summaryrefslogtreecommitdiffstats
path: root/paramlst.scm
diff options
context:
space:
mode:
Diffstat (limited to 'paramlst.scm')
-rw-r--r--paramlst.scm215
1 files changed, 215 insertions, 0 deletions
diff --git a/paramlst.scm b/paramlst.scm
new file mode 100644
index 0000000..f01788b
--- /dev/null
+++ b/paramlst.scm
@@ -0,0 +1,215 @@
+;;; "paramlst.scm" passing parameters by name.
+; Copyright 1995 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
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;; Format of arity-spec: (name predicate conversion)
+
+(require 'common-list-functions)
+
+(define arity->arity-spec
+ (let ((table
+ `((nary
+ ,(lambda (a) #t)
+ ,identity)
+ (nary1
+ ,(lambda (a) (not (null? a)))
+ ,identity)
+ (single
+ ,(lambda (a) (and (pair? a) (null? (cdr a))))
+ ,car)
+ (optional
+ ,(lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))
+ ,identity)
+ (boolean
+ ,(lambda (a)
+ (or (null? a)
+ (and (pair? a) (null? (cdr a)) (boolean? (car a)))))
+ ,(lambda (a) (if (null? a) #f (car a)))))))
+ (lambda (arity)
+ (assq arity table))))
+
+(define (fill-empty-parameters defaults parameter-list)
+ (map (lambda (default parameter)
+ (cond ((null? (cdr parameter))
+ (cons (car parameter)
+ (if default (default parameter-list) '())))
+ (else parameter)))
+ defaults parameter-list))
+
+(define (check-parameters checks parameter-list)
+ (for-each (lambda (check parameter)
+ (for-each
+ (lambda (p)
+ (cond ((and check (not (check p)))
+ (slib:error (car parameter)
+ "parameter is wrong type: " p))))
+ (cdr parameter)))
+ checks parameter-list)
+ parameter-list)
+
+(define (check-arities arity-specs parameter-list)
+ (and (every identity arity-specs)
+ (every
+ (lambda (arity-spec param)
+ ((cadr arity-spec) (cdr param)))
+ arity-specs parameter-list)))
+
+(define (parameter-list->arglist positions arities parameter-list)
+ (and (= (length arities) (length positions) (length parameter-list))
+ (let ((arity-specs (map arity->arity-spec arities))
+ (ans (make-vector (length positions) #f)))
+ (and (check-arities arity-specs parameter-list)
+ (for-each
+ (lambda (pos arity-spec param)
+ (vector-set! ans (+ -1 pos)
+ ((caddr arity-spec) (cdr param))))
+ positions arity-specs parameter-list)
+ (vector->list ans)))))
+
+(define (make-parameter-list parameter-names)
+ (map list parameter-names))
+
+(define (parameter-list-ref parameter-list i)
+ (let ((ans (assoc i parameter-list)))
+ (and ans (cdr ans))))
+
+(define (parameter-list-expand expanders parms)
+ (do ((lens (map length parms) (map length parms))
+ (olens '() lens))
+ ((equal? lens olens))
+ (for-each (lambda (expander parm)
+ (cond
+ (expander
+ (for-each
+ (lambda (news)
+ (cond ((adjoin-parameters! parms news))
+ (else (slib:error
+ "expanded feature unknown: " news))))
+ (apply append
+ (map (lambda (p)
+ (cond ((expander p))
+ ((not '()) '())
+ (else (slib:error
+ "couldn't expand feature: " p))))
+ (cdr parm)))))))
+ expanders
+ parms)))
+
+(define (adjoin-parameters! parameter-list . parameters)
+ (let ((apairs (map (lambda (param)
+ (cond ((pair? param)
+ (assoc (car param) parameter-list))
+ (else (assoc param parameter-list))))
+ parameters)))
+ (and (every identity apairs) ;same as APPLY AND?
+ (for-each
+ (lambda (apair param)
+ (cond ((pair? param)
+ (for-each (lambda (o)
+ (if (not (member o (cdr apair)))
+ (set-cdr! apair (cons o (cdr apair)))))
+ (cdr param)))
+ (else (if (not (memv #t (cdr apair)))
+ (set-cdr! apair (cons #t (cdr apair)))))))
+ apairs parameters)
+ parameter-list)))
+
+(define (getopt->parameter-list argc argv optnames arities types aliases)
+ (define (can-take-arg? opt)
+ (not (eq? (list-ref arities (position opt optnames))
+ 'boolean)))
+ (define (coerce-val val curopt)
+ (define ntyp (list-ref types (position curopt optnames)))
+ (case ntyp
+ ((expression) val)
+ (else (coerce val ntyp))))
+ (require 'getopt)
+ (let ((optlist '())
+ (long-opt-list '())
+ (optstring #f)
+ (parameter-list (make-parameter-list optnames))
+ (curopt '*unclaimed-argument*))
+ (set! aliases (map (lambda (alias)
+ (define str (string-copy (car alias)))
+ (do ((i (+ -1 (string-length str)) (+ -1 i)))
+ ((negative? i) (cons str (cdr alias)))
+ (cond ((char=? #\ (string-ref str i))
+ (string-set! str i #\-)))))
+ aliases))
+ (for-each
+ (lambda (alias)
+ (define opt (car alias))
+ (cond ((not (string? opt)))
+ ((< 1 (string-length opt))
+ (set! long-opt-list (cons opt long-opt-list)))
+ ((not (= 1 (string-length opt))))
+ ((can-take-arg? (cadr alias))
+ (set! optlist (cons (string-ref opt 0)
+ (cons #\: optlist))))
+ (else (set! optlist (cons (string-ref opt 0) optlist)))))
+ aliases)
+ (set! optstring (list->string (cons #\: optlist)))
+ (let loop ()
+ (let ((opt (getopt-- argc argv optstring)))
+ (case opt
+ ((#\: #\?)
+ (slib:error
+ 'getopt->parameter-list "unrecognized option"
+ getopt:opt))
+ ((#f)
+ (cond ((and (< *optind* argc)
+ (string=? "-" (list-ref argv *optind*)))
+ (set! *optind* (+ 1 *optind*)))
+ ((< *optind* argc)
+ (cond ((and (member curopt optnames)
+ (adjoin-parameters!
+ parameter-list
+ (list curopt
+ (coerce-val (list-ref argv *optind*)
+ curopt))))
+ (set! *optind* (+ 1 *optind*))
+ (loop))
+ (else (slib:error 'getopt->parameter-list curopt
+ (list-ref argv *optind*)
+ "not supported"))))))
+ (else
+ (cond ((char? opt) (set! opt (string opt))))
+ (let ((topt (assoc opt aliases)))
+ (cond (topt (set! topt (cadr topt)))
+ (else (slib:error "Option not recognized -" opt)))
+ (cond
+ ((not (can-take-arg? topt))
+ (adjoin-parameters! parameter-list (list topt #t)))
+ (*optarg*
+ (set! curopt topt)
+ (adjoin-parameters! parameter-list
+ (list topt (coerce-val *optarg* curopt))))
+ (else
+ (set! curopt topt)
+ (rdms:warn
+ 'getopt->parameter-list "argument missing for option--" opt))))
+ (loop)))))
+ parameter-list))
+
+(define (getopt->arglist argc argv optnames positions
+ arities types defaults checks aliases)
+ (let* ((params (getopt->parameter-list
+ argc argv optnames arities types aliases))
+ (fparams (fill-empty-parameters defaults params)))
+ (and (list? params) (check-parameters checks fparams))
+ (and (list? params) (parameter-list->arglist positions arities fparams))))