~ chicken-r7rs (master) /r7rs-compile-time.scm

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