Make command-line parser extensible.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 897f593d412ba2c79c7fc7327a7e27bc173ac40a..4dccff27879b2447e2cd228c2ad7e433a73a5342 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.37 1992/05/30 16:47:40 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.38 1992/08/12 01:08:14 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -44,6 +44,7 @@ MIT in each case. |#
   (set! load/default-types '("com" "bin" "scm"))
   (set! load/default-find-pathname-with-type search-types-in-order)
   (set! fasload/default-types '("com" "bin"))
+  (initialize-command-line-parsers)
   (set! hook/process-command-line default/process-command-line)
   (add-event-receiver! event:after-restart process-command-line))
 
@@ -285,60 +286,94 @@ MIT in each case. |#
   (hook/process-command-line ((ucode-primitive get-unused-command-line 0))))
 
 (define hook/process-command-line)
+
+(define *command-line-parsers* '())
+
+(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))
+  (let ((place (assoc keyword *command-line-parsers*)))
+    (if place
+       (set-cdr! place proc)
+       (begin
+         (set! *command-line-parsers*
+               (cons (cons keyword proc)
+                     *command-line-parsers*))
+         unspecific))))
+
+(define *load-init-file?*)
+
 (define (default/process-command-line unused-command-line)
-  (if unused-command-line
-      (letrec ((unused-command-line-length (vector-length unused-command-line))
-              (unused-for-each
-               (lambda (proc start end)
-                 (if (< start end)
-                     (begin (proc (vector-ref unused-command-line start))
-                            (unused-for-each proc (1+ start) end)))))
-              (find-first-dash
-               (lambda (index)
-                 (let loop ((index index))
-                   (if (= index unused-command-line-length)
-                       unused-command-line-length
-                       (let ((first (vector-ref unused-command-line index)))
-                         (cond ((zero? (string-length first))
-                                (loop (1+ index)))
-                               ((char=? (string-ref first 0) #\-)
-                                index)
-                               (else (loop (1+ index))))))))))
-       (let find-no-init-file-option ((index 0))
-         (if (= index unused-command-line-length)
-             (load-init-file)
-             (or (string=?
-                  "-no-init-file"
-                  (string-downcase (vector-ref unused-command-line index)))
-                 (find-no-init-file-option (1+ index)))))
-       (let process-next-option ((index 0)
-                                 (unhandled-options '()))
-         (if (= index unused-command-line-length)
-             (if (not (null? unhandled-options))
-                 (warn "Unhandled command line options:"
-                       (reverse unhandled-options)))
-             (let ((option
-                    (string-downcase (vector-ref unused-command-line index))))
-               (cond ((string=? "-no-init-file" option)
-                      (process-next-option (1+ index) unhandled-options))
-                     ((string=? "-eval" option)
-                      (let ((next-option (find-first-dash (1+ index))))
-                        (unused-for-each
-                         (lambda (string)
-                           (eval (with-input-from-string string read)
-                                 user-initial-environment))
-                         (1+ index)
-                         next-option)
-                        (process-next-option next-option unhandled-options)))
-                     ((string=? "-load" option)
-                      (let ((next-option (find-first-dash (1+ index))))
-                        (unused-for-each load (1+ index) next-option)
-                        (process-next-option next-option unhandled-options)))
-                     (else (process-next-option
-                            (1+ index)
-                            (cons (vector-ref unused-command-line index)
-                                  unhandled-options))))))))
-      (load-init-file)))
+  (define (process-keyword command-line unused-options)
+    (cond ((not (null? command-line))
+          (let* ((keyword (car command-line))
+                 (place (assoc keyword *command-line-parsers*)))
+            (cond (place
+                   (process-keyword ((cdr place) command-line)
+                                    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))))))
+         ((not (null? unused-options))
+          (warn "Unhandled command line options:"
+                (reverse unused-options)))))
+
+  (define (find-next-keyword command-line unused-options)
+    (if (null? command-line)
+       (process-keyword '() unused-options)
+       (let ((keyword (car command-line)))
+         (if (or (< (string-length keyword) 2)
+                 (not (char=? (string-ref keyword 0) #\-)))
+             (find-next-keyword (cdr command-line)
+                                (cons keyword unused-options))
+             (process-keyword command-line unused-options)))))
+
+  (fluid-let ((*load-init-file?* true))
+    (if unused-command-line
+       (process-keyword (vector->list unused-command-line) '()))
+    (if *load-init-file?*
+       (load-init-file))))
+\f
+(define (for-each-non-keyword command-line processor)
+  (let loop ((command-line command-line))
+    (if (null? command-line)
+       '()
+       (let ((next (car command-line)))
+         (if (and (> (string-length next) 0)
+                  (char=? (string-ref next 0) #\-))
+             command-line
+             (begin
+               (processor next)
+               (loop (cdr command-line))))))))
+
+(define (initialize-command-line-parsers)
+  (set-command-line-parser!
+   "-no-init-file"
+   (lambda (command-line)
+     (set! *load-init-file?* false)
+     (cdr command-line)))
+
+  (set-command-line-parser!
+   "-load"
+   (lambda (command-line)
+     (for-each-non-keyword (cdr command-line) load)))
+
+  (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))))))
 \f
 ;;;; Loader for packed binaries
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5bae834cd7e2429a7390c8544de8996c202a6589..5400783535c5535460b721f1246e635525b39742 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.157 1992/07/24 22:19:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.158 1992/08/12 01:08:57 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -1197,7 +1197,8 @@ MIT in each case. |#
          load/default-find-pathname-with-type
          load/push-hook!
          load/suppress-loading-message?
-         read-file)
+         read-file
+         set-command-line-parser!)
   (initialization (initialize-package!)))
 
 (define-package (runtime macros)

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 9f58553a3b2d4c7f5be7508aa07dcbd3430df407..b781a66f1b42a68c73025c179cb2cc50aa98ec1f 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.154 1992/07/20 20:12:04 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.155 1992/08/12 01:09:14 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 154))
+  (add-identification! "Runtime" 14 155))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index afef19401082caff7afb27bfbfb9109d5ee722d2..41ec1e5c540f3599d8239a8aaf9dff306ea9f617 100644 (file)
--- a/v8/src/runtime/load.scm
+++ b/v8/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.37 1992/05/30 16:47:40 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.38 1992/08/12 01:08:14 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -44,6 +44,7 @@ MIT in each case. |#
   (set! load/default-types '("com" "bin" "scm"))
   (set! load/default-find-pathname-with-type search-types-in-order)
   (set! fasload/default-types '("com" "bin"))
+  (initialize-command-line-parsers)
   (set! hook/process-command-line default/process-command-line)
   (add-event-receiver! event:after-restart process-command-line))
 
@@ -285,60 +286,94 @@ MIT in each case. |#
   (hook/process-command-line ((ucode-primitive get-unused-command-line 0))))
 
 (define hook/process-command-line)
+
+(define *command-line-parsers* '())
+
+(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))
+  (let ((place (assoc keyword *command-line-parsers*)))
+    (if place
+       (set-cdr! place proc)
+       (begin
+         (set! *command-line-parsers*
+               (cons (cons keyword proc)
+                     *command-line-parsers*))
+         unspecific))))
+
+(define *load-init-file?*)
+
 (define (default/process-command-line unused-command-line)
-  (if unused-command-line
-      (letrec ((unused-command-line-length (vector-length unused-command-line))
-              (unused-for-each
-               (lambda (proc start end)
-                 (if (< start end)
-                     (begin (proc (vector-ref unused-command-line start))
-                            (unused-for-each proc (1+ start) end)))))
-              (find-first-dash
-               (lambda (index)
-                 (let loop ((index index))
-                   (if (= index unused-command-line-length)
-                       unused-command-line-length
-                       (let ((first (vector-ref unused-command-line index)))
-                         (cond ((zero? (string-length first))
-                                (loop (1+ index)))
-                               ((char=? (string-ref first 0) #\-)
-                                index)
-                               (else (loop (1+ index))))))))))
-       (let find-no-init-file-option ((index 0))
-         (if (= index unused-command-line-length)
-             (load-init-file)
-             (or (string=?
-                  "-no-init-file"
-                  (string-downcase (vector-ref unused-command-line index)))
-                 (find-no-init-file-option (1+ index)))))
-       (let process-next-option ((index 0)
-                                 (unhandled-options '()))
-         (if (= index unused-command-line-length)
-             (if (not (null? unhandled-options))
-                 (warn "Unhandled command line options:"
-                       (reverse unhandled-options)))
-             (let ((option
-                    (string-downcase (vector-ref unused-command-line index))))
-               (cond ((string=? "-no-init-file" option)
-                      (process-next-option (1+ index) unhandled-options))
-                     ((string=? "-eval" option)
-                      (let ((next-option (find-first-dash (1+ index))))
-                        (unused-for-each
-                         (lambda (string)
-                           (eval (with-input-from-string string read)
-                                 user-initial-environment))
-                         (1+ index)
-                         next-option)
-                        (process-next-option next-option unhandled-options)))
-                     ((string=? "-load" option)
-                      (let ((next-option (find-first-dash (1+ index))))
-                        (unused-for-each load (1+ index) next-option)
-                        (process-next-option next-option unhandled-options)))
-                     (else (process-next-option
-                            (1+ index)
-                            (cons (vector-ref unused-command-line index)
-                                  unhandled-options))))))))
-      (load-init-file)))
+  (define (process-keyword command-line unused-options)
+    (cond ((not (null? command-line))
+          (let* ((keyword (car command-line))
+                 (place (assoc keyword *command-line-parsers*)))
+            (cond (place
+                   (process-keyword ((cdr place) command-line)
+                                    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))))))
+         ((not (null? unused-options))
+          (warn "Unhandled command line options:"
+                (reverse unused-options)))))
+
+  (define (find-next-keyword command-line unused-options)
+    (if (null? command-line)
+       (process-keyword '() unused-options)
+       (let ((keyword (car command-line)))
+         (if (or (< (string-length keyword) 2)
+                 (not (char=? (string-ref keyword 0) #\-)))
+             (find-next-keyword (cdr command-line)
+                                (cons keyword unused-options))
+             (process-keyword command-line unused-options)))))
+
+  (fluid-let ((*load-init-file?* true))
+    (if unused-command-line
+       (process-keyword (vector->list unused-command-line) '()))
+    (if *load-init-file?*
+       (load-init-file))))
+\f
+(define (for-each-non-keyword command-line processor)
+  (let loop ((command-line command-line))
+    (if (null? command-line)
+       '()
+       (let ((next (car command-line)))
+         (if (and (> (string-length next) 0)
+                  (char=? (string-ref next 0) #\-))
+             command-line
+             (begin
+               (processor next)
+               (loop (cdr command-line))))))))
+
+(define (initialize-command-line-parsers)
+  (set-command-line-parser!
+   "-no-init-file"
+   (lambda (command-line)
+     (set! *load-init-file?* false)
+     (cdr command-line)))
+
+  (set-command-line-parser!
+   "-load"
+   (lambda (command-line)
+     (for-each-non-keyword (cdr command-line) load)))
+
+  (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))))))
 \f
 ;;;; Loader for packed binaries
 

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index c366aaa3e23a2cf2d757ce533d3b1de2ba29d551..6e0b3f30a8f66a7572e0bb6796b767a0daee2389 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.157 1992/07/24 22:19:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.158 1992/08/12 01:08:57 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -1197,7 +1197,8 @@ MIT in each case. |#
          load/default-find-pathname-with-type
          load/push-hook!
          load/suppress-loading-message?
-         read-file)
+         read-file
+         set-command-line-parser!)
   (initialization (initialize-package!)))
 
 (define-package (runtime macros)