From f24b9140d6f74804d5599ec225717d38ca443813 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:26 -0800
Subject: Import Upstream version 2c0

---
 paramlst.scm | 74 +++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 61 insertions(+), 13 deletions(-)

(limited to 'paramlst.scm')

diff --git a/paramlst.scm b/paramlst.scm
index f01788b..706c91c 100644
--- a/paramlst.scm
+++ b/paramlst.scm
@@ -1,5 +1,5 @@
 ;;; "paramlst.scm" passing parameters by name.
-; Copyright 1995 Aubrey Jaffer
+; Copyright 1995, 1996, 1997 Aubrey Jaffer
 ;
 ;Permission to copy this software, to redistribute it, and to use it
 ;for any purpose is granted, subject to the following restrictions and
@@ -43,13 +43,13 @@
     (lambda (arity)
       (assq arity table))))
 
-(define (fill-empty-parameters defaults parameter-list)
-  (map (lambda (default parameter)
+(define (fill-empty-parameters defaulters parameter-list)
+  (map (lambda (defaulter parameter)
 	 (cond ((null? (cdr parameter))
 		(cons (car parameter)
-		      (if default (default parameter-list) '())))
+		      (if defaulter (defaulter parameter-list) '())))
 	       (else parameter)))
-       defaults parameter-list))
+       defaulters parameter-list))
 
 (define (check-parameters checks parameter-list)
   (for-each (lambda (check parameter)
@@ -139,7 +139,8 @@
       ((expression) val)
       (else (coerce val ntyp))))
   (require 'getopt)
-  (let ((optlist '())
+  (let ((starting-optind *optind*)
+	(optlist '())
 	(long-opt-list '())
 	(optstring #f)
 	(parameter-list (make-parameter-list optnames))
@@ -168,9 +169,55 @@
       (let ((opt (getopt-- argc argv optstring)))
 	(case opt
 	  ((#\: #\?)
-	   (slib:error
-	    'getopt->parameter-list "unrecognized option"
-	    getopt:opt))
+	   (let ((aliast (map list optnames))
+		 (strlen=1? (lambda (s) (= 1 (string-length s))))
+		 (cep (current-error-port)))
+	     (require 'printf)
+	     (require 'common-list-functions)
+	     (for-each (lambda (alias)
+			 (let ((apr (assq (cadr alias) aliast)))
+			   (set-cdr! apr (cons (car alias) (cdr apr)))))
+		       aliases)
+	     (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..."
+		      (list-ref argv (+ -1 starting-optind)))
+	     (newline cep) (newline cep)
+	     (for-each
+	      (lambda (optname arity aliat)
+		(let loop ((initials (remove-if-not strlen=1? (cdr aliat)))
+			   (longname (remove-if strlen=1? (cdr aliat))))
+		  (cond ((and (null? initials) (null? longname)))
+			(else
+			 (fprintf cep
+				  (case arity
+				    ((boolean) "  %3s %s")
+				    (else "  %3s %s<%s> %s"))
+				  (if (null? initials)
+				      ""
+				      (string-append
+				       "-" (car initials)
+				       (if (null? longname) " " ",")))
+				  (if (null? longname)
+				      "      "
+				      (string-append
+				       "--" (car longname)
+				       (case arity
+					 ((boolean) " ")
+					 (else "="))))
+				  (case arity
+				    ((boolean) "")
+				    (else optname))
+				  (case arity
+				    ((nary nary1) "...")
+				    (else "")))
+			 (newline cep)
+			 (loop (if (null? initials) '() (cdr initials))
+			       (if (null? longname) '() (cdr longname)))))))
+	      optnames arities aliast))
+	   (slib:error 'getopt->parameter-list
+		       (case opt
+			 ((#\:) "argument missing after")
+			 ((#\?) "unrecognized option"))
+		       (string #\- getopt:opt)))
 	  ((#f)
 	   (cond ((and (< *optind* argc)
 		       (string=? "-" (list-ref argv *optind*)))
@@ -201,15 +248,16 @@
 				   (list topt (coerce-val *optarg* curopt))))
 	      (else
 	       (set! curopt topt)
-	       (rdms:warn
-		'getopt->parameter-list "argument missing for option--" opt))))
+;;;	       (slib:warn 'getopt->parameter-list
+;;;			  "= missing for option--" opt)
+	       )))
 	   (loop)))))
     parameter-list))
 
 (define (getopt->arglist argc argv optnames positions
-			 arities types defaults checks aliases)
+			 arities types defaulters checks aliases)
   (let* ((params (getopt->parameter-list
 		  argc argv optnames arities types aliases))
-	 (fparams (fill-empty-parameters defaults params)))
+	 (fparams (fill-empty-parameters defaulters params)))
     (and (list? params) (check-parameters checks fparams))
     (and (list? params) (parameter-list->arglist positions arities fparams))))
-- 
cgit v1.2.3