Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
- of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
This file is part of MIT/GNU Scheme.
(map cdr
(sort (append!
(map (lambda (package)
- (cons package (package->external package #f)))
+ (cons (package/ancestry package)
+ (package->external package #f)))
(pmodel/packages pmodel))
(map (lambda (package)
- (cons package (package->external package #t)))
+ (cons (package/ancestry package)
+ (package->external package #t)))
(new-extension-packages pmodel)))
(lambda (a b)
- (package-structure<? (car a) (car b))))))
+ (package-ancestry<? (car a) (car b))))))
(list->vector
(map package-load->external
(list-transform-positive (pmodel/loads pmodel)
(lambda (link)
(eq? (link/owner link) package)))))))
-(define (package-structure<? x y)
- (cond ((package/topological<? x y) #t)
- ((package/topological<? y x) #f)
- (else (package<? x y))))
-
-(define (package/topological<? x y)
- (and (not (eq? x y))
- (let loop ((y (package/parent y)))
- (and (package? y)
- (if (eq? x y)
- #t
- (loop (package/parent y)))))))
+(define (package/ancestry package)
+ (let loop ((parent (package/parent package))
+ (ancestors (list (package/name package))))
+ (if parent
+ (loop (package/parent parent)
+ (cons (package/name parent) ancestors))
+ ancestors)))
+
+(define (package-ancestry<? x y)
+ (cond ((symbol-list<? (car x) (car y)) #t)
+ ((symbol-list<? (car y) (car x)) #f)
+ ((null? (cdr x)) (not (null? (cdr y))))
+ ((null? (cdr y)) #f)
+ (else (package-ancestry<? (cdr x) (cdr y)))))
\f
(define (package->external package extension?)
(call-with-values (lambda () (split-links package))
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
- of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
This file is part of MIT/GNU Scheme.
(export 'NAME->PACKAGE)
(export 'PACKAGE-SET-PATHNAME)
(export 'PACKAGE/ADD-CHILD!)
- (export 'PACKAGE/CHILD)
(export 'PACKAGE/CHILDREN)
(export 'PACKAGE/ENVIRONMENT)
(export 'PACKAGE/NAME)
(export 'PACKAGE/PARENT)
(export 'PACKAGE/REFERENCE)
- (export 'PACKAGE?)
- (export 'SYSTEM-GLOBAL-PACKAGE))
-(package/add-child! system-global-package 'PACKAGE environment-for-package)
+ (export 'PACKAGE?))
+(package/add-child! (find-package '()) 'PACKAGE environment-for-package)
(define packages-file
(let ((name
)
-(package/add-child! system-global-package 'USER user-initial-environment)
+(package/add-child! (find-package '()) 'USER user-initial-environment)
;; Might be better to do this sooner, to trap on floating-point
;; mistakes earlier in the cold load.
(flo:set-environment! (flo:default-environment))
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
- of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
This file is part of MIT/GNU Scheme.
(define-integrable (set-package/children! package children)
(%record-set! package 2 children))
-(define-integrable (package/%name package)
+(define-integrable (package/name package)
(%record-ref package 3))
(define-integrable (package/environment package)
(define (finalize-package-record-type!)
(let ((rtd
- (make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT))))
+ (make-record-type "package" '(PARENT CHILDREN NAME ENVIRONMENT))))
(let ((tag (record-type-dispatch-tag rtd)))
(set! package-tag tag)
- (let loop ((package system-global-package))
- (%record-set! package 0 tag)
- (for-each loop (package/children package))))
+ (for-each (lambda (p) (%record-set! p 0 tag)) *packages*))
(set-record-type-unparser-method! rtd
(standard-unparser-method 'PACKAGE
(lambda (package port)
(write-char #\space port)
(write (package/name package) port))))))
\f
-(define (package/child package name)
- (let loop ((children (package/children package)))
- (and (pair? children)
- (if (eq? name (package/%name (car children)))
- (car children)
- (loop (cdr children))))))
-
-(define (package/name package)
- (let loop ((package package) (result '()))
- (if (package/parent package)
- (loop (package/parent package) (cons (package/%name package) result))
- result)))
-
(define (name->package name)
- (let loop ((path name) (package system-global-package))
- (if (pair? path)
- (let ((child (package/child package (car path))))
- (and child
- (loop (cdr path) child)))
- package)))
+ (find-package name #f))
+
+(define (all-packages)
+ (let loop ((packages *packages*))
+ (if (pair? packages)
+ (cons (car packages) (loop (cdr packages)))
+ '())))
(define (environment->package environment)
(and (interpreter-environment? environment)
((ucode-primitive string->symbol) "#[(package)package-name-tag]"))
(define (find-package name #!optional error?)
- (let loop ((path name) (package system-global-package))
- (if (pair? path)
- (loop (cdr path)
- (let ((child (package/child package (car path))))
- (if (and (not child) error?)
- (error "Unable to find package:"
- (list-difference name (cdr path))))
- child))
- package)))
-
-(define (list-difference list tail)
- (let loop ((list list))
- (if (eq? list tail)
- '()
- (cons (car list) (loop (cdr list))))))
+ (let package-loop ((packages *packages*))
+ (if (null? packages)
+ (if error?
+ (error "Unable to find package:" name)
+ #f)
+ (if (let name-loop ((name1 name)
+ (name2 (package/name (car packages))))
+ (cond ((and (null? name1) (null? name2)) #t)
+ ((or (null? name1) (null? name2)) #f)
+ ((eq? (car name1) (car name2))
+ (name-loop (cdr name1) (cdr name2)))
+ (else #f)))
+ (car packages)
+ (package-loop (cdr packages))))))
+
+(define (name-append name package)
+ (let loop ((names (package/name package)))
+ (if (pair? names)
+ (cons (car names) (loop (cdr names)))
+ (cons name '()))))
(define (package/add-child! package name environment #!optional force?)
- (let ((child (package/child package name))
- (finish
- (lambda (child)
- (if (not (interpreter-environment->package environment))
- (local-assignment environment package-name-tag child))
- child)))
+ (let* ((real-name (name-append name package))
+ (child (find-package real-name #f)))
(if child
(begin
(if (not (if (default-object? force?)
(error "Package already has child of given name:" package name))
(set-package/environment! child environment)
(set-package/children! child '())
- (finish child))
- (let ((child (make-package package name environment)))
- (set-package/children! package
- (cons child (package/children package)))
- (finish child)))))
+ (if (not (interpreter-environment->package environment))
+ (local-assignment environment package-name-tag child))
+ child)
+ (package/create real-name package environment))))
-(define system-global-package)
+(define *packages* '())
(define *allow-package-redefinition?* #f)
(define (initialize-package!)
- (set! system-global-package (make-package #f #f system-global-environment))
- (local-assignment system-global-environment
- package-name-tag
- system-global-package))
+ (set! *packages* '())
+ (package/create '() #f system-global-environment))
\f
(define (load-package-set filename #!optional options)
(let ((pathname (merge-pathnames filename))
(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.
+;; CONSTRUCT-PACKAGES-FROM-FILE is called from the cold load before
+;; the runtime system is loaded. Thus it must only call procedures
+;; that are defined in this file.
(define (construct-packages-from-file file)
(let ((descriptions (package-file/descriptions file))
((fix:= i n))
(let ((description (vector-ref descriptions i)))
(let ((name (package-description/name description)))
- (if (not (skip-package? name))
- (construct-normal-package-from-description description)))))
+ (if (and (not (skip-package? name))
+ (not (package-description/extension? description))
+ ;; If there is an existing package, treat this as
+ ;; though an extension.
+ (not (find-package name #f)))
+ (create-package-from-description description)))))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
(let ((description (vector-ref descriptions i)))
(if (not (skip-package? name))
(create-links-from-description description))))))))
-(define (construct-normal-package-from-description description)
- (let ((name (package-description/name description))
- (extension? (package-description/extension? description))
- (environment
- (extend-package-environment
- (let ((ancestors (package-description/ancestors description)))
- (if (pair? ancestors)
- (package/environment (find-package (car ancestors)))
- null-environment))
- (cons (package-description/internal-names description)
- (lambda (name) name))
- (cons (package-description/exports description)
- (lambda (binding) (vector-ref binding 0)))
- (cons (package-description/imports description)
- (lambda (binding) (vector-ref binding 0))))))
- (let loop ((path name) (package system-global-package))
- (if (pair? (cdr path))
- (loop (cdr path)
- (or (package/child package (car path))
- (error "Unable to find package:"
- (list-difference name (cdr path)))))
- (if (not (and extension? (package/child package (car path))))
- (package/add-child! package (car path) environment))))))
+(define (create-package-from-description description)
+ (let* ((parent (let ((ancestors (package-description/ancestors description)))
+ (if (pair? ancestors)
+ (find-package (car ancestors))
+ #f)))
+ (environment
+ (extend-package-environment
+ (if parent (package/environment parent) null-environment)
+ (cons (package-description/internal-names description)
+ (lambda (name) name))
+ (cons (package-description/exports description)
+ (lambda (binding) (vector-ref binding 0)))
+ (cons (package-description/imports description)
+ (lambda (binding) (vector-ref binding 0))))))
+ (package/create (package-description/name description) parent environment)))
+
+(define (package/create name parent environment)
+ (let ((new (make-package parent name environment)))
+ (local-assignment environment package-name-tag new)
+ (if parent
+ (set-package/children! parent (cons new (package/children parent))))
+ (set! *packages* (cons new *packages*))
+ new))
(define (create-links-from-description description)
(let ((environment
projects / mit-scheme.git / commitdiff