Moved the library directories facility to its own module.

scsh/lib-dirs.scm

@@ -0,0 +1,112 @@
+;;; More imports for the new library-search facility:
+;;;     HANDLE: with-handler
+;;;     LIST-LIB: any
+;;;     SCSH-LEVEL-0: directory-files open-input-file file-directory?
+;;;     SCSH-LEVEL-0: getenv
+;;;     SCSH-LEVEL-0: the file-name procs
+
+(define default-lib-dirs '("/usr/local/lib/scsh/modules/"))
+
+(define (set-default-lib-dirs! path-list)
+  (set! default-lib-dirs path-list))
+
+;;; Search library dirs for FILE.
+(define (find-library-file file lib-dirs script-file)
+  (letrec ((recur (lambda (dir)
+;		    (format (error-output-port) "flf -- entering ~a\n" dir)
+		    (let* ((f (string-append dir file)))	; Resolve it.
+		      (or (check-file-for-open f)		; Found it.
+			  (any (lambda (f)			; Search subdirs.
+				 (let ((dir (string-append dir f "/")))
+				   (and (file-directory?/safe dir) (recur dir))))
+			       (directory-files/safe dir)))))))
+    (any (lambda (dir)
+	   (cond ((eq? dir 'script-dir)
+		  (let* ((script-dir (file-name-directory script-file))
+			 (fname (string-append script-dir file)))
+		    (check-file-for-open fname)))
+
+		 ;; Ends in / means recursive search.
+		 ((file-name-directory? dir)
+		  (recur dir))
+
+		 (else (check-file-for-open (absolute-file-name file dir)))))
+	 lib-dirs)))
+			    
+
+;;; (in-any-event abort-exp body ...)
+;;; If *anything* goes wrong, bag the BODY forms, and eval ABORT-EXP instead.
+
+(define-syntax in-any-event
+  (syntax-rules ()
+    ((in-any-event abort-exp body ...)
+     (call-with-current-continuation
+      (lambda (ret)
+	(with-handler (lambda (condition more) (ret abort-exp))
+		      (lambda () body ...)))))))
+
+(define (check-file-for-open f)
+  (in-any-event #f (let ((iport (open-input-file f)))
+		     (close-input-port iport)
+		     f)))                      ; Any error, say false.
+
+(define (directory-files/safe dir)
+  (in-any-event '() (directory-files dir)))	; Any error, say ().
+
+(define (file-directory?/safe f)
+  (in-any-event #f (file-directory? f)))	; Any error, say false.
+
+(define (resolve-dir-name dir)
+  (if (file-name-directory? dir)
+      (file-name-as-directory (resolve-file-name dir))
+      (resolve-file-name dir)))
+
+;;; Expand out env vars & ~user home dir prefixes.
+(define (expand-lib-dir dir)
+  (substitute-env-vars (resolve-dir-name dir)))
+
+;;; Parse up the $SCSH_LIB_DIRS path list.
+(define (parse-lib-dirs-env-var)
+   (let ((s (getenv "SCSH_LIB_DIRS")))
+     (if (not s)
+         default-lib-dirs
+         (with-current-input-port (make-string-input-port s)
+            (let recur ()
+              (let ((val (read)))
+                (cond ((eof-object? val) '())
+                      ((string? val) (cons val (recur)))
+                      ((not val) (append default-lib-dirs (recur)))
+                      (else (error "Illegal path element in $SCSH_LIB_DIRS"
+                                   s val)))))))))
+
+;; We don't want to try to parse $SCSH_LIB_DIRS until we actually
+;; need the value -- if the user is using the -lp-default switch,
+;; for example, a parse error shouldn't effect the startup.
+(define %lib-dirs #f)
+(define reinit-lib-dirs 
+  (make-reinitializer (lambda () (set! %lib-dirs #f))))
+
+(define (lib-dirs)
+  (if (not %lib-dirs) (set! %lib-dirs (parse-lib-dirs-env-var)))
+  %lib-dirs)
+
+;; Don't export -- direct modification of %lib-dirs 
+(define (set-lib-dirs! val) (set! %lib-dirs val))
+
+(define (lib-dirs-append-script-dir!)
+  (set-lib-dirs! (append (lib-dirs) '(script-dir))))
+
+(define (lib-dirs-prepend-script-dir!)
+  (set-lib-dirs! (cons 'script-dir (lib-dirs))))
+
+(define (reset-lib-dirs!)
+  (set-lib-dirs! default-lib-dirs))
+
+(define (clear-lib-dirs!)
+  (set-lib-dirs! '()))
+
+(define (lib-dirs-prepend! dir)
+  (set-lib-dirs! (cons dir (lib-dirs))))
+
+(define (lib-dirs-append! dir)
+  (set-lib-dirs! (append (lib-dirs) (list dir))))

scsh/scsh-interfaces.scm

@@ -1206,4 +1206,18 @@
           cppflags
           ldflags
           linker-flags
-          compiler-flags))
+          compiler-flags))
+
+(define-interface lib-dirs-interface
+  (export lib-dirs
+          find-library-file
+
+          lib-dirs-append-script-dir!
+          lib-dirs-prepend-script-dir!
+          reset-lib-dirs!
+          clear-lib-dirs!
+          lib-dirs-prepend!
+          lib-dirs-append!))
+
+(define-interface lib-dirs-internal-interface
+  (export expand-lib-dir))

scsh/scsh-package.scm

@@ -356,7 +356,8 @@
 				; with-current-output-port exit
 	scsh-level-0-internals	; set-command-line-args! init-scsh-vars
 	threads
-	(subset srfi-1 (any))
+        lib-dirs
+        lib-dirs-internal
 	(subset srfi-14 (char-set
 			 char-set-complement!
 			 char-set-contains?
@@ -458,6 +459,7 @@
 		      dot-locking-interface
 		      md5-interface
                       configure-interface
+                      lib-dirs-interface
 		      )
 
   (open structure-refs
@@ -474,6 +476,7 @@
 	dot-locking
 	md5
         configure
+        lib-dirs
 	scheme)
 
   (access scsh-top-package)
@@ -591,4 +594,13 @@
   (open scheme
         re-level-0 rx-syntax
         (subset srfi-13 (string-join)))
-  (files configure))
+  (files configure))
+
+(define-structures ((lib-dirs lib-dirs-interface)
+                    (lib-dirs-internal lib-dirs-internal-interface))
+  (open scsh-level-0
+        scheme
+        handle
+        scsh-utilities
+        (subset srfi-1 (any)))
+  (files lib-dirs))

scsh/top.scm

@@ -19,13 +19,7 @@
 ;;;	RECEIVING: mv return stuff
 ;;;	SCSH-LEVEL-0-INTERNALS: set-command-line-args!
 ;;;	SCSH-VERSION: scsh-version-string
-;;;	
-;;; More imports for the new library-search facility:
 ;;;     HANDLE: with-handler
-;;;     LIST-LIB: any
-;;;     SCSH-LEVEL-0: directory-files open-input-file file-directory? getenv
-;;;     SCSH-LEVEL-0: getenv
-;;;     SCSH-LEVEL-0: the file-name procs
 
 ;;; This should be defined by the package code, but it isn't.
 
@@ -50,7 +44,19 @@
   (let-fluid $current-noise-port (make-null-output-port)
 	     (lambda ()
 	       (apply ensure-loaded structs))))
-		      
+
+(define (load-library-file file lib-dirs script-file package)
+; (format (error-output-port) "Load-library-file: ~a ~s\n" file lib-dirs)
+  (cond ((file-name-absolute? file)
+         (load-quietly file package))
+
+	;; Search library dirs for FILE.
+	((find-library-file file lib-dirs script-file) =>
+	 (lambda (file)
+           (load-quietly file package)))  ; Load it.
+
+	(else (error "Couldn't find library file" file lib-dirs))))
+
 ;;; The switches:
 ;;; 	-o <struct>		Open the structure in current package.
 ;;; 	-n <package>		Create new package, make it current package.
@@ -183,24 +189,11 @@
 
 	(values (reverse switches) #f #f top-entry '()))))
 
-(define default-lib-dirs '("/usr/local/lib/scsh/modules/"))
-
-(define (set-default-lib-dirs! path-list)
-  (set! default-lib-dirs path-list))
-
 ;;; Do each -ds, -dm, -de, -o, -n, -m, -l/lm/ll, +lp/+lpe/lp+/lpe+, or
 ;;; -lp-clear/lp-default switch, and return the final result package and a
 ;;; flag saying if the script was loaded by a -ds, -dm, or -de.
 
 (define (do-switches switches script-file)
-  ;; We don't want to try to parse $SCSH_LIB_DIRS until we actually
-  ;; need the value -- if the user is using the -lp-default switch,
-  ;; for example, a parse error shouldn't effect the startup.
-  (define %mod-dirs #f)
-  (define (mod-dirs)
-    (if (not %mod-dirs) (set! %mod-dirs (parse-lib-dirs-env-var)))
-    %mod-dirs)
-  (define (set-mod-dirs! val) (set! %mod-dirs val))
 
 ; (format #t "Switches = ~a~%" switches)
   (let lp ((switches switches)
@@ -227,19 +220,19 @@
 	     (lp switches #t))
 
 	    ((equal? switch "-lp-clear")
-	     (set-mod-dirs! '())
+             (clear-lib-dirs!)
 	     (lp switches script-loaded?))
 
 	    ((equal? switch "-lp-default")
-	     (set-mod-dirs! default-lib-dirs)
+             (reset-lib-dirs!)
 	     (lp switches script-loaded?))
 
 	    ((equal? switch "+lpsd")
-	     (set-mod-dirs! (cons 'script-dir (mod-dirs)))
+             (lib-dirs-prepend-script-dir!)
 	     (lp switches script-loaded?))
 
 	    ((equal? switch "lpsd+")
-	     (set-mod-dirs! (append (mod-dirs) '(script-dir)))
+             (lib-dirs-append-script-dir!)
 	     (lp switches script-loaded?))
 
 	    ((string=? (car switch) "-l")
@@ -258,29 +251,29 @@
 	     (lp switches script-loaded?))
 
 	    ((string=? (car switch) "-ll")
-	     (load-library-file (cdr switch) (mod-dirs) script-file 
+	     (load-library-file (cdr switch) (lib-dirs) script-file 
                                 (config-package))
 	     (lp switches script-loaded?))
 
 	    ((string=? (car switch) "-lel")
-	     (load-library-file (cdr switch) (mod-dirs) script-file 
+	     (load-library-file (cdr switch) (lib-dirs) script-file 
                                 (user-command-environment))
 	     (lp switches script-loaded?))
 
 	    ((string=? (car switch) "+lp")
-	     (set-mod-dirs! (cons (cdr switch) (mod-dirs)))
+             (lib-dirs-prepend! (cdr switch))
 	     (lp switches script-loaded?))
+
 	    ((string=? (car switch) "lp+")
-	     (set-mod-dirs! (append (mod-dirs) (list (cdr switch))))
+             (lib-dirs-append! (cdr switch))
 	     (lp switches script-loaded?))
 	     
 	    ((string=? (car switch) "+lpe")
-	     (set-mod-dirs! (cons (expand-lib-dir (cdr switch)) (mod-dirs)))
+             (lib-dirs-prepend! (expand-lib-dir (cdr switch)))
 	     (lp switches script-loaded?))
 
 	    ((string=? (car switch) "lpe+")
-	     (set-mod-dirs! (append (mod-dirs)
+             (lib-dirs-append! (expand-lib-dir (cdr switch)))
-				    (list (expand-lib-dir (cdr switch)))))
 	     (lp switches script-loaded?))
 
 	    ((string=? (car switch) "-o")
@@ -425,83 +418,6 @@
 
 (add-narrowed-exit-hook! flush-all-ports-no-threads)
 
-(define (load-library-file file lib-dirs script-file package)
-; (format (error-output-port) "Load-library-file: ~a ~s\n" file lib-dirs)
-  (cond ((file-name-absolute? file)
-         (load-quietly file package))
-
-	;; Search library dirs for FILE.
-	((find-library-file file lib-dirs script-file) =>
-	 (lambda (file)
-           (load-quietly file package)))  ; Load it.
-
-	(else (error "Couldn't find library file" file lib-dirs))))
-
-;;; Search library dirs for FILE.
-(define (find-library-file file lib-dirs script-file)
-  (letrec ((recur (lambda (dir)
-;		    (format (error-output-port) "flf -- entering ~a\n" dir)
-		    (let* ((f (string-append dir file)))	; Resolve it.
-		      (or (check-file-for-open f)		; Found it.
-			  (any (lambda (f)			; Search subdirs.
-				 (let ((dir (string-append dir f "/")))
-				   (and (file-directory?/safe dir) (recur dir))))
-			       (directory-files/safe dir)))))))
-    (any (lambda (dir)
-	   (cond ((eq? dir 'script-dir)
-		  (let* ((script-dir (file-name-directory script-file))
-			 (fname (string-append script-dir file)))
-		    (check-file-for-open fname)))
-
-		 ;; Ends in / means recursive search.
-		 ((file-name-directory? dir)
-		  (recur dir))
-
-		 (else (check-file-for-open (absolute-file-name file dir)))))
-	 lib-dirs)))
-			    
-
-;;; (in-any-event abort-exp body ...)
-;;; If *anything* goes wrong, bag the BODY forms, and eval ABORT-EXP instead.
-
-(define-syntax in-any-event
-  (syntax-rules ()
-    ((in-any-event abort-exp body ...)
-     (call-with-current-continuation
-      (lambda (ret)
-	(with-handler (lambda (condition more) (ret abort-exp))
-		      (lambda () body ...)))))))
-
-(define (check-file-for-open f)
-  (in-any-event #f (let ((iport (open-input-file f)))
-		     (close-input-port iport)
-		     f)))                      ; Any error, say false.
-
-(define (directory-files/safe dir)
-  (in-any-event '() (directory-files dir)))	; Any error, say ().
-
-(define (file-directory?/safe f)
-  (in-any-event #f (file-directory? f)))	; Any error, say false.
-
-
-;;; Expand out env vars & ~user home dir prefixes.
-(define (expand-lib-dir dir)
-  (substitute-env-vars (resolve-file-name dir)))
-
-;;; Parse up the $SCSH_LIB_DIRS path list.
-(define (parse-lib-dirs-env-var)
-   (let ((s (getenv "SCSH_LIB_DIRS")))
-     (if (not s)
-         default-lib-dirs
-         (with-current-input-port (make-string-input-port s)
-            (let recur ()
-              (let ((val (read)))
-                (cond ((eof-object? val) '())
-                      ((string? val) (cons val (recur)))
-                      ((not val) (append default-lib-dirs (recur)))
-                      (else (error "Illegal path element in $SCSH_LIB_DIRS"
-                                   s val))))))))))
-
 (define (bad-arg . msg)
   (with-current-output-port (current-error-port)
     (for-each (lambda (x) (display x) (write-char #\space)) msg)