From 388d2f7b2b8da1ec8d34f69be4f1c91f371a9db8 Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Fri, 20 Feb 2004 15:03:45 +0000
Subject: [PATCH] Better checking for the inter-switch dependencies.

In particular, the code now complains if -e was used with an
end-option, switches to non-interactive-mode for -e and ensures that
-ds,-dm, and -de always get -s <script> as end-option.

In addition, better diagnostics is provided.
---
 scsh/top.scm | 175 ++++++++++++++++++++++++++++-----------------------
 1 file changed, 97 insertions(+), 78 deletions(-)

diff --git a/scsh/top.scm b/scsh/top.scm
index 4ae6c7b..42f3621 100644
--- a/scsh/top.scm
+++ b/scsh/top.scm
@@ -107,7 +107,7 @@
 (define (parse-scsh-args args)
   (let lp ((args (meta-arg-process-arglist args))
 	   (switches '())	; A list of handler thunks
-	   (top-entry #f)	; -t <entry>
+	   (top-entry #f)	; -e <entry>
 	   (need-script? #f))	; Found a -ds, -dm, or -de?
 ;    (display args    (current-output-port))
     (if (pair? args)
@@ -115,31 +115,47 @@
 	      (args (cdr args)))
 
 	  (cond ((string=? arg "-c")
-		 (if (or need-script? top-entry (not (pair? args)))
-		     (bad-arg)
-		     (values (reverse switches) 'c (car args)
-			     top-entry (cdr args))))
+                 (cond ((not (pair? args))
+                        (bad-arg "-c switch requires argument"))
+                       (top-entry
+                        (bad-arg "-c switch used with -e switch"))
+                       (need-script?
+                        (bad-arg "-ds, -dm, or -de switch requires -s <script>"))
+                       (else
+                        (values (reverse switches) 'c (car args)
+                                top-entry (cdr args)))))
 
 		((string=? arg "-s")
-		 (if (not (pair? args))
-		     (bad-arg "-s switch requires argument")
-		     (values (reverse switches) 's (car args)
-			     top-entry (cdr args))))
+		 (cond ((not (pair? args))
+                        (bad-arg "-s switch requires argument"))
+                       (top-entry
+                        (bad-arg "-s switch used with -e switch"))
+                       (need-script?
+                        (bad-arg "-ds, -dm, or -de switch requires -s <script>"))
+                       (else
+                        (values (reverse switches) 's (car args)
+                                top-entry (cdr args)))))
 
 		;; -sfd <num>
 		((string=? arg "-sfd")
-		 (if (not (pair? args))
-		     (bad-arg "-sfd switch requires argument")
-		     (let* ((fd (string->number (car args)))
-			    (p (fdes->inport fd)))
-		       (release-port-handle p)	; Unreveal the port.
-		       (values (reverse switches) 'sfd p
-			       top-entry (cdr args)))))
+                 (cond ((not (pair? args))
+                        (bad-arg "-sfd switch requires argument"))
+                       (top-entry
+                        (bad-arg "-sdf switch used with -e switch"))
+                       (else
+                        (let* ((fd (string->number (car args)))
+                               (p (fdes->inport fd)))
+                          (release-port-handle p)	; Unreveal the port.
+                          (values (reverse switches) 'sfd p
+                                  top-entry (cdr args))))))
 
 		((string=? arg "--")
-		 (if need-script?
-		     (bad-arg "-ds, -dm, or -de switch requires -s <script>")
-		     (values (reverse switches) #f #f top-entry args)))
+		 (cond (need-script?
+                        (bad-arg "-ds, -dm, or -de switch requires -s <script>"))
+                       (top-entry
+                        (bad-arg "-- switch used with -e switch"))
+                       (else
+                        (values (reverse switches) #f #f top-entry args))))
 
 		((or (string=? arg "-ds")
 		     (string=? arg "-dm")
@@ -186,8 +202,10 @@
 		     (string->symbol (car args)) need-script?))
 
 	    (else (bad-arg "Unknown switch" arg))))
-
-	(values (reverse switches) #f #f top-entry '()))))
+        (cond (need-script?
+               (bad-arg "-ds, -dm, or -de switch requires -s <script>"))
+              (else
+               (values (reverse switches) #f #f top-entry '()))))))
 
 ;;; 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
@@ -341,68 +359,69 @@
 (define (parse-switches-and-execute all-args context)
   (receive (switches term-switch term-val top-entry args)
       (parse-scsh-args (cdr all-args))
-    (with-handler 
-     (lambda (cond more)
-       (if (warning? cond)
-	   (more)
-	   (with-handler
-	    (lambda (c m)
-	      (scheme-exit-now 1))
-	    (lambda ()
-	      (call-exit-hooks-and-narrow (lambda () #t))
-	      (more)))))
-     (lambda ()
-       (with-scsh-initialized
-	(not term-switch) context args
-	(lambda ()
-	  ;; Have to do these before calling DO-SWITCHES, because actions
-	  ;; performed while processing the switches may use these guys.
-	  (set-command-line-args!
-	   (cons (if (eq? term-switch 's)
-                     term-val	; Script file.
-                     (if (eq? term-val 'sfd)
-			 "file-descriptor-script" ; -sfd <num>
-                         (car all-args)))
-		 args))
+    (let ((interactive? (not (or term-switch top-entry))))
+      (with-handler 
+       (lambda (cond more)
+         (if (warning? cond)
+             (more)
+             (with-handler
+              (lambda (c m)
+                (scheme-exit-now 1))
+              (lambda ()
+                (call-exit-hooks-and-narrow (lambda () #t))
+                (more)))))
+       (lambda ()
+         (with-scsh-initialized
+          interactive? context args
+          (lambda ()
+            ;; Have to do these before calling DO-SWITCHES, because actions
+            ;; performed while processing the switches may use these guys.
+            (set-command-line-args!
+             (cons (if (eq? term-switch 's)
+                       term-val         ; Script file.
+                       (if (eq? term-val 'sfd)
+                           "file-descriptor-script" ; -sfd <num>
+                           (car all-args)))
+                   args))
 	 
-	  (let* ((script-loaded?  (do-switches switches term-val)))
-	    (if (not script-loaded?) ; There wasn't a -ds, -dm, or -de,
-                (if (eq? term-switch 's) ; but there is a script,
-                    (load-quietly term-val; so load it now.
-                                  (interaction-environment))
-                    (if (eq? term-switch 'sfd)
-                        (load-port-quietly term-val (interaction-environment)))))
+            (let* ((script-loaded?  (do-switches switches term-val)))
+              (if (not script-loaded?) ; There wasn't a -ds, -dm, or -de,
+                  (if (eq? term-switch 's) ; but there is a script,
+                      (load-quietly term-val ; so load it now.
+                                    (interaction-environment))
+                      (if (eq? term-switch 'sfd)
+                          (load-port-quietly term-val (interaction-environment)))))
 	   
-	    (cond ((not term-switch)	; -- interactive
-		   (scsh-exit-now       ;; TODO: ,exit will bypass this
-		    (restart-command-processor 
-		     args 
-		     context 
-		     (lambda ()
-		       (display (string-append 
-				 "Welcome to scsh "
-				 scsh-version-string
-				 " (" scsh-release-name ")")
-				(current-output-port))
-		       (newline (current-output-port))
-		       (display "Type ,? for help."
-				(current-output-port))
-		       (newline (current-output-port))
-		       (in-package (user-environment) '())))))
+              (cond (interactive?
+                     (scsh-exit-now ;; TODO: ,exit will bypass this
+                      (restart-command-processor 
+                       args 
+                       context 
+                       (lambda ()
+                         (display (string-append 
+                                   "Welcome to scsh "
+                                   scsh-version-string
+                                   " (" scsh-release-name ")")
+                                  (current-output-port))
+                         (newline (current-output-port))
+                         (display "Type ,? for help."
+                                  (current-output-port))
+                         (newline (current-output-port))
+                         (in-package (user-environment) '())))))
 
-		  ((eq? term-switch 'c)
-		   (let ((result (eval (read-exactly-one-sexp-from-string term-val)
-				       (interaction-environment))))
-		     (scsh-exit-now 0)))
+                    ((eq? term-switch 'c)
+                     (let ((result (eval (read-exactly-one-sexp-from-string term-val)
+                                         (interaction-environment))))
+                       (scsh-exit-now 0)))
 		 
-		  (top-entry		; There was a -e <entry>.
-		   ((eval top-entry (interaction-environment))
-		    (command-line))
-		   (scsh-exit-now 0))
+                    (top-entry		; There was a -e <entry>.
+                     ((eval top-entry (interaction-environment))
+                      (command-line))
+                     (scsh-exit-now 0))
 		 
-		  ;; Otherwise, the script executed as it loaded,
-		  ;; so we're done.
-		  (else (scsh-exit-now 0))))))))))
+                    ;; Otherwise, the script executed as it loaded,
+                    ;; so we're done.
+                    (else (scsh-exit-now 0)))))))))))
 
 
 (define (read-exactly-one-sexp-from-string s)