Menu
▾
▴
clisp-cvs digest, Vol 1 #1045 - 10 msgs
|
From: <cli...@li...> - 2005-04-06 20:54:22
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/modules/clx/new-clx clx.f,2.30,2.31 (Sam Steingold) 2. clisp/src ChangeLog,1.4438,1.4439 (Sam Steingold) 3. clisp/modules/matlab link.sh,1.2,1.3 Makefile,1.4,1.5 (Sam Steingold) 4. clisp/modules/clx/new-clx clx.lisp,1.7,1.8 clx.f,2.31,2.32 (Sam Steingold) 5. clisp/src ChangeLog,1.4439,1.4440 (Sam Steingold) 6. clisp/src ChangeLog,1.4440,1.4441 .gdbinit,1.29,1.30 (Sam Steingold) 7. clisp/src ChangeLog,1.4441,1.4442 (Sam Steingold) 8. clisp/modules/clx/new-clx clx.lisp,1.8,1.9 clx.f,2.32,2.33 (Sam Steingold) 9. clisp/src ChangeLog,1.4442,1.4443 (Sam Steingold) 10. clisp/modules/clx/new-clx resource.lisp,NONE,2.1 link.sh.in,1.3,1.4 clx.f,2.33,2.34 Makefile.in,1.7,1.8 (Sam Steingold) --__--__-- Message: 1 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx clx.f,2.30,2.31 Date: Wed, 06 Apr 2005 14:16:45 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20178/modules/clx/new-clx Modified Files: clx.f Log Message: (XLIB::%DISPLAY-XID): new function (XLIB:DISPLAY-XID): return it Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.30 retrieving revision 2.31 diff -u -d -r2.30 -r2.31 --- clx.f 28 Mar 2005 20:18:42 -0000 2.30 +++ clx.f 6 Apr 2005 14:16:41 -0000 2.31 @@ -727,7 +727,7 @@ /* Now the XID objects */ static object make_xid_obj_low (gcv_object_t *prealloc, gcv_object_t *type, - gcv_object_t *dpy, XID xid) + gcv_object_t *dpy, XID xid) { if (nullp (*prealloc)) { /* (make-instance type :display dpy :id xid) */ @@ -1833,11 +1833,18 @@ value1 = value2; mv_count = 1; } +DEFUN(XLIB::%DISPLAY-XID, display) +{ + Display *dpy = pop_display (); + VALUES1(make_uint29(XAllocID(dpy))); +} + DEFUN(XLIB:DISPLAY-XID, display) -/* This functions seems to return a function to allocate new resource id`s, - so have a closer look at (from Xlib.h): - #define XAllocID(dpy) ((*((_XPrivDisplay)dpy)->resource_alloc)((dpy))) */ -{UNDEFINED;} +/* This functions returns a function to allocate new resource id's */ +{ + pop_display(); + VALUES1(``XLIB::%DISPLAY-XID``); +} DEFUN(XLIB:DISPLAY-AFTER-FUNCTION, display) /* OK */ { --__--__-- Message: 2 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4438,1.4439 Date: Wed, 06 Apr 2005 14:16:43 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20178/src Modified Files: ChangeLog Log Message: (XLIB::%DISPLAY-XID): new function (XLIB:DISPLAY-XID): return it Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4438 retrieving revision 1.4439 diff -u -d -r1.4438 -r1.4439 --- ChangeLog 6 Apr 2005 02:03:34 -0000 1.4438 +++ ChangeLog 6 Apr 2005 14:16:16 -0000 1.4439 @@ -1,3 +1,8 @@ +2005-04-06 Sam Steingold <sd...@gn...> + + * modules/clx/new-clx/clx.f (XLIB::%DISPLAY-XID): new function + (XLIB:DISPLAY-XID): return it + 2005-04-05 Sam Steingold <sd...@gn...> * case-sensitive.lisp: add CS-COMMON-LISP to *SYSTEM-PACKAGE-LIST* --__--__-- Message: 3 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/matlab link.sh,1.2,1.3 Makefile,1.4,1.5 Date: Wed, 06 Apr 2005 16:53:13 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/matlab In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv454/modules/matlab Modified Files: link.sh Makefile Log Message: upgraded Matlab 6.5.1 --> 7 Index: link.sh =================================================================== RCS file: /cvsroot/clisp/clisp/modules/matlab/link.sh,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- link.sh 1 Apr 2005 20:38:06 -0000 1.2 +++ link.sh 6 Apr 2005 16:53:10 -0000 1.3 @@ -5,17 +5,17 @@ mod_list="$mod_list"' matlab' fi # matlab=/usr/local/matlab/extern/lib/ -matlab=c:/MATLAB6p5/extern/lib/win32/microsoft/msvc60 +matlab=d:/MATLAB7/extern/lib/win32/microsoft/msvc60 make clisp-module \ CC="${CC}" CPPFLAGS="${CPPFLAGS}" CFLAGS="${CFLAGS}" \ INCLUDES="$absolute_linkkitdir" NEW_FILES="$file_list" NEW_LIBS="$file_list"; -for lib in eng mat matlb matlbmx mex mx; do +for lib in eng mat mex mx; do NEW_LIBS=${NEW_LIBS}" ${matlab}/lib${lib}.lib" done NEW_MODULES="$mod_list" TO_LOAD='matlab wrap' CLFLAGS="${CLFLAGS}" # -L${matlab} -PATH="${PATH}:/cygdrive/c/MATLAB6p5/bin/win32/" +PATH="${PATH}:/cygdrive/d/MATLAB7/bin/win32/" Index: Makefile =================================================================== RCS file: /cvsroot/clisp/clisp/modules/matlab/Makefile,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- Makefile 5 Apr 2005 14:18:05 -0000 1.4 +++ Makefile 6 Apr 2005 16:53:11 -0000 1.5 @@ -6,7 +6,7 @@ CFLAGS = -Wall -O2 INCLUDES = .. # MATLAB = /usr/local/matlab/extern/include -MATLAB = c:/MATLAB6p5/extern/include +MATLAB = d:/MATLAB7/extern/include CLISP = clisp -q -norc LN = ln --__--__-- Message: 4 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx clx.lisp,1.7,1.8 clx.f,2.31,2.32 Date: Wed, 06 Apr 2005 17:17:41 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7134/modules/clx/new-clx Modified Files: clx.lisp clx.f Log Message: (XLIB::LOOKUP-RESOURCE-ID): implemented Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.31 retrieving revision 2.32 diff -u -d -r2.31 -r2.32 --- clx.f 6 Apr 2005 14:16:41 -0000 2.31 +++ clx.f 6 Apr 2005 17:17:36 -0000 2.32 @@ -656,14 +656,15 @@ } /* display_hash_table -- return the hashtable of a display object - > STACK_0 the display object - < STACK_0 its hash table + > the display object + < its hash table This function is somewhat silly, since it introduces double type checking! */ -static void display_hash_table (void) +static object display_hash_table (object dpy) { + pushSTACK(dpy); if (!ensure_living_display(&(STACK_0))) closed_display_error(TheSubr(subr_self)->name,STACK_0); - STACK_0 = TheStructure (STACK_0)->recdata[slot_DISPLAY_HASH_TABLE]; + return TheStructure (popSTACK())->recdata[slot_DISPLAY_HASH_TABLE]; } /* pop_display --- return the C Display* of an display object @@ -699,7 +700,7 @@ } static void *get_ptr_object_and_display (object type, object obj, - Display **dpyf) + Display **dpyf) { /* 'obj' is the lisp object, whose C representation is returned. When 'dpyf' is non-0, the display of 'obj' is also returned and it is ensured that it lives. [Otherwise an error is signaled.] @@ -755,6 +756,27 @@ DEFVAR(xlib_a_cons,`(NIL . NIL)`); +/* find the resource in the display hash table + < display object, XID number + > returns dpy->hash-table if NOT found + nullobj if found, in which case the object found is in value1 */ +static object lookup_xid (object dpy, XID xid) { + if (xid == 0) { /* This is trivial, but is it also right?! */ + VALUES1(NIL); + return nullobj; + } else { + object ht = display_hash_table(dpy); + Car (O(xlib_a_cons)) = make_uint16 (xid & 0xFFFF); /* lower halfword */ + Cdr (O(xlib_a_cons)) = make_uint16 (xid >> 16); /* upper halfword */ + value1 = gethash(O(xlib_a_cons),ht,false); /* look it up */ + if (!eq(value1,nullobj)) { /* something found? */ + mv_count = 1; /* simply return what we found */ + return nullobj; + } else + return ht; /* return the hash-table */ + } +} + static object make_xid_obj_2 (object type, object dpy, XID xid, object prealloc) { /* NOTE: - This code is not reentrant :-( But hence it saves consing @@ -771,42 +793,24 @@ 2. If lookup succeeds we could also check the type. 3. We should check the type of the preallocated object?! [Compare to make_ptr_obj] */ - - if (xid == 0) { /* This is trivial, but is it also right?! */ - VALUES1(NIL); - } else { - pushSTACK(prealloc); /* save is save */ - pushSTACK(type); /* ditto */ - pushSTACK(dpy); /* ditto */ - - Car (O(xlib_a_cons)) = make_uint16 (xid & 0xFFFF); /* lower halfword */ - Cdr (O(xlib_a_cons)) = make_uint16 (xid >> 16); /* upper halfword */ - - /* Now go with that cons into the hash-table ... */ - pushSTACK(STACK_0); /* the display object */ - display_hash_table(); /* the table [also ensures that dpy is a display] */ - value1 = gethash(O(xlib_a_cons),popSTACK(),true); /* look it up */ - if (!eq(value1,nullobj)) { /* something found? */ - mv_count = 1; /* simply return what we found */ - } else { /* Nothing found, so create a new object */ - pushSTACK(make_xid_obj_low (&STACK_2, &STACK_1, &STACK_0, xid)); - - /* Now enter this into the hashtable */ - pushSTACK(make_uint16 (xid & 0xFFFF)); /* lower halfword */ - pushSTACK(make_uint16 (xid >> 16)); /* upper halfword */ - funcall(L(cons),2); /* cons `em */ - pushSTACK(value1); /* key for puthash */ - pushSTACK(STACK_2); - display_hash_table(); /* table " " */ - pushSTACK(STACK_2); /* value " " */ - funcall (L(puthash), 3); /* put it into the hashtable */ - - VALUES1(popSTACK()); /* return freshly allocated structure */ - } - - skipSTACK(3); /* remove saved prealloc, type, dpy */ + object ht = lookup_xid(dpy,xid); + if (!eq(ht,nullobj)) { /* allocate and enter object into the hashtable */ + pushSTACK(prealloc); /* save is save */ + pushSTACK(type); /* ditto */ + pushSTACK(dpy); /* ditto */ + pushSTACK(ht); /* hashtable */ + pushSTACK(make_xid_obj_low (&STACK_3, &STACK_2, &STACK_1, xid)); + /* Now enter this into the hashtable */ + pushSTACK(make_uint16 (xid & 0xFFFF)); /* lower halfword */ + pushSTACK(make_uint16 (xid >> 16)); /* upper halfword */ + funcall(L(cons),2); /* cons `em */ + pushSTACK(value1); /* key for puthash */ + pushSTACK(STACK_2); /* hashtable */ + pushSTACK(STACK_2); /* value */ + funcall (L(puthash), 3); /* put it into the hashtable */ + VALUES1(popSTACK()); /* return freshly allocated structure */ + skipSTACK(4); /* remove saved prealloc, type, dpy, ht */ } - return value1; } @@ -1840,12 +1844,17 @@ } DEFUN(XLIB:DISPLAY-XID, display) -/* This functions returns a function to allocate new resource id's */ -{ +{ /* This functions returns a function to allocate new resource id's */ pop_display(); VALUES1(``XLIB::%DISPLAY-XID``); } +DEFUN(XLIB::LOOKUP-RESOURCE-ID, display id) { + XID resource_id = get_uint29(popSTACK()); + object ht = lookup_xid(popSTACK(),resource_id); /* set value1 if found */ + if (!eq(ht,nullobj)) VALUES1(NIL); /* not found */ +} + DEFUN(XLIB:DISPLAY-AFTER-FUNCTION, display) /* OK */ { ensure_living_display (&(STACK_0)); Index: clx.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- clx.lisp 5 Apr 2005 22:48:31 -0000 1.7 +++ clx.lisp 6 Apr 2005 17:17:35 -0000 1.8 @@ -1093,8 +1093,8 @@ (let ((killid (aref prop 9))) (if (= killid 1) :release-by-freeing-colormap - ;; FIXME function lookup-resource-id not defined - (lookup-resource-id (window-display window) killid))))))))) + (lookup-resource-id (window-display window) + killid))))))))) (defsetf rgb-colormaps set-rgb-colormaps) (defun set-rgb-colormaps (window property maps) --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4439,1.4440 Date: Wed, 06 Apr 2005 17:17:42 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7134/src Modified Files: ChangeLog Log Message: (XLIB::LOOKUP-RESOURCE-ID): implemented Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4439 retrieving revision 1.4440 diff -u -d -r1.4439 -r1.4440 --- ChangeLog 6 Apr 2005 14:16:16 -0000 1.4439 +++ ChangeLog 6 Apr 2005 17:17:07 -0000 1.4440 @@ -2,6 +2,10 @@ * modules/clx/new-clx/clx.f (XLIB::%DISPLAY-XID): new function (XLIB:DISPLAY-XID): return it + (display_hash_table): pass the arguments the usual way, not via STACK + (lookup_xid): new function (mostly extracted from make_xid_obj_2) + (make_xid_obj_2): use make_xid_obj_2() + (XLIB::LOOKUP-RESOURCE-ID): implemented using lookup_xid() 2005-04-05 Sam Steingold <sd...@gn...> --__--__-- Message: 6 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4440,1.4441 .gdbinit,1.29,1.30 Date: Wed, 06 Apr 2005 17:21:24 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8393/src Modified Files: ChangeLog .gdbinit Log Message: (full): added commented-out module debugging infrastructure Index: .gdbinit =================================================================== RCS file: /cvsroot/clisp/clisp/src/.gdbinit,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- .gdbinit 14 Feb 2005 12:20:58 -0000 1.29 +++ .gdbinit 6 Apr 2005 17:21:21 -0000 1.30 @@ -20,6 +20,8 @@ define full file full/lisp.run set args -B . -M full/lispinit.mem -q -norc + # -i ../tests/tests -x '(run-test "***/test")' + # -i clx/new-clx/demos/clx-demos.lisp -x '(clx-demos:qix)' -x '(clx-demos:sokoban)' break my_type_error break closed_display_error end Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4440 retrieving revision 1.4441 diff -u -d -r1.4440 -r1.4441 --- ChangeLog 6 Apr 2005 17:17:07 -0000 1.4440 +++ ChangeLog 6 Apr 2005 17:21:12 -0000 1.4441 @@ -1,5 +1,9 @@ 2005-04-06 Sam Steingold <sd...@gn...> + * .gdbinit (full): added commented-out module debugging infrastructure + +2005-04-06 Sam Steingold <sd...@gn...> + * modules/clx/new-clx/clx.f (XLIB::%DISPLAY-XID): new function (XLIB:DISPLAY-XID): return it (display_hash_table): pass the arguments the usual way, not via STACK --__--__-- Message: 7 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4441,1.4442 Date: Wed, 06 Apr 2005 20:21:00 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15261/src Modified Files: ChangeLog Log Message: more CLUE support Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4441 retrieving revision 1.4442 diff -u -d -r1.4441 -r1.4442 --- ChangeLog 6 Apr 2005 17:21:12 -0000 1.4441 +++ ChangeLog 6 Apr 2005 20:20:54 -0000 1.4442 @@ -1,5 +1,14 @@ 2005-04-06 Sam Steingold <sd...@gn...> + * modules/clx/new-clx/clx.f (set_resource_id, delete_resource_id): added + (make_xid_obj_2): use set_resource_id() + (XLIB::SAVE-ID, XLIB::DEALLOCATE-RESOURCE-ID, XLIB:KEYSYM) + (XLIB::SET-GCONTEXT-DISPLAY): for CLUE + (XLIB:KEYSYM->CHARACTER): use int_char() + * modules/clx/new-clx/clx.lisp (GCONTEXT-DISPLAY): defsetf for CLUE + +2005-04-06 Sam Steingold <sd...@gn...> + * .gdbinit (full): added commented-out module debugging infrastructure 2005-04-06 Sam Steingold <sd...@gn...> --__--__-- Message: 8 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx clx.lisp,1.8,1.9 clx.f,2.32,2.33 Date: Wed, 06 Apr 2005 20:21:02 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15261/modules/clx/new-clx Modified Files: clx.lisp clx.f Log Message: more CLUE support Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.32 retrieving revision 2.33 diff -u -d -r2.32 -r2.33 --- clx.f 6 Apr 2005 17:17:36 -0000 2.32 +++ clx.f 6 Apr 2005 20:20:58 -0000 2.33 @@ -777,6 +777,28 @@ } } +/* set the ID to map to RESOURCE on display + < display hash-table object, XID number, resource object + can trigger GC */ +static void set_resource_id (gcv_object_t *ht, XID xid, + gcv_object_t *resource) { + pushSTACK(make_uint16 (xid & 0xFFFF)); /* lower halfword */ + pushSTACK(make_uint16 (xid >> 16)); /* upper halfword */ + funcall(L(cons),2); /* cons `em */ + pushSTACK(value1); /* key for puthash */ + pushSTACK(*ht); /* hashtable */ + pushSTACK(*resource); /* value */ + funcall (L(puthash), 3); /* put it into the hashtable */ +} + +/* delete the resource ID from the display + < display hash-table object, XID number */ +static Values delete_resource_id (gcv_object_t *ht, XID xid) { + Car (O(xlib_a_cons)) = make_uint16 (xid & 0xFFFF); /* lower halfword */ + Cdr (O(xlib_a_cons)) = make_uint16 (xid >> 16); /* upper halfword */ + pushSTACK(O(xlib_a_cons)); pushSTACK(*ht); funcall(L(remhash),2); +} + static object make_xid_obj_2 (object type, object dpy, XID xid, object prealloc) { /* NOTE: - This code is not reentrant :-( But hence it saves consing @@ -800,14 +822,7 @@ pushSTACK(dpy); /* ditto */ pushSTACK(ht); /* hashtable */ pushSTACK(make_xid_obj_low (&STACK_3, &STACK_2, &STACK_1, xid)); - /* Now enter this into the hashtable */ - pushSTACK(make_uint16 (xid & 0xFFFF)); /* lower halfword */ - pushSTACK(make_uint16 (xid >> 16)); /* upper halfword */ - funcall(L(cons),2); /* cons `em */ - pushSTACK(value1); /* key for puthash */ - pushSTACK(STACK_2); /* hashtable */ - pushSTACK(STACK_2); /* value */ - funcall (L(puthash), 3); /* put it into the hashtable */ + set_resource_id(&STACK_1,xid,&STACK_0); /* enter it into the hashtable */ VALUES1(popSTACK()); /* return freshly allocated structure */ skipSTACK(4); /* remove saved prealloc, type, dpy, ht */ } @@ -1849,12 +1864,44 @@ VALUES1(``XLIB::%DISPLAY-XID``); } -DEFUN(XLIB::LOOKUP-RESOURCE-ID, display id) { +DEFUN(XLIB::LOOKUP-RESOURCE-ID, display id) { /* used by RGB-COLORMAPS */ XID resource_id = get_uint29(popSTACK()); object ht = lookup_xid(popSTACK(),resource_id); /* set value1 if found */ if (!eq(ht,nullobj)) VALUES1(NIL); /* not found */ } +DEFUN(XLIB::SAVE-ID, display id resource) { /* used by CLUE */ + XID resource_id = get_uint29(STACK_1); + STACK_2 = display_hash_table(STACK_2); + set_resource_id(&STACK_2,resource_id,&STACK_0); + VALUES1(STACK_0); + skipSTACK(3); +} + +DEFUN(XLIB::DEALLOCATE-RESOURCE-ID, display id type) { /* used by CLUE */ + XID resource_id = get_uint29(STACK_1); + STACK_2 = display_hash_table(STACK_2); + delete_resource_id(&STACK_2,resource_id); /* sets values */ + skipSTACK(3); +} + +DEFUN(XLIB::SET-GCONTEXT-DISPLAY, display gcontext) { /* used by CLUE */ + Display *dpy_orig, *dpy_new; + GC gcon = get_gcontext_and_display(STACK_0,&dpy_orig); + pushSTACK(STACK_1); dpy_new = pop_display(); + if (dpy_orig != dpy_new) { + pushSTACK(uint32_to_I(dpy_orig)); pushSTACK(uint32_to_I(dpy_new)); + pushSTACK(STACK_3)/*gc*/; pushSTACK(STACK_3)/* dpy */; + pushSTACK(TheSubr(subr_self)->name); + fehler(error,"~S: cannot change dpy of ~S to ~S (~S is not ~S)"); + } + pushSTACK(STACK_0); /* GC */ + pushSTACK(`XLIB::DISPLAY`); /* slot */ + pushSTACK(STACK_3); /* dpy */ + funcall(L(set_slot_value),3); + skipSTACK(2); +} + DEFUN(XLIB:DISPLAY-AFTER-FUNCTION, display) /* OK */ { ensure_living_display (&(STACK_0)); @@ -6786,9 +6833,8 @@ keysym = get_uint32 (popSTACK()); dpy = pop_display (); - - NOTIMPLEMENTED; /* Too wired -- I have to browse some more in the manuals ... Back soon. */ + VALUES1(int_char(keysym)); /* how about just int_char ?! */ } /* Return keycodes for keysym, as multiple values @@ -6802,6 +6848,30 @@ UNDEFINED; } +DEFUN(XLIB:KEYSYM, keysym &rest bytes) { /* see mit-clx/translate.lisp */ + if (uint8_p(STACK_(argcount))) { + uint32 keysym = get_uint8(STACK_(argcount)); + int count = argcount; + while (count--) keysym = (keysym<<8) | get_uint8(STACK_(count)); + skipSTACK(argcount+1); + VALUES1(make_uint32(keysym)); + } else if ((stringp(STACK_(argcount)) || symbolp(STACK_(argcount))) + && argcount==0) { + KeySym keysym; + /* unfortunately, keysyms should be named Hyper_L or Super_R, + not :left-hyper or :right-super */ + with_stringable_0_tc(STACK_0,GLO(misc_encoding),name, { + X_CALL(keysym=XStringToKeysym(name)); + }); + skipSTACK(1); + VALUES1(make_uint32(keysym)); + } else { + object tmp = listof(argcount+1); pushSTACK(tmp); + pushSTACK(TheSubr(subr_self)->name); + fehler(error,("~S: invalid arguments ~S")); + } +} + /* And there also the undocumented function: DEFUN(XLIB:KEYCODE->CHARACTER, a1 a2 a3 &key KEYSYM-INDEX KEYSYM-INDEX-FUNCTION) {UNDEFINED;} */ Index: clx.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.lisp,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- clx.lisp 6 Apr 2005 17:17:35 -0000 1.8 +++ clx.lisp 6 Apr 2005 20:20:58 -0000 1.9 @@ -435,6 +435,9 @@ `(SET-WINDOW-PRIORITY ,mode ,window ,sibling)) (defsetf WINDOW-SAVE-UNDER SET-WINDOW-SAVE-UNDER) +;; for CLUE +(defsetf GCONTEXT-DISPLAY SET-GCONTEXT-DISPLAY) + ;;;; -------------------------------------------------------------------------- ;;;; Macros --__--__-- Message: 9 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4442,1.4443 Date: Wed, 06 Apr 2005 20:51:57 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5334/src Modified Files: ChangeLog Log Message: resource.lisp: added (from wit-clx with minor adaptations) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4442 retrieving revision 1.4443 diff -u -d -r1.4442 -r1.4443 --- ChangeLog 6 Apr 2005 20:20:54 -0000 1.4442 +++ ChangeLog 6 Apr 2005 20:51:51 -0000 1.4443 @@ -1,5 +1,10 @@ 2005-04-06 Sam Steingold <sd...@gn...> + * modules/clx/new-clx/resource.lisp: added (from mit-clx with + minor adaptations) + +2005-04-06 Sam Steingold <sd...@gn...> + * modules/clx/new-clx/clx.f (set_resource_id, delete_resource_id): added (make_xid_obj_2): use set_resource_id() (XLIB::SAVE-ID, XLIB::DEALLOCATE-RESOURCE-ID, XLIB:KEYSYM) --__--__-- Message: 10 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx resource.lisp,NONE,2.1 link.sh.in,1.3,1.4 clx.f,2.33,2.34 Makefile.in,1.7,1.8 Date: Wed, 06 Apr 2005 20:51:58 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5334/modules/clx/new-clx Modified Files: link.sh.in clx.f Makefile.in Added Files: resource.lisp Log Message: resource.lisp: added (from wit-clx with minor adaptations) Index: Makefile.in =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/Makefile.in,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- Makefile.in 26 Feb 2004 20:06:27 -0000 1.7 +++ Makefile.in 6 Apr 2005 20:51:56 -0000 1.8 @@ -9,7 +9,7 @@ LN = ln SHELL = /bin/sh -DISTRIBFILES = link.sh Makefile clx-preload.lisp clx.lisp clx.fas image.lisp image.fas clx.o +DISTRIBFILES = link.sh Makefile clx-preload.lisp clx.lisp image.lisp resource.lisp clx.o distribdir = ### Custom defs. @@ -18,7 +18,7 @@ WANTS = @WANTS@ X_CFLAGS = @X_CFLAGS@ -all : clx.fas image.fas clx.o +all : clx.fas image.fas resource.fas clx.o clx.fas clx.lib: clx.lisp clx-preload.lisp $(CLISP) -i clx-preload.lisp -c clx.lisp @@ -26,6 +26,9 @@ image.fas: image.lisp clx.lib $(CLISP) -i clx-preload.lisp -c image.lisp +resource.fas: resource.lisp clx.lib + $(CLISP) -i clx-preload.lisp -c resource.lisp + clx.e: clx.f $(CCMP2C) clx.f > genclx.c $(CC) $(CPPFLAGS) $(CFLAGS) $(WANTS) genclx.c -o genclx @@ -41,7 +44,7 @@ $(CC) $(CPPFLAGS) $(CFLAGS) $(X_CFLAGS) -I$(INCLUDES) -c clx.c # Make a module -clisp-module : clx.fas image.fas clx.o +clisp-module : clx.fas image.fas resource.fas clx.o # Make a module distribution into $(distribdir) clisp-module-distrib : clisp-module force @@ -49,7 +52,7 @@ clean : force - $(RM) genclx.c genclx clx.temp *.lib *.fas clx.e clx.d clx.c clx.o + $(RM) genclx.c genclx *.lib *.fas clx.e clx.d clx.c clx.o force: Index: link.sh.in =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/link.sh.in,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- link.sh.in 26 Feb 2004 20:06:27 -0000 1.3 +++ link.sh.in 6 Apr 2005 20:51:55 -0000 1.4 @@ -1,11 +1,8 @@ -file_list='' -mod_list='' -file_list="$file_list"' clx.o' -mod_list="$mod_list"' clx' -make clisp-module CC="${CC}" CPPFLAGS="${CPPFLAGS}" CFLAGS="${CFLAGS}" INCLUDES="$absolute_linkkitdir" -NEW_FILES="$file_list" -NEW_LIBS="$file_list @X_LIBS@ @X_PRE_LIBS@ -lX11" -NEW_MODULES="$mod_list" -NEW_FILES="$NEW_FILES clx-preload.lisp clx.lisp clx.fas image.lisp image.fas" +make clisp-module \ + CC="${CC}" CPPFLAGS="${CPPFLAGS}" CFLAGS="${CFLAGS}" \ + INCLUDES="$absolute_linkkitdir" +NEW_FILES="clx.o" +NEW_LIBS="${NEW_FILES} @X_LIBS@ @X_PRE_LIBS@ -lX11" +NEW_MODULES="clx" TO_PRELOAD='clx-preload.lisp' -TO_LOAD='clx image' +TO_LOAD='clx image resource' Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.33 retrieving revision 2.34 diff -u -d -r2.33 -r2.34 --- clx.f 6 Apr 2005 20:20:58 -0000 2.33 +++ clx.f 6 Apr 2005 20:51:55 -0000 2.34 @@ -6452,7 +6452,8 @@ * Chapter 13 Resources * ----------------------------------------------------------------------- */ -/* Maybe we want simply to drop in the LISP code here? */ +/* Maybe we want simply to drop in the LISP code here? + -- I did (sds) */ /* 13.3 Basic Resource Database Functions */ ##if 0 --- NEW FILE: resource.lisp --- ;;; -*- Mode: LISP; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;; RESOURCE - Lisp version of XLIB's Xrm resource manager ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (require :clx) (in-package :xlib) (declaim (declaration clx-values)) ;; The C version of this uses a 64 entry hash table at each entry. ;; Small hash tables lose in Lisp, so we do linear searches on lists. (defstruct (resource-database (:copier nil) (:predicate nil) (:constructor make-resource-database-internal)) (name nil :type stringable :read-only t) (value nil) (tight nil :type list) ;; List of resource-database (loose nil :type list) ;; List of resource-database ) (defmethod print-object ((database resource-database) (stream stream)) (declare (type resource-database database)) (print-unreadable-object (database stream :type t) (write-string (string (resource-database-name database)) stream) (when (resource-database-value database) (write-string " " stream) (prin1 (resource-database-value database) stream)))) ;; The value slot of the top-level resource-database structure is used for a ;; time-stamp. (defun make-resource-database () ;; Make a resource-database with initial timestamp of 0 (make-resource-database-internal :name "Top-Level" :value 0)) (defun resource-database-timestamp (database) (declare (type resource-database database)) (resource-database-value database)) (defun incf-resource-database-timestamp (database) ;; Increment the timestamp (declare (type resource-database database)) (let ((timestamp (resource-database-value database))) (setf (resource-database-value database) (if (= timestamp most-positive-fixnum) most-negative-fixnum (1+ timestamp))))) ;; DEBUG FUNCTION (not exported) (defun print-db (entry &optional (level 0) type) ;; Debug function to print a resource database (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" level (resource-database-name entry) (eq type 'loose) (resource-database-value entry)) (when (resource-database-tight entry) (dolist (tight (resource-database-tight entry)) (print-db tight (+ 2 level) 'tight))) (when (resource-database-loose entry) (dolist (loose (resource-database-loose entry)) (print-db loose (+ 2 level) 'loose)))) ;; DEBUG FUNCTION #+comment (defun print-search-table (table) (terpri) (dolist (dbase-list table) (format t "~%~s" dbase-list) (dolist (db dbase-list) (print-db db) (dolist (dblist table) (unless (eq dblist dbase-list) (when (member db dblist) (format t " duplicate at ~s" db)))) ))) ;; ;; If this is true, resource symbols will be compared in a case-insensitive ;; manner, and converting a resource string to a keyword will uppercaseify it. ;; (defparameter *uppercase-resource-symbols* nil) (defun resource-key (stringable) ;; Ensure STRINGABLE is a keyword. (declare (type stringable stringable)) (etypecase stringable (symbol (if (keywordp (the symbol stringable)) stringable (kintern (symbol-name (the symbol stringable))))) (string (if *uppercase-resource-symbols* (setq stringable (string-upcase (the string stringable)))) (kintern (the string stringable))))) (defun stringable-equal (a b) ;; Compare two stringables. ;; Ignore case when comparing to a symbol. (declare (type stringable a b)) (declare (clx-values generalized-boolean)) (etypecase a (string (etypecase b (string (string= (the string a) (the string b))) (symbol (if *uppercase-resource-symbols* (string-equal (the string a) (the string (symbol-name (the symbol b)))) (string= (the string a) (the string (symbol-name (the symbol b)))))))) (symbol (etypecase b (string (if *uppercase-resource-symbols* (string-equal (the string (symbol-name (the symbol a))) (the string b)) (string= (the string (symbol-name (the symbol a))) (the string b)))) (symbol (string= (the string (symbol-name (the symbol a))) (the string (symbol-name (the symbol b))))))))) ;;;----------------------------------------------------------------------------- ;;; Add/delete resource (defun add-resource (database name-list value) ;; name-list is a list of either strings or symbols. If a symbol, ;; case-insensitive comparisons will be used, if a string, ;; case-sensitive comparisons will be used. The symbol '* or ;; string "*" are used as wildcards, matching anything or nothing. (declare (type resource-database database) (type (clx-list stringable) name-list) (type t value)) (unless value (error "Null resource values are ignored")) (incf-resource-database-timestamp database) (do* ((list name-list (cdr list)) (name (car list) (car list)) (node database) (loose-p nil)) ((endp list) (setf (resource-database-value node) value)) ;; Key is the first name that isn't * (if (stringable-equal name "*") (setq loose-p t) ;; find the entry associated with name (progn (do ((entry (if loose-p (resource-database-loose node) (resource-database-tight node)) (cdr entry))) ((endp entry) ;; Entry not found - create a new one (setq entry (make-resource-database-internal :name name)) (if loose-p (push entry (resource-database-loose node)) (push entry (resource-database-tight node))) (setq node entry)) (when (stringable-equal name (resource-database-name (car entry))) ;; Found entry - use it (return (setq node (car entry))))) (setq loose-p nil))))) (defun delete-resource (database name-list) (declare (type resource-database database) (type list name-list)) (incf-resource-database-timestamp database) (delete-resource-internal database name-list)) (defun delete-resource-internal (database name-list) (declare (type resource-database database) (type (clx-list stringable) name-list)) (do* ((list name-list (cdr list)) (string (car list) (car list)) (node database) (loose-p nil)) ((endp list) nil) ;; Key is the first name that isn't * (if (stringable-equal string "*") (setq loose-p t) ;; find the entry associated with name (progn (do* ((first-entry (if loose-p (resource-database-loose node) (resource-database-tight node))) (entry-list first-entry (cdr entry-list)) (entry (car entry-list) (car entry-list))) ((endp entry-list) ;; Entry not found - exit (return-from delete-resource-internal nil)) (when (stringable-equal string (resource-database-name entry)) (when (cdr list) (delete-resource-internal entry (cdr list))) (when (and (null (resource-database-loose entry)) (null (resource-database-tight entry))) (if loose-p (setf (resource-database-loose node) (delete entry (resource-database-loose node) :test #'eq :count 1)) (setf (resource-database-tight node) (delete entry (resource-database-tight node) :test #'eq :count 1)))) (return-from delete-resource-internal t))) (setq loose-p nil))))) ;;;----------------------------------------------------------------------------- ;;; Get Resource (defun get-resource (database value-name value-class full-name full-class) ;; Return the value of the resource in DATABASE whose partial name ;; most closely matches (append full-name (list value-name)) and ;; (append full-class (list value-class)). (declare (type resource-database database) (type stringable value-name value-class) (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let ((names (append full-name (list value-name))) (classes (append full-class (list value-class)))) (let* ((result (get-entry (resource-database-tight database) (resource-database-loose database) names classes))) (when result (resource-database-value result))))) (defun get-entry-lookup (table name names classes) (declare (type list table names classes) (type stringable name)) (dolist (entry table) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (if (null (cdr names)) (return entry) (let ((result (get-entry (resource-database-tight entry) (resource-database-loose entry) (cdr names) (cdr classes)))) (declare (type (or null resource-database) result)) (when result (return result) )))))) (defun get-entry (tight loose names classes &aux result) (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) (declare (type stringable name class)) (cond ((and tight (get-entry-lookup tight name names classes))) ((and loose (get-entry-lookup loose name names classes))) ((and tight (not (stringable-equal name class)) (get-entry-lookup tight class names classes))) ((and loose (not (stringable-equal name class)) (get-entry-lookup loose class names classes))) (loose (loop (pop names) (pop classes) (unless (and names classes) (return nil)) (setq name (car names) class (car classes)) (when (setq result (get-entry-lookup loose name names classes)) (return result)) (when (and (not (stringable-equal name class)) (setq result (get-entry-lookup loose class names classes))) (return result)) ))))) ;;;----------------------------------------------------------------------------- ;;; Get-resource with search-table (defun get-search-resource (table name class) ;; (get-search-resource (get-search-table database full-name full-class) ;; value-name value-class) ;; is equivalent to ;; (get-resource database value-name value-class full-name full-class) ;; But since most of the work is done by get-search-table, ;; get-search-resource is MUCH faster when getting several resources with ;; the same full-name/full-class (declare (type list table) (type stringable name class)) (let ((do-class (and class (not (stringable-equal name class))))) (dolist (dbase-list table) (declare (type list dbase-list)) (dolist (dbase dbase-list) (declare (type resource-database dbase)) (when (stringable-equal name (resource-database-name dbase)) (return-from get-search-resource (resource-database-value dbase)))) (when do-class (dolist (dbase dbase-list) (declare (type resource-database dbase)) (when (stringable-equal class (resource-database-name dbase)) (return-from get-search-resource (resource-database-value dbase)))))))) (defvar *get-table-result*) (defun get-search-table (database full-name full-class) ;; Return a search table for use with get-search-resource. (declare (type resource-database database) (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let* ((tight (resource-database-tight database)) (loose (resource-database-loose database)) (result (cons nil nil)) (*get-table-result* result)) (declare (type list tight loose) (type cons result)) (when (or tight loose) (when full-name (get-tables tight loose full-name full-class)) ;; Pick up bindings of the form (* name). These are the elements of ;; top-level loose without further tight/loose databases. ;; ;; (Hack: these bindings belong in ANY search table, so recomputing them ;; is a drag. True fix involves redesigning entire lookup ;; data-structure/algorithm.) ;; (let ((universal-bindings (remove nil loose :test-not #'eq :key #'(lambda (database) (or (resource-database-tight database) (resource-database-loose database)))))) (when universal-bindings (setf (cdr *get-table-result*) (list universal-bindings))))) (cdr result))) (defun get-tables-lookup (dbase name names classes) (declare (type list dbase names classes) (type stringable name)) #-clx-debugging (declare (optimize speed)) (dolist (entry dbase) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (let ((tight (resource-database-tight entry)) (loose (resource-database-loose entry))) (declare (type list tight loose)) (when (or tight loose) (if (cdr names) (get-tables tight loose (cdr names) (cdr classes)) (when tight (let ((result *get-table-result*)) ;; Put tight at end of *get-table-result* (setf (cdr result) (setq *get-table-result* (cons tight nil)))))) (when loose (let ((result *get-table-result*)) ;; Put loose at end of *get-table-result* (setf (cdr result) (setq *get-table-result* (cons loose nil)))))))))) (defun get-tables (tight loose names classes) (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) (declare (type stringable name class)) (when tight (get-tables-lookup tight name names classes)) (when loose (get-tables-lookup loose name names classes)) (when (and tight (not (stringable-equal name class))) (get-tables-lookup tight class names classes)) (when (and loose (not (stringable-equal name class))) (get-tables-lookup loose class names classes)) (when loose (loop (pop names) (pop classes) (unless (and names classes) (return nil)) (setq name (car names) class (car classes)) (get-tables-lookup loose name names classes) (unless (stringable-equal name class) (get-tables-lookup loose class names classes)) )))) ;;;----------------------------------------------------------------------------- ;;; Utility functions (defun map-resource (database function &rest args) ;; Call FUNCTION on each resource in DATABASE. ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) (type (function (list t &rest t) t) function) (dynamic-extent function) (dynamic-extent args)) (declare (clx-values nil)) (labels ((map-resource-internal (database function args name) (declare (type resource-database database) (type (function (list t &rest t) t) function) (type list name) (dynamic-extent function)) (let ((tight (resource-database-tight database)) (loose (resource-database-loose database))) (declare (type list tight loose)) (dolist (resource tight) (declare (type resource-database resource)) (let ((value (resource-database-value resource)) (name (append name (list (resource-database-name resource))))) (if value (apply function name value args) (map-resource-internal resource function args name)))) (dolist (resource loose) (declare (type resource-database resource)) (let ((value (resource-database-value resource)) (name (append name (list "*" (resource-database-name resource))))) (if value (apply function name value args) (map-resource-internal resource function args name))))))) (map-resource-internal database function args nil))) (defun merge-resources (database with-database) (declare (type resource-database database with-database)) (declare (clx-values resource-database)) (map-resource database #'(lambda (name value database) (add-resource database name value)) with-database) with-database) (defun char-memq (key char) ;; Used as a test function for POSITION (declare (type base-char char)) (member char key)) (defmacro resource-with-open-file ((stream pathname &rest options) &body body) ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the ;; stream (let ((abortp (gensym)) (streamp (gensym))) `(let* ((,abortp t) (,streamp (streamp pathname)) (,stream (if ,streamp pathname (open ,pathname ,@options)))) (unwind-protect (multiple-value-prog1 (progn ,@body) (setq ,abortp nil)) (unless ,streamp (close stream :abort ,abortp)))))) (defun read-resources (database pathname &key key test test-not) ;; Merges resources from a file in standard X11 format with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (resource-with-open-file (stream pathname) (loop (let ((string (read-line stream nil :eof))) (declare (type (or string keyword) string)) (when (eq string :eof) (return database)) (let* ((end (length string)) (i (position '(#\tab #\space) string :test-not #'char-memq :end end)) (term nil)) (declare (type array-index end) (type (or null array-index) i term)) (when i ;; else blank line (case (char string i) (#\! nil) ;; Comment - skip ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip (#\# ;; Include (setq term (position '(#\tab #\space) string :test #'char-memq :start i :end end)) (when (string-equal string "#INCLUDE" :start1 i :end1 term) (let ((path (merge-pathnames (string-trim '(#\tab #\space #\") (subseq string (1+ term))) (truename stream)))) (read-resources database path :key key :test test :test-not test-not)))) (otherwise (multiple-value-bind (name-list value) (parse-resource string i end) (when name-list (when key (setq value (funcall key value))) (when (cond (test (funcall test name-list value)) (test-not (not (funcall test-not name-list value))) (t t)) (add-resource database name-list value)))))))))))) (defun parse-resource (string &optional (start 0) end) ;; Parse a resource specfication string into a list of names and a value ;; string (declare (type string string) (type array-index start) (type (or null array-index) end)) (declare (clx-values name-list value)) (do ((i start) (end (or end (length string))) (term) (name-list)) ((>= i end)) (declare (type array-index end) (type (or null array-index) i term)) (setq term (position '(#\. #\* #\:) string :test #'char-memq :start i :end end)) (case (and term (char string term)) ;; Name seperator (#\. (when (> term i) (push (subseq string i term) name-list))) ;; Wildcard seperator (#\* (when (> term i) (push (subseq string i term) name-list)) (push '* name-list)) ;; Value separator (#\: (push (subseq string i term) name-list) (return (values (nreverse name-list) (string-trim '(#\tab #\space) (subseq string (1+ term)))))) (otherwise (return (values (nreverse name-list) (subseq string i term))))) (setq i (1+ term)))) (defun write-resources (database pathname &key write test test-not) ;; Write resources to PATHNAME in the standard X11 format. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string stream) t)) write) (type (or null (function (list t) generalized-boolean)) test test-not)) (resource-with-open-file (stream pathname :direction :output) (map-resource database #'(lambda (name-list value stream write test test-not) (when (cond (test (funcall test name-list value)) (test-not (not (funcall test-not name-list value))) (t t)) (let ((previous (car name-list))) (princ previous stream) (dolist (name (cdr name-list)) (unless (or (stringable-equal name "*") (stringable-equal previous "*")) (write-char #\. stream)) (setq previous name) (princ name stream))) (write-string ": " stream) (funcall write value stream) (terpri stream))) stream (or write #'princ) test test-not)) database) (defun wm-resources (database window &key key test test-not) ;; Takes the resources associated with the RESOURCE_MANAGER property ;; of WINDOW (if any) and merges them with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type window window) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (let ((string (get-property window :RESOURCE_MANAGER :type :STRING :result-type 'string :transform #'xlib::card8->char))) (when string (with-input-from-string (stream string) (read-resources database stream :key key :test test :test-not test-not))))) (defun set-wm-resources (database window &key write test test-not) ;; Sets the resources associated with the RESOURCE_MANAGER property ;; of WINDOW. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type window window) (type (or null (function (string stream) t)) write) (type (or null (function (list t) generalized-boolean)) test test-not)) (xlib::set-string-property window :RESOURCE_MANAGER (with-output-to-string (stream) (write-resources database stream :write write :test test :test-not test-not)))) (defun root-resources (screen &key database key test test-not) "Returns a resource database containing the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. If an existing DATABASE is given, then resource values are merged with the DATABASE and the modified DATABASE is returned. TEST and TEST-NOT are predicates for selecting which resources are read. Arguments are a resource name list and a resource value. The KEY function, if given, is called to convert a resource value string to the value given to TEST or TEST-NOT." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not) (clx-values resource-database)) (let* ((screen (if (typep screen 'display) (display-default-screen screen) screen)) (window (screen-root screen)) (database (or database (make-resource-database)))) (wm-resources database window :key key :test test :test-not test-not) database)) (defun set-root-resources (screen &key test test-not (write #'princ) database) "Changes the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. TEST and TEST-NOT are predicates for selecting which resources from the DATABASE are written. Arguments are a resource name list and a resource value. The WRITE function is used to convert a resource value into a string stored in the property." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (list t) generalized-boolean)) test test-not) (type (or null (function (string stream) t)) write) (clx-values resource-database)) (let* ((screen (if (typep screen 'display) (display-default-screen screen) screen)) (window (screen-root screen))) (set-wm-resources database window :write write :test test :test-not test-not) database)) (defsetf root-resources (screen &key test test-not (write #'princ))(database) `(set-root-resources ,screen :test ,test :test-not ,test-not :write ,write :database ,database)) (defun default-resources-pathname () (make-pathname :name ".Xdefaults" :defaults (user-homedir-pathname))) (defun resources-pathname () (or (let ((string (ext:getenv "XENVIRONMENT"))) (and string (pathname string))) (make-pathname :name (ext:string-concat ".Xdefaults-" (let ((s (machine-instance))) ; hostname (subseq s 0 (position #\Space s)))) :defaults (user-homedir-pathname)))) (defun initialize-resource-database (display) ;; This function is (supposed to be) equivalent to the Xlib initialization ;; code. (declare (type display display)) (let ((rdb (make-resource-database)) (rootwin (screen-root (car (display-roots display))))) ;; First read the server defaults if present, otherwise from the default ;; resource file (if (get-property rootwin :RESOURCE_MANAGER) (wm-resources rdb rootwin) (let ((path (default-resources-pathname))) (when (and path (probe-file path)) (read-resources rdb path)))) ;; Next read from the resources file (let ((path (resources-pathname))) (when (and path (probe-file path)) (read-resources rdb path))) ;; do we need to record the database? ;; (setf (display-xdefaults display) rdb) )) --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |