From cc32f3eea25a021baf5cd98537a0cefd7516366f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Jun 2009 13:26:07 +0000 Subject: [PATCH] fix problems with get-info use by setup-plt svn: r15242 --- collects/compiler/compiler-unit.ss | 7 +++++-- collects/setup/infotab.ss | 9 +++++---- collects/setup/private/omitted-paths.ss | 19 ++++++++++--------- collects/setup/setup-unit.ss | 4 ++-- 4 files changed, 22 insertions(+), 17 deletions(-) diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss index ed18fb3fcb..ba8911f651 100644 --- a/collects/compiler/compiler-unit.ss +++ b/collects/compiler/compiler-unit.ss @@ -51,6 +51,9 @@ (define (c-get-info cp) ((current-compiler-dynamic-require-wrapper) (lambda () (get-info cp)))) + (define (c-get-info/full cp) + ((current-compiler-dynamic-require-wrapper) + (lambda () (get-info/full cp)))) (define (make-extension-compiler mode prefix) (let ([u (c-dynamic-require 'compiler/private/base 'base@)] @@ -143,7 +146,7 @@ (define (compile-directory dir info #:verbose [verbose? #t]) (define info* (or info (lambda (key mk-default) (mk-default)))) - (define omit-paths (omitted-paths dir)) + (define omit-paths (omitted-paths dir c-get-info/full)) (unless (eq? 'all omit-paths) (parameterize ([current-directory dir] [current-load-relative-directory dir] @@ -168,7 +171,7 @@ (for ([p (directory-list dir)]) (let ([p* (build-path dir p)]) (when (and (directory-exists? p*) (not (member p omit-paths))) - (compile-directory p* (get-info/full p*)))))))) + (compile-directory p* (c-get-info/full p*)))))))) (define (compile-collection-zos collection . cp) (compile-directory (apply collection-path collection cp) diff --git a/collects/setup/infotab.ss b/collects/setup/infotab.ss index 803f0e8470..1301c8bc3c 100644 --- a/collects/setup/infotab.ss +++ b/collects/setup/infotab.ss @@ -1,7 +1,8 @@ ;; Defines a language to be used by info.ss files -#lang mzscheme +#lang scheme/base +(require (for-syntax scheme/base)) (define-syntax info-module-begin (lambda (stx) @@ -49,14 +50,14 @@ (define-syntax (limited-require stx) (syntax-case stx () - [(_ lib) (member (syntax-object->datum #'lib) + [(_ lib) (member (syntax->datum #'lib) '((lib "string-constant.ss" "string-constants") (lib "string-constants/string-constant.ss") string-constants/string-constant string-constants)) (syntax/loc stx (require lib))])) -(provide (rename info-module-begin #%module-begin) +(provide (rename-out [info-module-begin #%module-begin]) #%app #%datum #%top define quote list cons car cdr quasiquote unquote unquote-splicing @@ -64,4 +65,4 @@ string-append path->string build-path collection-path system-library-subpath - (rename limited-require require)) + (rename-out [limited-require require])) diff --git a/collects/setup/private/omitted-paths.ss b/collects/setup/private/omitted-paths.ss index 7a249fbbc6..4e560cb6c4 100644 --- a/collects/setup/private/omitted-paths.ss +++ b/collects/setup/private/omitted-paths.ss @@ -9,7 +9,7 @@ (provide omitted-paths) -(require scheme/path scheme/list "../dirs.ss" "../getinfo.ss" "lib-roots.ss") +(require scheme/path scheme/list "../dirs.ss" "lib-roots.ss") ;; An entry for each collections root that holds a hash table. The hash table ;; maps a reversed list of subpath elements to the exploded omitted-paths @@ -42,7 +42,7 @@ (and omit-doc? (equal? "doc" str)) (regexp-match? #rx"^[.]" str)))) -(define (compute-omitted dir accumulated implicit-omit?) +(define (compute-omitted dir accumulated implicit-omit? get-info/full) (define info (or (get-info/full dir) (lambda _ '()))) (define explicit (let ([omit (info 'compile-omit-paths (lambda () '()))]) @@ -63,12 +63,12 @@ (map list (filter implicit-omit? (directory-list dir))) accumulated)])) -(define (accumulate-omitted rsubs root t omit-doc?) +(define (accumulate-omitted get-info/full rsubs root t omit-doc?) (define dir (apply build-path root)) (define implicit? (implicit-omit? omit-doc?)) (let loop ([rsubs rsubs]) (if (null? rsubs) - (compute-omitted dir '() implicit?) + (compute-omitted dir '() implicit? get-info/full) (with-memo t rsubs (let ([acc (loop (cdr rsubs))]) (if (or (eq? 'all acc) (member (list (car rsubs)) acc)) @@ -78,9 +78,10 @@ #:when (equal? (car up) (car rsubs))) ;; must have non-null cdr: see `member' check (cdr up)) - implicit?))))))) + implicit? + get-info/full))))))) -(define (omitted-paths* dir) +(define (omitted-paths* dir get-info/full) (unless (and (path-string? dir) (complete-path? dir) (directory-exists? dir)) (raise-type-error 'omitted-paths "complete path to an existing directory" dir)) @@ -89,7 +90,7 @@ (let ([r (relative-from dir* (car root+table))]) (and r (cons (reverse r) root+table)))) roots)] - [r (and r (apply accumulate-omitted r))]) + [r (and r (apply accumulate-omitted get-info/full r))]) (unless r (error 'omitted-paths "given directory path is not in any collection root: ~e" dir)) @@ -99,5 +100,5 @@ (define omitted-paths-memo (make-hash)) -(define (omitted-paths dir) - (with-memo omitted-paths-memo dir (omitted-paths* dir))) +(define (omitted-paths dir get-info/full) + (with-memo omitted-paths-memo dir (omitted-paths* dir get-info/full))) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 9baabeff62..1f80ecac3c 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -186,7 +186,7 @@ "ignoring `compile-subcollections' entry in info ~a" path-name)) ;; this check is also done in compiler/compiler-unit, in compile-directory - (and (not (eq? 'all (omitted-paths path))) + (and (not (eq? 'all (omitted-paths path getinfo))) (make-cc collection path (if name (string-append path-name " (" name ")") path-name) info root-dir info-path shadowing-policy))) @@ -282,7 +282,7 @@ ;; collection should not have been included, but we might ;; jump in if a command-line argument specified a ;; coll/subcoll - [omit (omitted-paths ccp)] + [omit (omitted-paths ccp getinfo)] [subs (if (eq? 'all omit) '() (filter (lambda (p)