smalltalk-tng

view etng-r2/compile-to-scheme.scm @ 258:4d06e035b80e

find changesets by author, revision, files, or words in the commit message
Begin adapting evaluator to codegen
author Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
date Fri Jul 24 16:00:30 2009 +0100 (2009-07-24)
parents 10e62e160cb0
children 843b43973b4c
line source
1 (define previous-inspector (current-inspector))
2 (current-inspector (make-inspector))
3
4 (define-record-type etng-function
5 (make-etng-function ;;sources
6 clauses)
7 etng-function?
8 ;;(sources etng-function-sources)
9 (clauses etng-function-clauses))
10
11 (current-inspector previous-inspector)
12
13 ;---------------------------------------------------------------------------
14
15 (define etng-namespaces '())
16 (define implicit-etng-namespace #f)
17
18 (define builtin-namespace-url "http://www.eighty-twenty.org/etng/r2/builtin#")
19
20 (define (set-etng-namespace! prefix url)
21 (cond
22 ((assq prefix etng-namespaces) =>
23 (lambda (cell) (set-box! (cdr cell) url)))
24 (else
25 (set! etng-namespaces (cons (cons prefix (box url)) etng-namespaces)))))
26
27 (set-etng-namespace! '|| builtin-namespace-url)
28
29 (define (mangle-etng-id* url localname)
30 (string->symbol (string-append "etng___" url (symbol->string localname))))
31
32 (define (mangle-etng-id id)
33 (cond
34 ((qname? id)
35 (cond
36 ((assq (qname-uri id) etng-namespaces) =>
37 (lambda (entry)
38 (mangle-etng-id* (unbox (cdr entry)) (qname-localname id))))
39 (else
40 (error 'unknown-qname-prefix id))))
41 ((symbol? id)
42 (if implicit-etng-namespace
43 (mangle-etng-id* implicit-etng-namespace id)
44 (mangle-etng-id* "" id)))
45 (else (error 'invalid-etng-id id))))
46
47 (define (etng-send-via-named-proxy receiver localname message)
48 (etng-send* receiver
49 (namespace-variable-value (mangle-etng-id* builtin-namespace-url localname))
50 message))
51
52 (define (etng-lookup receiver via message)
53 (let lookup ((clauses (etng-function-clauses via)))
54 (if (null? clauses)
55 #f
56 (let apply-loop ((matcher (car clauses))
57 (args message))
58 (if (null? args)
59 (make-etng-function ;;... some source code ...?
60 (list matcher
61 (lambda (arg kcomplete kmore kfail)
62 (
63 (let ((arg (car args))
64 (remaining-args (cdr args)))
65 (matcher arg
66 (lambda (thunk) thunk)
67 (lambda (next-matcher) (apply-loop next-matcher remaining-args))
68 (lambda () (lookup (cdr clauses)))))))
69
70 (define (etng-send* receiver via message)
71 (cond
72 ((etng-function? via)
73 (let ((thunk (or (etng-lookup receiver via message)
74 (error 'does-not-understand receiver via message))))
75 (thunk receiver)))
76 ((number? via) (etng-send-via-named-proxy receiver 'numberProxy message))
77 ((string? via) (etng-send-via-named-proxy receiver 'stringProxy message))
78 ((qname-or-symbol? via) (etng-send-via-named-proxy receiver 'symbolProxy message))
79 ((vector? via) (etng-send-via-named-proxy receiver 'tupleProxy message))
80 ((not via) (etng-send-via-named-proxy receiver 'falseProxy message))
81 ((eq? via #t) (etng-send-via-named-proxy receiver 'trueProxy message))
82 (else (error 'illegal-primitive-object receiver via message))))
83
84 (define (etng-send receiver message)
85 (etng-send* receiver receiver message))
86
87 (define (etng-merge-functions f1 f2)
88 (make-etng-function ;;(append (etng-function-sources f1) (etng-function-sources f2))
89 (append (etng-function-clauses f1) (etng-function-clauses f2))))
90
91 (define (compile-to-scheme ast)
92
93 (define (schemeify tng-sexp)
94 (if (pair? tng-sexp)
95 (case (car tng-sexp)
96 ((paren) (map schemeify (cdr tng-sexp)))
97 (else (error 'brack-and-brace-illegal-in-scheme-assembly)))
98 tng-sexp))
99
100 (define (make-definition id val)
101 `(namespace-set-variable-value! ',(mangle-etng-id id) ,val))
102
103 (define (toplevel ast)
104 (case (car ast)
105 ((define-namespace) `(set-etng-namespace! ',(cadr ast) ',(caddr ast)))
106 ((declare-default-namespace) `(set! implicit-etng-namespace ',(cadr ast)))
107 ((define-value) (make-definition (cadr ast) (expr (caddr ast))))
108 ((define-function) (make-definition (cadr ast) (expr `(function ,(caddr ast)))))
109 (else (expr ast))))
110
111 (define (expr ast)
112 (case (car ast)
113 ((ref) (mangle-etng-id (cadr ast)))
114 ((lit) `',(cadr ast))
115 ((object) `(make-etng-function ;;',(cddr ast)
116 (list ,@(map (method (cadr ast)) (cddr ast)))))
117 ((function) `(make-etng-function ;;',(cdr ast)
118 (list ,@(map (method #f) (cdr ast)))))
119 ((tuple) `(vector ,@(map expr (cdr ast))))
120 ((send) `(etng-send ,(expr (cadr ast)) (list ,@(map expr (cddr ast)))))
121 ((assemble) `(let ,(map (lambda (binding)
122 `(,(car binding) ,(expr (cadr binding))))
123 (cadr ast))
124 ,(schemeify (cadr (assq 'scheme (caddr ast))))))))
125
126 (define (pattern p on-success on-failure)
127 (case (car p)
128 ((discard) on-success)
129 ((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success))
130 ((lit) `(if (equal? ',(cadr p) _arg)
131 ,on-success
132 ,on-failure))
133 ((tuple) `(if (and (vector? _arg)
134 (= (vector-length _arg) ,(length (cdr p))))
135 ,(let ((tuple-name (gensym '_argtuple)))
136 `(let ((,tuple-name _arg))
137 ,(let match-elts ((elts (cdr p))
138 (index 0))
139 (if (null? elts)
140 on-success
141 `(let ((_arg (vector-ref ,tuple-name ,index)))
142 ,(pattern (car elts)
143 (match-elts (cdr elts) (+ index 1))
144 on-failure))))))
145 ,on-failure))))
146
147 (define (method self-id)
148 (lambda (ast)
149 `(lambda (_arg _kcomplete _kmore _kfail)
150 ,(let* ((patterns (cadr ast))
151 (body (caddr ast))
152 (remaining-patterns (cdr patterns)))
153 (pattern (car patterns)
154 (if (null? remaining-patterns)
155 `(_kcomplete (lambda (,(if self-id (mangle-etng-id self-id) '_self))
156 ,(expr body)))
157 `(_kmore ,((method #f) `(method ,remaining-patterns ,body))))
158 `(_kfail))))))
159
160 (toplevel ast))