3imp/opsym2code.scm at master · localchart/3imp · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
#!/usr/local/bin/gosh

(define optbl
  '((HALT ())
    (LREF (n . $x))
    (FREF (n . $x))
    (GREF (sym . $x))
    (UNBOX $x)
    (CONST (obj . $x))
    (CLOSE (argnum n $body . $x))
    (BOX (n . $x))
    (TEST ($then . $else))
    (LSET (n . $x))
    (FSET (n . $x))
    (GSET (sym . $x))
    (CONTI (tail$ . $x))
    (NUATE (stack . $x))
    (FRAME ($x . $ret))
    (ARG $x)
    (SHIFT (n . $x))
    (APPLY (argnum))
    (RET ())
    (EXTEND (argnum . $x))
    (SHRINK (n . $x))
    (UNDEF $x)

    (GREF-APPLY (sym n))
    (GREF-SHIFT-APPLY (sym n))
    (SHIFT-APPLY (n))
    (CONST-ARG (obj . $x))
    ))


(define *h* (make-hash-table))

(let loop ((ls optbl)
           (i 0))
  (if (null? ls)
      '()
    (let* ((e (car ls))
           (sym (car e))
           (args (cadr e)))
      (hash-table-put! *h* sym (list i args))
      (loop (cdr ls) (+ i 1)))))


(define (op-sym->code ls)
  (define (each* f xs ys)
    (set-car! ys (f (car xs) (car ys)))
    (cond ((pair? (cdr xs))
           (each* f (cdr xs) (cdr ys)))
          ((null? (cdr xs))
           '())
          (else
           (set-cdr! ys (f (cdr xs) (cdr ys))))))
  (define (f sym val)
    (if (eq? (string-ref (symbol->string sym) 0)
             #\$)
        (op-sym->code val)
      val))

  (when (pair? ls)
    (let1 sym (car ls)
      (when (hash-table-exists? *h* sym)
        (let* ((e (hash-table-get *h* sym))
               (opid (car e))
               (elems (cadr e)))
          (set-car! ls opid)
          (each* f (cons 'op elems) ls)))))
  ls)


(define (main args)
  (until (read) eof-object? => sexp
    (write/ss (op-sym->code sexp))
    (newline)))