68 lines
2.6 KiB
Scheme
68 lines
2.6 KiB
Scheme
; Look up a value associated with a symbolic key in alist
|
|
; ((key value) ...) or ((key . value) ...)
|
|
; and return the associated value.
|
|
; If the association has the form
|
|
; (key . value) where value is not a pair --> return value
|
|
; (key value) --> return value
|
|
; (key value1 value2 value3 ...) -> return (value1 value2 value3 ...)
|
|
; that is, the procedure tries to do the right thing for
|
|
; both kinds of associative lists.
|
|
;
|
|
; The form `lookup-def' is a special form rather than a regular
|
|
; procedure. Its first two arguments are evaluated exactly once. The
|
|
; default-value argument, if given, is evaluated only if the desired key
|
|
; is not found. I have not seen any need to pass `lookup-def' as an
|
|
; argument to other functions. If the latter is desired, it is not
|
|
; difficult to accomplish by explicitly wrapping `lookup-def' into a
|
|
; lambda form.
|
|
;
|
|
; We use a pseudo-keyword argument warn: as a modifier.
|
|
; This is not really a keyword argument (although it may be,
|
|
; if the Scheme system turns out DSSSL-compatible)
|
|
;
|
|
; (lookup-def key alist) -- lookup the key in the alist and return the
|
|
; associated value. Raise an error if the key is not
|
|
; found.
|
|
; (lookup-def key alist default-exp)
|
|
; -- lookup the key in the alist and return the associated
|
|
; value. If the the key is not found, evaluate
|
|
; the default-exp and return its result.
|
|
; (lookup-def key alist warn: default-exp)
|
|
; -- the same as above. In addition, write a warning
|
|
; (using cerr above) if the key is not found.
|
|
|
|
(define-syntax lookup-def
|
|
(syntax-rules (warn:)
|
|
((lookup-def key alist)
|
|
(let ((nkey key) (nalist alist)) ; evaluate them only once
|
|
(let ((res (assq nkey nalist)))
|
|
(if res
|
|
(let ((res (cdr res)))
|
|
(cond
|
|
((not (pair? res)) res)
|
|
((null? (cdr res)) (car res))
|
|
(else res)))
|
|
(error "Failed to find " nkey " in " nalist)))))
|
|
((lookup-def key alist default-exp)
|
|
(let ((res (assq key alist)))
|
|
(if res
|
|
(let ((res (cdr res)))
|
|
(cond
|
|
((not (pair? res)) res)
|
|
((null? (cdr res)) (car res))
|
|
(else res)))
|
|
default-exp)))
|
|
((lookup-def key alist warn: default-exp)
|
|
(let ((nkey key) (nalist alist)) ; evaluate them only once
|
|
(let ((res (assq nkey nalist)))
|
|
(if res
|
|
(let ((res (cdr res)))
|
|
(cond
|
|
((not (pair? res)) res)
|
|
((null? (cdr res)) (car res))
|
|
(else res)))
|
|
(begin
|
|
(cerr "Failed to find " nkey " in " nalist #\newline)
|
|
default-exp)))))
|
|
))
|