r6rs library form improvements

svn: r468

collects/r6rs/doc.txt

@@ -43,12 +43,6 @@ Limitations:
  - doesn't enforce that a for-run import isn't also
    a for-expand import in a different import-spec
 
- - doesn't enforce that idenfiers in a macro expansion
-   are only the ones declared by indirect-export
-
- - doesn't check that an identifiers in an indirect-export
-   declaration are actually defined
-
  - reader adjusts only string, character, and quoted-symbol
    syntax (as in SRFI-75), for now
 

collects/r6rs/library-module.ss

@@ -2,7 +2,11 @@
 (module library-module mzscheme
   (require-for-syntax "private/helpers.ss"
 		      (lib "kerncase.ss" "syntax")
-		      (lib "context.ss" "syntax"))
+		      (lib "context.ss" "syntax")
+		      (lib "boundmap.ss" "syntax")
+		      (lib "stxparam.ss")
+		      (lib "list.ss"))
+  (require (lib "stxparam.ss"))
 
   (provide (rename library-module-begin #%module-begin)
 	   import)
@@ -33,41 +37,29 @@
   (define-for-syntax (split-bodies bodies)
     (let loop ([bodies bodies]
 	       [imports null]
-	       [exports null]
+	       [exports null])
-	       [indirect-exports null])
       (if (null? bodies)
 	  (values (reverse imports)
 		  (reverse exports)
-		  (reverse indirect-exports)
 		  null)
-	  (syntax-case (car bodies) (import export indirect-export)
+	  (syntax-case (car bodies) (import export)
 	    [(import in ...)
 	     (loop (cdr bodies)
 		   (append (syntax->list #'(in ...)) imports)
-		   exports
+		   exports)]
-		   indirect-exports)]
 	    [(import . rest)
 	     (raise-syntax-error #f "bad syntax" (car bodies))]
 	    [(export out ...)
 	     (loop (cdr bodies)
 		   imports
-		   (append (syntax->list #'(out ...)) exports)
+		   (append (syntax->list #'(out ...)) exports))]
-		   indirect-exports)]
 	    [(export . rest)
 	     (raise-syntax-error #f "bad syntax" (car bodies))]
-	    [(indirect-export indirect ...)
-	     (loop (cdr bodies)
-		   imports
-		   exports
-		   (append (syntax->list #'(indirect ...)) indirect-exports))]
-	    [(indirect-export . rest)
-	     (raise-syntax-error #f "bad syntax" (car bodies))]
 	    [else (values (reverse imports)
 			  (reverse exports)
-			  (reverse indirect-exports)
 			  bodies)]))))
 
-  (define-for-syntax (make-unboxer id)
+  (define-for-syntax (make-unboxer id in-src-module-id)
     (with-syntax ([id id])
       (make-set!-transformer
        (lambda (stx)
@@ -76,6 +68,44 @@
 	   [(_ arg ...) #'((unbox id) arg ...)]
 	   [_ #'(unbox id)])))))
 
+  (define-for-syntax (box-rhs stx)
+    (syntax-case stx ()
+      [(_ rhs) #'(box rhs)]))
+
+  (define-for-syntax (make-protected-unboxer id  in-src-module-id)
+    (with-syntax ([id id])
+      (make-set!-transformer
+       (lambda (stx)
+	 (unless (syntax-parameter-value in-src-module-id)
+	   (raise-syntax-error
+	    #f
+	    "reference to non-exported identifier allowed only within its source library"
+	    stx))
+	 (syntax-case stx (set!)
+	   [(set! _ v) #'(set! id v)]
+	   [(_ arg ...) #'(id arg ...)]
+	   [_ #'id])))))
+
+  (define-for-syntax (no-box-rhs stx)
+    (syntax-case stx ()
+      [(_ rhs) #'rhs]))
+
+  (define-for-syntax (check-exported-macro f ok?)
+    (let ([wrap (lambda (f)
+		  (lambda (stx)
+		    (unless (ok?)
+		      (raise-syntax-error
+		       #f
+		       "reference to non-exported identifier allowed only within its source library"
+		       stx))
+		    (f stx)))])
+      (cond
+       [(and (procedure? f) (procedure-arity-includes? f 1))
+	(wrap f)]
+       [(set!-transformer? f)
+	(make-set!-transformer (wrap (set!-transformer-procedure f)))]
+       [else f])))
+
   (define-syntax (library-module-begin stx)
     (syntax-case stx ()
       [(_ (__ name lang body ...))
@@ -95,18 +125,30 @@
 	    stx
 	    #'lang))
 	 (let ([bodies (syntax->list #'(body ...))])
-	   (let-values ([(imports exports indirect-exports bodies)
+	   (let-values ([(imports exports bodies)
 			 (split-bodies bodies)])
-	     #`(#%plain-module-begin
+	     (let ([provides (map translate-export exports)])
-		(require #,(datum->syntax-object stx '(all-except (lib "r6rs.ss" "r6rs")
+	       #`(#%plain-module-begin
-								  #%module-begin)))
+		  (require #,(datum->syntax-object stx '(all-except (lib "r6rs.ss" "r6rs")
-		(require-for-syntax #,(datum->syntax-object stx '(lib "r6rs.ss" "r6rs")))
+								    #%module-begin)))
-		(require #,(datum->syntax-object stx '(lib "library-module.ss" "r6rs")))
+		  (require-for-syntax #,(datum->syntax-object stx '(lib "r6rs.ss" "r6rs")))
-		#,@(map translate-import imports)
+		  (require #,(datum->syntax-object stx '(lib "library-module.ss" "r6rs")))
-		#,@(map translate-export exports)
+		  #,@(map translate-import imports)
-		(begin-library-body
+		  #,@provides
-		 #,indirect-exports
+		  (define-syntax-parameter in-src-module #f)
-		 #,bodies)))))]
+		  (begin-library-body
+		   in-src-module
+		   #,(apply append (map (lambda (prov)
+					  (map (lambda (p)
+						 (syntax-case p ()
+						   [(_ loc ext) #'loc]
+						   [_else p]))
+					       (cdr (syntax->list prov))))
+					provides))
+		   ()
+		   #,bodies
+		   ()
+		   ()))))))]
       [(_ x)
        (raise-syntax-error
 	#f
@@ -121,29 +163,149 @@
 
   (define-syntax (begin-library-body stx)
     (syntax-case stx ()
-      [(_ indirects ())
+      [(_ in-src-module export-info ((macro-id ind-id ...) ...) 
-       #'(begin)]
+	  () ; no body forms left
-      [(_ indirects (body0 body ...))
+	  ((def-macro-id check-id) ...)
+	  ((id gen-id boxdef-id) ...))
+       ;; We've processed the whole body, and now we need to
+       ;;  create unboxers for the defined names:
+       (let ([macro-ids (syntax->list #'(macro-id ...))]
+	     [ind-idss (map syntax->list (syntax->list #'((ind-id ...) ...)))])
+	 ;; Check that each inidirect-export id was defined
+	 (let ([t (make-bound-identifier-mapping)])
+	   (for-each (lambda (id)
+		       (bound-identifier-mapping-put! t id #t))
+		     (syntax->list #'(def-macro-id ...)))
+	   (for-each (lambda (macro-id)
+		       (unless (bound-identifier-mapping-get t macro-id (lambda () #f))
+			 (raise-syntax-error
+			  #f
+			  "id to trigger indirect exports not defined as syntax in the library"
+			  macro-id)))
+		     macro-ids)
+	   (for-each (lambda (id)
+		       (bound-identifier-mapping-put! t id #t))
+		     (syntax->list #'(id ...)))
+	   (for-each (lambda (id)
+		       (unless (bound-identifier-mapping-get t id (lambda () #f))
+			 (raise-syntax-error
+			  #f
+			  "indirect export not defined in the library"
+			  id)))
+		     (apply append ind-idss)))
+	 ;; Add each explicitly exported id to a table
+	 (let ([t (make-bound-identifier-mapping)])
+	   (for-each (lambda (id)
+		       (bound-identifier-mapping-put! t id #t))
+		     (syntax->list #'export-info))
+	   ;; Find fixpoint, adding indirect ids when the macro id is
+	   ;;  exported:
+	   (let loop ([macro-ids macro-ids]
+		      [ind-idss ind-idss]
+		      [next-macro-ids null]
+		      [next-ind-idss null]
+		      [added? #f])
+	     (cond
+	      [(null? macro-ids)
+	       (when added?
+		 (loop next-macro-ids next-ind-idss null null #f))]
+	      [(bound-identifier-mapping-get t (car macro-ids) (lambda () #f))
+	       (for-each (lambda (ind-id)
+			   (bound-identifier-mapping-put! t ind-id #t))
+			 (car ind-idss))
+	       (loop (cdr macro-ids) (cdr ind-idss) next-macro-ids next-ind-idss #t)]
+	      [else
+	       (loop (cdr macro-ids) (cdr ind-idss) 
+		     (cons (car macro-ids) next-macro-ids)
+		     (cons (car ind-idss) next-ind-idss)
+		     added?)]))
+	   ;; For each defined id, select an unboxer:
+	   (with-syntax ([((make-an-unboxer . box-a-def) ...)
+			  (map (lambda (id)
+				 (if (bound-identifier-mapping-get t id (lambda () #f))
+				     #'(make-unboxer . box-rhs)
+				     #'(make-protected-unboxer . no-box-rhs)))
+			       (syntax->list #'(id ...)))])
+	     ;; For each unexported macro id, add compile-time set!:
+	     (with-syntax ([(check-id ...)
+			    (map cdr (filter (lambda (p)
+					       (not (bound-identifier-mapping-get t (car p) (lambda () #f))))
+					     (map cons 
+						  (syntax->list #'(def-macro-id ...))
+						  (syntax->list #'(check-id ...)))))])
+	       #'(begin
+		   (begin-for-syntax (set! check-id #f) ...)
+		   (define-syntaxes (boxdef-id) box-a-def) ...
+		   (define-syntaxes (id ...)
+		     (values (make-an-unboxer (quote-syntax gen-id) (quote-syntax in-src-module)) ...)))))))]
+      [(_ in-src-module export-info indirects (body0 body ...) define-macro-ids defined-ids)
+       ;; Process one body form, body0
        (let ([comdef (local-expand #'body0
 				   'module
 				   stops)])
-	 (syntax-case comdef (begin define-syntaxes define-values)
+	 (syntax-case comdef (begin define-syntaxes define-values indirect-export)
 	   [(begin comdef ...)
-	    #`(begin-library-body indirects (comdef ... body ...))]
+	    #`(begin-library-body in-src-module
+				  export-info 
+				  indirects
+				  (comdef ... body ...)
+				  define-macro-ids
+				  defined-ids)]
 	   [(define-syntaxes (id ...) rhs)
-	    #`(begin (define-syntaxes (id ...) rhs)
+	    (with-syntax ([(check-id ...) (generate-temporaries #'(id ...))])
-		     (begin-library-body indirects (body ...)))]
+	      #`(begin (define-for-syntax check-id #t) ...
+		       (define-syntaxes (id ...)
+			 (let-values ([(id ...) rhs])
+			   (values (check-exported-macro id (lambda () check-id)) ...)))
+		       (begin-library-body in-src-module
+					   export-info 
+					   indirects
+					   (body ...)
+					   ((id check-id) ... . define-macro-ids)
+					   defined-ids)))]
 	   [(define-values (id ...) rhs)
-	    (with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))])
+	    (with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))]
+			  [(boxdef-id ...) (generate-temporaries #'(id ...))])
 	      #`(begin 
 		  (define-values (gen-id ...) 
-		    (let-values ([(id ...) rhs])
+		    (syntax-parameterize ([in-src-module #t])
-		      (values (box id) ...)))
+		      (let-values ([(id ...) rhs])
-		  (define-syntaxes (id ...)
+			(values (boxdef-id id) ...))))
-		    (values (make-unboxer (quote-syntax gen-id)) ...))
+		  (begin-library-body in-src-module
-		  (begin-library-body indirects (body ...))))]
+				      export-info 
+				      indirects
+				      (body ...)
+				      define-macro-ids
+				      ((id gen-id boxdef-id) ... . defined-ids))))]
+	   [(indirect-export (macro-id id ...) ...)
+	    (begin
+	      (for-each (lambda (x)
+			  (unless (identifier? x)
+			    (raise-syntax-error
+			     #f
+			     "expected an identifier"
+			     comdef
+			     x)))
+			(syntax->list #'(macro-id ... id ... ...)))
+	      #`(begin-library-body in-src-module
+				    export-info 
+				    ((macro-id id ...) ... . indirects)
+				    (body ...)
+				    define-macro-ids
+				    defined-ids))]
+	   [(indirect-export . _)
+	    (raise-syntax-error
+	     #f
+	     "bad syntax"
+	     comdef)]
 	   [expr
-	    ;; begin0 forces an expression (not defn):
+	    ;; syntax-parameterize forces an expression (not defn):
 	    #`(begin
-		(begin0 expr)
+		(syntax-parameterize ([in-src-module #t]) 
-		(begin-library-body indirects (body ...)))]))])))
+		  expr)
+		(begin-library-body in-src-module
+				    export-info 
+				    indirects
+				    (body ...)
+				    define-macro-ids
+				    defined-ids))]))])))

collects/r6rs/private/helpers.ss

@@ -45,11 +45,11 @@
      [(bound-identifier=? id (caar renames)) (cdar renames)]
      [else (locate-rename id (cdr renames))]))
 
-  (define (apply-rename new-names old-names name-pairs)
+  (define (apply-rename new-names old-names name-pairs rcons)
     (map (lambda (i)
 	   (or (ormap (lambda (new old)
 			(and (bound-identifier=? (car i) new)
-			     (cons old (cdr i))))
+			     (rcons old (cdr i))))
 		      new-names old-names)
 	       i))
 	 name-pairs))
@@ -153,51 +153,52 @@
     (translate-impexp 
      i orig-i
      (lambda (i exceptions onlys renames extra-prefix)
-       (syntax-case* i (all-defined) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
+       (define (result l)
-	 [(all-defined)
+	 (when exceptions
-	  (cond
+	   (check-present orig-i "except not" "identifier" values exceptions l))
-	   [onlys
+	 (when onlys
-	    #`(provide #,@(map (lambda (name-pair)
+	   (check-present orig-i "only not" "identifier" values onlys l))
-				 #`(rename #,(car name-pair) #,(cdr name-pair)))
+	 (when renames
-			       onlys))]
+	   (check-present orig-i "rename not" "identifier" values renames l))
-	   [(or exceptions (pair? renames))
+	 (let* ([l (if exceptions
-	    ;; First import non-renamed, then renamed:
+		       (filter (lambda (i)
-	    #`(provide (#,(if extra-prefix #'prefix-all-defined-except #'all-defined-except)
+				 (not (ormap (lambda (x) (bound-identifier=? (car x) i))
-			#,@(if extra-prefix (list extra-prefix) null)
+					     exceptions)))
-			#,@(append (map car (or exceptions null))
+			       l)
-				   (map car renames)))
+		       l)]
-		       #,@(map (lambda (i)
+		[name-pairs (if onlys 
-				 #`(rename #,(car i) #,(cdr i)))
+				onlys
-			       renames))]
+				(apply-rename (map car renames) (map cdr renames)
-	   [extra-prefix
+					      (map cons l
-	    #`(provide (prefix-all-defined #,extra-prefix))]
+						   (map (lambda (i) (add-prefix extra-prefix i)) l))
-	   [else
+					      (lambda (b a) (cons a b))))])
-	    #`(provide (all-defined))])]
+	   (if (andmap (lambda (p) (eq? (car p) (cdr p)))
-	 [(all-defined . _)
+		       name-pairs)
-	  (raise-syntax-error #f "bad syntax" i)]
+	       #`(provide #,@(map car name-pairs))
+	       #`(provide #,@(map (lambda (p)
+				    #`(rename #,(car p) #,(cdr p)))
+				  name-pairs)))))
+       (syntax-case* i (set) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
+	 [(set id ...)
+	  (let ([ids (syntax->list #'(id ...))])
+	    (for-each (lambda (x)
+			(unless (identifier? x)
+			  (raise-syntax-error
+			   #f
+			   "expected an identifier"
+			   i
+			   x)))
+		      ids)
+	    (result ids))]
 	 [_else
 	  (begin
 	    (unless (identifier? i)
 	      (raise-syntax-error
 	       #f
-	       "expected an identifier or an `all-defined', `only', `except', `add-prefix', or `rename' form"
+	       "expected an identifier or a `set', `only', `except', `add-prefix', or `rename' form"
 	       orig-i
 	       i))
-	    (when exceptions
+	    (result (list i)))]))))
-	      (check-present orig-i "except not" "identifier" values exceptions (list i)))
-	    (when onlys
-	      (check-present orig-i "only not" "identifier" values onlys (list i)))
-	    (when renames
-	      (check-present orig-i "rename not" "identifier" values renames (list i)))
-	    (cond
-	     [(pair? exceptions)
-	      ;; Must be the only exception, so nothing is exported
-	      #'(provide)]
-	     [(pair? renames)
-	      #`(provide (rename #,(caar renames) #,(cdar renames)))]
-	     [extra-prefix
-	      #`(provide (rename #,i #,(add-prefix extra-prefix i)))]
-	     [else #`(provide #,i)]))]))))
 
   (define (translate-impexp i orig-i k)
     (let loop ([i i]
@@ -290,7 +291,7 @@
 	   (check-unique-names orig-i "`rename' source" old-names)
 	   (let ([combine-renames
 		  (lambda ()
-		    (let ([renames (apply-rename new-names old-names renames)])
+		    (let ([renames (apply-rename new-names old-names renames cons)])
 		      (append
 		       renames
 		       (remove* renames name-pairs 
@@ -299,14 +300,14 @@
 	     (cond
 	      [exceptions
 	       (loop #'sub
-		     (apply-rename new-names old-names exceptions)
+		     (apply-rename new-names old-names exceptions cons)
 		     #f
 		     (combine-renames)
 		     extra-prefix)]
 	      [onlys
 	       (loop #'sub
 		     #f
-		     (apply-rename new-names old-names onlys)
+		     (apply-rename new-names old-names onlys cons)
 		     null
 		     #f)]
 	      [else