magic/magic.scm

(define (digit->number d)
  (case d
    ((#\0) 0)
    ((#\1) 1)
    ((#\2) 2)
    ((#\3) 3)
    ((#\4) 4)
    ((#\5) 5)
    ((#\6) 6)
    ((#\7) 7)
    ((#\8) 8)
    ((#\9) 9)
    (else 44)))

(define (string->number s)
  (let ((l (string-length s)))
    (let loop ((n 0) (i 0))
      (if (= i l)
	  n
	  (let ((digit (string-ref s i)))
	    (loop (+ (* 10 n) (digit->number digit)) (+ i 1)))))))

(define (list->string chrs)
  (let ((l (length chrs)))
    (let ((s (make-string l #\?)))
      (let loop ((i 0) (chrs chrs))
	(if (null? chrs)
	    s
	    (begin
	      (string-set! s i (car chrs))
	      (loop (+ i 1) (cdr chrs))))))))



(define (make-collector) (vector '() #f))

(define (collect! c x)
  (let ((l (cons x '())))
    (cond ((vector-ref c 1)
           => (lambda (tail)
                (set-cdr! tail l)
                (vector-set! c 1 l)))
          (else (vector-set! c 0 l)
                (vector-set! c 1 l)))))

(define (find-tail l)
  (if (null? l)
      (error 'find-tail 'no-tail l)
      (if (null? (cdr l))
	  l
	  (find-tail (cdr l)))))

(define (collect-append! c l)
  ;; input list must be ours to mutate
  (if (null? l)
      #t
      (cond ((vector-ref c 1) =>
	     (lambda (tail)
	       (set-cdr! tail l)
	       (vector-set! c 1 (find-tail l))))
	    (else
	     (vector-set! c 0 l)
	     (vector-set! c 1 (find-tail l))))))

(define (collector-get c)
  (vector-ref c 0))





(define (make-token type metadata s)
  (cons type (cons s (cons metadata '()))))
(define (token? s) (and (pair? s) (eq? 'token (car s))))

(define token-type car)
(define token-metadata caddr)
(define token-data cadr)

(define (atomic-token? token)
  (member (token-type token)
	  '(symbol number boolean character string)))
(define (mark-token? token)
  (member (token-type token)
	  '(quote unquote quasiquote)))
(define (dot-token? token)
  (equal? (token-type token) 'dot))
(define (open-token? token)
  (equal? (token-type token) 'open))
(define (close-token? token)
  (equal? (token-type token) 'close))


;; token-builders that the generated code uses

(define (whitespace-token metadata tok)
  #f)

(define (symbol-token metadata tok)
  (make-token 'symbol metadata (string->symbol tok)))

(define (number-token metadata tok)
  (make-token 'number metadata (string->number tok)))

(define (boolean-token metadata tok)
  (cond
   ((equal? (string-ref tok 1) #\t) (make-token 'boolean metadata #t))
   ((equal? (string-ref tok 1) #\f) (make-token 'boolean metadata #f))
   (else (error "invalid boolean token" (make-token metadata tok)))))

(define (character-token metadata tok)
  (if (= 3 (string-length tok))
      (make-token 'character metadata (string-ref tok 2))
      (if (string=? tok "#\\newline")
	  (make-token 'character metadata #\newline)
	  (if (string=? tok "#\\space")
	      (make-token 'character metadata #\space)
	      (if (string=? tok "#\\tab")
		  (make-token 'character metadata #\tab)
		  (error 'character-token "weird" tok))))))

(define (string-token metadata tok)
  (make-token 'string metadata
	        (list->string (let ((l (string-length tok)))
				(let loop ((i 1))
				  (if (= i (- l 1))
				      '()
				      (let ((c (string-ref tok i)))
					(if (eq? c #\\)
					    (cons (string-ref tok (+ i 1)) (loop (+ i 2)))
					    (cons c (loop (+ i 1)))))))))))

(define (quote-mark-token metadata tok)
  (make-token 'quote metadata #f))

(define (unquote-mark-token metadata tok)
  (make-token 'unquote metadata #f))

(define (quasiquote-mark-token metadata tok)
  (make-token 'quasiquote metadata #f))

(define (dot-token metadata tok)
  (make-token 'dot metadata #f))

(define (open-token metadata tok)
  (make-token 'open metadata #f))

(define (close-token metadata tok)
  (make-token 'close metadata #f))


;; execute the state machine

;(include "t/boot/tokenizer.gen.scm")

(define (tell) 0)

(define (tokenize)
  (let ((collect (make-collector)))
    (let loop ((state start-state) (t '()))
      (cond ((eof-object? (peek-char))
	     (collector-get collect))
	    
	    ((step state (peek-char)) =>
	     (lambda (state)
	       (loop state (cons (read-char) t))))
	    
	    ((accepting? state) =>
	     (lambda (make-token)
	       (let ((tok (make-token (tell) (list->string (reverse t)))))
		 (when tok (collect! collect tok))
		 (loop start-state  '()))))
	    (else (error 'tokenize "no parsable token"))))))


(define start-state 0)
(define (accepting? state)
  (case state
    ((14) whitespace-token)
    ((15) symbol-token)
    ((12) close-token)
    ((13) open-token)
    ((10) quasiquote-mark-token)
    ((11) dot-token)
    ((8) unquote-mark-token)
    ((9) quote-mark-token)
    ((6) symbol-token)
    ((7) number-token)
    ((4) boolean-token)
    ((5) string-token)
    ((2) number-token)
    ((3) number-token)
    ((1) character-token)
    (else #f)))
(define (step state symbol)
  (case state
    ((2) (case symbol ((#\1) 2) ((#\0) 2) (else #f)))
    ((3)
     (case symbol
       ((#\F) 3)
       ((#\E) 3)
       ((#\D) 3)
       ((#\C) 3)
       ((#\B) 3)
       ((#\A) 3)
       ((#\9) 3)
       ((#\8) 3)
       ((#\7) 3)
       ((#\6) 3)
       ((#\5) 3)
       ((#\4) 3)
       ((#\3) 3)
       ((#\2) 3)
       ((#\1) 3)
       ((#\0) 3)
       (else #f)))
    ((1)
     (case symbol
       ((#\~) 1)
       ((#\}) 1)
       ((#\{) 1)
       ((#\_) 1)
       ((#\^) 1)
       ((#\]) 1)
       ((#\\) 1)
       ((#\[) 1)
       ((#\@) 1)
       ((#\?) 1)
       ((#\>) 1)
       ((#\=) 1)
       ((#\<) 1)
       ((#\:) 1)
       ((#\/) 1)
       ((#\-) 1)
       ((#\+) 1)
       ((#\*) 1)
       ((#\&) 1)
       ((#\%) 1)
       ((#\$) 1)
       ((#\!) 1)
       ((#\Z) 1)
       ((#\Y) 1)
       ((#\X) 1)
       ((#\W) 1)
       ((#\V) 1)
       ((#\U) 1)
       ((#\T) 1)
       ((#\S) 1)
       ((#\R) 1)
       ((#\Q) 1)
       ((#\P) 1)
       ((#\O) 1)
       ((#\N) 1)
       ((#\M) 1)
       ((#\L) 1)
       ((#\K) 1)
       ((#\J) 1)
       ((#\I) 1)
       ((#\H) 1)
       ((#\G) 1)
       ((#\F) 1)
       ((#\E) 1)
       ((#\D) 1)
       ((#\C) 1)
       ((#\B) 1)
       ((#\A) 1)
       ((#\z) 1)
       ((#\y) 1)
       ((#\x) 1)
       ((#\w) 1)
       ((#\v) 1)
       ((#\u) 1)
       ((#\t) 1)
       ((#\s) 1)
       ((#\r) 1)
       ((#\q) 1)
       ((#\p) 1)
       ((#\o) 1)
       ((#\n) 1)
       ((#\m) 1)
       ((#\l) 1)
       ((#\k) 1)
       ((#\j) 1)
       ((#\i) 1)
       ((#\h) 1)
       ((#\g) 1)
       ((#\f) 1)
       ((#\e) 1)
       ((#\d) 1)
       ((#\c) 1)
       ((#\b) 1)
       ((#\a) 1)
       ((#\9) 1)
       ((#\8) 1)
       ((#\7) 1)
       ((#\6) 1)
       ((#\5) 1)
       ((#\4) 1)
       ((#\3) 1)
       ((#\2) 1)
       ((#\1) 1)
       ((#\0) 1)
       (else #f)))
    ((16)
     (case symbol
       ((#\~) 1)
       ((#\}) 1)
       ((#\{) 1)
       ((#\|) 1)
       ((#\_) 1)
       ((#\^) 1)
       ((#\]) 1)
       ((#\\) 1)
       ((#\[) 1)
       ((#\@) 1)
       ((#\?) 1)
       ((#\>) 1)
       ((#\=) 1)
       ((#\<) 1)
       ((#\:) 1)
       ((#\/) 1)
       ((#\-) 1)
       ((#\+) 1)
       ((#\*) 1)
       ((#\&) 1)
       ((#\%) 1)
       ((#\$) 1)
       ((#\!) 1)
       ((#\)) 1)
       ((#\() 1)
       ((#\") 1)
       ((#\#) 1)
       ((#\`) 1)
       ((#\;) 1)
       ((#\.) 1)
       ((#\,) 1)
       ((#\') 1)
       ((#\Z) 1)
       ((#\Y) 1)
       ((#\X) 1)
       ((#\W) 1)
       ((#\V) 1)
       ((#\U) 1)
       ((#\T) 1)
       ((#\S) 1)
       ((#\R) 1)
       ((#\Q) 1)
       ((#\P) 1)
       ((#\O) 1)
       ((#\N) 1)
       ((#\M) 1)
       ((#\L) 1)
       ((#\K) 1)
       ((#\J) 1)
       ((#\I) 1)
       ((#\H) 1)
       ((#\G) 1)
       ((#\F) 1)
       ((#\E) 1)
       ((#\D) 1)
       ((#\C) 1)
       ((#\B) 1)
       ((#\A) 1)
       ((#\z) 1)
       ((#\y) 1)
       ((#\x) 1)
       ((#\w) 1)
       ((#\v) 1)
       ((#\u) 1)
       ((#\t) 1)
       ((#\s) 1)
       ((#\r) 1)
       ((#\q) 1)
       ((#\p) 1)
       ((#\o) 1)
       ((#\n) 1)
       ((#\m) 1)
       ((#\l) 1)
       ((#\k) 1)
       ((#\j) 1)
       ((#\i) 1)
       ((#\h) 1)
       ((#\g) 1)
       ((#\f) 1)
       ((#\e) 1)
       ((#\d) 1)
       ((#\c) 1)
       ((#\b) 1)
       ((#\a) 1)
       ((#\9) 1)
       ((#\8) 1)
       ((#\7) 1)
       ((#\6) 1)
       ((#\5) 1)
       ((#\4) 1)
       ((#\3) 1)
       ((#\2) 1)
       ((#\1) 1)
       ((#\0) 1)
       (else #f)))
    ((17)
     (case symbol
       ((#\F) 3)
       ((#\E) 3)
       ((#\D) 3)
       ((#\C) 3)
       ((#\B) 3)
       ((#\A) 3)
       ((#\9) 3)
       ((#\8) 3)
       ((#\7) 3)
       ((#\6) 3)
       ((#\5) 3)
       ((#\4) 3)
       ((#\3) 3)
       ((#\2) 3)
       ((#\1) 3)
       ((#\0) 3)
       (else #f)))
    ((4) (case symbol (else #f)))
    ((18) (case symbol ((#\1) 2) ((#\0) 2) (else #f)))
    ((19) (case symbol ((#\\) 20) ((#\") 20) (else #f)))
    ((5) (case symbol (else #f)))
    ((14)
     (case symbol
       ((#\newline) 14)
       ((#\tab) 14)
       ((#\space) 14)
       ((#\;) 22)
       (else #f)))
    ((15)
     (case symbol
       ((#\~) 6)
       ((#\}) 6)
       ((#\{) 6)
       ((#\_) 6)
       ((#\^) 6)
       ((#\]) 6)
       ((#\\) 6)
       ((#\[) 6)
       ((#\@) 6)
       ((#\?) 6)
       ((#\>) 6)
       ((#\=) 6)
       ((#\<) 6)
       ((#\:) 6)
       ((#\/) 6)
       ((#\-) 6)
       ((#\+) 6)
       ((#\*) 6)
       ((#\&) 6)
       ((#\%) 6)
       ((#\$) 6)
       ((#\!) 6)
       ((#\Z) 6)
       ((#\Y) 6)
       ((#\X) 6)
       ((#\W) 6)
       ((#\V) 6)
       ((#\U) 6)
       ((#\T) 6)
       ((#\S) 6)
       ((#\R) 6)
       ((#\Q) 6)
       ((#\P) 6)
       ((#\O) 6)
       ((#\N) 6)
       ((#\M) 6)
       ((#\L) 6)
       ((#\K) 6)
       ((#\J) 6)
       ((#\I) 6)
       ((#\H) 6)
       ((#\G) 6)
       ((#\F) 6)
       ((#\E) 6)
       ((#\D) 6)
       ((#\C) 6)
       ((#\B) 6)
       ((#\A) 6)
       ((#\z) 6)
       ((#\y) 6)
       ((#\x) 6)
       ((#\w) 6)
       ((#\v) 6)
       ((#\u) 6)
       ((#\t) 6)
       ((#\s) 6)
       ((#\r) 6)
       ((#\q) 6)
       ((#\p) 6)
       ((#\o) 6)
       ((#\n) 6)
       ((#\m) 6)
       ((#\l) 6)
       ((#\k) 6)
       ((#\j) 6)
       ((#\i) 6)
       ((#\h) 6)
       ((#\g) 6)
       ((#\f) 6)
       ((#\e) 6)
       ((#\d) 6)
       ((#\c) 6)
       ((#\b) 6)
       ((#\a) 6)
       ((#\9) 7)
       ((#\8) 7)
       ((#\7) 7)
       ((#\6) 7)
       ((#\5) 7)
       ((#\4) 7)
       ((#\3) 7)
       ((#\2) 7)
       ((#\1) 7)
       ((#\0) 7)
       (else #f)))
    ((12) (case symbol (else #f)))
    ((13) (case symbol (else #f)))
    ((20)
     (case symbol
       ((#\newline) 20)
       ((#\tab) 20)
       ((#\space) 20)
       ((#\~) 20)
       ((#\}) 20)
       ((#\{) 20)
       ((#\_) 20)
       ((#\^) 20)
       ((#\]) 20)
       ((#\\) 19)
       ((#\[) 20)
       ((#\@) 20)
       ((#\?) 20)
       ((#\>) 20)
       ((#\=) 20)
       ((#\<) 20)
       ((#\:) 20)
       ((#\/) 20)
       ((#\-) 20)
       ((#\+) 20)
       ((#\*) 20)
       ((#\&) 20)
       ((#\%) 20)
       ((#\$) 20)
       ((#\!) 20)
       ((#\)) 20)
       ((#\() 20)
       ((#\") 5)
       ((#\#) 20)
       ((#\`) 20)
       ((#\;) 20)
       ((#\.) 20)
       ((#\,) 20)
       ((#\') 20)
       ((#\Z) 20)
       ((#\Y) 20)
       ((#\X) 20)
       ((#\W) 20)
       ((#\V) 20)
       ((#\U) 20)
       ((#\T) 20)
       ((#\S) 20)
       ((#\R) 20)
       ((#\Q) 20)
       ((#\P) 20)
       ((#\O) 20)
       ((#\N) 20)
       ((#\M) 20)
       ((#\L) 20)
       ((#\K) 20)
       ((#\J) 20)
       ((#\I) 20)
       ((#\H) 20)
       ((#\G) 20)
       ((#\F) 20)
       ((#\E) 20)
       ((#\D) 20)
       ((#\C) 20)
       ((#\B) 20)
       ((#\A) 20)
       ((#\z) 20)
       ((#\y) 20)
       ((#\x) 20)
       ((#\w) 20)
       ((#\v) 20)
       ((#\u) 20)
       ((#\t) 20)
       ((#\s) 20)
       ((#\r) 20)
       ((#\q) 20)
       ((#\p) 20)
       ((#\o) 20)
       ((#\n) 20)
       ((#\m) 20)
       ((#\l) 20)
       ((#\k) 20)
       ((#\j) 20)
       ((#\i) 20)
       ((#\h) 20)
       ((#\g) 20)
       ((#\f) 20)
       ((#\e) 20)
       ((#\d) 20)
       ((#\c) 20)
       ((#\b) 20)
       ((#\a) 20)
       ((#\9) 20)
       ((#\8) 20)
       ((#\7) 20)
       ((#\6) 20)
       ((#\5) 20)
       ((#\4) 20)
       ((#\3) 20)
       ((#\2) 20)
       ((#\1) 20)
       ((#\0) 20)
       (else #f)))
    ((21)
     (case symbol
       ((#\\) 16)
       ((#\x) 17)
       ((#\t) 4)
       ((#\f) 4)
       ((#\b) 18)
       (else #f)))
    ((10) (case symbol (else #f)))
    ((22)
     (case symbol
       ((#\newline) 14)
       ((#\tab) 22)
       ((#\space) 22)
       ((#\|) 22)
       ((#\~) 22)
       ((#\}) 22)
       ((#\{) 22)
       ((#\_) 22)
       ((#\^) 22)
       ((#\]) 22)
       ((#\\) 22)
       ((#\[) 22)
       ((#\@) 22)
       ((#\?) 22)
       ((#\>) 22)
       ((#\=) 22)
       ((#\<) 22)
       ((#\:) 22)
       ((#\/) 22)
       ((#\-) 22)
       ((#\+) 22)
       ((#\*) 22)
       ((#\&) 22)
       ((#\%) 22)
       ((#\$) 22)
       ((#\!) 22)
       ((#\)) 22)
       ((#\() 22)
       ((#\") 22)
       ((#\#) 22)
       ((#\`) 22)
       ((#\;) 22)
       ((#\.) 22)
       ((#\,) 22)
       ((#\') 22)
       ((#\Z) 22)
       ((#\Y) 22)
       ((#\X) 22)
       ((#\W) 22)
       ((#\V) 22)
       ((#\U) 22)
       ((#\T) 22)
       ((#\S) 22)
       ((#\R) 22)
       ((#\Q) 22)
       ((#\P) 22)
       ((#\O) 22)
       ((#\N) 22)
       ((#\M) 22)
       ((#\L) 22)
       ((#\K) 22)
       ((#\J) 22)
       ((#\I) 22)
       ((#\H) 22)
       ((#\G) 22)
       ((#\F) 22)
       ((#\E) 22)
       ((#\D) 22)
       ((#\C) 22)
       ((#\B) 22)
       ((#\A) 22)
       ((#\z) 22)
       ((#\y) 22)
       ((#\x) 22)
       ((#\w) 22)
       ((#\v) 22)
       ((#\u) 22)
       ((#\t) 22)
       ((#\s) 22)
       ((#\r) 22)
       ((#\q) 22)
       ((#\p) 22)
       ((#\o) 22)
       ((#\n) 22)
       ((#\m) 22)
       ((#\l) 22)
       ((#\k) 22)
       ((#\j) 22)
       ((#\i) 22)
       ((#\h) 22)
       ((#\g) 22)
       ((#\f) 22)
       ((#\e) 22)
       ((#\d) 22)
       ((#\c) 22)
       ((#\b) 22)
       ((#\a) 22)
       ((#\9) 22)
       ((#\8) 22)
       ((#\7) 22)
       ((#\6) 22)
       ((#\5) 22)
       ((#\4) 22)
       ((#\3) 22)
       ((#\2) 22)
       ((#\1) 22)
       ((#\0) 22)
       (else #f)))
    ((11) (case symbol (else #f)))
    ((8) (case symbol (else #f)))
    ((9) (case symbol (else #f)))
    ((6)
     (case symbol
       ((#\~) 6)
       ((#\}) 6)
       ((#\{) 6)
       ((#\_) 6)
       ((#\^) 6)
       ((#\]) 6)
       ((#\\) 6)
       ((#\[) 6)
       ((#\@) 6)
       ((#\?) 6)
       ((#\>) 6)
       ((#\=) 6)
       ((#\<) 6)
       ((#\:) 6)
       ((#\/) 6)
       ((#\-) 6)
       ((#\+) 6)
       ((#\*) 6)
       ((#\&) 6)
       ((#\%) 6)
       ((#\$) 6)
       ((#\!) 6)
       ((#\Z) 6)
       ((#\Y) 6)
       ((#\X) 6)
       ((#\W) 6)
       ((#\V) 6)
       ((#\U) 6)
       ((#\T) 6)
       ((#\S) 6)
       ((#\R) 6)
       ((#\Q) 6)
       ((#\P) 6)
       ((#\O) 6)
       ((#\N) 6)
       ((#\M) 6)
       ((#\L) 6)
       ((#\K) 6)
       ((#\J) 6)
       ((#\I) 6)
       ((#\H) 6)
       ((#\G) 6)
       ((#\F) 6)
       ((#\E) 6)
       ((#\D) 6)
       ((#\C) 6)
       ((#\B) 6)
       ((#\A) 6)
       ((#\z) 6)
       ((#\y) 6)
       ((#\x) 6)
       ((#\w) 6)
       ((#\v) 6)
       ((#\u) 6)
       ((#\t) 6)
       ((#\s) 6)
       ((#\r) 6)
       ((#\q) 6)
       ((#\p) 6)
       ((#\o) 6)
       ((#\n) 6)
       ((#\m) 6)
       ((#\l) 6)
       ((#\k) 6)
       ((#\j) 6)
       ((#\i) 6)
       ((#\h) 6)
       ((#\g) 6)
       ((#\f) 6)
       ((#\e) 6)
       ((#\d) 6)
       ((#\c) 6)
       ((#\b) 6)
       ((#\a) 6)
       ((#\9) 6)
       ((#\8) 6)
       ((#\7) 6)
       ((#\6) 6)
       ((#\5) 6)
       ((#\4) 6)
       ((#\3) 6)
       ((#\2) 6)
       ((#\1) 6)
       ((#\0) 6)
       (else #f)))
    ((7)
     (case symbol
       ((#\9) 7)
       ((#\8) 7)
       ((#\7) 7)
       ((#\6) 7)
       ((#\5) 7)
       ((#\4) 7)
       ((#\3) 7)
       ((#\2) 7)
       ((#\1) 7)
       ((#\0) 7)
       (else #f)))
    ((0)
     (case symbol
       ((#\newline) 14)
       ((#\tab) 14)
       ((#\space) 14)
       ((#\~) 6)
       ((#\}) 6)
       ((#\{) 6)
       ((#\_) 6)
       ((#\^) 6)
       ((#\]) 6)
       ((#\\) 6)
       ((#\[) 6)
       ((#\@) 6)
       ((#\?) 6)
       ((#\>) 6)
       ((#\=) 6)
       ((#\<) 6)
       ((#\:) 6)
       ((#\/) 6)
       ((#\-) 15)
       ((#\+) 6)
       ((#\*) 6)
       ((#\&) 6)
       ((#\%) 6)
       ((#\$) 6)
       ((#\!) 6)
       ((#\)) 12)
       ((#\() 13)
       ((#\") 20)
       ((#\#) 21)
       ((#\`) 10)
       ((#\;) 22)
       ((#\.) 11)
       ((#\,) 8)
       ((#\') 9)
       ((#\Z) 6)
       ((#\Y) 6)
       ((#\X) 6)
       ((#\W) 6)
       ((#\V) 6)
       ((#\U) 6)
       ((#\T) 6)
       ((#\S) 6)
       ((#\R) 6)
       ((#\Q) 6)
       ((#\P) 6)
       ((#\O) 6)
       ((#\N) 6)
       ((#\M) 6)
       ((#\L) 6)
       ((#\K) 6)
       ((#\J) 6)
       ((#\I) 6)
       ((#\H) 6)
       ((#\G) 6)
       ((#\F) 6)
       ((#\E) 6)
       ((#\D) 6)
       ((#\C) 6)
       ((#\B) 6)
       ((#\A) 6)
       ((#\z) 6)
       ((#\y) 6)
       ((#\x) 6)
       ((#\w) 6)
       ((#\v) 6)
       ((#\u) 6)
       ((#\t) 6)
       ((#\s) 6)
       ((#\r) 6)
       ((#\q) 6)
       ((#\p) 6)
       ((#\o) 6)
       ((#\n) 6)
       ((#\m) 6)
       ((#\l) 6)
       ((#\k) 6)
       ((#\j) 6)
       ((#\i) 6)
       ((#\h) 6)
       ((#\g) 6)
       ((#\f) 6)
       ((#\e) 6)
       ((#\d) 6)
       ((#\c) 6)
       ((#\b) 6)
       ((#\a) 6)
       ((#\9) 7)
       ((#\8) 7)
       ((#\7) 7)
       ((#\6) 7)
       ((#\5) 7)
       ((#\4) 7)
       ((#\3) 7)
       ((#\2) 7)
       ((#\1) 7)
       ((#\0) 7)
       (else #f)))))



(define parser:strip #t)

(define (strip-token t)
  (if (mark-token? t)
      (strip-token (make-token 'symbol
			       (token-metadata t)
			       (token-type t)))
      (if parser:strip
	  (if (atomic-token? t)
	      (token-data t)
	      (token-type t))
	  t)))

(define (read-s* ts)
  (let loop ((co (make-collector)) (ts ts))
    (if (null? ts)
	(collector-get co)
	(read-s ts
		(lambda (s ts)
		  (collect! co s)
		  (loop co ts))))))

(define (read-s ts k)
  (if (null? ts)
      (error 'read-s "read-s")
      (let ((t (car ts)) (ts (cdr ts)))
	(cond ((atomic-token? t)
	       (k (strip-token t) ts))
	      ((mark-token? t)
	       (read-s ts
		       (lambda (s ts)
			 (k (cons (strip-token t) (cons s '())) ts))))
	      ((open-token? t)
	       (read-s+/close ts k))
	      ((close-token? t)
	       (error 'read-s "too many closed brackets" t))
	      (else
	       (error 'read-s "unknown token" t))))))

(define (read-s+/close ts k)
  (if (null? ts)
      (error 'read-s+/close "read-s+/close")
      (let ((t (car ts)) (ts (cdr ts)))
	(cond ((close-token? t)
	       (k '() ts))
	      (else
	       (read-s (cons t ts)
		       (lambda (s ts)
			 (let ((co (make-collector)))
			   (collect! co s)
			   (read-s+ co ts k)))))))))

(define (read-s+ co ts k)
  (if (null? ts)
      (error 'read-s+ "read-s+")
      (let ((t (car ts)) (ts (cdr ts)))
	(cond ((close-token? t)
	       (k (collector-get co) ts))
	      ((dot-token? t)
	       (read-s ts
		       (lambda (s ts)
			 (unless (close-token? (car ts))
			   (error 'read-s+ "only one form after a dot token"))
			 (k (append (collector-get co) s) (cdr ts)))))
	      (else
	       (read-s (cons t ts)
		       (lambda (s ts)
			 (collect! co s)
			 (read-s+ co ts k))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (box val) (make-vector 1 val))
(define (unbox b) (vector-ref b 0))
(define (set-box! b v) (vector-set! b 0 v))

(define put-hash-table! hash-table-set!)
(define (get-hash-table h k) (hash-table-ref h k #f))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; match macro


(define (moo-match e)
  (let ((exp (cadr e))
	(clauses (cddr e))
	(tmp (gensym "tmp")))
    `(let ((,tmp ,exp))
       ,(moo-match-aux tmp clauses))))

(define (quote? p)
  (and (pair? p) (eq? (car p) 'quote)))

; takes: expression to match on, pattern, body, place, failure continuation
; returns: code that returns #t if pattern matches and #f if not, and an assoc list of
; bindings
(define (subpattern-match s p)
  (begin ;(print `("in subpatterN" ,s ,p))
  (cond
   ((null? p)
    (cons `((null? ,s))
	  '()))
   ((number? p)
    (cons `((number? ,s) (= ,s ,p))
	  '()))
   ((symbol? p)
    (cons `(#t)
	  `((,p ,s))))
   ((quote? p)
    (cons `((equal? ',(cadr p) ,s))
	  '()))
   ((pair? p)
    (let ((l (subpattern-match `(car ,s) (car p)))
	  (r (subpattern-match `(cdr ,s) (cdr p))))
      (cons (cons `(pair? ,s) (append (car l) (car r)))
	    (append (cdr l) (cdr r)))))
   (else
    (begin
      (print "undefined subpattern")
      (print p))))))

(define (try t pat body fk)
  (let ((m (subpattern-match t pat)))
    `(if (and . ,(car m))
	 ,(if (not (null? (cdr m)))
	      `(let ,(cdr m)
		 ,body)
	      body)
	 (,fk))))
  
(define (moo-match-aux t clauses)
  (if (null? clauses)
      `(error 'match "match fail")
      (let ((pat (caar clauses))
	    (body `(begin . ,(cdar clauses)))
	    (fk (gensym "fk")))
	`(let ((,fk (lambda ()
		      ,(moo-match-aux t (cdr clauses)))))
	   ,(try t pat body fk)))))


(defmacro match moo-match)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; scan

(define (pass-scan tbl)
  (transform-assoc tbl (globals toplevel)
    (let ((c (make-collector)))
      (letrec ((process
		(lambda (top)
		  ;(print `(processing ,top))
		  (match top
		    (('define (nm . args) . body)
		     (process `(define ,nm (lambda ,args . ,body))))
		    (('define nm body)
		     (let ((idx (- (extend! globals nm) 1)))
		       (collect! c `(define ,nm ,idx ,body))))
		    (('define nm . body)
		     (let ((idx (- (extend! globals nm) 1)))
		       (collect! c `(define ,nm ,idx (begin ,body)))))
		    (('defmacro nm body)
		     (let ((gen (gensym nm))
			   (idx (- (extend! globals nm) 1)))
		       (collect! c `(defmacro ,nm ,gen ,idx ,body))))
		    ;(('include filename)
		    ; (for-each process (read-file filename)))
		    (else
		     (collect! c top))))))
	(for-each process toplevel))
      `((globals . ,globals)
	(toplevel . ,(collector-get c))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; hoist

(define (quote-builder exp)
  (cond ((or (symbol? exp) (null? exp) (datum? exp))
	 `(datum ,exp))
	((pair? exp)
	 `(builtin cons ,(quote-builder (car exp)) ,(quote-builder (cdr exp))))))

(define (mk-var sort)
  (lambda (i)
    `(var ,sort ,i)))

(define hoist-code (box #f))

(define (label! obj)
  (let ((lbl (gensym 'clo)))
    (collect! (unbox hoist-code) `(code ,lbl ,obj))
    lbl))

(define dbg:form (box #f))

(define (my-extend! b x)
  ;(print `(extend! ,b ,x))
  (let ((res (extend! b x)))
    ;(print `(done-extending ,b ,res))
    res))

(define (hoist-var var scope)
  (match-assoc scope (tmp loc env glo caps)
    (cond ((reverse-index var tmp) => (mk-var 'tmp))
	  ((index var loc) => (mk-var 'loc))
	  ((member var env)
	   (cond ((index var (unbox caps)) => (mk-var 'env))
		 (else ((mk-var 'env) (- (my-extend! caps var) 1)))))
	  ((index var glo) => (mk-var 'glo))
	  (else
	   (print `(while processing ,(unbox dbg:form)))
	   (print `(unbound ,var in scope ,scope))
	   (error 'hoist-variable "unbound variable?" var)))))

(define (hoist exp scope)
  (cond ((datum? exp) `(datum ,exp))

	((quote? exp) (quote-builder (cadr exp)))

	((variable? exp) (hoist-var exp scope))

	((if? exp)
	 (let ((t (cadr exp))
	       (c (caddr exp))
	       (a (cadddr exp)))
	   `(if ,(hoist t scope)
		,(hoist c scope)
		,(hoist a scope))))

	((begin? exp)
	 (let ((sts (cdr exp)))
	   `(begin . ,(mapply hoist sts scope))))

	((lambda? exp)
	 (let ((bind (cadr exp))
	       (body (cddr exp)))
	   (match-assoc scope (tmp loc env glo caps)
	     (let ((caps^ (box '())))
	       (let ((body^ (hoist `(begin . ,body)
				   `((tmp . ())
				     (loc . ,bind)
				     (env . ,(append tmp (append loc env)))
				     (glo . ,glo)
				     (caps . ,caps^)))))
		 (let ((label (label! body^)))
		   `(closure ,label ,(mapply hoist (unbox caps^) scope))))))))

	((let? exp)
	 (match-assoc scope (tmp loc env glo caps)
	   (let ((tmp^ (box (copy-list tmp))))
	     (let ((bindings (map* (lambda (entry)
				     (let ((exp (hoist (cadr entry) scope))
					   (var (- (my-extend! tmp^ (car entry)) 1)))
				       (list var exp)))
				   (cadr exp))))
	       `(let ,bindings ,(hoist (caddr exp)
				       `((tmp . ,(unbox tmp^))
					 (loc . ,loc)
					 (env . ,env)
					 (glo . ,glo)
					 (caps . ,caps))))))))

	((letrec? exp)
	 (match-assoc scope (tmp loc env glo caps)
	   (let ((tmp^ (box (copy-list tmp))))
	     (for-each (lambda (entry)
			 (my-extend! tmp^ (car entry)))
		       (cadr exp))
	     (let ((scope^ `((tmp . ,(unbox tmp^))
			     (loc . ,loc)
			     (env . ,env)
			     (glo . ,glo)
			     (caps . ,caps))))
	       (let ((bindings (map* (lambda (entry)
				       (let ((exp (hoist (cadr entry) scope^))
					     (var (index (car entry) (unbox tmp^))))
					 (list var exp)))
				     (cadr exp))))
		 `(letrec ,bindings ,(hoist (caddr exp) scope^)))))))

	((builtin-app? exp)
	 `(builtin ,(cadr exp) . ,(mapply hoist (cddr exp) scope)))

	((app? exp)
	 `(app . ,(mapply hoist exp scope)))

	(else
	 (error 'hoist "unknown exp" exp))))

(define (hoist^ exp glo)
  (set-box! dbg:form exp)
  (hoist exp `((tmp . ())
	       (loc . ())
	       (env . ())
	       (glo . ,glo)
	       (caps . ,(box '())))))

(define (pass-hoist tbl)
  (set-box! hoist-code (make-collector))
  (transform-assoc tbl (globals toplevel)
    ;(set! code (make-collector))
    (let ((toplevel (map* (lambda (top)
			    (match top
			      (('define nm id exp)
			       `(define ,nm ,id ,(hoist^ exp (unbox globals))))
			      (else
			       (hoist^ top (unbox globals)))))
			  toplevel)))
      `((globals . ,globals)
	(toplevel . ,toplevel)
	(closures . ,(collector-get (unbox hoist-code)))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; denest


(define (let-form? p)
  (and (pair? p) (eq? (car p) 'let-form)))
(define (make-let-form bindings body)
  (list 'let-form bindings body))
(define let-form-bindings cadr)
(define let-form-body caddr)

;; LET OBJECTS
;;
(define (let-form->let l)
  (if (let-form? l)
      `(let ,(sequence->list (let-form-bindings l)) ,(let-form-body l))
      l))

(define (let-bindings exp)
  (match exp
    (('let-form bindings body) bindings)
    ;(`(let ,bindings ,body) `(cat ,bindings))
    (else 'nil)
    ))

(define (let-body exp)
  (match exp
    (('let-form bindings body) body)
    ;(`(let ,bindings ,body) body)
    (else exp)))


;; TMPALLOC
;;

(define (temporary! name b)
  (cond ((index name (unbox b)) => (lambda (i) i))
	(else (- (extend! b name) 1))))

(define (process-bindings bindings b)
  (map* (lambda (binding)
	  (match binding
	    ((tmp exp)
	     (let ((i (temporary! tmp b)))
	       `(,i ,(process-body exp b))))
	    (else (error 'process-bindings ""))))
	bindings))

(define (process-body body b)
  (match body
    (('datum d) body)

    (('var 'tmp nm)
     (let ((i (index nm (unbox b))))
       (unless i (error 'process-body "index error" nm))
       `(var tmp ,i)))

    (('var sort nm) body)

    (('closure lbl size)
     body)

    (('set-closure! clo-tmp i val)
     `(set-closure! ,(process-body clo-tmp b) ,i ,(process-body val b)))

    (('if t c a)
     (let ((t^ (process-body t b))
	   (c^ (tmpalloc^ c b))
	   (a^ (tmpalloc^ a b)))
       `(if ,t^ ,c^ ,a^)))

    (('builtin nm . args)
     `(builtin ,nm . ,(mapply process-body args b)))

    (('app . args)
     `(app . ,(mapply process-body args b)))

    (else
     (error 'process-body "Unhandled expression:" body))))

(define (tmpalloc^ l b)
  (match l
    (('let bindings body)
     (let ((bindings^ (process-bindings bindings b))
	   (body^ (process-body body b)))
       `(let ,(length (unbox b)) ,bindings^ ,body^)))
    (else
     (let ((body (process-body l b)))
       `(let ,(length (unbox b)) () ,body)))))

(define (tmpalloc l)
  (let ((b (box '())))
    (tmpalloc^ l b)))


;; DENEST PASS
;;

(define (denest-binding binding)
  (let ((nm (car binding))
	(exp (cadr binding)))
    (let ((l (denest-aux exp #f)))
      `(join ,(let-bindings l) (elt ,(list nm (let-body l)))))))

(define (denest-letrec-binding binding b)
  (match (cadr binding)
    (('closure lbl env)
     (if (null? env)
	 (denest-binding binding)
	 (let ((tmp (car binding))
	       (i (box 0)))
	   (map* (lambda (elt)
		   (extend! b `(elt (#f (set-closure! (var tmp ,tmp) ,(unbox i) ,elt))))
		   (set-box! i (+ (unbox i) 1)))
		 env)
	   `(elt ,(list tmp `(closure ,lbl ,(length env)))))))
    (else (denest-binding binding))))

(define (denest-aux^ exp)
  (match exp
    (('datum d) exp)

    (('var sort i) exp)

    (('app . args)
     (let ((args^ (mapply denest-aux args #t)))
       (let ((bindings (map let-bindings args^))
	     (bodies (map let-body args^)))
       (make-let-form `(cat ,bindings) `(app . ,bodies)))))

    (('builtin nm . args)
     (let ((args^ (mapply denest-aux args #t)))
       (let ((bindings (map let-bindings args^))
	     (bodies (map let-body args^)))
	 (make-let-form `(cat ,bindings) `(builtin ,nm . ,bodies)))))

    (('closure lbl env)
     (if (null? env)
	 `(closure ,lbl 0)
	 (let ((tmp (gensym "tmp")))
	   (make-let-form 
	    `(join
	      (elt ,(list tmp `(closure ,lbl ,(length env))))
	      (cat ,(let ((i (box 0)))
		      (map* (lambda (elt)
			      (let ((res `(set-closure! (var tmp ,tmp) ,(unbox i) ,elt)))
				(set-box! i (+ (unbox i) 1))
				`(elt ,(list #f res))))
			    env))))
	    `(var tmp ,tmp)))))

    (('if t c a)
     (let ((l (denest-aux t #f)))
       (make-let-form (let-bindings l)
		      `(if ,(let-body l)
			   ,(denest c)
			   ,(denest a)))))

    (('let bindings body)
     (let ((l (denest-aux body #f)))
       (make-let-form `(join (cat ,(map* denest-binding bindings))
			     ,(let-bindings l))
		      (let-body l))))

    (('letrec bindings body)
     (let ((b (box '()))
	   (l (denest-aux body #f)))
       (let ((creation (mapply denest-letrec-binding bindings b))
	     (setup (unbox b)))
	 (make-let-form `(join (cat ,creation)
			       (join (cat ,setup)
				     ,(let-bindings l)))
			(let-body l)))))

    (('begin . stmts)
     (let loop ((stmts stmts) (bindings 'nil))
       (cond ((null? stmts)
	      (error 'denest-aux^ "empty begin"))
	     (else
	      (let ((l (denest-aux (car stmts) #f)))
		(let ((binds (let-bindings l))
		      (body (let-body l)))
		  (if (null? (cdr stmts))
		      (make-let-form `(join ,bindings ,binds)
				     body)
		      (loop (cdr stmts)
			    `(join ,bindings (join ,binds (elt (#f ,body))))))))))))))

(define (simple? exp)
  (match exp
    (('datum v) #t)
    (('var sort nm) #t)
    (else #f)))

(define (denest-aux exp simple)
  ;; simple = #t   let bodies must be variables
  ;; simple = #f   allow complex let bodies
  ;;
  (let ((l (denest-aux^ exp)))
    (if (and simple (not (simple? (let-body l))))
	(let ((t (gensym "tmp")))
	  (make-let-form `(join ,(let-bindings l) (elt ,(list t (let-body l))))
			 `(var tmp ,t)))
	l)))

(define (denest exp)
  (let-form->let (denest-aux exp #f)))

(define (pass-denest tbl)
  (transform-assoc tbl (toplevel closures)
    `((toplevel . ,(map* (lambda (t)
			   (match t
			     (('define nm id body)
			      `(define ,nm ,id ,(tmpalloc (denest body))))
			     (else
			      (tmpalloc (denest t)))
			     (else (error 'pass-denest "" t))))
			 toplevel))
      (closures . ,(map* (lambda (st)
			   (match st
			     (('code lbl body)
			      `(code ,lbl ,(tmpalloc (denest body))))
			     (else (error 'pass-denest "" st))))
			closures)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; instructions

(define emitter (box #f))

(define (emit! elt) (collect! (unbox emitter) elt))

(define (instructions^ exp place tail?)
  (match exp
    (('datum d)
     (emit! `(move ,place ,exp)))

    (('var sort nm)
     (emit! `(move ,place ,exp)))

    (('app . args)
     (cond ((equal? place '(reg return))
	    (if tail?
                (emit! `(tail-call . ,args))
                (emit! `(call . ,args))))
	   (else (emit! `(call . ,args))
		 (emit! `(move ,place (reg return))))))

    (('builtin nm . args)
     (emit! `(builtin ,place ,nm . ,args)))

    (('closure lbl size)
     (emit! `(make-closure ,place ,lbl ,size)))

    (('set-closure! clo i elt)
     (emit! `(set-closure! ,clo ,i ,elt)))

    (('if t c a)
     (let ((lbl-tru (gensym 'if-tru))
	   (lbl-end (gensym 'if-end)))
       (instructions^ t '(reg return) #f)
       (emit! `(branch ,lbl-tru))
       (instructions a place #f tail?)
       (emit! `(jump ,lbl-end))
       (emit! lbl-tru)
       (instructions c place #f tail?)
       (emit! lbl-end)))

    (('begin . stmts)
     (let loop ((stmts stmts))
       (if (null? (cdr stmts))
	   (instructions^ (car stmts) place tail?)
	   (begin
	     (instructions^ (car stmts) #f #f)
	     (loop (cdr stmts))))))

    (else (error 'instructions "" exp))))

(define (instructions exp place entry? tail?)
  (match exp
    (('let tmps bindings body)
     (when entry?
       (emit! `(alloc-tmps ,tmps)))
     (for-each binding-instructions bindings)
     (instructions^ body place tail?))
    (else (instructions^ exp place tail?))))

(define (binding-instructions binding)
  (let ((place (car binding))
	(exp (cadr binding)))
    (instructions^ exp `(var tmp ,place) #t)))

(define (pass-instructions tbl)
  (match-assoc tbl (toplevel closures)
    (let ((start (gensym 'start)))
      (set-box! emitter (make-collector))
      (for-each (lambda (t)
		  (match t
		    (('define nm id body)
		     (instructions body `(var glo ,id) #t #f))
		    (else
		     (instructions t '(reg return) #t #f))
		    (else (error 'pass-instructions "" t))))
		toplevel)
      (emit! `(halt))
      (for-each (lambda (st)
		  (match st
		    (('code lbl body)
		     (emit! lbl)
		     (instructions body '(reg return) #t #t)
		     (emit! '(return)))
		    (else (error 'pass-denest "" st))))
	        closures)
      `(,start . ,(collector-get (unbox emitter))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; execute!

;; INSTRUCTION CODE ::=
;;   <label>
;;   (halt)
;;   (builtin <bltn-name> <args>*)
;;   (move <place> <var>)
;;   (alloc-tmps <num>)
;;   (make-closure <place> <lbl> <size>)
;;   (set-closure! <var> <index> <arg>)
;;   (call <clo> <args>*)
;;   (tail-call <clo> <args>*)
;;   (return)
;;   (branch <lbl>)
;;   (jump <lbl>)

(define bytecode (box (make-vector 100000 #f)))
(define bytecode-size (box 1))
(define index-table (make-hash-table))

(define execute:globals (make-vector 2000 #f))

(define (append-bytecode! insts)
  (vector-set! (unbox bytecode) 0 `(halt))
  (vector-overlay! (unbox bytecode) (unbox bytecode-size) insts)
  (let ((i (box (unbox bytecode-size))))
    (vector-for-each
     (lambda (elt)
       (when (symbol? elt)
	     (put-hash-table! index-table elt (unbox i)))
       (set-box! i (+ (unbox i) 1)))
     insts))
  (set-box! bytecode-size (+ (unbox bytecode-size) (vector-length insts))))

(defmacro magic-assoc
  (lambda (exp)
    `(list . ,(map (lambda (nm)
		     `(cons ',nm ,nm))
		   (cdr exp)))))

(define string->list #f)
;(define symbol->string #f)

(define builtins (magic-assoc
  exit
  gensym
  display newline print
  eq? equal?
  cons car cdr set-car! set-cdr!
  null? pair?
  number? boolean? string? char? symbol?
  + - * = < > <= >=
  quotient modulo
  list

  box
  unbox
  set-box!

  
  vector-ref
  vector-set!
  make-vector
  vector-length

  ;string->list
  ;symbol->string
  ;list->string

  make-string
  string-set!
  string-ref
  string->symbol
  string-length
  string=?

  eof-object?
  read-char
  peek-char

  vector?
  symbol->string
  char->integer
  ))



(define ip (box #f))
(define (inc! b)
  (set-box! b (+ 1 (unbox b))))

(define return-register (box #f))
(define stack (box '()))

(define (push! b e)
  (set-box! b (cons e (unbox b))))

(define (pop! b)
  (let ((s (unbox b)))
    (set-box! b (cdr s))
    (car s)))

(define (make-stack-frame tmp loc env return-address) (vector tmp loc env return-address))
(define (stack-frame-tmp s) (vector-ref s 0))
(define (stack-frame-loc s) (vector-ref s 1))
(define (stack-frame-env s) (vector-ref s 2))
(define (stack-frame-return-address s) (vector-ref s 3))
(define (set-stack-frame-tmp! s v)
  (vector-set! s 0 v))
(define (make-closure lbl env) (vector 'closure lbl env))
(define (closure-label clo) (vector-ref clo 1))
(define (closure-env clo) (vector-ref clo 2))

(define (evaluate place)
  (case (car place)
    ((datum) (cadr place))
    ((reg)
     (case (cadr place)
       ((return) (unbox return-register))
       (else (error 'evaluate "reg" place))))
    ((var)
     (case (cadr place)
       ((glo) (vector-ref execute:globals (caddr place)))
       ((tmp) (vector-ref (stack-frame-tmp (car (unbox stack))) (caddr place)))
       ((loc) (vector-ref (stack-frame-loc (car (unbox stack))) (caddr place)))
       ((env) (vector-ref (stack-frame-env (car (unbox stack))) (caddr place)))
       (else (error 'evaluate "var" place))))
    (else
     (error 'evaluate "" place))))

(define (move! place value)
  (case (car place)
    ((reg)
     (case (cadr place)
       ((return) (set-box! return-register value))
       (else (error 'move! "reg" place))))
    ((var)
     (case (cadr place)
       ((glo) (vector-set! execute:globals (caddr place) value))
       ((tmp) (vector-set! (stack-frame-tmp (car (unbox stack))) (caddr place) value))
       ((loc) (vector-set! (stack-frame-loc (car (unbox stack))) (caddr place) value))
       ((env) (vector-set! (stack-frame-env (car (unbox stack))) (caddr place) value))
       (else (error 'move! "var" place))))
    (else
     (error 'move! "" place))))

(define (go)
  (let ((inst (vector-ref (unbox bytecode) (unbox ip))))
    ;(print inst)
    (inc! ip)
    (if (symbol? inst)
	(go)
	(case (car inst)
	  ;; HALT
	  ((halt)
	   #t)

	  ;; BUILTIN <place> <name> <args>*
	  ((builtin)
	   (let ((place (cadr inst))
		 (name (caddr inst))
		 (args (map evaluate (cdddr inst))))
	     (cond ((assoc name builtins)
		    => (lambda (entry)
			 (case (length args)
			   ((0) (move! place ((cdr entry))))
			   ((1) (move! place ((cdr entry) (car args))))
			   ((2) (move! place ((cdr entry) (car args) (cadr args))))
			   ((3) (move! place ((cdr entry) (car args) (cadr args) (caddr args))))
			   ((4) (move! place ((cdr entry) (car args) (cadr args) (caddr args) (cadddr args))))
			   (else (error 'go "builtin with too many args" name)))
			 (go)))
		   (else (error 'go "unknown builtin" name)))))

	  ;; MOVE <place> <value>
	  ((move)
	   (let ((place (cadr inst))
		 (value (evaluate (caddr inst))))
	     (move! place value)
	     (go)))

	  ;; ALLOC-TMPS <num>
	  ((alloc-tmps)
	   (let ((value (cadr inst)))
	     (set-stack-frame-tmp! (car (unbox stack)) (make-vector value #f))
	     (go)))

	  ;; MAKE-CLOSURE <place> <label> <num>
	  ((make-closure)
	   (let ((place (cadr inst))
		 (label (get-hash-table index-table (caddr inst) #f))
		 (env (make-vector (cadddr inst) #f)))
	     (unless label
		     (error 'go "make-closure: missing label" label))
	     (move! place (make-closure label env))
	     (go)))

	  ;; SET-CLOSURE! <closure> <index> <value>
	  ((set-closure!)
	   (let ((clo (evaluate (cadr inst)))
		 (i (caddr inst))
		 (val (evaluate (cadddr inst))))
	     (vector-set! (closure-env clo) i val)
	     (go)))

	  ;; CALL <closure> <args>*
	  ((call)
	   (let ((clo (evaluate (cadr inst)))
		 (args (list->vector (map evaluate (cddr inst)))))
	     (push! stack (make-stack-frame #f args (closure-env clo) (unbox ip)))
	     (set-box! ip (closure-label clo))
	     (go)))

	  ;; TAIL-CALL <closure> <args>*
	  ((tail-call)
	   (let ((clo (evaluate (cadr inst)))
		 (args (list->vector (map evaluate (cddr inst)))))
             (let ((ret (stack-frame-return-address (car (unbox stack)))))
	       (set-car! (unbox stack) (make-stack-frame #f args (closure-env clo) ret))
	       (set-box! ip (closure-label clo))
	       (go))))

	  ;; RETURN
	  ((return)
           (when (null? (unbox stack)) (error 'go "returning too many times"))
	   (let ((frame (pop! stack)))
	     (set-box! ip (stack-frame-return-address frame))
	     (go)))

	  ;; BRANCH <label>
	  ((branch)
	   (let ((lbl (get-hash-table index-table (cadr inst) #f)))
	     (when (unbox return-register) (set-box! ip lbl))
	     (go)))

	  ;; JUMP <label>
	  ((jump)
	   (let ((lbl (get-hash-table index-table (cadr inst) #f)))
	     (set-box! ip lbl)
	     (go)))

	  (else
	   (error 'go "unknown instruction" inst))))))


(define (execute start)
  (set-box! ip (get-hash-table index-table start #f))
  (unless (unbox ip)
	  (error 'execute "no such label" start))
  (set-box! return-register #f)
  (set-box! stack (list (make-stack-frame #f #f #f 0)))
  (go)
  (unbox return-register))

(define (execute-call clo-name args)
  (set-box! return-register #f)
  (let ((clo (vector-ref execute:globals clo-name)))
    (set-box! ip (closure-label clo))
    (set-box! stack (list (make-stack-frame #f (list->vector args) (closure-env clo) 0))))
  (go)
  (unbox return-register))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pass-bytes


(define bytes:bytecode-size (box 2))
(define bytes:index-table (make-hash-table))

(define (pass-bytes insts)
  ;; first pass resolves all the labels
  (let ((i (box (unbox bytes:bytecode-size))))
    (for-each
     (lambda (elt)
					;(print `(pass-bytes elt ,elt))
       (when (symbol? elt)
	 (put-hash-table! bytes:index-table elt (unbox i)))
       (set-box! i (+ (unbox i) (emit-bytes #t elt))))
     insts)
    (set-box! bytes:bytecode-size (+ (unbox i) 1)))
  ;; +1 for the newline
  
  ;; second pass is printing it out
  (for-each (lambda (i) (emit-bytes #f i)) insts)
  (newline))

(define builtins-list
  '(exit
  gensym
  display newline print
  eq? equal?
  cons car cdr set-car! set-cdr!
  null? pair?
  number? boolean? string? char? symbol?

;;19
  + - * = < > <= >=

 ;;27
  quotient modulo
  list

  box
  unbox
  set-box!
  
  vector-ref
  vector-set!
  make-vector ;; 35
  vector-length

  make-string
  string-set!
  string-ref
  string->symbol
  string-length
  string=?
  
  ;string->list
  ;symbol->string
					;list->string

  eof-object?
  read-char
  peek-char

  vector?
  symbol->string
  char->integer
  ))

(define (+/3 a b c) (+ a (+ b c)))
(define (+/4 a b c d) (+ a (+ b (+ c d))))
(define (+/5 a b c d e) (+ a (+ b (+ c (+ d e)))))

(define (sum/for-each func count? args)
  (let loop ((sum 0) (args args))
    (if (null? args)
	sum
	(loop (+ sum (func count? (car args))) (cdr args)))))

(define (puts count? s)
  (if (symbol? s)
      (puts count? (builtin symbol->string s))
      (if count?
	  (string-length s)
	  (begin (display s) 0))))

(define (hx/char c)
  (if (= c 0)
      #\0
      (if (= c 1)
	  #\1
	  (if (= c 2)
	      #\2
	      (if (= c 3)
		  #\3
		  (if (= c 4)
		      #\4
		      (if (= c 5)
			  #\5
			  (if (= c 6)
			      #\6
			      (if (= c 7)
				  #\7
				  (if (= c 8)
				      #\8
				      (if (= c 9)
					  #\9
					  (if (= c 10)
					      #\A
					      (if (= c 11)
						  #\B
						  (if (= c 12)
						      #\C
						      (if (= c 13)
							  #\D
							  (if (= c 14)
							      #\E
							      (if (= c 15)
								  #\F
								  (print '(builtin exit 2)))))))))))))))))))

(define (hx num width)
  (if (= width 0)
      (if (= num 0)
	  #t
	  (print '(builtin exit)))
      (begin (hx (quotient num 16) (- width 1))
	     (display (hx/char (modulo num 16))))))

(define (emit-num/4 count? i)
  (unless count? (hx i 4))
  4)

(define (emit-num/6 count? i)
  (unless count? (hx i 6))
  6)

(define (emit-num/16 count? i)
  (unless count? (hx i 16))
  16)

(define (emit-num/2 count? i)
  (unless count? (hx i 2))
  2)

(defmacro plus
  (lambda (exp)
    (let ((v (gensym "v")))
      `(let ((,v ,(cadr exp)))
	 (+ ,v ,(caddr exp))))))

(define (emit-place count? place)
  (match place
    (('reg return) (puts count? "r"))
    (('var 'glo i) (plus (puts count? "g") (emit-num/4 count? i)))
    (('var 'tmp i) (plus (puts count? "t") (emit-num/2 count? i)))
    (('var 'loc i) (plus (puts count? "l") (emit-num/2 count? i)))
    (('var 'env i) (plus (puts count? "e") (emit-num/2 count? i)))
    (else (error 'emit-place "" place))))

(define (write-char count? ch)
  (unless count?
    (builtin display #\#)
    (builtin display #\\)
    (display ch))
  3)

(define (put-dot count?)
  (unless count?
    (display #\.))
  1)

(define (emit-value count? val)
  (match val
    (('datum d)
     (cond ((null? d)
	    (puts count? "N"))
	   ((boolean? d)
	    (puts count? (if d "#t" "#f")))
	   ((char? d)
	    (if (equal? d #\newline)
		(puts count? "#N")
		(if (equal? d #\tab)
		    (puts count? "#T")
		    (write-char count? d))))
	   ((number? d)
	    (if (< d 65535)
		(plus (puts count? "x")
		      (emit-num/4 count? d))
		(plus (puts count? "X")
		      (emit-num/16 count? d))))
	   ((symbol? d)
	    (let ((t1 (puts count? "S"))
		  (t2 (puts count? d)) ;; todo escape .
		  (t3 (put-dot count?)))
	      (+ t1 (+ t2 t3))))
	   ((string? d)
	    (unless count?
	      (builtin display #\"))
	    (let ((t2 (puts count? d)) ;; todo escape .
		  (t3 (put-dot count?)))
	      (+ 1 (+ t2 t3))))
	   (else (error 'emit-value "todo" val))))
    (else (emit-place count? val))))

(define (emit-bytes count? inst)
  ;(print inst)
  (match inst
    (('halt)
     (puts count? "H"))

    (('builtin place nm . args)
     (let ((t1 (puts count? "B"))
	   (t2 (emit-place count? place))
	   (t3 (emit-num/2 count? (index nm builtins-list)))
	   (t4 (sum/for-each emit-value count? args))
	   (t5 (put-dot count?)))
       (+ t1 (+ t2 (+ t3 (+ t4 t5))))))

    (('move place value)
     (let ((t1 (puts count? "M"))
	   (t2 (emit-place count? place))
	   (t3 (emit-value count? value)))
       (+ t1 (+ t2 t3))))

    (('alloc-tmps num)
     (let ((t1 (puts count? "A"))
	   (t2 (emit-num/2 count? num)))
       (+ t1 t2)))

    (('make-closure place lbl size)
     (let ((t1 (puts count? "c"))
	   (t2 (emit-place count? place))
	   (t3 (emit-num/6 count? (get-hash-table bytes:index-table lbl #f)))
	   (t4 (emit-num/2 count? size)))
       (+ (+ t1 t2) (+ t3 t4))))

    (('set-closure! clo idx value)
     (let ((t1 (puts count? "E"))
	   (t2 (emit-value count? clo))
	   (t3 (emit-num/2 count? idx))
	   (t4 (emit-value count? value)))
       (+ (+ (+ t1 t2) t3) t4)))
    
    (('call clo . args)
     (let ((t1 (puts count? "C"))
	   (t2 (emit-value count? clo))
	   (t3 (sum/for-each emit-value count? args))
	   (t4 (put-dot count?)))
       (+ (+ t1 t2) (+ t3 t4))))

    (('tail-call clo . args)
     (let ((t1 (puts count? "T"))
	   (t2 (emit-value count? clo))
	   (t3 (sum/for-each emit-value count? args))
	   (t4 (put-dot count?)))
       (+ t1 (+ t2 (+ t3 t4)))))

    (('return)
     (puts count? "R"))
    
    (('branch lbl)
     (let ((t1 (puts count? "b"))
	   (t2 (emit-num/6 count? (get-hash-table bytes:index-table lbl #f))))
       (+ t1 t2)))

    (('jump lbl)
     (let ((t1 (puts count? "J"))
	   (t2 (emit-num/6 count? (get-hash-table bytes:index-table lbl #f))))
       (+ t1 t2)))

    (else
     (unless (symbol? inst)
       (print 'bad-error)
       (print inst)
       (error 'emit-bytes "TODO" inst)
       (puts count? "-"))
     0)))


;;;; pass expand

(define glo (box #f))
(define mac (box #f))

(define (macro? m) (assoc m (unbox mac)))

(define (interpretdef exp)
  (let ((tbl (box `((globals . ,glo)
		    (macros . ,mac)
		    (toplevel ,exp)))))
    (set-box! tbl (pass-hoist (unbox tbl)))
    (set-box! tbl (pass-denest (unbox tbl)))
    (set-box! tbl (pass-instructions (unbox tbl)))
    (append-bytecode! (list->vector (unbox tbl)))
    (execute (car (unbox tbl)))))

(define (interpretmac exp)
  (let ((name (assoc (car exp) (unbox mac))))
    (execute-call (cdr name) (cons exp '()))))

(define (expandm exp)
  (cond ((datum? exp) exp)

	((quote? exp) exp)

	((variable? exp) exp)

	((if? exp)
	 (let ((t (cadr exp))
	       (c (caddr exp))
	       (a (cadddr exp)))
	   `(if ,(expandm t)
		,(expandm c)
		,(expandm a))))

	((begin? exp)
	 (let ((sts (cdr exp)))
	   (if (null? (cdr sts))
	       (expandm (car sts))
	       `(begin . ,(mapply expandm sts)))))

	((lambda? exp)
	 (let ((bind (cadr exp))
	       (body `(begin . ,(cddr exp))))
	   `(lambda ,bind ,(expandm body))))

	((named-let? exp)
	 (let ((name (cadr exp))
	       (bindings (caddr exp))
	       (body `(begin . ,(cdddr exp))))
	   (expandm
	    `(letrec ((,name (lambda ,(map car bindings)
			       ,body)))
	       (,name . ,(map cadr bindings))))))

	((let? exp)
	 `(let ,(map (lambda (bind)
		       (list (car bind) (expandm (cadr bind)))) (cadr exp))
	    ,(expandm `(begin . ,(cddr exp)))))

	((letrec? exp)
	 `(letrec ,(map (lambda (bind)
			  (list (car bind) (expandm (cadr bind)))) (cadr exp))
	    ,(expandm `(begin . ,(cddr exp)))))

	((builtin-app? exp)
	 `(builtin ,(cadr exp) . ,(mapply expandm (cddr exp))))

	((app? exp)
	 (cond ((macro? (car exp))
		(expandm (interpretmac exp)))
	       (else
		(mapply expandm exp))))

	(else
	 (error 'expandm "unknown exp" exp))))

(define (pass-expand tbl)
  (transform-assoc tbl (globals macros toplevel)
    (let ((c (make-collector)))
      (set-box! glo (unbox globals))
      (set-box! mac (unbox macros))
      (letrec ((process
		(lambda (top)
		  (match top
		    (('define nm idx body)
		     (collect! c `(define ,nm ,idx ,(expandm body))))
		    (('defmacro nm gen idx body)
		     (begin
		       (set-box! mac (cons (cons nm idx) (unbox mac)))
		       (interpretdef `(define ,gen ,idx ,(expandm body)))))
		    (else
		     (collect! c (expandm top)))))))
	(for-each process toplevel))
      (set-box! globals (unbox glo))
      (set-box! macros (unbox mac))
      `((globals . ,globals)
	(macros . ,macros)
	(toplevel . ,(collector-get c))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define globals (box '()))
(define macros (box '()))

(define (definition? x)
  (and (pair? x)
       (or (eq? 'define (car x))
	   (eq? 'defmacro (car x)))))

(define (program) (read-s* (tokenize))) ;; parlse

;; and then i just added on each pass 1 by 1,
;; then the VM execute a the end;

(display "H") (newline)
(let ((tbl `((globals . ,globals)
	     (toplevel . ,(program)))))
  (let ((tbl (pass-scan tbl)))
    (let loop ((exps (cdr (assoc 'toplevel tbl))))
      (unless (null? exps)
	(let ((tbl `((globals . ,globals)
		     (macros . ,macros)
		     (toplevel ,(car exps))))
	      (def? (definition? (car exps))))
	  ;(print 'expand)
	  ;(print tbl)
	  (let ((tbl (pass-expand tbl)))
	  ;(print 'hoist)
	  ;(print tbl)
	  (let ((tbl (pass-hoist tbl)))
	    ;(print 'denest)
	    ;(print tbl)
	    (let ((tbl (pass-denest tbl)))
	      ;(print 'instructions)
	      ;(print tbl)
	      (let ((tbl (pass-instructions tbl)))
		(append-bytecode! (list->vector tbl))
		(when def?
		  (execute (car tbl)))
		(pass-bytes tbl)
	    (loop (cdr exps)))))))))))
(display "Q") (newline)

; (include "t/boot/try-compiler.scm")