+;;;; C callbacks
+
+(defmacro define-callback (name return-type args &body body)
+ (let ((define-callback
+ #+cmu'alien:def-callback
+ #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
+ #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
+ (multiple-value-bind (doc declaration body)
+ (cond
+ ((and (stringp (first body)) (eq (cadr body) 'declare))
+ (values (first body) (second body) (cddr body)))
+ ((stringp (first body))
+ (values (first body) nil (rest body)))
+ ((eq (caar body) 'declare)
+ (values nil (first body) (rest body)))
+ (t (values nil nil body)))
+ `(progn
+ #+cmu(defparameter ,name nil)
+ (,define-callback ,name
+ #+(and sbcl alien-callbacks),(alien-type return-type)
+ (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
+ ,@(mapcar #'(lambda (arg)
+ (destructuring-bind (name type) arg
+ `(,name ,(alien-type type))))
+ args))
+ ,@(when doc (list doc))
+ ,(to-alien-form return-type
+ `(let (,@(loop
+ for (name type) in args
+ as from-alien-form = (callback-from-alien-form type name)
+ collect `(,name ,from-alien-form)))
+ ,@(when declaration (list declaration))
+ (unwind-protect
+ (progn ,@body)
+ ,@(loop
+ for (name type) in args
+ do (callback-cleanup-form type name))))))))))
+
+(defun callback-address (callback)
+ #+cmu(alien::callback-trampoline callback)
+ #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
+ #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
+
+#+sbcl
+(deftype callback ()
+ #-alien-callbacks'sb-alien:alien-function
+ #+alien-callbacks'sb-alien:alien)
+
+
+;;; These are for backward compatibility
+
+(defmacro defcallback (name (return-type &rest args) &body body)
+ `(define-callback ,name ,return-type ,args ,@body))
+
+#-cmu
+(defun callback (callback)
+ (callback-address callback))
+
+
+
+;;;; The "type method" system
+
+(defun find-applicable-type-method (name type-spec &optional (error-p t))
+ (let ((type-methods (get name 'type-methods)))
+ (labels ((search-method-in-cpl-order (classes)
+ (when classes
+ (or
+ (gethash (class-name (first classes)) type-methods)
+ (search-method-in-cpl-order (rest classes)))))
+ (lookup-method (type-spec)
+ (if (and (symbolp type-spec) (find-class type-spec nil))
+ (search-method-in-cpl-order
+ (class-precedence-list (find-class type-spec)))
+ (or
+ (let ((specifier (etypecase type-spec
+ (symbol type-spec)
+ (list (first type-spec)))))
+ (gethash specifier type-methods))
+ (multiple-value-bind (expanded-type expanded-p)
+ (type-expand-1 type-spec)
+ (when expanded-p
+ (lookup-method expanded-type))))))
+ (search-built-in-type-hierarchy (sub-tree)
+ (when (subtypep type-spec (first sub-tree))
+ (or
+ (search-nodes (cddr sub-tree))
+ (second sub-tree))))
+ (search-nodes (nodes)
+ (loop
+ for node in nodes
+ as function = (search-built-in-type-hierarchy node)
+ until function
+ finally (return function))))
+ (or
+ (lookup-method type-spec)
+ ;; This is to handle unexpandable types whichs doesn't name a class
+ (unless (and (symbolp type-spec) (find-class type-spec nil))
+ (search-nodes (get name 'built-in-type-hierarchy)))
+ (and
+ error-p
+ (error "No applicable type method for ~A when call width type specifier ~A" name type-spec))))))
+
+
+(defun insert-type-in-hierarchy (specifier function nodes)
+ (cond
+ ((let ((node (find specifier nodes :key #'first)))
+ (when node
+ (setf (second node) function)
+ nodes)))
+ ((let ((node
+ (find-if
+ #'(lambda (node)
+ (subtypep specifier (first node)))
+ nodes)))
+ (when node
+ (setf (cddr node)
+ (insert-type-in-hierarchy specifier function (cddr node)))
+ nodes)))
+ ((let ((sub-nodes (remove-if-not
+ #'(lambda (node)
+ (subtypep (first node) specifier))
+ nodes)))
+ (cons
+ (list* specifier function sub-nodes)
+ (nset-difference nodes sub-nodes))))))
+
+
+(defun add-type-method (name specifier function)
+ (setf (gethash specifier (get name 'type-methods)) function)
+ (when (typep (find-class specifier nil) 'built-in-class)
+ (setf (get name 'built-in-type-hierarchy)
+ (insert-type-in-hierarchy specifier function
+ (get name 'built-in-type-hierarchy)))))
+
+
+;; TODO: handle optional, key and rest arguments
+(defmacro define-type-generic (name lambda-list &optional documentation)
+ (if (or
+ (not lambda-list)
+ (find (first lambda-list) '(&optional &key &rest &allow-other-keys)))
+ (error "A type generic needs at least one required argument")
+ `(progn
+ (setf (get ',name 'type-methods) (make-hash-table))
+ (setf (get ',name 'built-in-type-hierarchy) ())
+ (defun ,name ,lambda-list
+ ,documentation
+ (funcall
+ (find-applicable-type-method ',name ,(first lambda-list))
+ ,@lambda-list)))))
+
+
+(defmacro define-type-method (name lambda-list &body body)
+ (let ((specifier (cadar lambda-list))
+ (args (cons (caar lambda-list) (rest lambda-list))))
+ `(progn
+ (add-type-method ',name ',specifier #'(lambda ,args ,@body))
+ ',name)))
+
+
+
+;;;; Definitons and translations of fundamental types
+
+(define-type-generic alien-type (type-spec))
+(define-type-generic size-of (type-spec))
+(define-type-generic to-alien-form (type-spec form))
+(define-type-generic from-alien-form (type-spec form))
+(define-type-generic cleanup-form (type-spec form)
+ "Creates a form to clean up after the alien call has finished.")
+(define-type-generic callback-from-alien-form (type-spec form))
+(define-type-generic callback-cleanup-form (type-spec form))
+
+(define-type-generic to-alien-function (type-spec))
+(define-type-generic from-alien-function (type-spec))
+(define-type-generic cleanup-function (type-spec))
+
+(define-type-generic copy-to-alien-form (type-spec form))
+(define-type-generic copy-to-alien-function (type-spec))
+(define-type-generic copy-from-alien-form (type-spec form))
+(define-type-generic copy-from-alien-function (type-spec))
+(define-type-generic writer-function (type-spec))
+(define-type-generic reader-function (type-spec))
+(define-type-generic destroy-function (type-spec))
+
+(define-type-generic unbound-value (type-spec)
+ "Returns a value which should be intepreted as unbound for slots with virtual allocation")
+
+
+;; Sizes of fundamental C types in bytes (8 bits)
+(defconstant +size-of-short+ 2)
+(defconstant +size-of-int+ 4)
+(defconstant +size-of-long+ 4)
+(defconstant +size-of-pointer+ 4)
+(defconstant +size-of-float+ 4)
+(defconstant +size-of-double+ 8)
~mdw / clg / blobdiff