From 0c01c48dfe2d44cd7eddb8f2432d2de1bdeecf88 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 29 Apr 2007 18:24:35 +0000 Subject: [PATCH] Suppress loading/dumping messages for most files. --- v7/src/cref/anfile.scm | 32 +++++----- v7/src/cref/redpkg.scm | 136 ++++++++++++++++++++--------------------- 2 files changed, 80 insertions(+), 88 deletions(-) diff --git a/v7/src/cref/anfile.scm b/v7/src/cref/anfile.scm index aae7ddab9..118df8984 100644 --- 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)) (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 998068261..0275aabbb 100644 --- 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. (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)))) (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)))) (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. (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) -- 2.25.1