smalltalk-tng

view etng-r1/main.scm @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents 1025f8d25eb3
children
line source
1 (require (lib "1.ss" "srfi") ;; lists
2 (lib "4.ss" "srfi") ;; homogeneous-numeric-vectors, u8vector
3 (lib "8.ss" "srfi") ;; receive
4 (lib "9.ss" "srfi") ;; records
5 (lib "13.ss" "srfi") ;; strings
6 (only (lib "list.ss") mergesort)
7 (lib "pretty.ss")
8 (lib "packrat.ss" "json-scheme"))
9
10 ;; SRFI-31, "A special form rec for recursive evaluation"
11 (define-syntax rec
12 (syntax-rules ()
13 ((rec (NAME . VARIABLES) . BODY)
14 (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME))
15 ((rec NAME EXPRESSION)
16 (letrec ( (NAME EXPRESSION) ) NAME))))
17
18 (print-struct #t)
19 (define previous-inspector (current-inspector))
20 (current-inspector (make-inspector))
21
22 (define-record-type tng-qname
23 (make-qname uri localname)
24 qname?
25 (uri qname-uri)
26 (localname qname-localname))
27
28 (current-inspector previous-inspector)
29
30 (load "node.scm")
31 (load "expand-qname.scm")
32 (load "alternaparse.scm")
33 ;;(load "oo.scm")
34
35 (define (generic-node-map fn node)
36 (let visit ((node node))
37 (cond
38 ((node? node)
39 (fn node
40 (lambda ()
41 (make-node* (node-kind node)
42 (map (lambda (field) (list (car field) (visit (cadr field))))
43 (node-fields node))))))
44 ((pair? node)
45 (cons (visit (car node))
46 (visit (cdr node))))
47 (else
48 (fn node
49 (lambda ()
50 node))))))
51
52 (define (gen-random-string charcount)
53 (list->string
54 (let gen ((charcount charcount))
55 (if (zero? charcount)
56 '()
57 (cons (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
58 (random 64))
59 (gen (- charcount 1)))))))
60
61 (define (genqname)
62 (make-qname "http://eighty-twenty.org/etng/r1/ns/etng/gensyms#"
63 (string->uninterned-symbol (gen-random-string 16))))
64
65 (define *debug-mode* '(sequence-phases))
66
67 (define (valid-namespace-prefix? x)
68 (symbol? x))
69
70 (define etng-r1-languages
71 `(
72 (toplevel-command
73 (%or
74 (command-define-namespace (prefix ,valid-namespace-prefix?) (uri ,string?))
75 (command-define-values (pattern data-pattern) (value core-exp))
76 (command-define-object (name ,qname?) (args (%list-of data-pattern)) (body core-exp))
77 (command-exp (value core-exp))))
78
79 (core-exp
80 (%or
81 (core-send (receiver core-exp) (message core-exp))
82 (core-object (methods (%list-of core-method)))
83 (core-function (methods (%list-of core-method)))
84 (core-message (parts (%list-of core-exp)))
85 (core-ref (name ,qname?))
86 (core-tuple (elements (%list-of core-exp)))
87 (core-lit (value #t))
88 ))
89
90 (core-method
91 (%or
92 (core-constant (patterns (%list-of data-pattern)) (body core-exp))
93 (core-method (patterns (%list-of data-pattern)) (body core-exp))
94 ))
95
96 (data-pattern
97 (%or
98 (pat-discard)
99 (pat-binding (name ,qname?))
100 (pat-tuple (elements (%list-of data-pattern)))
101 (pat-lit (value #t))))
102
103 (med-exp
104 (%or
105 med-object
106 (med-send (receiver med-exp) (message med-exp))
107 (med-tuple (elements (%list-of med-exp)))
108 (med-lit (value #t))
109 (med-ref (name ,qname?))
110 (med-self)
111 (med-super)
112 ))
113
114 (med-object
115 (%or
116 (med-discard (k med-exp))
117 (med-bind (name ,qname?) (k med-exp))
118 (med-litmatch (value #t) (match-k med-exp) (nomatch-k med-exp))
119 (med-tuplematch (arity ,integer?) (match-k med-exp) (nomatch-k med-exp))
120 (med-extend (over med-exp) (under med-exp))
121 ))
122
123 ))
124
125 (define (stdin-results)
126 (packrat-port-results "<stdin>" (current-input-port)))
127
128 (define (debug-mode=? what)
129 (and (memq what *debug-mode*) #t))
130
131 (define (etng-eval-node ast qname-env)
132 (let ((expanded (expand-qnames ast qname-env)))
133 (pretty-print (node->list expanded))
134 (node-match expanded
135 ((command-define-namespace prefix uri)
136 (extend-qname-env qname-env prefix uri))
137 (else
138 qname-env))))
139
140 (define (pp clue x . maybe-transformer)
141 (pretty-print (list clue
142 (if (null? maybe-transformer)
143 x
144 ((car maybe-transformer) x))))
145 (newline)
146 x)
147
148 (define (!pp clue x . maybe-transformer)
149 x)
150
151 (define (etng-repl)
152 (let loop ((qname-env (extend-qname-env* `((,(string->symbol "") .
153 "http://eighty-twenty.org/etng/r1/ns/etng#")
154 (#f . ""))
155 '())))
156 (display ">>ETNG>> ")
157 (flush-output)
158 (let ((results (stdin-results)))
159 (read-etng results
160 (lambda (sexp next)
161 (pp 'raw-sexp sexp)
162 (display (etng-sexp->string '() sexp)) (newline)
163 (let* ((ast (pp 'ast (etng-sexp-parse sexp qname-env) node->list)))
164 (if (check-language ast 'core-exp etng-r1-languages #f)
165 (display ";; Language check passed")
166 (error "Failed language check")))
167 (newline)
168 (when (and next (not (eq? next results)))
169 (loop qname-env)))
170 (lambda (error-description)
171 (pretty-print error-description)
172 (loop qname-env))))))
173
174 ;;; Local Variables:
175 ;;; eval: (put 'node-match 'scheme-indent-function 1)
176 ;;; eval: (put 'rec 'scheme-indent-function 1)
177 ;;; End: