(define-syntax lookup-shared-value
  (syntax-rules ()
    ((lookup-shared-valued str)
     (shared-binding-ref (lookup-imported-binding str)))))

(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)
  (zero? code))

(define yp-unknown-key?
  (let ((yp-unknown-key (lookup-shared-value "yp-error-key")))
    (lambda (code)
      (equal? yp-unknown-key code))))

(define yp-no-more-results?
  (let ((yp-error-nomore (lookup-shared-value "yp-error-nomore")))
    (lambda (code)
      (equal? yp-error-nomore code))))

;;; 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))
    (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)))
    (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)))
    (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))
      (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))
      (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))
      (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))
      (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))
      (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 (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))

(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")