From da81faadb603ce1bf07a91ff972c111b3cece570 Mon Sep 17 00:00:00 2001 From: eknauel Date: Thu, 30 Oct 2003 20:04:17 +0000 Subject: [PATCH] use conditions for signaling errors --- scheme/yp-interfaces.scm | 26 ++++-- scheme/yp-packages.scm | 2 +- scheme/yp.scm | 192 ++++++++++++++++++++++++++------------- 3 files changed, 150 insertions(+), 70 deletions(-) diff --git a/scheme/yp-interfaces.scm b/scheme/yp-interfaces.scm index 0bf9a2b..6acd21a 100644 --- a/scheme/yp-interfaces.scm +++ b/scheme/yp-interfaces.scm @@ -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)) \ No newline at end of file + yp-map->list)) diff --git a/scheme/yp-packages.scm b/scheme/yp-packages.scm index 0ae8142..55f21a8 100644 --- a/scheme/yp-packages.scm +++ b/scheme/yp-packages.scm @@ -3,7 +3,7 @@ scheme signals srfi-8 - finite-types + conditions let-opt external-calls) (files yp)) \ No newline at end of file diff --git a/scheme/yp.scm b/scheme/yp.scm index 4e4f159..3148555 100644 --- a/scheme/yp.scm +++ b/scheme/yp.scm @@ -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))))))) + (if (yp-success? code) + domain + (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) - (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)))))) + (receive (key val) (yp-first map domain) + (let loop ((key key) (res (cons (cons key val) '()))) + (receive (key val) + (yp-next map key domain) + (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 ()