Suppress loading/dumping messages for most files.

diff --git a/v7/src/cref/anfile.scm b/v7/src/cref/anfile.scm
index aae7ddab95074b3617577de5158345ab98f36cf0..118df8984a5a121698ff8dc4c76e79e9226dac22 100644 (file)
--- a/v7/src/cref/anfile.scm
+++ b/v7/src/cref/anfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: anfile.scm,v 1.11 2007/01/05 21:19:23 cph Exp $
+$Id: anfile.scm,v 1.12 2007/04/29 18:24:29 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,19 +30,18 @@ USA.
 (declare (usual-integrations))
 \f
 (define (analyze-file pathname)
-  (analyze/top-level (fasload pathname)))
+  (analyze/top-level (fasload pathname #t)))
 
 (define (analyze/top-level expression)
-  (with-values (lambda () (sort-expressions (process-top-level expression)))
-    (lambda (definitions others)
-      (let ((definition-analysis
-             (map analyze/top-level/definition definitions)))
-       (if (not (null? others))
-           (cons (vector false
-                         'EXPRESSION
-                         (analyze-and-compress (make-sequence others)))
-                 definition-analysis)
-           definition-analysis)))))
+  (receive (definitions others)
+      (sort-expressions (process-top-level expression))
+    (let ((definition-analysis (map analyze/top-level/definition definitions)))
+      (if (pair? others)
+         (cons (vector false
+                       'EXPRESSION
+                       (analyze-and-compress (make-sequence others)))
+               definition-analysis)
+         definition-analysis))))
 
 (define (sort-expressions expressions)
   (if (null? expressions)
@@ -50,11 +49,10 @@ USA.
       (let ((rest (lambda () (sort-expressions (cdr expressions)))))
        (if (block-declaration? (car expressions))
            (rest)
-           (with-values rest
-             (lambda (definitions others)
-               (if (definition? (car expressions))
-                   (values (cons (car expressions) definitions) others)
-                   (values definitions (cons (car expressions) others)))))))))
+           (receive (definitions others) (rest)
+             (if (definition? (car expressions))
+                 (values (cons (car expressions) definitions) others)
+                 (values definitions (cons (car expressions) others))))))))
 
 (define (process-top-level expression)
   (cond ((comment? expression)

diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 9980682616b6d0a0355e353cec75e01d80ec37f5..0275aabbb9dc7037c286d136173f5e7ea6d4cccc 100644 (file)
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.30 2007/01/05 21:19:23 cph Exp $
+$Id: redpkg.scm,v 1.31 2007/04/29 18:24:35 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -32,34 +32,32 @@ USA.
 \f
 (define (read-package-model filename os-type)
   (let ((model-pathname (merge-pathnames filename)))
-    (with-values
-       (lambda ()
-         (sort-descriptions (read-and-parse-model model-pathname os-type)))
-      (lambda (packages extensions loads globals)
-       (descriptions->pmodel
-        packages
-        extensions
-        loads
-        (map (lambda (pathname)
-               (cons
-                (->namestring pathname)
-                (let ((pathname
-                       (package-set-pathname
-                        (merge-pathnames pathname model-pathname)
-                        os-type)))
-                  (if (file-exists? pathname)
-                      (let ((contents (fasload pathname)))
-                        (if (package-file? contents)
-                            contents
-                            (begin
-                              (warn "Malformed package-description file:"
-                                    pathname)
-                              #f)))
-                      (begin
-                        (warn "Can't find package-description file:" pathname)
-                        #f)))))
-             globals)
-        model-pathname)))))
+    (receive (packages extensions loads globals)
+       (sort-descriptions (read-and-parse-model model-pathname os-type))
+      (descriptions->pmodel
+       packages
+       extensions
+       loads
+       (map (lambda (pathname)
+             (cons
+              (->namestring pathname)
+              (let ((pathname
+                     (package-set-pathname
+                      (merge-pathnames pathname model-pathname)
+                      os-type)))
+                (if (file-exists? pathname)
+                    (let ((contents (fasload pathname #f)))
+                      (if (package-file? contents)
+                          contents
+                          (begin
+                            (warn "Malformed package-description file:"
+                                  pathname)
+                            #f)))
+                    (begin
+                      (warn "Can't find package-description file:" pathname)
+                      #f)))))
+           globals)
+       model-pathname))))
 \f
 (define (sort-descriptions descriptions)
   (letrec
@@ -92,24 +90,22 @@ USA.
                         loads
                         (append! (reverse (cdr description)) globals)))
                  ((NESTED-DESCRIPTIONS)
-                  (call-with-values
-                      (lambda ()
-                        (loop (cdr description)
-                              packages
-                              extensions
-                              loads
-                              globals))
-                    (lambda (packages extensions loads globals)
-                      (loop descriptions packages extensions loads globals))))
+                  (receive (packages extensions loads globals)
+                      (loop (cdr description)
+                            packages
+                            extensions
+                            loads
+                            globals)
+                    (loop descriptions packages extensions loads globals)))
                  (else
                   (error "Unknown description keyword:" (car description)))))
              (values packages extensions loads globals)))))
-    (call-with-values (lambda () (loop descriptions '() '() '() '()))
-      (lambda (packages extensions loads globals)
-       (values (reverse! packages)
-               (reverse! extensions)
-               (reverse! loads)
-               (reverse! globals))))))
+    (receive (packages extensions loads globals)
+       (loop descriptions '() '() '() '())
+      (values (reverse! packages)
+             (reverse! extensions)
+             (reverse! loads)
+             (reverse! globals)))))
 
 (define (interesting-package-to-load? description)
   (or (pair? (package-description/file-cases description))
@@ -117,15 +113,14 @@ USA.
       (pair? (package-description/finalizations description))))
 \f
 (define (read-file-analyses! pmodel os-type)
-  (call-with-values (lambda () (cache-file-analyses! pmodel os-type))
-    (lambda (analyses changes?)
-      (for-each (lambda (p&c)
-                 (record-file-analysis! pmodel
-                                        (car p&c)
-                                        (analysis-cache/pathname (cdr p&c))
-                                        (analysis-cache/data (cdr p&c))))
-               analyses)
-      changes?)))
+  (receive (analyses changes?) (cache-file-analyses! pmodel os-type)
+    (for-each (lambda (p&c)
+               (record-file-analysis! pmodel
+                                      (car p&c)
+                                      (analysis-cache/pathname (cdr p&c))
+                                      (analysis-cache/data (cdr p&c))))
+             analyses)
+    changes?))
 
 (define-structure (analysis-cache
                   (type vector)
@@ -142,7 +137,8 @@ USA.
                            "fre"))
        (changes? (list #f)))
     (let ((result
-          (let ((caches (if (file-exists? pathname) (fasload pathname) '())))
+          (let ((caches
+                 (if (file-exists? pathname) (fasload pathname #f) '())))
             (let ((cache-packages
                    (lambda (packages)
                      (append-map!
@@ -158,7 +154,7 @@ USA.
               (append! (cache-packages (pmodel/packages pmodel))
                        (cache-packages (pmodel/extra-packages pmodel)))))))
       (if (car changes?)
-         (fasdump (map cdr result) pathname))
+         (fasdump (map cdr result) pathname #t))
       (values result (car changes?)))))
 
 (define (cache-file-analysis! pmodel caches pathname changes?)
@@ -307,22 +303,20 @@ USA.
 \f
 (define (parse-package-definition name options)
   (check-package-options options)
-  (call-with-values
-      (lambda ()
-       (let ((option (assq 'PARENT options)))
-         (if option
-             (let ((options (delq option options)))
-               (if (not (and (pair? (cdr option))
-                             (null? (cddr option))))
-                   (error "Ill-formed PARENT option:" option))
-               (if (assq 'PARENT options)
-                   (error "Multiple PARENT options."))
-               (values (parse-name (cadr option)) options))
-             (values 'NONE options))))
-    (lambda (parent options)
-      (let ((package (make-package-description name parent)))
-       (process-package-options package options)
-       package))))
+  (receive (parent options)
+      (let ((option (assq 'PARENT options)))
+       (if option
+           (let ((options (delq option options)))
+             (if (not (and (pair? (cdr option))
+                           (null? (cddr option))))
+                 (error "Ill-formed PARENT option:" option))
+             (if (assq 'PARENT options)
+                 (error "Multiple PARENT options."))
+             (values (parse-name (cadr option)) options))
+           (values 'NONE options)))
+    (let ((package (make-package-description name parent)))
+      (process-package-options package options)
+      package)))
 
 (define (parse-package-extension name options)
   (check-package-options options)