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 ae8c300ddad0c971f1819e889c56fac713fb4acc..e61302ff677d5a2861f9d74544f266e67e32e652 100644 (file)
--- 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)))))))
-
+\f
 (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))))))
 \f
 (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 b40e1b6f8b3f5a3111bc71d6c2056fdb59ef40c9..dbd08ec1057e19fb104d393be82bb49538fe20fc 100644 (file)
--- 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 44f5858950b68b426d4b08e212029d2667f2a02e..107fa71a7186ef0da3466558fdca7d717eceac45 100644 (file)
--- 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)