(define-condition-type <foreign> <error> foreign-status?
   (set foreign-status-set)
   (code foreign-status-code)
   (table %foreign-status-table))

(define (%make-foreign-status condition-type plist)
   (define (ensure-symbol x)
     (cond ((keyword? x) (string->symbol (keyword->string x)))
           ((symbol? x) x)
           (else (error "Bad plist keyword:" x))))
   (let ((table (make-hash-table)))
     (let loop ((tail plist) (set #f) (code #f))
       (cond ((null? tail)
              (make-condition condition-type
                              'set set
                              'code code
                              'table table))
             ((not (and (pair? tail) (pair? (cdr tail))))
              (error "Bad plist:" plist))
             (else
              (let ((property (ensure-symbol (car tail)))
                    (value (cadr tail)))
                (case property
                  ((set)
                   (loop (cddr tail) value code))
                  ((code)
                   (loop (cddr tail) set value))
                  (else
                   (hash-table-set! table property value)
                   (loop (cddr tail) set code)))))))))

(define (make-foreign-status :key :allow-other-keys plist)
   (%make-foreign-status <foreign> plist))

(define-method foreign-status-ref ((st <foreign>) property)
   (case property
     ((set code)
      (condition-ref st property))
     (else
      (hash-table-ref/default (%foreign-status-table st) property #f))))

;;

(define-condition-type <errno> <foreign> errno-status?)

(define-method foreign-status-ref ((st <errno>) property)
   (case property
     ((message)  (sys-strerror (foreign-status-code st)))
     (else       (next-method))))

(define (make-errno-status code :key :allow-other-keys plist)
   (%make-foreign-status <errno> (list* :set 'errno :code code plist)))

;;

(define-syntax pp
   (syntax-rules ()
     ((_ x) (begin (write 'x) (display " => ") (write x) (newline)))))

(let ((st (make-foreign-status :set 'errno :code 4)))
   (pp (foreign-status? st))
   (pp (errno-status? st))
   (pp (foreign-status-set st))
   (pp (foreign-status-ref st 'set))
   (pp (foreign-status-code st))
   (pp (foreign-status-ref st 'code)))
(newline)
(let ((st (make-errno-status 4 :foreign-procedure 'read)))
   (pp (foreign-status? st))
   (pp (errno-status? st))
   (pp (foreign-status-set st))
   (pp (foreign-status-ref st 'set))
   (pp (foreign-status-code st))
   (pp (foreign-status-ref st 'code))
   (pp (foreign-status-ref st 'message))
   (pp (foreign-status-ref st 'foreign-procedure)))

;;;; OUTPUT:

(foreign-status? st) => #t
(errno-status? st) => #f
(foreign-status-set st) => errno
(foreign-status-ref st 'set) => errno
(foreign-status-code st) => 4
(foreign-status-ref st 'code) => 4

(foreign-status? st) => #t
(errno-status? st) => #t
(foreign-status-set st) => errno
(foreign-status-ref st 'set) => errno
(foreign-status-code st) => 4
(foreign-status-ref st 'code) => 4
(foreign-status-ref st 'message) => "Interrupted system call"
(foreign-status-ref st 'foreign-procedure) => read