source: project/lexmod/lexmod-base.scm @ 5139

Last change on this file since 5139 was 5139, checked in by Kon Lovett, 13 years ago

Added structures like functionality.

File size: 4.6 KB
Line 
1(cond-expand
2  (chicken
3    (use srfi-1)
4    (eval-when (compile)
5      (declare
6        (usual-integrations)
7        (no-procedure-checks)
8        (inline)
9        (fixnum)
10#| THIS CAUSES THE ENTIRE BUILTIN SYMBOL TABLE TO VANISH!
11        (import
12          ##sys#setslot)
13        (bound-to-procedure
14          ##sys#setslot)
15|#
16        (export
17          lexmod:get-defined-tag
18          lexmod:get-modname-tag
19          lexmod:assert-satisfies
20          lexmod-version
21          interface?
22          interface-exports?
23          lexmod-name
24          lexmod-exports?
25          lexmod-satisfies?
26          lexmod-fulfills?
27          lexmod?
28          lexmod-open
29          compound-lexmod) ) ) )
30  (else) )
31
32;;; (C) 2003 Taylor Campbell.
33;;; All rights reserved.
34;;;
35;;; For details, see the LICENCE file, which should have come in the
36;;; lexmod distribution.
37
38(define (lexmod-version) '(009 final)) ; fnord
39
40(define lexmod:get-defined-tag "get-defined")
41(define lexmod:get-modname-tag "get-modname")
42
43(define (lexmod-name mod) (mod lexmod:get-modname-tag))
44
45;;; It might be better to include this in the neutral table interface,
46;;; rather than WALK-SYMBOL-TABLE, especially since CALL/CC can be
47;;; expensive and SYMBOL-TABLE-EVERY? needn't be.  (of course, CALL/CC
48;;; _shouldn't_ be expensive, but some Scheme implementations suck...)
49(define (symbol-table-every? f t)
50  (call-with-current-continuation
51   (lambda (return)
52     (hash-table-walk t (lambda (k v) (if (not (f k v)) (return #f))))
53     #t)))
54
55;;; Might it be better to turn this into an ADT, disjoint from tables?
56(define (interface? x)
57  (and (hash-table? x)
58       (symbol-table-every? (lambda (k v) (eqv? v #t)) x)))
59
60(define (interface-exports? interface symbol)
61  (hash-table-ref/default interface symbol #f) )
62
63(define (lexmod-exports? mod symbol)
64  (and (hash-table-ref/default (mod lexmod:get-defined-tag) symbol #f)
65       #t))
66
67(define (lexmod-satisfies? mod interface)
68  (symbol-table-every? (lambda (symbol _)
69                         (lexmod-exports? mod symbol))
70                       interface))
71
72(define (lexmod:assert-satisfies mod interface)
73  (if (not (lexmod-satisfies? mod interface))
74      (error "lexmod does not satisfy interface"
75             (lexmod-name mod)
76             mod
77             interface)))
78
79;;
80
81(cond-expand
82  (chicken
83    (define (check-lexmod obj loc)
84      (unless (lexmod? obj)
85        (error loc "invalid lexmod" obj)) )
86
87    (define (%lexmod? obj)
88      (and (procedure? obj)
89           (call/cc
90             (lambda (k)
91               (with-exception-handler
92                 (lambda (exp) (k #f))
93                 (lambda () (lexmod-name obj))))) ) )
94
95    (define (lexmod-fulfills? mod . exps)
96      (every
97        (lambda (exp)
98          (cond
99            [(and (pair? exp) (eq? 'export (car exp)))
100              (every (cut lexmod-exports? mod <>) (cdr exp))]
101            [(interface? exp)
102              (lexmod-satisfies? mod exp)]
103            [else
104              (error 'lexmod? "invalid export syntax" exp)]) )
105        exps) )
106
107    (define (lexmod? obj . exps)
108      (and (%lexmod? obj)
109           (or (null? exps)
110               (apply lexmod-fulfills? exps) ) ) )
111
112    (define (lexmod-open . mods)
113      (for-each
114        (lambda (mod)
115          (check-lexmod mod 'lexmod-open)
116          (for-each
117            (lambda (sym)
118              (##sys#setslot sym 0 (mod sym)))
119            (hash-table-keys (mod lexmod:get-defined-tag))) )
120        mods) )
121
122    ; Two ways to implement:
123    ; using lexmod macro or using knowledge of lexmod macro
124
125    (define (compound-lexmod . mods)
126      (let ([*defined* (make-hash-table eq?)]
127            [*name* ""])
128        (for-each
129          (lambda (mod)
130            (check-lexmod mod 'compound-lexmod)
131            (let ([syms (hash-table-keys (mod lexmod:get-defined-tag))])
132              (let ([dups (lset-intersection eq? (hash-table-keys *defined*) syms)])
133                (unless (null? dups)
134                  (error 'compound-lexmod "multiply defined exports" dups) ) )
135              (set! *name* (string-append *name* "+" (lexmod-name mod)))
136              (for-each
137                (lambda (sym)
138                  (hash-table-set! *defined* sym (mod sym)) )
139                syms) ) )
140          mods)
141        (set! *name* (string->symbol *name*))
142        (lambda (x)
143           (cond ((symbol? x)
144                  (hash-table-ref *defined* x
145                    (lambda () (error *name* "unknown name in module" x))))
146                 ((eq? x lexmod:get-defined-tag) *defined*)
147                 ((eq? x lexmod:get-modname-tag) *name*)
148                 (else (error *name* "invalid argument" x)) ) ) ) ) )
149  (else) )
Note: See TracBrowser for help on using the repository browser.