From 1251cf7e62930d4559f2b729eaef4e72042845e5 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 12 Aug 1992 01:09:14 +0000 Subject: [PATCH] Make command-line parser extensible. --- v7/src/runtime/load.scm | 143 +++++++++++++++++++++++-------------- v7/src/runtime/runtime.pkg | 7 +- v7/src/runtime/version.scm | 4 +- v8/src/runtime/load.scm | 143 +++++++++++++++++++++++-------------- v8/src/runtime/runtime.pkg | 7 +- 5 files changed, 188 insertions(+), 116 deletions(-) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 897f593d4..4dccff278 100644 --- 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)))) + +(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)))))) ;;;; Loader for packed binaries diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 5bae834cd..540078353 100644 --- 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 9f58553a3..b781a66f1 100644 --- 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 afef19401..41ec1e5c5 100644 --- 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)))) + +(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)))))) ;;;; Loader for packed binaries diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index c366aaa3e..6e0b3f30a 100644 --- 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) -- 2.25.1