;;;
;;; hgdiobj.lisp
;;;
;;; GDI objects and GDI object handles.
;;;

(cl:in-package :lh-winapi)


;;;; Storage representation.

;;; We represent GDI objects as a set of wrapper classes and an
;;; underlying integer object handle.  This is supposedly a closed
;;; class hierarchy (there is no way to add "user" GDI objects).

(defclass hgdiobj ()
  ((hgdiobj :accessor hgdiobj-hgdiobj :initarg hgdiobj)))

(defclass hpen (hgdiobj) ())
(defclass hbrush (hgdiobj) ())
(defclass hdc (hgdiobj) ())
(defclass hpalette (hgdiobj) ())
(defclass hfont (hgdiobj) ())
(defclass hbitmap (hgdiobj) ())
(defclass hrgn (hgdiobj) ())
(defclass hmetafile (hgdiobj) ())
(defclass henhmetafile (hgdiobj) ())


;;;; GDI object type mapping.

;;; When we are working with an under-specified object type
;;; (specifically HGDIOBJ) we query GDI as to exactly what type of
;;; handle we are given and use the result of the query to determine
;;; the correct wrapper class.  The enum and class below support this.

(define-alien-type gdi-object-type-id
    (enum gdi-object-type-id
	  (obj_pen 1)
	  obj_brush
	  obj_dc
	  obj_metadc
	  obj_pal
	  obj_font
	  obj_bitmap
	  obj_region
	  obj_metafile
	  obj_memdc
	  obj_extpen
	  obj_enhmetadc
	  obj_enhmetafile))

(defun class-for-gdi-object-type (type-id)
  (or (getf '(obj_pen hpen
	      obj_brush hbrush
	      obj_dc hdc
	      obj_metadc hdc
	      obj_pal hpalette
	      obj_font hfont
	      obj_bitmap hbitmap
	      obj_region hrgn
	      obj_metafile hmetafile
	      obj_memdc hdc
	      obj_extpen hpen
	      obj_enhmetadc hdc
	      obj_enhmetafile henhmetafile)
	    type-id)
      (error "Unable to find wrapper class for GDI object type ~A" type-id)))


;;;; Alien type definition.

;;; This is based on the original work done for translated alien type
;;; definition in lh-guid.lisp.  As a departure from previous work
;;; such as the hwnd.lisp type definition, this is a parameterized
;;; type with several non-parameterized type translators for the
;;; various GDI object handle types.  Additionally, naturalizing a GDI
;;; object handle declared as an HGDIOBJ (the root class of the
;;; hierarchy) invokes a lookup to determine exactly which type the
;;; object really is.  Also unlike the previous alien type definitions
;;; that I have done, there is no "interning".  A fresh wrapper can be
;;; constructed several times for the same handle.

;;; First, the basics.  Class definition, translator definition and
;;; supporting methods for type tranlsation.  We still include a type
;;; so that we don't have to worry about arg-tn or result-tn methods.

(define-alien-type-class (gdi-object :include integer
				     :include-args (signed))
    (gdi-handle-type nil :type symbol))

(define-alien-type-translator hgdiobj ()
  (make-alien-gdi-object-type :bits 32 :signed nil))

(macrolet ((translate (class)
	     `(define-alien-type-translator ,class ()
	       (make-alien-gdi-object-type :bits 32 :signed nil
		                           :gdi-handle-type ',class))))
  (translate hpen)
  (translate hbrush)
  (translate hdc)
  (translate hpalette)
  (translate hfont)
  (translate hbitmap)
  (translate hrgn)
  (translate hmetafile)
  (translate henhmetafile))

(define-alien-type-method (gdi-object :unparse) (type)
  (or (alien-gdi-object-type-gdi-handle-type type)
      'hgdiobj))

(define-alien-type-method (gdi-object :lisp-rep) (type)
  `(or ,(or (alien-gdi-object-type-gdi-handle-type type)
	    'hgdiobj)
    null))

;;; Because we're a parameterized type we actually need type= and
;;; subtypep methods (okay, we might not need a subtypep method, as
;;; they're only defined for array and pointer types in SBCL proper,
;;; but we may as well, since conceptually this -is- a pointer type).

;;; Note that if there is a defined lisp-rep type for an alien then it
;;; will be used to determine subtype relationships in some but not
;;; all circumstances instead of the subtypep method, so they must be
;;; consistent.

;;; Two gdi-objects are type= if they have the same gdi-handle-type.
(define-alien-type-method (gdi-object :type=) (type1 type2)
  (eq (alien-gdi-object-type-gdi-handle-type type1)
      (alien-gdi-object-type-gdi-handle-type type2)))

;;; Given two gdi-objects type1 and type2, type2 is subtypep type1 if
;;; type1 is an hgdiobj or if type1 and type2 are type=.
(define-alien-type-method (gdi-object :subtypep) (type1 type2)
  (and (alien-gdi-object-type-p type2)
       (or (not (alien-gdi-object-type-gdi-handle-type type1))
	   (alien-type-= type1 type2))))

;;; There is a cleverness here: If TYPE is unspecialized (that is, it
;;; is HGDIOBJ) then we determine the actual type to use at runtime.
(define-alien-type-method (gdi-object :naturalize-gen) (type alien)
  (let ((handle-type (alien-gdi-object-type-gdi-handle-type type))
	(getobjecttype (gensym))
	(object-type-id (gensym)))
    `(if (not (zerop ,alien))
      ,(if handle-type
	   `(make-instance ',handle-type 'hgdiobj ,alien)
	   `(with-alien ((,getobjecttype (function gdi-object-type-id
						   unsigned-long)
			  :extern "GetObjectType"))
	     ;; This definition of GetObjectType is defined to take
	     ;; the underlying (alien) integer handle rather than a
	     ;; proper hgdiobj, mostly to avoid either having a pile
	     ;; of eval-when goop in this file or splitting off a
	     ;; separate file just for the :naturalize-gen method.
	     (let ((,object-type-id (alien-funcall ,getobjecttype ,alien)))
	       (make-instance (class-for-gdi-object-type ,object-type-id)
			      'hgdiobj ,alien))))
      nil)))

(define-alien-type-method (gdi-object :deport-gen) (type object)
  (declare (ignore type))
  `(if ,object
    (the (unsigned-byte 32) (hgdiobj-hgdiobj ,object))
    0))


;;; EOF