author | Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
Sun, 05 Jul 2009 15:06:54 +0100 | |
changeset 234 | 10e62e160cb0 |
parent 230 | 70e311e51c29 |
child 258 | 4d06e035b80e |
permissions | -rw-r--r-- |
187
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
1 |
(require srfi/1) ;; lists |
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
2 |
(require srfi/4) ;; homogeneous-numeric-vectors, u8vector |
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
3 |
(require srfi/8) ;; receive |
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
4 |
(require srfi/9) ;; records |
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
5 |
(require srfi/13) ;; strings |
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
6 |
(require scheme/pretty) |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
7 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
8 |
(print-struct #t) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
9 |
(define previous-inspector (current-inspector)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
10 |
(current-inspector (make-inspector)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
11 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
12 |
(define-record-type tng-qname |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
13 |
(make-qname uri localname) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
14 |
qname? |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
15 |
(uri qname-uri) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
16 |
(localname qname-localname)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
17 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
18 |
(current-inspector previous-inspector) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
19 |
|
187
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
20 |
(require "../../ometa-scheme/ometa.scm") |
176a3f4d1042
Changes to get the code running with mzscheme 4
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
183
diff
changeset
|
21 |
(ometa-library-path "../../ometa-scheme") |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
22 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
23 |
(define etng-naked-id-terminators (string->list "`.()[]{}:;,'\"")) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
24 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
25 |
(define (char-etng-id-alpha? ch) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
26 |
(or (char-alphabetic? ch) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
27 |
(eqv? ch #\_))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
28 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
29 |
(define (char-etng-id-punct? ch) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
30 |
(not (or (char-alphabetic? ch) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
31 |
(char-whitespace? ch) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
32 |
(char-numeric? ch) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
33 |
(memv ch etng-naked-id-terminators)))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
34 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
35 |
(define (eol-char? c) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
36 |
(or (eqv? c #\return) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
37 |
(eqv? c #\newline))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
38 |
|
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
39 |
(define (qname-or-symbol? x) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
40 |
(or (qname? x) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
41 |
(symbol? x))) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
42 |
|
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
43 |
(define EMPTY-SYMBOL (string->symbol "")) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
44 |
(define QUOTE-QNAME (make-qname EMPTY-SYMBOL 'quote)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
45 |
(define UNQUOTE-QNAME (make-qname EMPTY-SYMBOL 'unquote)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
46 |
(define SEMI (string->symbol ";")) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
47 |
(define COMMA (string->symbol ",")) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
48 |
(define ARROW '->) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
49 |
(define DISCARD '_) |
230 | 50 |
(define PIPE (string->symbol "|")) |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
51 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
52 |
(define (list-interleave x xs) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
53 |
(cond |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
54 |
((null? xs) '()) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
55 |
((null? (cdr xs)) xs) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
56 |
(else (cons (car xs) (cons x (list-interleave x (cdr xs))))))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
57 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
58 |
(define (invert-sign x) (- x)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
59 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
60 |
(define (etng-sexp-special-match? sexps qname) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
61 |
(and (pair? sexps) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
62 |
(let ((tok (car sexps))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
63 |
(equal? tok qname)))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
64 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
65 |
(define (special-segment-head? token) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
66 |
(or (equal? token QUOTE-QNAME) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
67 |
(equal? token UNQUOTE-QNAME) |
204
90899a08ca40
Parse '%assemble' construct.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
201
diff
changeset
|
68 |
(memq token '(namespace do let %assemble)))) |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
69 |
|
183
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
70 |
(define (->string x) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
71 |
(cond |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
72 |
((string? x) x) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
73 |
((symbol? x) (symbol->string x)) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
74 |
((qname? x) (string-append (->string (qname-uri x)) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
75 |
":" |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
76 |
(->string (qname-localname x)))) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
77 |
(else (let ((s (open-output-string))) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
78 |
(write x s) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
79 |
(get-output-string s))))) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
80 |
|
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
81 |
(define read-etng* (load-ometa "etng-reader.g")) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
82 |
(define parse-etng* (load-ometa "etng-parser.g")) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
83 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
84 |
(define (read-etng input ks kf) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
85 |
(read-etng* 'sexp input ks kf)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
86 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
87 |
(define (read-etng-toplevel input ks kf) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
88 |
(read-etng* 'sexp-toplevel input ks kf)) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
89 |
|
200
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
90 |
(define pass-common (opt (parse-ometa-file "etng-pass-common.g"))) |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
91 |
|
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
92 |
(define (load-pass grammar-filename) |
200
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
93 |
(let ((g (merge-ometa pass-common (parse-ometa-file grammar-filename)))) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
94 |
(lambda (input) |
200
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
95 |
(simple-ometa-driver g |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
96 |
'pass |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
97 |
(->input-stream (list input)) |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
98 |
(lambda (result next err) result) |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
99 |
(lambda (err) |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
100 |
(pretty-print `(,grammar-filename ,err))(newline) |
466a5b65f1bf
Use merge-ometa with passes.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
199
diff
changeset
|
101 |
#f))))) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
102 |
|
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
103 |
(define null-pass (load-pass "etng-null-pass.g")) |
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
104 |
|
201
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
105 |
(define convert-constant-methods-pass (load-pass "etng-convert-constant-methods-pass.g")) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
106 |
|
234
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
107 |
(define (convert-constant-methods ast-prefix methods) |
201
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
108 |
(let loop ((methods methods) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
109 |
(reversed-temporaries '()) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
110 |
(reversed-initializers '()) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
111 |
(transformed-methods '())) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
112 |
(if (null? methods) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
113 |
(let ((new-methods (reverse transformed-methods)) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
114 |
(temporaries (reverse reversed-temporaries)) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
115 |
(initializers (reverse reversed-initializers))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
116 |
(cond |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
117 |
((null? temporaries) |
234
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
118 |
`(,@ast-prefix ,@new-methods)) |
201
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
119 |
((null? (cdr temporaries)) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
120 |
`(send (function (method ((bind ,(car temporaries))) |
234
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
121 |
(,@ast-prefix ,@new-methods))) |
201
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
122 |
,(car initializers))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
123 |
(else |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
124 |
`(send (function (method ((tuple ,@(map (lambda (temp) `(bind ,temp)) temporaries))) |
234
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
125 |
(,@ast-prefix ,@new-methods))) |
201
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
126 |
(tuple ,@initializers))))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
127 |
(let ((method (car methods))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
128 |
(if (eq? (car method) 'constant-method) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
129 |
(let ((temp (gensym))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
130 |
(loop (cdr methods) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
131 |
(cons temp reversed-temporaries) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
132 |
(cons (caddr method) reversed-initializers) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
133 |
(cons `(method ,(cadr method) (ref ,temp)) transformed-methods))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
134 |
(loop (cdr methods) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
135 |
reversed-temporaries |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
136 |
reversed-initializers |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
137 |
(cons method transformed-methods))))))) |
9b22b7a23e39
Convert constant-methods to normal methods.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
200
diff
changeset
|
138 |
|
205
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
139 |
(define (alpha-convert-expr exp conversions) |
234
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
140 |
(define (convert-method method) |
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
141 |
`(,(car method) |
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
142 |
,(map (lambda (p) (alpha-convert-pattern p conversions)) (cadr method)) |
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
143 |
,(alpha-convert-expr (caddr method) conversions))) |
205
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
144 |
(case (car exp) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
145 |
((ref) `(ref ,(cond ((assq (cadr exp) conversions) => cadr) (else (cadr exp))))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
146 |
((lit) exp) |
234
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
147 |
((object) `(,(car exp) ,(cadr exp) ,@(map convert-method (cddr exp)))) |
10e62e160cb0
Switch from "[]" to "rec {}", and add "rec selfid {}" form
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
230
diff
changeset
|
148 |
((function) `(,(car exp) ,@(map convert-method (cdr exp)))) |
205
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
149 |
((tuple) `(tuple ,@(map (lambda (x) (alpha-convert-expr x conversions)) (cdr exp)))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
150 |
((send) `(send ,(alpha-convert-expr (cadr exp) conversions) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
151 |
,(alpha-convert-expr (caddr exp) conversions))))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
152 |
|
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
153 |
(define (alpha-convert-pattern pat conversions) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
154 |
(case (car exp) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
155 |
((discard) exp) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
156 |
((bind) `(bind ,(cond ((assq (cadr exp) conversions) => cadr) (else (cadr exp))))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
157 |
((lit) exp) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
158 |
((tuple) `(tuple ,@(map (lambda (p) (alpha-convert-pattern p conversions)) (cdr exp)))))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
159 |
|
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
160 |
(define (names-in-pattern p) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
161 |
(case (car p) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
162 |
((discard) '()) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
163 |
((bind) (list (cadr p))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
164 |
((lit) '()) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
165 |
((tuple) (append-map names-in-pattern (cdr p))))) |
0ab03377df02
Speculative utilities for alpha-conversion and bound-names-extraction.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
204
diff
changeset
|
166 |
|
183
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
167 |
(define (etng-sexp->string-tree e) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
168 |
(cond |
210
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
169 |
((pair? e) (cond |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
170 |
((and (eq? (car e) 'paren) |
218
e1adb1b53cc0
It's not an error (!) to have an empty (paren) etng-sexp.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
217
diff
changeset
|
171 |
(pair? (cdr e)) |
210
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
172 |
(equal? (cadr e) QUOTE-QNAME)) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
173 |
`("." ,(etng-sexp->string-tree (caddr e)))) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
174 |
(else |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
175 |
((case (car e) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
176 |
((paren) (lambda (es) `("(" ,es ")"))) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
177 |
((brack) (lambda (es) `("[" ,es "]"))) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
178 |
((brace) (lambda (es) `("{" ,es "}"))) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
179 |
(else (error 'illegal-sexp e))) |
3776775f3738
When printing eTNG sexps, treat quote specially (like a scheme pretty-printer
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
208
diff
changeset
|
180 |
(list-interleave " " (map etng-sexp->string-tree (cdr e))))))) |
183
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
181 |
((string? e) e) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
182 |
(else (->string e)))) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
183 |
|
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
184 |
(define (cons-tree-for-each f l) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
185 |
(let walk ((l l)) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
186 |
(if (pair? l) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
187 |
(begin (walk (car l)) (walk (cdr l))) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
188 |
(f l)))) |
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
189 |
|
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
190 |
(define (pp clue x . maybe-transformer) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
191 |
(pretty-print (list clue |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
192 |
(if (null? maybe-transformer) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
193 |
x |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
194 |
((car maybe-transformer) x)))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
195 |
(newline) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
196 |
x) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
197 |
|
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
198 |
(define (!pp clue x . maybe-transformer) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
199 |
x) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
200 |
|
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
201 |
(define (dump-string-tree t) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
202 |
(cons-tree-for-each (lambda (x) (or (null? x) (display x))) t) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
203 |
(newline)) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
204 |
|
211
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
205 |
(define (mark-position pos-path t) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
206 |
(if (null? pos-path) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
207 |
t |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
208 |
(call-with-values (lambda () (split-at t (car pos-path))) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
209 |
(lambda (left right) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
210 |
(if (null? (cdr pos-path)) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
211 |
(append left (list "<@@@@@>") right) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
212 |
(append left (list (mark-position (cdr pos-path) (car right))) (cdr right))))))) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
213 |
|
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
214 |
(define (display-parse-error clue err . maybe-ast) |
207
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
215 |
(display clue) |
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
216 |
(newline) |
211
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
217 |
(when (not (null? maybe-ast)) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
218 |
(dump-string-tree (etng-sexp->string-tree (car (mark-position (car err) |
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
219 |
(list (car maybe-ast))))))) |
207
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
220 |
(display (format-ometa-error err)) |
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
221 |
(newline)) |
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
222 |
|
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
223 |
(define (parse-print-and-eval sexp evaluator) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
224 |
;; (pp 'raw-sexp sexp) (newline) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
225 |
(dump-string-tree (etng-sexp->string-tree sexp)) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
226 |
(parse-etng* 'toplevel (list sexp) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
227 |
(lambda (ast dummy-next err) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
228 |
(if (null? (input-stream->list dummy-next)) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
229 |
(evaluator ast) |
211
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
230 |
(display-parse-error "Partial parse." err sexp))) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
231 |
(lambda (err) |
211
bd01f1a8bbae
Highlight position of syntax error in AST when printing it.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
210
diff
changeset
|
232 |
(display-parse-error "Unsuccessful parse." err sexp)))) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
233 |
|
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
234 |
(load "compile-to-scheme.scm") |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
235 |
|
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
236 |
(define (rude-evaluator input) |
227
da3853e42ca1
Make the repl a bit quieter.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
218
diff
changeset
|
237 |
(let* ((ast (!pp 'ast input)) |
da3853e42ca1
Make the repl a bit quieter.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
218
diff
changeset
|
238 |
(ast (!pp 'convert-constant-methods-pass (convert-constant-methods-pass ast))) |
da3853e42ca1
Make the repl a bit quieter.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
218
diff
changeset
|
239 |
(scheme-ast (!pp 'compile-to-scheme (compile-to-scheme ast))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
240 |
(thunk (!pp 'compile-scheme (eval `(lambda () ,scheme-ast)))) |
208
0fb5d58b308c
Cosmetic: move a close-paren to make cleaner future diffs on pass insertion.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
207
diff
changeset
|
241 |
) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
242 |
(write (thunk)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
243 |
(newline))) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
244 |
|
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
245 |
(define (etng-parse-file* filename evaluator) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
246 |
(call-with-input-file filename |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
247 |
(lambda (handle) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
248 |
(let loop ((input (->input-stream handle))) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
249 |
(read-etng-toplevel |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
250 |
input |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
251 |
(lambda (sexp0 next err) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
252 |
(if (eq? sexp0 'eof) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
253 |
'eof-reached |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
254 |
(let ((sexp (cons 'paren sexp0))) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
255 |
(parse-print-and-eval sexp evaluator) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
256 |
(when (and next (not (eq? next input))) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
257 |
(loop next))))) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
258 |
(lambda (error-description) |
207
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
259 |
(display-parse-error "Reader failure." error-description))))))) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
260 |
|
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
261 |
(define (etng-parse-file filename) |
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
262 |
(etng-parse-file* filename rude-evaluator)) |
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
263 |
|
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
264 |
(define (etng-repl* evaluator) |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
265 |
(let loop ((input (current-input-stream))) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
266 |
(display ">>ETNG>> ") |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
267 |
(flush-output) |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
268 |
(read-etng-toplevel |
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
269 |
input |
183
d6199b03d787
Simple etng-sexp printer.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
182
diff
changeset
|
270 |
(lambda (sexp0 next err) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
271 |
(if (eq? sexp0 'eof) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
272 |
'eof-reached |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
273 |
(let ((sexp (cons 'paren sexp0))) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
274 |
(parse-print-and-eval sexp evaluator) |
198
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
275 |
(when (and next (not (eq? next input))) |
072745b48add
Improve parser to the point where metaeval.tng at least parses.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
187
diff
changeset
|
276 |
(loop next))))) |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
277 |
(lambda (error-description) |
207
b913a690a851
Display read/parse errors in a friendlier style.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
205
diff
changeset
|
278 |
(display-parse-error "Reader failure." error-description) |
181
f82ec080be39
etng-r2, using ometa-scheme.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
279 |
(loop (current-input-stream)))))) |
199
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
280 |
|
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
281 |
(define (etng-repl) |
043539ed8a21
Add passes and a null pass.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
198
diff
changeset
|
282 |
(etng-repl* rude-evaluator)) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
283 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
284 |
(etng-parse-file "boot.tng") |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
211
diff
changeset
|
285 |
(etng-repl) |