#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/anfile.scm,v 1.3 1989/08/06 07:52:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/anfile.scm,v 1.4 1990/10/05 11:36:32 cph Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(define (analyze/directory filename)
- (for-each
- (lambda (input-pathname)
- (let ((output-pathname (pathname-new-type input-pathname "free")))
- (if (not (compare-file-modification-times input-pathname
- output-pathname))
- (analyze/file input-pathname output-pathname))))
- (directory-read
- (merge-pathnames (pathname-as-directory (->pathname filename))
- (string->pathname "*.bin")))))
-
-(define (read-analyzed-file input-pathname)
- (let ((output-pathname (pathname-new-type input-pathname "free")))
- (if (compare-file-modification-times input-pathname output-pathname)
- (fasload output-pathname)
- (analyze/file input-pathname output-pathname))))
-
-(define (analyze/file input-pathname output-pathname)
- (let ((analyzed-file (analyze/top-level (fasload input-pathname))))
- (if analyze/file/memoize?
- (fasdump analyzed-file output-pathname))
- analyzed-file))
-
-(define analyze/file/memoize? true)
-
-(define (compare-file-modification-times x y)
- (let ((x (file-modification-time x)))
- (and x
- (let ((y (file-modification-time y)))
- (and y
- (< x y))))))
-\f
+(define (analyze-file pathname)
+ (analyze/top-level (fasload pathname)))
+
(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 (with-values (lambda ()
- (analyze/expression (make-sequence others)))
- (lambda (references assignments executions)
- (vector false references assignments executions
- 'EXPRESSION)))
+ (cons (vector false
+ 'EXPRESSION
+ (analyze-and-compress (make-sequence others)))
definition-analysis)
definition-analysis)))))
(let ((name (definition-name definition))
(expression (definition-value definition)))
(cond ((unassigned-reference-trap? expression)
- (vector name '() '() '() 'UNASSIGNED))
+ (vector name 'UNASSIGNED '#()))
((scode-constant? expression)
- (vector name '() '() '() 'CONSTANT))
+ (vector name 'CONSTANT '#()))
(else
- (with-values (lambda () (analyze/expression expression))
- (lambda (references assignments executions)
- (vector name references assignments executions
- (cond ((lambda? expression) 'LAMBDA)
- ((delay? expression) 'DELAY)
- (else 'EXPRESSION)))))))))
+ (vector name
+ (cond ((lambda? expression) 'LAMBDA)
+ ((delay? expression) 'DELAY)
+ (else 'EXPRESSION))
+ (analyze-and-compress expression))))))
+
+(define (analyze-and-compress expression)
+ (list->vector (analyze/expression expression)))
\f
(define (analyze/expression expression)
((scode-walk analyze/dispatch expression) expression))
(define (analyze/expressions expressions)
(if (null? expressions)
- (values '() '() '())
- (result-sum (lambda () (analyze/expression (car expressions)))
- (lambda () (analyze/expressions (cdr expressions))))))
+ '()
+ (eq-set-union (analyze/expression (car expressions))
+ (analyze/expressions (cdr expressions)))))
(define (analyze/uninteresting expression)
- (values (if (primitive-procedure? expression) (list expression) '())
- '() '()))
+ (if (primitive-procedure? expression) (list expression) '()))
(define (analyze/error expression)
(error "Illegal expression" expression))
(define (analyze/access expression)
(if (access-environment expression)
(warn "Access to non-global environment:" (unsyntax expression)))
- (values (list expression) '() '()))
+ (list expression))
(define (analyze/variable expression)
- (values (list (variable-name expression)) '() '()))
+ (list (variable-name expression)))
(define (analyze/assignment expression)
- (with-values (lambda () (analyze/expression (assignment-value expression)))
- (lambda (references assignments executions)
- (values references
- (cons (assignment-name expression) assignments)
- executions))))
+ (eq-set-adjoin (assignment-name expression)
+ (analyze/expression (assignment-value expression))))
(define (analyze/combination expression)
- (result-sum (lambda ()
- (let ((operator (combination-operator expression)))
- (cond ((variable? operator)
- (values '() '() (list (variable-name operator))))
- ((or (primitive-procedure? operator)
- (and (access? operator)
- (not (access-environment operator))))
- (values '() '() (list operator)))
- (else
- (analyze/expression operator)))))
- (lambda ()
- (analyze/expressions (combination-operands expression)))))
+ (eq-set-union (analyze/expression (combination-operator expression))
+ (analyze/expressions (combination-operands expression))))
(define (analyze/lambda expression)
(lambda-components expression
(lambda (name required optional rest auxiliary declarations body)
name declarations
- (with-values (lambda () (analyze/expression body))
- (lambda (references assignments executions)
- (let ((bound
- (append required
- optional
- (if rest (list rest) '())
- auxiliary)))
- (values (multiset-difference references bound)
- (multiset-difference assignments bound)
- (multiset-difference executions bound))))))))
+ (eq-set-difference (analyze/expression body)
+ (append required
+ optional
+ (if rest (list rest) '())
+ auxiliary)))))
\f
(define (analyze/error-combination expression)
(combination-components expression
(SEQUENCE ,analyze/sequence)
(VARIABLE ,analyze/variable))))
-(define (result-sum first rest)
- (with-values first
- (lambda (references assignments executions)
- (with-values rest
- (lambda (references* assignments* executions*)
- (values (append! references references*)
- (append! assignments assignments*)
- (append! executions executions*)))))))
\ No newline at end of file
+(define (eq-set-adjoin x y)
+ (if (memq x y)
+ y
+ (cons x y)))
+
+(define (eq-set-union x y)
+ (if (null? y)
+ x
+ (let loop ((x x) (y y))
+ (if (null? x)
+ y
+ (loop (cdr x)
+ (if (memq (car x) y)
+ y
+ (cons (car x) y)))))))
+
+(define (eq-set-difference x y)
+ (let loop ((x x))
+ (cond ((null? x) '())
+ ((memq (car x) y) (loop (cdr x)))
+ (else (cons (car x) (loop (cdr x)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.2 1988/10/28 07:03:12 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.3 1990/10/05 11:31:38 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(files "anfile")
(parent (cross-reference))
(export (cross-reference)
- analyze/directory
- read-analyzed-file))
+ analyze-file))
(define-package (cross-reference constructor)
(files "conpkg")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.5 1989/08/03 23:26:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.6 1990/10/05 11:34:55 cph Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
(package/system-loader "cref" '() false)
-(add-system! (make-system "CREF" 1 5 '()))
\ No newline at end of file
+(add-system! (make-system "CREF" 1 6 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.2 1988/10/28 07:03:24 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.3 1990/10/05 11:33:16 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(integrate-external "object"))
\f
(define (read-package-model filename)
- (let* ((pathname (pathname->absolute-pathname (->pathname filename)))
- (default-pathname (pathname-directory-path pathname)))
+ (let ((model-pathname (pathname->absolute-pathname (->pathname filename))))
(with-values
(lambda ()
(sort-descriptions
(map (lambda (expression)
(parse-package-expression expression))
- (read-package-description-file pathname))))
+ (read-package-description-file model-pathname))))
(lambda (packages globals)
- (let ((pmodel (descriptions->pmodel packages default-pathname)))
+ (let ((pmodel (descriptions->pmodel packages model-pathname)))
(for-each
(let ((root-package (pmodel/root-package pmodel)))
(lambda (pathname)
(bind! root-package name expression)))
(fasload
(merge-pathnames (pathname-new-type pathname "glob")
- default-pathname)))))
+ model-pathname)))))
globals)
pmodel)))))
(read-file (pathname-default-type pathname "pkg")))
\f
(define (read-file-analyses! pmodel)
- (for-each (lambda (package)
- (for-each (lambda (pathname)
- (read-file-analysis! pmodel package pathname))
- (package/files package)))
- (pmodel/packages pmodel)))
-
-(define (read-file-analysis! pmodel package pathname)
- (let ((filename (pathname->string pathname))
- (root-package (pmodel/root-package pmodel))
- (primitive-package (pmodel/primitive-package pmodel)))
- (for-each (lambda (entry)
- (let ((name (vector-ref entry 0))
- (expression
- (make-expression package
- filename
- (vector-ref entry 4))))
- (let ((intern!
- (lambda (name)
- (cond ((symbol? name)
- (make-reference package name expression))
- ((primitive-procedure? name)
- (make-reference
- primitive-package
- (primitive-procedure-name name)
- expression))
- ((access? name)
- (if (access-environment name)
- (error "Non-root access" name))
- (make-reference root-package
- (access-name name)
- expression))
- (else
- (error "Illegal reference name" name))))))
- (for-each intern! (vector-ref entry 1))
- (for-each intern! (vector-ref entry 2))
- (for-each intern! (vector-ref entry 3)))
- (if name
- (bind! package name expression))))
- (read-analyzed-file
- (merge-pathnames (pathname-new-type pathname "bin")
- (pmodel/default-pathname pmodel))))))
+ (for-each (lambda (p&c)
+ (record-file-analysis! pmodel
+ (car p&c)
+ (analysis-cache/pathname (cdr p&c))
+ (analysis-cache/data (cdr p&c))))
+ (cache-file-analyses! pmodel)))
+
+(define-structure (analysis-cache
+ (type vector)
+ (constructor make-analysis-cache (pathname time data))
+ (conc-name analysis-cache/))
+ (pathname false read-only true)
+ (time false)
+ (data false))
+
+(define (cache-file-analyses! pmodel)
+ (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "free")))
+ (let ((result
+ (let ((caches (if (file-exists? pathname) (fasload pathname) '())))
+ (append-map! (lambda (package)
+ (map (lambda (pathname)
+ (cons package
+ (cache-file-analysis! pmodel
+ caches
+ pathname)))
+ (package/files package)))
+ (pmodel/packages pmodel)))))
+ (fasdump (map cdr result) pathname)
+ result)))
+
+(define (cache-file-analysis! pmodel caches pathname)
+ (let ((cache (analysis-cache/lookup caches pathname))
+ (full-pathname
+ (merge-pathnames (pathname-new-type pathname "bin")
+ (pmodel/pathname pmodel))))
+ (let ((time (file-modification-time full-pathname)))
+ (if (not time)
+ (error "unable to open file" full-pathname))
+ (if cache
+ (begin
+ (if (> time (analysis-cache/time cache))
+ (begin
+ (set-analysis-cache/data! cache (analyze-file full-pathname))
+ (set-analysis-cache/time! cache time)))
+ cache)
+ (make-analysis-cache pathname time (analyze-file full-pathname))))))
+
+(define (analysis-cache/lookup caches pathname)
+ (let loop ((caches caches))
+ (and (not (null? caches))
+ (if (pathname=? pathname (analysis-cache/pathname (car caches)))
+ (car caches)
+ (loop (cdr caches))))))
+
+(define (pathname=? x y)
+ (and (equal? (pathname-name x) (pathname-name y))
+ (equal? (pathname-directory x) (pathname-directory y))
+ (equal? (pathname-type x) (pathname-type y))
+ (equal? (pathname-version x) (pathname-version y))
+ (equal? (pathname-host x) (pathname-host y))
+ (equal? (pathname-device x) (pathname-device y))))
+\f
+(define (record-file-analysis! pmodel package pathname entries)
+ (for-each
+ (let ((filename (pathname->string pathname))
+ (root-package (pmodel/root-package pmodel))
+ (primitive-package (pmodel/primitive-package pmodel)))
+ (lambda (entry)
+ (let ((name (vector-ref entry 0))
+ (expression
+ (make-expression package filename (vector-ref entry 1))))
+ (for-each-vector-element (vector-ref entry 2)
+ (lambda (name)
+ (cond ((symbol? name)
+ (make-reference package name expression))
+ ((primitive-procedure? name)
+ (make-reference primitive-package
+ (primitive-procedure-name name)
+ expression))
+ ((access? name)
+ (if (access-environment name)
+ (error "Non-root access" name))
+ (make-reference root-package
+ (access-name name)
+ expression))
+ (else
+ (error "Illegal reference name" name)))))
+ (if name
+ (bind! package name expression)))))
+ entries))
(define (resolve-references! pmodel)
(for-each (lambda (package)
(lambda (package)
(symbol-list=? name (package/name package)))))
-(define (descriptions->pmodel descriptions default-pathname)
+(define (descriptions->pmodel descriptions pathname)
(let ((packages
(map (lambda (description)
(make-package
(make-package primitive-package-name '() '() false)
packages
extra-packages
- default-pathname))))
+ pathname))))
(define primitive-package-name
(list (string->symbol "#[(cross-reference reader)primitives]")))
projects / mit-scheme.git / commitdiff