CLX-PORTABLE port to LispWorks 6.x

Hello,

Is anyone interested in the port to LispWorks 6.x? It is based on
works (OPEN-UNIX-STREAM) by Barry Wilkes <bew <at> bcs.org.uk> and
(%CREATE-UNIX-DOMAIN-SOCKET) by Chun Tian (binghe).

It tested with LispWorks Professional and Personal editions. I also
have a port of StumpWM to LW running for a week on my laptop without
any issues.

Pull request is already sent to https://github.com/sharplispers/clx or
you can fetch the latest port form https://github.com/ska80/clx
(lispworks branch).

--

-- 
--ska

Multiple new events in extension

Hi there,

I contribute to the implementation of xkb extension
for clx. I tried to declare several new events,
but if I'm try to process those with "event-case"
all xkb specific events are mapped to the first
xkb event I declared, resulting in total garbish.

You can get the code with

git clone -b adding-events git://github.com/filonenko-mikhail/clx-xkeyboard.git

place a link to the repository somewhere, where
asdf can find xkeyboard.asd
do

(require 'clx)
(require 'xkeyboard) ;some errors about redefined constants pop up, but
                     ;just let them be redefined
(load "test/simple-xkb-event-viewer.lisp")
(xkb-test:simple-xkb-event-viewer)

a new window pops up and if you press some
modifiers, you will see new-keyboard-notify events,
which should be state-notify events.

I don't even have an idea how to debug
this. I tried to look into the clx code
for events, but get-internal-event-code
and get-external-event-code seem to work

trivial-features, CLX and SBCL mutual incompatibility

Forgive me if you've heard me rant about this before, but there is a mutual incompatibility between CLX,
trivial-features (which, for me at least, gets pulled in whenever I try to use CFFI) and SBCL. The problem
is that trivial-features puts :little-endian on *features* and CLX has the following code in defdeps.lisp:

#+(or lispm vax little-endian Minima)
(eval-when (eval compile load)
  (pushnew :clx-little-endian *features*))

These old-style eval-when conditions cause SBCL to issue a warning, which causes ASDF to stop compiling
CLX. There are many workarounds to this, such as loading CLX before CFFI and there are many possible fixes
(such as making SBCL less pedantic or making ASDF not stop on warnings of this kind, etc...) But it seems to
me that either fixing the CLX source code such that it is more tolerant of SBCL's pedantry or,
alternatively, picking less common names for the *features* in trivial-features would be a good thing. I
don't really have a preference, but it would be nice if the CLX and trivial-features maintainers would
play nice with each other such that, at least when using SBCL, one can load trivial-features and then CFFI.

I'm certainly open to other suggestions, but I've grown tired of working around this particular problem.

thanks,

Cyrus

get-best-authorization and localhost/unix:0

Ran into the following issue with the current clx (running on cmucl).
On my linux system, the xauth file (created by the system, not me) has
only one entry for localhost/unix:0.  When I try to open-clx-display, it
fails because get-best-authorization can't find the authorization data.
 The problem is that when the protocol is :local, get-best-auth looks up
the hostname and sets host-address to that.  The hostname isn't
"localhost", so nothing matches.

Here is a proposed patch.  The patch works for me, but I'm not sure if
it is the right thing to do.  Basically, in addition to matching
host-address to the xauth address, if the protocol is :local, allow a
match with "localhost".

Ray

Index: display.lisp
===================================================================
RCS file: /project/cmucl/cvsroot/src/clx/display.lisp,v
retrieving revision 1.15
diff -u -r1.15 display.lisp
--- display.lisp	13 Jul 2009 13:54:35 -0000	1.15
+++ display.lisp	16 Nov 2010 18:38:16 -0000
 <at>  <at>  -117,7 +117,9  <at>  <at> 
 		 (read-xauth-entry stream)
 	       (unless family (return))
 	       (when (and (eql family protocol)
-			  (equal host-address address)
+			  (or (equal host-address address)
+			      (and (eql protocol :local)
+				   (equal "localhost" address)))

:destroy-notify weirdness

CLX+SBCL Hangs with default font

Here is some more information on CLX+SBCL hanging. It seems to be
associated with the with-buffer-flush-inhibited macro. When forms are
enclosed with that macro, buffer-flush-inhibit is set to true. This, in
combination with not specifying the font causes the window to stop
responding to input. It seems to make a request for the default font,
but hangs trying to get the answer. Or maybe the request never gets sent
because of the flush being inhibited. I'm not sure. Anyway, the little
scratch code I've been using to identify the error is below. I'm too
tired at this point to figure out anything else.

Please email me with any suggestions or questions.

Regards,

Tom

-- 
=== Thomas M. Hermann ===

(defun test-clx ()
  (let* ((display (xlib:open-display ""))
	 (screen (first (xlib:display-roots display)))
	 (black (xlib:screen-black-pixel screen))
	 (white (xlib:screen-white-pixel screen))
	 (root-window (xlib:screen-root screen))
	 (gcontext (xlib:create-gcontext
		    :drawable root-window
		    :foreground white
		    :background black))
		    ;:font "-xos4-terminus-medium-r-normal--12-120-72-72-c-60-iso8859-1"))
	 (my-window (xlib:create-window
		     :parent root-window
		     :x 0
		     :y 0
		     :width 256
		     :height 128
		     :background black
		     :event-mask (xlib:make-event-mask :exposure
						       :button-press))))
    (xlib:map-window my-window)
    (xlib:event-case (display :force-output-p t
			      :discard-p t)
      (:exposure ()
		 (xlib::with-buffer-flush-inhibited (display)
		   (let ((font-id (xlib::font-id (xlib:gcontext-font gcontext t))))
		     (xlib::with-buffer-request-and-reply
			 (display xlib::+x-queryfont+ 60)
			 ((resource-id font-id))
		       (describe
			(xlib::query-font (xlib:gcontext-font gcontext t))))))
		 nil)
      (:button-press () t))
    (xlib:destroy-window my-window)
    (xlib:close-display display)))

Similar clx hang.

Shawn,

I read your post and looked at your backtrace after I posted my problem
with using a default font value in a graphics context. If I send a
sigint to lisp, the backtrace from my problem ends with several of the
same frames, so I think they may be related. I am using SBCL 1.0.3, clx
from darcs and FreeBSD. On the other hand, if I close the window outside
of lisp, I get a slightly different backtrace. See below.

Maybe if we identify the problem with default fonts in a graphics
context, it will help identify the problem in stumpwm.

Cheers,

Tom

-- 
=== Thomas M. Hermann ===

=== Backtrace from sigint to lisp: ===

interrupted at #X2817783F
   [Condition of type SIMPLE-CONDITION]

Restarts:
 0: [CONTINUE] Return from SB-UNIX:SIGINT.
 1: [ABORT] Return to SLIME's top level.
 2: [ABORT] Exit debugger, returning to top level.

Backtrace:
  0: (SB-UNIX::SIGINT-HANDLER
      #<unavailable argument>
      #<unavailable argument>
      #.(SB-SYS:INT-SAP #X283A4DF0))
  1: (SB-SYS:INVOKE-INTERRUPTION #<CLOSURE (LAMBDA #) {498ECEF5}>)
  2: ("foreign function: call_into_lisp")
  3: ("foreign function: funcall3")
  4: ("foreign function: interrupt_handle_now")
  5: ("foreign function: maybe_defer_handler")
  6: ("bogus stack frame")
  7: (SB-SYS:WAIT-UNTIL-FD-USABLE 9 :INPUT NIL)
  8: (XLIB::BUFFER-INPUT-WAIT-DEFAULT
      #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
      NIL)
  9: (XLIB::BUFFER-INPUT-WAIT
      #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
      NIL)
 10: (NIL
      #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
      NIL
      NIL
      #<FUNCTION (LAMBDA #) {49ECE145}>)
 11: (XLIB::READ-REPLY #<unavailable argument> #<unavailable argument>)
 12: (XLIB::QUERY-FONT #<XLIB:FONT (gcontext) :0 48234497>)
 13: (XLIB:FONT-MIN-CHAR #<XLIB:FONT (gcontext) :0 48234497>)
 14: (XLIB:TRANSLATE-DEFAULT
      "Hello World!"
      0
      12
      #<XLIB:FONT (gcontext) :0 48234497>
      #(47 0 2 0 1 0 224 2 1 0 ...)
      18)
 15: (XLIB::DRAW-GLYPHS8
      #<XLIB:WINDOW :0 2E00002>
      #<XLIB:GCONTEXT :0 48234497>
      20
      50
      "Hello World!"
      0
      12
      #<FUNCTION XLIB:TRANSLATE-DEFAULT>
      NIL)
 16: (HELLO-WORLD 256 256 "")
 17: (SB-INT:SIMPLE-EVAL-IN-LEXENV (HELLO-WORLD 256 256) #<NULL-LEXENV>)
 18: (SWANK::EVAL-REGION
      "(hello-world 256 256)
     "
      T)
 19: ((LAMBDA ()))
 20: ((LAMBDA (SWANK-BACKEND::FN)) #<CLOSURE (LAMBDA #) {4AD1F095}>)
 21: (SWANK::CALL-WITH-BUFFER-SYNTAX #<CLOSURE (LAMBDA #) {4AD1F095}>)
 22: (SWANK:LISTENER-EVAL
      "(hello-world 256 256)
     ")
 23: (SB-INT:SIMPLE-EVAL-IN-LEXENV
      (SWANK:LISTENER-EVAL "(hello-world 256 256)
     ")
      #<NULL-LEXENV>)
 24: ((LAMBDA ()))
 25: ((LAMBDA (SWANK-BACKEND::HOOK SWANK-BACKEND::FUN))
      #<FUNCTION SWANK:SWANK-DEBUGGER-HOOK>
      #<CLOSURE (LAMBDA #) {4AD1EF25}>)
 26: ((LAMBDA ()))
 27: ((LAMBDA (SWANK-BACKEND::HOOK SWANK-BACKEND::FUN))
      #<FUNCTION SWANK:SWANK-DEBUGGER-HOOK>
      #<FUNCTION (LAMBDA #) {49FB2E25}>)
 28: (SWANK::CALL-WITH-REDIRECTED-IO
      #<SWANK::CONNECTION {4A3CFC31}>
      #<CLOSURE (LAMBDA #) {4AD1C795}>)
 29: (SWANK::CALL-WITH-CONNECTION
      #<SWANK::CONNECTION {4A3CFC31}>
      #<FUNCTION (LAMBDA #) {49FB2E25}>)
 30: (SWANK::HANDLE-REQUEST #<SWANK::CONNECTION {4A3CFC31}>)
 31: (SWANK::PROCESS-AVAILABLE-INPUT
      #<SB-SYS:FD-STREAM for "a constant string" {4A3CEF29}>
      #<CLOSURE (LAMBDA #) {4AD1C755}>)
 32: ((FLET SWANK::HANDLER))
 33: ((LAMBDA (SWANK-BACKEND::_)) #<unused argument>)
 34: (SB-IMPL::SUB-SERVE-EVENT NIL 0)
 35: (SB-SYS:WAIT-UNTIL-FD-USABLE 0 :INPUT NIL)
 36: (SB-IMPL::REFILL-BUFFER/FD
      #<SB-SYS:FD-STREAM for "standard input" {4968FA11}>)
 37: (SB-IMPL::INPUT-CHAR/ASCII
      #<SB-SYS:FD-STREAM for "standard input" {4968FA11}>
      NIL
      #:EOF-OBJECT)
 38: (READ-CHAR
      #<SB-SYS:FD-STREAM for "standard input" {4968FA11}>
      NIL
      #:EOF-OBJECT
      #<unused argument>)
 39: (READ-CHAR
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      #:EOF-OBJECT
      #<unused argument>)
 40: (READ-PRESERVING-WHITESPACE
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      (NIL)
      T)
 41: (READ-PRESERVING-WHITESPACE
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      (NIL)
      NIL)
 42: (READ
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      (NIL)
      NIL)
 43: (SB-IMPL::REPL-READ-FORM-FUN
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      #<unavailable argument>)
 44: (SB-IMPL::REPL-FUN NIL)
 45: (SB-IMPL::REPL-FUN NIL)
 46: ((LAMBDA ()))
 47: ((LAMBDA ()))
 48: (SB-IMPL::%WITH-REBOUND-IO-SYNTAX #<CLOSURE (LAMBDA #) {49694BDD}>)
 49: (SB-IMPL::TOPLEVEL-REPL NIL)
 50: (SB-IMPL::TOPLEVEL-INIT)
 51: ((LABELS SB-IMPL::RESTART-LISP))

=== Backtrace from closing window: ===
end of file on #<SB-SYS:FD-STREAM for "a constant string" {498E0EE9}>
   [Condition of type END-OF-FILE]

Restarts:
 0: [ABORT] Return to SLIME's top level.
 1: [ABORT] Exit debugger, returning to top level.

Backtrace:
  0: (SB-IMPL::FD-STREAM-READ-N-BYTES
      #<SB-SYS:FD-STREAM for "a constant string" {498E0EE9}>
      #(0 0 0 0 0 0 0 0 0 0 ...)
      0
      32
      T)
  1: (XLIB::BUFFER-READ-DEFAULT
      #<unavailable argument>
      #<unavailable argument>
      #<unavailable argument>
      #<unavailable argument>
      #<unavailable argument>)
  2: (XLIB::BUFFER-INPUT
      #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
      #(0 0 0 0 0 0 0 0 0 0 ...)
      0
      32
      NIL)
  3: (NIL
      #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
      NIL
      NIL
      #<FUNCTION (LAMBDA #) {49ECE145}>)
  4: (XLIB::READ-REPLY #<unavailable argument> #<unavailable argument>)
  5: (XLIB::QUERY-FONT #<XLIB:FONT (gcontext) :0 48234497>)
  6: (XLIB:FONT-MIN-CHAR #<XLIB:FONT (gcontext) :0 48234497>)
  7: (XLIB:TRANSLATE-DEFAULT
      "Hello World!"
      0
      12
      #<XLIB:FONT (gcontext) :0 48234497>
      #(47 0 2 0 1 0 224 2 1 0 ...)
      18)
  8: (XLIB::DRAW-GLYPHS8
      #<XLIB:WINDOW :0 2E00002>
      #<XLIB:GCONTEXT :0 48234497>
      20
      50
      "Hello World!"
      0
      12
      #<FUNCTION XLIB:TRANSLATE-DEFAULT>
      NIL)
  9: (HELLO-WORLD 256 256 "")
 10: (SB-INT:SIMPLE-EVAL-IN-LEXENV (HELLO-WORLD 256 256) #<NULL-LEXENV>)
 11: (SWANK::EVAL-REGION
      "(hello-world 256 256)
     "
      T)
 12: ((LAMBDA ()))
 13: ((LAMBDA (SWANK-BACKEND::FN)) #<CLOSURE (LAMBDA #) {4AD1F095}>)
 14: (SWANK::CALL-WITH-BUFFER-SYNTAX #<CLOSURE (LAMBDA #) {4AD1F095}>)
 15: (SWANK:LISTENER-EVAL
      "(hello-world 256 256)
     ")
 16: (SB-INT:SIMPLE-EVAL-IN-LEXENV
      (SWANK:LISTENER-EVAL "(hello-world 256 256)
     ")
      #<NULL-LEXENV>)
 17: ((LAMBDA ()))
 18: ((LAMBDA (SWANK-BACKEND::HOOK SWANK-BACKEND::FUN))
      #<FUNCTION SWANK:SWANK-DEBUGGER-HOOK>
      #<CLOSURE (LAMBDA #) {4AD1EF25}>)
 19: ((LAMBDA ()))
 20: ((LAMBDA (SWANK-BACKEND::HOOK SWANK-BACKEND::FUN))
      #<FUNCTION SWANK:SWANK-DEBUGGER-HOOK>
      #<FUNCTION (LAMBDA #) {49FB2E25}>)
 21: (SWANK::CALL-WITH-REDIRECTED-IO
      #<SWANK::CONNECTION {4A3CFC31}>
      #<CLOSURE (LAMBDA #) {4AD1C795}>)
 22: (SWANK::CALL-WITH-CONNECTION
      #<SWANK::CONNECTION {4A3CFC31}>
      #<FUNCTION (LAMBDA #) {49FB2E25}>)
 23: (SWANK::HANDLE-REQUEST #<SWANK::CONNECTION {4A3CFC31}>)
 24: (SWANK::PROCESS-AVAILABLE-INPUT
      #<SB-SYS:FD-STREAM for "a constant string" {4A3CEF29}>
      #<CLOSURE (LAMBDA #) {4AD1C755}>)
 25: ((FLET SWANK::HANDLER))
 26: ((LAMBDA (SWANK-BACKEND::_)) #<unused argument>)
 27: (SB-IMPL::SUB-SERVE-EVENT NIL 0)
 28: (SB-SYS:WAIT-UNTIL-FD-USABLE 0 :INPUT NIL)
 29: (SB-IMPL::REFILL-BUFFER/FD
      #<SB-SYS:FD-STREAM for "standard input" {4968FA11}>)
 30: (SB-IMPL::INPUT-CHAR/ASCII
      #<SB-SYS:FD-STREAM for "standard input" {4968FA11}>
      NIL
      #:EOF-OBJECT)
 31: (READ-CHAR
      #<SB-SYS:FD-STREAM for "standard input" {4968FA11}>
      NIL
      #:EOF-OBJECT
      #<unused argument>)
 32: (READ-CHAR
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      #:EOF-OBJECT
      #<unused argument>)
 33: (READ-PRESERVING-WHITESPACE
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      (NIL)
      T)
 34: (READ-PRESERVING-WHITESPACE
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      (NIL)
      NIL)
 35: (READ
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      NIL
      (NIL)
      NIL)
 36: (SB-IMPL::REPL-READ-FORM-FUN
      #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDIN* {480CACB1}>
      #<unavailable argument>)
 37: (SB-IMPL::REPL-FUN NIL)
 38: (SB-IMPL::REPL-FUN NIL)
 39: ((LAMBDA ()))
 40: ((LAMBDA ()))
 41: (SB-IMPL::%WITH-REBOUND-IO-SYNTAX #<CLOSURE (LAMBDA #) {49694BDD}>)
 42: (SB-IMPL::TOPLEVEL-REPL NIL)
 43: (SB-IMPL::TOPLEVEL-INIT)
 44: ((LABELS SB-IMPL::RESTART-LISP))

_______________________________________________
Portable-clx mailing list
Portable-clx <at> lists.metacircles.com
http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
See http://www.cliki.net/clx for darcs URL(s)

Graphics Context Default Font

I'm using a darcs pull of clx with sbcl 1.0.3 and Xorg 6.9 on FreeBSD
6.1. I've been working through the examples described as Simple CLX:

http://www.cawtech.demon.co.uk/clx/simple/examples.html

I've successfully run every example up to 'hello-world'. Evaluation of
hello-world hangs because it relies on a default value for the font in
the graphics context. If I specify the font to use, it evaluates
correctly. Looking through the clx source, the error occurs because
translate-default is passed a pseudo-font when the font is not specified
in the graphics context. For some reason, with my setup,
translate-default doesn't get the correct information when passed a
pseudo-font.

So, the problem could be that my X server isn't providing any default
font information, that the graphics context isn't generating a valid
pseudo-font or that translate-default isn't processing the pseudo-font
correctly. There are probably many more opportunities for error that
I've not identified.

I would appreciate any suggestions or pointers on how to fix this or at
least identify the source of the error.

Thanks,

Tom H.

P.S. I made a minor modification to 'open-display' in display.lisp to
get it to handle a hostname of "localhost" correctly.

-- 
=== Thomas M. Hermann ===

(defun hello-world (width height &optional (host ""))
  (let* ((display (xlib:open-display host))
	 (screen (first (xlib:display-roots display)))
	 (black (xlib:screen-black-pixel screen))
	 (white (xlib:screen-white-pixel screen))
	 (root-window (xlib:screen-root screen))
	 (grackon (xlib:create-gcontext
		   :drawable root-window
		   :foreground white
		   :background black))
	 (my-window (xlib:create-window
		     :parent root-window
		     :x 0
		     :y 0
		     :width width
		     :height height
		     :background black
		     :event-mask (xlib:make-event-mask :exposure
						       :button-press))))
    (describe (xlib:gcontext-font grackon))
    (xlib:map-window my-window)
    (xlib:event-case (display :force-output-p t
			      :discard-p t)
      (:exposure (count)
	 (when (zerop count)
	   (xlib:draw-glyphs
	     my-window
	     grackon
	     20 50
	     "Hello World!"))
	 nil)
      (:button-press () t))
    (xlib:destroy-window my-window)
    (xlib:close-display display)))

clx hang?

Hi clx hackers,

I'm trying to debug this intermittent freeze bug 2 stumpwm users have
been having. 

Basically what happens is they're using stumpwm, then they step away,
come back a few hours later (or in the morning) and the keyboard is
completely frozen. The mouse still works, they can click around in the
current window. The keyboard is frozen to the point that even
control+alt+F1 won't switch to the console.

We got a backtrace by booting X without a wm, then running stumpwm
inside screen, and when it hangs sshing in and connecting to screen
and hit C-c to drop to the debugger.

stumpwm sets up a passive grab on several keys which freeze the
keyboard when you press them. Then stumpwm gets the key events and
unfreezes the kbd. I suspect what's happening is stumpwm is becoming
unresponsive somehow and so when one of these grabbed keys is hit X
freezes the keyboard and then..nothing happens.

Has anyone had clx hang for them? Or sbcl hang waiting for a fd? If
anyone has any ideas or similar encounters, I'd love to hear them. I'm
at my wits end!

Here's a backtrace on SBCL 1.0.4, clx 0.7.3, freebsd. I'm sorry didn't
get the version of freebsd. It's a new installation so probably the
current version.

Any help would be much appreciated!

-Shawn

debugger invoked on a SIMPLE-CONDITION: interrupted at #X28171767

Type HELP for debugger help, or (SB-EXT:QUIT) to exit from SBCL.

restarts (invokable by number or by possibly-abbreviated name):
  0: [CONTINUE] Return from SB-UNIX:SIGINT.
  1: [ABORT   ] Exit debugger, returning to top level.

(SB-UNIX::SIGINT-HANDLER
 #<unavailable argument>
 #<unavailable argument>
 #.(SB-SYS:INT-SAP #X2839A580))
0] backtrace

0: (SB-UNIX::SIGINT-HANDLER
    #<unavailable argument>
    #<unavailable argument>
    #.(SB-SYS:INT-SAP #X2839A580))
1: (SB-SYS:INVOKE-INTERRUPTION #<CLOSURE (LAMBDA #) {4A71292D}>)
2: ("foreign function: call_into_lisp")
3: ("foreign function: funcall3")
4: ("foreign function: interrupt_handle_now")
5: ("foreign function: maybe_defer_handler")
6: ("bogus stack frame")
7: (SB-SYS:WAIT-UNTIL-FD-USABLE 5 :INPUT NIL)
8: (XLIB::BUFFER-INPUT-WAIT-DEFAULT
    #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
    NIL)
9: (XLIB::BUFFER-INPUT-WAIT
    #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
    NIL)
10: (XLIB::READ-INPUT
     #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>
     NIL
     NIL
     #<FUNCTION (LAMBDA #) {49A253E5}>)
11: (XLIB::READ-REPLY #<unavailable argument> #<unavailable argument>)
12: (XLIB:DISPLAY-FINISH-OUTPUT
     #<XLIB:DISPLAY :0 (The X.Org Foundation R60900000)>)
13: (STUMPWM::STUMPWM-INTERNAL-LOOP)
14: (STUMPWM:STUMPWM ":0" NIL)
15: (SB-INT:SIMPLE-EVAL-IN-LEXENV (STUMPWM:STUMPWM) #<NULL-LEXENV>)
16: (INTERACTIVE-EVAL (STUMPWM:STUMPWM))
17: (SB-IMPL::REPL-FUN NIL)
18: (SB-IMPL::REPL-FUN NIL)
19: ((LAMBDA ()))
20: ((LAMBDA ()))
21: (SB-IMPL::%WITH-REBOUND-IO-SYNTAX #<CLOSURE (LAMBDA #) {4969080D}>)
22: (SB-IMPL::TOPLEVEL-REPL NIL)
23: (SB-IMPL::TOPLEVEL-INIT)
24: ((LABELS SB-IMPL::RESTART-LISP))

0] 

_______________________________________________
Portable-clx mailing list
Portable-clx <at> lists.metacircles.com
http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
See http://www.cliki.net/clx for darcs URL(s)

GLX choose-visual modification

Hi,

I've played a little with OpenGL through CLX lately and I found the existing glx:choose-visual to give me
consistently poor results. AFAICT it ignored whatever attributes I specified. I've hacked it a bit and
now, at least for me, it gives me much more relevant visuals.

Maybe this will be useful to someone else as well, attached is a darcs-patch against Christophe's clx-tree.

Sincerely yours,
Mikael Lax

[PATCH] CLISP support for telent-clx

Hi!

I merged CLISP dependent code from mit-clx sources to telent-clx. Now
telent-clx works also on CLISP. I tested some examples from clx/demo and run
McCLIM demo application (clim-demo::demodemo) from
mcclim/Examples. Patch attached. 

diff -r -u clx.orig/demo/clx-demos.lisp clx/demo/clx-demos.lisp
--- clx.orig/demo/clx-demos.lisp	2007-01-06 12:06:56.000000000 +0000
+++ clx/demo/clx-demos.lisp	2007-01-06 16:05:53.000000000 +0000
 <at>  <at>  -36,11 +36,11  <at>  <at> 
        (unless *display*
 	 #+:cmu
 	 (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
-	 #+(or sbcl allegro)
+	 #+(or sbcl allegro clisp)
 	 (progn
 	   (setf *display* (xlib::open-default-display))
 	   (setf *screen* (xlib:display-default-screen *display*)))
-	 #-(or cmu sbcl allegro)
+	 #-(or cmu sbcl allegro clisp)
 	 (progn
 	   ;; Portable method
 	   (setf *display* (xlib:open-display (machine-instance)))
diff -r -u clx.orig/depdefs.lisp clx/depdefs.lisp
--- clx.orig/depdefs.lisp	2007-01-06 12:06:56.000000000 +0000
+++ clx/depdefs.lisp	2007-01-06 15:24:26.000000000 +0000
 <at>  <at>  -177,6 +177,10  <at>  <at> 
 ;;; this to do fast array packing/unpacking when the overlapping-arrays
 ;;; feature is enabled.

+#+clisp
+(eval-when (:compile-toplevel :execute :load-toplevel)
+  (unless system::*big-endian* (pushnew :clx-little-endian *features*)))
+
 #+(and clx-little-endian lispm)
 (eval-when (eval compile load)
   (pushnew :clx-overlapping-arrays *features*))
diff -r -u clx.orig/dependent.lisp clx/dependent.lisp
--- clx.orig/dependent.lisp	2007-01-06 12:06:54.000000000 +0000
+++ clx/dependent.lisp	2007-01-06 15:51:12.000000000 +0000
 <at>  <at>  -689,7 +689,7  <at>  <at> 
   (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))

 
-#+(or cmu sbcl) (progn
+#+(or cmu sbcl clisp) (progn

 ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
 ;;; is irrational, there can't be a precise rational representation.  In
 <at>  <at>  -935,6 +935,14  <at>  <at> 
   `(mp:with-lock-held (,lock ,whostate , <at> (and timeout `(:timeout ,timeout)))
     , <at> body))

+#+clisp
+(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
+                              &key timeout)
+                        &body body)
+  (declare (ignore lock display whostate timeout))
+  `(progn
+     , <at> body))
+
 #+sbcl
 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
 			      &key timeout)
 <at>  <at>  -1168,6 +1176,7  <at>  <at> 
      (return))
    (yield)))

+
 ;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
 ;;; queues and condition variables might seem better, but in fact it
 ;;; turns out to make performance extremely suboptimal, at least as
 <at>  <at>  -1401,11 +1410,35  <at>  <at> 
 ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
 ;;; server

-#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl)
+#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp)
 (defun open-x-stream (host display protocol)
   host display protocol ;; unused
   (error "OPEN-X-STREAM not implemented yet."))

+#+clisp
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol)
+           (type (integer 0) display))
+  (let ((socket
+         ;; are we dealing with a localhost?
+         (progn #+nil ignore-errors
+           (when (or (string= host "")
+                     (string= host "unix"))
+             ;; ok, try to connect to a AF_UNIX domain socket
+             (sys::make-socket-stream "" display)))))
+    (if socket
+        socket
+        ;; try to connect by hand
+        (let ((host (host-address host)))
+          (when host
+            ;; Fixme: get a descent ip standard in CLX: a vector!
+            (let ((ip (format nil
+                              "~{~D~^.~}"
+                              (rest host))))
+              (socket:socket-connect (+ 6000 display) ip
+                                     :element-type '(unsigned-byte 8))))))))
+
+
 ;;; Genera:

 ;;; TCP and DNA are both layered products, so try to work with either one.
 <at>  <at>  -1653,7 +1686,7  <at>  <at> 
 	  vector start (- end start))
 	 nil)))

-#+ecl
+#+(or ecl clisp)
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
 	   (type buffer-bytes vector)
 <at>  <at>  -1675,7 +1708,7  <at>  <at> 
 ;;;	receiving all data from the X Window System server.
 ;;;	You are encouraged to write a specialized version of
 ;;;	buffer-read-default that does block transfers.
-#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp)
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
 	   (type buffer-bytes vector)
 <at>  <at>  -1766,7 +1799,7  <at>  <at> 
   (sb-impl::output-raw-bytes (display-output-stream display) vector start end)
   nil)

-#+ecl
+#+(or ecl clisp)
 (defun buffer-write-default (vector display start end)
   (declare (type buffer-bytes vector)
 	   (type display display)
 <at>  <at>  -1784,7 +1817,7  <at>  <at> 
 ;;;	You are STRONGLY encouraged to write a specialized version
 ;;;	of buffer-write-default that does block transfers.

-#-(or Genera explorer excl lcl3.0 Minima CMU sbcl)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp)
 (defun buffer-write-default (vector display start end)
   ;; The default buffer write function for use with common-lisp streams
   (declare (type buffer-bytes vector)
 <at>  <at>  -1847,7 +1880,7  <at>  <at> 
 #-(or Genera explorer excl lcl3.0 CMU sbcl)
 (defparameter *buffer-read-polling-time* 0.5)

-#-(or Genera explorer excl lcl3.0 CMU sbcl)
+#-(or Genera explorer excl lcl3.0 CMU sbcl clisp)
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
 	   (type (or null (real 0 *)) timeout))
 <at>  <at>  -1871,7 +1904,7  <at>  <at> 
 		 (return-from buffer-input-wait-default nil)))
 	     :timeout)))))

-#+(or CMU sbcl)
+#+(or CMU sbcl clisp)
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
 	   (type (or null number) timeout))
 <at>  <at>  -1885,7 +1918,10  <at>  <at> 
 						   :input timeout)
 	       #+mp (mp:process-wait-until-fd-usable
 		     (system:fd-stream-fd stream) :input timeout)
-	       #-(or sbcl mp) (system:wait-until-fd-usable
+               #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
+                         (ext:socket-status stream (and timeout sec)
+                                            (round usec 1d-6)))
+	       #-(or sbcl mp clisp) (system:wait-until-fd-usable
 			       (system:fd-stream-fd stream) :input timeout)
 	       nil
 	       :timeout)))))
 <at>  <at>  -2252,9 +2288,9  <at>  <at> 
 ;; dispatching, not just type checking.  -- Ram.

 (defmacro type? (object type)
-  #+(or cmu sbcl)
+  #+(or cmu sbcl clisp)
   `(typep ,object ,type)
-  #-(or cmu sbcl)
+  #-(or cmu sbcl clisp)
   (if (not (constantp type))
       `(typep ,object ,type)
     (progn
 <at>  <at>  -2325,12 +2361,12  <at>  <at> 
   (declare (dbg:error-reporter))
   (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))

-#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp))
+#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp))
 (defun x-error (condition &rest keyargs)
   (declare (dynamic-extent keyargs))
   (apply #'error condition keyargs))

-#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp)
 (defun x-cerror (proceed-format-string condition &rest keyargs)
   (declare (dynamic-extent keyargs))
   (apply #'cerror proceed-format-string condition keyargs))
 <at>  <at>  -2353,12 +2389,12  <at>  <at> 
 	(ext::disable-clx-event-handling disp)))
     (error condx)))

-#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (defun x-error (condition &rest keyargs)
   (error "X-Error: ~a"
 	 (princ-to-string (apply #'make-condition condition keyargs))))

-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (defun x-cerror (proceed-format-string condition &rest keyargs)
   (cerror proceed-format-string "X-Error: ~a"
 	 (princ-to-string (apply #'make-condition condition keyargs))))
 <at>  <at>  -2451,7 +2487,7  <at>  <at> 
 (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
   (format stream continue-format-string))

-#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (define-condition x-error (error) ())

 #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
 <at>  <at>  -2495,7 +2531,7  <at>  <at> 
 	       ,condition))
 	 ',name))))

-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (defun condition-print (condition stream depth)
   (declare (type x-error condition)
 	   (type stream stream)
 <at>  <at>  -2505,14 +2541,14  <at>  <at> 
     (funcall (x-error-report-function condition) condition stream))
   condition)

-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (defun make-condition (type &rest slot-initializations)
   (declare (dynamic-extent slot-initializations))
   (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
 			       (symbol-package type))))
     (apply make-function slot-initializations)))

-#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (define-condition type-error (x-error)
   ((datum :reader type-error-datum :initarg :datum)
    (expected-type :reader type-error-expected-type :initarg :expected-type))
 <at>  <at>  -2527,7 +2563,7  <at>  <at> 
 ;;  HOST hacking
 ;;-----------------------------------------------------------------------------

-#-(or explorer Genera Minima Allegro CMU sbcl ecl)
+#-(or explorer Genera Minima Allegro CMU sbcl ecl clisp)
 (defun host-address (host &optional (family :internet))
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
   ;; and cdr is a list of network address bytes.
 <at>  <at>  -2537,6 +2573,45  <at>  <at> 
   host family
   (error "HOST-ADDRESS not implemented yet."))

+#+clisp
+(defun host-address (host &optional (family :internet))
+  "Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  and cdr is a list of network address bytes."
+  (declare (type stringable host)
+           (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (labels ((no-host-error ()
+             (error "Unknown host ~S" host))
+           (no-address-error ()
+             (error "Host ~S has no ~S address" host family)))
+
+    (let ((hostent (posix::resolve-host-ipaddr (string host))))
+      (when (not (posix::hostent-addr-list hostent))
+        (no-host-error))
+      (ecase family
+        ((:internet nil 0)
+         (unless (= (posix::hostent-addrtype hostent) 2)
+           (no-address-error))
+         (let ((addr (first (posix::hostent-addr-list hostent))))
+           (etypecase addr
+             (integer
+              (list :internet
+                    (ldb (byte 8 24) addr)
+                    (ldb (byte 8 16) addr)
+                    (ldb (byte 8  8) addr)
+                    (ldb (byte 8  0) addr)))
+             (string
+              (let ((parts (read-from-string
+                            (nsubstitute #\Space #\. (ext:string-concat
+                                                      "(" addr ")")))))
+                (check-type parts (cons (unsigned-byte 8)
+                                        (cons (unsigned-byte 8)
+                                              (cons (unsigned-byte 8)
+                                                    (cons (unsigned-byte 8)
+                                                          NULL)))))
+                (cons :internet parts))))))))))
+
+
 #+explorer
 (defun host-address (host &optional (family :internet))
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
 <at>  <at>  -2808,7 +2883,8  <at>  <at> 
   #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
   #+sbcl (sb-ext:posix-getenv name)
   #+ecl (si:getenv name)
-  #-(or sbcl excl lcl3.0 CMU ecl) (progn name nil))
+  #+clisp (ext:getenv name)
+  #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil))

 (defun get-host-name ()
   "Return the same hostname as gethostname(3) would"
 <at>  <at>  -2818,7 +2894,8  <at>  <at> 
   ;; resources-pathname was using short-site-name for this purpose
   #+excl (short-site-name)
   #+ecl (si:getenv "HOST")
-  #-(or excl cmu sbcl ecl) (error "get-host-name not implemented"))
+  #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s)))
+  #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented"))

 (defun homedir-file-pathname (name)
   (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
 <at>  <at>  -2986,7 +3063,7  <at>  <at> 
       (setf (char-bit object :hyper) 1)))
   object)

-#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
+#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp)
 (defun default-keysym-translate (display state object)
   (declare (type display display)
 	   (type card16 state)