Another sketch of foreign-status abstraction in Common Lisp Lassi Kortela (14 Aug 2020 11:30 UTC)
|
Re: Another sketch of foreign-status abstraction in Common Lisp
Lassi Kortela
(14 Aug 2020 11:45 UTC)
|
Re: Another sketch of foreign-status abstraction in Common Lisp
Lassi Kortela
(14 Aug 2020 11:47 UTC)
|
Re: Another sketch of foreign-status abstraction in Common Lisp
Arthur A. Gleckler
(14 Aug 2020 23:38 UTC)
|
Same thing for Gauche's object and condition system
Lassi Kortela
(14 Aug 2020 12:50 UTC)
|
Re: Same thing for Gauche's object and condition system
Arthur A. Gleckler
(14 Aug 2020 23:39 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)))