From: Chris Hanson 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 @@ -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))