From 90e6e14bd2a449155a03de4a52ffec522415bb67 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 16 Oct 2000 18:00:55 +0000 Subject: [PATCH] Moved from dist directory. --- v7/src/etc/optiondb.scm | 52 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 v7/src/etc/optiondb.scm diff --git a/v7/src/etc/optiondb.scm b/v7/src/etc/optiondb.scm new file mode 100644 index 000000000..727740a6d --- /dev/null +++ b/v7/src/etc/optiondb.scm @@ -0,0 +1,52 @@ +#| -*-Scheme-*- + +$Id: optiondb.scm,v 1.1 2000/10/16 18:00:55 cph Exp $ + +Copyright (c) 2000 Massachusetts Institute of Technology + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +|# + +(define (guarded-system-loader package-name place #!optional filename) + (let ((directory + (merge-pathnames place + (directory-pathname (current-load-pathname))))) + (lambda () + (if (not (name->package package-name)) + (with-working-directory-pathname directory + (lambda () + (load + (let ((test + (lambda (name) + (or (file-exists? name) + (there-exists? load/default-types + (lambda (type) + (file-exists? + (pathname-new-type name (car type))))))))) + (cond ((not (default-object? filename)) filename) + ((test "make") "make") + ((test "load") "load") + (else (error "Can't find loader."))))))))))) + +(define-load-option 'CREF + (guarded-system-loader '(cross-reference) "cref")) + +(define-load-option 'SOS + (guarded-system-loader '(runtime object-system) "sos")) + +(define-load-option 'IMAIL + (guarded-system-loader '(edwin imail) "imail")) + +(further-load-options standard-load-options) \ No newline at end of file -- 2.25.1