From: Chris Hanson Date: Mon, 2 Oct 2006 04:18:15 +0000 (+0000) Subject: Fix bug: LOAD-OPTION was generating a SIGSEGV when trying to load a X-Git-Tag: 20090517-FFI~915 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a330c398280e18b4f79345171799de3a2dc8bf2b;p=mit-scheme.git Fix bug: LOAD-OPTION was generating a SIGSEGV when trying to load a runtime option, because it was confused by the "options" subdirectory. --- diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index ae8c300dd..e61302ff6 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.77 2006/09/16 11:19:09 gjr Exp $ +$Id: load.scm,v 14.78 2006/10/02 04:18:01 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology @@ -194,38 +194,21 @@ USA. (if (not pathname) (fail) (values pathname loader))))))) - -(define (try-built-in pathname wrapper) - (let ((prim (ucode-primitive initialize-c-compiled-block 1)) - (d (pathname-directory pathname))) - (if (or (not (implemented-primitive-procedure? prim)) - (not (pair? d))) - (values #f #f) - (let* ((name (string-append (car (last-pair d)) - "_" - (pathname-name pathname))) - (value (prim name))) - (if (not value) - (values #f #f) - (values pathname (wrapper value))))))) - + (define (search-types-in-order pathname default-types) (let loop ((types default-types)) (cond ((not (pair? types)) (values #f #f)) - ((caar types) + ((not (caar types)) + (let ((value (try-built-in pathname))) + (if value + (values pathname ((cadar types) value)) + (loop (cdr types))))) + (else (let ((pathname (pathname-new-type pathname (caar types)))) (if (file-exists? pathname) (values pathname (cadar types)) - (loop (cdr types))))) - (else - (call-with-values - (lambda () - (try-built-in pathname (cadar types))) - (lambda (pathname loader) - (if pathname - (values pathname loader) - (loop (cdr types))))))))) + (loop (cdr types)))))))) ;; This always considers a built-in to be the newest. @@ -237,28 +220,30 @@ USA. (cond ((not (pair? types)) (values latest-pathname latest-loader)) ((not (caar types)) - (call-with-values - (lambda () - (try-built-in pathname (cadar types))) - (lambda (pathname* loader*) - (if pathname* - (values pathname* loader*) - (loop (cdr types) - latest-pathname - latest-loader - latest-time))))) + (let ((value (try-built-in pathname))) + (if value + (values pathname ((cadar types) value)) + (loop (cdr types) + latest-pathname + latest-loader + latest-time)))) (else - (let ((pathname (pathname-new-type pathname (caar types))) - (skip - (lambda () - (loop (cdr types) - latest-pathname - latest-loader - latest-time)))) + (let ((pathname (pathname-new-type pathname (caar types)))) (let ((time (file-modification-time-indirect pathname))) (if (and time (> time latest-time)) (loop (cdr types) pathname (cadar types) time) - (skip)))))))) + (loop (cdr types) + latest-pathname + latest-loader + latest-time)))))))) + +(define (try-built-in pathname) + (let ((d (pathname-directory pathname))) + (and (pair? d) + ((ucode-primitive initialize-c-compiled-block 1) + (string-append (last d) + "_" + (pathname-name pathname)))))) (define (load/internal pathname environment purify? load-noisily?) (let* ((port (open-input-file pathname)) diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index b40e1b6f8..dbd08ec10 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: option.scm,v 14.49 2006/09/16 11:19:09 gjr Exp $ +$Id: option.scm,v 14.50 2006/10/02 04:18:06 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1997,1998,2001,2002 Massachusetts Institute of Technology @@ -87,8 +87,8 @@ USA. (standard-load-options))) (define (standard-load-options) - (or (library-file? "options/optiondb") - (library-file? "runtime/optiondb") ; for C back end + (or (library-file? "runtime/optiondb") ; for C back end + (library-file? "options/optiondb") (error "Cannot locate a load-option database") "optiondb")) @@ -97,26 +97,10 @@ USA. (merge-pathnames library-internal-path (library-directory-pathname "")))) (define (confirm-pathname pathname) - (let loop ((file-types load/default-types)) - (and (pair? file-types) - (let ((full-pathname (pathname-new-type pathname (caar file-types)))) - (cond ((file-exists? full-pathname) - ; not FULL-PATHNAME - pathname) - ((not (caar file-types)) - (let ((prim - (ucode-primitive initialize-c-compiled-block 1)) - (d (pathname-directory pathname))) - (if (and (implemented-primitive-procedure? prim) - (pair? d) - (prim (string-append - (car (last-pair d)) - "_" - (pathname-name pathname)))) - pathname - (loop (cdr file-types))))) - (else - (loop (cdr file-types)))))))) + (receive (pathname* loader) + (search-types-in-order pathname load/default-types) + pathname* + (and loader pathname))) (define loaded-options '()) (define *options* '()) ; Current options. diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 44f585895..107fa71a7 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.595 2006/09/16 11:19:09 gjr Exp $ +$Id: runtime.pkg,v 14.596 2006/10/02 04:18:15 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -2395,6 +2395,8 @@ USA. set-command-line-parser! simple-command-line-parser with-eval-unit) + (export (runtime options) + search-types-in-order) (initialization (initialize-package!))) (define-package (runtime microcode-errors)