Import Upstream version 2c3upstream/2c3

1 files changed, 71 insertions, 106 deletions

diff --git a/batch.scm b/batch.scm
index 88684c0..7749451 100644
--- a/batch.scm
+++ b/batch.scm
@@ -34,7 +34,11 @@
 ;;(trace system system:success? exit quit slib:exit)
 
 (define (batch:port parms)
-  (car (parameter-list-ref parms 'batch-port)))
+  (let ((bp (parameter-list-ref parms 'batch-port)))
+    (cond ((or (not (pair? bp)) (not (output-port? (car bp))))
+	   ;;(slib:error 'batch-line "missing batch-port parameter" bp)
+	   (current-output-port))
+	  (else (car bp)))))
 
 (define (batch:dialect parms)		; was batch-family
   (car (parameter-list-ref parms 'batch-dialect)))
@@ -49,13 +53,11 @@
 		  ((system) 1023)
 		  ((*unknown*) -1))))))
 
+(define (write-batch-line str line-limit port)
+  (cond ((and line-limit (>= (string-length str) line-limit)) #f)
+	(else (write-line str port) #t)))
 (define (batch-line parms str)
-  (let ((bp (parameter-list-ref parms 'batch-port))
-	(ln (batch:line-length-limit parms)))
-    (cond ((not bp) (slib:error 'batch-line "missing batch-port parameter"
-				parms))
-	  ((>= (string-length str) ln) #f)
-	  (else (write-line str (car bp)) #t))))
+  (write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
 
 ;;; add a Scheme batch-dialect?
 
@@ -70,56 +72,50 @@
 	    (else (loop (nthcdr (+ 1 hlen) fodder))
 		  (loop (butlast fodder hlen)))))))
 
-(define (batch:system parms . strings)
-  (cond ((not (provided? 'system))
-	 (slib:error 'batch:system 'system "procedure not supported."))
-	((apply batch:try-system parms strings))
-	(else (slib:error 'batch:system 'failed strings))))
-
 (define (batch:try-system parms . strings)
-  (define port (batch:port parms))
   (set! strings (batch:flatten strings))
   (case (batch:dialect parms)
     ((unix) (batch-line parms (apply string-join " " strings)))
     ((dos) (batch-line parms (apply string-join " " strings)))
     ((vms) (batch-line parms (apply string-join " " "$" strings)))
-    ((system) (cond ((provided? 'system)
-		     (write `(system ,(apply string-join " " strings)) port)
-		     (newline port)
-		     (system:success? (system (apply string-join " " strings))))
-		    (else #f))) 
-    ((*unknown*) (write `(system ,(apply string-join " " strings)) port)
-		 (newline port)
-		 #f)))
+    ((system)
+     (let ((port (batch:port parms))
+	   (str (apply string-join " " strings)))
+       (write `(system ,str) port) (newline port)
+       (and (provided? 'system) (system:success? (system str)))))
+    ((*unknown*)
+     (let ((port (batch:port parms))
+	   (str (apply string-join " " strings)))
+       (write `(system ,str) port) (newline port))
+     #t)
+    (else #f)))
+
+(define (batch:system parms . strings)
+  (cond ((apply batch:try-system parms strings))
+	(else (slib:error 'batch:system 'failed strings))))
 
 (define (batch:run-script parms name . strings)
   (case (batch:dialect parms strings)
     ((vms) (batch:system parms (string-append "@" name) strings))
     (else (batch:system parms name strings))))
 
+(define (batch:write-comment-line dialect line port)
+  (case dialect
+    ((unix) (write-batch-line (string-append "# " line) #f port))
+    ((dos) (write-batch-line (string-append "rem " line) #f port))
+    ((vms) (write-batch-line (string-append "$! " line) #f port))
+    ((system) (write-batch-line (string-append "; " line) #f port))
+    ((*unknown*) (write-batch-line (string-append ";;; " line) #f port)
+     ;;(newline port)
+     #f)))
+
 (define (batch:comment parms . lines)
   (define port (batch:port parms))
+  (define dialect (batch:dialect parms))
   (set! lines (batch:flatten lines))
-  (case (batch:dialect parms)
-    ((unix) (every (lambda (line)
-		     (batch-line parms (string-append "# " line)))
-		   lines))
-    ((dos) (every (lambda (line)
-		    (batch-line parms
-				(string-append
-				 "rem" (if (equal? "  " line) ".") line)))
-		  lines))
-    ((vms) (every (lambda (line)
-		    (batch-line parms (string-append "$! " line)))
-		  lines))
-    ((system) (every (lambda (line)
-		       (batch-line parms (string-append "; " line)))
-		     lines))
-    ((*unknown*) (for-each (lambda (line)
-			     (batch-line parms (string-append ";;; " line))
-			     (newline port))
-			   lines)
-		 #f)))
+  (every (lambda (line)
+	   (batch:write-comment-line dialect line port))
+	 lines))
 
 (define (batch:lines->file parms file . lines)
   (define port (batch:port parms))
@@ -195,61 +191,57 @@
 		 (newline port)
 		 #f)))
 
+(define (batch:write-header-comment dialect name port)
+  (batch:write-comment-line
+   dialect
+   (string-append (if (string? name)
+		      (string-append "\"" name "\"")
+		      (case dialect
+			((system *unknown*) "Scheme")
+			((vms) "VMS")
+			((dos) "DOS")
+			((default-for-platform) "??")
+			(else (symbol->string dialect))))
+		  " script created by SLIB/batch "
+		  (cond ((provided? 'bignum)
+			 (require 'posix-time)
+			 (let ((ct (ctime (current-time))))
+			   (substring ct 0 (+ -1 (string-length ct)))))
+			(else "")))
+   port))
+
 (define (batch:call-with-output-script parms name proc)
-  (case (batch:dialect parms)
+  (define dialect (batch:dialect parms))
+  (case dialect
     ((unix) ((cond ((and (string? name) (provided? 'system))
 		    (lambda (proc)
 		      (let ((ans (call-with-output-file name proc)))
 			(system (string-append "chmod +x " name))
 			ans)))
 		   ((output-port? name) (lambda (proc) (proc name)))
-		   (else  (lambda (proc) (proc (current-output-port)))))
+		   (else (lambda (proc) (proc (current-output-port)))))
 	     (lambda (port)
 	       (write-line "#!/bin/sh" port)
-	       (cond
-		((and (string? name) (provided? 'bignum))
-		 (require 'posix-time)
-		 (write-line
-		  (string-append
-		   "# \""  name "\" build script created "
-		   (ctime (current-time)))
-		  port)))
+	       (batch:write-header-comment dialect name port)
 	       (proc port))))
 
     ((dos) ((cond ((string? name)
 		   (lambda (proc)
 		     (call-with-output-file (string-append name ".bat") proc)))
 		  ((output-port? name) (lambda (proc) (proc name)))
-		  (else  (lambda (proc) (proc (current-output-port)))))
+		  (else (lambda (proc) (proc (current-output-port)))))
 	    (lambda (port)
-	      (cond
-	       ((and (string? name) (provided? 'bignum))
-		(require 'posix-time)
-		(write-line
-		 (string-append
-		  "rem " name
-		  " build script created "
-		  (ctime (current-time)))
-		 port)))
+	      (batch:write-header-comment dialect name port)
 	      (proc port))))
 
     ((vms) ((cond ((string? name)
 		   (lambda (proc)
 		     (call-with-output-file (string-append name ".COM") proc)))
 		  ((output-port? name) (lambda (proc) (proc name)))
-		  (else  (lambda (proc) (proc (current-output-port)))))
+		  (else (lambda (proc) (proc (current-output-port)))))
 	    (lambda (port)
-	      (cond
-	       ((and (string? name) (provided? 'bignum))
-		(require 'posix-time)
-		;;(write-line
-		;; "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
-		(write-line
-		 (string-append
-		  "$! " name
-		  " build script created "
-		  (ctime (current-time)))
-		 port)))
+	      (batch:write-header-comment dialect name port)
+	      ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
 	      (proc port))))
 
     ((system) ((cond ((and (string? name) (provided? 'system))
@@ -259,16 +251,9 @@
 			  (system (string-append "chmod +x " name))
 			  ans)))
 		     ((output-port? name) (lambda (proc) (proc name)))
-		     (else  (lambda (proc) (proc (current-output-port)))))
+		     (else (lambda (proc) (proc (current-output-port)))))
 	       (lambda (port)
-		 (cond
-		  ((and (string? name) (provided? 'bignum))
-		   (require 'posix-time)
-		   (write-line
-		    (string-append
-		     ";;; \""  name
-		     "\" build script created " (ctime (current-time)))
-		    port)))
+		 (batch:write-header-comment dialect name port)
 		 (proc port))))
 
     ((*unknown*) ((cond ((and (string? name) (provided? 'system))
@@ -278,18 +263,10 @@
 			     (system (string-append "chmod +x " name))
 			     ans)))
 			((output-port? name) (lambda (proc) (proc name)))
-			(else  (lambda (proc) (proc (current-output-port)))))
+			(else (lambda (proc) (proc (current-output-port)))))
 		  (lambda (port)
-		    (cond
-		     ((and (string? name) (provided? 'bignum))
-		      (require 'posix-time)
-		      (write-line
-		       (string-append
-			";;; \""  name
-			"\" build script created " (ctime (current-time)))
-		       port)))
-		    (proc port)))
-		 #f)))
+		    (batch:write-header-comment dialect name port)
+		    (proc port))))))
 
 ;;; This little ditty figures out how to use a Scheme extension or
 ;;; SYSTEM to execute a command that is not available in the batch
@@ -328,17 +305,6 @@
 	((string? chars) (set! chars (string->list chars))))
   (if (string? str) (tut str) (map tut str)))
 
-(define (replace-suffix str old new)
-  (define (cs str)
-    (let* ((len (string-length str))
-	   (re (- len (string-length old))))
-      (cond ((string-ci=? old (substring str re len))
-	     (string-append (substring str 0 re) new))
-	    (else
-	     (slib:error 'replace-suffix "suffix doens't match:"
-			 old str)))))
-  (if (string? str) (cs str) (map cs str)))
-
 (define (must-be-first firsts lst)
   (append (remove-if-not (lambda (i) (member i lst)) firsts)
 	  (remove-if (lambda (i) (member i firsts)) lst)))
@@ -439,4 +405,3 @@
 
   ((database 'add-domain) '(operating-system operating-system #f symbol #f))
   )
-