From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 27 Dec 2002 03:48:38 +0000 (+0000)
Subject: Change option processing to accept "--" option syntax, as required by
X-Git-Tag: 20090517-FFI~2098
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb04bc8f454606f44e1f18c821843e3041194e87;p=mit-scheme.git

Change option processing to accept "--" option syntax, as required by
GNU coding standards.  Older "-" syntax is preserved for
compatibility.
---

diff --git a/v7/src/6001/edextra.scm b/v7/src/6001/edextra.scm
index 7b89ceabd..298113efd 100644
--- a/v7/src/6001/edextra.scm
+++ b/v7/src/6001/edextra.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: edextra.scm,v 1.34 2002/11/20 19:45:46 cph Exp $
+$Id: edextra.scm,v 1.35 2002/12/27 03:48:38 cph Exp $
 
-Copyright (c) 1992-2001 Massachusetts Institute of Technology
+Copyright (c) 1992-2002 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -32,7 +32,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define pset-list-file)
 (define command-line-student-directory #f)
 
-(set-command-line-parser! "-student" 
+(set-command-line-parser! "student"
   (lambda (command-line)
     (let ((name (cadr command-line)))
       (if (file-directory? name)
diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm
index b428b4f2e..c2f34ba2b 100644
--- a/v7/src/edwin/editor.scm
+++ b/v7/src/edwin/editor.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: editor.scm,v 1.254 2002/11/20 19:45:59 cph Exp $
+;;; $Id: editor.scm,v 1.255 2002/12/27 03:48:01 cph Exp $
 ;;;
-;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
 ;;;
 ;;; This file is part of MIT Scheme.
 ;;;
@@ -85,7 +85,7 @@
 	      message))))))))
 
 (define (edwin . args) (apply edit args))
-(simple-command-line-parser "-edit" edit)
+(simple-command-line-parser "edit" edit)
 
 (define edwin-editor #f)
 (define editor-abort)
diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index e35544a3a..bb89c9a98 100644
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.63 2002/12/27 03:18:40 cph Exp $
+$Id: load.scm,v 14.64 2002/12/27 03:47:36 cph Exp $
 
 Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
@@ -26,7 +26,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 ;;; package: (runtime load)
 
 (declare (usual-integrations))
-
+
 (define (initialize-package!)
   (set! *purification-root-marker* (intern "#[PURIFICATION-ROOT]"))
   (set! load-noisily? #f)
@@ -394,40 +394,38 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (default/process-command-line unused-command-line)
   (let ((after-parsing-actions '()))
 
-    (define (process-keyword command-line unused-options)
-      (if (pair? command-line)
-	  (let* ((keyword (car command-line))
-		 (place (assoc keyword *command-line-parsers*)))
-	    (cond (place
-		   (call-with-values
-		       (lambda () ((cdr place) command-line))
-		     (lambda (next tail-action)
-		       (if tail-action
-			   (set! after-parsing-actions
-				 (cons tail-action after-parsing-actions)))
-		       (process-keyword next unused-options))))
-		  ((zero? (string-length keyword))
-		   (process-keyword (cdr command-line)
-				    unused-options))
-		  (else
-		   (if (or (not (char=? (string-ref keyword 0) #\-))
-			   (= (string-length keyword) 1))
-		       (warn "process-command-line: Invalid keyword" keyword))
-		   (find-next-keyword (cdr command-line)
-				      (cons (car command-line)
-					    unused-options)))))
-	  (let ((unused (reverse unused-options)))
-	    (if (pair? unused)
-		(warn "Unhandled command line options:" unused))
-	    unused)))
-
-    (define (find-next-keyword command-line unused-options)
+    (define (process-keyword command-line unused)
       (if (pair? command-line)
-	  (if (option-keyword? (car command-line))
-	      (process-keyword command-line unused-options)
-	      (find-next-keyword (cdr command-line)
-				 (cons keyword unused-options)))
-	  (process-keyword '() unused-options)))
+	  (let ((keyword (car command-line)))
+	    (if (option-keyword? keyword)
+		(let ((parser (find-keyword-parser keyword)))
+		  (if parser
+		      (call-with-values (lambda () (parser command-line))
+			(lambda (next tail-action)
+			  (if tail-action
+			      (set! after-parsing-actions
+				    (cons tail-action after-parsing-actions)))
+			  (process-keyword next unused)))
+		      (find-next-keyword command-line unused)))
+		(begin
+		  (warn "Invalid keyword:" keyword)
+		  (find-next-keyword command-line unused))))
+	  (done unused)))
+
+    (define (find-next-keyword command-line unused)
+      (let ((unused (cons (car command-line) unused))
+	    (command-line (cdr command-line)))
+	(if (pair? command-line)
+	    (if (option-keyword? (car command-line))
+		(process-keyword command-line unused)
+		(find-next-keyword command-line unused))
+	    (done unused))))
+
+    (define (done unused)
+      (let ((unused (reverse! unused)))
+	(if (pair? unused)
+	    (warn "Unhandled command line options:" unused))
+	unused))
 
     (if unused-command-line
 	(begin
@@ -442,9 +440,17 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  (set! *unused-command-line* #f)
 	  (load-init-file)))))
 
+(define (find-keyword-parser keyword)
+  (let ((entry (assoc (strip-leading-hyphens keyword) *command-line-parsers*)))
+    (and entry
+	 (cdr entry))))
+
 (define (option-keyword? argument)
   (and (fix:> (string-length argument) 1)
-       (char=? #\- (string-ref argument 0))))
+       (char=? #\- (string-ref argument 0))
+       (or (not (char=? #\- (string-ref argument 1)))
+	   (and (fix:> (string-length argument) 2)
+		(not (char=? #\- (string-ref argument 2)))))))
 
 (define (load-init-file)
   (let ((pathname (init-file-pathname)))
@@ -472,16 +478,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define (set-command-line-parser! keyword proc)
   (guarantee-string keyword 'SET-COMMAND-LINE-PARSER!)
-  (let ((keyword
-	 (let ((end (string-length keyword)))
-	   (let loop ((start 0))
-	     (cond ((and (fix:< start end)
-			 (char=? #\- (string-ref keyword start)))
-		    (loop (fix:+ start 1)))
-		   ((fix:= start 0)
-		    keyword)
-		   (else
-		    (substring keyword start end)))))))
+  (let ((keyword (strip-leading-hyphens keyword)))
     (if (string-null? keyword)
 	(error:bad-range-argument keyword 'SET-COMMAND-LINE-PARSER!))
     (let ((place (assoc keyword *command-line-parsers*)))
@@ -493,6 +490,17 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 			*command-line-parsers*))
 	    unspecific)))))
 
+(define (strip-leading-hyphens keyword)
+  (let ((end (string-length keyword)))
+    (let loop ((start 0))
+      (cond ((and (fix:< start end)
+		  (char=? #\- (string-ref keyword start)))
+	     (loop (fix:+ start 1)))
+	    ((fix:= start 0)
+	     keyword)
+	    (else
+	     (substring keyword start end))))))
+
 (define (simple-command-line-parser keyword thunk)
   (set-command-line-parser! keyword
     (lambda (command-line)