scsh-conservatory
/
scsh-yp
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

use conditions for signaling errors

This commit is contained in:
eknauel 2003-10-30 20:04:17 +00:00
parent 2d149c517f
commit da81faadb6
3 changed files with 150 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
scheme/yp-interfaces.scm
View File

@ -1,18 +1,28 @@
(define-interface yp-interface
(export
(yp-result-code :syntax)
yp-result-code-elements
yp-result-code-name
yp-success?
yp-error?
yp-communication-error?
yp-unknown-resource-error?
yp-internal-error?
yp-bad-arguments?
yp-bad-database?
yp-binding-error?
yp-unknown-key?
yp-unknown-map?
yp-no-domain?
yp-portmap-failure?
yp-allocation-failure?
yp-rpc-failure?
yp-bind-failure?
yp-server-error?
yp-get-default-domain
yp-bind
yp-unbind
yp-match
yp-order
yp-master
yp-first
yp-next
yp-map->list
yp-error-string
yp-protocol-error
yp-match))
yp-map->list))

2
scheme/yp-packages.scm
View File

@ -3,7 +3,7 @@
scheme
signals
srfi-8
finite-types
conditions
let-opt
external-calls)
(files yp))

184
scheme/yp.scm
View File

@ -3,120 +3,190 @@
((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-error-code-alist
`((,(lookup-shared-value "yp-error-badargs") . yp-bad-arguments)
(,(lookup-shared-value "yp-error-baddb") . yp-bad-database)
(,(lookup-shared-value "yp-error-domain") . yp-bad-domain)
(,(lookup-shared-value "yp-error-key") . yp-unknown-key)
(,(lookup-shared-value "yp-error-map") . yp-unknown-map)
(,(lookup-shared-value "yp-error-nodom") . yp-no-domain)
(,(lookup-shared-value "yp-error-pmap") . yp-portmap-failure)
(,(lookup-shared-value "yp-error-resrc") . yp-allocation-failure)
(,(lookup-shared-value "yp-error-rpc") . yp-rpc-failure)
(,(lookup-shared-value "yp-error-bind") . yp-bind-failure)
(,(lookup-shared-value "yp-error-yperr") . yp-internal-error)
(,(lookup-shared-value "yp-error-ypserv") . yp-server-error)))
(define (raise-yp-error code . args)
(cond
((assoc code yp-error-code-alist)
=> (lambda (code.ctype)
(let ((ctype (cdr code.ctype)))
(apply signal ctype
(append (list ctype (car code.ctype)) args)))))
(else
(error "scsh-yp internal error: unknown result code" code))))
(define (yp-success? code)
(equal? (yp-result-code success) code))
(zero? code))
(define (yp-error-no-more? code)
(equal? (yp-result-code no-more-records) code))
(define yp-unknown-key?
(let ((yp-unknown-key (lookup-shared-value "yp-error-key")))
(lambda (code)
(equal? yp-unknown-key code))))
(define (make-finite-type-alist elements id-proc)
(map (lambda (e)
(cons (id-proc e) e))
(vector->list elements)))
(define yp-no-more-results?
(let ((yp-error-nomore (lookup-shared-value "yp-error-nomore")))
(lambda (code)
(equal? yp-error-nomore code))))
(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))))))
;;; condition hierachy
(define-condition-type 'yp-error '(error))
(define yp-error?
(condition-predicate 'yp-error))
(define-condition-type 'yp-communication-error '(yp-error))
(define yp-communication-error?
(condition-predicate 'yp-communication-error))
(define-condition-type 'yp-unknown-resource-error '(yp-error))
(define yp-unknown-resource-error?
(condition-predicate 'yp-unknown-resource-error))
;;; conditions
(define-condition-type 'yp-bad-arguments '(yp-error))
(define yp-bad-arguments?
(condition-predicate 'yp-bad-arguments))
(define-condition-type 'yp-bad-database '(yp-error))
(define yp-bad-database?
(condition-predicate 'yp-bad-database))
(define-condition-type 'yp-bad-domain '(yp-communication-error))
(define yp-binding-error?
(condition-predicate 'yp-bad-domain))
(define-condition-type 'yp-unknown-key '(yp-unknown-resource-error))
(define yp-unknown-key?
(condition-predicate 'yp-unknown-key))
(define-condition-type 'yp-unknown-map '(yp-unknown-resource-error))
(define yp-unknown-map?
(condition-predicate 'yp-unknown-map))
(define-condition-type 'yp-no-domain '(yp-communication-error))
(define yp-no-domain?
(condition-predicate 'yp-no-domain))
(define-condition-type 'yp-portmap-failure '(yp-communication-error))
(define yp-portmap-failure?
(condition-predicate 'yp-portmap-failure))
(define-condition-type 'yp-allocation-failure '(yp-error))
(define yp-allocation-failure?
(condition-predicate 'yp-allocation-failure))
(define-condition-type 'yp-rpc-failure '(yp-communication-error))
(define yp-rpc-failure?
(condition-predicate 'yp-rpc-failure))
(define-condition-type 'yp-bind-failure '(yp-communication-error))
(define yp-bind-failure?
(condition-predicate 'yp-bind-failure))
(define-condition-type 'yp-internal-error '(yp-error))
(define yp-internal-error?
(condition-predicate 'yp-internal-error))
(define-condition-type 'yp-server-error '(yp-communication-error))
(define yp-server-error?
(condition-predicate 'yp-server-error))
(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)))))))
(raise-yp-error code `(yp-get-default-domain domain ,domain)))))
(define (yp-bind . domain)
(let-optionals domain
((domain (yp-get-default-domain)))
(translate-result-code (yp-bind-int domain))))
(let ((code (yp-bind-int domain)))
(or (yp-success? code)
(raise-yp-error code `(yp-bind domain ,domain))))))
(define (yp-unbind . domain)
(let-optionals domain
((domain (yp-get-default-domain)))
(translate-result-code (yp-unbind-int domain))))
(yp-unbind-int domain)
#t))
(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))))
(cond
((yp-success? code) val)
((yp-unknown-key? code) #f)
(else
(raise-yp-error
code `(yp-match map ,map key ,key domain ,domain)))))))
(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))))
(if (yp-success? code)
val
(raise-yp-error code `(yp-order map ,map domain, domain))))))
(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))))
(if (yp-success? code)
val
(raise-yp-error code `(yp-master map ,map domain ,domain))))))
(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))))
(if (yp-success? code)
(values key val)
(raise-yp-error code `(yp-first key ,key val ,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))))
(cond
((yp-success? code)
(values key val))
((yp-no-more-results? code)
(values #f #f))
(else
(raise-yp-error code `(yp-next key ,key val ,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)
(receive (key val) (yp-first map domain)
(let loop ((key key) (res (cons (cons key val) '())))
(receive (code key val)
(receive (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))))))
(if val
(loop key (cons (cons key val) res))
res))))))
(define (yp-error-string yp-result)
(yp-error-string-int (yp-result-code-id yp-result)))
(yp-error-string-int yp-result))
(import-lambda-definition yp-get-default-domain-int
()