Another sketch of foreign-status abstraction in Common Lisp Lassi Kortela 14 Aug 2020 11:30 UTC

Here's some CL code to illustrate the different implementation
strategies that are permitted free of charge if we use an abstract datatype.

The Common Lisp condition system is based on its type system, which has
a well-defined concept of subtypes. The example makes a `foreign-status`
condition type and a specialized `errno-status` subtype for it.

We can expect that the `set` and `code` properties are accessed all the
time so they are stored in special slots, possibly amenable to
optimization by Common Lisp. The rest are stored in a hash-table.

There's a flaw in the code in that (signal 'foreign-status ...) and
(error 'foreign-status ...) don't work nicely. These are CL equivalents
to Scheme's `raise` and it would be nice if we could pass an argument
list identical to the one we pass to `make-foreign-status` in the SRFI.

However, since the below implementation puts some properties into a
hash-table but not all of them, it would need to run a special
constructor to do that filtering. The define-condition :initarg system
is not powerful enough to express that.

CLOS (Common Lisp Object System) supports full-fledged constructors
(called initialize-instance) but CL condition types are not required by
the CL standard to be implemented as real CLOS classes, so I don't think
we can portably write a real constructor for a condition type; I would
love to be proven wrong on this.

;;----------------------------------------------------------------------

;; Foreign error type

(defun %make-foreign-status (condition-type plist)
   (let (set code (table (make-hash-table :test #'eq)))
     (do ((plist plist (cddr plist)))
         ((null plist))
       (let ((property (first plist))
             (value (second plist)))
         (case property
           (:set (setf set value))
           (:code (setf code value))
           (otherwise (setf (gethash (intern (symbol-name property)
*package*)
                                     table)
                            value)))))
     (make-condition condition-type :set set :code code :table table)))

(define-condition foreign-status (condition)
   ((set    :initarg :set    :reader foreign-status-set)
    (code   :initarg :code   :reader foreign-status-code)
    (table  :initarg :table)))

(defgeneric foreign-status-ref (st property))

(defun make-foreign-status (&rest plist &key &allow-other-keys)
   (%make-foreign-status 'foreign-status plist))

(defmethod foreign-status-ref ((st foreign-status) (property (eql 'set)))
   (foreign-status-set st))

(defmethod foreign-status-ref ((st foreign-status) (property (eql 'code)))
   (foreign-status-code st))

(defmethod foreign-status-ref ((st foreign-status) (property symbol))
   (values (gethash property (slot-value st 'table))))

;; Foreign error subtype just for errno values :)

(defun %strerror (errno) "Please implement strerror ^_^")

(define-condition errno-status (foreign-status)
   ())

(defmethod foreign-status-ref ((st errno-status) (property (eql 'message)))
   (%strerror (foreign-status-code st)))

(defun make-errno-status (code &rest plist &key &allow-other-keys)
   (%make-foreign-status 'errno-status (list* :set 'errno :code code
plist)))

;; Test

(defmacro pp (expr)
   `(format t "~S => ~S~%" ',expr ,expr))

(let ((st (make-foreign-status :set 'libcurl
                                :code 52
                                :name 'CURLE_GOT_NOTHING
                                :message "Message from curl")))
   (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 'name))
   (pp (foreign-status-ref st 'message)))
(write-line "")
(let ((st (make-errno-status 4 :foreign-procedure 'read)))
   (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)))