smalltalk-tng

annotate etng-r2/compile-to-scheme.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 4d06e035b80e
children
rev   line source
tonyg@217 1 (define previous-inspector (current-inspector))
tonyg@217 2 (current-inspector (make-inspector))
tonyg@217 3
tonyg@278 4 (define-record-type etng-alternation
tonyg@278 5 (make-etng-alternation clauses)
tonyg@278 6 etng-alternation?
tonyg@278 7 (clauses etng-alternation-clauses))
tonyg@217 8
tonyg@217 9 (current-inspector previous-inspector)
tonyg@217 10
tonyg@217 11 ;---------------------------------------------------------------------------
tonyg@217 12
tonyg@221 13 (define etng-namespaces '())
tonyg@221 14 (define implicit-etng-namespace #f)
tonyg@221 15
tonyg@221 16 (define builtin-namespace-url "http://www.eighty-twenty.org/etng/r2/builtin#")
tonyg@221 17
tonyg@221 18 (define (set-etng-namespace! prefix url)
tonyg@221 19 (cond
tonyg@221 20 ((assq prefix etng-namespaces) =>
tonyg@221 21 (lambda (cell) (set-box! (cdr cell) url)))
tonyg@221 22 (else
tonyg@221 23 (set! etng-namespaces (cons (cons prefix (box url)) etng-namespaces)))))
tonyg@221 24
tonyg@221 25 (set-etng-namespace! '|| builtin-namespace-url)
tonyg@221 26
tonyg@221 27 (define (mangle-etng-id* url localname)
tonyg@221 28 (string->symbol (string-append "etng___" url (symbol->string localname))))
tonyg@221 29
tonyg@217 30 (define (mangle-etng-id id)
tonyg@217 31 (cond
tonyg@221 32 ((qname? id)
tonyg@221 33 (cond
tonyg@221 34 ((assq (qname-uri id) etng-namespaces) =>
tonyg@221 35 (lambda (entry)
tonyg@221 36 (mangle-etng-id* (unbox (cdr entry)) (qname-localname id))))
tonyg@221 37 (else
tonyg@221 38 (error 'unknown-qname-prefix id))))
tonyg@221 39 ((symbol? id)
tonyg@221 40 (if implicit-etng-namespace
tonyg@221 41 (mangle-etng-id* implicit-etng-namespace id)
tonyg@221 42 (mangle-etng-id* "" id)))
tonyg@217 43 (else (error 'invalid-etng-id id))))
tonyg@217 44
tonyg@221 45 (define (etng-send-via-named-proxy receiver localname message)
tonyg@221 46 (etng-send* receiver
tonyg@221 47 (namespace-variable-value (mangle-etng-id* builtin-namespace-url localname))
tonyg@221 48 message))
tonyg@221 49
tonyg@278 50 (define (etng-alternation->parser a)
tonyg@278 51 (lambda (input ks kf)
tonyg@278 52 (let loop ((clauses (etng-alternation-clauses a)))
tonyg@278 53 (if (null? clauses)
tonyg@278 54 (kf)
tonyg@278 55 ((car clauses) input ks (lambda () (loop (cdr clauses))))))))
tonyg@278 56
tonyg@278 57 (define (make-parser-invocation first-message)
tonyg@278 58 (let ((fragments-rev (make-parameter (list first-message))))
tonyg@278 59 (define (fragment-following f)
tonyg@278 60 (let search ((candidate #f)
tonyg@278 61 (fs (fragments-rev)))
tonyg@278 62 (cond
tonyg@278 63 ((null? fs) (error 'should-not-reach-here 'fragment-following))
tonyg@278 64 ((eq? (car fs) f) candidate)
tonyg@278 65 (else (search (car fs) (cdr fs))))))
tonyg@278 66 (define (remaining-input-following f)
tonyg@278 67 (let search ((acc '())
tonyg@278 68 (fs (fragments-rev)))
tonyg@278 69 (cond
tonyg@278 70 ((null? fs) (error 'should-not-reach-here 'fragment-following))
tonyg@278 71 ((eq? (car fs) f) acc)
tonyg@278 72 (else (search (append (car fs) acc) (cdr fs))))))
tonyg@278 73 (define (stream-fragment f)
tonyg@278 74 (let loop ((position f))
tonyg@278 75 (lambda (op k)
tonyg@278 76 (case op
tonyg@278 77 ((next)
tonyg@278 78 (if (null? position)
tonyg@278 79 (let ((next-fragment (fragment-following f)))
tonyg@278 80 (if next-fragment
tonyg@278 81 ((stream-fragment next-fragment) 'next k)
tonyg@278 82 (let ((so-far (fragments-rev)))
tonyg@278 83 (lambda (ignored-receiver)
tonyg@278 84 (lambda (message)
tonyg@278 85 (parameterize ((fragments-rev (cons message so-far)))
tonyg@278 86 ((stream-fragment message) 'next k)))))))
tonyg@278 87 (k (car position) (loop (cdr position)))))
tonyg@278 88 ((rest)
tonyg@278 89 (k (append position (remaining-input-following f))))
tonyg@278 90 (else
tonyg@278 91 (error 'invalid-op op))))))
tonyg@278 92 (stream-fragment first-message)))
tonyg@278 93
tonyg@278 94 (define (etng-lookup via message)
tonyg@278 95 (cond
tonyg@278 96 ((etng-alternation? via)
tonyg@278 97 ((etng-alternation->parser via)
tonyg@278 98 (make-parser-invocation message)
tonyg@278 99 (lambda (rhs-thunk-waiting-for-self remaining-input)
tonyg@278 100 (remaining-input 'rest
tonyg@278 101 (lambda (remaining-message)
tonyg@278 102 (if (null? remaining-message)
tonyg@278 103 rhs-thunk-waiting-for-self
tonyg@278 104 (lambda (receiver)
tonyg@278 105 (etng-send (rhs-thunk-waiting-for-self receiver)
tonyg@278 106 remaining-message))))))
tonyg@278 107 (lambda () #f)))
tonyg@278 108 ((procedure? via)
tonyg@278 109 (via message))
tonyg@278 110 (else 'invalid-via (list via message))))
tonyg@278 111
tonyg@278 112 (define (etng-directly-invokable? x)
tonyg@278 113 (or (procedure? x) ;; a parser-invocation, (lambda (message) ...)
tonyg@278 114 (etng-alternation? x) ;; a parser without invocation: see etng-lookup
tonyg@278 115 ))
tonyg@217 116
tonyg@217 117 (define (etng-send* receiver via message)
tonyg@217 118 (cond
tonyg@278 119 ((etng-directly-invokable? via)
tonyg@278 120 (let ((thunk (or (etng-lookup via message)
tonyg@221 121 (error 'does-not-understand receiver via message))))
tonyg@221 122 (thunk receiver)))
tonyg@217 123 ((number? via) (etng-send-via-named-proxy receiver 'numberProxy message))
tonyg@217 124 ((string? via) (etng-send-via-named-proxy receiver 'stringProxy message))
tonyg@229 125 ((qname-or-symbol? via) (etng-send-via-named-proxy receiver 'symbolProxy message))
tonyg@221 126 ((vector? via) (etng-send-via-named-proxy receiver 'tupleProxy message))
tonyg@221 127 ((not via) (etng-send-via-named-proxy receiver 'falseProxy message))
tonyg@221 128 ((eq? via #t) (etng-send-via-named-proxy receiver 'trueProxy message))
tonyg@217 129 (else (error 'illegal-primitive-object receiver via message))))
tonyg@217 130
tonyg@217 131 (define (etng-send receiver message)
tonyg@217 132 (etng-send* receiver receiver message))
tonyg@217 133
tonyg@219 134 (define (etng-merge-functions f1 f2)
tonyg@278 135 (make-etng-alternation (append (etng-alternation-clauses f1) (etng-alternation-clauses f2))))
tonyg@219 136
tonyg@217 137 (define (compile-to-scheme ast)
tonyg@217 138
tonyg@217 139 (define (schemeify tng-sexp)
tonyg@217 140 (if (pair? tng-sexp)
tonyg@217 141 (case (car tng-sexp)
tonyg@217 142 ((paren) (map schemeify (cdr tng-sexp)))
tonyg@217 143 (else (error 'brack-and-brace-illegal-in-scheme-assembly)))
tonyg@217 144 tng-sexp))
tonyg@217 145
tonyg@217 146 (define (make-definition id val)
tonyg@217 147 `(namespace-set-variable-value! ',(mangle-etng-id id) ,val))
tonyg@217 148
tonyg@217 149 (define (toplevel ast)
tonyg@217 150 (case (car ast)
tonyg@221 151 ((define-namespace) `(set-etng-namespace! ',(cadr ast) ',(caddr ast)))
tonyg@221 152 ((declare-default-namespace) `(set! implicit-etng-namespace ',(cadr ast)))
tonyg@217 153 ((define-value) (make-definition (cadr ast) (expr (caddr ast))))
tonyg@217 154 ((define-function) (make-definition (cadr ast) (expr `(function ,(caddr ast)))))
tonyg@217 155 (else (expr ast))))
tonyg@217 156
tonyg@217 157 (define (expr ast)
tonyg@217 158 (case (car ast)
tonyg@217 159 ((ref) (mangle-etng-id (cadr ast)))
tonyg@217 160 ((lit) `',(cadr ast))
tonyg@278 161 ((object) `(make-etng-alternation (list ,@(map (method (cadr ast)) (cddr ast)))))
tonyg@278 162 ((function) `(make-etng-alternation (list ,@(map (method #f) (cdr ast)))))
tonyg@217 163 ((tuple) `(vector ,@(map expr (cdr ast))))
tonyg@258 164 ((send) `(etng-send ,(expr (cadr ast)) (list ,@(map expr (cddr ast)))))
tonyg@217 165 ((assemble) `(let ,(map (lambda (binding)
tonyg@217 166 `(,(car binding) ,(expr (cadr binding))))
tonyg@217 167 (cadr ast))
tonyg@217 168 ,(schemeify (cadr (assq 'scheme (caddr ast))))))))
tonyg@217 169
tonyg@258 170 (define (pattern p on-success on-failure)
tonyg@258 171 (case (car p)
tonyg@258 172 ((discard) on-success)
tonyg@258 173 ((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success))
tonyg@258 174 ((lit) `(if (equal? ',(cadr p) _arg)
tonyg@258 175 ,on-success
tonyg@258 176 ,on-failure))
tonyg@258 177 ((tuple) `(if (and (vector? _arg)
tonyg@258 178 (= (vector-length _arg) ,(length (cdr p))))
tonyg@258 179 ,(let ((tuple-name (gensym '_argtuple)))
tonyg@258 180 `(let ((,tuple-name _arg))
tonyg@258 181 ,(let match-elts ((elts (cdr p))
tonyg@258 182 (index 0))
tonyg@258 183 (if (null? elts)
tonyg@258 184 on-success
tonyg@258 185 `(let ((_arg (vector-ref ,tuple-name ,index)))
tonyg@258 186 ,(pattern (car elts)
tonyg@258 187 (match-elts (cdr elts) (+ index 1))
tonyg@258 188 on-failure))))))
tonyg@258 189 ,on-failure))))
tonyg@258 190
tonyg@234 191 (define (method self-id)
tonyg@217 192 (lambda (ast)
tonyg@278 193 (let ((body (caddr ast)))
tonyg@278 194 `(lambda (_stream _kt _kf)
tonyg@278 195 ,(let loop ((patterns (cadr ast)))
tonyg@278 196 `(_stream 'next
tonyg@278 197 (lambda (_arg _stream)
tonyg@278 198 ,(let* ((remaining-patterns (cdr patterns)))
tonyg@278 199 (pattern (car patterns)
tonyg@278 200 (if (null? remaining-patterns)
tonyg@278 201 `(_kt (lambda (,(if self-id
tonyg@278 202 (mangle-etng-id self-id)
tonyg@278 203 '_self))
tonyg@278 204 ,(expr body))
tonyg@278 205 _stream)
tonyg@278 206 (loop remaining-patterns))
tonyg@278 207 `(_kf))))))))))
tonyg@217 208
tonyg@217 209 (toplevel ast))