smalltalk-tng

view etng-r1/oo.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 d4a524efd9c5
children
line source
1 ;; Representation of values.
2
3 ;; Values can be:
4 ;; - fully-expanded qnames, i.e. uri-and-localname pairs
5 ;; - words ("integers")
6 ;; - byte-vectors (bases for strings)
7 ;; - tuples
8 ;; - messages (?)
9 ;; - objects
10 ;; - functions (objects that don't have a self)
11
12 ;; Patterns can be:
13 ;; - discard
14 ;; - messages (?)
15 ;; - bindings
16 ;; - tuples
17 ;; - literals, ie. words, qnames, byte-vectors (?)
18
19 ;; Objects and functions differ only in whether they bind self for the
20 ;; RHS of their method-bodies or not. Otherwise, they are logically an
21 ;; ordered list of mappings from pattern to closure. Thus an object
22 ;; template has an environment template specifying what features of
23 ;; the lexical environment are to be closed over, and an object itself
24 ;; has an environment vector containing the closed-over values.
25 ;;
26 ;; We represent the ordered list using unordered data structures such
27 ;; as hash tables where doing so is indistinguishable from preserving
28 ;; the full ordering of the member clauses of the object.
29 ;;
30 ;; Note that objects can be constructed from smaller objects by
31 ;; application of the traits operators '/', '+', '-' and '@'.
32
33 ;; words < qnames < byte-vectors
34 (define (lit<? a b)
35 (cond
36 ((number? a) (cond
37 ((number? b) (< a b))
38 (else #t)))
39 ((qname? a) (cond
40 ((qname? b) (or (string<? (qname-uri a) (qname-uri b))
41 (and (string=? (qname-uri a) (qname-uri b))
42 (string<? (symbol->string (qname-localname a))
43 (symbol->string (qname-localname b))))))
44 ((number? b) #f)
45 (else #t)))
46 ((string? a) (cond
47 ((string? b) (string<? a b))
48 (else #f)))))
49
50 ;---------------------------------------------------------------------------
51 ; MzScheme magic
52 (print-struct #t)
53 (define previous-inspector (current-inspector))
54 (current-inspector (make-inspector))
55 ;---------------------------------------------------------------------------
56
57 (define-record-type tng-pattern
58 (make-pattern* kind datum)
59 pattern?
60 (kind pattern-kind)
61 (datum pattern-datum))
62
63 (define-record-type tng-pattern-closure
64 (make-pattern-closure code env saved-self)
65 pattern-closure?
66 (code pattern-closure-code)
67 (env pattern-closure-env)
68 (saved-self pattern-closure-saved-self))
69
70 ;---------------------------------------------------------------------------
71 ; MzScheme magic
72 (current-inspector previous-inspector)
73 ;---------------------------------------------------------------------------
74
75 ;; Currying of patterns:
76 ;;
77 ;; Methods: [([Pattern] * Body)]
78 ;; Dispatch tree:
79 ;;
80 ;; - may be no patterns at all! (error situation)
81
82
83 (define (make-etng-object methods env saved-self)
84
85 (define (prepend-one patterns body accumulated-patterns)
86 (if (or (null? accumulated-patterns)
87 (not (aggregatable? patterns %%%%HERE ...
88
89 (let loop ((methods methods)
90 (rev-patterns '()))
91 (if (null? methods)
92 (reverse rev-patterns)
93 (let ((method (car methods)))
94 (loop (cdr methods)
95 (node-match method
96 ((core-constant patterns body)
97 (prepend-one patterns
98 (make-node 'core-lit
99 'value (error 'need-to-have-evaluated-already body))
100 rev-patterns))
101 ((core-method patterns body)
102 (prepend-one patterns
103 body
104 rev-patterns))))))))
105
106 (define (etng-match patterns value sk-outer fk-outer)
107
108 (define (match-tuple pats vals bindings sk fk)
109 (let ((tuple-length (vector-length pats)))
110 (let tuple-loop ((index 0)
111 (bindings bindings))
112 (if (= index tuple-length)
113 (sk bindings)
114 (match-pat (vector-ref pats index)
115 (vector-ref vals index)
116 bindings
117 (lambda (new-bindings) (tuple-loop (+ index 1) new-bindings))
118 fk)))))
119
120 (define (match-pat pat value bindings sk fk)
121 (let ((d (pattern-datum pat)))
122 (case (pattern-kind pat)
123 ((literals)
124 (let ((subpat (hash-table-get d value #f)))
125 (if subpat
126 (sk bindings)
127 (fk))))
128 ((tuples)
129 (if (vector? value)
130 (let ((probe-index (vector-length value)))
131 (if (>= probe-index (vector-length d))
132 (fk)
133 (let ((subpats (vector-ref d probe-index)))
134 (if subpats
135 (match-tuple subpats value bindings sk fk)
136 (fk)))))
137 (fk)))
138 ((binding)
139 (sk (cons (cons d value) bindings)))
140 (else
141 (error 'invalid-etng-match-pattern pat)))))
142
143 (let match-alternatives ((patterns patterns))
144 (if (null? patterns)
145 (fk)
146 (let* ((pat-and-closure (car patterns))
147 (pat (car pat-and-closure))
148 (clo (cdr pat-and-closure))
149 (next-match (lambda () (match-alternatives (cdr patterns)))))
150 (match-pat pat
151 value
152 (lambda (bindings)
153 (sk-outer bindings clo next-match))
154 next-match)))))