(define (error msg . args)
      (scm-error 'misc-error "args-fold" msg args #f))

    (define (mutate-seeds! procedure . params)
      (set! seeds (call-with-values
		      (lambda ()
			(apply procedure (append params seeds)))
		    list)))

    ;; Clean up the rest of ARGS, assuming they're all operands.
    (define (rest-operands)
      (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
		args)
      (set! args '()))

    ;; Call OPT's processor with OPT, NAME, an argument to be decided,
    ;; and the seeds.  Depending on OPT's *-arg? specification, get
    ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
    ;; if no argument is allowed, call NO-ARG-PROC thunk.
    (define (invoke-option-processor
	     opt name req-arg-proc opt-arg-proc no-arg-proc)
      (mutate-seeds!
       (option-processor opt) opt name
       (cond ((option-required-arg? opt) (req-arg-proc))
	     ((option-optional-arg? opt) (opt-arg-proc))
	     (else (no-arg-proc) #f))))

    ;; Compute and answer a short option argument, advancing ARGS as
    ;; necessary, for the short option whose character is at POSITION
    ;; in the current ARG.
    (define (short-option-argument position)
      (cond ((< (1+ position) (string-length (car args)))
	     (let ((result (substring (car args) (1+ position))))
	       (set! args (cdr args))
	       result))
	    ((pair? (cdr args))
	     (let ((result (cadr args)))
	       (set! args (cddr args))
	       result))
            ((pair? args)
             (set! args (cdr args))
             #f)
	    (else #f)))

    ;; Interpret the short-option at index POSITION in (car ARGS),
    ;; followed by the remaining short options in (car ARGS).
    (define (short-option position)
      (if (>= position (string-length (car args)))
          (begin
            (set! args (cdr args))
            (next-arg))
	  (let* ((opt-name (string-ref (car args) position))
		 (option-here (hash-ref lookup opt-name)))
	    (cond ((not option-here)
		   (mutate-seeds! unrecognized-option-proc
				  (option (list opt-name) #f #f
					  unrecognized-option-proc)
				  opt-name #f)
		   (short-option (1+ position)))
		  (else
		   (invoke-option-processor
		    option-here opt-name
		    (lambda ()
		      (or (short-option-argument position)
			  (error "Missing required argument after `-~A'" opt-name)))
		    (lambda ()
		      ;; edge case: -xo -zf or -xo -- where opt-name=#\o
		      ;; GNU getopt_long resolves these like I do
		      (short-option-argument position))
		    (lambda () #f))
		   (if (not (or (option-required-arg? option-here)
				(option-optional-arg? option-here)))
		       (short-option (1+ position))))))))

    ;; Process the long option in (car ARGS).  We make the
    ;; interesting, possibly non-standard assumption that long option
    ;; names might contain #\=, so keep looking for more #\= in (car
    ;; ARGS) until we find a named option in lookup.
    (define (long-option)
      (let ((arg (car args)))
	(let place-=-after ((start-pos 2))
	  (let* ((index (string-index arg #\= start-pos))
		 (opt-name (substring arg 2 (or index (string-length arg))))
		 (option-here (hash-ref lookup opt-name)))
	    (if (not option-here)
		;; look for a later #\=, unless there can't be one
		(if index
		    (place-=-after (1+ index))
		    (mutate-seeds!
		     unrecognized-option-proc
		     (option (list opt-name) #f #f unrecognized-option-proc)
		     opt-name #f))
		(invoke-option-processor
		 option-here opt-name
		 (lambda ()
		   (if index
		       (substring arg (1+ index))
		       (error "Missing required argument after `--~A'" opt-name)))
		 (lambda () (and index (substring arg (1+ index))))
		 (lambda ()
		   (if index
		       (error "Extraneous argument after `--~A'" opt-name))))))))
      (set! args (cdr args)))

    ;; Process the remaining in ARGS.  Basically like calling
    ;; `args-fold', but without having to regenerate `lookup' and the
    ;; funcs above.
    (define (next-arg)
      (if (null? args)
	  (apply values seeds)
	  (let ((arg (car args)))
	    (cond ((or (string-null? arg)
		       (not (char=? #\- (string-ref arg 0)))
		       (= 1 (string-length arg))) ;"-"
		   (mutate-seeds! operand-proc arg)
		   (set! args (cdr args)))
		  ((char=? #\- (string-ref arg 1))
		   (if (= 2 (string-length arg)) ;"--"
		       (begin (set! args (cdr args)) (rest-operands))
		       (long-option)))
		  (else (short-option 1)))
	    (next-arg))))

    (next-arg)))

;;; srfi-37.scm ends here