source: project/release/4/s48-modules/trunk/s48-modules.scm @ 19980

Last change on this file since 19980 was 19980, checked in by felix winkelmann, 10 years ago

tagged eggs

File size: 6.7 KB
Line 
1;;;; s48-modules.scm
2
3
4(module s48-modules (define-structure define-interface
5                      define-structures include-relative)
6
7  (import scheme chicken srfi-1 files)
8
9  (begin-for-syntax
10   (require 'srfi-1 'files)
11   (define s48-modules:*interfaces* '()) )
12
13  ;; Evil hackery to get around the way INCLUDE works
14  (define-for-syntax s48-modules:*current-file* #f)
15
16  (define-syntax s48-modules:set-current-file!
17    (lambda (x r c)
18      (set! s48-modules:*current-file* (cadr x))
19      `(,(r 'begin))) )
20
21  (define-for-syntax (s48-modules:get-current-file)
22    (or s48-modules:*current-file*
23        (and (feature? #:compiling) ##compiler#source-filename)
24        ##sys#current-source-filename))
25
26  (define-syntax include-relative
27    (lambda (x r c)
28      (let* ((old-file (s48-modules:get-current-file))
29             (file (make-pathname
30                   (if old-file
31                       (pathname-directory old-file)
32                       ".")
33                   (cadr x))))
34        `(,(r 'begin)
35          (,(r 's48-modules:set-current-file!) ,file)
36          (,(r 'include) ,file)
37          (,(r 's48-modules:set-current-file!) ,old-file) ) )) )
38
39  (define-for-syntax (s48-modules:parse-interface loc iface r c)
40    (let ((iface (##sys#strip-syntax iface)))
41      (define (fail)
42        (syntax-error loc "invalid interface specification" iface))
43      (let parse ((iface iface))
44        (cond ((symbol? iface)
45               (let ((a (assq iface s48-modules:*interfaces*)))
46                 (if a
47                     (cdr a)
48                     (fail))))
49              ((or (not (list? iface)) (not (pair? iface))) (fail))
50              ((c (r 'export) (car iface))
51               (map (lambda (sym)  ;; collapse  '(name :type) => 'name
52                      (if (pair? sym) (car sym) sym))
53                    (cdr iface)))
54              ((c (r 'compound-interface) (car iface))
55               (delete-duplicates
56                (append-map parse (cdr iface)) 
57                eq?))
58              (else (fail))))))
59
60  (define-syntax define-interface
61    (lambda (x r c)
62      (when (or (not (= 3 (length x)))
63                (not (symbol? (cadr x)) ) )
64        (syntax-error 'define-interface "invalid interface declaration" x))
65      `(,(r 'begin-for-syntax)
66        (,(r 'set!) s48-modules:*interfaces* 
67         (,(r 'alist-cons)
68          ',(##sys#strip-syntax (cadr x))
69          ',(s48-modules:parse-interface 'define-interface (caddr x) r c)
70          s48-modules:*interfaces*)))))
71
72  (define-syntax define-structure
73    (syntax-rules ()
74      ((_ name iface body ...)
75       (define-structures ((name iface)) body ...))))
76 
77  (define-syntax define-structures
78    (lambda (x r c)
79      (##sys#check-syntax 'define-structures x '(_ #((symbol _) 1) . #(_ 0)))
80      (let* ((%open (r 'open))
81             (%for-syntax (r 'for-syntax))
82             (%files (r 'files))
83             (%begin (r 'begin))
84             (%begin-for-syntax (r 'begin-for-syntax))
85             (%subset (r 'subset))
86             (%with-prefix (r 'with-prefix))
87             (%modify (r 'modify))
88             (%expose (r 'expose))
89             (%hide (r 'hide))
90             (%only (r 'only))
91             (%except (r 'except))
92             (%rename (r 'rename))
93             (%prefix (r 'prefix))
94             (%module (r 'module))
95             (%include-relative (r 'include-relative))
96             (%import (r 'import))
97             (%import-for-syntax (r 'import-for-syntax))
98             (heads (cadr x))
99             (defs '())
100             (iname1 (string->symbol (string-append "_" (symbol->string (caar heads))))))
101        (define (process1 head)
102          (let ((name (car head))
103                (exports (s48-modules:parse-interface 'define-structures (cadr head) r c)))
104            `(,%module ,name ,exports (,%import ,iname1))))
105        (define (parse-struct spec)
106          (cond ((symbol? spec) spec)
107                ((or (not (list? spec)) (< (length spec) 2))
108                 (syntax-error 
109                  'define-structures "invalid structure specification"
110                  spec))
111                ((c %subset (car spec))
112                 `(,%only ,(parse-struct (cadr spec)) ,@(cddr spec)))
113                ((c %with-prefix (car spec))
114                 `(,%prefix ,(parse-struct (cadr spec)) ,(caddr spec)))
115                ((c %modify (car spec))
116                 (fold-right
117                  (lambda (mod current)
118                    (unless (pair? mod)
119                      (syntax-error 'define-structures "invalid modifier" mod))
120                    (cond ((c %expose (car mod))
121                           `(,%only ,current ,@(cdr mod)))
122                          ((c %hide (car mod))
123                           `(,%except ,current ,@(cdr mod)))
124                          ((c %prefix (car mod))
125                           `(,%prefix ,current ,(cadr mod)))
126                          ((c %rename (car mod))
127                           `(,%rename ,current ,@(cdr mod)))
128                          (else
129                           (syntax-error 'define-structures "invalid modifier" mod))))
130                  (cadr spec)
131                  (cddr spec)))
132                (else
133                 (syntax-error 
134                  'define-structures "invalid structure specification"
135                  spec))))
136        (define (process-body body fs)
137          (if (null? body)
138              (reverse defs)
139              (let ((clause (car body)))
140                (cond ((or (not (list? clause)) (< (length clause) 2))
141                       (syntax-error 'define-structures "invalid structure clause"
142                                     clause))
143                      ((c %open (car clause))
144                       (set! defs 
145                         (cons `(,(if fs %import-for-syntax %import)
146                                 ,@(map parse-struct (cdr clause)))
147                               defs))
148                       (process-body (cdr body) fs))
149                      ((c %for-syntax (car clause))
150                       (process-body (cdr clause) #t)
151                       (process-body (cdr body) fs))
152                      ((c %begin (car clause))
153                       (set! defs
154                         (cons
155                          `(,(if fs %begin-for-syntax %begin)
156                            ,@(cdr clause)) 
157                          defs))
158                       (process-body (cdr body) fs))
159                      ((c %files (car clause))
160                       (set! defs 
161                         (cons `(,%include-relative
162                                 ,@(map
163                                    (lambda (fspec)
164                                      (let ((f (cond ((string? fspec) fspec)
165                                                     ((list? fspec)
166                                                      (string-intersperse
167                                                       (map ->string fspec)
168                                                       "/") )
169                                                     (else (->string fspec)))))
170                                        (make-pathname
171                                         (and ##sys#current-source-filename
172                                              (pathname-directory
173                                               ##sys#current-source-filename))
174                                         f)) )
175                                        (cdr clause)))
176                               defs))
177                       (process-body (cdr body) fs))
178                      (else (syntax-error 
179                             'define-structures
180                             "invalid structure clause"
181                             clause))))))
182        (let ((names (map (lambda (n) (##sys#strip-syntax (car n))) (cadr x))))
183         (when (and (feature? #:compiling)
184                     (any (lambda (n) (assq n ##compiler#import-libraries))
185                          names))
186            (set! ##compiler#import-libraries
187              (alist-cons 
188               iname1
189               (string-append (symbol->string iname1) ".import.scm")
190               ##compiler#import-libraries) ) ) )
191        `(,%begin
192         (,%module ,iname1 *
193                   (import (only s48-modules include-relative))
194                   ,@(process-body (cddr x) #f))
195          ,@(map process1 (cadr x))))))
196
197)
Note: See TracBrowser for help on using the repository browser.