source: project/release/4/static-modules/static-modules.scm @ 18057

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

added a copyright notice to static-modules

File size: 26.2 KB
Line 
1;;
2;;  A language-independent module system, suitable for
3;;  statically-typed languages.
4;;
5;;  Based on the code and paper by Xavier Leroy (2000): A modular
6;;  module system. Journal of Functional Programming, 10, pp 269-303
7;;  doi:10.1017/S0956796800003683
8;;
9;;
10;; Copyright 2010 Ivan Raikov and the Okinawa Institute of
11;; Science and Technology.
12;;
13;; This program is free software: you can redistribute it and/or
14;; modify it under the terms of the GNU General Public License as
15;; published by the Free Software Foundation, either version 3 of the
16;; License, or (at your option) any later version.
17;;
18;; This program is distributed in the hope that it will be useful, but
19;; WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21;; General Public License for more details.
22;;
23;; A full copy of the GPL license can be found at
24;; <http://www.gnu.org/licenses/>.
25;;
26
27(module static-modules
28       
29        (ident? ident-name ident-stamp ident-create ident-equal? ident-empty ident-add ident-find
30         path? Pident Pdot path-equal? subst-path subst-identity
31         typedecl? make-typedecl typedecl-manifest typedecl-kind
32         st-empty st-enter-value st-enter-type st-enter-module
33         st-value-path st-type-path st-module-path st-scope-module 
34
35         make-core-syntax make-core-typing make-core-scoping
36         core-syntax? core-typing? core-scoping?
37         make-mod-syntax make-mod-env make-mod-typing make-mod-scoping
38
39         modval? Structure_v Mclosure_v path-find-val find-module-val make-mod-eval
40         )
41
42        (import scheme chicken)
43        (import (only data-structures alist-ref)
44                (only extras fprintf))
45
46        (require-extension srfi-1 datatype)
47
48
49;; Section 2.1: Identifiers
50
51
52(define-record-type ident
53  (make-ident name stamp)
54  ident?
55  (name   ident-name) 
56  (stamp  ident-stamp)
57  )
58
59(define-record-printer (ident x out)
60  (fprintf out "~A" (ident-name x)))
61
62(define-values (ident-create ident-equal? ident-empty ident-add ident-find)
63  (letrec ((currstamp 0)
64           (create (lambda (s) (set! currstamp (+ 1 currstamp))
65                           (make-ident s currstamp)))
66           (equal (lambda (id1 id2) (= (ident-stamp id1) 
67                                        (ident-stamp id2))))
68           (empty '())
69           (add   (lambda (id data tbl) 
70                    (cons (cons id data) tbl)))
71           (compare (lambda (x y) (equal? (ident-name x) (ident-name y))))
72           (find  (lambda (id1 tbl)
73                    (alist-ref id1 tbl compare))))
74    (values create equal empty add find)))
75
76
77;; Section 2.2: Access paths
78
79(define-datatype path path?
80  (Pident (id ident?)) ;; identifier
81  (Pdot (p path?) (s string?))) ;; access to a module component
82
83(define-record-printer (path x out)
84  (cases path x
85         (Pident (id) (fprintf out "~A" (ident-name id)))
86         (Pdot (p s)  (fprintf out "~A.~A" p s))))
87
88(define (path-equal? p1 p2)
89  (cases path p1 
90         (Pident (id1) 
91                 (cases path p2
92                        (Pident (id2) (ident-equal? id1 id2))
93                        (else #f)))
94         (Pdot (r1 field1)
95               (cases path p2
96                      (Pdot (r2 field2)
97                            (and (path-equal? r1 r2)
98                                 (equal? field1 field2)))
99                      (else #f)))
100         (else #f)))
101
102;; Section 2.3: Substitutions
103
104(define-values (subst-identity subst-add subst-path)
105  (letrec ((identity ident-empty)
106           (add ident-add)
107           (path  (lambda (p sub)
108                    (cases path p
109                           (Pident (id) (or (ident-find id sub) p))
110                           (Pdot (root field) (Pdot (path root sub) field))))))
111    (values identity add path)))
112
113;; Section 2.4: Abstract syntax for the base language
114
115(define-record-type core-syntax
116  (make-core-syntax term? valtype? deftype? kind? make-valtype make-deftype subst-valtype subst-deftype subst-kind)
117  core-syntax?
118  (term?          cs-term?)
119  (valtype?       cs-valtype?)
120  (deftype?       cs-deftype?)
121  (kind?          cs-kind?)
122  (make-valtype   cs-make-valtype)
123  (make-deftype   cs-make-deftype)
124  (subst-valtype  cs-subst-valtype) 
125  (subst-deftype  cs-subst-deftype)
126  (subst-kind     cs-subst-kind)
127  )
128
129
130;; Section 2.5: Abstract syntax for the module language
131
132
133(define-record-type typedecl
134  (make-typedecl kind manifest)
135  typedecl?
136  (kind      typedecl-kind) 
137  (manifest  typedecl-manifest) ;; abstract or manifest type
138  )
139
140
141(define (make-mod-syntax core)
142
143  (define (modsig? x) (every modspec? x))
144
145  (define-datatype modtype modtype?
146    (Signature (s modsig?)) ;; sig ... end
147    (Functorty (id ident?) (mty1 modtype?) (mty2 modtype?))) ;; functor (X: mty) mty
148
149  (define-datatype modspec modspec?
150    (Value_sig  (id ident?) (valtype (cs-valtype? core))) ;; val x: ty
151    (Type_sig   (id ident?) (decl typedecl?)) ;; type t :: k [= ty]
152    (Module_sig (id ident?) (ty modtype?))) ;; module X: mty
153
154  (define (modstruct? x) (every moddef? x))
155
156  (define-datatype modterm modterm?
157    (Modid      (p path?))  ;; X or X.Y.Z
158    (Structure  (s modstruct?)) ;; struct ... end
159    (Functor    (id ident?) (mty modtype?) (m modterm?)) ;; functor (X: mty) mod
160    (Mapply     (m1 modterm?) (m2 modterm?)) ;; mod1 (mod2)
161    (Constraint (m modterm?) (mty modtype?)))
162
163  (define-datatype moddef moddef?
164    (Value_def  (id ident?) (term (cs-term? core)))
165    (Type_def   (id ident?) (kind (cs-kind? core)) 
166                (defty (cs-deftype? core)))
167    (Module_def (id ident?) (m modterm?)))
168
169
170
171  (define subst-kind (cs-subst-kind core))
172  (define subst-deftype (cs-subst-deftype core))
173  (define subst-valtype (cs-subst-valtype core))
174
175  (define (subst-typedecl decl sub)
176    (let ((manifest (typedecl-manifest decl)))
177      (make-typedecl (subst-kind (typedecl-kind decl) sub)
178                     (and manifest
179                          (subst-deftype manifest sub)))))
180                         
181
182  (define (subst-modtype mty sub)
183    (cases modtype mty
184           (Signature (sig) 
185                      (Signature (map (lambda (x) (subst-modspec x sub)) sig)))
186           (Functorty (id mty1 mty2)
187                      (Functorty id (subst-modtype mty1 sub) (subst-modtype mty2 sub)))))
188
189  (define (subst-modspec x sub)
190    (cases modspec x
191           (Value_sig (id vty)  (Value_sig id (subst-valtype vty sub)))
192           (Type_sig (id decl)  (Type_sig id (subst-typedecl decl sub)))
193           (Module_sig (id mty) (Module_sig id (subst-modtype mty sub)))))
194
195  (values modtype? Signature Functorty 
196          modspec? Value_sig Type_sig Module_sig
197          modterm? Modid Structure Functor Mapply Constraint
198          moddef? Value_def Type_def Module_def
199          subst-modtype subst-modspec subst-typedecl)
200
201)
202
203;; Section 2.6: The environment structure
204
205(define (make-mod-env core)
206  (let-values ((( modtype? Signature Functorty 
207                  modspec? Value_sig Type_sig Module_sig
208                  modterm? Modid Structure Functor Mapply Constraint
209                  moddef? Value_def Type_def Module_def
210                  subst-modtype subst-modspec subst-typedecl ) 
211                (make-mod-syntax core)))
212
213    (define valtype? (cs-valtype? core))
214    (define subst-valtype (cs-subst-valtype core))
215
216    (define-datatype binding binding?
217      (Value    (v valtype?))
218      (Type     (decl typedecl?))
219      (Module_  (t modtype?)))
220
221    (define empty ident-empty)
222
223    (define (add-value id vty env) (ident-add id (Value vty) env))
224    (define (add-type id decl env) (ident-add id (Type decl) env))
225    (define (add-module id mty env) (ident-add id (Module_ mty) env))
226
227    (define (add-spec item env)
228      (cases modspec item 
229             (Value_sig (id vty)  (add-value id vty env))
230             (Type_sig (id decl)  (add-type id decl env))
231             (Module_sig (id mty) (add-module id mty env))))
232
233    (define add-signature  (lambda (sig env) (fold-right add-spec env sig)))
234
235    (define (find p env)
236      (cases path p
237             (Pident (id) (ident-find id env))
238             (Pdot (root field)
239                   (cases modtype (find-module root env)
240                          (Signature (sig) 
241                                     (find-field root field subst-identity sig))
242                          (else (error 'find-field "structure expected in dot access"))))))
243                                                 
244    (define (find-field p field subst lst)
245      (if (null? lst)
246          (error 'find-field "No such field in structure")
247          (let ((x (car lst)))
248            (cases modspec x
249                   (Value_sig (id vty)
250                              (if (equal? (ident-name id) field)
251                                  (Value (subst-valtype vty subst))
252                                  (find-field p field subst (cdr lst))))
253
254                   (Type_sig (id decl)
255                             (if (equal? (ident-name id) field)
256                                 (Type (subst-typedecl decl subst))
257                                 (find-field p field
258                                             (subst-add id (Pdot p (ident-name id)) subst) 
259                                             (cdr lst))))
260
261                   (Module_sig (id mty)
262                               (if (equal? (ident-name id) field)
263                                   (Module_ (subst-modtype mty subst))
264                                   (find-field p field
265                                               (subst-add id (Pdot p (ident-name id)) subst)
266                                               (cdr lst))))))))
267
268    (define (find-value path env)
269      (let ((b (find path env)))
270        (cases binding b
271               (Value (vty) vty)
272               (else (error 'find-value "value field expected" b)))))
273
274
275    (define (find-type path env)
276      (let ((b (find path env)))
277        (cases binding b
278               (Type (decl) decl)
279               (else (error 'find-type "type field expected" b)))))
280
281
282    (define (find-module path env)
283      (let ((b (find path env)))
284        (cases binding b
285               (Module_ (mty) mty)
286               (else (error 'find-module "module field expected" b)))))
287
288
289    (values binding? empty 
290            add-signature add-module add-type add-spec add-value
291            find-value find-type find-module find
292            )
293   
294    ))
295
296;; Section 2.7: Type-checking the base language *)
297
298
299(define-record-type core-typing
300  (make-core-typing type-term kind-deftype check-valtype check-kind
301                    valtype-match deftype-equiv kind-match deftype-of-path)
302  core-typing?
303  ;; Typing functions
304  (type-term          ct-type-term)
305  (kind-deftype       ct-kind-deftype)
306  (check-valtype      ct-check-valtype)
307  (check-kind         ct-check-kind)
308  ;; Type matching functions
309  (valtype-match     ct-valtype-match)
310  (deftype-equiv     ct-deftype-equiv)
311  (kind-match        ct-kind-match)
312  (deftype-of-path   ct-deftype-of-path))
313
314;; Section 2.8: Type-checking the module language
315
316(define (make-mod-typing cs ct) ;; cs: core-syntax, ct: core-typing
317
318  (define-values (modtype? Signature Functorty 
319                     modspec? Value_sig Type_sig Module_sig
320                     modterm? Modid Structure Functor Mapply Constraint
321                     moddef? Value_def Type_def Module_def
322                     subst-modtype subst-modspec subst-typedecl ) 
323    (make-mod-syntax cs))
324
325  (define-values ( binding? empty 
326                   add-signature add-module add-type add-spec add-value
327                   find-value find-type find-module find)
328    (make-mod-env cs))
329
330  (define type-term          (ct-type-term ct))
331  (define check-kind         (ct-check-kind ct))
332  (define check-valtype      (ct-check-valtype ct))
333  (define kind-deftype       (ct-kind-deftype ct))
334  (define deftype-equiv      (ct-deftype-equiv ct))
335  (define deftype-of-path    (ct-deftype-of-path ct))
336  (define kind-match         (ct-kind-match ct))
337  (define valtype-match      (ct-valtype-match ct))
338  (define subst-valtype      (cs-subst-valtype cs))
339
340  ;; Section 2.9: Matching between module types
341  (define (modtype-match env mty1 mty2)
342      (cases modtype mty1
343             (Signature (sig1)
344                (cases modtype mty2
345                       (Signature (sig2)
346                                  (let* ((res (pair-signature-components sig1 sig2)) 
347                                         (paired-components (car res))
348                                         (subst (cadr res)))
349                                    (let* ((ext-env (add-signature sig1 env))
350                                           (spec-match (specification-match ext-env subst) ))
351                                      (for-each (lambda (p) (spec-match (car p) (cadr p)))
352                                                paired-components))))
353                       (else
354                        (error 'modtype-match "module type mismatch" mty1 mty2))))
355
356             (Functorty (param1 arg1 res1)
357                (cases modtype mty2
358                  (Functorty (param2 arg2 res2)
359                    (let* ((subst (subst-add param1 (Pident param2) subst-identity))
360                           (res11 (subst-modtype res1 subst)))
361                      (modtype-match env arg2 arg1)
362                      (modtype-match (add-module param2 arg2 env) res11 res2)))
363                 
364                  (else
365                   (error 'modtype-match "module type mismatch" mty1 mty2))))
366
367
368             (else
369              (error 'modtype-match "module type mismatch" mty1 mty2))))
370             
371
372    (define (pair-signature-components sig1 sig2)
373      (if  (null? sig2)  (list '() subst-identity)
374           (let ((item2 (car sig2))
375                 (rem2  (cdr sig2)))
376             (letrec ((find-matching-component
377                       (lambda (x)
378                         (if (null? x)
379                             (error 'find-matching-component
380                                    "unmatched signature component" x)
381                             (let* ((item1 (car x))
382                                    (rem1  (cdr x))
383                                    (res   (cases modspec item1
384                                             (Value_sig (id1 _)
385                                               (cases modspec item2
386                                                 (Value_sig (id2 _)
387                                                    (and (equal? (ident-name id1) (ident-name id2))
388                                                         (list id1 id2 item1)))
389                                                 (else #f)))
390                                             
391                                             (Type_sig (id1 _) 
392                                               (cases modspec item2
393                                                 (Type_sig (id2 _)
394                                                   (and (equal? (ident-name id1) (ident-name id2))
395                                                        (list id1 id2 item1)))
396                                                 (else #f)))
397                                 
398                                             (Module_sig (id1 _)
399                                               (cases modspec item2
400                                                 (Module_sig (id2 _)
401                                                   (and (equal? (ident-name id1) (ident-name id2))
402                                                        (list id1 id2 item1)))
403                                                 (else #f)))
404                                             
405                                             (else #f))))
406                               
407                               (if res res (find-matching-component rem1)))))))
408
409               (let* ((comp  (find-matching-component sig1))
410                      (id1   (car comp))
411                      (id2   (cadr comp))
412                      (item1 (caddr comp)))
413                 (let* ((ps (pair-signature-components sig1 rem2))
414                        (pairs (car ps))
415                        (subst (cadr ps)))
416
417                   (list (cons (list item1 item2) pairs)
418                         (subst-add id2 (Pident id2) subst))))
419               ))))
420                   
421                 
422                   
423   (define (specification-match env subst)
424     (lambda (spec1 spec2)
425       (cases modspec spec1
426              (Value_sig (_ vty1)
427                (cases modspec spec2 
428                  (Value_sig (_ vty2)
429                     (if (not (valtype-match env vty1 (subst-valtype vty2 subst)))
430                         (error 'specification-match
431                                "value components do not match"
432                                spec1 spec2)))
433                  (else
434                   (error 'specification-match
435                          "components do not match"
436                          spec1 spec2))))
437
438             
439              (Type_sig (id decl1)
440                (cases modspec spec2 
441                  (Type_sig (_ decl2)
442                     (if (not (typedecl-match env id decl1 (subst-typedecl decl2 subst)))
443                         (error 'specification-match
444                                "type components do not match"
445                                spec1 spec2)))
446                  (else
447                   (error 'specification-match
448                          "components do not match"
449                          spec1 spec2))))
450
451              (Module_sig (_ mty1)
452                (cases modspec spec2 
453                  (Module_sig (_ mty2)
454                     (modtype-match env mty1 (subst-modtype mty2 subst)))
455                  (else
456                   (error 'specification-match
457                          "components do not match"
458                          spec1 spec2)))))))
459
460             
461                               
462
463    (define (typedecl-match env id decl1 decl2)
464      (let ((k1 (typedecl-kind decl1))
465            (k2 (typedecl-kind decl2)))
466        (and (kind-match env k1 k2)
467             (let ((m1 (typedecl-manifest decl1))
468                   (m2 (typedecl-manifest decl2)))
469               (cond ((and m1 (not m2)) #t)
470                     ((and m1 m2)
471                      (deftype-equiv env k2 m1 m2))
472                     ((and (not m1) m2)
473                      (deftype-equiv env k2
474                        (deftype-of-path (Pident id) k1) m2)))))))
475
476    ;; Section 2.10: Strengthening of module types
477
478    (define (strengthen-modtype path mty)
479      (cases modtype mty 
480             (Signature (sg)    (Signature (map (lambda (item) (strengthen-spec path item)) sg)))
481             (Functorty (_ _ _) mty)))
482
483    (define (strengthen-spec path item)
484      (cases modspec item 
485             (Value_sig (id vty) item)
486             (Type_sig (id decl)
487                       (let ((m (typedecl-manifest decl)))
488                         (if (not m)
489                             (deftype-of-path (Pdot path (ident-name id)) (typedecl-kind decl))
490                             (Type_sig id (make-typedecl (typedecl-kind decl) m)))))
491             (Module_sig (id mty)
492                         (Module_sig id (strengthen-modtype (Pdot path (ident-name id)) mty)))))
493   
494    ;; Continuation of section 2.8: Type-checking the module language
495
496    (define (check-modtype env mty)
497      (cases modtype mty
498             (Signature (sg) 
499                        (check-signature env '() sg))
500             (Functorty (param arg res)
501                        (begin
502                          (check-modtype env arg)
503                          (check-modtype (add-module param arg env) res)))))
504
505    (define (check-signature env seen sig)
506        (if (null? sig)   '()
507            (let ((item (car sig))
508                  (rem  (cdr sig)))
509              (cases modspec item
510                     (Value_sig (id vty)
511                        (if (member (ident-name id) seen)
512                            (error 'check-signature "repeated value name"
513                                   (ident-name id))
514                            (begin
515                              (check-valtype env vty)
516                              (check-signature env 
517                                               (cons (ident-name id) seen) 
518                                               rem))))
519
520                     (Type_sig (id decl)
521                        (if (member (ident-name id) seen)
522                            (error 'check-signature "repeated type name"
523                                   (ident-name id))
524                            (let ((m (typedecl-manifest decl)))
525                              (check-kind env (typedecl-kind decl))
526                              (if (not m) '()
527                                  (if (not (kind-match env (kind-deftype env m) 
528                                                       (typedecl-kind decl)))
529                                      (error 'check-signature
530                                             "kind mismatch in manifest type specification"
531                                             decl)))
532                              (check-signature (add-type id decl env)
533                                               (cons (ident-name id) seen)
534                                               rem))))
535
536                     (Module_sig (id mty)
537                        (if (member (ident-name id) seen)
538                            (error 'check-signature "repeated module name"
539                                   (ident-name id))
540                            (begin
541                              (check-modtype env mty)
542                              (check-signature (add-module id mty env)
543                                               (cons (ident-name id) seen)
544                                               rem))))
545                     ))))
546
547
548    (define (type-modterm env mt)
549      (cases modterm mt
550             (Modid (path)
551                    (let ((m (find-module path env)))
552                      (strengthen-modtype path m)))
553             
554             (Structure (str)
555                        (Signature (type-moddef env '() str)))
556
557             (Functor (param mty body)
558                      (begin
559                        (check-modtype env mty)
560                        (Functorty param mty
561                                   (type-modterm (add-module param mty env) body))))
562
563             (Mapply (funct arg)
564                     (cases modterm arg
565                            (Modid (path)
566                               (cases modtype (type-modterm env funct)
567                                 (Functorty (param mty-param mty-res)
568                                    (let ((mty-arg (type-modterm env arg)))
569                                      (modtype-match env mty-arg mty-param)
570                                      (subst-modtype mty-res (subst-add param path subst-identity))))
571                                 (else (error 'type-modterm 
572                                              "application of a non-functor" funct))))
573                            (else (error 'type-modterm
574                                         "argument in functor application is not a path to a module"
575                                         arg))))
576
577             (Constraint (modl mty)
578                (begin
579                  (check-modtype env mty)
580                  (modtype-match env (type-modterm env modl) mty)))
581
582             ))
583
584
585    (define (type-moddef env seen struct)
586      (if (null? struct) '()
587          (let ((def     (car struct))
588                (rem     (cdr struct)))
589            (let* ((res (type-definition env seen def))
590                   (sigitem (car res))
591                   (seen1   (cadr res)))
592              (cons sigitem (type-moddef (add-spec sigitem env) seen1 rem))))))
593             
594
595    (define (type-definition env seen def)
596      (cases moddef def
597             (Value_def (id term)
598                        (if (member (ident-name id) seen)
599                            (error 'type-definition "repeated value name" (ident-name id))
600                            (list (Value_sig id (type-term env term))
601                                  (cons (ident-name id) seen))))
602             
603             (Module_def (id modl)
604                         (if (member (ident-name id) seen)
605                             (error 'type-definition "repeated module name" (ident-name id))
606                             (list (Module_sig id (type-modterm env modl))
607                                   (cons (ident-name id) seen))))
608
609
610             (Type_def  (id kind typ)
611                        (if (member (ident-name id) seen)
612                            (error 'type-definition "repeated type name" (ident-name id))
613                            (begin
614                              (check-kind env kind)
615                              (if (not (kind-match env (kind-deftype env typ) kind))
616                                  (error 'type-definition "kind mismatch" kind))
617                              (list (Type_sig id (make-typedecl kind typ))
618                                    (cons (ident-name id) seen)))))))
619
620    (values check-modtype check-signature
621            type-modterm type-moddef type-definition)
622
623    )
624#|
625
626 Generic ``scoping'' pass for the module language.  This pass is not
627described in the article.
628
629  Scoping is the act of associating identifiers with their binding
630location.  Here we assume that the parser generates fresh
631identifiers (values of type Ident.t) each time it encounters an
632occurrence of a lexical identifier in the program, and stores those
633fresh identifiers in the abstract syntax tree it constructs.  The
634scoping pass rewrites the abstract syntax tree to use identical
635identifiers at a binding site and at all its usage sites.
636
637|#
638
639;;   A scoping structure is a table recording (name, identifier)
640;;   associations for value names, type names and module names.
641
642
643(define-record-type scoping-table
644  (make-scoping-table values types modules)
645  scoping-table?
646  (values             st-values)
647  (types              st-types)
648  (modules            st-modules))
649
650
651(define update-scoping-table
652  (let ((unset (list 'unset)))
653    (lambda (sc #!key (values unset) (types unset) (modules unset) )
654      (make-scoping-table
655       (if (eq? values unset) (st-values sc) values)
656       (if (eq? types unset) (st-types sc) types)
657       (if (eq? modules unset) (st-modules sc) modules)))))
658
659(define-values (st-empty st-enter-value st-enter-type st-enter-module
660                         st-value-path st-type-path st-module-path
661                         st-scope-module )
662  (letrec ((empty        (make-scoping-table '() '() '()))
663           (enter-value  (lambda (id sc)
664                           (update-scoping-table sc
665                             values: (cons (list (ident-name id) id) (st-values sc)))))
666           (enter-type   (lambda (id sc)
667                           (update-scoping-table sc
668                             types: (cons (list (ident-name id) id) (st-types sc)))))
669           (enter-module  (lambda (id sc)
670                            (update-scoping-table sc
671                              modules: (cons (list (ident-name id) id) (st-modules sc)))))
672           (scope-value   (lambda (id sc)
673                            (or (assoc (ident-name id) (st-values sc))
674                                (error 'scope-value "unbound value" (ident-name id)))))
675           (scope-type    (lambda (id sc)
676                            (or (assoc (ident-name id) (st-types sc))
677                                (error 'scope-type "unbound type" (ident-name id)))))
678           (scope-module  (lambda (id sc)
679                            (or (assoc (ident-name id) (st-modules sc))
680                                (error 'scope-module "unbound module" (ident-name id)))))
681           (scope-path    (lambda (scope-ident)
682                            (lambda (p sc)
683                              (cases path p
684                                     (Pident (id)        (Pident (cadr (scope-ident id sc))))
685                                     (Pdot (root field)  (Pdot ((scope-path scope-module) root sc) field))))))
686           (value-path    (scope-path scope-value))
687           (type-path     (scope-path scope-type))
688           (module-path   (scope-path scope-module)))
689
690    (values empty enter-value  enter-type enter-module
691            value-path type-path module-path scope-module)))
692
693
694;; The scoping pass for the core language
695
696(define-record-type core-scoping
697  (make-core-scoping scope-term scope-valtype scope-deftype scope-kind)
698  core-scoping?
699  (scope-term     csc-scope-term)
700  (scope-valtype  csc-scope-valtype)
701  (scope-deftype  csc-scope-deftype)
702  (scope-kind     csc-scope-kind))
703
704
705;; The scoping pass for the module language is then as follows.
706
707(define (make-mod-scoping cs csc) ;; cs: core-syntax, csc: core-scoping
708
709  (let-values ((( modtype? Signature Functorty 
710                  modspec? Value_sig Type_sig Module_sig
711                  modterm? Modid Structure Functor Mapply Constraint
712                  moddef? Value_def Type_def Module_def
713                  subst-modtype subst-modspec subst-typedecl ) 
714                (make-mod-syntax cs)))
715   
716    (define scope-kind (csc-scope-kind csc))
717    (define scope-deftype (csc-scope-deftype csc))
718    (define scope-valtype (csc-scope-valtype csc))
719    (define scope-term    (csc-scope-term csc))
720
721    (define (scope-typedecl sc decl)
722      (let ((m (typedecl-manifest decl)))
723        (make-typedecl (scope-kind sc (typedecl-kind decl))
724                       (if (not m) #f (scope-deftype sc m)))))
725
726    (define (scope-modtype sc mty)
727      (cases modtype mty
728             (Signature (sg) 
729                        (Signature (scope-signature sc sg)))
730             (Functorty (id arg res)
731                        (scope-modtype (st-enter-module id sc) res))))
732
733    (define (scope-signature sc x)
734      (if (null? x) '()
735          (let ((rem (cdr x)))
736            (cases modspec (car x)
737                   (Value_sig (id vty)
738                              (cons (Value_sig id (scope-valtype sc vty))
739                                    (scope-signature (st-enter-value id sc) rem)))
740                   (Type_sig (id decl)
741                             (cons (Type_sig id (scope-typedecl sc decl))
742                                   (scope-signature (st-enter-type id sc) rem)))
743                   (Module_sig (id mty)
744                               (cons (Module_sig id (scope-modtype sc mty))
745                                     (scope-signature (st-enter-type id sc) rem)))))))
746
747    (define (scope-modterm sc mt)
748      (cases modterm mt
749             (Modid (path)   
750                    (Modid (st-module-path path sc)))
751             (Structure (str) 
752                        (Structure (scope-moddef sc str)))
753             (Functor (id arg body)
754                      (Functor id (scope-modtype sc arg)
755                               (scope-modterm (st-enter-module id sc) body)))
756             (Mapply (m1 m2) 
757                     (Mapply (scope-modterm sc m1) (scope-modterm sc m2)))
758             (Constraint (m mty)
759                         (Constraint (scope-modterm sc m)
760                                     (scope-modtype sc mty)))))
761
762    (define (scope-moddef sc defs)
763      (if (null? defs) '()
764          (let ((rem (cdr defs)))
765            (cases moddef (car defs)
766                   (Value_def (id v)
767                              (cons (Value_def id (scope-term sc v))
768                                    (scope-moddef (st-enter-value id sc) rem)))
769                   (Type_def (id kind dty)
770                             (cons (Type_def id (scope-kind sc kind) (scope-deftype sc dty))
771                                   (scope-moddef (st-enter-type id sc) rem)))
772                   (Module_def (id m)
773                               (cons (Module_def id (scope-modterm sc m))
774                                     (scope-moddef (st-enter-module id sc) rem)))))))
775
776
777    (values scope-typedecl scope-modtype scope-signature scope-modterm scope-moddef)
778    ))
779
780;; Support for evaluation
781
782(define-datatype modval modval?
783  (Structure_v    (env list?))
784  (Mclosure_v     (body modterm?) (env list?))
785  )
786
787(define (path-find-val p env)
788  (cases path p
789         (Pident (id) 
790                 (ident-find id env))
791         (Pdot (root field)
792               (cases modval (find-module-val root env)
793                      (Structure_v (env1) (ident-find field env1))
794                      (else (error 'path-find-val "structure expected in dot access" p))))))
795
796(define (find-module-val path env)
797  (let ((v (path-find-val path env)))
798    (if (not v) (error 'find-module-val "path not found" path))
799    (if (not (modval? v)) (error 'find-module-val "module expected" path))
800    v))
801
802
803(define (make-mod-eval core-eval enter-val)
804
805  (define (eval-modterm t env)
806    (cases modterm t
807           (Modid      (p) (find-module-val p env))
808
809           (Structure  (str)
810                       (Structure_v (fold eval-moddef '() str)))
811
812           (Functor    (id mty mt)
813                       (Mclosure_v t env))
814
815           (Mapply     (m1 m2)
816                       (cases modval (eval-modterm m1 env)
817                              (Mclosure_v (t env1) 
818                                (cases modterm t 
819                                       (Functor (id mty mt)
820                                        (let* ((v2 (eval-modterm m2 env))
821                                               (env2 (enter-val id v2 env1)))
822                                          (eval-modterm mt env2)))
823                                       (else
824                                        (error 'eval-modterm "functor expected in application" t))))
825                              (error 'eval-modterm "module closure expected in application" m1)
826                              ))
827                                       
828           (Constraint (m mty) t)
829           ))
830
831  (define (eval-moddef d env)
832    (cases moddef d
833           (Value_def  (id term) 
834                       (enter-val id (core-eval term env) env))
835
836           (Type_def   (id kind defty) 
837                       (enter-val id d env))
838                       
839           (Module_def (id mt)
840                       (enter-val id (eval-modterm mt env) env))
841           ))
842
843  (lambda (env dlst)
844    (fold eval-moddef env dlst))
845)
846
847
848)
Note: See TracBrowser for help on using the repository browser.