#| -*-Scheme-*-
-$Id: conpkg.scm,v 1.12 2001/08/20 02:48:57 cph Exp $
+$Id: conpkg.scm,v 1.13 2001/08/20 21:02:35 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(integrate-external "object"))
\f
(define (construct-external-descriptions pmodel)
- (let* ((packages (pmodel/packages pmodel))
- (alist
- (append! (map (lambda (package)
- (cons package
- (construct-external-description package #f)))
- packages)
- (map (lambda (package)
- (cons package
- (construct-external-description package #t)))
- (list-transform-positive
- (pmodel/extra-packages pmodel)
- (lambda (package)
- (pair? (package/files package))))))))
- (vector 'PACKAGE-DESCRIPTIONS ;tag
- 2 ;version
- (list->vector
- (map cdr
- (sort alist
- (lambda (a b)
- (package-structure<? (car a) (car b))))))
- (list->vector (map cdr alist)))))
+ (vector 'PACKAGE-DESCRIPTIONS ;tag
+ 2 ;version
+ (list->vector
+ (map cdr
+ (sort (append!
+ (map (lambda (package)
+ (cons package (package->external package #f)))
+ (pmodel/packages pmodel))
+ (map (lambda (package)
+ (cons package (package->external package #t)))
+ (new-extension-packages pmodel)))
+ (lambda (a b)
+ (package-structure<? (car a) (car b))))))
+ (list->vector
+ (map package-load->external
+ (list-transform-positive (pmodel/loads pmodel)
+ (lambda (load)
+ (or (pair? (package-load/file-cases load))
+ (pair? (package-load/initializations load))
+ (pair? (package-load/finalizations load)))))))))
+
+(define (new-extension-packages pmodel)
+ (list-transform-positive (pmodel/extra-packages pmodel)
+ (lambda (package)
+ (or (there-exists? (package/links package) link/new?)
+ (there-exists? (package/sorted-bindings package)
+ new-internal-binding?)))))
+
+(define (new-internal-binding? binding)
+ (and (binding/new? binding)
+ (binding/internal? binding)
+ (not (there-exists? (binding/links binding)
+ (let ((package (binding/package binding)))
+ (lambda (link)
+ (eq? (link/owner link) package)))))))
(define (package-structure<? x y)
(cond ((package/topological<? x y) true)
(and (not (eq? x y))
(let loop ((y (package/parent y)))
(and y
+ (not (eq? y 'UNKNOWN))
(if (eq? x y)
true
(loop (package/parent y)))))))
\f
-(define (construct-external-description package extension?)
+(define (package->external package extension?)
(call-with-values (lambda () (split-links package))
(lambda (exports imports)
(vector (package/name package)
(let loop ((package package))
(let ((parent (package/parent package)))
- (if parent
+ (if (and parent (not (eq? parent 'UNKNOWN)))
(cons (package/name parent) (loop parent))
'())))
- (map (lambda (file-case)
- (cons (file-case/type file-case)
- (if (file-case/type file-case)
- (map (lambda (clause)
- (cons (file-case-clause/keys clause)
- (map-files clause)))
- (file-case/clauses file-case))
- (map-files
- (car (file-case/clauses file-case))))))
- (package/file-cases package))
- (package/initialization package)
- (package/finalization package)
(list->vector
(map binding/name
(list-transform-positive (package/sorted-bindings package)
- (lambda (binding)
- (and (binding/new? binding)
- (binding/internal? binding)
- (not (there-exists? (binding/links binding)
- (lambda (link)
- (memq link
- (package/links package))))))))))
+ new-internal-binding?)))
(list->vector
(map (lambda (link)
(let ((source (link/source link))
(if (pair? links)
(let ((link (car links))
(links (cdr links)))
- (if (eq? (binding/package (link/source link)) package)
- (loop links (cons link exports) imports)
- (loop links exports (cons link imports))))
+ (if (link/new? link)
+ (if (eq? (binding/package (link/source link)) package)
+ (loop links (cons link exports) imports)
+ (loop links exports (cons link imports)))
+ (loop links exports imports)))
(values exports imports))))
+(define (package-load->external description)
+ (vector (package/name (package-load/package description))
+ (list->vector
+ (map (lambda (file-case)
+ (if (file-case/type file-case)
+ (cons (file-case/type file-case)
+ (map-clauses file-case))
+ (map-files (car (file-case/clauses file-case)))))
+ (package-load/file-cases description)))
+ (list->vector (package-load/initializations description))
+ (list->vector (package-load/finalizations description))))
+
+(define (map-clauses file-case)
+ (list->vector
+ (map (lambda (clause)
+ (cons (let ((keys (file-case-clause/keys clause)))
+ (if (list? keys)
+ (list->vector keys)
+ keys))
+ (map-files clause)))
+ (file-case/clauses file-case))))
+
(define (map-files clause)
- (map ->namestring (file-case-clause/files clause)))
\ No newline at end of file
+ (list->vector (map ->namestring (file-case-clause/files clause))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: object.scm,v 1.13 2001/08/20 02:49:01 cph Exp $
+$Id: object.scm,v 1.14 2001/08/20 21:02:37 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define-structure
- (package-description
- (type vector)
- (named
- (string->symbol "#[(cross-reference)package-description]"))
- (constructor make-package-description (name parent))
- (conc-name package-description/))
+(define-structure (package-description
+ (constructor make-package-description (name parent))
+ (conc-name package-description/))
(name #f read-only #t)
(file-cases '())
(parent #f read-only #t)
- (initialization #f)
- (finalization #f)
+ (initializations '())
+ (finalizations '())
(exports '())
(imports '()))
-(define-structure
- (pmodel
- (type vector)
- (named (string->symbol "#[(cross-reference)pmodel]"))
- (conc-name pmodel/))
+(define-structure (pmodel (conc-name pmodel/))
(root-package #f read-only #t)
(primitive-package #f read-only #t)
(packages #f read-only #t)
(extra-packages #f read-only #t)
+ (loads #f read-only #t)
(pathname #f read-only #t))
-(define-structure
- (package
- (type vector)
- (named (string->symbol "#[(cross-reference)package]"))
- (constructor make-package (name parent))
- (conc-name package/)
- (print-procedure
- (standard-unparser-method 'PACKAGE
- (lambda (package port)
- (write-char #\space port)
- (write (package/name package) port)))))
-
+(define-structure (package
+ (constructor make-package (name parent))
+ (conc-name package/)
+ (print-procedure
+ (standard-unparser-method 'PACKAGE
+ (lambda (package port)
+ (write-char #\space port)
+ (write (package/name package) port)))))
(name #f read-only #t)
- (file-cases '())
(files '())
- (initialization #f)
- (finalization #f)
parent
(children '())
(bindings (make-rb-tree eq? symbol<?) read-only #t)
(define-integrable (file-case-clause/files clause)
(cdr clause))
\f
-(define-structure
- (binding
- (type vector)
- (named (string->symbol "#[(cross-reference)binding]"))
- (constructor %make-binding (package name value-cell new?))
- (conc-name binding/)
- (print-procedure
- (standard-unparser-method 'BINDING
- (lambda (binding port)
- (write-char #\space port)
- (write (binding/name binding) port)
- (write-char #\space port)
- (write (package/name (binding/package binding)) port)))))
+(define-structure (package-load
+ (conc-name package-load/))
+ (package #f read-only #t)
+ (file-cases '())
+ (initializations #f)
+ (finalizations #f))
+
+(define-structure (binding
+ (constructor %make-binding (package name value-cell new?))
+ (conc-name binding/)
+ (print-procedure
+ (standard-unparser-method 'BINDING
+ (lambda (binding port)
+ (write-char #\space port)
+ (write (binding/name binding) port)
+ (write-char #\space port)
+ (write (package/name (binding/package binding))
+ port)))))
(package #f read-only #t)
(name #f read-only #t)
(value-cell #f read-only #t)
(define (binding/internal? binding)
(eq? binding (binding/source-binding binding)))
-(define-structure
- (value-cell
- (type vector)
- (named (string->symbol "#[(cross-reference)value-cell]"))
- (constructor make-value-cell ())
- (conc-name value-cell/))
+(define-structure (value-cell
+ (constructor make-value-cell ())
+ (conc-name value-cell/))
(bindings '())
(expressions '())
(source-binding #f))
-(define-structure
- (link
- (type vector)
- (named (string->symbol "#[(cross-reference)link]"))
- (constructor %make-link (source destination new?))
- (conc-name link/))
+(define-structure (link
+ (constructor %make-link (source destination owner new?))
+ (conc-name link/))
(source #f read-only #t)
(destination #f read-only #t)
+ (owner #f read-only #t)
(new? #f read-only #t))
-(define (make-link source-binding destination-binding owner-package new?)
- (let ((link (%make-link source-binding destination-binding new?)))
+(define (make-link source-binding destination-binding owner new?)
+ (let ((link (%make-link source-binding destination-binding owner new?)))
(set-binding/links! source-binding
(cons link (binding/links source-binding)))
- (set-package/links! owner-package
- (cons link (package/links owner-package)))
+ (set-package/links! owner (cons link (package/links owner)))
link))
\f
-(define-structure
- (expression
- (type vector)
- (named (string->symbol "#[(cross-reference)expression]"))
- (constructor make-expression (package file type))
- (conc-name expression/))
+(define-structure (expression
+ (constructor make-expression (package file type))
+ (conc-name expression/))
(package #f read-only #t)
(file #f read-only #t)
(type #f read-only #t)
(references '())
(value-cell #f))
-(define-structure
- (reference
- (type vector)
- (named (string->symbol "#[(cross-reference)reference]"))
- (constructor %make-reference (package name))
- (conc-name reference/)
- (print-procedure
- (standard-unparser-method 'REFERENCE
- (lambda (reference port)
- (write-char #\space port)
- (write (reference/name reference) port)
- (write-char #\space port)
- (write (package/name (reference/package reference)) port)))))
+(define-structure (reference
+ (constructor %make-reference (package name))
+ (conc-name reference/)
+ (print-procedure
+ (standard-unparser-method 'REFERENCE
+ (lambda (reference port)
+ (write-char #\space port)
+ (write (reference/name reference) port)
+ (write-char #\space port)
+ (write (package/name (reference/package reference))
+ port)))))
(package #f read-only #t)
(name #f read-only #t)
(expressions '())
#| -*-Scheme-*-
-$Id: redpkg.scm,v 1.17 2001/08/20 02:49:09 cph Exp $
+$Id: redpkg.scm,v 1.18 2001/08/20 21:02:41 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(with-values
(lambda ()
(sort-descriptions (read-and-parse-model model-pathname)))
- (lambda (packages extensions globals)
+ (lambda (packages extensions loads globals)
(descriptions->pmodel
packages
extensions
+ loads
(map (lambda (pathname)
(cons
(->namestring pathname)
#f)))))
globals)
model-pathname)))))
-
+\f
(define (sort-descriptions descriptions)
- (let ((packages '())
- (extensions '())
- (globals '()))
- (let loop ((descriptions descriptions))
- (for-each (lambda (description)
- (case (car description)
- ((DEFINE-PACKAGE)
- (set! packages (cons (cdr description) packages)))
- ((EXTEND-PACKAGE)
- (set! extensions (cons (cdr description) extensions)))
- ((GLOBAL-DEFINITIONS)
- (set! globals
- (append! globals (list-copy (cdr description)))))
- ((NESTED-DESCRIPTIONS)
- (loop (cdr description)))
- (else
- (error "Unknown description keyword:"
- (car description)))))
- descriptions))
- (values (reverse! packages)
- (reverse! extensions)
- globals)))
+ (letrec
+ ((loop
+ (lambda (descriptions packages extensions loads globals)
+ (if (pair? descriptions)
+ (let ((description (car descriptions))
+ (descriptions (cdr descriptions)))
+ (case (car description)
+ ((DEFINE-PACKAGE)
+ (loop descriptions
+ (cons (cdr description) packages)
+ extensions
+ (if (interesting-package-to-load? (cdr description))
+ (cons (cdr description) loads)
+ loads)
+ globals))
+ ((EXTEND-PACKAGE)
+ (loop descriptions
+ packages
+ (cons (cdr description) extensions)
+ (if (interesting-package-to-load? (cdr description))
+ (cons (cdr description) loads)
+ loads)
+ globals))
+ ((GLOBAL-DEFINITIONS)
+ (loop descriptions
+ packages
+ extensions
+ 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))))
+ (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))))))
+
+(define (interesting-package-to-load? description)
+ (or (pair? (package-description/file-cases description))
+ (pair? (package-description/initializations description))
+ (pair? (package-description/finalizations description))))
\f
(define (read-file-analyses! pmodel)
(call-with-values (lambda () (cache-file-analyses! pmodel))
((FILES)
(set-package-description/file-cases!
package
- (append (package-description/file-cases package)
- (list (parse-filenames (cdr option))))))
+ (append! (package-description/file-cases package)
+ (list (parse-filenames (cdr option))))))
((FILE-CASE)
(set-package-description/file-cases!
package
- (append (package-description/file-cases package)
- (list (parse-file-case (cdr option))))))
+ (append! (package-description/file-cases package)
+ (list (parse-file-case (cdr option))))))
((EXPORT)
(set-package-description/exports!
package
- (append (package-description/exports package)
- (list (parse-import/export (cdr option))))))
+ (append! (package-description/exports package)
+ (list (parse-import/export (cdr option))))))
((IMPORT)
(set-package-description/imports!
package
- (append (package-description/imports package)
- (list (parse-import/export (cdr option))))))
+ (append! (package-description/imports package)
+ (list (parse-import/export (cdr option))))))
((INITIALIZATION)
- (if (package-description/initialization package)
- (error "Multiple INITIALIZATION options:" option))
- (set-package-description/initialization!
- package
- (parse-initialization (cdr option))))
+ (let ((initialization (parse-initialization (cdr option))))
+ (if initialization
+ (set-package-description/initializations!
+ package
+ (append! (package-description/initializations package)
+ (list initialization))))))
+ ((FINALIZATION)
+ (let ((finalization (parse-initialization (cdr option))))
+ (if finalization
+ (set-package-description/finalizations!
+ package
+ (append! (package-description/finalizations package)
+ (list finalization))))))
(else
(error "Unrecognized option keyword:" (car option)))))
options))
(->pathname filename))
(define (parse-initialization initialization)
- (if (not (and (pair? initialization) (null? (cdr initialization))))
- (error "illegal initialization" initialization))
- (car initialization))
+ (if (and (pair? initialization) (null? (cdr initialization)))
+ (car initialization)
+ (begin
+ (warn "Illegal initialization/finalization:" initialization)
+ #f)))
(define (parse-import/export object)
(if (not (and (pair? object)
\f
;;;; Packages
-(define (descriptions->pmodel descriptions extensions globals pathname)
+(define (descriptions->pmodel descriptions extensions loads globals pathname)
(let ((packages
(map (lambda (description)
(make-package (package-description/name description) 'UNKNOWN))
extension
get-package
#f))
- extensions))
- (make-pmodel root-package
- (make-package primitive-package-name #f)
- packages
- extra-packages
- pathname))))
+ extensions)
+ (make-pmodel root-package
+ (make-package primitive-package-name #f)
+ packages
+ extra-packages
+ (map (lambda (package)
+ (process-package-load
+ (get-package (package-description/name package)
+ #f)
+ package))
+ loads)
+ pathname)))))
\f
(define (process-globals-info file namestring get-package)
(for-each-vector-element (vector-ref file 2)
(set-package/parent! package #f))))
(let ((expression (make-expression package namestring #f)))
;; Unlinked internal names.
- (for-each-vector-element (vector-ref desc 5)
+ (for-each-vector-element (vector-ref desc 2)
(lambda (name)
(bind! package name expression #f)))
;; Exported bindings.
- (for-each-vector-element (vector-ref desc 6)
+ (for-each-vector-element (vector-ref desc 3)
(lambda (entry)
(let ((name (vector-ref entry 0))
(external-package (get-package (vector-ref entry 1) #t))
external-package external-name
package #f))))
;; Imported bindings.
- (for-each-vector-element (vector-ref desc 7)
+ (for-each-vector-element (vector-ref desc 4)
(lambda (entry)
(let ((external-package (get-package (vector-ref entry 1) #t))
(external-name
(define (process-package-description package description get-package new?)
(let ((file-cases (package-description/file-cases description)))
- (set-package/file-cases! package
- (append! (package/file-cases package)
- (list-copy file-cases)))
(set-package/files!
package
(append! (package/files package)
(append-map! (lambda (file-case)
(append-map cdr (cdr file-case)))
file-cases))))
- (let ((initialization (package-description/initialization description)))
- (if (and initialization
- (package/initialization package))
- (error "Multiple package initializations:" initialization))
- (set-package/initialization! package initialization))
(for-each (lambda (export)
(let ((destination (get-package (car export) #t)))
(for-each (lambda (names)
(define primitive-package-name
(list (string->symbol "#[(cross-reference reader)primitives]")))
+
+(define (process-package-load package description)
+ (make-package-load package
+ (package-description/file-cases description)
+ (package-description/initializations description)
+ (package-description/finalizations description)))
\f
;;;; Binding and Reference
#| -*-Scheme-*-
-$Id: triv.pkg,v 1.6 2001/08/20 02:49:18 cph Exp $
+$Id: triv.pkg,v 1.7 2001/08/20 21:02:43 cph Exp $
Copyright (c) 2001 Massachusetts Institute of Technology
;;;; CREF Packaging: hand-compiled package for bootstrapping
-(let ((v
- (let ((package
- (lambda (package-name ancestors files
- exported-names imported-names)
- (vector package-name
- ancestors
- (list (cons #f files))
- #f
- #f
- '#()
- (list->vector
- (map (lambda (name)
- (vector name (car ancestors)))
- exported-names))
- (list->vector
- (map (lambda (n.p)
- (vector (car n.p) (cdr n.p)))
- imported-names))
- #f))))
- (vector (package '(cross-reference)
- '(())
- '("mset" "object" "toplev")
- '(cref/generate-all
- cref/generate-constructors
- cref/generate-cref
- cref/generate-cref-unusual
- cref/generate-trivial-constructor)
- '())
- (package '(cross-reference analyze-file)
- '((cross-reference) ())
- '("anfile")
- '(analyze-file)
- '())
- (package '(cross-reference constructor)
- '((cross-reference) ())
- '("conpkg")
- '(construct-external-descriptions)
- '())
- (package '(cross-reference formatter)
- '((cross-reference) ())
- '("forpkg")
- '(format-packages
- format-packages-unusual)
- '())
- (package '(cross-reference reader)
- '((cross-reference) ())
- '("redpkg")
- '(read-file-analyses!
- read-package-model
- resolve-references!)
- '((package-file? . (package))))))))
- (vector 'PACKAGE-DESCRIPTIONS 2 v v))
\ No newline at end of file
+(vector
+ 'PACKAGE-DESCRIPTIONS
+ 2
+ (let ((package
+ (lambda (package-name ancestors exported-names imported-names)
+ (vector package-name
+ ancestors
+ '#()
+ (list->vector
+ (map (lambda (name)
+ (vector name (car ancestors)))
+ exported-names))
+ (list->vector
+ (map (lambda (n.p)
+ (vector (car n.p) (cdr n.p)))
+ imported-names))
+ #f))))
+ (vector (package '(cross-reference)
+ '(())
+ '(cref/generate-all
+ cref/generate-constructors
+ cref/generate-cref
+ cref/generate-cref-unusual
+ cref/generate-trivial-constructor)
+ '())
+ (package '(cross-reference analyze-file)
+ '((cross-reference) ())
+ '(analyze-file)
+ '())
+ (package '(cross-reference constructor)
+ '((cross-reference) ())
+ '(construct-external-descriptions)
+ '())
+ (package '(cross-reference formatter)
+ '((cross-reference) ())
+ '(format-packages
+ format-packages-unusual)
+ '())
+ (package '(cross-reference reader)
+ '((cross-reference) ())
+ '(read-file-analyses!
+ read-package-model
+ resolve-references!)
+ '((package-file? . (package))))))
+ (let ((files
+ (lambda (package-name . files)
+ (vector package-name
+ (vector (list->vector files))
+ '#()
+ '#()))))
+ (vector (files '(cross-reference) "mset" "object" "toplev")
+ (files '(cross-reference analyze-file) "anfile")
+ (files '(cross-reference constructor) "conpkg")
+ (files '(cross-reference formatter) "forpkg")
+ (files '(cross-reference reader) "redpkg"))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: packag.scm,v 14.33 2001/08/20 02:48:31 cph Exp $
+$Id: packag.scm,v 14.34 2001/08/20 21:02:13 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(conc-name package-file/))
(tag #f read-only #t)
(version #f read-only #t)
- (sorted-descriptions #f read-only #t)
- (descriptions #f read-only #t))
+ (descriptions #f read-only #t)
+ (loads #f read-only #t))
(define-structure (package-description (type vector)
(conc-name package-description/))
(name #f read-only #t)
(ancestors #f read-only #t)
- (file-cases #f read-only #t)
- (initialization #f read-only #t)
- (finalization #f read-only #t)
(internal-names #f read-only #t)
(exports #f read-only #t)
(imports #f read-only #t)
(extension? #f read-only #t))
+(define-structure (load-description (type vector)
+ (conc-name load-description/))
+ (name #f read-only #t)
+ (file-cases #f read-only #t)
+ (initializations #f read-only #t)
+ (finalizations #f read-only #t))
+
(define (package-file? object)
(and (vector? object)
(fix:= (vector-length object) 4)
(eq? (package-file/tag object) 'PACKAGE-DESCRIPTIONS)
(and (index-fixnum? (package-file/version object))
(fix:= (package-file/version object) 2))
- (let ((descriptions (package-file/sorted-descriptions object)))
- (and (vector? descriptions)
- (let ((n (vector-length descriptions)))
- (let loop ((i 0))
- (or (fix:= i n)
- (and (package-description? (vector-ref descriptions i))
- (loop (fix:+ i 1))))))))
- ;; This is the same as sorted-descriptions, in a different order.
- ;; Don't bother to check it.
- (vector? (package-file/descriptions object))))
+ (vector-of-type? (package-file/descriptions object)
+ package-description?)
+ (vector-of-type? (package-file/loads object)
+ load-description?)))
(define (package-description? object)
(and (vector? object)
- (fix:= (vector-length object) 9)
+ (fix:= (vector-length object) 6)
(package-name? (package-description/name object))
(list-of-type? (package-description/ancestors object) package-name?)
- (list-of-type? (package-description/file-cases object)
- (lambda (case)
- (and (pair? case)
- (or (and (not (car case))
- (list-of-type? (cdr case) string?))
- (and (symbol? (car case))
- (list-of-type? (cdr case)
- (lambda (clause)
- (and (pair? clause)
- (or (list-of-type? (car clause) symbol?)
- (eq? (car clause) 'ELSE))
- (list-of-type? (cdr clause) string?)))))))))
(vector-of-type? (package-description/internal-names object) symbol?)
(vector-of-type? (package-description/exports object) link-description?)
(vector-of-type? (package-description/imports object) link-description?)
(package-name? (vector-ref object 1))
(symbol? (vector-ref object 2))))
(else #f))))
+
+(define (load-description? object)
+ (and (vector? object)
+ (fix:= (vector-length object) 4)
+ (package-name? (load-description/name object))
+ (vector-of-type? (load-description/file-cases object)
+ (lambda (file-case)
+ (if (pair? file-case)
+ (and (symbol? (car file-case))
+ (vector-of-type? (cdr file-case)
+ (lambda (clause)
+ (and (pair? clause)
+ (or (eq? (car clause) 'ELSE)
+ (vector-of-type? (car clause) symbol?))
+ (vector-of-type? (cdr clause) string?)))))
+ (vector-of-type? file-case string?))))
+ (vector? (load-description/initializations object))
+ (vector? (load-description/finalizations object))))
\f
;; CONSTRUCT-PACKAGES-FROM-FILE is called from the cold load and must
;; only use procedures that are inline-coded by the compiler.
(define (construct-packages-from-file file)
- (let ((descriptions (package-file/sorted-descriptions file))
+ (let ((descriptions (package-file/descriptions file))
(skip-package?
(lambda (name)
(or (null? name)
;; use procedures that are inline-coded by the compiler.
(define (load-packages-from-file file options file-loader)
- (let ((descriptions (package-file/descriptions file)))
- (let ((n (vector-length descriptions)))
+ (let ((loads (package-file/loads file)))
+ (let ((n (vector-length loads)))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
- (let ((description (vector-ref descriptions i)))
+ (let ((description (vector-ref loads i)))
(load-package-from-description
- (find-package (package-description/name description))
+ (find-package (load-description/name description))
description
options
file-loader))))))
(let ((environment (package/environment package)))
(let ((load-files
(lambda (filenames)
- (do ((filenames filenames (cdr filenames)))
- ((not (pair? filenames)))
- (file-loader (car filenames) environment)))))
- (do ((cases (package-description/file-cases description) (cdr cases)))
- ((not (pair? cases)))
- (let ((case (car cases)))
- (let ((key (car case)))
- (if key
- (let ((option (lookup-option key options)))
+ (let ((n (vector-length filenames)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (file-loader (vector-ref filenames i) environment)))))
+ (cases (load-description/file-cases description)))
+ (let ((n (vector-length cases)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((file-case (vector-ref cases i)))
+ (if (pair? file-case)
+ (let ((option (lookup-option (car file-case) options)))
(if (not option)
(error "Missing key:" key))
- (do ((clauses (cdr case) (cdr clauses)))
- ((not (pair? clauses)))
- (let ((clause (car clauses)))
- (if (let loop ((options (car clause)))
- (and (pair? options)
- (or (eq? (car options) option)
- (loop (cdr options)))))
- (load-files (cdr clause))))))
- (load-files (cdr case)))))))))
+ (let ((clauses (cdr file-case)))
+ (let ((n (vector-length clauses)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((clause (vector-ref clauses i)))
+ (if (let ((keys (car clause)))
+ (or (eq? keys 'ELSE)
+ (let ((n (vector-length keys)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (or (eq? (vector-ref keys i)
+ option)
+ (loop (fix:+ i 1))))))))
+ (load-files (cdr clause))))))))
+ (load-files file-case))))))))
(define (lookup-option key options)
(let loop ((options options))
(loop (cdr options))))))
(define (initialize-packages-from-file file)
- (initialize/finalize file package-description/initialization "Initializing"))
+ (initialize/finalize file load-description/initializations "Initializing"))
(define (finalize-packages-from-file file)
- (initialize/finalize file package-description/finalization "Finalizing"))
+ (initialize/finalize file load-description/finalizations "Finalizing"))
(define (initialize/finalize file selector verb)
- (for-each-vector-element (package-file/descriptions file)
+ (for-each-vector-element (package-file/loads file)
(lambda (description)
- (let ((expression (selector description)))
- (if expression
- (let ((name (package-description/name description))
+ (let ((expressions (selector description)))
+ (if (fix:> (vector-length expressions) 0)
+ (let ((name (load-description/name description))
(port (notification-output-port)))
(fresh-line port)
(write-string ";" port)
(write-string verb port)
(write-string " package " port)
(write name port)
- (eval expression (find-package-environment name))
+ (for-each-vector-element expressions
+ (let ((environment (find-package-environment name)))
+ (lambda (expression)
+ (eval expression environment))))
(write-string " -- done" port)
(newline port)))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff