diff options
Diffstat (limited to 'paramlst.scm')
| -rw-r--r-- | paramlst.scm | 215 |
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)))) |