Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/eXene/lib/protocol/xreply.sml
ViewVC logotype

View of /sml/trunk/src/eXene/lib/protocol/xreply.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1856 - (download) (annotate)
Wed Nov 2 22:24:39 2005 UTC (14 years, 11 months ago) by mblume
File size: 32314 byte(s)
updated runtime system, CML, and eXene to reflect recent changes to Basis
(* xreply.sml
 *
 * COPYRIGHT (c) 1990,1991 by John H. Reppy.  See COPYRIGHT file for details.
 *
 * Routines to decode reply, error and event messages received from the server.
 *
 * TODO
 *   events
 *     decodeKeymapNotify
 *   replies
 *     decodeAllocColorCellsReply
 *     decodeAllocColorPlanesReply
 *     decodeGetPointerMappingReply
 *     decodeListExtensionsReply
 *     decodeQueryExtensionReply
 *     decodeQueryKeymapReply
 *)

structure XReply =
  struct
    local
      structure W8 = Word8 and W8V = Word8Vector
      structure G = Geometry
      structure XTy = XProtTypes
      structure XEvt = XEventTypes

      val & = LargeWord.andb
      val ++ = LargeWord.orb
      infix & ++

      fun isSet(x, i) = ((x & LargeWord.<<(0w1, i)) <> 0w0)

      fun pad n = (case Word.andb(Word.fromInt n, 0w3)
	     of 0w0 => n
	      | r => (n + (4 - Word.toIntX r))
	    (* end case *))

      fun getString (bv, i, n) =
	  Byte.unpackStringVec (Word8VectorSlice.slice (bv, i, SOME n))

      val get8 = W8.toLargeWord o W8V.sub
      fun getWord8 arg = Word.fromLargeWord(W8.toLargeWord(W8V.sub arg))
      fun getInt8 arg = W8.toInt(W8V.sub arg)
      fun getSigned8 arg = W8.toIntX(W8V.sub arg)

      fun get16 (s, i) = PackWord16Big.subVec(s, i div 2)
      fun getWord16 (s, i) = Word.fromLargeWord(get16(s, i))
      fun getInt16 (s, i) = LargeWord.toInt(get16(s, i))
      fun getSigned16 (s, i) = LargeWord.toIntX(PackWord16Big.subVecX(s, i div 2))

      fun get32 (s, i) = Word32.fromLargeWord(PackWord32Big.subVec(s, i div 4))
      fun getSigned32 (s, i) =
	    Int32.fromLarge(LargeWord.toLargeInt(PackWord32Big.subVecX(s, i div 4)))
      fun getWord (s, i) = Word.fromLargeWord(get32(s, i))
      fun getInt (s, i) = LargeWord.toIntX(PackWord32Big.subVecX(s, i div 4))

      val w8vextract = Word8VectorSlice.vector o Word8VectorSlice.slice

fun wrapFn name f (s, i) = (f(s, i) handle ex => (
XDebug.errTrace(fn () => ["**** ", name, "(", Int.toString(W8V.length s), ",",
Int.toString i, ")\n"]); raise ex))
val get8 = wrapFn "get8" get8
val getWord8 = wrapFn "getWord8" getWord8
val getInt8 = wrapFn "getInt8" getInt8
val getSigned8 = wrapFn "getSigned8" getSigned8
val get16 = wrapFn "get16" get16
val getWord16 = wrapFn "getWord16" getWord16
val getInt16 = wrapFn "getInt16" getInt16
val getSigned16 = wrapFn "getSigned16" getSigned16
val get32 = wrapFn "get32" get32
val getSigned32 = wrapFn "getSigned32" getSigned32
val getWord = wrapFn "getWord" getWord
val getInt = wrapFn "getInt" getInt

      fun getList (f, sz : int) (buf, i, n) = let
	    fun get (_, 0, l) = List.rev l
	      | get (i, n, l) = get (i+sz, n-1, f(buf, i)::l)
	    in
	      get (i, n, [])
	    end

    (* get a list of strings, where each string is preceded by a one-byte length
     * field.
     *)
      fun getStringList (buf, i, n) = let
	    fun get (_, 0, l) = List.rev l
	      | get (i, n, l) = let
		  val len = getInt8(buf, i) and j = i+1
		  in
		    get (j+len, n-1, getString(buf, j, len) :: l)
		  end
	    in
	      get (i, n, [])
	    end

      val getXAtom = (XTy.XAtom o getWord)
      fun getXAtomOption arg = (case getWord arg
	     of 0w0 => NONE
	      | x => SOME(XTy.XAtom x)
	    (* end case *))
      val getXId = (XTy.XID o getWord)
      fun getXIdOption arg = (case getWord arg
	     of 0w0 => NONE
	      | x => SOME(XTy.XID x)
	    (* end case *))

      val getEventMask = (XTy.XEVTMASK o getWord)
      val getVisualId = (XTy.VISUALID o getWord)
      fun getVisualIdOption arg = (case getWord arg
	     of 0w0 => NONE
	      | x => SOME(XTy.VISUALID x)
	    (* end case *))
      val getPixel = XTy.PIXEL o getInt

(* Are time values signed??? *)
      fun getTime (s, i) = XTime.XT(get32(s, i))
      fun getTS (s, i) = (case get32(s, i)
	     of 0w0 => XTy.CurrentTime
	      | t => XTy.TimeStamp(XTime.XT t)
	    (* end case *))

      fun getBool arg = (case (W8V.sub arg) of 0w0 => false | _ => true)
      fun getPt (s, i) = G.PT{ x = getSigned16(s, i), y = getSigned16(s, i+2) }
      fun getSize (s, i) = G.SIZE{ wid = getInt16(s, i), ht = getInt16(s, i+2) }
      fun getRect (s, i) = G.RECT{
	      x = getSigned16(s, i), y = getSigned16(s, i+2),
	      wid = getInt16(s, i+4), ht = getInt16(s, i+6)
	    }
      fun getWGeom (s, i) = G.WGEOM{
	      pos = getPt(s, i), sz = getSize(s, i+4), border = getInt16(s, i+8)
	    }

      val getKeyCode = XTy.KEYCODE o getInt8

      fun getStkPos arg = (case (W8V.sub arg)
	     of 0w0 => XTy.PlaceOnTop
	      | _ => XTy.PlaceOnBottom
	    (* end case *))

      fun getFocusMode (s, i) = (case W8V.sub(s, i)
	     of 0w0 => XTy.FocusNormal | 0w1 => XTy.FocusGrab
	      | 0w2 => XTy.FocusUngrab | 0w3 => XTy.FocusWhileGrabbed
	      | _ => MLXError.impossible "bad focus mode"
	    (* end case *))
      fun getFocusDetail (s, i) = (case W8V.sub(s, i)
	     of 0w0 => XTy.FocusAncestor | 0w1 => XTy.FocusVirtual
	      | 0w2 => XTy.FocusInferior | 0w3 => XTy.FocusNonlinear
	      | 0w4 => XTy.FocusNonlinearVirtual | 0w5 => XTy.FocusPointer
	      | 0w6 => XTy.FocusPointerRoot | 0w7 => XTy.FocusNone
	      | _ => MLXError.impossible "bad focus detail"
	    (* end case *))

      fun getKeyButSet (s, i) = let val m = getWord16(s, i)
	    in
	      ( XTy.MKState(Word.andb(m, 0wxFF)),
		XTy.MBState(Word.andb(m, 0wx1F00)))
	    end

      fun getRGB (buf, i) = XTy.RGB{
	      red = getWord16(buf, i),
	      green = getWord16(buf, i+2),
	      blue = getWord16(buf, i+4)
	    }

      fun getBS (buf, i) = (case W8V.sub(buf, i)
	     of 0w0 => XTy.BS_NotUseful
	      | 0w1 => XTy.BS_WhenMapped
	      | _ => XTy.BS_Always
	    (* end case *))

      fun getFontDir (buf, i) = (case W8V.sub(buf, i)
	     of 0w0 => XTy.FontLeftToRight | 0w1 => XTy.FontRightToLeft
	      | _ => MLXError.impossible "bad font direction"
	    (* end case *))

      val getXIdList = getList (getXId, 4)
      val getXAtomList = getList (getXAtom, 4)

      local
        fun toGravity (0w1 : Word8.word) = SOME XTy.NorthWestGravity
	  | toGravity 0w2 = SOME XTy.NorthGravity
	  | toGravity 0w3 = SOME XTy.NorthEastGravity
	  | toGravity 0w4 = SOME XTy.WestGravity
	  | toGravity 0w5 = SOME XTy.CenterGravity
	  | toGravity 0w6 = SOME XTy.EastGravity
	  | toGravity 0w7 = SOME XTy.SouthWestGravity
	  | toGravity 0w8 = SOME XTy.SouthGravity
	  | toGravity 0w9 = SOME XTy.SouthEastGravity
	  | toGravity 0w10 = SOME XTy.StaticGravity
	  | toGravity _ = NONE
      in
      fun getBitGravity arg = (case toGravity(W8V.sub arg)
	     of NONE => XTy.ForgetGravity
	      | SOME g => g
	    (* end case *))
      fun getWinGravity arg = (case toGravity(W8V.sub arg)
	     of NONE => XTy.UnmapGravity
	      | SOME g => g
	    (* end case *))
      end (* local *)

      fun getRawFormat arg = (case (W8V.sub arg)
	   of 0w8 => XTy.Raw8 | 0w16 => XTy.Raw16 | 0w32 => XTy.Raw32
	    | _ => MLXError.impossible "[getRawFormat: bad ClientMessage]")

    in

  (** Get the reply from a connection request **)
    local
      val prefix_sz = 8
      fun getOrder(buf, i) = (case get8(buf, i)
	     of 0w0 => XTy.LSBFirst
	      | _ => XTy.MSBFirst)
      fun getFormat (buf, i) = XTy.FORMAT {
	      depth = getInt8(buf, i), 
	      bits_per_pixel = getInt8(buf, i+1), 
	      scanline_pad = getRawFormat(buf, i+2)
	    }
      fun getVisualDepth (buf, i, depth) = XTy.VisualDepth{
	      id = getVisualId(buf, i),
	      depth = depth,
	      class = (case W8V.sub(buf, i+4)
		 of 0w0 => XTy.StaticGray | 0w1 => XTy.GrayScale
		  | 0w2 => XTy.StaticColor | 0w3 => XTy.PseudoColor
		  | 0w4 => XTy.TrueColor | 0w5 => XTy.DirectColor
		  | _ => MLXError.impossible "bad visual depth"
		(* end case *)),
	      bits_per_rgb = getInt8(buf, i+5),
	      cmap_entries = getInt16(buf, i+6),
	      red_mask = getWord(buf, i+8),
	      green_mask = getWord(buf, i+12),
	      blue_mask = getWord(buf, i+16)
	    }
      fun getVisualDepthList (buf, i, ndepths) = let
	    fun getDepths (0, i, l) = (List.rev l, i)
	      | getDepths (ndepths, i, l) = let
		  val depth = getInt8(buf, i)
		  in
		    case (getInt16(buf, i+2))
		     of 0 => getDepths (ndepths-1, i+8, (XTy.Depth depth)::l)
		      | nVisuals => getVisuals (ndepths-1, depth, nVisuals, i+8, l)
		  end
	    and getVisuals (ndepths, _, 0, i, l) = getDepths (ndepths, i, l)
	      | getVisuals (ndepths, depth, k, i, l) =
		  getVisuals (ndepths, depth, k-1, i+24,
		    getVisualDepth(buf, i, depth)::l)
	    in
	      getDepths (ndepths, i, [])
	    end
      fun getScreen (buf, i) = let
	    val (vdepths, next) = getVisualDepthList(buf, i+40, getInt8(buf, i+39))
	    in (
	      {
		root_win = getXId(buf, i),
		cmap = getXId(buf, i+4),
		white = getPixel(buf, i+8),
		black = getPixel(buf, i+12),
		input_masks = getEventMask(buf, i+16),
		pixel_wid = getInt16(buf, i+20),
		pixel_ht = getInt16(buf, i+22),
		mm_wid = getInt16(buf, i+24),
		mm_ht = getInt16(buf, i+26),
		installed_maps = {min = getInt16(buf, i+28), max = getInt16(buf, i+30)},
		root_visualid = getVisualId(buf, i+32),
		backing_store = getBS(buf, i+36),
		save_unders = getBool(buf, i+37),
		root_depth = getInt8(buf, i+38),
		visualdepths = vdepths
	      }, next)
	    end
      val getFormats = getList (getFormat, 8)
      fun getScreens (buf, i, nscreens) = let
	    fun get (0, _, l) = List.rev l
	      | get (n, i, l) = let
		  val (scr, next) = getScreen(buf, i)
		  in
		    get(n-1, next, scr::l)
		  end
	    in
	      get (nscreens, i, [])
	    end
    in
    fun decodeConnectReqReply (prefix, msg) = let
	  val vendor_len = getInt16(msg, 16)
	  val nscreens = getInt8(msg, 20)
	  val nformats = getInt8(msg, 21)
	  val format_offset = pad (32 + vendor_len)
	  val screen_offset = format_offset + 8*nformats
	  in {
	    protocol_version = {
		major = getInt16(prefix, 2),
		minor = getInt16(prefix, 4)
	      },
	    release_num = getInt(msg, 0),
	    rsrc_id_base = getWord(msg, 4),
	    rsrc_id_mask = getWord(msg, 8),
	    motion_buf_sz = getInt(msg, 12),
	    max_req_len = getInt16(msg, 18),
	    im_byte_order = getOrder(msg, 22),
	    bitmap_order = getOrder(msg, 23),
	    bitmap_scanline_unit = getRawFormat(msg, 24),
	    bitmap_scanline_pad = getRawFormat(msg, 25),
	    min_keycode = getKeyCode(msg, 26),
	    max_keycode = getKeyCode(msg, 27),
	    vendor = getString(msg, 32, vendor_len),
	    formats = getFormats(msg, format_offset, nformats),
	    roots = getScreens(msg, screen_offset, nscreens)
	  } end
    end (* local *)


  (** decode event messages **)

    local
      fun getKeyXEvt buf = let val (mks, mbs) = getKeyButSet(buf, 28)
	    in {
	      keycode = getKeyCode(buf, 1),
	      time = getTime(buf, 4),
	      root = getXId(buf, 8),
	      event = getXId(buf, 12),
	      child = getXIdOption(buf, 16),
	      root_pt = getPt(buf, 20),
	      event_pt = getPt(buf, 24),
	      mod_state = mks,
	      mbut_state = mbs,
	      same_screen = getBool(buf, 30)
	    } end
      fun getButtonXEvt buf = let val (mks, mbs) = getKeyButSet(buf, 28)
	    in {
	      button = XTy.MButton(getInt8(buf, 1)),
	      time = getTime(buf, 4),
	      root = getXId(buf, 8),
	      event = getXId(buf, 12),
	      child = getXIdOption(buf, 16),
	      root_pt = getPt(buf, 20),
	      event_pt = getPt(buf, 24),
	      mod_state = mks,
	      mbut_state = mbs,
	      same_screen = getBool(buf, 30)
	    } end
      fun decodeMotionNotify buf = let
	    val (mks, mbs) = getKeyButSet(buf, 28)
	    in
	      XEvt.MotionNotifyXEvt {
		  hint = getBool(buf, 1),
		  time = getTime(buf, 4),
		  root = getXId(buf, 8),
		  event = getXId(buf, 12),
		  child = getXIdOption(buf, 16),
		  root_pt = getPt(buf, 20),
		  event_pt = getPt(buf, 24),
		  mod_state = mks,
		  mbut_state = mbs,
		  same_screen = getBool(buf, 30)
		}
	    end
      fun getEnterLeaveXEvt buf = let
	    val (mks, mbs) = getKeyButSet(buf, 28)
	    val flags = get8(buf, 31)
	    in {
	      detail = getFocusDetail(buf, 1),
	      time = getTime(buf, 4),
	      root = getXId(buf, 8),
	      event = getXId(buf, 12),
	      child = getXIdOption(buf, 16),
	      root_pt = getPt(buf, 20),
	      event_pt = getPt(buf, 24),
	      mod_state = mks,
	      mbut_state = mbs,
	      mode = getFocusMode(buf, 30),
	      focus = isSet(flags, 0w0),
	      same_screen = isSet(flags, 0w1)
	    } end
      fun getFocusXEvt buf = {
	      detail = getFocusDetail(buf, 1),
	      event = getXId(buf, 4),
	      mode = getFocusMode(buf, 8)
	    }
      fun decodeKeymapNotify buf =
	    XEvt.KeymapNotifyXEvt {}(** NOTE: no seqn # **) (** FIX **)
      fun decodeExpose buf = XEvt.ExposeXEvt {
	      window = getXId(buf, 4),
	      rects = [getRect(buf, 8)],
	      count = getInt16(buf, 16)
	    }
      fun decodeGraphicsExpose buf = XEvt.GraphicsExposeXEvt {
	      drawable = getXId(buf, 4),
	      rect = getRect(buf, 8),
	      minor_opcode = getWord16(buf, 16),
	      count = getInt16(buf, 18),
	      major_opcode = getWord16(buf, 20)
	    }
      fun decodeNoExpose buf = XEvt.NoExposeXEvt {
	      drawable = getXId(buf, 4),
	      minor_opcode = getWord16(buf, 8),
	      major_opcode = getWord16(buf, 10)
	    }
      fun decodeVisibilityNotify buf = XEvt.VisibilityNotifyXEvt {
	      window = getXId(buf, 4),
	      state = (case W8V.sub(buf, 8)
		 of 0w0 => XTy.VisibilityUnobscured
		  | 0w1 => XTy.VisibilityPartiallyObscured
		  | 0w2 => XTy.VisibilityFullyObscured
		  | _ => MLXError.impossible "bad VisibilityNotify"
		(* end case *))
	    }
      fun decodeCreateNotify buf = XEvt.CreateNotifyXEvt {
	      parent = getXId(buf, 4),
	      window = getXId(buf, 8),
	      rect = getRect(buf, 12),
	      border_wid = getInt16(buf, 20),
	      override_redirect = getBool(buf, 21)
	    }
      fun decodeDestroyNotify buf = XEvt.DestroyNotifyXEvt {
	      event = getXId(buf, 4),
	      window = getXId(buf, 8)
	    }
      fun decodeUnmapNotify buf = XEvt.UnmapNotifyXEvt {
	      event = getXId(buf, 4),
	      window = getXId(buf, 8),
	      from_config = getBool(buf, 12)
	    }
      fun decodeMapNotify buf = XEvt.MapNotifyXEvt {
	      event = getXId(buf, 4),
	      window = getXId(buf, 8),
	      override_redirect = getBool(buf, 12)
	    }
      fun decodeMapRequest buf = XEvt.MapRequestXEvt {
	      parent = getXId(buf, 4),
	      window = getXId(buf, 8)
	    }
      fun decodeReparentNotify buf = XEvt.ReparentNotifyXEvt {
	      event = getXId(buf, 4),
	      parent = getXId(buf, 8),
	      window = getXId(buf, 12),
	      corner = getPt(buf, 16),
	      override_redirect = getBool(buf, 20)
	    }
      fun decodeConfigureNotify buf = XEvt.ConfigureNotifyXEvt {
	      event = getXId(buf, 4),
	      window = getXId(buf, 8),
	      sibling = getXIdOption(buf, 12),
	      rect = getRect(buf, 16),
	      border_wid = getInt16(buf, 20),
	      override_redirect = getBool(buf, 22)
	    }
      fun decodeConfigureRequest buf = let
	    val mask = get16(buf, 26)
	    fun getOpt getFn (i, j) = if isSet(mask, i)
		  then SOME(getFn(buf, j))
		  else NONE
	    in
	      XEvt.ConfigureRequestXEvt{
		  stack_mode = if isSet(mask, 0w6)
		    then (case W8V.sub(buf, 1)
		       of 0w0 => SOME XTy.Above
		        | 0w1 => SOME XTy.Below
		        | 0w2 => SOME XTy.TopIf
		        | 0w3 => SOME XTy.BottomIf
		        | 0w4 => SOME XTy.Opposite
		        | _ => MLXError.impossible "bad ConfigureRequest"
		      (* end case *))
		    else NONE,
		parent = getXId(buf, 4),
		window = getXId(buf, 8),
		sibling = getXIdOption(buf, 12),
		x = getOpt getSigned16 (0w0, 16),
		y = getOpt getSigned16 (0w1, 18),
		wid = getOpt getInt16 (0w2, 20),
		ht = getOpt getInt16 (0w3, 22),
		border_wid = getOpt getInt16 (0w4, 24)
	      }
	    end
      fun decodeGravityNotify buf = XEvt.GravityNotifyXEvt {
	      event = getXId(buf, 4),
	      window = getXId(buf, 8),
	      corner = getPt(buf, 12)
	    }
      fun decodeResizeRequest buf = XEvt.ResizeRequestXEvt {
	      window = getXId(buf, 4),
	      req_sz = getSize(buf, 8)
	    }
      fun decodeCirculateNotify buf = XEvt.CirculateNotifyXEvt {
	      event = getXId(buf, 4),
	      window = getXId(buf, 8),
	      parent = getXId(buf, 12),
	      place = getStkPos(buf, 16)
	    }
      fun decodeCirculateRequest buf = XEvt.CirculateRequestXEvt {
	      parent = getXId(buf, 4),
	      window = getXId(buf, 8),
	      place = getStkPos(buf, 12)
	    }
      fun decodePropertyNotify buf = XEvt.PropertyNotifyXEvt {
	      window = getXId(buf, 4),
	      atom = getXAtom(buf, 8),
	      time = getTime(buf, 12),
	      deleted = getBool(buf, 16)		
	    }
      fun decodeSelectionClear buf = XEvt.SelectionClearXEvt {
	      time = getTime(buf, 4),
	      owner = getXId(buf, 8),
	      selection = getXAtom(buf, 12)
	    }
      fun decodeSelectionRequest buf = XEvt.SelectionRequestXEvt {
	      time = getTS(buf, 4),
	      owner = getXId(buf, 8),
	      requestor = getXId(buf, 12),
	      selection = getXAtom(buf, 16),
	      target = getXAtom(buf, 20),
	      property = getXAtomOption(buf, 24)
	    }
      fun decodeSelectionNotify buf = XEvt.SelectionNotifyXEvt {
	      time = getTS(buf, 4),
	      requestor = getXId(buf, 8),
	      selection = getXAtom(buf, 12),
	      target = getXAtom(buf, 16),
	      property = getXAtomOption(buf, 20)
	    }
      fun decodeColormapNotify buf = XEvt.ColormapNotifyXEvt {
	      window = getXId(buf, 4),
	      cmap = getXIdOption(buf, 8),
	      new = getBool(buf, 12),
	      installed = getBool(buf, 13)
	    }
      fun decodeClientMessage buf = XEvt.ClientMessageXEvt {
	      window = getXId(buf, 4),
	      typ = getXAtom(buf, 8),
	      value = XTy.RAW_DATA {
		  format = getRawFormat(buf, 1),
		  data = w8vextract(buf, 12, SOME 20)
		}
	    }
      fun decodeMappingNotify buf = (case W8V.sub(buf, 4)
	   of 0w0 => XEvt.ModifierMappingNotifyXEvt
	    | 0w1 => XEvt.KeyboardMappingNotifyXEvt {
		      first_keycode = getKeyCode(buf, 5),
		      count = getInt8(buf, 6)
		    }
	    | 0w2 => XEvt.PointerMappingNotifyXEvt
	    | _ => MLXError.impossible "bad MappingNotify")
    in
    fun decodeXEvent (code : Word8.word, buf) = let
	  val n = W8.andb(code, 0wx7f)
	  val xevt = case n
	       of 0w2 => XEvt.KeyPressXEvt (getKeyXEvt buf)
		| 0w3 => XEvt.KeyReleaseXEvt (getKeyXEvt buf)
		| 0w4 => XEvt.ButtonPressXEvt (getButtonXEvt buf)
		| 0w5 => XEvt.ButtonReleaseXEvt (getButtonXEvt buf)
		| 0w6 => decodeMotionNotify buf
		| 0w7 => XEvt.EnterNotifyXEvt (getEnterLeaveXEvt buf)
		| 0w8 => XEvt.LeaveNotifyXEvt (getEnterLeaveXEvt buf)
		| 0w9 => XEvt.FocusInXEvt (getFocusXEvt buf)
		| 0w10 => XEvt.FocusOutXEvt (getFocusXEvt buf)
		| 0w11 => decodeKeymapNotify buf
		| 0w12 => decodeExpose buf
		| 0w13 => decodeGraphicsExpose buf
		| 0w14 => decodeNoExpose buf
		| 0w15 => decodeVisibilityNotify buf
		| 0w16 => decodeCreateNotify buf
		| 0w17 => decodeDestroyNotify buf
		| 0w18 => decodeUnmapNotify buf
		| 0w19 => decodeMapNotify buf
		| 0w20 => decodeMapRequest buf
		| 0w21 => decodeReparentNotify buf
		| 0w22 => decodeConfigureNotify buf
		| 0w23 => decodeConfigureRequest buf
		| 0w24 => decodeGravityNotify buf
		| 0w25 => decodeResizeRequest buf
		| 0w26 => decodeCirculateNotify buf
		| 0w27 => decodeCirculateRequest buf
		| 0w28 => decodePropertyNotify buf
 		| 0w29 => decodeSelectionClear buf
		| 0w30 => decodeSelectionRequest buf
		| 0w31 => decodeSelectionNotify buf
		| 0w32 => decodeColormapNotify buf
		| 0w33 => decodeClientMessage buf
		| 0w34 => decodeMappingNotify buf
		| _ => MLXError.impossible "bad event code"
	  in
	    (code = n, xevt)
	  end
  (* we export the decode functions for reporting graphics exposures *)
    val decodeGraphicsExpose = decodeGraphicsExpose
    val decodeNoExpose = decodeNoExpose
    end (* local *)


  (** decode error messages **)
      local
	structure XErr = XErrors
	fun get_err (kind, buf) = XErr.XErr{
		kind = kind,
		minor_op = getWord16(buf, 8),
		major_op = W8V.sub(buf, 10)
	      }
      in
      fun decodeError buf = (case (W8V.sub (buf, 1))
	   of 0w1 => get_err (XErr.BadRequest, buf)
	    | 0w2 => get_err (XErr.BadValue(getString(buf, 4, 4)), buf)
	    | 0w3 => get_err (XErr.BadWindow(getXId(buf, 4)), buf)
	    | 0w4 => get_err (XErr.BadPixmap(getXId(buf, 4)), buf)
	    | 0w5 => get_err (XErr.BadAtom(getXId(buf, 4)), buf)
	    | 0w6 => get_err (XErr.BadCursor(getXId(buf, 4)), buf)
	    | 0w7 => get_err (XErr.BadFont(getXId(buf, 4)), buf)
	    | 0w8 => get_err (XErr.BadMatch, buf)
	    | 0w9 => get_err (XErr.BadDrawable(getXId(buf, 4)), buf)
	    | 0w10 => get_err (XErr.BadAccess, buf)
	    | 0w11 => get_err (XErr.BadAlloc, buf)
	    | 0w12 => get_err (XErr.BadColor(getXId(buf, 4)), buf)
	    | 0w13 => get_err (XErr.BadGC(getXId(buf, 4)), buf)
	    | 0w14 => get_err (XErr.BadIDChoice(getXId(buf, 4)), buf)
	    | 0w15 => get_err (XErr.BadName, buf)
	    | 0w16 => get_err (XErr.BadLength, buf)
	    | 0w17 => get_err (XErr.BadImplementation, buf)
	    | _ => MLXError.impossible "bad error number")
      end (* local *)


  (** decode reply messages **)

    fun decodeGetWindowAttributesReply msg = {
	    backing_store = getBS(msg, 1),
	    visual = getVisualId(msg, 8),
	    input_only = (case get16(msg, 12)
	       of 0w1 => false | 0w2 => true
		| _ => MLXError.impossible "bad GetWindowAttributes reply"
	      (* end case *)),
	    bit_gravity = getBitGravity(msg, 14),
	    win_gravity = getWinGravity(msg, 15),
	    backing_planes = XTy.PLANEMASK(getWord(msg, 16)),
	    backing_pixel = getPixel(msg,20),
	    save_under = getBool(msg, 24),
	    map_is_installed = getBool(msg, 25),
	    map_state = (case W8V.sub(msg, 26)
	       of 0w0 => XTy.WinIsUnmapped
		| 0w1 => XTy.WinIsUnviewable
		| 0w2 => XTy.WinIsViewable
		| _ => MLXError.impossible "bad GetWindowAttributes reply"
	      (* end case *)),
	    override_redirect = getBool(msg, 27),
	    colormap = getXIdOption(msg, 28),
	    all_event_mask = getEventMask(msg, 32),
	    event_mask = getEventMask(msg, 36),
	    do_not_propagate = getEventMask(msg, 40)
	  }

    fun decodeAllocColorCellsReply msg = {
	    err = MLXError.impossible "unimplemented" (*** FIX ***)
	  }
    fun decodeAllocColorPlanesReply msg = {
	    err = MLXError.impossible "unimplemented" (*** FIX ***)
	  }

    fun decodeAllocColorReply msg = {
	    visual_rgb = getRGB(msg, 8),
	    pixel = getPixel(msg, 16)
	  }

    fun decodeAllocNamedColorReply msg = {
	    pixel = getPixel(msg, 8),
	    exact_rgb = getRGB(msg, 12),
	    visual_rgb = getRGB(msg, 18)
	  }

    fun decodeGetAtomNameReply msg = getString(msg, 32, getInt16(msg, 8))

    fun decodeGetFontPathReply msg = getStringList (msg, 32, getInt16(msg, 8))

    fun decodeGetGeometryReply msg = {
	    depth = getInt8(msg, 1),
	    root = getXId(msg, 8),
	    geom = getWGeom(msg, 12)
	  }

    fun decodeGetImageReply msg = {
	    depth = getInt8(msg, 1),
	    visualid = getVisualIdOption(msg, 8),
	    data = w8vextract(msg, 32, SOME(4*getInt(msg, 4)))
	  }

    fun decodeGetInputFocusReply msg = {
	    revert_to = (case W8V.sub(msg, 1)
	       of 0w0 => XTy.RevertToNone
		| 0w1 => XTy.RevertToPointerRoot
		| _ => XTy.RevertToParent
	      (* end case *)),
	    focus = (case getWord(msg, 8)
	       of 0w0 => XTy.InputFocus_None
		| 0w1 => XTy.InputFocus_PointerRoot
		| w => XTy.InputFocus_Window(XTy.XID w)
	      (* end case *))
	  }

    fun decodeGetKeyboardControlReply msg = {
	    glob_auto_repeat = getBool(msg, 1),
	    led_mask = get32(msg, 8),
	    key_click_pct = getInt8(msg, 12),
	    bell_pct = getInt8(msg, 13),
	    bell_pitch = getInt16(msg, 14),
	    bell_duration = getInt16(msg, 16),
	    auto_repeats = w8vextract(msg, 20, SOME 32)
	  }

    fun decodeGetKeyboardMappingReply msg = let
	  val symsPerCode = getInt8(msg, 1)
	  val nKeyCodes = getInt(msg, 4) div symsPerCode
	(* get the keysyms bound to a given keycode;  Discard trailing NoSymbols,
	 * but include intermediate ones. *)
	  fun cleanTl (XTy.NoSymbol :: r) = cleanTl r
	    | cleanTl l = rev l
	  fun getSyms (i, 0, l) = cleanTl l
	    | getSyms (i, j, l) = (case getInt(msg, i)
	       of 0 => getSyms(i+4, j-1, XTy.NoSymbol :: l)
		| k => getSyms(i+4, j-1, (XTy.KEYSYM k) :: l))
	  in
	    getList (fn (_, i) => getSyms(i, symsPerCode, []), symsPerCode*4)
	      (msg, 32, nKeyCodes)
          end

    fun decodeGetModifierMappingReply msg = let
	  val codesPerMod = getInt8(msg, 1)
	  fun getSyms k = let
		fun get (i, 0) = []
		  | get (i, j) = (case getInt8(msg, i)
		       of 0 => get(i+1, j-1)    (* 0 == unused *)
		        | k => (XTy.KEYCODE k) :: get(i+1, j-1)
		      (* end case *))
		in
		  get (32 + codesPerMod*k, codesPerMod)
		end
	  in {
	    shift_keycodes = getSyms 0,
	    lock_keycodes = getSyms 1,
	    cntl_keycodes = getSyms 2,
	    mod1_keycodes = getSyms 3,
	    mod2_keycodes = getSyms 4,
	    mod3_keycodes = getSyms 5,
	    mod4_keycodes = getSyms 6,
	    mod5_keycodes = getSyms 7
          } end

    local
      val getEvts = getList
	    ((fn (buf, i) => { time = getTime(buf, i), coord = getPt(buf, i+4) }), 8)
    in
    fun decodeGetMotionEventsReply msg = getEvts (msg, 32, getInt16(msg, 8))
    end (* local *)

    fun decodeGetPointerControlReply msg = {
	    acceleration_numerator = get16(msg, 8),
	    acceleration_denominator = get16(msg, 10),
	    threshold = get16(msg, 12)
	  }

    fun decodeGetPointerMappingReply msg = {
	    err = MLXError.impossible "unimplemented" (*** FIX ***)
	  }

    fun decodeGetPropertyReply msg = (case getWord(msg, 8)
	   of 0w0 => NONE
	    | t => let
		val nitems = getInt(msg, 16)
		val (fmt, nbytes) = (case W8V.sub(msg, 1)
		     of 0w8 => (XTy.Raw8, nitems)
		      | 0w16 => (XTy.Raw16, 2*nitems)
		      | 0w32 => (XTy.Raw32, 4*nitems)
		      | _ => MLXError.impossible "bad GetProperty reply"
		    (* end case *))
		in
		  SOME {
		      typ = XTy.XAtom t,
		      bytes_after = getInt(msg, 12),
		      value = XTy.RAW_DATA {
			  format = fmt,
			  data = w8vextract(msg, 32, SOME nbytes)
			}
		    }
		end)

    fun decodeGetScreenSaverReply msg = {
	    timeout = get16(msg, 8),
	    interval = get16(msg, 10),
	    prefer_blanking = getBool(msg, 12),
	    allow_exposures = getBool(msg, 13)
	  }

    fun decodeGetSelectionOwnerReply msg = getXIdOption(msg, 8)

    local
      fun decodeGrabReply msg = (case W8V.sub(msg, 1)
	     of 0w0 => XTy.GrabSuccess | 0w1 => XTy.AlreadyGrabbed
	      | 0w2 => XTy.GrabInvalidTime | 0w3 => XTy.GrabNotViewable
	      | _ => XTy.GrabFrozen
	    (* end case *))
    in
    val decodeGrabKeyboardReply = decodeGrabReply
    val decodeGrabPointerReply = decodeGrabReply
    end (* local *)

    fun decodeInternAtomReply msg = getXAtom(msg, 8)

    fun decodeListExtensionsReply msg = {
	    err = MLXError.impossible "unimplemented" (*** FIX ***)
	  }

    fun decodeListFontsReply msg = getStringList (msg, 32, getInt16(msg, 8))

    local
      fun getHostList (buf, n) = let
	    fun get (_, 0, l) = l
	      | get (i, n, l) = let
		  val addrLen = getInt16(buf, i+2)
		  val addr = getString(buf, i+4, addrLen)
		  val host = case W8V.sub(buf, i)
			 of 0w0 => XTy.InternetHost addr
			  | 0w1 => XTy.DECnetHost addr
			  | 0w2 => XTy.ChaosHost addr
			  | _ => raise (MLXError.xerror "unknown host family"
			(* end case *))
		  in
		    get (i+(pad addrLen)+4, n-1, host::l)
		  end
	    in
	      get (32, n, [])
	    end
    in
    fun decodeListHostsReply msg = {
	    enabled = getBool(msg, 1),
	    hosts = getHostList(msg, getInt16(msg, 8))
	  }
    end (* local *)

    fun decodeListInstalledColormapsReply msg = getXIdList(msg, 32, getInt16(msg, 8))

    fun decodeListPropertiesReply msg = getXAtomList(msg, 32, getInt16(msg, 8))

    fun decodeLookupColorReply msg = {
	    exact_rgb = getRGB(msg, 8),
	    visual_rgb = getRGB(msg, 14)
	  }

    fun decodeQueryBestSizeReply msg = {
	    wid = getInt16(msg, 8),
	    ht = getInt16(msg, 10)
	  }

    local
      val getRGBList = getList (getRGB, 8)
    in
    fun decodeQueryColorsReply msg = getRGBList(msg, 32, getInt16(msg, 8))
    end (* local *)

    fun decodeQueryExtensionReply msg = {
	    err = MLXError.impossible "unimplemented" (*** FIX ***)
	  }

    local
      val getProps = getList ((fn (buf, i) => XTy.FontProp{
		name = getXAtom(buf, i),
		value = get32(buf, i+4)
	      }), 8)
      fun getCharInfo (buf, i) = XTy.CharInfo{
		left_bearing = getSigned16(buf, i),
		right_bearing = getSigned16(buf, i+2),
		char_wid = getSigned16(buf, i+4),
		ascent = getSigned16(buf, i+6),
		descent = getSigned16(buf, i+8),
		attributes = getWord16(buf, i+10)
	      }
      val getCharInfoList = getList (getCharInfo, 12)
      fun getInfo buf = let
	    val n_props = getInt16(buf, 46)
	    in {
	      min_bounds = getCharInfo(buf, 8),
	      max_bounds = getCharInfo(buf, 24),
	      min_char = getInt16(buf, 40),
	      max_char = getInt16(buf, 42),
	      default_char = getInt16(buf, 44),
	      draw_dir = getFontDir(buf, 48),
	      min_byte1 = getInt8(buf, 49),
	      max_byte1 = getInt8(buf, 50),
	      all_chars_exist = getBool(buf, 51),
	      font_ascent = getInt16(buf, 52),
	      font_descent = getInt16(buf, 54),
	      n_props = n_props,
	      properties = getProps(buf, 60, n_props)
	    } end
    in
(****** THIS GENERATES MULTIPLE REPLYS ****
  (* this gets a list of font name/info replies *)
    fun decodeListFontsWithInfoReply msg = let
	  fun getList l = let
	    val (msg, extra) = getReply (conn, sizeOfListFontsWithInfoReply)
	    val name_len = get8(msg, 1)
	    in
	      if (name_len = 0)
		then (* this is the last in a series of replies *)
		  (rev l)
		else let
		  val info = getInfo(msg, extra)
		  val reply = {
			  min_bounds = #min_bounds info,
			  max_bounds = #max_bounds info,
			  min_char = #min_char info,
			  max_char = #max_char info,
			  default_char = #default_char info,
			  draw_dir = #draw_dir info,
			  min_byte1 = #min_byte1 info,
			  max_byte1 = #max_byte1 info,
			  all_chars_exist = #all_chars_exist info,
			  font_ascent = #font_ascent info,
			  font_descent = #font_descent info,
			  replies_hint = get32(msg, 56),
			  properties = #properties info,
			  name = getString(extra, 8*(#n_props info), name_len)
			}
		  in
		    getList (reply :: l)
		  end
	    end (* getList *)
	  in
	    getList []
	  end (* getListFontsWithInfoReply *)
*********)

    fun decodeQueryFontReply msg = let
	  val info = getInfo msg
	  in {
	    min_bounds = #min_bounds info,
	    max_bounds = #max_bounds info,
	    min_char = #min_char info,
	    max_char = #max_char info,
	    default_char = #default_char info,
	    draw_dir = #draw_dir info,
	    min_byte1 = #min_byte1 info,
	    max_byte1 = #max_byte1 info,
	    all_chars_exist = #all_chars_exist info,
	    font_ascent = #font_ascent info,
	    font_descent = #font_descent info,
	    properties = #properties info,
	    char_infos = getCharInfoList(msg, 60+8*(#n_props info), getInt(msg, 56))
	  } end
    end (* local *)

    fun decodeQueryKeymapReply msg = {
	    err = MLXError.impossible "unimplemented" (*** FIX ***)
	  }

    fun decodeQueryPointerReply msg = let val (mks, mbs) = getKeyButSet(msg, 24)
	  in {
	    same_scr = getBool(msg, 1),
	    root = getXId(msg, 8),
	    child = getXIdOption(msg, 12),
	    root_pt = getPt(msg, 16),
	    win_pt = getPt(msg, 20),
	    mod_state = mks,
	    mbut_state = mbs
	  } end

    fun decodeQueryTextExtentsReply msg = {
	    draw_dir = getFontDir(msg, 1),
	    font_ascent = get16(msg, 8),
	    font_descent = get16(msg, 10),
	    overall_ascent = get16(msg, 12),
	    overall_descent = get16(msg, 14),
	    overall_wid = get16(msg, 16),
	    overall_left = get16(msg, 18),
	    overall_right = get16(msg, 20)
	  }

    fun decodeQueryTreeReply msg = {
	    root = getXId(msg, 8),
	    parent = getXIdOption(msg, 12),
	    children = getXIdList (msg, 32, getInt16(msg, 16)) 
	  }

    local
      fun getSetMappingReply msg = (case get8(msg, 1)
	     of 0w0 => XTy.MappingSuccess
	      | 0w1 => XTy.MappingBusy
	      | _ => XTy.MappingFailed
	    (* end case *))
    in
    val decodeSetModifierMappingReply = getSetMappingReply
    val decodeSetPointerMappingReply = getSetMappingReply
    end (* local *)

    fun decodeTranslateCoordsReply msg = {
	    child = getXIdOption(msg, 8),
	    dst_pt = getPt(msg, 12)
	  }

    end (* local open XTypes *)

  end (* XReply *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0