smalltalk-tng
view etng-r2/main.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | 4d06e035b80e |
| children |
line source
1 (require srfi/1) ;; lists
2 (require srfi/4) ;; homogeneous-numeric-vectors, u8vector
3 (require srfi/8) ;; receive
4 (require srfi/9) ;; records
5 (require srfi/13) ;; strings
6 (require scheme/pretty)
8 (print-struct #t)
9 (define previous-inspector (current-inspector))
10 (current-inspector (make-inspector))
12 (define-record-type tng-qname
13 (make-qname uri localname)
14 qname?
15 (uri qname-uri)
16 (localname qname-localname))
18 (current-inspector previous-inspector)
20 (require "../../ometa-scheme/ometa.scm")
21 (ometa-library-path "../../ometa-scheme")
23 (define etng-naked-id-terminators (string->list "`.()[]{}:;,'\""))
25 (define (char-etng-id-alpha? ch)
26 (or (char-alphabetic? ch)
27 (eqv? ch #\_)))
29 (define (char-etng-id-punct? ch)
30 (not (or (char-alphabetic? ch)
31 (char-whitespace? ch)
32 (char-numeric? ch)
33 (memv ch etng-naked-id-terminators))))
35 (define (eol-char? c)
36 (or (eqv? c #\return)
37 (eqv? c #\newline)))
39 (define (qname-or-symbol? x)
40 (or (qname? x)
41 (symbol? x)))
43 (define EMPTY-SYMBOL (string->symbol ""))
44 (define QUOTE-QNAME (make-qname EMPTY-SYMBOL 'quote))
45 (define UNQUOTE-QNAME (make-qname EMPTY-SYMBOL 'unquote))
46 (define SEMI (string->symbol ";"))
47 (define COMMA (string->symbol ","))
48 (define ARROW '->)
49 (define DISCARD '_)
50 (define PIPE (string->symbol "|"))
52 (define (list-interleave x xs)
53 (cond
54 ((null? xs) '())
55 ((null? (cdr xs)) xs)
56 (else (cons (car xs) (cons x (list-interleave x (cdr xs)))))))
58 (define (invert-sign x) (- x))
60 (define (etng-sexp-special-match? sexps qname)
61 (and (pair? sexps)
62 (let ((tok (car sexps)))
63 (equal? tok qname))))
65 (define (special-segment-head? token)
66 (or (equal? token QUOTE-QNAME)
67 (equal? token UNQUOTE-QNAME)
68 (memq token '(namespace do let %assemble))))
70 (define (->string x)
71 (cond
72 ((string? x) x)
73 ((symbol? x) (symbol->string x))
74 ((qname? x) (string-append (->string (qname-uri x))
75 ":"
76 (->string (qname-localname x))))
77 (else (let ((s (open-output-string)))
78 (write x s)
79 (get-output-string s)))))
81 (define read-etng* (load-ometa "etng-reader.g"))
82 (define parse-etng* (load-ometa "etng-parser.g"))
84 (define (read-etng input ks kf)
85 (read-etng* 'sexp input ks kf))
87 (define (read-etng-toplevel input ks kf)
88 (read-etng* 'sexp-toplevel input ks kf))
90 (define pass-common (opt (parse-ometa-file "etng-pass-common.g")))
92 (define (load-pass grammar-filename)
93 (let ((g (merge-ometa pass-common (parse-ometa-file grammar-filename))))
94 (lambda (input)
95 (simple-ometa-driver g
96 'pass
97 (->input-stream (list input))
98 (lambda (result next err) result)
99 (lambda (err)
100 (pretty-print `(,grammar-filename ,err))(newline)
101 #f)))))
103 (define null-pass (load-pass "etng-null-pass.g"))
105 (define convert-constant-methods-pass (load-pass "etng-convert-constant-methods-pass.g"))
107 (define (convert-constant-methods ast-prefix methods)
108 (let loop ((methods methods)
109 (reversed-temporaries '())
110 (reversed-initializers '())
111 (transformed-methods '()))
112 (if (null? methods)
113 (let ((new-methods (reverse transformed-methods))
114 (temporaries (reverse reversed-temporaries))
115 (initializers (reverse reversed-initializers)))
116 (cond
117 ((null? temporaries)
118 `(,@ast-prefix ,@new-methods))
119 ((null? (cdr temporaries))
120 `(send (function (method ((bind ,(car temporaries)))
121 (,@ast-prefix ,@new-methods)))
122 ,(car initializers)))
123 (else
124 `(send (function (method ((tuple ,@(map (lambda (temp) `(bind ,temp)) temporaries)))
125 (,@ast-prefix ,@new-methods)))
126 (tuple ,@initializers)))))
127 (let ((method (car methods)))
128 (if (eq? (car method) 'constant-method)
129 (let ((temp (gensym)))
130 (loop (cdr methods)
131 (cons temp reversed-temporaries)
132 (cons (caddr method) reversed-initializers)
133 (cons `(method ,(cadr method) (ref ,temp)) transformed-methods)))
134 (loop (cdr methods)
135 reversed-temporaries
136 reversed-initializers
137 (cons method transformed-methods)))))))
139 (define (alpha-convert-expr exp conversions)
140 (define (convert-method method)
141 `(,(car method)
142 ,(map (lambda (p) (alpha-convert-pattern p conversions)) (cadr method))
143 ,(alpha-convert-expr (caddr method) conversions)))
144 (case (car exp)
145 ((ref) `(ref ,(cond ((assq (cadr exp) conversions) => cadr) (else (cadr exp)))))
146 ((lit) exp)
147 ((object) `(,(car exp) ,(cadr exp) ,@(map convert-method (cddr exp))))
148 ((function) `(,(car exp) ,@(map convert-method (cdr exp))))
149 ((tuple) `(tuple ,@(map (lambda (x) (alpha-convert-expr x conversions)) (cdr exp))))
150 ((send) `(send ,@(map (lambda (x) (alpha-convert-expr x conversions)) (cdr exp))))))
152 (define (alpha-convert-pattern pat conversions)
153 (case (car exp)
154 ((discard) exp)
155 ((bind) `(bind ,(cond ((assq (cadr exp) conversions) => cadr) (else (cadr exp)))))
156 ((lit) exp)
157 ((tuple) `(tuple ,@(map (lambda (p) (alpha-convert-pattern p conversions)) (cdr exp))))))
159 (define (names-in-pattern p)
160 (case (car p)
161 ((discard) '())
162 ((bind) (list (cadr p)))
163 ((lit) '())
164 ((tuple) (append-map names-in-pattern (cdr p)))))
166 (define (etng-sexp->string-tree e)
167 (cond
168 ((pair? e) (cond
169 ((and (eq? (car e) 'paren)
170 (pair? (cdr e))
171 (equal? (cadr e) QUOTE-QNAME))
172 `("." ,(etng-sexp->string-tree (caddr e))))
173 (else
174 ((case (car e)
175 ((paren) (lambda (es) `("(" ,es ")")))
176 ((brack) (lambda (es) `("[" ,es "]")))
177 ((brace) (lambda (es) `("{" ,es "}")))
178 (else (error 'illegal-sexp e)))
179 (list-interleave " " (map etng-sexp->string-tree (cdr e)))))))
180 ((string? e) e)
181 (else (->string e))))
183 (define (cons-tree-for-each f l)
184 (let walk ((l l))
185 (if (pair? l)
186 (begin (walk (car l)) (walk (cdr l)))
187 (f l))))
189 (define (pp clue x . maybe-transformer)
190 (pretty-print (list clue
191 (if (null? maybe-transformer)
192 x
193 ((car maybe-transformer) x))))
194 (newline)
195 x)
197 (define (!pp clue x . maybe-transformer)
198 x)
200 (define (dump-string-tree t)
201 (cons-tree-for-each (lambda (x) (or (null? x) (display x))) t)
202 (newline))
204 (define (mark-position pos-path t)
205 (if (null? pos-path)
206 t
207 (call-with-values (lambda () (split-at t (car pos-path)))
208 (lambda (left right)
209 (if (null? (cdr pos-path))
210 (append left (list "<@@@@@>") right)
211 (append left (list (mark-position (cdr pos-path) (car right))) (cdr right)))))))
213 (define (display-parse-error clue err . maybe-ast)
214 (display clue)
215 (newline)
216 (when (not (null? maybe-ast))
217 (dump-string-tree (etng-sexp->string-tree (car (mark-position (car err)
218 (list (car maybe-ast)))))))
219 (display (format-ometa-error err))
220 (newline))
222 (define (parse-print-and-eval sexp evaluator)
223 ;; (pp 'raw-sexp sexp) (newline)
224 (dump-string-tree (etng-sexp->string-tree sexp))
225 (parse-etng* 'toplevel (list sexp)
226 (lambda (ast dummy-next err)
227 (if (null? (input-stream->list dummy-next))
228 (evaluator ast)
229 (display-parse-error "Partial parse." err sexp)))
230 (lambda (err)
231 (display-parse-error "Unsuccessful parse." err sexp))))
233 (load "compile-to-scheme.scm")
235 (define (rude-evaluator input)
236 (let* ((ast (!pp 'ast input))
237 (ast (!pp 'convert-constant-methods-pass (convert-constant-methods-pass ast)))
238 (scheme-ast (!pp 'compile-to-scheme (compile-to-scheme ast)))
239 (thunk (!pp 'compile-scheme (eval `(lambda () ,scheme-ast))))
240 )
241 (write (thunk))
242 (newline)))
244 (define (etng-parse-file* filename evaluator)
245 (call-with-input-file filename
246 (lambda (handle)
247 (let loop ((input (->input-stream handle)))
248 (read-etng-toplevel
249 input
250 (lambda (sexp0 next err)
251 (if (eq? sexp0 'eof)
252 'eof-reached
253 (let ((sexp (cons 'paren sexp0)))
254 (parse-print-and-eval sexp evaluator)
255 (when (and next (not (eq? next input)))
256 (loop next)))))
257 (lambda (error-description)
258 (display-parse-error "Reader failure." error-description)))))))
260 (define (etng-parse-file filename)
261 (etng-parse-file* filename rude-evaluator))
263 (define (etng-repl* evaluator)
264 (let loop ((input (current-input-stream)))
265 (display ">>ETNG>> ")
266 (flush-output)
267 (read-etng-toplevel
268 input
269 (lambda (sexp0 next err)
270 (if (eq? sexp0 'eof)
271 'eof-reached
272 (let ((sexp (cons 'paren sexp0)))
273 (parse-print-and-eval sexp evaluator)
274 (when (and next (not (eq? next input)))
275 (loop next)))))
276 (lambda (error-description)
277 (display-parse-error "Reader failure." error-description)
278 (loop (current-input-stream))))))
280 (define (etng-repl)
281 (etng-repl* rude-evaluator))
283 (etng-parse-file "boot.tng")
284 (etng-repl)