#| -*-Scheme-*-
-$Id: make.scm,v 15.36 2003/02/14 18:28:00 cph Exp $
+$Id: make.scm,v 15.37 2004/12/13 03:22:21 cph Exp $
-Copyright (c) 1991-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,1995,1996,1998 Massachusetts Institute of Technology
+Copyright 1999,2001,2002,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(if (and (eq? 'UNIX microcode-id/operating-system)
(string-ci=? "HP-UX" microcode-id/operating-system-variant))
(load "floppy" (->environment '(EDWIN))))))))
-(add-identification! "6.001" 15 31)
+(add-subsystem-identification! "6.001" '(15 31))
;;; Customize the runtime system:
(set! repl:allow-restart-notifications? #f)
#| -*-Scheme-*-
-$Id: make.scm,v 4.123 2004/07/05 03:59:36 cph Exp $
+$Id: make.scm,v 4.124 2004/12/13 03:22:21 cph Exp $
Copyright 1991,1992,1993,1994,1997,1998 Massachusetts Institute of Technology
Copyright 1999,2001,2002,2003,2004 Massachusetts Institute of Technology
(lambda (architecture-name)
architecture-name
+ (load-option 'COMPRESS)
+ (load-option 'RB-TREE)
((access with-directory-rewriting-rule
(->environment '(RUNTIME COMPILER-INFO)))
(working-directory-pathname)
(pathname-as-directory "compiler")
(lambda ()
- (load-option 'COMPRESS)
- (load-option 'RB-TREE)
(load-package-set "compiler")))
- (add-identification! "LIAR" 4 117))
\ No newline at end of file
+ (add-subsystem-identification! "LIAR" '(4 117)))
#| -*-Scheme-*-
-$Id: make.scm,v 1.27 2003/02/14 18:28:10 cph Exp $
+$Id: make.scm,v 1.28 2004/12/13 03:22:21 cph Exp $
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1993,1994 Massachusetts Institute of Technology
+Copyright 1995,1996,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2002,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(declare (usual-integrations))
-(with-working-directory-pathname
- (directory-pathname (current-load-pathname))
+(load-option 'RB-TREE)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
((access with-directory-rewriting-rule
(->environment '(RUNTIME COMPILER-INFO)))
(working-directory-pathname)
(pathname-as-directory "cref")
(lambda ()
- (load-option 'RB-TREE)
(load-package-set "cref")))))
-(add-identification! "CREF" 2 3)
\ No newline at end of file
+(add-subsystem-identification! "CREF" '(2 3))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: make.scm,v 3.120 2004/02/16 05:43:45 cph Exp $
+$Id: make.scm,v 3.121 2004/12/13 03:22:21 cph Exp $
Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,2000,2001,2002,2003,2004 Massachusetts Institute of Technology
(declare (usual-integrations))
-(with-working-directory-pathname
- (directory-pathname (current-load-pathname))
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
((access with-directory-rewriting-rule
(->environment '(RUNTIME COMPILER-INFO)))
(load-package-set "edwin"
`((alternate-package-loader
. ,(load "edwin.bld" system-global-environment))))))))
-(add-identification! "Edwin" 3 116)
\ No newline at end of file
+(add-subsystem-identification! "Edwin" '(3 116))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.8 2003/02/14 18:28:31 cph Exp $
+$Id: load.scm,v 1.9 2004/12/13 03:22:21 cph Exp $
-Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology
+Copyright 1995,1998,2001,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(declare (usual-integrations))
\f
-(package/system-loader "pcs" '() 'QUERY)
-(add-identification! "PC Sampler" 1 0)
+(load-package-set "pcs")
+(add-subsystem-identification! "PC Sampler" '(1 0))
(let ()
(define (package-initialize package-name
#| -*-Scheme-*-
-$Id: make.scm,v 14.96 2004/11/17 05:24:19 cph Exp $
+$Id: make.scm,v 14.97 2004/12/13 03:22:21 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology
(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)
#| -*-Scheme-*-
-$Id: packag.scm,v 14.44 2003/03/13 18:13:52 cph Exp $
+$Id: packag.scm,v 14.45 2004/12/13 03:22:21 cph Exp $
Copyright 1988,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1996,1998,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
\f
(define system-loader/enable-query? #f)
-(define (load-package-set filename #!optional options load-interpreted?)
- (let ((pathname (package-set-pathname filename))
- (options
- (cons (cons 'OS-TYPE microcode-id/operating-system)
- (if (default-object? options) '() options))))
- (with-working-directory-pathname (directory-pathname pathname)
- (lambda ()
- (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
- (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 'DEFAULT #t))))))
- (if alternate-loader
- (alternate-loader load-component options)
- (begin
- (load-packages-from-file file options load-component)
- (initialize-packages-from-file file)))))))))
+(define (load-package-set filename #!optional options)
+ (let ((os-type microcode-id/operating-system))
+ (let ((pathname (package-set-pathname filename os-type))
+ (options
+ (cons (cons 'OS-TYPE os-type)
+ (if (default-object? options) '() options))))
+ (with-working-directory-pathname (directory-pathname pathname)
+ (lambda ()
+ (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 (and system-loader/enable-query?
+ (prompt-for-confirmation "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
+ (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 'DEFAULT #t))))))
+ (if alternate-loader
+ (alternate-loader load-component options)
+ (begin
+ (load-packages-from-file file options load-component)
+ (initialize-packages-from-file file))))))))))
;; 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.
(flush-purification-queue!))
-(define (package-set-pathname pathname #!optional os-type)
+(define (package-set-pathname pathname os-type)
(make-pathname (pathname-host pathname)
(pathname-device pathname)
(pathname-directory pathname)
(string-append (pathname-name pathname)
- (case (if (or (default-object? os-type)
- (not os-type))
- microcode-id/operating-system
- os-type)
+ (case os-type
((NT) "-w32")
((OS/2) "-os2")
((UNIX) "-unx")
(write-string ";Initialized " port)
(write name port)
value))))))
-
-(define package/system-loader load-package-set)
\f
(define-integrable (make-package-file tag version descriptions loads)
(vector tag version descriptions loads))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.521 2004/11/26 05:04:42 cph Exp $
+$Id: runtime.pkg,v 14.522 2004/12/13 03:22:21 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
package/name
package/parent
package/reference
- package/system-loader
package?
system-global-package)
(export (runtime environment)
(files "system")
(parent (runtime))
(export ()
- add-identification!
add-subsystem-identification!
get-subsystem-identification-string
get-subsystem-names
#| -*-Scheme-*-
-$Id: system.scm,v 14.15 2003/02/14 18:28:34 cph Exp $
+$Id: system.scm,v 14.16 2004/12/13 03:22:21 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1991,1998 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
'ADD-SUBSYSTEM-IDENTIFICATION!))
(let ((version
(let loop ((version version))
- (append-map
- (lambda (version)
- (cond ((exact-nonnegative-integer? version)
- (list version))
- ((string? version)
- (if (string-null? version)
- '()
- (list version)))
- ((list? version)
- (loop version))
- (else
- (error "Illegal subsystem version:"
- version))))
- version))))
+ (append-map (lambda (version)
+ (cond ((exact-nonnegative-integer? version)
+ (list version))
+ ((string? version)
+ (if (string-null? version)
+ '()
+ (list version)))
+ ((list? version)
+ (loop version))
+ (else
+ (error "Illegal subsystem version:"
+ version))))
+ version))))
(let ((entry (find-entry name)))
(if entry
(begin
(define (remove-subsystem-identification! name)
(let loop ((previous #f) (entries subsystem-identifications))
- (if (not (null? entries))
+ (if (pair? entries)
(if (match-entry? name (car entries))
(begin
(if previous
(string-append name " " s)))))))
\f
(define (version-string version)
- (if (null? version)
- ""
+ (if (pair? version)
(let loop ((version version))
(let ((s
(if (string? (car version))
(car version)
(number->string (car version)))))
- (if (null? (cdr version))
- s
- (string-append s "." (loop (cdr version))))))))
+ (if (pair? (cdr version))
+ (string-append s "." (loop (cdr version)))
+ s)))
+ ""))
(define (find-entry name)
- (list-search-positive subsystem-identifications
+ (find-matching-item subsystem-identifications
(lambda (entry)
(match-entry? name entry))))
(or (string-find-next-char s #\space)
(string-length s)))))
-(define subsystem-identifications '())
-
-;;; Upwards compatibility.
-
-(define (add-identification! name version modification)
- (add-subsystem-identification! name (list version modification)))
\ No newline at end of file
+(define subsystem-identifications '())
\ No newline at end of file
#| -*-Scheme-*-
-$Id: sbuild.scm,v 1.7 2003/02/14 18:28:35 cph Exp $
+$Id: sbuild.scm,v 1.8 2004/12/13 03:22:21 cph Exp $
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright 1990,1991,1998,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(for-each (lambda (filename)
(load filename system-global-environment))
'("compat" "graphics" "strmac" "stream" "genenv" "studen"))
-(add-identification! "Student (6.001)" 14 3)
+(add-subsystem-identification! "Student (6.001)" '(14 3))
"Student environment loaded."
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.15 2003/04/25 03:48:28 cph Exp $
+$Id: load.scm,v 1.16 2004/12/13 03:22:21 cph Exp $
Copyright 1997,1998,1999,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
(load-package-set "sos")))
-(add-identification! "SOS" 1 8)
\ No newline at end of file
+(add-subsystem-identification! "SOS" '(1 8))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.5 2004/11/24 20:20:41 cph Exp $
+$Id: load.scm,v 1.6 2004/12/13 03:22:21 cph Exp $
Copyright 2003,2004 Massachusetts Institute of Technology
(load-option 'mime-codec)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (package/system-loader "ssp" '() 'query)))
+ (load-package-set "ssp")))
(add-subsystem-identification! "SSP" '(0 4))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.16 2003/04/25 03:53:58 cph Exp $
+$Id: load.scm,v 1.17 2004/12/13 03:22:21 cph Exp $
-Copyright 2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (package/system-loader "parser" '() 'QUERY)))
+ (load-package-set "parser")))
(add-subsystem-identification! "*Parser" '(0 12))
\ No newline at end of file
#|
-(with-working-directory-pathname
- (directory-pathname (current-load-pathname))
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
;; Dynamically load the microcode. Order important.
(load "dynload/scxl")
(working-directory-pathname)
(pathname-as-directory "lib/swat")
(lambda ()
- (package/system-loader "swat" '() 'QUERY)))
- (add-identification! "SWAT" 1 0)))
+ (load-package-set "swat")))
+ (add-subsystem-identification! "SWAT" '(1 0))))
|#
#| -*-Scheme-*-
-$Id: load.scm,v 1.5 2003/02/14 18:28:35 cph Exp $
+$Id: load.scm,v 1.6 2004/12/13 03:22:21 cph Exp $
-Copyright (c) 1994-1999 Massachusetts Institute of Technology
+Copyright 1994,1995,1998,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(display "\n; Package already loaded under some other alias")
'ok)
(else
- (package/system-loader "wabbit" '() 'QUERY)
- (add-identification! "Wabbit Hunting / Headhunting GC" 1 0)
+ (load-package-set "wabbit")
+ (add-subsystem-identification! "Wabbit Hunting / Headhunting GC" '(1 0))
(let ()
(define (package-initialize package-name
(package-initialize '(gc-wabbits)))))
;;; fini
-
#| -*-Scheme-*-
-$Id: make.scm,v 1.15 2004/01/16 20:43:16 cph Exp $
+$Id: make.scm,v 1.16 2004/12/13 03:22:21 cph Exp $
Copyright 1993,1998,2001,2002,2003,2004 Massachusetts Institute of Technology
(pathname-as-directory "win32")
(lambda ()
(load-package-set "win32")))))
-(add-identification! "Win32" 1 8)
\ No newline at end of file
+(add-subsystem-identification! "Win32" '(1 8))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.2 2004/11/02 03:57:41 cph Exp $
+$Id: load.scm,v 1.3 2004/12/13 03:22:21 cph Exp $
Copyright 2004 Massachusetts Institute of Technology
(export 'xml-comment 'comment)))
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (package/system-loader "xdoc" '() 'query)))
+ (load-package-set "xdoc")))
(add-subsystem-identification! "XDOC" '(0 3))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.14 2004/07/24 03:45:34 cph Exp $
+$Id: load.scm,v 1.15 2004/12/13 03:22:21 cph Exp $
Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
(load-option 'SOS)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (package/system-loader "xml" '() 'QUERY)))
+ (load-package-set "xml")))
(add-subsystem-identification! "XML" '(0 7))
\ No newline at end of file
projects / mit-scheme.git / commitdiff