-;;;; Type methods
-
-(defvar *type-methods* (make-hash-table))
-
-(defun ensure-type-method-fun (fname)
- (unless (fboundp fname)
- (setf
- (symbol-function fname)
- #'(lambda (type-spec &rest args)
- (apply
- (find-applicable-type-method type-spec fname) type-spec args)))))
-
-(defmacro define-type-method-fun (fname lambda-list)
- (declare (ignore lambda-list))
- `(defun ,fname (type-spec &rest args)
- (apply
- (find-applicable-type-method type-spec ',fname) type-spec args)))
-
-
-(defun ensure-type-name (type)
- (etypecase type
- (symbol type)
- (pcl::class (class-name type))))
-
-(defun add-type-method (type fname function)
- (push
- (cons fname function)
- (gethash (ensure-type-name type) *type-methods*)))
-
-(defun find-type-method (type fname)
- (cdr (assoc fname (gethash (ensure-type-name type) *type-methods*))))
-
-(defun find-applicable-type-method (type-spec fname &optional (error t))
- (flet ((find-superclass-method (class)
- (when (and class (class-finalized-p class))
-; (unless (class-finalized-p class)
-; (finalize-inheritance class))
- (dolist (super (cdr (pcl::class-precedence-list class)))
- (return-if (find-type-method super fname)))))
- (find-expanded-type-method (type-spec)
- (multiple-value-bind (expanded-type-spec expanded-p)
- (type-expand-1 type-spec)
- (cond
- (expanded-p
- (find-applicable-type-method expanded-type-spec fname nil))
- ((neq type-spec t)
- (find-applicable-type-method t fname nil))))))
-
- (or
- (typecase type-spec
- (pcl::class
- (or
- (find-type-method type-spec fname)
- (find-superclass-method type-spec)))
- (symbol
- (or
- (find-type-method type-spec fname)
- (find-expanded-type-method type-spec)
- (find-superclass-method (find-class type-spec nil))))
- (cons
- (or
- (find-type-method (first type-spec) fname)
- (find-expanded-type-method type-spec)))
- (t
- (error "Invalid type specifier ~A" type-spec)))
- (and
- error
- (error
- "No applicable method for ~A when called with type specifier ~A"
- fname type-spec)))))
-
-(defmacro deftype-method (fname type lambda-list &body body)
- `(progn
- (ensure-type-method-fun ',fname)
- (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body))
- ',fname))
-
-;; To make the compiler happy
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (define-type-method-fun translate-type-spec (type-spec))
- (define-type-method-fun size-of (type-spec))
- (define-type-method-fun translate-to-alien (type-spec expr &optional weak-ref))
- (define-type-method-fun translate-from-alien (type-spec expr &optional weak-ref))
- (define-type-method-fun cleanup-alien (type-spec sap &otional weak-ref))
- (define-type-method-fun unreference-alien (type-spec sap)))
-
-
-;;;;
-
-(defvar *type-function-cache* (make-hash-table :test #'equal))
-
-(defun get-cached-function (type-spec fname)
- (cdr (assoc fname (gethash type-spec *type-function-cache*))))
-
-(defun set-cached-function (type-spec fname function)
- (push (cons fname function) (gethash type-spec *type-function-cache*))
- function)
-
-
-(defun intern-argument-translator (type-spec)
- (or
- (get-cached-function type-spec 'argument-translator)
- (set-cached-function type-spec 'argument-translator
- (compile
- nil
- `(lambda (object)
- (declare (ignorable object))
- ,(translate-to-alien type-spec 'object t))))))
-
-(defun intern-return-value-translator (type-spec)
- (or
- (get-cached-function type-spec 'return-value-translator)
- (set-cached-function type-spec 'return-value-translator
- (compile
- nil
- `(lambda (alien)
- (declare (ignorable alien))
- ,(translate-from-alien type-spec 'alien nil))))))
-
-(defun intern-cleanup-function (type-spec)
- (or
- (get-cached-function type-spec 'cleanup-function)
- (set-cached-function type-spec 'cleanup-function
- (compile
- nil
- `(lambda (alien)
- (declare (ignorable alien))
- ,(cleanup-alien type-spec 'alien t))))))
-
-
-
-;; Returns a function to write an object of the specified type
-;; to a memory location
-(defun intern-writer-function (type-spec)
- (or
- (get-cached-function type-spec 'writer-function)
- (set-cached-function type-spec 'writer-function
- (compile
- nil
- `(lambda (value sap offset)
- (declare (ignorable value sap offset))
- (setf
- (,(sap-ref-fname type-spec) sap offset)
- ,(translate-to-alien type-spec 'value nil)))))))
-
-;; Returns a function to read an object of the specified type
-;; from a memory location
-(defun intern-reader-function (type-spec)
- (or
- (get-cached-function type-spec 'reader-function)
- (set-cached-function type-spec 'reader-function
- (compile
- nil
- `(lambda (sap offset)
- (declare (ignorable sap offset))
- ,(translate-from-alien
- type-spec `(,(sap-ref-fname type-spec) sap offset) t))))))
-
-(defun intern-destroy-function (type-spec)
- (if (atomic-type-p type-spec)
- #'(lambda (sap offset)
- (declare (ignore sap offset)))
- (or
- (get-cached-function type-spec 'destroy-function)
- (set-cached-function type-spec 'destroy-function
- (compile
- nil
- `(lambda (sap offset)
- (declare (ignorable sap offset))
- ,(unreference-alien
- type-spec `(,(sap-ref-fname type-spec) sap offset))))))))
-
-
-