Menu
▾
▴
clisp-cvs digest, Vol 1 #1033 - 10 msgs
|
From: <cli...@li...> - 2005-03-28 20:20:19
|
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/doc impext.xml,1.321,1.322 (Sam Steingold) 2. clisp/tests ffi.tst,1.35,1.36 ChangeLog,1.331,1.332 (Sam Steingold) 3. clisp/src foreign1.lisp,1.82,1.83 NEWS,1.243,1.244 ChangeLog,1.4413,1.4414 (Sam Steingold) 4. clisp/tests ffi.tst,1.36,1.37 (Sam Steingold) 5. clisp/modules/clx/new-clx clx.f,2.27,2.28 (Sam Steingold) 6. clisp/src ChangeLog,1.4414,1.4415 (Sam Steingold) 7. clisp/modules/clx/new-clx clx.f,2.28,2.29 (Sam Steingold) 8. clisp/src ChangeLog,1.4415,1.4416 (Sam Steingold) 9. clisp/src ChangeLog,1.4416,1.4417 (Sam Steingold) 10. clisp/modules/clx/new-clx clx.f,2.29,2.30 (Sam Steingold) --__--__-- Message: 1 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impext.xml,1.321,1.322 Date: Mon, 28 Mar 2005 17:06:51 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9177/doc Modified Files: impext.xml Log Message: (DEF-C-VAR, DEF-CALL-OUT): accept :DOCUMENTATION Index: impext.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impext.xml,v retrieving revision 1.321 retrieving revision 1.322 diff -u -d -r1.321 -r1.322 --- impext.xml 28 Mar 2005 01:31:16 -0000 1.321 +++ impext.xml 28 Mar 2005 17:06:46 -0000 1.322 @@ -2361,6 +2361,9 @@ <simpara>&name-r; should <emphasis>evaluate</emphasis> to a &string-t; or, depending on the underlying &dlsym; implementation, &default-k; or <constant>:NEXT</constant>.</simpara></listitem></varlistentry> +<varlistentry><term><code>(&documentation-k; &string-r;)</code></term> + <listitem><simpara>Specifies the (optional) variable documentation. +</simpara></listitem></varlistentry> </variablelist></listitem></varlistentry> <varlistentry id="def-call-out"><term><code>(&def-call-out; @@ -2392,6 +2395,9 @@ <simpara>&name-r; should <emphasis>evaluate</emphasis> to a &string-t;, or, depending on the underlying &dlsym; implementation, &default-k; or <constant>:NEXT</constant>.</simpara></listitem></varlistentry> +<varlistentry><term><code>(&documentation-k; &string-r;)</code></term> + <listitem><simpara>Specifies the (optional) function documentation. +</simpara></listitem></varlistentry> </variablelist></listitem></varlistentry> <varlistentry id="def-call-in"><term><code>(&def-call-in; --__--__-- Message: 2 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/tests ffi.tst,1.35,1.36 ChangeLog,1.331,1.332 Date: Mon, 28 Mar 2005 17:06:25 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9177/tests Modified Files: ffi.tst ChangeLog Log Message: (DEF-C-VAR, DEF-CALL-OUT): accept :DOCUMENTATION Index: ffi.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ffi.tst,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- ffi.tst 4 Jan 2005 15:47:21 -0000 1.35 +++ ffi.tst 28 Mar 2005 17:06:18 -0000 1.36 @@ -19,10 +19,14 @@ (def-call-out c-self (:name "ffi_identity") + (:documentation "return the pointer argument as is") (:arguments (obj c-pointer)) (:return-type c-pointer) (:language :stdc)) C-SELF +(stringp (documentation 'c-self 'function)) +T + (typep #'c-self 'function) T Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.331 retrieving revision 1.332 diff -u -d -r1.331 -r1.332 --- ChangeLog 27 Mar 2005 02:56:46 -0000 1.331 +++ ChangeLog 28 Mar 2005 17:06:22 -0000 1.332 @@ -1,3 +1,7 @@ +2005-03-28 Sam Steingold <sd...@gn...> + + * ffi.tst (c-self): test the :DOCUMENTATION option to DEF-CALL-OUT + 2005-03-26 Sam Steingold <sd...@gn...> * excepsit.tst ("sys:foo.bar."): fixed the test (parse-namestring --__--__-- Message: 3 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src foreign1.lisp,1.82,1.83 NEWS,1.243,1.244 ChangeLog,1.4413,1.4414 Date: Mon, 28 Mar 2005 17:06:48 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9177/src Modified Files: foreign1.lisp NEWS ChangeLog Log Message: (DEF-C-VAR, DEF-CALL-OUT): accept :DOCUMENTATION Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.243 retrieving revision 1.244 diff -u -d -r1.243 -r1.244 --- NEWS 14 Mar 2005 18:36:53 -0000 1.243 +++ NEWS 28 Mar 2005 17:06:24 -0000 1.244 @@ -277,6 +277,9 @@ * New FFI function CLOSE-FOREIGN-LIBRARY can be used to unload a library. See <http://clisp.cons.org/impnotes.html#dffi-close-lib> for details. +* Foreign functions and variables can now be documented using the + :DOCUMENTATION option to DEF-CALL-OUT and DEF-C-VAR. + * Buffered streams now are suitable for interactive streams. It is no longer necessary to use :BUFFERED NIL to avoid blocking in various situations. Index: foreign1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/foreign1.lisp,v retrieving revision 1.82 retrieving revision 1.83 diff -u -d -r1.82 -r1.83 --- foreign1.lisp 1 Feb 2005 17:22:48 -0000 1.82 +++ foreign1.lisp 28 Mar 2005 17:06:23 -0000 1.83 @@ -799,8 +799,10 @@ (defmacro DEF-C-VAR (&whole whole-form name &rest options) (setq name (check-symbol name (first whole-form))) - (let* ((alist (parse-options options '(:name :type :read-only :alloc :library) + (let* ((alist (parse-options options '(:name :type :read-only :alloc + :library :documentation) whole-form)) + (doc (assoc ':documentation alist)) (c-name (foreign-name name (assoc ':name alist))) (type (second (or (assoc ':type alist) (sys::error-of-type 'ext:source-program-error @@ -842,6 +844,7 @@ ',c-name (FFI::FOREIGN-LIBRARY ,library) nil (PARSE-C-TYPE ',type)) `(LOOKUP-FOREIGN-VARIABLE ',c-name (PARSE-C-TYPE ',type))))) + ,@(when doc `((SETF (DOCUMENTATION ',name 'VARIABLE) ',(second doc)))) (DEFINE-SYMBOL-MACRO ,name (FOREIGN-VALUE (LOAD-TIME-VALUE (GET ',name 'FOREIGN-VARIABLE)))) ',name))) @@ -934,10 +937,10 @@ (defmacro DEF-CALL-OUT (&whole whole-form name &rest options) (setq name (check-symbol name (first whole-form))) (let* ((alist - (parse-options - options - '(:name :arguments :return-type :language :built-in :library) - whole-form)) + (parse-options options '(:name :arguments :return-type :language + :built-in :library :documentation) + whole-form)) + (doc (assoc ':documentation alist)) (parsed-function (parse-c-function alist whole-form)) (signature (argvector-to-signature (svref parsed-function 2))) (library (second (assoc :library alist))) @@ -950,6 +953,7 @@ (LET () (SYSTEM::REMOVE-OLD-DEFINITIONS ',name) (COMPILER::EVAL-WHEN-COMPILE (COMPILER::C-DEFUN ',name ',signature)) + ,@(when doc `((SETF (DOCUMENTATION ',name 'FUNCTION) ',(second doc)))) (SYSTEM::%PUTD ',name ,(if library `(FFI::FOREIGN-LIBRARY-FUNCTION Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4413 retrieving revision 1.4414 diff -u -d -r1.4413 -r1.4414 --- ChangeLog 28 Mar 2005 01:31:13 -0000 1.4413 +++ ChangeLog 28 Mar 2005 17:06:24 -0000 1.4414 @@ -1,3 +1,8 @@ +2005-03-28 Sam Steingold <sd...@gn...> + + * foreign1.lisp (DEF-C-VAR, DEF-CALL-OUT): accept :DOCUMENTATION + Suggested by Yaroslav Kavenchuk <kav...@je...> + 2005-03-26 Sam Steingold <sd...@gn...> replaced -interactive-debug with -on-error <action> @@ -82,7 +87,7 @@ 2005-03-22 Sam Steingold <sd...@gn...> * modules/wildcard/wildcard.lisp (*features*): add :WILDCARD - Requested by Yaroslav Kavenchuk <kav...@je...> + Suggested by Yaroslav Kavenchuk <kav...@je...> 2005-03-22 Bruno Haible <br...@cl...> --__--__-- Message: 4 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/tests ffi.tst,1.36,1.37 Date: Mon, 28 Mar 2005 17:54:46 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5224/tests Modified Files: ffi.tst Log Message: comment Index: ffi.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ffi.tst,v retrieving revision 1.36 retrieving revision 1.37 diff -u -d -r1.36 -r1.37 --- ffi.tst 28 Mar 2005 17:06:18 -0000 1.36 +++ ffi.tst 28 Mar 2005 17:54:43 -0000 1.37 @@ -1,6 +1,6 @@ ;; -*- lisp -*- ;; (ext:cd "../tests/") (load "tests") (run-test "ffi") -;; ./clisp -norc -i suite/tests -x '(run-test "suite/ffi")' +;; ./clisp -E utf-8 -norc -i tests/tests -x '(run-test "tests/ffi")' (progn (defpackage "FTEST" (:use "FFI" "COMMON-LISP")) (in-package "FTEST") T) T --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx clx.f,2.27,2.28 Date: Mon, 28 Mar 2005 18:27:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20991/modules/clx/new-clx Modified Files: clx.f Log Message: (xlib_error_handler): use switch, not if Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.27 retrieving revision 2.28 diff -u -d -r2.27 -r2.28 --- clx.f 16 Mar 2005 20:55:37 -0000 2.27 +++ clx.f 28 Mar 2005 18:27:42 -0000 2.28 @@ -7041,7 +7041,7 @@ Lisp error handler here found in the ERROR-HANDLER slot in the display. */ int xlib_error_handler (Display *display, XErrorEvent *event) { - int f = 0; + int f = 11; begin_callback (); @@ -7073,33 +7073,33 @@ pushSTACK(`:MAJOR`); pushSTACK(make_uint8 (event->request_code)); pushSTACK(`:MINOR`); pushSTACK(make_uint16(event->minor_code)); - if (event->error_code == BadColor || /* colormap-error */ - event->error_code == BadCursor || /* cursor-error */ - event->error_code == BadDrawable || /* drawable-error */ - event->error_code == BadFont || /* font-error */ - event->error_code == BadGC || /* gcontext-error */ - event->error_code == BadIDChoice || /* id-choice-error */ - event->error_code == BadPixmap || /* pixmap-error */ - event->error_code == BadWindow) { /* window-error */ - pushSTACK(`:RESOURCE-ID`); - pushSTACK(make_uint32 (event->resourceid)); - f = 1; - } - - if (event->error_code == BadAtom) { /* atom-error */ - pushSTACK(`:ATOM-ID`); - pushSTACK(make_uint32 (event->resourceid)); - f = 1; - } - - if (event->error_code == BadValue) { /* value-error */ - pushSTACK(`:VALUE`); - pushSTACK(make_uint32 (event->resourceid)); - f = 1; + switch (event->error_code) { + case BadColor: /* colormap-error */ + case BadCursor: /* cursor-error */ + case BadDrawable: /* drawable-error */ + case BadFont: /* font-error */ + case BadGC: /* gcontext-error */ + case BadIDChoice: /* id-choice-error */ + case BadPixmap: /* pixmap-error */ + case BadWindow: /* window-error */ + pushSTACK(`:RESOURCE-ID`); + pushSTACK(make_uint32 (event->resourceid)); + f += 2; + break; + case BadAtom: /* atom-error */ + pushSTACK(`:ATOM-ID`); + pushSTACK(make_uint32 (event->resourceid)); + f += 2; + break; + case BadValue: /* value-error */ + pushSTACK(`:VALUE`); + pushSTACK(make_uint32 (event->resourceid)); + f += 2; + break; } /* Now call the handler: */ - funcall (L(funcall), f ? 13 : 11); + funcall (L(funcall), f); skipSTACK(1); /* clean up */ --__--__-- Message: 6 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4414,1.4415 Date: Mon, 28 Mar 2005 18:27:44 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20991/src Modified Files: ChangeLog Log Message: (xlib_error_handler): use switch, not if Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4414 retrieving revision 1.4415 diff -u -d -r1.4414 -r1.4415 --- ChangeLog 28 Mar 2005 17:06:24 -0000 1.4414 +++ ChangeLog 28 Mar 2005 18:27:18 -0000 1.4415 @@ -1,5 +1,9 @@ 2005-03-28 Sam Steingold <sd...@gn...> + * modules/clx/new-clx/clx.f (xlib_error_handler): use switch, not if + +2005-03-28 Sam Steingold <sd...@gn...> + * foreign1.lisp (DEF-C-VAR, DEF-CALL-OUT): accept :DOCUMENTATION Suggested by Yaroslav Kavenchuk <kav...@je...> --__--__-- Message: 7 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx clx.f,2.28,2.29 Date: Mon, 28 Mar 2005 19:04:23 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9536/modules/clx/new-clx Modified Files: clx.f Log Message: use getters with defaults Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.28 retrieving revision 2.29 diff -u -d -r2.28 -r2.29 --- clx.f 28 Mar 2005 18:27:42 -0000 2.28 +++ clx.f 28 Mar 2005 19:04:14 -0000 2.29 @@ -551,10 +551,13 @@ #define I_to_uint29 I_to_UL /* XXX ditto */ #define DEFINE_INTEGER_GETTER(type, lspnam) \ - type get_##type (object obj) { \ + static inline type get_##type (object obj) { \ if (type##_p (obj)) \ return I_to_##type (obj); \ else my_type_error(lspnam,obj); \ + } \ + static inline type get_##type##_0 (object obj) { \ + return missingp(obj) ? 0 : get_##type(obj); \ } DEFINE_INTEGER_GETTER (uint8, `XLIB::CARD8`) @@ -1183,7 +1186,7 @@ DEFCHECKER(get_new_value_or_deleted,default=, \ NEW-VALUE=PropertyNewValue DELETED=PropertyDelete) #define make_new_value_or_deleted get_new_value_or_deleted_reverse -DEFCHECKER(get_ordering,default=, UNSORTED=Unsorted Y-SORTED=YSorted \ +DEFCHECKER(get_ordering,default=Unsorted, UNSORTED=Unsorted Y-SORTED=YSorted \ YX-SORTED=YXSorted YX-BANDED=YXBanded) DEFCHECKER(get_mapping_request,default=, MODIFIER=MappingModifier \ KEYBOARD=MappingKeyboard POINTER=MappingPointer) @@ -1316,8 +1319,7 @@ static unsigned int get_modifier_mask (object obj) { - unsigned int mask = 0; - + if (!boundp(obj)) return 0; if (eq (obj, `:ANY`)) return AnyModifier; if (integerp (obj)) return get_uint16 (obj); if (listp(obj)) return check_modifier_from_list(obj); @@ -2984,7 +2986,7 @@ in the gcontext. We should think about the portability of using a halfword-vector and then beam the data directly into the rectangles vector. */ - int ordering = (missingp(STACK_0) ? Unsorted : get_ordering (STACK_0)); + int ordering = get_ordering(STACK_0); int n = get_sint32(funcall1(L(length),STACK_2)); /* See if length is a multiple of 4? */ @@ -3264,10 +3266,10 @@ { Display *dpy; Window win = get_drawable_and_display (STACK_5, &dpy); - int x = missingp(STACK_4) ? 0 : get_sint16 (STACK_4); - int y = missingp(STACK_3) ? 0 : get_sint16 (STACK_3); - int w = missingp(STACK_1) ? 0 : get_uint16 (STACK_2); - int h = missingp(STACK_1) ? 0 : get_uint16 (STACK_1); + int x = get_sint16_0 (STACK_4); + int y = get_sint16_0 (STACK_3); + int w = get_uint16_0 (STACK_2); + int h = get_uint16_0 (STACK_1); int exposures_p = !missingp(STACK_0); X_CALL(XClearArea (dpy, win, x,y,w,h, exposures_p)); @@ -3985,8 +3987,8 @@ { /* This is a *VERY* silly implementation. XXX see that the keyword arguments are actually given */ Display *dpy; - int src_x = boundp(STACK_6) ? get_sint32(STACK_6) : 0; - int src_y = boundp(STACK_5) ? get_sint32(STACK_5) : 0; + int src_x = get_sint32_0(STACK_6); + int src_y = get_sint32_0(STACK_5); int x = get_sint32 (STACK_4); int y = get_sint32 (STACK_3); int w = get_sint32 (STACK_2); @@ -4480,7 +4482,7 @@ if (simple_string_p (STACK_3)) { object font; XFontStruct *font_info = get_font_info_and_display (STACK_4, &font, 0); - int start = missingp(STACK_2) ? 0 : get_uint16 (STACK_2); + int start = get_uint16_0 (STACK_2); int end = missingp(STACK_1) ? vector_length (STACK_3) : get_uint16 (STACK_1); int dir; int font_ascent, font_descent; @@ -4541,7 +4543,7 @@ /* First fetch the quite common special case where sequence is a simple string: */ if (simple_string_p (STACK_3)) { - int start = missingp(STACK_2) ? 0 : get_uint16 (STACK_2); + int start = get_uint16_0 (STACK_2); int end = missingp(STACK_1) ? vector_length (STACK_3) : get_uint16 (STACK_1); int w; @@ -4570,7 +4572,7 @@ else if (vectorp (STACK_3)) { /* Generic case for vectors. XXX faked. */ - int start = missingp(STACK_2) ? 0 : get_uint16 (STACK_2); + int start = get_uint16_0 (STACK_2); int end = missingp(STACK_1) ? vector_length (STACK_3) : get_uint16 (STACK_1); VALUES2(make_sint32(0),NIL); } else @@ -4763,7 +4765,7 @@ Display *dpy; Colormap cm = get_colormap_and_display (STACK_4, &dpy); unsigned int npixels = get_uint32 (STACK_3); - unsigned int nplanes = boundp(STACK_2) ? get_uint32(STACK_2) : 0; + unsigned int nplanes = get_uint32_0(STACK_2); Bool contiguous_p = !missingp(STACK_1); gcv_object_t *res_type = &STACK_0; @@ -4813,9 +4815,9 @@ Display *dpy; Colormap cm = get_colormap_and_display (STACK_6, &dpy); unsigned int ncolors = get_uint32 (STACK_5); - unsigned int nreds = boundp(STACK_4) ? get_uint32(STACK_4) : 0; - unsigned int ngreens = boundp(STACK_3) ? get_uint32(STACK_3) : 0; - unsigned int nblues = boundp(STACK_2) ? get_uint32(STACK_2) : 0; + unsigned int nreds = get_uint32_0(STACK_4); + unsigned int ngreens = get_uint32_0(STACK_3); + unsigned int nblues = get_uint32_0(STACK_2); Bool contiguous_p = !missingp(STACK_1); unsigned long red_mask, green_mask, blue_mask; gcv_object_t *res_type = &STACK_0; @@ -5178,7 +5180,7 @@ Atom type = get_xatom (dpy, STACK_5); int format = get_uint8 (STACK_4); int mode = check_propmode(STACK_3); - int start = (missingp(STACK_2) ? 0 : get_uint32 (STACK_2)); + int start = get_uint32_0 (STACK_2); int end; int i; int len; @@ -5279,7 +5281,7 @@ /* How is :start/:end counted? CLX counts the same way libX counts [This should be documented.] */ - long_offset = (missingp(STACK_4) ? 0 : get_uint32 (STACK_4)); + long_offset = get_uint32_0 (STACK_4); long_length = (missingp(STACK_3) ? 0x7FFFFFFF : (get_uint32(STACK_3) - long_offset)); delete_p = (missingp(STACK_2) ? 0 : 1); req_type = (missingp(STACK_5) ? AnyPropertyType : get_xatom (display, STACK_5)); @@ -6154,20 +6156,19 @@ DEFUN(XLIB:WARP-POINTER-IF-INSIDE, destination destination-x destination-y \ source source-x source-y &optional source-width source-height) { + int src_h = get_sint16_0(popSTACK()); + int src_w = get_sint16_0(popSTACK()); + int src_y = get_sint16 (popSTACK()); + int src_x = get_sint16 (popSTACK()); + Window src = get_window (popSTACK()); + int dest_y = get_sint16 (popSTACK()); + int dest_x = get_sint16 (popSTACK()); Display *dpy; - Window dest = get_window_and_display (STACK_7, &dpy); - int dest_x = get_sint16 (STACK_6); - int dest_y = get_sint16 (STACK_5); - Window src = get_window (STACK_4); - int src_x = get_sint16 (STACK_3); - int src_y = get_sint16 (STACK_2); - int src_w = (boundp(STACK_1) ? get_sint16(STACK_1) : 0); - int src_h = (boundp(STACK_0) ? get_sint16(STACK_0) : 0); + Window dest = get_window_and_display (popSTACK(), &dpy); X_CALL(XWarpPointer(dpy,src,dest,src_x,src_y,src_w,src_h,dest_x,dest_y)); VALUES1(NIL); - skipSTACK(8); } /* XLIB:WARP-POINTER-RELATIVE-IF-INSIDE x-offset y-offset source @@ -6175,19 +6176,18 @@ DEFUN(XLIB:WARP-POINTER-RELATIVE-IF-INSIDE, x-offset y-offset source \ source-x source-y &optional source-width source-height) { - int x_off = get_sint16 (STACK_6); - int y_off = get_sint16 (STACK_5); + int src_h = get_sint16_0(popSTACK()); + int src_w = get_sint16_0(popSTACK()); + int src_y = get_sint16 (popSTACK()); + int src_x = get_sint16 (popSTACK()); Display *dpy; - Window src = get_window_and_display (STACK_4, &dpy); - int src_x = get_sint16 (STACK_3); - int src_y = get_sint16 (STACK_2); - int src_w = boundp(STACK_1) ? get_sint16(STACK_1) : 0; - int src_h = boundp(STACK_0) ? get_sint16(STACK_0) : 0; + Window src = get_window_and_display (popSTACK(), &dpy); + int y_off = get_sint16 (popSTACK()); + int x_off = get_sint16 (popSTACK()); X_CALL(XWarpPointer(dpy,src,None,src_x,src_y,src_w,src_h,x_off,y_off)); VALUES1(NIL); - skipSTACK(7); } /* 12.7 Managing Input Focus */ @@ -6304,7 +6304,7 @@ Window win = get_window_and_display (STACK_8, &dpy); int button = !(eq (STACK_7, `:ANY`) ? AnyButton : get_uint8 (STACK_7)); unsigned long event_mask = get_event_mask (STACK_6); - unsigned int modifiers = boundp(STACK_0) ? get_modifier_mask(STACK_5) : 0; + unsigned int modifiers = get_modifier_mask(STACK_5); Bool owner_p = !missingp(STACK_4); Bool sync_pointer = missingp(STACK_3); Bool sync_keyboard = missingp(STACK_2); @@ -6323,7 +6323,7 @@ Display *dpy; Window win = get_window_and_display (STACK_2, &dpy); int code = (eq (STACK_1, `:ANY`) ? AnyKey : get_uint8(STACK_1)); - unsigned int modifiers = (boundp(STACK_0) ? get_modifier_mask(STACK_0) : 0); + unsigned int modifiers = get_modifier_mask(STACK_0); X_CALL(XUngrabButton (dpy, code, modifiers, win)); @@ -6361,7 +6361,7 @@ Display *dpy; Window win = get_window_and_display (STACK_5, &dpy); int keycode = get_uint8 (STACK_4); - unsigned int modifiers = (boundp(STACK_3) ? get_modifier_mask(STACK_3) : 0); + unsigned int modifiers = get_modifier_mask(STACK_3); Bool owner_p = !missingp(STACK_2); Bool sync_pointer_p = missingp(STACK_1) ? GrabModeAsync : GrabModeSync; Bool sync_keyboard_p = missingp(STACK_0) ? GrabModeAsync : GrabModeSync; @@ -6378,7 +6378,7 @@ Display *dpy; Window win = get_window_and_display (STACK_2, &dpy); int code = (eq (STACK_1, `:ANY`) ? AnyKey : get_uint8(STACK_1)); - unsigned int modifiers = (boundp(STACK_0) ? get_modifier_mask(STACK_0) : 0); + unsigned int modifiers = get_modifier_mask(STACK_0); X_CALL(XUngrabKey (dpy, code, modifiers, win)); @@ -6618,10 +6618,8 @@ /* 14.3 Keyboard Control */ DEFUN(XLIB:BELL, display &optional percent) { - int percent = (!missingp(STACK_0) ? get_sint16(STACK_0) : 0); - Display *dpy; - skipSTACK(1); - dpy = pop_display (); + int percent = get_sint16_0(popSTACK()); + Display *dpy = pop_display (); X_CALL(XBell (dpy, percent)); @@ -7136,8 +7134,9 @@ /* First three little enums (three? I can only see two!) */ -DEFCHECKER(get_shape_kind,default=, BOUNDING=ShapeBounding CLIP=ShapeClip) -DEFCHECKER(get_shape_operation,default=, SET=ShapeSet UNION=ShapeUnion \ +DEFCHECKER(get_shape_kind,default=ShapeBounding, \ + BOUNDING=ShapeBounding CLIP=ShapeClip) +DEFCHECKER(get_shape_operation,default=ShapeSet, SET=ShapeSet UNION=ShapeUnion \ INTERSECT=ShapeIntersect SUBTRACT=ShapeSubtract INVERT=ShapeInvert) static Bool ensure_shape_extension (Display *dpy, object dpy_obj, int error_p) @@ -7184,15 +7183,15 @@ DEFUN(XLIB:SHAPE-COMBINE, destination source \ &key KIND X-OFFSET Y-OFFSET OPERATION ORDERING) { + int ordering = get_ordering(popSTACK()); + int op = get_shape_operation(popSTACK()); + int y_off = get_sint16_0(popSTACK()); + int x_off = get_sint16_0(popSTACK()); + int kind = get_shape_kind(popSTACK()); Display *dpy; - Window dest = get_window_and_display (STACK_6, &dpy); - int kind = boundp(STACK_4) ? get_shape_kind(STACK_4) : ShapeBounding; - int x_off = boundp(STACK_3) ? get_sint16(STACK_3) : 0; - int y_off = boundp(STACK_2) ? get_sint16(STACK_2) : 0; - int op = boundp(STACK_1) ? get_shape_operation(STACK_1) : ShapeSet; - int ordering = boundp(STACK_0) ? get_ordering(STACK_0) : Unsorted; + Window dest = get_window_and_display (STACK_1, &dpy); - (void)ensure_shape_extension (dpy, get_display_obj (STACK_6), 1); + (void)ensure_shape_extension (dpy, get_display_obj (STACK_1), 1); /* Now we have to select on the second arg, which operation is actually wanted: @@ -7203,19 +7202,19 @@ FIXME: Should we emit an error message if we get keywords, which are not applicable? */ - if (pixmap_p (STACK_5)) { - Pixmap src = get_pixmap (STACK_5); + if (pixmap_p (STACK_0)) { + Pixmap src = get_pixmap (STACK_0); XShapeCombineMask (dpy, dest, kind, x_off, y_off, src, op); - } else if (window_p (STACK_5)) { + } else if (window_p (STACK_0)) { /* FIXME -- a :source-kind keyword is missing here. */ - Pixmap src = get_window (STACK_5); + Pixmap src = get_window (STACK_0); XShapeCombineShape(dpy,dest,kind,x_off,y_off,src,kind/*src_kind*/,op); - } else if (listp (STACK_5) || vectorp (STACK_5)) { - int i, nrectangles = get_uint32(funcall1(L(length),STACK_5)); + } else if (listp (STACK_0) || vectorp (STACK_0)) { + int i, nrectangles = get_uint32(funcall1(L(length),STACK_0)); DYNAMIC_ARRAY (rectangles, XRectangle, nrectangles); for (i = 0; i < nrectangles; i++) { - pushSTACK(STACK_5); /* rectangles */ + pushSTACK(STACK_0); /* rectangles */ pushSTACK(fixnum(i)); /* index */ funcall (L(elt), 2); pushSTACK(value1); /* save element */ @@ -7241,7 +7240,7 @@ } VALUES1(NIL); - skipSTACK(7); /* all done */ + skipSTACK(2); /* all done */ } DEFUN(XLIB:SHAPE-OFFSET, destination kind x-offset y-offset) --__--__-- Message: 8 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4415,1.4416 Date: Mon, 28 Mar 2005 19:04:16 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9536/src Modified Files: ChangeLog Log Message: use getters with defaults Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4415 retrieving revision 1.4416 diff -u -d -r1.4415 -r1.4416 --- ChangeLog 28 Mar 2005 18:27:18 -0000 1.4415 +++ ChangeLog 28 Mar 2005 19:03:11 -0000 1.4416 @@ -1,6 +1,19 @@ 2005-03-28 Sam Steingold <sd...@gn...> * modules/clx/new-clx/clx.f (xlib_error_handler): use switch, not if + (DEFINE_INTEGER_GETTER): also define get_##type_0 (default to 0) + (get_ordering): default=Unsorted + (get_modifier_mask): unbound -> 0 + (XLIB:SET-GCONTEXT-CLIP-MASK): rely on get_ordering() default + (XLIB:CLEAR-AREA, XLIB:PUT-IMAGE, XLIB:TEXT-EXTENTS, XLIB:TEXT-WIDTH) + (XLIB:ALLOC-COLOR-CELLS, XLIB:ALLOC-COLOR-PLANES, XLIB:GET-PROPERTY) + (XLIB:WARP-POINTER-IF-INSIDE, XLIB:WARP-POINTER-RELATIVE-IF-INSIDE) + (XLIB:BELL): use get_##type_0 + (XLIB:GRAB-BUTTON, XLIB:UNGRAB-BUTTON, XLIB:GRAB-KEY, XLIB:UNGRAB-KEY): + rely on get_modifier_mask() default + (get_shape_kind): default=ShapeBounding + (get_shape_operation): default=ShapeSet + (XLIB:SHAPE-COMBINE): reply on these defaults 2005-03-28 Sam Steingold <sd...@gn...> --__--__-- Message: 9 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.4416,1.4417 Date: Mon, 28 Mar 2005 20:18:44 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16832/src Modified Files: ChangeLog Log Message: (general_draw_text, XLIB:TEXT-EXTENTS, XLIB:TEXT-WIDTH): removed the SIMPLE-STRING limitation Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4416 retrieving revision 1.4417 diff -u -d -r1.4416 -r1.4417 --- ChangeLog 28 Mar 2005 19:03:11 -0000 1.4416 +++ ChangeLog 28 Mar 2005 20:18:36 -0000 1.4417 @@ -14,6 +14,8 @@ (get_shape_kind): default=ShapeBounding (get_shape_operation): default=ShapeSet (XLIB:SHAPE-COMBINE): reply on these defaults + (general_draw_text, XLIB:TEXT-EXTENTS, XLIB:TEXT-WIDTH): + removed the SIMPLE-STRING limitation 2005-03-28 Sam Steingold <sd...@gn...> --__--__-- Message: 10 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/clx/new-clx clx.f,2.29,2.30 Date: Mon, 28 Mar 2005 20:18:45 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/clx/new-clx In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16832/modules/clx/new-clx Modified Files: clx.f Log Message: (general_draw_text, XLIB:TEXT-EXTENTS, XLIB:TEXT-WIDTH): removed the SIMPLE-STRING limitation Index: clx.f =================================================================== RCS file: /cvsroot/clisp/clisp/modules/clx/new-clx/clx.f,v retrieving revision 2.29 retrieving revision 2.30 diff -u -d -r2.29 -r2.30 --- clx.f 28 Mar 2005 19:04:14 -0000 2.29 +++ clx.f 28 Mar 2005 20:18:42 -0000 2.30 @@ -3574,7 +3574,6 @@ /* 6.7 Drawing Text */ -#ifdef UNICODE /* Conversion from chart array to XChar2b array. Returns 1 if a char array was generated, or 2 if a XChar2b array was generated. */ @@ -3616,7 +3615,6 @@ } return 2; } -#endif void general_draw_text (int image_p) { /* General text drawing routine to not to have to duplicate code for @@ -3696,15 +3694,15 @@ GC gcon = get_gcontext (STACK_8); int x = get_sint16 (STACK_7); int y = get_sint16 (STACK_6); - int len = vector_length (STACK_5); - if (!simple_string_p(STACK_5)) { NOTIMPLEMENTED; } + STACK_5 = check_string(STACK_5); -#ifdef UNICODE { object font; XFontStruct* font_info = get_font_info_and_display(STACK_8,&font,0); + unsigned long len, offset; + object s_string = unpack_string_ro(STACK_5,&len,&offset); const chart* charptr; - unpack_sstring_alloca(STACK_5,len,0,charptr=); + unpack_sstring_alloca(s_string,len,offset,charptr=); { DYNAMIC_ARRAY(str,XChar2b,len); if (to_XChar2b(font,font_info,charptr,str,len) == 1) X_CALL((image_p ? XDrawImageString : XDrawString) @@ -3715,12 +3713,6 @@ FREE_DYNAMIC_ARRAY(str); } } -#else - { char* str = (char*)(TheSstring(STACK_5)->data); - X_CALL((image_p ? XDrawImageString : XDrawString) - (dpy, da, gcon, x, y, str, len)); - } -#endif VALUES0; skipSTACK(10); @@ -4479,58 +4471,52 @@ DEFUN(XLIB:TEXT-EXTENTS, font obj &key START END TRANSLATE) { /* FIXME: Could font be a graphics context?! -- yes! This is handled by get_font_info_and_display already */ - if (simple_string_p (STACK_3)) { - object font; - XFontStruct *font_info = get_font_info_and_display (STACK_4, &font, 0); - int start = get_uint16_0 (STACK_2); - int end = missingp(STACK_1) ? vector_length (STACK_3) : get_uint16 (STACK_1); - int dir; - int font_ascent, font_descent; - XCharStruct overall; - -# ifdef UNICODE - const chart* charptr; - unpack_sstring_alloca(STACK_3,end-start,start,charptr=); - { DYNAMIC_ARRAY(str,XChar2b,end-start); - if (to_XChar2b(font,font_info,charptr,str,end-start) == 1) - X_CALL(XTextExtents (font_info, (char*)str, end-start, &dir, - &font_ascent, &font_descent, &overall)); - else - X_CALL(XTextExtents16 (font_info, str, end-start, &dir, - &font_ascent, &font_descent, &overall)); - FREE_DYNAMIC_ARRAY(str); - } -# else - { char* string = (char*)(TheSstring(STACK_3)->data); - X_CALL(XTextExtents (font_info, string + start, end - start, &dir, + object font; + XFontStruct *font_info = get_font_info_and_display (STACK_4, &font, 0); + int start = get_uint16_0 (STACK_2); + int dir; + int font_ascent, font_descent; + XCharStruct overall; + unsigned long len, offset; + object s_string = unpack_string_ro(STACK_3=check_string(STACK_3), + &len,&offset); + const chart* charptr; + int end = missingp(STACK_1) ? len : get_uint16(STACK_1); + /* START/END handling should be done via test_string_limits_ro ... */ + if (end > len) end = len; + if (start > end) start = end; + unpack_sstring_alloca(s_string,end-start,start+offset,charptr=); + { DYNAMIC_ARRAY(str,XChar2b,end-start); + if (to_XChar2b(font,font_info,charptr,str,end-start) == 1) + X_CALL(XTextExtents (font_info, (char*)str, end-start, &dir, &font_ascent, &font_descent, &overall)); - } -# endif + else + X_CALL(XTextExtents16 (font_info, str, end-start, &dir, + &font_ascent, &font_descent, &overall)); + FREE_DYNAMIC_ARRAY(str); + } - pushSTACK(make_sint32(overall.width)); /* width */ - pushSTACK(make_sint16(overall.ascent)); /* ascent */ - pushSTACK(make_sint16(overall.descent)); /* descent */ - pushSTACK(make_sint16(overall.lbearing)); /* left */ - pushSTACK(make_sint16(overall.rbearing)); /* right */ - pushSTACK(make_sint16(font_ascent)); /* font-ascent */ - pushSTACK(make_sint16(font_descent)); /* font-descent */ - pushSTACK(make_draw_direction (dir)); /* direction */ - pushSTACK(NIL); /* first-not-done */ + pushSTACK(make_sint32(overall.width)); /* width */ + pushSTACK(make_sint16(overall.ascent)); /* ascent */ + pushSTACK(make_sint16(overall.descent)); /* descent */ + pushSTACK(make_sint16(overall.lbearing)); /* left */ + pushSTACK(make_sint16(overall.rbearing)); /* right */ + pushSTACK(make_sint16(font_ascent)); /* font-ascent */ + pushSTACK(make_sint16(font_descent)); /* font-descent */ + pushSTACK(make_draw_direction (dir)); /* direction */ + pushSTACK(NIL); /* first-not-done */ - value9 = popSTACK(); - value8 = popSTACK(); - value7 = popSTACK(); - value6 = popSTACK(); - value5 = popSTACK(); - value4 = popSTACK(); - value3 = popSTACK(); - value2 = popSTACK(); - value1 = popSTACK(); - mv_count = 9; - skipSTACK(5); - } else { - NOTIMPLEMENTED; - } + value9 = popSTACK(); + value8 = popSTACK(); + value7 = popSTACK(); + value6 = popSTACK(); + value5 = popSTACK(); + value4 = popSTACK(); + value3 = popSTACK(); + value2 = popSTACK(); + value1 = popSTACK(); + mv_count = 9; + skipSTACK(5); } /* -> width - Type int32 @@ -4540,16 +4526,17 @@ object font; XFontStruct *font_info = get_font_info_and_display (STACK_4, &font, 0); - /* First fetch the quite common special case where sequence - is a simple string: */ - if (simple_string_p (STACK_3)) { + if (stringp(STACK_3)) { int start = get_uint16_0 (STACK_2); - int end = missingp(STACK_1) ? vector_length (STACK_3) : get_uint16 (STACK_1); int w; - -# ifdef UNICODE + unsigned long len, offset; + object s_string = unpack_string_ro(STACK_3,&len,&offset); const chart* charptr; - unpack_sstring_alloca(STACK_3,end-start,start,charptr=); + int end = missingp(STACK_1) ? len : get_uint16(STACK_1); + /* START/END handling should be done via test_string_limits_ro ... */ + if (end > len) end = len; + if (start > end) start = end; + unpack_sstring_alloca(s_string,end-start,start+offset,charptr=); { DYNAMIC_ARRAY(str,XChar2b,end-start); if (to_XChar2b(font,font_info,charptr,str,end-start) == 1) X_CALL(w = XTextWidth (font_info, (char*)str, end-start)); @@ -4557,26 +4544,20 @@ X_CALL(w = XTextWidth16 (font_info, str, end-start)); FREE_DYNAMIC_ARRAY(str); } -# else - { char* string = (char*) (TheSstring(STACK_3)->data); - X_CALL(w = XTextWidth (font_info, string+start, end-start)); - } -# endif - VALUES2(make_sint32 (w),NIL); - } else if (listp (STACK_3)) + } else if (listp (STACK_3)) { /* Now the generic case for lists XXX -- Fix this also above XXX This is faked, isn't it. */ VALUES2(make_sint32(0),NIL); - else if (vectorp (STACK_3)) { + } else if (vectorp (STACK_3)) { /* Generic case for vectors. XXX faked. */ int start = get_uint16_0 (STACK_2); int end = missingp(STACK_1) ? vector_length (STACK_3) : get_uint16 (STACK_1); VALUES2(make_sint32(0),NIL); } else - NOTIMPLEMENTED; + my_type_error(`SEQUENCE`,STACK_3); skipSTACK(5); } --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |