Import Upstream version 2c7upstream/2c7

1 files changed, 99 insertions, 52 deletions

diff --git a/batch.scm b/batch.scm
index 7749451..d77519d 100644
--- a/batch.scm
+++ b/batch.scm
@@ -36,74 +36,77 @@
 (define (batch:port parms)
   (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)
+	   (slib:warn '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)))
 
-(define (batch:line-length-limit parms)
-  (let ((bl (parameter-list-ref parms 'batch-line-length-limit)))
-    (cond (bl (car bl))
-	  (else (case (batch:dialect parms)
-		  ((unix) 1023)
-		  ((dos) 127)
-		  ((vms) 1023)
-		  ((system) 1023)
-		  ((*unknown*) -1))))))
-
 (define (write-batch-line str line-limit port)
-  (cond ((and line-limit (>= (string-length str) line-limit)) #f)
+  (cond ((and line-limit (>= (string-length str) line-limit))
+	 (slib:warn 'write-batch-line 'too-long
+		    (string-length str) '> line-limit)
+	 #f)
 	(else (write-line str port) #t)))
 (define (batch-line parms str)
   (write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
 
 ;;; add a Scheme batch-dialect?
 
-(define (batch:apply-chop-to-fit proc . args)
-  (define args-but-last (butlast args 1))
+(define (batch:try-chopped-command parms . args)
+  (define args-but-last (batch:flatten (butlast args 1)))
+  (define line-limit (batch:line-length-limit parms))
   (let loop ((fodder (car (last-pair args))))
-    (let ((hlen (quotient (length fodder) 2)))
-      (cond ((apply proc (append args-but-last (list fodder))))
-	    ((not (positive? hlen))
-	     (slib:error 'batch:apply-chop-to-fit "can't split"
-			 (cons proc (append args-but-last (list fodder)))))
-	    (else (loop (nthcdr (+ 1 hlen) fodder))
-		  (loop (butlast fodder hlen)))))))
-
-(define (batch:try-system parms . strings)
-  (set! strings (batch:flatten strings))
+    (let ((str (batch:glued-line parms
+				 (batch:flatten
+				  (append args-but-last (list fodder))))))
+      (cond ((< (string-length str) line-limit)
+	     (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))))
+	     #f)
+	    (else (let ((hlen (quotient (length fodder) 2)))
+		    (and (loop (last fodder hlen))
+			 (loop (butlast fodder hlen)))))))))
+
+(define (batch:glued-line parms 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)
-     (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)
+    ((vms) (apply string-join " " "$" strings))
+    ((unix dos amigados system *unknown*) (apply string-join " " strings))
     (else #f)))
 
-(define (batch:system parms . strings)
-  (cond ((apply batch:try-system parms strings))
-	(else (slib:error 'batch:system 'failed strings))))
+(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))
+	   ((system)
+	    (let ((port (batch:port parms)))
+	      (write `(system ,line) port) (newline port)
+	      (and (provided? 'system) (system:success? (system line)))))
+	   ((*unknown*)
+	    (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:system parms (string-append "@" name) strings))
-    (else (batch:system parms name strings))))
+    ((vms) (batch:command parms (string-append "@" name) strings))
+    (else (batch:command 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))
+    ((amigados) (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)
@@ -139,6 +142,24 @@
 		(every (lambda (string) (batch-line parms string))
 		       lines)
 		(batch-line parms (string-append "$EOD"))))
+    ((amigados) (batch-line parms (string-append "delete force " file))
+	    (every
+	     (lambda (str)
+	       (letrec ((star-quote
+			 (lambda (str)
+			   (if (equal? "" str)
+			       str
+			       (let* ((ch (string-ref str 0))
+				      (s (if (char=? ch #\")
+					     (string #\* ch)
+					     (string ch))))
+				 (string-append
+				  s
+				  (star-quote
+				   (substring str 1 (string-length str)))))))))
+		 (batch-line parms (string-append "echo \"" (star-quote str)
+						  "\" >> " file))))
+	     lines))
     ((system) (write `(delete-file ,file) port) (newline port)
 	      (delete-file file)
 	      (require 'pretty-print)
@@ -174,6 +195,8 @@
 	   #t)
     ((vms) (batch-line parms (string-append "$DELETE " file))
 	   #t)
+    ((amigados) (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)
@@ -186,6 +209,9 @@
     ;;((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)))
     ((system) (batch:extender 'rename-file batch:rename-file))
     ((*unknown*) (write `(rename-file ,old-name ,new-name) port)
 		 (newline port)
@@ -244,6 +270,17 @@
 	      ;;(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))))
+
     ((system) ((cond ((and (string? name) (provided? 'system))
 		      (lambda (proc)
 			(let ((ans (call-with-output-file name
@@ -340,9 +377,12 @@
 	 (delete-file file-name))))
 
 (define batch:database #f)
-(define (os->batch-dialect os)
-  ((((batch:database 'open-table) 'operating-system #f)
-    'get 'os-family) os))
+(define os->batch-dialect #f)
+(define batch-dialect->line-length-limit #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)
@@ -350,12 +390,13 @@
 
     '(batch-dialect
       ((family atom))
-      ()
-      ((unix)
-       (dos)
-       (vms)
-       (system)
-       (*unknown*)))
+      ((line-length-limit number))
+      ((unix 1023)
+       (dos 127)
+       (vms 1023)
+       (amigados 511)
+       (system 1023)
+       (*unknown* -1)))
 
     '(operating-system
       ((name symbol))
@@ -365,7 +406,7 @@
        (acorn		*unknown*)
        (aix		unix)
        (alliant		*unknown*)
-       (amiga		*unknown*)
+       (amiga		amigados)
        (apollo		unix)
        (apple2		*unknown*)
        (arm		*unknown*)
@@ -378,6 +419,7 @@
        (harris		*unknown*)
        (hp-ux		unix)
        (hp48		*unknown*)
+       (irix		unix)
        (isis		*unknown*)
        (linux		unix)
        (mac		*unknown*)
@@ -404,4 +446,9 @@
        )))
 
   ((database 'add-domain) '(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))
   )