Old format was code to build the packages and load files into them.
New format is a summary description of the packages, which is
interpreted at run time to provide the same functionality.
The purpose of this change is to support uninstallation and
replacement of packages. The new compiled package descriptions are
general enough for this purpose.
#| -*-Scheme-*-
-$Id: conpkg.scm,v 1.8 2001/08/09 03:06:12 cph Exp $
+$Id: conpkg.scm,v 1.9 2001/08/15 02:59:35 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(declare (usual-integrations)
(integrate-external "object"))
\f
-;;; Construct expressions to construct the package structure.
-
-(define (construct-constructor pmodel)
- (let ((packages (pmodel/packages pmodel)))
- ;; SYSTEM-GLOBAL-ENVIRONMENT is here so that it is not integrated.
- ;; This is necessary for cross-syntaxing when the representation of
- ;; #F, () or the system-global-environment changes.
- `((DECLARE (USUAL-INTEGRATIONS SYSTEM-GLOBAL-ENVIRONMENT))
- ,@(append-map*
- (let ((links
- (append-map*
- (append-map construct-links (pmodel/extra-packages pmodel))
- construct-links packages)))
- (if (pair? links)
- `((LET ((LINK-VARIABLES
- (LET-SYNTAX
- ((UCODE-PRIMITIVE
- (MACRO (NAME ARITY)
- (MAKE-PRIMITIVE-PROCEDURE NAME ARITY))))
- (UCODE-PRIMITIVE LINK-VARIABLES 4))))
- ,@links))
- '()))
- construct-definitions
- (sort packages package-structure<?)))))
-
-(define (construct-definitions package)
- (cond ((package/root? package)
- `((IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
- ,@(map (lambda (binding) `(DEFINE ,(binding/name binding)))
- (package/source-bindings package)))))
- ((equal? (package/name package) '(PACKAGE))
- ;; This environment is hand built by the cold-load.
- '())
- (else
- (package-definition
- (package/name package)
- `(IN-PACKAGE ,(package-reference (package/parent package))
- (LET (,@(map (lambda (binding) `(,(binding/name binding)))
- (package/source-bindings package)))
- (THE-ENVIRONMENT)))))))
-
-(define (construct-links package)
- (if (equal? (package/name package) '(PACKAGE))
- '()
- (append-map
- (lambda (binding)
- (map (lambda (link)
- (let ((source (link/source link))
- (destination (link/destination link)))
- `(LINK-VARIABLES
- ,(package-reference (binding/package destination))
- ',(binding/name destination)
- ,(package-reference (binding/package source))
- ',(binding/name source))))
- (binding/links binding)))
- (package/sorted-bindings package))))
-
-(define (package/source-bindings package)
- (list-transform-positive (package/sorted-bindings package)
- (lambda (binding)
- (eq? (binding/source-binding binding) binding))))
+(define (construct-external-descriptions pmodel)
+ (let* ((packages (pmodel/packages pmodel))
+ (alist
+ (map (lambda (package)
+ (cons package (construct-external-description package)))
+ packages)))
+ (vector 'PACKAGE-DESCRIPTIONS ;tag
+ 2 ;version
+ (list->vector
+ (map (lambda (package)
+ (cdr (assq package alist)))
+ (sort packages package-structure<?)))
+ (list->vector (map cdr alist)))))
+
+(define (construct-external-description package)
+ (call-with-values
+ (lambda ()
+ (split-bindings-list (package/sorted-bindings package)))
+ (lambda (internal external)
+ (vector (package/name package)
+ (let ((parent (package/parent package)))
+ (if parent
+ (package/name parent)
+ 'NONE))
+ (map (let ((map-files
+ (lambda (clause)
+ (map ->namestring
+ (file-case-clause/files clause)))))
+ (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-negative internal
+ (lambda (binding)
+ (pair? (binding/links binding))))))
+ (list->vector
+ (map (lambda (binding)
+ (list->vector
+ (cons (binding/name binding)
+ (map (lambda (link)
+ (let ((dest (link/destination link)))
+ (cons (package/name
+ (binding/package dest))
+ (binding/name dest))))
+ (binding/links binding)))))
+ (list-transform-positive internal
+ (lambda (binding)
+ (pair? (binding/links binding))))))
+ (list->vector
+ (map (lambda (binding)
+ (let ((source (binding/source-binding binding)))
+ (if (eq? (binding/name binding) (binding/name source))
+ (vector (binding/name binding)
+ (package/name (binding/package source)))
+ (vector (binding/name binding)
+ (package/name (binding/package source))
+ (binding/name source)))))
+ external))))))
+
+(define (split-bindings-list bindings)
+ (let loop ((bindings bindings) (internal '()) (external '()))
+ (if (pair? bindings)
+ (if (binding/internal? (car bindings))
+ (loop (cdr bindings)
+ (cons (car bindings) internal)
+ external)
+ (loop (cdr bindings)
+ internal
+ (cons (car bindings) external)))
+ (values (reverse! internal) (reverse! external)))))
(define (package-structure<? x y)
(cond ((package/topological<? x y) true)
(and y
(if (eq? x y)
true
- (loop (package/parent y)))))))
-\f
-;;; Construct a procedure which will load the files into the package
-;;; structure.
-
-(define (construct-loader pmodel)
- `((DECLARE (USUAL-INTEGRATIONS))
- (LAMBDA (LOAD KEY-ALIST)
- (LET ((LOOKUP-KEY
- (LAMBDA (KEY)
- (LET LOOP ((ALIST KEY-ALIST))
- (IF (NULL? ALIST)
- (ERROR "Missing key" KEY))
- (IF (EQ? KEY (CAR (CAR ALIST)))
- (CDR (CAR ALIST))
- (LOOP (CDR ALIST)))))))
- LOOKUP-KEY ;ignore if not referenced
- ,@(append-map (lambda (package)
- (let ((reference (package-reference package)))
- (if (> (package/n-files package) 1)
- `((LET ((ENVIRONMENT ,reference))
- ,@(load-package package 'ENVIRONMENT)))
- (load-package package reference))))
- (pmodel/packages pmodel))))))
-
-(define (load-package package environment)
- (append-map (lambda (file-case)
- (let ((type (file-case/type file-case)))
- (if type
- `((CASE (LOOKUP-KEY ',type)
- ,@(map (lambda (clause)
- `(,(file-case-clause/keys clause)
- ,@(clause-loader clause environment)))
- (file-case/clauses file-case))))
- (clause-loader (car (file-case/clauses file-case))
- environment))))
- (package/file-cases package)))
-
-(define (clause-loader clause environment)
- (let ((files (file-case-clause/files clause)))
- (if (null? files)
- `(FALSE)
- (map (lambda (file)
- `(LOAD ,(->namestring file) ,environment))
- files))))
-
-(define (package-definition name value)
- (let ((path (reverse name)))
- `((PACKAGE/ADD-CHILD! (FIND-PACKAGE ',(reverse (cdr path)))
- ',(car path)
- ,value))))
-
-(define (package-reference package)
- `(PACKAGE/ENVIRONMENT (FIND-PACKAGE ',(package/name package))))
\ No newline at end of file
+ (loop (package/parent y)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: cref.pkg,v 1.8 2001/08/09 03:05:30 cph Exp $
+$Id: cref.pkg,v 1.9 2001/08/15 02:59:39 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(files "conpkg")
(parent (cross-reference))
(export (cross-reference)
- construct-constructor
- construct-loader))
+ construct-external-descriptions))
(define-package (cross-reference formatter)
(files "forpkg")
#| -*-Scheme-*-
-$Id: cref.sf,v 1.12 2001/05/29 21:25:33 cph Exp $
+$Id: cref.sf,v 1.13 2001/08/15 02:59:46 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(sf-conditionally "object")
(sf-directory ".")
-(if (not (file-exists? "cref.bco"))
- (sf "triv.con" "cref.bco"))
-(if (not (file-exists? "cref.bld"))
- (sf "triv.ldr" "cref.bld"))
+(if (not (file-exists? "cref.pkd"))
+ (fasdump (load "triv.pkg") "cref.pkd"))
-(if (file-exists? "../runtime/runtime.glo")
+(if (file-exists? "../runtime/runtime.pkd")
(begin
(if (not (name->package '(CROSS-REFERENCE)))
(load "make"))
- (cref/generate-constructors "cref")
- (sf-conditionally "cref.con")
- (sf-conditionally "cref.ldr")))
\ No newline at end of file
+ (cref/generate-constructors "cref")))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: make.scm,v 1.20 2001/08/09 03:06:14 cph Exp $
+$Id: make.scm,v 1.21 2001/08/15 02:59:50 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(lambda ()
(load-option 'RB-TREE)
(package/system-loader "cref" '() #f)))))
-(add-identification! "CREF" 1 20)
\ No newline at end of file
+(add-identification! "CREF" 2 0)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: object.scm,v 1.10 1999/01/02 06:11:34 cph Exp $
+$Id: object.scm,v 1.11 2001/08/15 02:59:54 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
|#
;;;; Package Model Data Structures
(file-cases '())
(parent #f read-only #t)
(initialization #f)
+ (finalization #f)
(exports '())
(imports '()))
(file-cases '())
(files '())
(initialization #f)
+ (finalization #f)
parent
(children '())
(bindings (make-rb-tree eq? symbol<?) read-only #t)
#| -*-Scheme-*-
-$Id: toplev.scm,v 1.13 2000/01/18 20:39:42 cph Exp $
+$Id: toplev.scm,v 1.14 2001/08/15 02:59:58 cph Exp $
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
|#
;;;; Package Model: Top Level
(define (cref/generate-trivial-constructor filename)
(let ((pathname (merge-pathnames filename)))
- (write-constructor pathname (read-package-model pathname) #f)))
+ (write-external-descriptions pathname (read-package-model pathname) #f)))
(define cref/generate-cref
(generate/common
(lambda (pathname pmodel changes?)
(write-cref-unusual pathname pmodel changes?)
(write-globals pathname pmodel changes?)
- (write-constructor pathname pmodel changes?)
- (write-loader pathname pmodel changes?))))
+ (write-external-descriptions pathname pmodel changes?))))
(define cref/generate-all
(generate/common
(lambda (pathname pmodel changes?)
(write-cref pathname pmodel changes?)
(write-globals pathname pmodel changes?)
- (write-constructor pathname pmodel changes?)
- (write-loader pathname pmodel changes?))))
-\f
-(define (write-constructor pathname pmodel changes?)
- (if (or changes? (not (file-processed? pathname "pkg" "con")))
- (let ((constructor (construct-constructor pmodel)))
- (with-output-to-file (pathname-new-type pathname "con")
- (lambda ()
- (fluid-let ((*unparser-list-breadth-limit* #F)
- (*unparser-list-depth-limit* #F))
- (write-string ";;; -*-Scheme-*-")
- (newline)
- (write-string ";;; program to make package structure")
- (newline)
- (write '(DECLARE (USUAL-INTEGRATIONS)))
- (for-each (lambda (expression)
- (pp expression (current-output-port) true))
- constructor)))))))
+ (write-external-descriptions pathname pmodel changes?))))
-(define (write-loader pathname pmodel changes?)
- changes?
- (if (not (file-processed? pathname "pkg" "ldr"))
- (let ((loader (construct-loader pmodel)))
- (with-output-to-file (pathname-new-type pathname "ldr")
- (lambda ()
- (fluid-let ((*unparser-list-breadth-limit* #F)
- (*unparser-list-depth-limit* #F))
- (write-string ";;; -*-Scheme-*-")
- (newline)
- (write-string ";;; program to load package contents")
- (newline)
- (write '(DECLARE (USUAL-INTEGRATIONS)))
- (for-each (lambda (expression)
- (pp expression (current-output-port) true))
- loader)))))))
+(define (write-external-descriptions pathname pmodel changes?)
+ (if (or changes? (not (file-processed? pathname "pkg" "pkd")))
+ (fasdump (construct-external-descriptions pmodel)
+ (pathname-new-type pathname "pkd"))))
(define (write-cref pathname pmodel changes?)
(if (or changes? (not (file-processed? pathname "pkg" "crf")))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: triv.pkg,v 1.1 2001/08/15 03:00:01 cph Exp $
+
+Copyright (c) 2001 Massachusetts Institute of Technology
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+|#
+
+;;;; CREF Packaging: hand-compiled package for bootstrapping
+
+(let ((v
+ (let ((package
+ (lambda (package-name parent-name files exported-names)
+ (vector package-name
+ parent-name
+ (list (cons #f files))
+ #f
+ #f
+ '#()
+ (list->vector
+ (map (lambda (name)
+ (vector name (cons parent-name name)))
+ exported-names))
+ '#()))))
+ (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!))))))
+ (vector 'PACKAGE-DESCRIPTIONS 2 v v))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: dragon4.scm,v 1.14 1999/01/02 06:11:34 cph Exp $
+$Id: dragon4.scm,v 1.15 2001/08/15 02:55:49 cph Exp $
Copyright (c) 1989-1999 Massachusetts Institute of Technology
(scale (int:* 2 r) (int:* 2 s) (int:* 2 m-))
(scale r s m-)))
-
-(define expt-radix
- (let ((v (make-initialized-vector 310 (lambda (i) (expt 10 i)))))
- (lambda (base exponent)
- (if (and (= base 10)
- (>= exponent 0)
- (< exponent (vector-length v)))
- (vector-ref v exponent)
- (rat:expt base exponent)))))
+(define expt-radix)
+
+(define (initialize-dragon4!)
+ (set! expt-radix
+ (let ((v (make-initialized-vector 310 (lambda (i) (expt 10 i)))))
+ (lambda (base exponent)
+ (if (and (= base 10)
+ (>= exponent 0)
+ (< exponent (vector-length v)))
+ (vector-ref v exponent)
+ (rat:expt base exponent)))))
+ unspecific)
\f
#| Test code. Re-run after changing anything.
#| -*-Scheme-*-
-$Id: list.scm,v 14.24 2000/05/02 20:39:37 cph Exp $
+$Id: list.scm,v 14.25 2001/08/15 02:55:55 cph Exp $
Copyright (c) 1988-2000 Massachusetts Institute of Technology
(loop (cdr l1) (cdr l2)))
(null? l1)))))
(null? l1))))
+
+(define (list-of-type? object predicate)
+ (let loop ((l1 object) (l2 object))
+ (if (pair? l1)
+ (and (predicate (car l1))
+ (let ((l1 (cdr l1)))
+ (and (not (eq? l1 l2))
+ (if (pair? l1)
+ (and (predicate (car l1))
+ (loop (cdr l1) (cdr l2)))
+ (null? l1)))))
+ (null? l1))))
\f
(define (list-copy items)
(let ((lose (lambda () (error:wrong-type-argument items "list" 'LIST-COPY))))
#| -*-Scheme-*-
-$Id: make.scm,v 14.70 2001/08/09 03:04:46 cph Exp $
+$Id: make.scm,v 14.71 2001/08/15 02:55:59 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(vector-ref values i)))))))))
;; This definition is replaced later in the boot sequence.
-
(define apply (ucode-primitive apply 2))
-;; This must go before the uses of the-environment later,
-;; and after apply above.
-
+;; *MAKE-ENVIRONMENT is referred to by compiled code. It must go
+;; before the uses of the-environment later, and after apply above.
(define (*make-environment parent names . values)
- (apply
- ((ucode-primitive scode-eval 2)
- #|
- (make-slambda (vector-ref names 0)
- (subvector->list names 1 (vector-length names)))
- |#
- ((ucode-primitive system-pair-cons 3) ; &typed-pair-cons
- (ucode-type lambda) ; slambda-type
- ((ucode-primitive object-set-type 2) ; (make-the-environment)
- (ucode-type the-environment)
- 0)
- names)
- parent)
- values))
-
-(define system-global-environment (the-environment))
-
-(define *dashed-hairy-migration-support:false-value*
- #F)
-
-(define *dashed-hairy-migration-support:system-global-environment*
- system-global-environment)
+ (apply ((ucode-primitive scode-eval 2)
+ ((ucode-primitive system-pair-cons 3)
+ (ucode-type lambda)
+ ((ucode-primitive object-set-type 2)
+ (ucode-type the-environment)
+ 0)
+ names)
+ parent)
+ values))
+
+(define system-global-environment
+ (the-environment))
\f
(let ((environment-for-package (let () (the-environment))))
+(define this-environment (the-environment))
+
(define-primitives
(+ integer-add)
(- integer-subtract)
;; Lotta hair here to load the package code before its package is built.
(eval (file->object "packag" #t #f) environment-for-package)
((access initialize-package! environment-for-package))
-(let loop ((names
- '(*ALLOW-PACKAGE-REDEFINITION?*
- ENVIRONMENT->PACKAGE
- FIND-PACKAGE
- NAME->PACKAGE
- PACKAGE/ADD-CHILD!
- PACKAGE/CHILD
- PACKAGE/CHILDREN
- PACKAGE/ENVIRONMENT
- PACKAGE/NAME
- PACKAGE/PARENT
- PACKAGE/REFERENCE
- PACKAGE/SYSTEM-LOADER
- PACKAGE?
- SYSTEM-GLOBAL-PACKAGE)))
- (if (pair? names)
- (begin
- (link-variables system-global-environment (car names)
- environment-for-package (car names))
- (loop (cdr names)))))
+(let ((export
+ (lambda (name)
+ (link-variables system-global-environment name
+ environment-for-package name))))
+ (export '*ALLOW-PACKAGE-REDEFINITION?*)
+ (export 'CONSTRUCT-PACKAGES-FROM-FILE)
+ (export 'ENVIRONMENT->PACKAGE)
+ (export 'FIND-PACKAGE)
+ (export 'LOAD-PACKAGES-FROM-FILE)
+ (export 'NAME->PACKAGE)
+ (export 'PACKAGE/ADD-CHILD!)
+ (export 'PACKAGE/CHILD)
+ (export 'PACKAGE/CHILDREN)
+ (export 'PACKAGE/ENVIRONMENT)
+ (export 'PACKAGE/NAME)
+ (export 'PACKAGE/PARENT)
+ (export 'PACKAGE/REFERENCE)
+ (export 'PACKAGE/SYSTEM-LOADER)
+ (export 'PACKAGE?)
+ (export 'SYSTEM-GLOBAL-PACKAGE))
(package/add-child! system-global-package 'PACKAGE environment-for-package)
-(eval (fasload "runtime.bco" #f) system-global-environment)
+
+(let ((import
+ (lambda (name)
+ (link-variables this-environment name
+ environment-for-package name))))
+ (import 'CONSTRUCT-PACKAGES-FROM-FILE)
+ (import 'LOAD-PACKAGES-FROM-FILE))
+(define packages-file (fasload "runtime.pkd" #f))
+(construct-packages-from-file packages-file)
;;; Global databases. Load, then initialize.
(let ((files1
(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
(package-initialize '(RUNTIME GC-FINALIZER) 'INITIALIZE-PACKAGE! #t)
-;; Load everything else.
-;; Note: The following code needs MAP* and MEMBER-PROCEDURE
-;; from runtime/list. Fortunately that file has already been loaded.
-
- ((eval (fasload "runtime.bld" #f) system-global-environment)
- (let ((to-avoid
- (cons "packag"
- (map* (if (file-exists? "runtime.bad")
- (fasload "runtime.bad" #f)
- '())
- car
- (append files1 files2))))
- (string-member? (member-procedure string=?)))
- (lambda (filename environment)
- (if (not (string-member? filename to-avoid))
- (eval (file->object filename #t #f) environment))
- unspecific))
- `((SORT-TYPE . MERGE-SORT)
- (OS-TYPE . ,os-name)
- (OPTIONS . NO-LOAD))))
+ ;; Load everything else.
+ (load-packages-from-file packages-file
+ `((SORT-TYPE . MERGE-SORT)
+ (OS-TYPE . ,os-name)
+ (OPTIONS . NO-LOAD))
+ (let ((file-member?
+ (lambda (filename files)
+ (let loop ((files files))
+ (and (pair? files)
+ (or (string=? (car (car files)) filename)
+ (loop (cdr files))))))))
+ (lambda (filename environment)
+ (if (not (or (string=? filename "packag")
+ (file-member? filename files1)
+ (file-member? filename files2)))
+ (eval (file->object filename #t #f)
+ environment))
+ unspecific))))
\f
;;; Funny stuff is done. Rest of sequence is standardized.
(package-initialization-sequence
((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS! #t)
;; Basic data structures
(RUNTIME NUMBER)
+ ((RUNTIME NUMBER) INITIALIZE-DRAGON4! #t)
(RUNTIME CHARACTER)
(RUNTIME CHARACTER-SET)
(RUNTIME GENSYM)
#| -*-Scheme-*-
-$Id: packag.scm,v 14.28 1999/01/02 06:11:34 cph Exp $
+$Id: packag.scm,v 14.29 2001/08/15 02:56:08 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
|#
;;;; Simple Package Namespace
(define-integrable (set-package/environment! package environment)
(%record-set! package 4 environment))
+(define (package-name? object)
+ (list-of-type? object symbol?))
+
+(define (package/reference package name)
+ (lexical-reference (package/environment package) name))
+
(define (finalize-package-record-type!)
(let ((rtd
(make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT))))
\f
(define (package/child package name)
(let loop ((children (package/children package)))
- (and (not (null? children))
+ (and (pair? children)
(if (eq? name (package/%name (car children)))
(car children)
(loop (cdr children))))))
(define (name->package name)
(let loop ((path name) (package system-global-package))
- (if (null? path)
- package
+ (if (pair? path)
(let ((child (package/child package (car path))))
(and child
- (loop (cdr path) child))))))
+ (loop (cdr path) child)))
+ package)))
(define (environment->package environment)
(and (interpreter-environment? environment)
(define (find-package name)
(let loop ((path name) (package system-global-package))
- (if (null? path)
- package
+ (if (pair? path)
(loop (cdr path)
(or (package/child package (car path))
- (error "Unable to find package"
- (list-difference name (cdr path))))))))
+ (error "Unable to find package:"
+ (list-difference name (cdr path)))))
+ package)))
(define (list-difference list tail)
(let loop ((list list))
(finish child)))))
(define system-global-package)
-(define *allow-package-redefinition?*)
+(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))
\f
(define system-loader/enable-query?
- false)
+ #f)
-(define (package/system-loader filename options load-interpreted?)
- (let ((pathname (->pathname filename)))
+(define (package/system-loader filename #!optional options load-interpreted?)
+ (let* ((options (if (default-object? options) '() options))
+ (pathname
+ (let ((rewrite (lookup-option 'REWRITE-PACKAGE-FILE-NAME options))
+ (pathname (pathname-new-type filename "pkd")))
+ (if rewrite
+ (rewrite pathname)
+ pathname))))
(with-working-directory-pathname (directory-pathname pathname)
(lambda ()
- (fluid-let ((load/default-types
- (if (if (eq? load-interpreted? 'QUERY)
- (and system-loader/enable-query?
- (prompt-for-confirmation "Load interpreted"))
- load-interpreted?)
- (list (assoc "bin" load/default-types)
- (assoc "scm" load/default-types))
- load/default-types)))
- (let ((syntax-table (nearest-repl/syntax-table)))
- (load (let ((rewrite (assq 'MAKE-CONSTRUCTOR-NAME options))
- (pathname (pathname-new-type pathname "bco")))
- (if rewrite
- ((cdr rewrite) pathname)
- pathname))
- system-global-environment
- syntax-table false)
- ((load (let ((rewrite (assq 'MAKE-LOADER-NAME options))
- (pathname (pathname-new-type pathname "bld")))
- (if rewrite
- ((cdr rewrite) pathname)
- pathname))
- system-global-environment
- syntax-table false)
- (lambda (component environment)
- (cond ((filename->compiled-object filename component)
- => (lambda (value)
- (purify (load/purification-root value))
- (scode-eval value environment)))
- (else
- (load component environment syntax-table true))))
- options))))))
+ (let ((file (fasload pathname)))
+ (if (not (package-file? file))
+ (error "Malformed package-description file:" pathname))
+ (construct-packages-from-file file)
+ (fluid-let
+ ((load/default-types
+ (if (if (or (default-object? load-interpreted?)
+ (eq? load-interpreted? 'QUERY))
+ (and system-loader/enable-query?
+ (prompt-for-confirmation "Load interpreted"))
+ load-interpreted?)
+ (list (assoc "bin" load/default-types)
+ (assoc "scm" load/default-types))
+ load/default-types)))
+ (let ((alternate-loader
+ (lookup-option 'ALTERNATE-PACKAGE-LOADER options))
+ (load-component
+ (let ((syntax-table (nearest-repl/syntax-table)))
+ (lambda (component environment)
+ (let ((value
+ (filename->compiled-object filename component)))
+ (if value
+ (begin
+ (purify (load/purification-root value))
+ (scode-eval value environment))
+ (load component environment syntax-table #t)))))))
+ (if alternate-loader
+ (alternate-loader load-component options)
+ (load-packages-from-file file options load-component))))))))
;; Make sure that everything we just loaded is purified. If the
;; program runs before it gets purified, some of its run-time state
;; can end up being purified also.
(let* ((p (->pathname component))
(d (pathname-directory p)))
(string-append
- (if (or (not d) (null? d))
- system
- (car (last-pair d)))
+ (if (pair? d)
+ (car (last-pair d))
+ system)
"_"
(string-replace (pathname-name p) ; kludge
#\-
(write-string ";Initialized " port)
(write name port)
value))))))
+\f
+(define-structure (package-file (type vector)
+ (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))
-(define-integrable (package/reference package name)
- (lexical-reference (package/environment package) name))
+(define-structure (package-description (type vector)
+ (conc-name package-description/))
+ (name #f read-only #t)
+ (parent-name #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)
+ (internal-bindings #f read-only #t)
+ (external-bindings #f read-only #t))
-(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! *allow-package-redefinition?* #f)
- unspecific)
\ No newline at end of file
+(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))))
+
+(define (package-description? object)
+ (and (vector? object)
+ (fix:= (vector-length object) 8)
+ (package-name? (package-description/name object))
+ (or (package-name? (package-description/parent-name object))
+ (eq? (package-description/parent-name object) 'NONE))
+ (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/internal-bindings object)
+ (lambda (binding)
+ (and (vector? binding)
+ (let ((n (vector-length binding)))
+ (and (fix:>= n 2)
+ (symbol? (vector-ref binding 0))
+ (let loop ((i 1))
+ (or (fix:= i n)
+ (and (let ((p.n (vector-ref binding i)))
+ (and (pair? p.n)
+ (package-name? (car p.n))
+ (symbol? (cdr p.n))))
+ (loop (fix:+ i 1))))))))))
+ (vector-of-type? (package-description/external-bindings object)
+ (lambda (binding)
+ (and (vector? binding)
+ (or (fix:= (vector-length binding) 2)
+ (fix:= (vector-length binding) 3))
+ (symbol? (vector-ref binding 0))
+ (package-name? (vector-ref binding 1))
+ (or (fix:= (vector-length binding) 2)
+ (symbol? (vector-ref binding 2))))))))
+\f
+(define (construct-packages-from-file file)
+ (let ((descriptions (package-file/sorted-descriptions file))
+ (skip-package?
+ (lambda (name)
+ (or (null? name)
+ (and (pair? name)
+ (eq? (car name) 'PACKAGE)
+ (null? (cdr name)))))))
+ (let ((n (vector-length descriptions)))
+ (do ((i 0 (fix:+ i 1)))
+ ((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)))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((description (vector-ref descriptions i)))
+ (let ((name (package-description/name description)))
+ (if (not (skip-package? name))
+ (create-links-from-description description))))))))
+
+(define (construct-normal-package-from-description description)
+ (let ((name (package-description/name description))
+ (environment
+ (extend-package-environment
+ (let ((parent (package-description/parent-name description)))
+ (if (eq? parent 'NONE)
+ null-environment
+ (package/environment (find-package parent))))
+ (cons (package-description/internal-names description)
+ (lambda (name) name))
+ (cons (package-description/internal-bindings description)
+ (lambda (binding) (vector-ref binding 0)))
+ (cons (package-description/external-bindings 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)))))
+ (package/add-child! package (car path) environment)))))
+
+(define (create-links-from-description description)
+ (let ((environment
+ (find-package-environment (package-description/name description))))
+ (let ((bindings (package-description/internal-bindings description)))
+ (let ((n (vector-length bindings)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((binding (vector-ref bindings i)))
+ (let ((name (vector-ref binding 0))
+ (n (vector-length binding)))
+ (do ((i 1 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((link (vector-ref binding i)))
+ (link-variables (find-package-environment (car link))
+ (cdr link)
+ environment
+ name))))))))
+ (let ((bindings (package-description/external-bindings description)))
+ (let ((n (vector-length bindings)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((binding (vector-ref bindings i)))
+ (link-variables environment
+ (vector-ref binding 0)
+ (find-package-environment (vector-ref binding 1))
+ (if (fix:= (vector-length binding) 3)
+ (vector-ref binding 2)
+ (vector-ref binding 0)))))))))
+\f
+(define (extend-package-environment environment . name-sources)
+ (let ((n
+ (let loop ((name-sources name-sources) (n 1))
+ (if (pair? name-sources)
+ (loop (cdr name-sources)
+ (fix:+ n (vector-length (car (car name-sources)))))
+ n))))
+ (let ((vn ((ucode-primitive vector-cons) n #f))
+ (vv
+ ((ucode-primitive vector-cons)
+ n
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type reference-trap)
+ 0))))
+ (let loop ((name-sources name-sources) (i 1))
+ (if (pair? name-sources)
+ (let ((v (car (car name-sources)))
+ (p (cdr (car name-sources))))
+ (let ((n (vector-length v)))
+ (let do-source ((j 0) (i i))
+ (if (fix:< j n)
+ (begin
+ (vector-set! vn i (p (vector-ref v j)))
+ (do-source (fix:+ j 1) (fix:+ i 1)))
+ (loop (cdr name-sources) i)))))))
+ (vector-set! vn 0 'DUMMY-PROCEDURE)
+ (vector-set! vv 0
+ (system-pair-cons (ucode-type procedure)
+ (system-pair-cons (ucode-type lambda)
+ #f
+ vn)
+ environment))
+ (object-new-type (ucode-type environment) vv))))
+
+(define null-environment
+ (object-new-type (object-type #f)
+ (fix:xor (object-datum #F) 1)))
+
+(define (find-package-environment name)
+ (package/environment (find-package name)))
+
+(define-primitives
+ link-variables)
+\f
+(define (load-packages-from-file file options file-loader)
+ (let ((descriptions (package-file/descriptions file)))
+ (let ((n (vector-length descriptions)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((description (vector-ref descriptions i)))
+ (load-package-from-description
+ (find-package (package-description/name description))
+ description
+ options
+ file-loader))))))
+
+(define (load-package-from-description package 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)))
+ (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)))))))))
+
+(define (lookup-option key options)
+ (let loop ((options options))
+ (and (pair? options)
+ (if (eq? (car (car options)) key)
+ (cdr (car options))
+ (loop (cdr options))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.372 2001/08/10 17:09:28 cph Exp $
+$Id: runtime.pkg,v 14.373 2001/08/15 02:56:21 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(else)))
(define-package (package)
- ;; The information appearing here must be duplicated in the cold load
- ;; sequence. If you change this package make sure to edit that also.
+ ;; The information appearing here must be exactly duplicated in the
+ ;; cold load sequence in "make.scm".
(files "packag")
(parent ())
(export ()
*allow-package-redefinition?*
+ construct-packages-from-file
environment->package
find-package
+ load-packages-from-file
name->package
package/add-child!
package/child
list-deletor
list-deletor!
list-head
+ list-of-type?
list-ref
list-search-negative
list-search-positive
truncate
truncate->exact
zero?)
- (initialization (initialize-package!)))
+ (initialization
+ (begin
+ (initialize-package!)
+ (initialize-dragon4!))))
(define-package (runtime number interface)
(file-case options
#| -*-Scheme-*-
-$Id: runtime.sf,v 14.14 2001/06/15 20:38:43 cph Exp $
+$Id: runtime.sf,v 14.15 2001/08/15 02:56:26 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
;; that when cross-syntaxing the cref `native' to the running system
;; is loaded.
(load-option 'CREF)
-(cref/generate-constructors "runtime")
-(sf-conditionally "runtime.con")
-(sf-conditionally "runtime.ldr")
-(if (file-exists? "runtime.avd")
- (fasdump (read-file "runtime.avd") "runtime.bad"))
\ No newline at end of file
+(cref/generate-constructors "runtime")
\ No newline at end of file
#| -*-Scheme-*-
-$Id: vector.scm,v 14.15 2000/03/27 19:56:07 cph Exp $
+$Id: vector.scm,v 14.16 2001/08/15 02:56:30 cph Exp $
Copyright (c) 1988-2000 Massachusetts Institute of Technology
(begin
(procedure (vector-ref vector index))
(loop (fix:+ index 1)))))))
+
+(define (vector-of-type? vector predicate)
+ (and (vector? vector)
+ (let ((n (vector-length vector)))
+ (let loop ((i 0))
+ (or (fix:= i n)
+ (and (predicate (vector-ref vector i))
+ (loop (fix:+ i 1))))))))
\f
(define (subvector-find-next-element vector start end item)
(guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT)
#| -*-Scheme-*-
-$Id: version.scm,v 14.199 2001/08/03 20:30:02 cph Exp $
+$Id: version.scm,v 14.200 2001/08/15 02:57:00 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(add-subsystem-identification! "Release" '(7 5 18 "pre"))
(snarf-microcode-version!)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-subsystem-identification! "Runtime" '(14 190)))
+ (add-subsystem-identification! "Runtime" '(14 191)))
(define (snarf-microcode-version!)
(add-subsystem-identification! "Microcode"
projects / mit-scheme.git / commitdiff