From: Chris Hanson Date: Wed, 15 Aug 2001 03:00:01 +0000 (+0000) Subject: Implement completely new format for compiled package descriptions. X-Git-Tag: 20090517-FFI~2602 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=69afca2bc6e590419423ab2b19612597fddbbdb0;p=mit-scheme.git Implement completely new format for compiled package descriptions. 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. --- diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm index 3e98944d2..ed61fac21 100644 --- a/v7/src/cref/conpkg.scm +++ b/v7/src/cref/conpkg.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -25,67 +25,86 @@ USA. (declare (usual-integrations) (integrate-external "object")) -;;; 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-structurevector + (map (lambda (package) + (cdr (assq package alist))) + (sort packages package-structurevector (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 (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 diff --git a/v7/src/cref/cref.pkg b/v7/src/cref/cref.pkg index b6b1c290f..bed9c8dda 100644 --- a/v7/src/cref/cref.pkg +++ b/v7/src/cref/cref.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -46,8 +46,7 @@ USA. (files "conpkg") (parent (cross-reference)) (export (cross-reference) - construct-constructor - construct-loader)) + construct-external-descriptions)) (define-package (cross-reference formatter) (files "forpkg") diff --git a/v7/src/cref/cref.sf b/v7/src/cref/cref.sf index c4582f40d..0a36f038a 100644 --- a/v7/src/cref/cref.sf +++ b/v7/src/cref/cref.sf @@ -1,6 +1,6 @@ #| -*-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 @@ -24,15 +24,11 @@ USA. (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 diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm index 0863ad9f4..2988e1b5e 100644 --- a/v7/src/cref/make.scm +++ b/v7/src/cref/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -34,4 +34,4 @@ USA. (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 diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm index be8ce053a..bd7b3141d 100644 --- a/v7/src/cref/object.scm +++ b/v7/src/cref/object.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -16,7 +16,8 @@ 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., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Package Model Data Structures @@ -34,6 +35,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (file-cases '()) (parent #f read-only #t) (initialization #f) + (finalization #f) (exports '()) (imports '())) @@ -64,6 +66,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (file-cases '()) (files '()) (initialization #f) + (finalization #f) parent (children '()) (bindings (make-rb-tree eq? symbolvector + (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 diff --git a/v7/src/runtime/dragon4.scm b/v7/src/runtime/dragon4.scm index 7c0f51593..0b62aec72 100644 --- a/v7/src/runtime/dragon4.scm +++ b/v7/src/runtime/dragon4.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -269,15 +269,18 @@ not much different to numbers within a few orders of magnitude of 1. (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) #| Test code. Re-run after changing anything. diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index 9997a5eb7..6cb58ba66 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -154,6 +154,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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)))) (define (list-copy items) (let ((lose (lambda () (error:wrong-type-argument items "list" 'LIST-COPY)))) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 00593bee0..6d32a9972 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -49,38 +49,28 @@ USA. (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)) (let ((environment-for-package (let () (the-environment)))) +(define this-environment (the-environment)) + (define-primitives (+ integer-add) (- integer-subtract) @@ -297,28 +287,36 @@ USA. ;; 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 @@ -368,26 +366,24 @@ USA. (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)))) ;;; Funny stuff is done. Rest of sequence is standardized. (package-initialization-sequence @@ -403,6 +399,7 @@ USA. ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS! #t) ;; Basic data structures (RUNTIME NUMBER) + ((RUNTIME NUMBER) INITIALIZE-DRAGON4! #t) (RUNTIME CHARACTER) (RUNTIME CHARACTER-SET) (RUNTIME GENSYM) diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 23f9b57a0..3eb893cdc 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -16,7 +16,8 @@ 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., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Simple Package Namespace @@ -57,6 +58,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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)))) @@ -73,7 +80,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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)))))) @@ -86,11 +93,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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) @@ -108,12 +115,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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)) @@ -143,46 +150,56 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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)) (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. @@ -195,9 +212,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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 #\- @@ -211,14 +228,241 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (write-string ";Initialized " port) (write name port) value)))))) + +(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)))))))) + +(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))))))))) + +(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) + +(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 diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 1ea6475e5..e5397387b 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -45,14 +45,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -1405,6 +1407,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA list-deletor list-deletor! list-head + list-of-type? list-ref list-search-negative list-search-positive @@ -1636,7 +1639,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA truncate truncate->exact zero?) - (initialization (initialize-package!))) + (initialization + (begin + (initialize-package!) + (initialize-dragon4!)))) (define-package (runtime number interface) (file-case options diff --git a/v7/src/runtime/runtime.sf b/v7/src/runtime/runtime.sf index 2301b39bf..8786f5d9f 100644 --- a/v7/src/runtime/runtime.sf +++ b/v7/src/runtime/runtime.sf @@ -1,6 +1,6 @@ #| -*-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 @@ -32,8 +32,4 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 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 diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 9ce8d5827..4f0fb63a1 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -141,6 +141,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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)))))))) (define (subvector-find-next-element vector start end item) (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 8bd0c8146..465ccc07c 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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"