160 lines
4.6 KiB
Scheme
160 lines
4.6 KiB
Scheme
(define-syntax lookup-shared-value
|
|
(syntax-rules ()
|
|
((lookup-shared-valued str)
|
|
(shared-binding-ref (lookup-imported-binding str)))))
|
|
|
|
(define-finite-type yp-result-code :yp-result-code
|
|
(id)
|
|
yp-result-code?
|
|
yp-result-code-elements
|
|
yp-result-code-name
|
|
yp-result-code-index
|
|
(id yp-result-code-id)
|
|
((success 0)
|
|
(bad-args (lookup-shared-value "yp-error-badargs"))
|
|
(bad-database (lookup-shared-value "yp-error-baddb"))
|
|
(bad-domain (lookup-shared-value "yp-error-domain"))
|
|
(unknown-key (lookup-shared-value "yp-error-key"))
|
|
(unknown-map (lookup-shared-value "yp-error-map"))
|
|
(no-domain (lookup-shared-value "yp-error-nodom"))
|
|
(no-more-records (lookup-shared-value "yp-error-nomore"))
|
|
(portmap-failure (lookup-shared-value "yp-error-pmap"))
|
|
(allocation-failure (lookup-shared-value "yp-error-resrc"))
|
|
(rpc-failure (lookup-shared-value "yp-error-rpc"))
|
|
(bind-failure (lookup-shared-value "yp-error-bind"))
|
|
(internal-error (lookup-shared-value "yp-error-yperr"))
|
|
(server-error (lookup-shared-value "yp-error-ypserv"))))
|
|
|
|
(define (yp-success? code)
|
|
(equal? (yp-result-code success) code))
|
|
|
|
(define (yp-error-no-more? code)
|
|
(equal? (yp-result-code no-more-records) code))
|
|
|
|
(define (make-finite-type-alist elements id-proc)
|
|
(map (lambda (e)
|
|
(cons (id-proc e) e))
|
|
(vector->list elements)))
|
|
|
|
(define translate-result-code
|
|
(let ((alist (make-finite-type-alist
|
|
yp-result-code-elements yp-result-code-id)))
|
|
(lambda (id)
|
|
(cond
|
|
((assoc id alist) => cdr)
|
|
(else
|
|
(error "yp: internal error. Could not map YP result code to finite type" id))))))
|
|
|
|
(define (yp-get-default-domain)
|
|
(receive (code domain)
|
|
(apply values (yp-get-default-domain-int))
|
|
(let ((code (translate-result-code code)))
|
|
(if (yp-success? code)
|
|
domain
|
|
(error "yp: Could not get default domain."
|
|
(yp-error-string (yp-result-code-id code)))))))
|
|
|
|
(define (yp-bind . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(translate-result-code (yp-bind-int domain))))
|
|
|
|
(define (yp-unbind . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(translate-result-code (yp-unbind-int domain))))
|
|
|
|
(define (yp-match map key . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code val)
|
|
(apply values (yp-match-int domain map key))
|
|
(values (translate-result-code code) val))))
|
|
|
|
(define (yp-order map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code val)
|
|
(apply values (yp-order-int domain map))
|
|
(values (translate-result-code code) val))))
|
|
|
|
(define (yp-master map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code val)
|
|
(apply values (yp-master-int domain map))
|
|
(values (translate-result-code code) val))))
|
|
|
|
(define (yp-first map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code key val)
|
|
(apply values (yp-first-int domain map))
|
|
(values (translate-result-code code) key val))))
|
|
|
|
(define (yp-next map key . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code key val)
|
|
(apply values (yp-next-int domain map key))
|
|
(values (translate-result-code code) key val))))
|
|
|
|
(define (yp-map->list map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code key val) (yp-first map domain)
|
|
(if (yp-success? code)
|
|
(let loop ((key key) (res (cons (cons key val) '())))
|
|
(receive (code key val)
|
|
(yp-next map key domain)
|
|
(cond
|
|
((yp-error-no-more? code) res)
|
|
((yp-success? code)
|
|
(loop key (cons (cons key val) res)))
|
|
(else
|
|
(error (yp-error-string code))))))
|
|
(error (yp-error-string code))))))
|
|
|
|
(define (yp-error-string yp-result)
|
|
(yp-error-string-int (yp-result-code-id yp-result)))
|
|
|
|
(import-lambda-definition yp-get-default-domain-int
|
|
()
|
|
"scsh_yp_getdefaultdomain")
|
|
|
|
(import-lambda-definition yp-bind-int
|
|
(domain)
|
|
"scsh_yp_bind")
|
|
|
|
(import-lambda-definition yp-unbind-int
|
|
(domain)
|
|
"scsh_yp_unbind")
|
|
|
|
(import-lambda-definition yp-error-string-int
|
|
(code)
|
|
"scsh_yp_errstring")
|
|
|
|
(import-lambda-definition yp-protocol-error
|
|
(code)
|
|
"scsh_yp_proterr")
|
|
|
|
(import-lambda-definition yp-match-int
|
|
(domain map key)
|
|
"scsh_yp_match")
|
|
|
|
(import-lambda-definition yp-order-int
|
|
(domain map)
|
|
"scsh_yp_order")
|
|
|
|
(import-lambda-definition yp-master-int
|
|
(domain map)
|
|
"scsh_yp_master")
|
|
|
|
(import-lambda-definition yp-first-int
|
|
(domain map)
|
|
"scsh_yp_first")
|
|
|
|
(import-lambda-definition yp-next-int
|
|
(domain map key)
|
|
"scsh_yp_next")
|