From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 11 May 1999 20:30:21 +0000 (+0000)
Subject: Implement new procedures SIMPLE-COMMAND-LINE-PARSER and
X-Git-Tag: 20090517-FFI~4541
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=99fd5981f6df7941716b2bb5b03a286aa235f8e4;p=mit-scheme.git

Implement new procedures SIMPLE-COMMAND-LINE-PARSER and
ARGUMENT-COMMAND-LINE-PARSER and export them to global.
---

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 2a4bb16b1..38accb491 100644
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.51 1999/01/02 06:06:43 cph Exp $
+$Id: load.scm,v 14.52 1999/05/11 20:30:16 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -87,14 +87,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		      (find-pathname filename load/default-types))
 		  (lambda (pathname loader)
 		    (fluid-let ((load/current-pathname pathname))
-		      (let ((value
-			     (loader pathname
-				     environment
-				     syntax-table
-				     purify?
-				     load-noisily?)))
-			(cond (last-file? value)
-			      (load-noisily? (write-line value))))))))))
+		      (let ((load-it
+			     (lambda ()
+			       (loader pathname
+				       environment
+				       syntax-table
+				       purify?
+				       load-noisily?))))
+			(cond (last-file? (load-it))
+			      (load-noisily? (write-line (load-it)))
+			      (else (load-it) unspecific)))))))))
 	 (if (pair? filename/s)
 	     (let loop ((filenames filename/s))
 	       (if (null? (cdr filenames))
@@ -437,10 +439,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 ;; delayed actions.
 
 (define (set-command-line-parser! keyword proc)
-  (if (or (not (string? keyword))
-	  (< (string-length keyword) 2)
-	  (not (char=? (string-ref keyword 0) #\-)))
-      (error "set-command-line-parser!: Invalid keyword" keyword))
+  (if (not (and (string? keyword)
+		(>= (string-length keyword) 2)
+		(char=? #\- (string-ref keyword 0))))
+      (error:wrong-type-argument keyword
+				 "command-line option keyword"
+				 'SET-COMMAND-LINE-PARSER!))
   (let ((place (assoc keyword *command-line-parsers*)))
     (if place
 	(set-cdr! place proc)
@@ -450,54 +454,65 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		      *command-line-parsers*))
 	  unspecific))))
 
-(define (simple-option-parser keyword thunk)
+(define (simple-command-line-parser keyword thunk)
   (set-command-line-parser! keyword
 			    (lambda (command-line)
-			      (thunk)
-			      (values (cdr command-line) #f))))
+			      (values (cdr command-line) thunk))))
 
-(define (for-each-non-keyword command-line processor)
-  (define (end command-line accum)
-    (if (null? accum)
-	(values command-line #f)
-	(let ((objects (reverse accum)))
-	  (values command-line
-		  (lambda ()
-		    (for-each processor objects))))))
-  
-  (let loop ((command-line command-line)
-	     (accum '()))
-    (if (null? command-line)
-	(end '() accum)
-	(let ((next (car command-line)))
-	  (if (and (> (string-length next) 0)
-		   (char=? (string-ref next 0) #\-))
-	      (end command-line accum)
-	      (loop (cdr command-line)
-		    (cons next accum)))))))
-
-(define (initialize-command-line-parsers)
-  (simple-option-parser "-no-init-file"
-			(lambda () (set! *load-init-file?* #f)))
-
-  (set! generate-suspend-file? #f)
-  (simple-option-parser "-suspend-file"
-			(lambda () (set! generate-suspend-file? #t)))
-  (simple-option-parser "-no-suspend-file"
-			(lambda () (set! generate-suspend-file? #f)))
+;; Upwards compatibility.
+(define simple-option-parser simple-command-line-parser)
 
+(define (argument-command-line-parser keyword multiple? procedure)
   (set-command-line-parser!
-   "-load"
-   (lambda (command-line)
-     (for-each-non-keyword (cdr command-line) load)))
+   keyword
+   (if multiple?
+       (lambda (command-line)
+	 (for-each-non-keyword (cdr command-line) procedure))
+       (lambda (command-line)
+	 (if (null? (cdr command-line))
+	     (values '()
+		     (lambda ()
+		       (warn "Missing argument to command-line option:"
+			     keyword)))
+	     (values (cddr command-line)
+		     (lambda () (procedure (cadr command-line)))))))))
 
-  (set-command-line-parser!
-   "-eval"
-   (lambda (command-line)
-     (for-each-non-keyword (cdr command-line)
-			   (lambda (arg)
-			     (eval (with-input-from-string arg read)
-				   user-initial-environment))))))
+(define (for-each-non-keyword command-line processor)
+  (let ((end
+	 (lambda (command-line accum)
+	   (if (null? accum)
+	       (values command-line #f)
+	       (let ((objects (reverse accum)))
+		 (values command-line
+			 (lambda () (for-each processor objects))))))))
+    (let loop ((command-line command-line) (accum '()))
+      (if (null? command-line)
+	  (end '() accum)
+	  (let ((next (car command-line)))
+	    (if (and (> (string-length next) 0)
+		     (char=? #\- (string-ref next 0)))
+		(end command-line accum)
+		(loop (cdr command-line) (cons next accum))))))))
+
+(define (initialize-command-line-parsers)
+  (simple-command-line-parser "-no-init-file"
+			      (lambda ()
+				(set! *load-init-file?* #f)
+				unspecific))
+  (set! generate-suspend-file? #f)
+  (simple-command-line-parser "-suspend-file"
+			      (lambda ()
+				(set! generate-suspend-file? #t)
+				unspecific))
+  (simple-command-line-parser "-no-suspend-file"
+			      (lambda ()
+				(set! generate-suspend-file? #f)
+				unspecific))
+  (argument-command-line-parser "-load" #t load)
+  (argument-command-line-parser "-eval" #t
+				(lambda (arg)
+				  (eval (with-input-from-string arg read)
+					user-initial-environment))))
 
 ;;;; Loader for packed binaries
 
@@ -615,7 +630,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (with-binary-input-file file action)
   (with-binary-file-channel file action
     open-binary-input-file
-    input-port/channel
+    port/input-channel
     'with-binary-input-file))
 
 (define (with-binary-file-channel file action open extract-channel name)
diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index c418fdded..f36c53a0e 100644
--- a/v8/src/runtime/load.scm
+++ b/v8/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.54 1999/02/18 04:14:03 cph Exp $
+$Id: load.scm,v 14.55 1999/05/11 20:30:21 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -446,10 +446,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 ;; delayed actions.
 
 (define (set-command-line-parser! keyword proc)
-  (if (or (not (string? keyword))
-	  (< (string-length keyword) 2)
-	  (not (char=? (string-ref keyword 0) #\-)))
-      (error "set-command-line-parser!: Invalid keyword" keyword))
+  (if (not (and (string? keyword)
+		(>= (string-length keyword) 2)
+		(char=? #\- (string-ref keyword 0))))
+      (error:wrong-type-argument keyword
+				 "command-line option keyword"
+				 'SET-COMMAND-LINE-PARSER!))
   (let ((place (assoc keyword *command-line-parsers*)))
     (if place
 	(set-cdr! place proc)
@@ -459,54 +461,65 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		      *command-line-parsers*))
 	  unspecific))))
 
-(define (simple-option-parser keyword thunk)
+(define (simple-command-line-parser keyword thunk)
   (set-command-line-parser! keyword
 			    (lambda (command-line)
-			      (thunk)
-			      (values (cdr command-line) #f))))
+			      (values (cdr command-line) thunk))))
 
-(define (for-each-non-keyword command-line processor)
-  (define (end command-line accum)
-    (if (null? accum)
-	(values command-line #f)
-	(let ((objects (reverse accum)))
-	  (values command-line
-		  (lambda ()
-		    (for-each processor objects))))))
-  
-  (let loop ((command-line command-line)
-	     (accum '()))
-    (if (null? command-line)
-	(end '() accum)
-	(let ((next (car command-line)))
-	  (if (and (> (string-length next) 0)
-		   (char=? (string-ref next 0) #\-))
-	      (end command-line accum)
-	      (loop (cdr command-line)
-		    (cons next accum)))))))
-
-(define (initialize-command-line-parsers)
-  (simple-option-parser "-no-init-file"
-			(lambda () (set! *load-init-file?* #f)))
-
-  (set! generate-suspend-file? #f)
-  (simple-option-parser "-suspend-file"
-			(lambda () (set! generate-suspend-file? #t)))
-  (simple-option-parser "-no-suspend-file"
-			(lambda () (set! generate-suspend-file? #f)))
+;; Upwards compatibility.
+(define simple-option-parser simple-command-line-parser)
 
+(define (argument-command-line-parser keyword multiple? procedure)
   (set-command-line-parser!
-   "-load"
-   (lambda (command-line)
-     (for-each-non-keyword (cdr command-line) load)))
+   keyword
+   (if multiple?
+       (lambda (command-line)
+	 (for-each-non-keyword (cdr command-line) procedure))
+       (lambda (command-line)
+	 (if (null? (cdr command-line))
+	     (values '()
+		     (lambda ()
+		       (warn "Missing argument to command-line option:"
+			     keyword)))
+	     (values (cddr command-line)
+		     (lambda () (procedure (cadr command-line)))))))))
 
-  (set-command-line-parser!
-   "-eval"
-   (lambda (command-line)
-     (for-each-non-keyword (cdr command-line)
-			   (lambda (arg)
-			     (eval (with-input-from-string arg read)
-				   user-initial-environment))))))
+(define (for-each-non-keyword command-line processor)
+  (let ((end
+	 (lambda (command-line accum)
+	   (if (null? accum)
+	       (values command-line #f)
+	       (let ((objects (reverse accum)))
+		 (values command-line
+			 (lambda () (for-each processor objects))))))))
+    (let loop ((command-line command-line) (accum '()))
+      (if (null? command-line)
+	  (end '() accum)
+	  (let ((next (car command-line)))
+	    (if (and (> (string-length next) 0)
+		     (char=? #\- (string-ref next 0)))
+		(end command-line accum)
+		(loop (cdr command-line) (cons next accum))))))))
+
+(define (initialize-command-line-parsers)
+  (simple-command-line-parser "-no-init-file"
+			      (lambda ()
+				(set! *load-init-file?* #f)
+				unspecific))
+  (set! generate-suspend-file? #f)
+  (simple-command-line-parser "-suspend-file"
+			      (lambda ()
+				(set! generate-suspend-file? #t)
+				unspecific))
+  (simple-command-line-parser "-no-suspend-file"
+			      (lambda ()
+				(set! generate-suspend-file? #f)
+				unspecific))
+  (argument-command-line-parser "-load" #t load)
+  (argument-command-line-parser "-eval" #t
+				(lambda (arg)
+				  (eval (with-input-from-string arg read)
+					user-initial-environment))))
 
 ;;;; Loader for packed binaries