module/slib/comparse.scm

   1 ;;; "comparse.scm" Break command line into arguments.
   2 ;Copyright (C) 1995, 1997 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 ;;;; This is a simple command-line reader.  It could be made fancier
  21 ;;; to handle lots of `shell' syntaxes.
  22
  23 ;;; Albert L. Ting points out that a similar process can be used for
  24 ;;; reading files of options -- therefore READ-OPTIONS-FILE.
  25
  26 (require 'string-port)
  27 (define (read-command-from-port port nl-term?)
  28   (define argv '())
  29   (define obj "")
  30   (define chars '())
  31   (define readc (lambda () (read-char port)))
  32   (define peekc (lambda () (peek-char port)))
  33   (define s-expression
  34     (lambda ()
  35       (splice-arg (call-with-output-string
  36                    (lambda (p) (display (slib:eval (read port)) p))))))
  37   (define backslash
  38     (lambda (goto)
  39       (readc)
  40       (let ((c (readc)))
  41         (cond ((eqv? #\newline c) (goto (peekc)))
  42               ((and (char-whitespace? c) (eqv? #\newline (peekc))
  43                     (eqv? 13 (char->integer c)))
  44                (readc) (goto (peekc)))
  45               (else (set! chars (cons c chars)) (build-token (peekc)))))))
  46   (define loop
  47     (lambda (c)
  48       (case c
  49         ((#\\) (backslash loop))
  50         ((#\") (splice-arg (read port)))
  51         ((#\( #\') (s-expression))
  52         ((#\#) (do ((c (readc) (readc)))
  53                    ((or (eof-object? c) (eqv? #\newline c))
  54                     (if nl-term? c (loop (peekc))))))
  55         ((#\;) (readc))
  56         ((#\newline) (readc) (and (not nl-term?) (loop (peekc))))
  57         (else (cond ((eof-object? c) c)
  58                     ((char-whitespace? c) (readc) (loop (peekc)))
  59                     (else (build-token c)))))))
  60   (define splice-arg
  61     (lambda (arg)
  62       (set! obj (string-append obj (list->string (reverse chars)) arg))
  63       (set! chars '())
  64       (build-token (peekc))))
  65   (define buildit
  66     (lambda ()
  67       (readc)
  68       (set! argv (cons (string-append obj (list->string (reverse chars)))
  69                        argv))))
  70   (define build-token
  71     (lambda (c)
  72       (case c
  73         ((#\") (splice-arg (read port)))
  74         ((#\() (s-expression))
  75         ((#\\) (backslash build-token))
  76         ((#\;) (buildit))
  77         (else (cond ((or (eof-object? c) (char-whitespace? c))
  78                      (buildit)
  79                      (cond ((not (and nl-term? (eqv? c #\newline)))
  80                             (set! obj "")
  81                             (set! chars '())
  82                             (loop (peekc)))))
  83                     (else (set! chars (cons (readc) chars))
  84                           (build-token (peekc))))))))
  85   (let ((c (loop (peekc))))
  86     (cond ((and (null? argv) (eof-object? c)) c)
  87           (else (reverse argv)))))
  88
  89 (define (read-command . port)
  90   (read-command-from-port (cond ((null? port) (current-input-port))
  91                                 ((= 1 (length port)) (car port))
  92                                 (else
  93                                  (slib:error 'read-command
  94                                              "Wrong Number of ARGs:" port)))
  95                           #t))
  96
  97 (define (read-options-file filename)
  98   (call-with-input-file filename
  99     (lambda (port) (read-command-from-port port #f))))