⟦d8b2c3c6e⟧

TextFile

% Copyright    Barbara Liskov    1985, 1986

x_display = cluster is init,
		       root, width, height, device, protocol, planes, cells,
		       grab, ungrab,
		       alloc_color, alloc_cell, alloc_cells,
		       free_color, free_colors,
		       store_color, store_colors, query_color, lookup_color,
		       black, white

rep = null

own base: x_window
own rwidth: int
own rheight: int
own devid: int
own numproto: int
own numplanes: int
own numcells: int
own haveblack: bool
own blackp: x_pixmap
own havewhite: bool
own whitep: x_pixmap
own colbuf: _bytevec

init = proc (display: string) signals (error(string))
    qw = sequence[_wordvec]
    if string$empty(display)
       then display := _environ("DISPLAY")
	       except when not_found: end
       end
    num: int := string$indexc(':', display)
    if num ~= 0
       then display, num := string$substr(display, 1, num - 1),
			    int$parse(string$rest(display, num + 1))
       end
    addrs: qw := qw$new()
    if string$empty(display)  cor  display = "unix"
       then addrs := qw$addh(addrs,
			     _cvt[string, _wordvec]("\000\001/tmp/X" ||
						    int$unparse(num)))
            addrs := qw$addh(addrs,
			     _cvt[string, _wordvec]("\000\001/dev/X" ||
						    int$unparse(num)))
       end
    if string$empty(display)  cor  display ~= "unix"
       then if string$empty(display)
	       then display := _host_name() end
	    l, r: int := host_address(display)
	       except when not_found, bad_address: signal error("bad host") end
	    addr: _wordvec := _wordvec$create(4)
	    _wordvec$wstore(addr, 1, 2)
	    num := num + 5900
	    _wordvec$bstore(addr, 3, num / 2**8)
	    _wordvec$bstore(addr, 4, num)
	    _wordvec$bstore(addr, 5, r)
	    _wordvec$bstore(addr, 6, r / 2**8)
	    _wordvec$bstore(addr, 7, l)
	    _wordvec$bstore(addr, 8, l / 2**8)
	    addrs := qw$addh(addrs, addr)
       end
    err: string := ""
    for addr: _wordvec in qw$elements(addrs) do
	x_buf$init(addr)
	   except when error (why: string):
		       err := why
		       continue
		  end
	err := ""
	break
	end
    if ~string$empty(err)
       then signal error(err) end
    x_buf$setup(x_setup, 0, 0, 0)
    x_buf$receive()
    base := _cvt[int, x_window](x_buf$get_lp0())
    rwidth := 0
    rheight := 0
    numproto := x_buf$get_sp2()
    devid := x_buf$get_sp3()
    numplanes := x_buf$get_sp4()
    numcells := x_buf$get_sp5() // 2**16
    haveblack := false
    havewhite := false
    colbuf := _bytevec$create(8)
    x_input$init()
    end init

root = proc () returns (x_window)
    return(base)
    end root

width = proc () returns (int)
    if rwidth = 0
       then x, y, w, h, b, s, k: int, i: x_window := x_window$query(base)
	    rwidth := w
	    rheight := h
       end
    return(rwidth)
    end width

height = proc () returns (int)
    if rheight = 0
       then x, y, w, h, b, s, k: int, i: x_window := x_window$query(base)
	    rwidth := w
	    rheight := h
       end
    return(rheight)
    end height

device = proc () returns (int)
    return(devid)
    end device

protocol = proc () returns (int)
    return(numproto)
    end protocol

planes = proc () returns (int)
    return(numplanes)
    end planes

cells = proc () returns (int)
    return(numcells)
    end cells

grab = proc ()
    x_buf$setup(x_grabserver, 0, 0, 0)
    end grab

ungrab = proc ()
    x_buf$setup(x_ungrabserver, 0, 0, 0)
    end ungrab

alloc_color = proc (red, green, blue: int) returns (int)
					   signals (error(string))
    x_buf$setup(x_getcolor, 0, 0, 0)
    x_buf$set_s0123(red, green, blue, 0)
    x_buf$receive()
       resignal error
    return(x_buf$get_sp0() // 2**16)
    end alloc_color

alloc_cell = proc () returns (int) signals (error(string))
    x_buf$setup(x_getcolorcells, 0, 0, 0)
    x_buf$set_s01(1, 0)
    x_buf$receive()
       resignal error
    b: _bytevec := _bytevec$create(2)
    x_buf$receive_data(b)
    return(_wordvec$wfetch(b2w(b), 1))
    end alloc_cell

alloc_cells = proc (ncolors, nplanes: int, contig: bool)
			       returns (pixellist, int) signals (error(string))
    if contig
       then x_buf$setup(x_getcolorcells, 1, 0, 0)
       else x_buf$setup(x_getcolorcells, 0, 0, 0)
       end
    x_buf$set_s01(ncolors, nplanes)
    x_buf$receive()
       resignal error
    mask: int := x_buf$get_sp0() // 2**16
    pixels: pixellist := pixellist$fill(1, ncolors, 0)
    if ncolors > 0
       then b: _bytevec := _bytevec$create(ncolors * 2)
	    x_buf$receive_data(b)
	    for i: int in int$from_to_by(ncolors, 1, -1) do
		pixels[i] := _wordvec$wfetch(b2w(b), i * 2 - 1)
		end
       end
    return(pixels, mask)
    end alloc_cells

free_color = proc (pixel: int)
    x_buf$setup(x_freecolors, 0, 0, 0)
    x_buf$set_s0(1)
    b: _bytevec := _bytevec$create(2)
    _wordvec$wstore(b2w(b), 1, pixel)
    x_buf$send_data(b, 1, 2)
    end free_color

free_colors = proc (pixels: pixellist, mask: int)
    x_buf$setup(x_freecolors, 0, mask, 0)
    x_buf$set_s0(pixellist$size(pixels))
    b: _bytevec := _bytevec$create(pixellist$size(pixels) * 2)
    i: int := 1
    for pixel: int in pixellist$elements(pixels) do
	_wordvec$wstore(b2w(b), i, pixel)
	i := i + 2
	end
    x_buf$send_data(b, 1, _bytevec$size(b))
    end free_colors

store_color = proc (pixel, red, green, blue: int)
    x_buf$setup(x_storecolors, 0, 0, 0)
    x_buf$set_s0(1)
    _wordvec$wstore(b2w(colbuf), 1, pixel)
    _wordvec$wstore(b2w(colbuf), 3, red)
    _wordvec$wstore(b2w(colbuf), 5, green)
    _wordvec$wstore(b2w(colbuf), 7, blue)
    x_buf$send_data(colbuf, 1, 8)
    end store_color

store_colors = proc (defs: colordeflist)
    x_buf$setup(x_storecolors, 0, 0, 0)
    x_buf$set_s0(colordeflist$size(defs))
    z: int := colordeflist$size(defs) * 8
    if _bytevec$size(colbuf) < z
       then colbuf := _bytevec$create(z) end
    i: int := 1
    for def: colordef in colordeflist$elements(defs) do
	_wordvec$wstore(b2w(colbuf), i, def.pixel)
	_wordvec$wstore(b2w(colbuf), i + 2, def.red)
	_wordvec$wstore(b2w(colbuf), i + 4, def.green)
	_wordvec$wstore(b2w(colbuf), i + 6, def.blue)
	i := i + 8
	end
    x_buf$send_data(colbuf, 1, z)
    end store_colors

query_color = proc (pixel: int) returns (int, int, int) signals (error(string))
    x_buf$setup(x_querycolor, 0, 0, 0)
    x_buf$set_s0(pixel)
    x_buf$receive()
       resignal error
    return(x_buf$get_sp0() // 2**16,
	   x_buf$get_sp1() // 2**16,
	   x_buf$get_sp2() // 2**16)
    end query_color

lookup_color = proc (name: string) returns (int, int, int, int, int, int)
				   signals (error(string))
    x_buf$setup(x_lookupcolor, 0, 0, 0)
    x_buf$set_s0(string$size(name))
    x_buf$send_data(s2b(name), 1, string$size(name))
    x_buf$receive()
       resignal error
    return(x_buf$get_sp0() // 2**16,
	   x_buf$get_sp1() // 2**16,
	   x_buf$get_sp2() // 2**16,
    	   x_buf$get_sp3() // 2**16,
	   x_buf$get_sp4() // 2**16,
	   x_buf$get_sp5() // 2**16)
    end lookup_color

black = proc () returns (x_pixmap)
    if ~haveblack
       then blackp := x_pixmap$tile(BlackPixel)
	    haveblack := true
       end
    return(blackp)
    end black

white = proc () returns (x_pixmap)
    if ~havewhite
       then whitep := x_pixmap$tile(WhitePixel)
	    havewhite := true
       end
    return(whitep)
    end white

end x_display
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦d8b2c3c6e⟧ TextFile

Derivation

TextFile
