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

Last change on this file since 24070 was 24070, checked in by felix winkelmann, 9 years ago

import chicken except define-interface - this is for specialuzation but happens to be compatible to the current version. not tagged yet

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