http://t3x.org/s9fes/keyword-value.scm.html

keyword-value

Location: lib, 28 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (accept-keywords string list1 list2)  ==>  #t | undefined
; (keyword-value list symbol)           ==>  object | undefined
; (keyword-value list symbol object)    ==>  object
;
; KEYWORD-VALUE finds the value associated with a keyword in a property
; list (keywords in odd positions, values in even positions). When the
; keyword is not found in the plist and a default OBJECT is specified,
; that object is returned. When the keyword is not found and no default
; is given, an error is signalled.
;
; ACCEPT-KEYWORDS checks each keyword in LIST1 against symbols listed
; in LIST2. When LIST1 contains a keyword not contained in LIST2, it
; signals an error. It also signals an error when LIST1 contains a
; trailing keyword (without an associated value).
; When reporting an error ACCEPT-KEYWORD will insert the given STRING
; as the source of the error.
;
; Example:   (keyword-value '(foo 1 bar 2) 'bar)  ==>  2
;            (keyword-value '(foo 1) 'bar 0)      ==>  0
;
;            (accept-keywords "test" '(foo 1 bar 2) '(foo bar))  ==>  #t

(define (keyword-value opts key . default)
  (letrec
     ((getprop
        (lambda (x a)
          (cond ((null? a) #f)
                ((null? (cdr a)) #f)
                ((eq? x (car a)) a)
                (else (getprop x (cddr a)))))))
    (cond ((getprop key opts)
            => (lambda (opt)
                 (if (pair? (cdr opt))
                     (cadr opt)
                     (error "keyword-value: missing value" key))))
          ((not (null? default))
            (car default))
          (else
            (error "keyword-value: no such keyword" key)))))

(define (accept-keywords who opts keywords)
  (cond ((null? opts))
        ((null? (cdr opts))
          (error (string-append who ": keyword without value")
                 (car opts)))
        ((memq (car opts) keywords)
          (accept-keywords who (cddr opts) keywords))
        (else
          (error (string-append who ": unknown keyword")
                 (car opts)))))

contact  |  privacy