source: project/release/5/r7rs/trunk/r7rs-compile-time.scm @ 38750

Last change on this file since 38750 was 38750, checked in by felix winkelmann, 3 months ago

Omit C4-only module check, add cond-expand tests

(Patch provided by wasamasa)

Dropped some unnecessary compile-time conditionals.

File size: 7.3 KB
Line 
1;;;; compile-time support code (mostly for modules)
2
3(import-syntax matchable)
4(import chicken.base chicken.file chicken.plist)
5(import chicken.syntax chicken.platform)
6(import srfi-1)
7(import r7rs-library r7rs-support)
8
9(define (locate-library name loc)               ; must be stripped
10  ;;XXX scan include-path?
11  (let* ((name2 (parse-library-name name loc))
12         (sname2 (symbol->string name2)))
13    (or (##sys#find-module name2 #f)
14        (file-exists? (string-append sname2 ".import.so"))
15        (file-exists? (string-append sname2 ".import.scm")))))
16
17(define (process-cond-expand clauses)
18  ;; returns list of forms of successful clause or #f
19  (define (fail msg . args)
20    (apply
21     syntax-error 
22     msg
23     (append args
24             `((cond-expand
25                 ,@(map (lambda (clause) (cons (car clause) '(...))) clauses))))))
26  (define (check test)
27    (match test
28      ('else #t)
29      (('not test) (not (check test)))
30      (('and tests ...) (every check tests))
31      (('or tests ...) (any check tests))
32      (('library name) (locate-library name 'cond-expand))
33      ((? symbol? feature) (feature? feature))
34      (_ (fail "invalid test expression in \"cond-expand\" form" test))))
35  (let loop ((cs clauses))
36    (match cs
37      (() (fail "no clause applies in \"cond-expand\" form"))
38      (((test body ...) . more)
39       (if (check (strip-syntax test))
40           body
41           (loop more)))
42      (else (fail "invalid \"cond-expand\" form")))))
43
44;; Dig e.g. foo.bar out of (only (foo bar) ...) ...
45(define (import/export-spec-feature-name spec loc)
46  (match spec
47    ((? symbol? spec) spec)
48    (((or 'only 'except 'rename 'prefix) name . more)
49     (import/export-spec-feature-name name loc))
50    ((name ...)
51     (parse-library-name name loc))
52    (else
53     (syntax-error loc "invalid import/export specifier" spec))))
54
55(define (expand/begin e)
56  (match (expand e '())
57    (('##core#begin . rest)
58     (cons '##core#begin (map expand/begin rest)))
59    (e* e*)))
60
61(define (expand-toplevel-r7rs-library-forms exps)
62  (parameterize ((##sys#macro-environment (r7rs-library-macro-environment)))
63    (map expand/begin exps)))
64
65(define (read-forms filename ci?)
66  (fluid-let ((##sys#default-read-info-hook
67               (let ((name 'chicken.compiler.support#read-info-hook))
68                 (and (feature? 'compiling)
69                      (##sys#symbol-has-toplevel-binding? name)
70                      (##sys#slot name 0)))))
71     (parameterize ((case-sensitive (not ci?)))
72       (##sys#include-forms-from-file
73        filename
74        ##sys#current-source-filename
75        expand-toplevel-r7rs-library-forms))))
76
77(define implicit-r7rs-library-bindings
78  '(begin
79    cond-expand
80    export
81    import
82    import-for-syntax
83    include
84    include-ci
85    syntax-rules))
86
87(define (parse-library-definition form dummy-export)    ; expects stripped syntax
88  (match form
89    ((_ name decls ...)
90     (let ((real-name (parse-library-name name 'define-library)))
91       (define (parse-exports specs)
92         (map (match-lambda
93                ((and spec ('rename _ _))
94                 (syntax-error
95                  'define-library
96                  "\"rename\" export specifier currently not supported" 
97                  name))
98                ((? symbol? exp)
99                 `(export ,exp))
100                (spec (syntax-error 'define-library "invalid export specifier" spec name)))
101              specs))
102       (define (parse-imports specs)
103         ;; What R7RS calls IMPORT, we call USE (it imports *and* loads code)
104         ;; XXX TODO: Should be import-for-syntax'ed as well?
105         `(import ,@specs)) ; NOTE this is the r7rs module's IMPORT!
106       (define (process-includes fnames ci?)
107         `(##core#begin
108           ,@(map (match-lambda
109                    ((? string? fname)
110                     `(##core#begin ,@(read-forms fname ci?)))
111                    (fname (syntax-error 'include "invalid include-filename" fname)))
112                  fnames)))
113       (define (process-include-decls fnames)
114         (parse-decls (append-map (lambda (fname) (read-forms fname #t)) fnames)))
115       (define (parse-decls decls)
116         (match decls
117           (() '(##core#begin))
118           ((('export specs ...) . more)
119            `(##core#begin
120              ,@(parse-exports specs)
121              ,(parse-decls more)))
122           ((('import specs ...) . more)
123            `(##core#begin
124              ,(parse-imports specs)
125              ,(parse-decls more)))
126           ((('include fnames ...) . more)
127            `(##core#begin
128              ,(process-includes fnames #f)
129              ,(parse-decls more)))
130           ((('include-ci fnames ...) . more)
131            `(##core#begin
132              ,(process-includes fnames #t)
133              ,(parse-decls more)))
134           ((('include-library-declarations fnames ...) . more)
135            `(##core#begin
136              ,(process-include-decls fnames)
137              ,(parse-decls more)))
138           ((('cond-expand decls ...) . more)
139            `(##core#begin
140              ,@(process-cond-expand decls)
141              ,(parse-decls more)))
142           ((('begin code ...) . more)
143            `(##core#begin
144              ,@code
145              ,(parse-decls more)))
146           (decl (syntax-error 'define-library "invalid library declaration" decl))))
147       `(##core#module ,real-name ((,dummy-export))
148         ;; gruesome hack: we add a dummy export for adding indirect exports
149         (##core#define-syntax ,dummy-export
150          (##sys#er-transformer (##core#lambda (x r c) (##core#undefined))))
151         ;; Another gruesome hack: provide feature so "use" works properly
152         (##sys#provide (##core#quote ,real-name))
153         ;; Set up an R7RS environment for the module's body.
154         (import-for-syntax (only r7rs ,@implicit-r7rs-library-bindings))
155         (import (only r7rs ,@implicit-r7rs-library-bindings))
156         ;; Now process all toplevel library declarations
157         ,(parse-decls decls))))
158    (_ (syntax-error 'define-library "invalid library definition" form))))
159
160(define (register-r7rs-module name)
161  (let ((dummy (string->symbol (string-append "\x04r7rs" (symbol->string name)))))
162    (put! name '##r7rs#module dummy)
163    dummy))
164
165(set! ##sys#register-export
166  (let ((register-export ##sys#register-export))
167    (lambda (sym mod)
168      (when mod
169        (let-values (((explist ve se) (##sys#module-exports mod)))
170          (and-let* ((dummy (get (##sys#module-name mod) '##r7rs#module)))
171            (unless (eq? sym dummy)
172              (cond ((memq sym explist))
173                    ((find (lambda (a) (and (pair? a) (eq? (car a) dummy))) explist) =>
174                     (lambda (dummylist)
175                       (set-cdr! dummylist (cons sym (cdr dummylist))))))))
176          (register-export sym mod))))))
177
178(define r7rs-define-library
179  (er-macro-transformer
180   (lambda (x r c)
181     (match (strip-syntax x)
182       ((_ name decls ...)
183        (let ((dummy (register-r7rs-module (parse-library-name name 'define-library))))
184          (parse-library-definition x dummy)))
185       (else
186        (syntax-error 'define-library "invalid library definition" x))))))
187
188(define r7rs-cond-expand
189  (er-macro-transformer
190   (lambda (x r c)
191     (cons (r 'begin)
192           (process-cond-expand (cdr x))))))
193
194(define r7rs-include
195  (er-macro-transformer
196   (lambda (e r c)
197     (cons (r 'begin)
198           (append-map (cut read-forms <> #f) (cdr e))))))
199
200(define r7rs-include-ci
201  (er-macro-transformer
202   (lambda (e r c)
203     (cons (r 'begin)
204           (append-map (cut read-forms <> #t) (cdr e))))))
205
206;; NOTE Not really "r7rs" -- just the core begin rewrapped in
207;; a transformer. Used when expanding toplevel library forms.
208(define r7rs-begin
209  (##sys#make-structure 'transformer (macro-handler 'begin)))
210
211(define (r7rs-library-macro-environment)
212  (filter (lambda (p)
213            (memv (caddr p)
214                  (map (cut ##sys#slot <> 1)
215                       (list r7rs-begin
216                             r7rs-cond-expand
217                             r7rs-define-library
218                             r7rs-include
219                             r7rs-include-ci))))
220          (##sys#macro-environment)))
Note: See TracBrowser for help on using the repository browser.