From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 14 Apr 2007 03:53:04 +0000 (+0000)
Subject: Redesign interface to built-in object files, so that (1) they include
X-Git-Tag: 20090517-FFI~665
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=90e2bf75bf0978f1c8f6b589914f128054522e0c;p=mit-scheme.git
Redesign interface to built-in object files, so that (1) they include
the pathname type of the file, and (2) the mapping from pathnames to
handles is specified in fewer places.
---
diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index 6a80995e8..0de85a197 100644
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.70 2007/01/05 21:19:20 cph Exp $
+$Id: toplev.scm,v 4.71 2007/04/14 03:52:22 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -139,28 +139,30 @@ USA.
(and (not (default-object? output-string)) output-string)
(make-pathname #f #f #f #f "bin" 'NEWEST)
(lambda (input-pathname output-pathname)
- (let ((scode (compiler-fasload input-pathname)))
- (if (and (scode/constant? scode)
- (not compiler:compile-data-files-as-expressions?))
- (compile-data-from-file scode output-pathname)
- (maybe-open-file
- compiler:generate-rtl-files?
- (pathname-new-type output-pathname "rtl")
- (lambda (rtl-output-port)
- (maybe-open-file
- compiler:generate-lap-files?
- (pathname-new-type output-pathname "lap")
- (lambda (lap-output-port)
- (fluid-let ((*debugging-key*
- (random-byte-vector 32)))
- (compile-scode/internal
- scode
- (pathname-new-type output-pathname "inf")
- rtl-output-port
- lap-output-port))))))))))
+ (fluid-let ((*compiler-input-pathname* input-pathname))
+ (let ((scode (compiler-fasload input-pathname)))
+ (if (and (scode/constant? scode)
+ (not compiler:compile-data-files-as-expressions?))
+ (compile-data-from-file scode output-pathname)
+ (maybe-open-file
+ compiler:generate-rtl-files?
+ (pathname-new-type output-pathname "rtl")
+ (lambda (rtl-output-port)
+ (maybe-open-file
+ compiler:generate-lap-files?
+ (pathname-new-type output-pathname "lap")
+ (lambda (lap-output-port)
+ (fluid-let ((*debugging-key*
+ (random-byte-vector 32)))
+ (compile-scode/internal
+ scode
+ (pathname-new-type output-pathname "inf")
+ rtl-output-port
+ lap-output-port)))))))))))
unspecific)))
(define *debugging-key*)
+(define *compiler-input-pathname*)
(define (maybe-open-file open? pathname receiver)
(if open?
diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg
index f22093a33..698a9948b 100644
--- a/v7/src/compiler/machines/C/compiler.pkg
+++ b/v7/src/compiler/machines/C/compiler.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.21 2007/01/05 21:19:20 cph Exp $
+$Id: compiler.pkg,v 1.22 2007/04/14 03:52:27 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -256,6 +256,7 @@ USA.
;; lap->code
)
(export (compiler)
+ *compiler-input-pathname*
canonicalize-label-name)
(export (compiler fg-generator)
compile-recursively)
diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm
index f5947ac6c..0617817ca 100644
--- a/v7/src/compiler/machines/C/cout.scm
+++ b/v7/src/compiler/machines/C/cout.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: cout.scm,v 1.34 2007/01/21 22:19:06 riastradh Exp $
+$Id: cout.scm,v 1.35 2007/04/14 03:52:31 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -45,9 +45,8 @@ USA.
(else
(let ((values-names (caar bindings))
(values-form (cadar bindings)))
- `(WITH-VALUES (LAMBDA () ,values-form)
- (LAMBDA ,values-names
- ,(recur (cdr bindings))))))))))))
+ `(RECEIVE ,values-names ,values-form
+ ,(recur (cdr bindings)))))))))))
(define *use-stackify?* #t)
(define *disable-nonces?* #f)
@@ -62,15 +61,7 @@ USA.
(define (stringify-data/stackify object output-pathname)
(let* ((str (stackify 0 object))
- (handle (or (and output-pathname
- (let ((dir (pathname-directory output-pathname)))
- (string-append
- (if (or (not dir) (null? dir))
- ""
- (car (last-pair dir)))
- "_"
- (pathname-name output-pathname))))
- "handle"))
+ (handle (default-file-handle))
(data-name
(canonicalize-label-name
(string-append handle "_data_" (make-nonce)))))
@@ -89,15 +80,7 @@ USA.
(define (stringify-data/traditional object output-pathname)
(let*/mv (((vars prefix suffix) (handle-top-level-data/traditional object))
- (handle (or (and output-pathname
- (let ((dir (pathname-directory output-pathname)))
- (string-append
- (if (or (not dir) (null? dir))
- ""
- (car (last-pair dir)))
- "_"
- (pathname-name output-pathname))))
- "handle"))
+ (handle (default-file-handle))
(data-name
(canonicalize-label-name
(string-append handle "_data_" (make-nonce)))))
@@ -118,6 +101,10 @@ USA.
(c:group (c:data-section (declare-object handle proc))
(c:line)
(declare-dynamic-object-initialization handle)))
+
+(define (default-file-handle)
+ (or (liarc-object-pathname->handle *compiler-input-pathname*)
+ "handle"))
(define (stringify suffix initial-label lap-code info-output-pathname)
;; returns <code-name data-name ntags symbol-table code proxy>
@@ -138,37 +125,25 @@ USA.
(choose-name #f "" "" nonce))
(define (choose-name full? default midfix nonce)
- (let ((path (and info-output-pathname
- (merge-pathnames
- (if (pair? info-output-pathname)
- (car info-output-pathname)
- info-output-pathname)))))
-
- (cond ((not *C-procedure-name*)
- (string-append default suffix "_" nonce))
- ((not (eq? *C-procedure-name* 'DEFAULT))
- (string-append *C-procedure-name*
- midfix
- suffix))
- ((not path)
- (string-append default suffix "_" nonce))
- ((or top-level? *disable-nonces?*)
- (let ((dir (pathname-directory path)))
- (string-append
- (if (or (not dir) (null? dir))
- default
- (canonicalize-name (car (last-pair dir)) full?))
- "_"
- (canonicalize-name (pathname-name path) full?)
- midfix
- suffix)))
- (else
- (string-append (canonicalize-name (pathname-name path) full?)
- "_"
- default
- suffix
- "_"
- nonce)))))
+ (cond ((not *C-procedure-name*)
+ (string-append default suffix "_" nonce))
+ ((not (eq? *C-procedure-name* 'DEFAULT))
+ (string-append *C-procedure-name*
+ midfix
+ suffix))
+ ((not info-output-pathname)
+ (string-append default suffix "_" nonce))
+ ((or top-level? *disable-nonces?*)
+ (string-append (canonicalize-name (default-file-handle) full?)
+ midfix
+ suffix))
+ (else
+ (string-append (canonicalize-name (default-file-handle) full?)
+ "_"
+ default
+ suffix
+ "_"
+ nonce))))
(define (subroutine-information)
(let*/mv (((decls-1 code-1) (subroutine-information-1))
diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm
index 3c007b0ee..25a3f964d 100644
--- a/v7/src/compiler/machines/C/ctop.scm
+++ b/v7/src/compiler/machines/C/ctop.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: ctop.scm,v 1.23 2007/01/28 23:03:06 riastradh Exp $
+$Id: ctop.scm,v 1.24 2007/04/14 03:52:35 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -60,21 +60,7 @@ USA.
(load shared-library-pathname environment))))
(define (compiler-output->compiled-expression compiler-output)
- (finish-c-compilation
- compiler-output
- (lambda (pathname)
- (let* ((handle ((ucode-primitive load-object-file 1)
- (->namestring pathname)))
- (cth ((ucode-primitive object-lookup-symbol 3)
- handle "dload_initialize_file" 0)))
- (if (not cth)
- (error "compiler-output->compiled-expression:"
- "Cannot find init procedure"
- pathname))
- ((ucode-primitive initialize-c-compiled-block 1)
- ((ucode-primitive address-to-string 1)
- ((ucode-primitive invoke-c-thunk 1)
- cth)))))))
+ (finish-c-compilation compiler-output fasload-liarc-object-file))
(define (compile-scode/internal/hook action)
(if (not (eq? *info-output-filename* 'KEEP))
diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm
index 5744ccea4..27d9320d8 100644
--- a/v7/src/edwin/autold.scm
+++ b/v7/src/edwin/autold.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: autold.scm,v 1.69 2007/04/04 05:08:19 riastradh Exp $
+$Id: autold.scm,v 1.70 2007/04/14 03:52:39 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -156,15 +156,9 @@ USA.
(for-each (lambda (entry)
(let ((file (car entry))
(environment (->environment (cadr entry)))
- (purify? (or (null? (cddr entry)) (caddr entry))))
- (cond (((let-syntax ((ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure
- (cdr form))))))
- (ucode-primitive initialize-c-compiled-block 1))
- (string-append "edwin_" file))
+ (purify? (if (pair? (cddr entry)) (caddr entry) #t)))
+ (cond ((built-in-object-file
+ (merge-pathnames file (pathname-as-directory "edwin")))
=> (lambda (obj)
(if purify? (purify obj))
(scode-eval obj environment)))
diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index d09c73847..3b62b5417 100644
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: load.scm,v 14.87 2007/04/09 16:41:56 cph Exp $
+$Id: load.scm,v 14.88 2007/04/14 03:52:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -166,6 +166,11 @@ USA.
(define (find-pathname filename default-types)
(let ((pathname (merge-pathnames filename))
+ (find-loader
+ (lambda (extension)
+ (let ((place (assoc extension default-types)))
+ (and place
+ (cadr place)))))
(fail
(lambda ()
(find-pathname (error:file-operation filename
@@ -175,17 +180,17 @@ USA.
find-pathname
(list filename default-types))
default-types))))
- (cond ((file-regular? pathname)
+ (cond ((built-in-object-file pathname)
+ => (lambda (value)
+ (values pathname
+ ((find-loader #f) value))))
+ ((file-regular? pathname)
(values pathname
- (let ((find-loader
- (lambda (extension)
- (let ((place (assoc extension default-types)))
- (and place
- (cadr place))))))
- (or (and (pathname-type pathname)
- (find-loader (pathname-type pathname)))
- (find-loader "scm")
- (find-loader "bin")))))
+ (or (and (pathname-type pathname)
+ (find-loader (pathname-type pathname)))
+ (and (fasl-file? pathname)
+ (find-loader "bin"))
+ (find-loader "scm"))))
((pathname-type pathname)
(fail))
(else
@@ -200,7 +205,7 @@ USA.
(cond ((not (pair? types))
(values #f #f))
((not (caar types))
- (let ((value (try-built-in pathname)))
+ (let ((value (built-in-object-file pathname)))
(if value
(values pathname ((cadar types) value))
(loop (cdr types)))))
@@ -220,7 +225,7 @@ USA.
(cond ((not (pair? types))
(values latest-pathname latest-loader))
((not (caar types))
- (let ((value (try-built-in pathname)))
+ (let ((value (built-in-object-file pathname)))
(if value
(values pathname ((cadar types) value))
(loop (cdr types)
@@ -236,39 +241,26 @@ USA.
latest-pathname
latest-loader
latest-time))))))))
-
-(define (try-built-in pathname)
- (let ((d (pathname-directory pathname)))
- (and (pair? d)
- (let ((tail (last d)))
- (and (string? tail) ;Doesn't handle UP ("..").
- ((ucode-primitive initialize-c-compiled-block 1)
- (string-append tail
- "_"
- (pathname-name pathname))))))))
(define (load/internal pathname environment purify? load-noisily?)
- (let* ((port (open-input-file pathname))
- (fasl-marker (peek-char port)))
- (if (and (not (eof-object? fasl-marker))
- (= 250 (char->ascii fasl-marker)))
- (begin
- (close-input-port port)
- (load-scode-end (fasload/internal pathname
- load/suppress-loading-message?)
- environment
- purify?))
- (let ((value-stream
- (lambda ()
- (eval-stream (read-stream port environment) environment))))
- (if load-noisily?
- (write-stream (value-stream)
- (lambda (exp&value)
- (repl-write (cdr exp&value) (car exp&value))))
- (with-loading-message pathname
- (lambda ()
- (write-stream (value-stream)
- (lambda (exp&value) exp&value #f)))))))))
+ (if (fasl-file? pathname)
+ (load-scode-end (fasload/internal pathname
+ load/suppress-loading-message?)
+ environment
+ purify?)
+ (call-with-input-file pathname
+ (lambda (port)
+ (let ((value-stream
+ (lambda ()
+ (eval-stream (read-stream port environment) environment))))
+ (if load-noisily?
+ (write-stream (value-stream)
+ (lambda (exp&value)
+ (repl-write (cdr exp&value) (car exp&value))))
+ (with-loading-message pathname
+ (lambda ()
+ (write-stream (value-stream)
+ (lambda (exp&value) exp&value #f))))))))))
(define (fasload/internal pathname suppress-loading-message?)
(let ((namestring (->namestring pathname)))
@@ -287,20 +279,41 @@ USA.
(define (fasload-object-file pathname suppress-loading-message?)
(with-loading-message pathname
(lambda ()
- (let* ((handle ((ucode-primitive load-object-file 1)
- (->namestring pathname)))
- (cth ((ucode-primitive object-lookup-symbol 3)
- handle "dload_initialize_file" 0)))
- (if (not cth)
- (error "load-object-file: Cannot find init procedure" pathname))
- (let ((scode ((ucode-primitive initialize-c-compiled-block 1)
- ((ucode-primitive address-to-string 1)
- ((ucode-primitive invoke-c-thunk 1)
- cth)))))
- (fasload/update-debugging-info! scode pathname)
- scode)))
+ (let ((scode (fasload-liarc-object-file pathname)))
+ (fasload/update-debugging-info! scode pathname)
+ scode))
suppress-loading-message?))
+(define (fasload-liarc-object-file pathname)
+ (let* ((handle ((ucode-primitive load-object-file 1)
+ (->namestring pathname)))
+ (cth ((ucode-primitive object-lookup-symbol 3)
+ handle "dload_initialize_file" 0)))
+ (if (not cth)
+ (error "Cannot find init procedure:" pathname))
+ ((ucode-primitive initialize-c-compiled-block 1)
+ ((ucode-primitive address-to-string 1)
+ ((ucode-primitive invoke-c-thunk 1)
+ cth)))))
+
+(define (built-in-object-file pathname)
+ (let ((handle (liarc-object-pathname->handle pathname)))
+ (and handle
+ ((ucode-primitive initialize-c-compiled-block 1) handle))))
+
+(define (liarc-object-pathname->handle pathname)
+ (let ((pathname (merge-pathnames pathname)))
+ (let ((d (pathname-directory pathname))
+ (n (pathname-name pathname))
+ (t (pathname-type pathname)))
+ (and (pair? d)
+ (let ((tail (last d)))
+ (and (string? tail) ;Doesn't handle UP ("..").
+ (string-append tail "_" n
+ (cond ((not t) ".bin")
+ ((string? t) (string-append "." t))
+ (else "")))))))))
+
(define (wrapper/fasload/built-in value)
(lambda (pathname suppress-loading-message?)
(with-loading-message pathname
@@ -429,6 +442,18 @@ USA.
(loop (stream-car stream) (stream-cdr stream)))
(cdr exp&value)))
unspecific))
+
+(define (fasl-file? pathname)
+ (call-with-binary-input-file pathname
+ (lambda (port)
+ (let ((n (vector-ref (gc-space-status) 0)))
+ (let ((marker (make-string n)))
+ (and (eqv? (read-string! marker port) n)
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (fix:= (vector-8b-ref marker i) #xFA)
+ (loop (fix:+ i 1)))
+ #t))))))))
;;;; Command Line Parser
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index bf2687248..b6866f2c5 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: make.scm,v 14.108 2007/01/05 21:19:28 cph Exp $
+$Id: make.scm,v 14.109 2007/04/14 03:52:47 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -243,7 +243,7 @@ USA.
bin-file)))))
(define (file->object filename purify? optional?)
- (let* ((block-name (string-append "runtime_" filename))
+ (let* ((block-name (string-append "runtime_" filename ".bin"))
(value (initialize-c-compiled-block block-name)))
(cond (value
(tty-write-string newline-string)
@@ -263,13 +263,19 @@ USA.
(tty-write-string " evaluated")
value))
-(define (string-append x y)
- (let ((x-length (string-length x))
- (y-length (string-length y)))
- (let ((result (string-allocate (+ x-length y-length))))
- (substring-move-right! x 0 x-length result 0)
- (substring-move-right! y 0 y-length result x-length)
- result)))
+(define (string-append . strings)
+ (let ((result
+ (string-allocate
+ (let loop ((strings strings) (n 0))
+ (if (pair? strings)
+ (loop (cdr strings) (fix:+ (string-length (car strings)) n))
+ n)))))
+ (let loop ((strings strings) (start 0))
+ (if (pair? strings)
+ (let ((n (string-length (car strings))))
+ (substring-move-right! (car strings) 0 n result start)
+ (loop (cdr strings) (fix:+ start n)))))
+ result))
(define (string-downcase string)
(let ((size (string-length string)))
@@ -285,8 +291,7 @@ USA.
(define (intern string)
(string->symbol (string-downcase string)))
-(define fasload-purification-queue
- '())
+(define fasload-purification-queue '())
(define (implemented-primitive-procedure? primitive)
((ucode-primitive get-primitive-address)
@@ -297,9 +302,7 @@ USA.
(let ((prim (ucode-primitive initialize-c-compiled-block 1)))
(if (implemented-primitive-procedure? prim)
prim
- (lambda (name)
- name ; ignored
- #f))))
+ (lambda (name) name #f))))
(define os-name
(intern os-name-string))
@@ -337,12 +340,15 @@ USA.
(package/add-child! system-global-package 'PACKAGE environment-for-package)
(define packages-file
- (let ((name (cond ((eq? os-name 'NT) "runtime-w32")
- ((eq? os-name 'OS/2) "runtime-os2")
- ((eq? os-name 'UNIX) "runtime-unx")
- (else "runtime-unk"))))
+ (let ((name
+ (string-append "runtime-"
+ (cond ((eq? os-name 'NT) "w32")
+ ((eq? os-name 'OS/2) "os2")
+ ((eq? os-name 'UNIX) "unx")
+ (else "unk"))
+ ".pkd")))
(or (initialize-c-compiled-block (string-append "runtime_" name))
- (fasload (string-append name ".pkd") #f))))
+ (fasload name #f))))
((lexical-reference environment-for-package 'CONSTRUCT-PACKAGES-FROM-FILE)
packages-file)
diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm
index 8894e5f56..c1373216e 100644
--- a/v7/src/runtime/option.scm
+++ b/v7/src/runtime/option.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: option.scm,v 14.52 2007/01/05 21:19:28 cph Exp $
+$Id: option.scm,v 14.53 2007/04/14 03:52:51 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -114,27 +114,26 @@ USA.
(lambda ()
(let ((environment (package/environment (find-package package-name)))
(runtime (pathname-as-directory "runtime")))
- (for-each (lambda (file)
- (let ((file (force* file)))
- (cond
- (((ucode-primitive initialize-c-compiled-block 1)
- (string-append "runtime_" file))
- => (lambda (obj)
- (purify obj)
- (scode-eval obj environment)))
- (else
- (let* ((options (library-directory-pathname "options"))
- (pathname (merge-pathnames file options)))
- (with-directory-rewriting-rule options runtime
+ (for-each
+ (lambda (file)
+ (let ((file (force* file)))
+ (cond ((built-in-object-file (merge-pathnames file runtime))
+ => (lambda (obj)
+ (purify obj)
+ (scode-eval obj environment)))
+ (else
+ (let* ((options (library-directory-pathname "options"))
+ (pathname (merge-pathnames file options)))
+ (with-directory-rewriting-rule options runtime
+ (lambda ()
+ (with-working-directory-pathname
+ (directory-pathname pathname)
(lambda ()
- (with-working-directory-pathname
- (directory-pathname pathname)
- (lambda ()
- (load pathname
- environment
- 'DEFAULT
- #t))))))))))
- files)
+ (load pathname
+ environment
+ 'DEFAULT
+ #t))))))))))
+ files)
(flush-purification-queue!)
(eval init-expression environment))))
diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index c83efaec3..3236d3628 100644
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: packag.scm,v 14.52 2007/04/04 18:35:16 riastradh Exp $
+$Id: packag.scm,v 14.53 2007/04/14 03:52:55 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -163,28 +163,21 @@ USA.
package-name-tag
system-global-package))
-(define system-loader/enable-query? #f)
-
-(define (quasi-fasload pathname)
- (let ((prim (ucode-primitive initialize-c-compiled-block 1))
- (path (merge-pathnames pathname)))
- (or (and (implemented-primitive-procedure? prim)
- (prim (string-append (car (last-pair (pathname-directory path)))
- "_"
- (pathname-name path))))
- (fasload pathname))))
-
(define (load-package-set filename #!optional options)
- (let ((os-type microcode-id/operating-system))
- (let ((pathname (package-set-pathname filename os-type))
+ (let ((pathname (merge-pathnames filename))
+ (os-type microcode-id/operating-system))
+ (let ((dir (directory-pathname pathname))
+ (pkg (package-set-pathname pathname os-type))
(options
(cons (cons 'OS-TYPE os-type)
(if (default-object? options) '() options))))
- (with-working-directory-pathname (directory-pathname pathname)
+ (with-working-directory-pathname dir
(lambda ()
- (let ((file (quasi-fasload pathname)))
+ (let ((file
+ (or (built-in-object-file pkg)
+ (fasload pkg))))
(if (not (package-file? file))
- (error "Malformed package-description file:" pathname))
+ (error "Malformed package-description file:" pkg))
(construct-packages-from-file file)
(fluid-let
((load/default-types
@@ -196,14 +189,13 @@ USA.
(let ((alternate-loader
(lookup-option 'ALTERNATE-PACKAGE-LOADER options))
(load-component
- (lambda (component environment)
- (let ((value
- (filename->compiled-object filename component)))
+ (lambda (name environment)
+ (let ((value (filename->compiled-object dir name)))
(if value
(begin
(purify (load/purification-root value))
(scode-eval value environment))
- (load component environment 'DEFAULT #t))))))
+ (load name environment 'DEFAULT #t))))))
(if alternate-loader
(alternate-loader load-component options)
(begin
@@ -213,41 +205,32 @@ USA.
;; program runs before it gets purified, some of its run-time state
;; can end up being purified also.
(flush-purification-queue!))
-
+
+(define system-loader/enable-query? #f)
+
(define (package-set-pathname pathname #!optional os-type)
- (make-pathname (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- (string-append (pathname-name pathname)
- (case (if (default-object? os-type)
- microcode-id/operating-system
- os-type)
- ((NT) "-w32")
- ((OS/2) "-os2")
- ((UNIX) "-unx")
- (else "-unk")))
- "pkd"
- (pathname-version pathname)))
-
-(define (filename->compiled-object system component)
- (let ((prim (ucode-primitive initialize-c-compiled-block 1)))
- (and (implemented-primitive-procedure? prim)
- (let* ((name
- (let* ((p (->pathname component))
- (d (pathname-directory p)))
- (string-append
- (if (pair? d) (car (last-pair d)) system)
- "_"
- (pathname-name p))))
- (value (prim name)))
- (if (or (not value) load/suppress-loading-message?)
- value
- (begin
- (write-notification-line
- (lambda (port)
- (write-string "Initialized " port)
- (write name port)))
- value))))))
+ (pathname-new-type
+ (pathname-new-name pathname
+ (string-append (pathname-name pathname)
+ "-"
+ (case (if (default-object? os-type)
+ microcode-id/operating-system
+ os-type)
+ ((NT) "w32")
+ ((OS/2) "os2")
+ ((UNIX) "unx")
+ (else "unk"))))
+ "pkd"))
+
+(define (filename->compiled-object directory name)
+ (let ((pathname (merge-pathnames name directory)))
+ (let ((value (built-in-object-file pathname)))
+ (if (and value (not load/suppress-loading-message?))
+ (write-notification-line
+ (lambda (port)
+ (write-string "Initialized " port)
+ (write (enough-namestring pathname) port))))
+ value)))
(define-integrable (make-package-file tag version descriptions loads)
(vector tag version descriptions loads))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 4ce303133..824b69f1e 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.614 2007/04/01 17:33:07 riastradh Exp $
+$Id: runtime.pkg,v 14.615 2007/04/14 03:52:59 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -2407,12 +2407,16 @@ USA.
(parent (runtime))
(export ()
argument-command-line-parser
+ built-in-object-file
condition-type:not-loading
current-eval-unit
current-load-pathname
+ fasl-file?
fasload
fasload-latest
+ fasload-liarc-object-file
fasload/default-types
+ liarc-object-pathname->handle
load
load-latest
load-library-object-file
diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm
index 8979792e2..7f15ea073 100644
--- a/v7/src/runtime/utabs.scm
+++ b/v7/src/runtime/utabs.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: utabs.scm,v 14.22 2007/01/05 21:19:28 cph Exp $
+$Id: utabs.scm,v 14.23 2007/04/14 03:53:04 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -56,11 +56,8 @@ USA.
(define (read-microcode-tables! #!optional filename)
(set! microcode-tables-identification
(scode-eval
- (or (let ((prim ((ucode-primitive get-primitive-address)
- 'initialize-c-compiled-block
- #f)))
- (and prim
- (prim "microcode_utabmd")))
+ (or ((ucode-primitive initialize-c-compiled-block 1)
+ "microcode_utabmd.bin")
((ucode-primitive binary-fasload)
(if (default-object? filename)
((ucode-primitive microcode-tables-filename))