source: project/release/4/miniML/trunk/miniMLeval.scm @ 22116

Last change on this file since 22116 was 22116, checked in by Ivan Raikov, 10 years ago

miniML: capitalizing element names in SXML representation

File size: 8.3 KB
Line 
1;;
2;;  A type checker and interpreter for a simple ML-like language.
3;;
4;;  Based on the code and paper by Xavier Leroy (2000): A modular
5;;  module system. Journal of Functional Programming, 10, pp 269-303
6;;  doi:10.1017/S0956796800003683
7;;
8;;
9;; Copyright 2010 Ivan Raikov and the Okinawa Institute of
10;; Science and Technology.
11;;
12;; This program is free software: you can redistribute it and/or
13;; modify it under the terms of the GNU General Public License as
14;; published by the Free Software Foundation, either version 3 of the
15;; License, or (at your option) any later version.
16;;
17;; This program is distributed in the hope that it will be useful, but
18;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20;; General Public License for more details.
21;;
22;; A full copy of the GPL license can be found at
23;; <http://www.gnu.org/licenses/>.
24;;
25
26(module miniMLeval
27
28        (
29         Value_def Type_def Module_def
30         value? Const_v Closure_v Prim_v Tuple_v 
31         core-eval-cbv eval-cbv-initialize mod-eval-cbv
32         eval-env-entry->sxml eval-env->sxml
33         )
34
35        (import scheme chicken)
36
37        (require-extension datatype static-modules miniML miniMLsyntax)
38        (import (only data-structures compose)
39                (only srfi-1 fold filter member delete-duplicates)
40                (only extras pp fprintf))
41
42
43(define (freevars t bnds ax)
44  (cases term t 
45         (Let0 (i v b)
46          (let ((bnds1 (cons i bnds)))
47            (freevars b bnds1 (freevars v bnds ax))))
48         (Apply (t1 t2)   
49                (freevars t1 bnds (freevars t2 bnds ax)))
50         (Longid (p) 
51                 (cases path p
52                        (Pident (s) (if (not (member s bnds ident-equal?)) (cons s ax) ax))
53                        (Pdot (p s) (let recur ((p p) (ax ax))
54                                      (cases path p
55                                             (Pident (s)  (if (not (member s bnds ident-equal?)) (cons s ax) ax))
56                                             (Pdot (p s)  (recur p ax)))))))
57         (Function (i t) 
58                   (let ((bnds1 (cons i bnds)))
59                     (freevars t bnds1 ax)))
60
61         (Const (c) ax)))
62
63;; values
64
65(define-datatype value value?
66  (Const_v    (c constant?))
67  (Closure_v  (body term?) (env list?))
68  (Prim_v     (v procedure?))
69  (Tuple_v    (slots (lambda (x) (or (pair? x) (null? x))))))
70
71
72(define-record-printer (value x out)
73  (fprintf out "#<value ~S>"
74           (cases value x
75                  (Const_v (c) `(Const ,c))
76                  (Closure_v (body env) 
77                             (if (null? env) `(Closure ,body ())
78                                 `(Closure ,body (,(car env) ...))))
79                  (Prim_v (p) `(Prim ,p))
80                  (Tuple_v (d) `(Data ,d)))))
81
82
83(define-inline (constval c)
84  (cases value c
85         (Const_v (c) (cadr c))
86         (else (error 'constval "invalid constant" c))))
87
88
89(define-values ( env-binding? env-empty env-add-signature env-add-module env-add-type env-add-spec env-add-value
90                 env-find-value env-find-type env-find-module env-find)
91  (make-mod-env core-syntax))
92
93
94(define init-scope (make-parameter st-empty))
95(define init-env   (make-parameter env-empty))
96
97(define (enter-typedecl id decl)
98  (init-scope (st-enter-type id (init-scope)))
99  (init-env   (env-add-type id decl (init-env))))
100
101(define (enter-valtype name ty)
102  (let ((id (ident-create name)))
103    (init-scope (st-enter-value id (init-scope)))
104    (init-env   (env-add-value id ty (init-env)))))
105
106(define (enter-val* name val env)
107  (let ((id (or (and (ident? name) name) (ident-create name))))
108    (ident-add id val env)))
109
110
111(define (ident= x y)
112  (equal? (ident-name x) (ident-name y)))
113
114(define (core-eval-cbv t env)
115
116  (define (eval t env)
117    (cases term t
118           (Const (c) (Const_v c))
119
120           (Longid (p) 
121                   (let ((vp (path-find-val p env)))
122                     (or vp (error 'ML-core-eval "unknown id" p))))
123
124           (Function (_ _) 
125                     (let* ((fv (delete-duplicates (freevars t '() '()) ident=))
126                            (env1 (filter (lambda (x) (member (car x) fv ident=)) env)))
127                       (Closure_v t env1)))
128
129           (Apply (funct arg) 
130                  (let ((fv (eval funct env)))
131                    (cases value fv
132                           
133                           (Closure_v (body env1)
134                                      (cases term body 
135                                             (Function (param body)
136                                                       (let ((env2 (enter-val* param (eval arg env) env1)))
137                                                         (eval body env2)))
138                                             
139                                             (else
140                                              (error 'ML-core-eval "function expected in application" t))))
141
142                           (Prim_v (proc)  (proc env arg))
143                           
144                           (else
145                            (error 'ML-core-eval "function expected in application" t fv)))))
146
147           (Let0 (id arg body)
148                 (let ((env1 (enter-val* id (eval arg env) env)))
149                   (eval body env1)))
150
151           (else
152            (error 'ML-core-eval "invalid term" t))
153
154           ))
155  (eval t env))
156
157
158(define (prim-binop-cbv eval-closure name op)
159  (Prim_v (lambda (xenv x)
160            (let ((x (eval-closure (Closure_v x xenv))))
161              (Prim_v (lambda (yenv y) (op x (eval-closure (Closure_v y yenv)))))))))
162
163
164(define (eval-cbv-initialize enter-val)
165       
166          (define eval core-eval-cbv)
167       
168          (define (eval-closure name)
169            (lambda (x)
170              (cases value x
171                     (Closure_v (x xenv) (eval x xenv))
172                     (else (error name "closure expected" x)))))
173         
174          (begin
175
176            (enter-val "false"  (Const_v `(bool #f) ))
177            (enter-val "true"   (Const_v `(bool #t) ))
178            (enter-val "empty"  (Tuple_v '()) )
179            (enter-val "null"   (Tuple_v '()) )
180       
181            (for-each
182             (lambda (name op) 
183               (enter-val
184                name
185                (prim-binop-cbv (eval-closure name) name 
186                 (lambda (x y) 
187                   (let ((xv (constval x))
188                         (yv (constval y)))
189                     (Const_v `(nat ,(op xv yv))))))))
190             '("add" "sub" "mul" "div" 
191               "==" "<>" "<" "<=" ">" ">=")
192             (list + - * / 
193                   = (compose not =) < <= > >=))
194       
195            (enter-val
196             "cond" 
197             (Prim_v 
198              (lambda (cenv c) 
199                (Prim_v 
200                 (lambda (tenv t) 
201                   (Prim_v 
202                    (lambda (fenv f) 
203                      (let ((cv (constval (eval cenv c))))
204                        (or (and cv ((eval-closure 'cond) (Closure_v t tenv)))
205                            ((eval-closure 'cond) (Closure_v f fenv)))))))))))
206       
207            (enter-val 
208             "pair" 
209             (prim-binop-cbv (eval-closure 'pair)
210              'pair (lambda (x y) (Tuple_v (cons x y)))))
211       
212            (enter-val
213             "fst" 
214             (Prim_v
215              (lambda (env x) 
216                (cases value (eval x env)
217                       (Tuple_v (p) (if (pair? p) (car p)
218                                       (error 'fst "empty data element" x)))
219                       (else
220                        (error 'fst "invalid data element" x))))))
221       
222            (enter-val
223             "snd" 
224             (Prim_v
225              (lambda (env x) 
226                (cases value (eval x env)
227                       (Tuple_v (p) (if (pair? p) (cadr p)
228                                        (error 'snd "empty data element" x)))
229                       (else
230                        (error 'snd "invalid data element" x))))))
231           
232            (enter-val 
233             "cons" 
234             (prim-binop-cbv (eval-closure 'cons)
235              'cons (lambda (x y) (Tuple_v (cons x y)))))
236       
237            (enter-val
238             "head" 
239             (Prim_v
240              (lambda (env x) 
241                (cases value (eval x env)
242                       (Tuple_v (p) (if (pair? p) (car p)
243                                       (error 'head "empty data element" x)))
244                       (else
245                        (error 'head "invalid data element" x))))))
246
247
248            (enter-val
249             "tail" 
250             (Prim_v
251              (lambda (env x) 
252                (cases value (eval x env)
253                       (Tuple_v (p) (if (pair? p) (Tuple_v (cdr p))
254                                        (error 'tail "empty data element" x)))
255                       (else
256                        (error 'tail "invalid data element" x))))))
257           
258           
259            ))
260
261(define mod-eval-cbv (make-mod-eval core-eval-cbv enter-val*))
262
263
264(define (value->sxml v)
265
266      (cases value v
267             (Const_v     (c)       `(Const ,(const->sxml c)))
268             
269             (Prim_v      (proc)    `(Prim))
270             
271             (Tuple_v      (slots)   (if (null? slots) `(null)
272                                        `(Tuple (left ,(value->sxml (car slots)))
273                                                (right ,(value->sxml (cdr slots))))))
274             
275             (Closure_v   (body env)
276                            `(Closure (body ,(term->sxml body))
277                                      (env  ,@(eval-env->sxml env))))
278             ))
279
280(define (modval->sxml name v)
281  (cases modval v
282         (Structure_v (env) 
283                      `(Component (@ (name ,name)) . ,(eval-env->sxml env)))
284         (Mclosure_v  (body env) 
285                      `(Modclosure  (@ (name ,name))
286                                    (body ,(modterm->sxml body))
287                                    (env . ,@(eval-env->sxml env))))))
288
289(define (eval-env-entry->sxml x)
290  (let ((id (car x))
291        (v  (cdr x)))
292    (cond ((value? v)
293           `(Binding (@ (name ,(ident-name id))) (value ,(value->sxml v))))
294          ((moddef? v)
295           (moddef->sxml v))
296          ((modval? v)
297           (modval->sxml (ident-name id) v))
298          (else (error 'eval-env-entry->sxml "invalid entry" x)))))
299     
300
301(define (eval-env->sxml env) (map eval-env-entry->sxml env))
302
303 
304
305)
Note: See TracBrowser for help on using the repository browser.