use conditions for signaling errors

scheme/yp-interfaces.scm

@@ -1,18 +1,28 @@
 (define-interface yp-interface
   (export
-   (yp-result-code :syntax)
+   yp-error?
-   yp-result-code-elements
+   yp-communication-error?
-   yp-result-code-name
+   yp-unknown-resource-error?
-   yp-success?
+   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-map->list))
-   yp-error-string
-   yp-protocol-error
-   yp-match))   

scheme/yp-packages.scm

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

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
+(define yp-error-code-alist
-  (id)
+  `((,(lookup-shared-value "yp-error-badargs")	. yp-bad-arguments)
-  yp-result-code?
+    (,(lookup-shared-value "yp-error-baddb")	. yp-bad-database)
-  yp-result-code-elements
+    (,(lookup-shared-value "yp-error-domain")	. yp-bad-domain)
-  yp-result-code-name
+    (,(lookup-shared-value "yp-error-key")	. yp-unknown-key)
-  yp-result-code-index
+    (,(lookup-shared-value "yp-error-map")	. yp-unknown-map)
-  (id yp-result-code-id)
+    (,(lookup-shared-value "yp-error-nodom")	. yp-no-domain)
-  ((success		0)
+    (,(lookup-shared-value "yp-error-pmap")	. yp-portmap-failure)
-   (bad-args		(lookup-shared-value "yp-error-badargs"))
+    (,(lookup-shared-value "yp-error-resrc")	. yp-allocation-failure)
-   (bad-database	(lookup-shared-value "yp-error-baddb"))
+    (,(lookup-shared-value "yp-error-rpc")	. yp-rpc-failure)
-   (bad-domain		(lookup-shared-value "yp-error-domain"))
+    (,(lookup-shared-value "yp-error-bind")	. yp-bind-failure)
-   (unknown-key		(lookup-shared-value "yp-error-key"))
+    (,(lookup-shared-value "yp-error-yperr")	. yp-internal-error)
-   (unknown-map		(lookup-shared-value "yp-error-map"))
+    (,(lookup-shared-value "yp-error-ypserv")	. yp-server-error)))
-   (no-domain		(lookup-shared-value "yp-error-nodom"))
+
-   (no-more-records	(lookup-shared-value "yp-error-nomore"))
+(define (raise-yp-error code . args)
-   (portmap-failure	(lookup-shared-value "yp-error-pmap"))
+  (cond
-   (allocation-failure	(lookup-shared-value "yp-error-resrc"))
+   ((assoc code yp-error-code-alist)
-   (rpc-failure		(lookup-shared-value "yp-error-rpc"))
+    => (lambda (code.ctype)
-   (bind-failure	(lookup-shared-value "yp-error-bind"))
+	 (let ((ctype (cdr code.ctype)))
-   (internal-error	(lookup-shared-value "yp-error-yperr"))
+	   (apply signal ctype 
-   (server-error	(lookup-shared-value "yp-error-ypserv"))))
+		  (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)
+(define yp-unknown-key?
-  (equal? (yp-result-code no-more-records) code))
+  (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)
+(define yp-no-more-results?
-  (map (lambda (e) 
+  (let ((yp-error-nomore (lookup-shared-value "yp-error-nomore")))
-	 (cons (id-proc e) e))
+    (lambda (code)
-       (vector->list elements)))
+      (equal? yp-error-nomore code))))
 
-(define translate-result-code
+;;; condition hierachy
-  (let ((alist (make-finite-type-alist 
+(define-condition-type 'yp-error '(error))
-		yp-result-code-elements yp-result-code-id)))
+(define yp-error? 
-    (lambda (id)
+  (condition-predicate 'yp-error))
-      (cond 
+
-       ((assoc id alist) => cdr)
+(define-condition-type 'yp-communication-error '(yp-error))
-       (else
+(define yp-communication-error?
-	(error "yp: internal error. Could not map YP result code to finite type" id))))))
+  (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)
-      (if (yp-success? code)
+	domain
-	  domain
+	(raise-yp-error code `(yp-get-default-domain domain ,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))))
+    (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)
+    (receive (key val) (yp-first map domain)
-      (if (yp-success? code)
+      (let loop ((key key) (res (cons (cons key val) '())))
-	  (let loop ((key key) (res (cons (cons key val) '())))
+	(receive (key val) 
-	    (receive (code key val) 
+	    (yp-next map key domain)
-		(yp-next map key domain)
+	  (if val
-	      (cond
+	      (loop key (cons (cons key val) res))
-	       ((yp-error-no-more? code) res)
+	      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)))
+  (yp-error-string-int yp-result))
 
 (import-lambda-definition yp-get-default-domain-int
 			  ()