From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:29 -0800
Subject: Import Upstream version 3a1

---
 batch.scm | 145 +++++++++++++++++++++++++++++++++++++-------------------------
 1 file changed, 87 insertions(+), 58 deletions(-)

(limited to 'batch.scm')

diff --git a/batch.scm b/batch.scm
index 45b404c..bef29cc 100644
--- a/batch.scm
+++ b/batch.scm
@@ -8,7 +8,7 @@
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
 ;
-;2.  I have made no warrantee or representation that the operation of
+;2.  I have made no warranty or representation that the operation of
 ;this software will be error-free, and I am under no obligation to
 ;provide any services, by way of maintenance, update, or otherwise.
 ;
@@ -17,11 +17,14 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
+(require 'tree)
 (require 'line-i/o)			;Just for write-line
+(require 'databases)
 (require 'parameters)
-(require 'database-utilities)
 (require 'string-port)
-(require 'tree)
+(require 'pretty-print)
+(require 'common-list-functions)
+(require-if '(and bignum compiling) 'posix-time)
 
 (define system
   (if (provided? 'system)
@@ -43,6 +46,9 @@
 (define (batch:dialect parms)		; was batch-family
   (car (parameter-list-ref parms 'batch-dialect)))
 
+(define (batch:operating-system parms)
+  (car (parameter-list-ref parms 'operating-system)))
+
 (define (write-batch-line str line-limit port)
   (cond ((and line-limit (>= (string-length str) line-limit))
 	 (slib:warn 'write-batch-line 'too-long
@@ -53,7 +59,7 @@
   (write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
 
 ;;; add a Scheme batch-dialect?
-
+;@
 (define (batch:try-chopped-command parms . args)
   (define args-but-last (batch:flatten (butlast args 1)))
   (define line-limit (batch:line-length-limit parms))
@@ -65,7 +71,7 @@
 	     (batch:try-command parms str))
 	    ((< (length fodder) 2)
 	     (slib:warn 'batch:try-chopped-command "can't fit in " line-limit
-			(cons proc (append args-but-last (list fodder))))
+			(append args-but-last (list fodder)))
 	     #f)
 	    (else (let ((hlen (quotient (length fodder) 2)))
 		    (and (loop (last fodder hlen))
@@ -74,15 +80,15 @@
 (define (batch:glued-line parms strings)
   (case (batch:dialect parms)
     ((vms) (apply string-join " " "$" strings))
-    ((unix dos amigados system *unknown*) (apply string-join " " strings))
+    ((unix dos amigaos system *unknown*) (apply string-join " " strings))
     (else #f)))
-
+;@
 (define (batch:try-command parms . strings)
   (set! strings (batch:flatten strings))
   (let ((line (batch:glued-line parms strings)))
     (and line
 	 (case (batch:dialect parms)
-	   ((unix dos vms amigados) (batch-line parms line))
+	   ((unix dos vms amigaos) (batch-line parms line))
 	   ((system)
 	    (let ((port (batch:port parms)))
 	      (write `(system ,line) port) (newline port)
@@ -91,11 +97,11 @@
 	    (let ((port (batch:port parms)))
 	      (write `(system ,line) port) (newline port) #t))
 	   (else #f)))))
-
+;@
 (define (batch:command parms . strings)
   (cond ((apply batch:try-command parms strings))
 	(else (slib:error 'batch:command 'failed strings))))
-
+;@
 (define (batch:run-script parms name . strings)
   (case (batch:dialect parms strings)
     ((vms) (batch:command parms (string-append "@" name) strings))
@@ -106,12 +112,12 @@
     ((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))
-    ((amigados) (write-batch-line (string-append "; " line) #f port))
+    ((amigaos) (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))
@@ -119,7 +125,7 @@
   (every (lambda (line)
 	   (batch:write-comment-line dialect line port))
 	 lines))
-
+;@
 (define (batch:lines->file parms file . lines)
   (define port (batch:port parms))
   (set! lines (batch:flatten lines))
@@ -142,7 +148,7 @@
 		(every (lambda (string) (batch-line parms string))
 		       lines)
 		(batch-line parms (string-append "$EOD"))))
-    ((amigados) (batch-line parms (string-append "delete force " file))
+    ((amigaos) (batch-line parms (string-append "delete force " file))
 	    (every
 	     (lambda (str)
 	       (letrec ((star-quote
@@ -162,7 +168,6 @@
 	     lines))
     ((system) (write `(delete-file ,file) port) (newline port)
 	      (delete-file file)
-	      (require 'pretty-print)
 	      (pretty-print `(call-with-output-file ,file
 			       (lambda (fp)
 				 (for-each
@@ -175,7 +180,6 @@
 	      #t)
     ((*unknown*)
      (write `(delete-file ,file) port) (newline port)
-     (require 'pretty-print)
      (pretty-print
       `(call-with-output-file ,file
 	 (lambda (fp)
@@ -185,7 +189,7 @@
 	    ,lines)))
       port)
      #f)))
-
+;@
 (define (batch:delete-file parms file)
   (define port (batch:port parms))
   (case (batch:dialect parms)
@@ -195,13 +199,13 @@
 	   #t)
     ((vms) (batch-line parms (string-append "$DELETE " file))
 	   #t)
-    ((amigados) (batch-line parms (string-append "delete force " file))
+    ((amigaos) (batch-line parms (string-append "delete force " file))
 	    #t)
     ((system) (write `(delete-file ,file) port) (newline port)
 	      (delete-file file))	; SLIB provides
     ((*unknown*) (write `(delete-file ,file) port) (newline port)
 		 #f)))
-
+;@
 (define (batch:rename-file parms old-name new-name)
   (define port (batch:port parms))
   (case (batch:dialect parms)
@@ -209,15 +213,18 @@
     ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name)))
     ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name)))
     ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name)))
-    ((amigados) (batch-line parms (string-join " " "failat 21"))
-		(batch-line parms (string-join " " "delete force" new-name))
-		(batch-line parms (string-join " " "rename" old-name new-name)))
+    ((amigaos) (batch-line parms (string-join " " "failat 21"))
+	       (batch-line parms (string-join " " "delete force" new-name))
+	       (batch-line parms (string-join " " "rename" old-name new-name)))
     ((system) (batch:extender 'rename-file batch:rename-file))
     ((*unknown*) (write `(rename-file ,old-name ,new-name) port)
 		 (newline port)
 		 #f)))
 
-(define (batch:write-header-comment dialect name port)
+(define (batch:write-header-comment parms name port)
+  (define dialect (batch:dialect parms))
+  (define operating-system
+    (or (batch:operating-system parms) *operating-system*))
   (batch:write-comment-line
    dialect
    (string-append (if (string? name)
@@ -228,6 +235,7 @@
 			((dos) "DOS")
 			((default-for-platform) "??")
 			(else (symbol->string dialect))))
+		  " (" (symbol->string operating-system) ")"
 		  " script created by SLIB/batch "
 		  (cond ((provided? 'bignum)
 			 (require 'posix-time)
@@ -235,9 +243,11 @@
 			   (substring ct 0 (+ -1 (string-length ct)))))
 			(else "")))
    port))
-
+;@
 (define (batch:call-with-output-script parms name proc)
   (define dialect (batch:dialect parms))
+  (define operating-system
+    (or (batch:operating-system parms) *operating-system*))
   (case dialect
     ((unix) ((cond ((and (string? name) (provided? 'system))
 		    (lambda (proc)
@@ -247,8 +257,11 @@
 		   ((output-port? name) (lambda (proc) (proc name)))
 		   (else (lambda (proc) (proc (current-output-port)))))
 	     (lambda (port)
-	       (write-line "#!/bin/sh" port)
-	       (batch:write-header-comment dialect name port)
+	       (write-line (if (eq? 'plan9 operating-system)
+			       "#! /bin/rc"
+			       "#! /bin/sh")
+			   port)
+	       (batch:write-header-comment parms name port)
 	       (proc port))))
 
     ((dos) ((cond ((string? name)
@@ -257,7 +270,7 @@
 		  ((output-port? name) (lambda (proc) (proc name)))
 		  (else (lambda (proc) (proc (current-output-port)))))
 	    (lambda (port)
-	      (batch:write-header-comment dialect name port)
+	      (batch:write-header-comment parms name port)
 	      (proc port))))
 
     ((vms) ((cond ((string? name)
@@ -266,20 +279,20 @@
 		  ((output-port? name) (lambda (proc) (proc name)))
 		  (else (lambda (proc) (proc (current-output-port)))))
 	    (lambda (port)
-	      (batch:write-header-comment dialect name port)
+	      (batch:write-header-comment parms name port)
 	      ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
 	      (proc port))))
 
-    ((amigados) ((cond ((and (string? name) (provided? 'system))
-		    (lambda (proc)
-		      (let ((ans (call-with-output-file name proc)))
-			(system (string-append "protect " name " rswd"))
-			ans)))
-		   ((output-port? name) (lambda (proc) (proc name)))
-		   (else (lambda (proc) (proc (current-output-port)))))
-	     (lambda (port)
-	       (batch:write-header-comment dialect name port)
-	       (proc port))))
+    ((amigaos) ((cond ((and (string? name) (provided? 'system))
+		       (lambda (proc)
+			 (let ((ans (call-with-output-file name proc)))
+			   (system (string-append "protect " name " rswd"))
+			   ans)))
+		      ((output-port? name) (lambda (proc) (proc name)))
+		      (else (lambda (proc) (proc (current-output-port)))))
+		(lambda (port)
+		  (batch:write-header-comment parms name port)
+		  (proc port))))
 
     ((system) ((cond ((and (string? name) (provided? 'system))
 		      (lambda (proc)
@@ -290,7 +303,7 @@
 		     ((output-port? name) (lambda (proc) (proc name)))
 		     (else (lambda (proc) (proc (current-output-port)))))
 	       (lambda (port)
-		 (batch:write-header-comment dialect name port)
+		 (batch:write-header-comment parms name port)
 		 (proc port))))
 
     ((*unknown*) ((cond ((and (string? name) (provided? 'system))
@@ -302,7 +315,7 @@
 			((output-port? name) (lambda (proc) (proc name)))
 			(else (lambda (proc) (proc (current-output-port)))))
 		  (lambda (port)
-		    (batch:write-header-comment dialect name port)
+		    (batch:write-header-comment parms name port)
 		    (proc port))))))
 
 ;;; This little ditty figures out how to use a Scheme extension or
@@ -321,8 +334,9 @@
      (else
       (let ((pl (make-parameter-list (map car parms))))
 	(adjoin-parameters!
-	 pl (cons 'batch-dialect (os->batch-dialect
-				  (parameter-list-ref parms 'platform))))
+	 pl (cons 'batch-dialect
+		  (os->batch-dialect
+		   (parameter-list-ref parms 'operating-system))))
 	(system
 	 (call-with-output-string
 	  (lambda (port)
@@ -332,7 +346,7 @@
 	       (define new-parms (copy-tree pl))
 	       (adjoin-parameters! new-parms (list 'batch-port batch-port))
 	       (apply BATCHER new-parms args)))))))))))
-
+;@
 (define (truncate-up-to str chars)
   (define (tut str)
     (do ((i (string-length str) (+ -1 i)))
@@ -341,15 +355,15 @@
   (cond ((char? chars) (set! chars (list chars)))
 	((string? chars) (set! chars (string->list chars))))
   (if (string? str) (tut str) (map tut 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)))
-
+;@
 (define (must-be-last lst lasts)
   (append (remove-if (lambda (i) (member i lasts)) lst)
 	  (remove-if-not (lambda (i) (member i lst)) lasts)))
-
+;@
 (define (string-join joiner . args)
   (if (null? args) ""
       (apply string-append
@@ -369,21 +383,15 @@
 				     obj "in" strings))))
 	   strings)))
 
-(define batch:platform (software-type))
-(cond ((and (eq? 'unix batch:platform) (provided? 'system))
-       (let ((file-name (tmpnam)))
-	 (system (string-append "uname > " file-name))
-	 (set! batch:platform (call-with-input-file file-name read))
-	 (delete-file file-name))))
-
 (define batch:database #f)
-(define os->batch-dialect #f)
 (define batch-dialect->line-length-limit #f)
+;@
+(define os->batch-dialect #f)
 
 (define (batch:line-length-limit parms)
   (let ((bl (parameter-list-ref parms 'batch-line-length-limit)))
     (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms)))))
-
+;@
 (define (batch:initialize! database)
   (set! batch:database database)
   (define-tables database
@@ -394,7 +402,7 @@
       ((unix 1023)
        (dos 127)
        (vms 1023)
-       (amigados 511)
+       (amigaos 511)
        (system 1023)
        (*unknown* -1)))
 
@@ -406,7 +414,7 @@
        (acorn		*unknown*)
        (aix		unix)
        (alliant		*unknown*)
-       (amiga		amigados)
+       (amiga		amigaos)
        (apollo		unix)
        (apple2		*unknown*)
        (arm		*unknown*)
@@ -415,6 +423,7 @@
        (celerity	*unknown*)
        (concurrent	*unknown*)
        (convex		*unknown*)
+       (darwin		unix)
        (encore		*unknown*)
        (harris		*unknown*)
        (hp-ux		unix)
@@ -432,6 +441,7 @@
        (novell		*unknown*)
        (os/2		dos)
        (osf1		unix)
+       (plan9		unix)
        (prime		*unknown*)
        (psion		*unknown*)
        (pyramid		*unknown*)
@@ -445,10 +455,29 @@
        (vms		vms)
        )))
 
-  ((database 'add-domain) '(operating-system operating-system #f symbol #f))
+  (define-domains database '(operating-system operating-system #f symbol #f))
   (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f)
 			   'get 'os-family))
   (set! batch-dialect->line-length-limit
 	(((batch:database 'open-table) 'batch-dialect #f)
 	 'get 'line-length-limit))
   )
+;@
+(define *operating-system*
+  (cond ((and (eq? 'unix (software-type)) (provided? 'system))
+	 (let* ((file-name (tmpnam))
+		(uname (and (system (string-append "uname > " file-name))
+			    (call-with-input-file file-name read)))
+		(ustr (and (symbol? uname) (symbol->string uname))))
+	   (delete-file file-name)
+	   (cond ((and ustr
+		       (> (string-length ustr) 5)
+		       (string-ci=? "cygwin" (substring ustr 0 6)))
+		  'gnu-win32)
+		 ((and ustr
+		       (> (string-length ustr) 4)
+		       (string-ci=? "mingw" (substring ustr 0 5)))
+		  'gnu-win32)
+		 (ustr uname)
+		 (else (software-type)))))
+	(else (software-type))))
-- 
cgit v1.2.3