author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Wed, 16 Jan 2019 17:15:58 +0000 | |
changeset 438 | 1fe179d53161 |
parent 223 | 646d45b098aa |
permissions | -rw-r--r-- |
223
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
1 |
;; Compile AST to a set of prototype methods and blocks. |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
2 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
3 |
(define-record-type compilation-state |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
4 |
(make-compilation-state* next-literal rev-literals) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
5 |
compilation-state? |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
6 |
(next-literal compilation-state-next-literal) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
7 |
(rev-literals compilation-state-rev-literals)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
8 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
9 |
(define (make-compilation-state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
10 |
(make-compilation-state* 0 '())) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
11 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
12 |
(define (push-literal state val) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
13 |
(let ((i (compilation-state-next-literal state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
14 |
(values i |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
15 |
(make-compilation-state* (+ i 1) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
16 |
(cons val (compilation-state-rev-literals state)))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
17 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
18 |
(define (finish-compilation-state state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
19 |
(list->vector (reverse (compilation-state-rev-literals state)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
20 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
21 |
(define *all-method-code-prologues* '()) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
22 |
(define *invocation-count-decay-half-life* 15) ;; seconds |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
23 |
(define *invocation-count-update-interval* 4) ;; seconds |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
24 |
(define *recompilation-count-limit* 1000) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
25 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
26 |
(define (instruction->code instr is-closure) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
27 |
(let ((prologue (vector 0 (if is-closure *true* *false*)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
28 |
(let ((locative (make-weak-locative prologue 0))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
29 |
(push! *all-method-code-prologues* locative)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
30 |
(cons prologue instr))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
31 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
32 |
(define (invocation-count-decay-constant) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
33 |
(exp (/ (log 2) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
34 |
(/ *invocation-count-decay-half-life* *invocation-count-update-interval*)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
35 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
36 |
(define (decay-invocation-counts!) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
37 |
(debug 0 "Decaying invocation counts...") |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
38 |
(let ((decay-constant (invocation-count-decay-constant))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
39 |
(set! *all-method-code-prologues* |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
40 |
(filter! (lambda (locative) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
41 |
(let ((prologue (locative->object locative))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
42 |
(if prologue |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
43 |
(vector-set! prologue 0 (/ (vector-ref prologue 0) decay-constant))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
44 |
prologue)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
45 |
*all-method-code-prologues*)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
46 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
47 |
(define (bump-invocation-count! prologue method) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
48 |
(let ((invocation-count (+ (vector-ref prologue 0) 1))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
49 |
(vector-set! prologue 0 invocation-count) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
50 |
(if (>= invocation-count *recompilation-count-limit*) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
51 |
(begin |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
52 |
(vector-set! prologue 0 0) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
53 |
(recompile-method! method))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
54 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
55 |
(define compile-ThiNG |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
56 |
(let () |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
57 |
(define (do-ref cenv state name) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
58 |
(let* ((name (string->symbol name))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
59 |
(values (cond ((memq name cenv) `#(local ,name)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
60 |
(else `#(global ,name))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
61 |
state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
62 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
63 |
(define (compile-tuple cenv state exprs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
64 |
(let loop ((exprs exprs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
65 |
(state state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
66 |
(acc '())) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
67 |
(if (null? exprs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
68 |
(values (list->vector (reverse acc)) state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
69 |
(let*-values (((instr state) (compile cenv state (car exprs)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
70 |
(loop (cdr exprs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
71 |
state |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
72 |
(cons instr acc)))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
73 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
74 |
(define (do-send cenv state selector exprs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
75 |
(let-values (((selector) (string->symbol selector)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
76 |
((instrs state) (compile-tuple cenv state exprs))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
77 |
(values `#(send ,selector ,instrs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
78 |
state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
79 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
80 |
(define (do-block cenv state binders statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
81 |
(let* ((block (clone-object *block*)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
82 |
(num-formals (length binders)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
83 |
(formals (map string->symbol binders)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
84 |
(formal-cenv (append (cons '_ formals) cenv)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
85 |
(selector (if (zero? num-formals) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
86 |
'do |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
87 |
(string->symbol |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
88 |
(string-concatenate (cons "applyWith:" |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
89 |
(make-list (- num-formals 1) "with:"))))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
90 |
(let*-values (((instr block-state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
91 |
(compile formal-cenv (make-compilation-state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
92 |
`(scope ,*nil* ,statements))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
93 |
((litvec) (finish-compilation-state block-state)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
94 |
((method) (define-method! selector (cons '_ formals) (list block) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
95 |
(instruction->code instr #t))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
96 |
((block-index state) (push-literal state block))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
97 |
(set-slot! method 'literals litvec) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
98 |
(values `#(closure ,block-index) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
99 |
state)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
100 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
101 |
(define (do-scope cenv state name statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
102 |
(if (eq? *nil* name) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
103 |
(let-values (((instrs state) (compile-statements cenv state statements))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
104 |
(values `#(begin ,instrs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
105 |
state)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
106 |
(let*-values (((name) (string->symbol name)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
107 |
((instrs state) (compile-statements (cons name cenv) state statements))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
108 |
(values `#(scope ,name ,instrs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
109 |
state)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
110 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
111 |
(define (do-literal cenv state val) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
112 |
(let-values (((index state) (push-literal state val))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
113 |
(values `#(literal ,index) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
114 |
state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
115 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
116 |
(define (do-update cenv state template-expr updates) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
117 |
(let*-values (((template-instr state) (compile cenv state template-expr)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
118 |
((updates state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
119 |
(let loop ((updates updates) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
120 |
(state state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
121 |
(acc '())) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
122 |
(if (null? updates) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
123 |
(values (list->vector (reverse acc)) state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
124 |
(let*-values (((update) (car updates)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
125 |
((update-instr state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
126 |
(compile cenv state (caddr update)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
127 |
(loop (cdr updates) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
128 |
state |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
129 |
(cons (vector (car update) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
130 |
(string->symbol (cadr update)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
131 |
update-instr) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
132 |
acc))))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
133 |
(values `#(update ,template-instr ,updates) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
134 |
state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
135 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
136 |
(define (do-tuple cenv state exprs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
137 |
(let-values (((instrs state) (compile-tuple cenv state exprs))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
138 |
(values `#(tuple ,instrs) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
139 |
state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
140 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
141 |
(define (do-resend cenv state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
142 |
(values `#(resend) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
143 |
state)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
144 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
145 |
(define (do-method cenv state pattern statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
146 |
(let* ((selector (string->symbol (cadr pattern))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
147 |
(params (caddr pattern)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
148 |
(formals (map (lambda (entry) (string->symbol (or (non-*false*? (car entry)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
149 |
"_"))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
150 |
params))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
151 |
(let*-values (((specializer-instrs state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
152 |
(compile-tuple cenv state (map (lambda (entry) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
153 |
(let ((exp (cadr entry))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
154 |
(if (non-*false*? exp) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
155 |
exp |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
156 |
`(ref "NoRole")))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
157 |
params))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
158 |
((body-instr method-state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
159 |
(compile formals (make-compilation-state) `(scope ,*nil* ,statements))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
160 |
((method-litvec) (finish-compilation-state method-state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
161 |
(values `#(method ,selector ,formals ,specializer-instrs |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
162 |
,(instruction->code body-instr #f) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
163 |
,method-litvec) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
164 |
state)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
165 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
166 |
(define (compile-statement cenv state statement) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
167 |
(if (and (pair? statement) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
168 |
(eq? (car statement) 'let)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
169 |
(let* ((name (string->symbol (cadr statement))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
170 |
(expr (caddr statement)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
171 |
(newenv (cons name cenv))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
172 |
(let-values (((instr state) (compile newenv state expr))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
173 |
(values `#(bind ,name ,instr) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
174 |
newenv |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
175 |
state))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
176 |
(let-values (((instr state) (compile cenv state statement))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
177 |
(values instr cenv state)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
178 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
179 |
(define (compile-statements cenv state statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
180 |
(let loop ((cenv cenv) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
181 |
(state state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
182 |
(statements statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
183 |
(acc '())) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
184 |
(if (null? statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
185 |
(values (list->vector (reverse acc)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
186 |
state) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
187 |
(let-values (((instr cenv state) (compile-statement cenv state (car statements)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
188 |
(loop cenv |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
189 |
state |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
190 |
(cdr statements) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
191 |
(cons instr acc)))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
192 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
193 |
(define (compile cenv state ast) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
194 |
(debug 1 "compile "ast" "cenv) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
195 |
(cond |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
196 |
((pair? ast) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
197 |
(apply (cond |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
198 |
((assq (car ast) `((ref ,do-ref) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
199 |
(send ,do-send) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
200 |
(block ,do-block) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
201 |
(scope ,do-scope) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
202 |
(string ,do-literal) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
203 |
(symbol ,do-literal) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
204 |
(number ,do-literal) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
205 |
(update ,do-update) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
206 |
(tuple ,do-tuple) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
207 |
(resend ,do-resend) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
208 |
(method ,do-method) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
209 |
)) => cadr) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
210 |
(else (error "Unknown ast kind" ast))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
211 |
cenv state |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
212 |
(cdr ast))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
213 |
(else (error "Non-pair ast" ast)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
214 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
215 |
(lambda (ast) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
216 |
(let-values (((instr state) (compile '() (make-compilation-state) ast))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
217 |
(values instr |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
218 |
(finish-compilation-state state)))))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
219 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
220 |
(define (instruction-vector-size seed instr-vec) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
221 |
(vector-fold (lambda (instr acc) (+ (instruction-size instr) acc)) seed instr-vec)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
222 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
223 |
(define (instruction-size instr) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
224 |
(case (vector-ref instr 0) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
225 |
((local global closure literal resend) 1) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
226 |
((send) (instruction-vector-size 1 (vector-ref instr 2))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
227 |
((begin) (instruction-vector-size 0 (vector-ref instr 1))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
228 |
((scope) (instruction-vector-size 0 (vector-ref instr 2))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
229 |
((update) (instruction-vector-size 1 (vector-ref instr 2))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
230 |
((tuple) (instruction-vector-size 1 (vector-ref instr 1))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
231 |
((method) 1) ;; not quite correct, but mneh. until the macro is expanded properly, will do. |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
232 |
(else (error "Illegal instruction in instruction-size" instr)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
233 |
|
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
234 |
(define (recompile-method! method) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
235 |
(let ((instr (cdr (get-slot method 'code)))) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
236 |
(pretty-print `(recompile-method! |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
237 |
(size ,(instruction-size instr)) |
646d45b098aa
During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
238 |
(instr ,instr))))) |