home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.src.lha / src / stdwin.d < prev    next >
Text File  |  1996-04-15  |  43KB  |  1,358 lines
  1. # STDWIN-Interface für CLISP
  2. # Bruno Haible, Matthias Lindner 29.8.1993
  3.  
  4. #include "lispbibl.c"
  5.  
  6. # If STDWIN is not defined, we are compiling this as a separate module.
  7. #ifndef STDWIN
  8. #define STDWIN_MODULE
  9. #endif
  10.  
  11. #ifdef STDWIN_MODULE
  12.  
  13. struct {
  14.   object stdwin_drawproc_alist;
  15. }
  16. module__stdwin__object_tab;
  17.  
  18. uintC module__stdwin__object_tab_size = sizeof(module__stdwin__object_tab)/sizeof(object);
  19.  
  20. object_initdata module__stdwin__object_tab_initdata[sizeof(module__stdwin__object_tab)/sizeof(object)] = {
  21.   { "NIL" },
  22. };
  23.  
  24. #define OM(name)  (module__stdwin__object_tab.name)
  25.  
  26. #else
  27.  
  28. #define OM(name)  O(name)
  29.  
  30. #endif
  31.  
  32. #if defined(STDWIN) || defined(STDWIN_MODULE)
  33.  
  34. #include <stdwin.h>  # "stdwin/H/stdwin.h"
  35.  
  36.  
  37. #                           Foreign Function Interface
  38. #                           ==========================
  39.  
  40. # We call library functions that can do callbacks. When we pass a parameter
  41. # to such a library function, maybe it first does a callback - which may
  42. # involve garbage collection - and only then looks at the parameter.
  43. # Therefore all the parameters, especially strings, must be located in
  44. # areas that are not moved by garbage collection.
  45.  
  46. # with_string(string,charptr,len,statement);
  47. # copies the contents of string (which should be a Lisp string) to a safe area,
  48. # binds the variable charptr pointing to it and the variable len to its length,
  49. # and executes the statement.
  50.   #define with_string(string,charptrvar,lenvar,statement)  \
  51.     { var uintL lenvar;                                      \
  52.       var reg2 uintB* ptr1 = unpack_string(string,&lenvar);  \
  53.      {var DYNAMIC_ARRAY(_EMA_,charptrvar##_data,uintB,lenvar);    \
  54.       {var reg1 uintB* ptr2 = &charptrvar##_data[0];         \
  55.        var reg3 uintL count;                                 \
  56.        dotimesL(count,lenvar, { *ptr2++ = *ptr1++; } );      \
  57.       }                                                      \
  58.       {var char* charptrvar = (char*) &charptrvar##_data[0]; \
  59.        statement                                             \
  60.       }                                                      \
  61.       FREE_DYNAMIC_ARRAY(charptrvar##_data);                 \
  62.     }}
  63.  
  64.  
  65. #                           Initialization and clean-up
  66. #                           +++++++++++++++++++++++++++
  67.  
  68. # We free the programmer from the duty to call (STDWIN::WINIT).
  69.  
  70. local boolean initialized = FALSE; # tells whether winit() has been called
  71.  
  72. local void initialize (void);
  73. local void initialize()
  74.   { begin_call();
  75.     winit();
  76.     wmenusetdeflocal(TRUE); # change STDWIN's default behaviour for menus
  77.     end_call();
  78.     OM(stdwin_drawproc_alist) = NIL;
  79.     initialized = TRUE;
  80.   }
  81.  
  82. # (STDWIN::INIT) calls winit().
  83. LISPFUNN(stdwin_init,0)
  84. {
  85.   if (!initialized) initialize();
  86.   value1 = NIL; mv_count=1; # returns NIL
  87. }
  88.  
  89. # (STDWIN::DONE) calls wdone().
  90. LISPFUNN(stdwin_done,0)
  91. {
  92.   if (initialized)
  93.     { begin_call();
  94.       wdone();
  95.       end_call();
  96.       initialized = FALSE;
  97.     }
  98.   value1 = NIL; mv_count=1; # returns NIL
  99. }
  100.  
  101. # check_init(); checks that STDWIN has been initialized.
  102.   #define check_init()  \
  103.     if (!initialized) initialize()
  104.  
  105. #                         Creating and destroying windows
  106. #                         +++++++++++++++++++++++++++++++
  107.  
  108. # OM(stdwin_drawproc_alist) is a list of conses (win . drawproc),
  109. # where drawproc is the Lisp function for redrawing the window win.
  110.  
  111. # Looks up a given window in OM(stdwin_drawproc_alist):
  112.   local object find_win (void* win);
  113.   local object find_win(win)
  114.     var reg3 void* win;
  115.     { var reg2 object key = type_untype_object(machine_type,win);
  116.       var reg1 object l;
  117.       for (l = OM(stdwin_drawproc_alist); consp(l); l = Cdr(l))
  118.         { if (eq(Car(Car(l)),key)) { return Car(l); } }
  119.       return NIL;
  120.     }
  121.  
  122. # General redrawing function:
  123.   local void drawproc (WINDOW* win, int left, int top, int right, int bottom);
  124.   local void drawproc(win,left,top,right,bottom)
  125.     var reg3 WINDOW* win;
  126.     var reg4 int left;
  127.     var reg5 int top;
  128.     var reg6 int right;
  129.     var reg7 int bottom;
  130.     { begin_callback();
  131.      {var reg1 object acons = find_win(win);
  132.       if (consp(acons))
  133.         { var reg2 object fun = Cdr(acons);
  134.           if (!nullp(fun))
  135.             { pushSTACK(fun);
  136.               pushSTACK(type_untype_object(machine_type,win));
  137.               pushSTACK(L_to_I(left));
  138.               pushSTACK(L_to_I(top));
  139.               pushSTACK(L_to_I(right));
  140.               pushSTACK(L_to_I(bottom));
  141.               funcall(STACK_5,5);
  142.               skipSTACK(1);
  143.         }   }
  144.       end_callback();
  145.     }}
  146.  
  147. # (STDWIN::DRAWPROC-ALIST) returns the OM(stdwin_drawproc_alist).
  148. # Why should this be useful?? Remove!??
  149. LISPFUNN(stdwin_drawproc_alist,0)
  150. { value1 = OM(stdwin_drawproc_alist); mv_count=1; }
  151.  
  152. # (STDWIN::WOPEN title drawproc) calls wopen().
  153. LISPFUNN(stdwin_wopen,2)
  154. { if (!mstringp(STACK_1)) { STACK_1 = O(leer_string); }
  155.   # Pre-allocate the conses for the alist:
  156.   pushSTACK(allocate_cons()); pushSTACK(allocate_cons());
  157.   check_init();
  158.  {var reg3 WINDOW* win;
  159.   with_string_0(STACK_(1+2),title,
  160.     { begin_call();
  161.       win = wopen(title,(nullp(STACK_(0+2)) ? NULL : drawproc));
  162.       end_call();
  163.     });
  164.   {var reg1 object acons = popSTACK();
  165.    var reg2 object newcons = popSTACK();
  166.    if (win==NULL)
  167.      { value1 = NIL; }
  168.      else
  169.      { value1 = Car(acons) = type_untype_object(machine_type,win);
  170.        Cdr(acons) = STACK_0;
  171.        Car(newcons) = acons;
  172.        Cdr(newcons) = OM(stdwin_drawproc_alist);
  173.        OM(stdwin_drawproc_alist) = newcons;
  174.   }  }
  175.   mv_count=1;
  176.   skipSTACK(2);
  177. }}
  178.  
  179. # (STDWIN::WCLOSE win) calls wclose().
  180. LISPFUNN(stdwin_wclose,1)
  181. { var reg3 object arg = popSTACK();
  182.   check_init();
  183.  {var reg2 WINDOW* win = (WINDOW*)TheMachine(arg);
  184.   var reg1 object acons = find_win(win);
  185.   if (consp(acons))
  186.     { OM(stdwin_drawproc_alist) = deleteq(OM(stdwin_drawproc_alist),acons);
  187.       begin_call();
  188.       wclose(win);
  189.       end_call();
  190.     }
  191.   value1 = NIL; mv_count=1; # returns NIL
  192. }}
  193.  
  194. # test_window(arg) checks that an argument is an STDWIN window, and returns it.
  195.   local WINDOW* test_window (object arg);
  196.   local WINDOW* test_window(arg)
  197.     var reg2 object arg;
  198.     { var reg1 WINDOW* win = (WINDOW*)TheMachine(arg);
  199.       check_init();
  200.       if (nullp(find_win(win)))
  201.         { pushSTACK(arg);
  202.           pushSTACK(TheSubr(subr_self)->name);
  203.           # type_error ??
  204.           //: DEUTSCH "~: Argument ~ ist kein STDWIN:WINDOW."
  205.           //: ENGLISH "~: argument ~ is not a STDWIN:WINDOW"
  206.           //: FRANCAIS "~ : L'argument ~ n'est pas de type STDWIN:WINDOW."
  207.           fehler(error,  GETTEXT("~: argument ~ is not a STDWIN:WINDOW"));
  208.         }
  209.       return win;
  210.     }
  211.  
  212. #                          Changing defaults
  213. #                          -----------------
  214.  
  215. # (STDWIN::SCROLLBAR-P) calls wgetdefscrollbars().
  216. LISPFUNN(stdwin_scrollbar_p,0)
  217. { var int h_p;
  218.   var int v_p;
  219.   check_init();
  220.   begin_call();
  221.   wgetdefscrollbars(&h_p,&v_p);
  222.   end_call();
  223.   value1 = (h_p ? T : NIL); value2 = (v_p ? T : NIL); mv_count=2;
  224. }
  225.  
  226. # (STDWIN::SET-SCROLLBAR-P horizontal-bar-p vertical-bar-p) calls wsetdefscrollbars().
  227. LISPFUNN(stdwin_set_scrollbar_p,2)
  228. { var reg2 int h_p = (nullp(STACK_1) ? FALSE : TRUE);
  229.   var reg1 int v_p = (nullp(STACK_0) ? FALSE : TRUE);
  230.   check_init();
  231.   begin_call();
  232.   wsetdefscrollbars(h_p,v_p);
  233.   end_call();
  234.   STACK_to_mv(2); # returns two values: h_p and v_p
  235. }
  236.  
  237. # (STDWIN::DEFAULT-WINDOW-SIZE) calls wgetdefwinsize().
  238. LISPFUNN(stdwin_default_window_size,0)
  239. { var int w;
  240.   var int h;
  241.   check_init();
  242.   begin_call();
  243.   wgetdefwinsize(&w,&h);
  244.   end_call();
  245.   pushSTACK(L_to_I(w)); pushSTACK(L_to_I(h));
  246.   STACK_to_mv(2); # returns two values: w and h
  247. }
  248.  
  249. # (STDWIN::SET-DEFAULT-WINDOW-SIZE width height) calls wsetdefwinsize().
  250. LISPFUNN(stdwin_set_default_window_size,2)
  251. { var reg2 sintL w = I_to_L(STACK_1);
  252.   var reg1 sintL h = I_to_L(STACK_0);
  253.   check_init();
  254.   begin_call();
  255.   wsetdefwinsize(w,h);
  256.   end_call();
  257.   STACK_to_mv(2); # returns two values: w and h
  258. }
  259.  
  260. # (STDWIN::DEFAULT-WINDOW-POSITION) calls wgetdefwinpos().
  261. LISPFUNN(stdwin_default_window_position,0)
  262. { var int x;
  263.   var int y;
  264.   check_init();
  265.   begin_call();
  266.   wgetdefwinpos(&x,&y);
  267.   end_call();
  268.   pushSTACK(L_to_I(x)); pushSTACK(L_to_I(y));
  269.   STACK_to_mv(2); # returns two values: x and y
  270. }
  271.  
  272. # (STDWIN::SET-DEFAULT-WINDOW-POSITION x y) calls wsetdefwinpos().
  273. LISPFUNN(stdwin_set_default_window_position,2)
  274. { var reg2 sintL x = I_to_L(STACK_1);
  275.   var reg1 sintL y = I_to_L(STACK_0);
  276.   check_init();
  277.   begin_call();
  278.   wsetdefwinpos(x,y);
  279.   end_call();
  280.   STACK_to_mv(2); # returns two values: x and y
  281. }
  282.  
  283. #                              The output model
  284. #                              ++++++++++++++++
  285.  
  286. # (STDWIN::SCREEN-SIZE) calls wgetscrsize().
  287. # (STDWIN::WINDOW-SIZE win) calls wgetwinsize().
  288. # (STDWIN::WINDOW-POSITION win) calls wgetwinpos().
  289. # (STDWIN::WINDOW-DOCUMENT-SIZE win) calls wgetdocsize().
  290. # (STDWIN::SET-WINDOW-DOCUMENT-SIZE win width height) calls wsetdocsize().
  291. # (STDWIN::WINDOW-TITLE win) calls wgettitle().
  292. # (STDWIN::SET-WINDOW-TITLE win string) calls wsettitle().
  293. # (STDWIN::SET-WINDOW-CURSOR win string) calls wfetchcursor() and wsetwincursor().
  294.  
  295. # (STDWIN::SCREEN-SIZE) calls wgetscrsize().
  296. LISPFUNN(stdwin_screen_size,0)
  297. { var int w;
  298.   var int h;
  299.   check_init();
  300.   begin_call();
  301.   wgetscrsize(&w,&h);
  302.   end_call();
  303.   pushSTACK(L_to_I(w)); pushSTACK(L_to_I(h));
  304.   STACK_to_mv(2); # returns two values: w and h
  305. }
  306.  
  307. # (STDWIN::WINDOW-SIZE win) calls wgetwinsize().
  308. LISPFUNN(stdwin_window_size,1)
  309. { var reg2 object arg = popSTACK();
  310.   var reg1 WINDOW* win = test_window(arg);
  311.   var int w;
  312.   var int h;
  313.   begin_call();
  314.   wgetwinsize(win,&w,&h);
  315.   end_call();
  316.   pushSTACK(L_to_I(w)); pushSTACK(L_to_I(h));
  317.   STACK_to_mv(2); # returns two values: w and h
  318. }
  319.  
  320. # (STDWIN::WINDOW-POSITION win) calls wgetwinpos().
  321. LISPFUNN(stdwin_window_position,1)
  322. { var reg2 object arg = popSTACK();
  323.   var reg1 WINDOW* win = test_window(arg);
  324.   var int x;
  325.   var int y;
  326.   begin_call();
  327.   wgetwinpos(win,&x,&y);
  328.   end_call();
  329.   pushSTACK(L_to_I(x)); pushSTACK(L_to_I(y));
  330.   STACK_to_mv(2); # returns two values: x and y
  331. }
  332.  
  333. # (STDWIN::WINDOW-DOCUMENT-SIZE win) calls wgetdocsize().
  334. LISPFUNN(stdwin_window_document_size,1)
  335. { var reg2 object arg = popSTACK();
  336.   var reg1 WINDOW* win = test_window(arg);
  337.   var int w;
  338.   var int h;
  339.   begin_call();
  340.   wgetdocsize(win,&w,&h);
  341.   end_call();
  342.   pushSTACK(L_to_I(w)); pushSTACK(L_to_I(h));
  343.   STACK_to_mv(2); # returns two values: w and h
  344. }
  345.  
  346. # (STDWIN::SET-WINDOW-DOCUMENT-SIZE win width height) calls wsetdocsize().
  347. LISPFUNN(stdwin_set_window_document_size,3)
  348. { var reg3 WINDOW* win = test_window(STACK_2);
  349.   var reg2 sintL w = I_to_L(STACK_1);
  350.   var reg1 sintL h = I_to_L(STACK_0);
  351.   begin_call();
  352.   wsetdocsize(win,w,h);
  353.   end_call();
  354.   STACK_to_mv(2); # returns two values: w and h
  355.   skipSTACK(1);
  356. }
  357.  
  358. # (STDWIN::WINDOW-TITLE win) calls wgettitle().
  359. LISPFUNN(stdwin_window_title,1)
  360. { var reg2 object arg = popSTACK();
  361.   var reg1 WINDOW* win = test_window(arg);
  362.   var reg3 char* title;
  363.   begin_call();
  364.   title = wgettitle(win);
  365.   end_call();
  366.   value1 = (title==NULL ? NIL : asciz_to_string(title)); mv_count=1;
  367. }
  368.  
  369. # (STDWIN::SET-WINDOW-TITLE win string) calls wsettitle().
  370. LISPFUNN(stdwin_set_window_title,2)
  371. { var reg4 WINDOW* win = test_window(STACK_1);
  372.   if (!mstringp(STACK_0)) { fehler_string(STACK_0); }
  373.   with_string_0(STACK_0,title,
  374.     { begin_call();
  375.       wsettitle(win,title);
  376.       end_call();
  377.     });
  378.   value1 = STACK_0; mv_count=1; # returns the string
  379.   skipSTACK(2);
  380. }
  381.  
  382.   nonreturning_function(local, fehler_not_cursor_type, (object string));
  383.   local void fehler_not_cursor_type(string)
  384.     var reg2 object string;
  385.     { pushSTACK(string);
  386.       pushSTACK(TheSubr(subr_self)->name);      
  387.       //: DEUTSCH "~: Argument ~ benennt keinen Cursor-Typ."
  388.       //: ENGLISH "~: argument ~ does not name a cursor type"
  389.       //: FRANCAIS "~ : L'argument ~ n'est pas le nom d'un CURSOR."
  390.       fehler(error, GETTEXT("~: argument ~ does not name a cursor type"));
  391.     }
  392.  
  393. # (STDWIN::SET-WINDOW-CURSOR win string) calls wfetchcursor() and wsetwincursor().
  394. LISPFUNN(stdwin_set_window_cursor,2)
  395. { var reg4 WINDOW* win = test_window(STACK_1);
  396.   if (!mstringp(STACK_0)) { fehler_string(STACK_0); }
  397.   with_string_0(STACK_0,cursor_name,
  398.     { begin_call();
  399.      {var reg5 CURSOR* cur = wfetchcursor(cursor_name);
  400.       if (cur == NULL)
  401.         { end_call();
  402.           fehler_not_cursor_type(STACK_0);
  403.         }
  404.       wsetwincursor(win,cur);
  405.       end_call();
  406.     }});
  407.   value1 = STACK_0; mv_count=1; # returns the string
  408.   skipSTACK(2);
  409. }
  410.  
  411. # (STDWIN::WINDOW-SHOW win left top right bottom) calls wshow().
  412. # (STDWIN::WINDOW-ORIGIN win) calls wgetorigin().
  413. # (STDWIN::SET-WINDOW-ORIGIN win x y) calls wsetorigin().
  414. # (STDWIN::WINDOW-CHANGE win left top right bottom) calls wchange().
  415. # (STDWIN::WINDOW-UPDATE win) calls wupdate().
  416.  
  417. # (STDWIN::WINDOW-SHOW win left top right bottom) calls wshow().
  418. LISPFUNN(stdwin_window_show,5)
  419. { var reg5 WINDOW* win = test_window(STACK_4);
  420.   var reg4 sintL left   = I_to_L(STACK_3);
  421.   var reg3 sintL top    = I_to_L(STACK_2);
  422.   var reg2 sintL right  = I_to_L(STACK_1);
  423.   var reg1 sintL bottom = I_to_L(STACK_0);
  424.   begin_call();
  425.   wshow(win,left,top,right,bottom);
  426.   end_call();
  427.   skipSTACK(5);
  428.   value1 = NIL; mv_count=1; # returns NIL
  429. }
  430.  
  431. # (STDWIN::WINDOW-ORIGIN win) calls wgetorigin().
  432. LISPFUNN(stdwin_window_origin,1)
  433. { var reg2 object arg = popSTACK();
  434.   var reg1 WINDOW* win = test_window(arg);
  435.   var int x;
  436.   var int y;
  437.   begin_call();
  438.   wgetorigin(win,&x,&y);
  439.   end_call();
  440.   pushSTACK(L_to_I(x)); pushSTACK(L_to_I(y));
  441.   STACK_to_mv(2); # returns two values: x and y
  442. }
  443.  
  444. # (STDWIN::SET-WINDOW-ORIGIN win x y) calls wsetorigin().
  445. LISPFUNN(stdwin_set_window_origin,3)
  446. { var reg3 WINDOW* win = test_window(STACK_2);
  447.   var reg2 sintL x = I_to_L(STACK_1);
  448.   var reg1 sintL y = I_to_L(STACK_0);
  449.   begin_call();
  450.   wsetorigin(win,x,y);
  451.   end_call();
  452.   STACK_to_mv(2); # returns two values: x and y
  453.   skipSTACK(1);
  454. }
  455.  
  456. # (STDWIN::WINDOW-CHANGE win left top right bottom) calls wchange().
  457. LISPFUNN(stdwin_window_change,5)
  458. { var reg5 WINDOW* win = test_window(STACK_4);
  459.   var reg4 sintL left   = I_to_L(STACK_3);
  460.   var reg3 sintL top    = I_to_L(STACK_2);
  461.   var reg2 sintL right  = I_to_L(STACK_1);
  462.   var reg1 sintL bottom = I_to_L(STACK_0);
  463.   begin_call();
  464.   wchange(win,left,top,right,bottom);
  465.   end_call();
  466.   skipSTACK(5);
  467.   value1 = NIL; mv_count=1; # returns NIL
  468. }
  469.  
  470. # (STDWIN::WINDOW-UPDATE win) calls wupdate().
  471. LISPFUNN(stdwin_window_update,1)
  472. { var reg1 WINDOW* win = test_window(popSTACK());
  473.   begin_call();
  474.   wupdate(win);
  475.   end_call();
  476.   value1 = NIL; mv_count=1; # returns NIL
  477. }
  478.  
  479. #                           Drawing in a document
  480. #                           +++++++++++++++++++++
  481.  
  482. #                          Preparation for drawing
  483. #                          -----------------------
  484.  
  485. # (STDWIN::BEGIN-DRAWING win) calls wbegindrawing().
  486. # (STDWIN::END-DRAWING win) calls wenddrawing().
  487.  
  488. # (STDWIN::BEGIN-DRAWING win) calls wbegindrawing().
  489. LISPFUNN(stdwin_begin_drawing,1)
  490. { var reg1 WINDOW* win = test_window(popSTACK());
  491.   begin_call();
  492.   wbegindrawing(win);
  493.   end_call();
  494.   value1 = NIL; mv_count=0; # returns nothing
  495. }
  496.  
  497. # (STDWIN::END-DRAWING win) calls wenddrawing().
  498. LISPFUNN(stdwin_end_drawing,1)
  499. { var reg1 WINDOW* win = test_window(popSTACK());
  500.   begin_call();
  501.   wenddrawing(win);
  502.   end_call();
  503.   value1 = NIL; mv_count=0; # returns nothing
  504. }
  505.  
  506. # These cannot be used: they are not implemented in STDWIN-ALFA.
  507. # (STDWIN::CLIP left top right bottom) calls wcliprect().
  508. # (STDWIN::NOCLIP) calls wnoclip().
  509.  
  510. #                           Graphical primitives
  511. #                           --------------------
  512.  
  513. # (STDWIN::DRAW-LINE x1 y1 x2 y2) calls wdrawline().
  514. LISPFUNN(stdwin_draw_line,4)
  515. { var reg4 sintL x1 = I_to_L(STACK_3);
  516.   var reg3 sintL y1 = I_to_L(STACK_2);
  517.   var reg2 sintL x2 = I_to_L(STACK_1);
  518.   var reg1 sintL y2 = I_to_L(STACK_0);
  519.   check_init();
  520.   begin_call();
  521.   wdrawline(x1,y1,x2,y2);
  522.   end_call();
  523.   skipSTACK(4);
  524.   value1 = NIL; mv_count=1; # returns NIL
  525. }
  526.  
  527. # (STDWIN::XOR-LINE x1 y1 x2 y2) calls wxorline().
  528. LISPFUNN(stdwin_xor_line,4)
  529. { var reg4 sintL x1 = I_to_L(STACK_3);
  530.   var reg3 sintL y1 = I_to_L(STACK_2);
  531.   var reg2 sintL x2 = I_to_L(STACK_1);
  532.   var reg1 sintL y2 = I_to_L(STACK_0);
  533.   check_init();
  534.   begin_call();
  535.   wxorline(x1,y1,x2,y2);
  536.   end_call();
  537.   skipSTACK(4);
  538.   value1 = NIL; mv_count=1; # returns NIL
  539. }
  540.  
  541. # (STDWIN::DRAW-BOX left top right bottom) calls wdrawbox().
  542. LISPFUNN(stdwin_draw_box,4)
  543. { var reg4 sintL left   = I_to_L(STACK_3);
  544.   var reg3 sintL top    = I_to_L(STACK_2);
  545.   var reg2 sintL right  = I_to_L(STACK_1);
  546.   var reg1 sintL bottom = I_to_L(STACK_0);
  547.   check_init();
  548.   begin_call();
  549.   wdrawbox(left,top,right,bottom);
  550.   end_call();
  551.   skipSTACK(4);
  552.   value1 = NIL; mv_count=1; # returns NIL
  553. }
  554.  
  555. # (STDWIN::PAINT left top right bottom) calls wpaint().
  556. LISPFUNN(stdwin_paint,4)
  557. { var reg4 sintL left   = I_to_L(STACK_3);
  558.   var reg3 sintL top    = I_to_L(STACK_2);
  559.   var reg2 sintL right  = I_to_L(STACK_1);
  560.   var reg1 sintL bottom = I_to_L(STACK_0);
  561.   check_init();
  562.   begin_call();
  563.   wpaint(left,top,right,bottom);
  564.   end_call();
  565.   skipSTACK(4);
  566.   value1 = NIL; mv_count=1; # returns NIL
  567. }
  568.  
  569. # (STDWIN::INVERT left top right bottom) calls winvert().
  570. LISPFUNN(stdwin_invert,4)
  571. { var reg4 sintL left   = I_to_L(STACK_3);
  572.   var reg3 sintL top    = I_to_L(STACK_2);
  573.   var reg2 sintL right  = I_to_L(STACK_1);
  574.   var reg1 sintL bottom = I_to_L(STACK_0);
  575.   check_init();
  576.   begin_call();
  577.   winvert(left,top,right,bottom);
  578.   end_call();
  579.   skipSTACK(4);
  580.   value1 = NIL; mv_count=1; # returns NIL
  581. }
  582.  
  583. # (STDWIN::ERASE left top right bottom) calls werase().
  584. LISPFUNN(stdwin_erase,4)
  585. { var reg4 sintL left   = I_to_L(STACK_3);
  586.   var reg3 sintL top    = I_to_L(STACK_2);
  587.   var reg2 sintL right  = I_to_L(STACK_1);
  588.   var reg1 sintL bottom = I_to_L(STACK_0);
  589.   check_init();
  590.   begin_call();
  591.   werase(left,top,right,bottom);
  592.   end_call();
  593.   skipSTACK(4);
  594.   value1 = NIL; mv_count=1; # returns NIL
  595. }
  596.  
  597. # (STDWIN::SHADE left top right bottom percent) calls wshade().
  598. LISPFUNN(stdwin_shade,5)
  599. { var reg4 sintL left   = I_to_L(STACK_4);
  600.   var reg3 sintL top    = I_to_L(STACK_3);
  601.   var reg2 sintL right  = I_to_L(STACK_2);
  602.   var reg1 sintL bottom = I_to_L(STACK_1);
  603.   if (mfloatp(STACK_0))
  604.     { # percent := (round (* percent 100))
  605.       pushSTACK(fixnum(100)); funcall(L(mal),2);
  606.       pushSTACK(value1); funcall(L(round),1);
  607.       pushSTACK(value1);
  608.     }
  609.  {var reg5 sintL percent = I_to_L(STACK_0);
  610.   check_init();
  611.   begin_call();
  612.   wshade(left,top,right,bottom,percent);
  613.   end_call();
  614.   skipSTACK(5);
  615.   value1 = NIL; mv_count=1; # returns NIL
  616. }}
  617.  
  618. # (STDWIN::DRAW-CIRCLE x y radius) calls wdrawcircle().
  619. LISPFUNN(stdwin_draw_circle,3)
  620. { var reg3 sintL x = I_to_L(STACK_2);
  621.   var reg2 sintL y = I_to_L(STACK_1);
  622.   var reg1 sintL radius = I_to_L(STACK_0);
  623.   check_init();
  624.   begin_call();
  625.   wdrawcircle(x,y,radius);
  626.   end_call();
  627.   skipSTACK(3);
  628.   value1 = NIL; mv_count=1; # returns NIL
  629. }
  630.  
  631. # (STDWIN::XOR-CIRCLE x y radius) calls wxorcircle().
  632. LISPFUNN(stdwin_xor_circle,3)
  633. { var reg3 sintL x = I_to_L(STACK_2);
  634.   var reg2 sintL y = I_to_L(STACK_1);
  635.   var reg1 sintL radius = I_to_L(STACK_0);
  636.   check_init();
  637.   begin_call();
  638.   wxorcircle(x,y,radius);
  639.   end_call();
  640.   skipSTACK(3);
  641.   value1 = NIL; mv_count=1; # returns NIL
  642. }
  643.  
  644. # (STDWIN::FILL-CIRCLE x y radius) calls wfillcircle().
  645. LISPFUNN(stdwin_fill_circle,3)
  646. { var reg3 sintL x = I_to_L(STACK_2);
  647.   var reg2 sintL y = I_to_L(STACK_1);
  648.   var reg1 sintL radius = I_to_L(STACK_0);
  649.   check_init();
  650.   begin_call();
  651.   wfillcircle(x,y,radius);
  652.   end_call();
  653.   skipSTACK(3);
  654.   value1 = NIL; mv_count=1; # returns NIL
  655. }
  656.  
  657. # (STDWIN::DRAW-ARC x y rx ry angle1 angle2) calls wdrawelarc().
  658. LISPFUNN(stdwin_draw_arc,6)
  659. { var reg6 sintL x = I_to_L(STACK_5);
  660.   var reg5 sintL y = I_to_L(STACK_4);
  661.   var reg4 sintL rx = I_to_L(STACK_3);
  662.   var reg3 sintL ry = I_to_L(STACK_2);
  663.   var reg2 sintL angle1 = I_to_L(STACK_1);
  664.   var reg1 sintL angle2 = I_to_L(STACK_0);
  665.   check_init();
  666.   begin_call();
  667.   wdrawelarc(x,y,rx,ry,angle1,angle2);
  668.   end_call();
  669.   skipSTACK(6);
  670.   value1 = NIL; mv_count=1; # returns NIL
  671. }
  672.  
  673. # (STDWIN::XOR-ARC x y rx ry angle1 angle2) calls wxorelarc().
  674. LISPFUNN(stdwin_xor_arc,6)
  675. { var reg6 sintL x = I_to_L(STACK_5);
  676.   var reg5 sintL y = I_to_L(STACK_4);
  677.   var reg4 sintL rx = I_to_L(STACK_3);
  678.   var reg3 sintL ry = I_to_L(STACK_2);
  679.   var reg2 sintL angle1 = I_to_L(STACK_1);
  680.   var reg1 sintL angle2 = I_to_L(STACK_0);
  681.   check_init();
  682.   begin_call();
  683.   wxorelarc(x,y,rx,ry,angle1,angle2);
  684.   end_call();
  685.   skipSTACK(6);
  686.   value1 = NIL; mv_count=1; # returns NIL
  687. }
  688.  
  689. # (STDWIN::FILL-ARC x y rx ry angle1 angle2) calls wfillelarc().
  690. LISPFUNN(stdwin_fill_arc,6)
  691. { var reg6 sintL x = I_to_L(STACK_5);
  692.   var reg5 sintL y = I_to_L(STACK_4);
  693.   var reg4 sintL rx = I_to_L(STACK_3);
  694.   var reg3 sintL ry = I_to_L(STACK_2);
  695.   var reg2 sintL angle1 = I_to_L(STACK_1);
  696.   var reg1 sintL angle2 = I_to_L(STACK_0);
  697.   check_init();
  698.   begin_call();
  699.   wfillelarc(x,y,rx,ry,angle1,angle2);
  700.   end_call();
  701.   skipSTACK(6);
  702.   value1 = NIL; mv_count=1; # returns NIL
  703. }
  704.  
  705. #                       Text drawing primitives
  706. #                       -----------------------
  707.  
  708. # (STDWIN::DRAW-CHAR x y char) calls wdrawchar().
  709. LISPFUNN(stdwin_draw_char,3)
  710. { var reg2 sintL x = I_to_L(STACK_2);
  711.   var reg1 sintL y = I_to_L(STACK_1);
  712.   if (!string_char_p(STACK_0)) { fehler_string_char(STACK_0); }
  713.   check_init();
  714.   begin_call();
  715.   wdrawchar(x,y,char_code(STACK_0));
  716.   end_call();
  717.   skipSTACK(3);
  718.   value1 = NIL; mv_count=1; # returns NIL
  719. }
  720.  
  721. # (STDWIN::DRAW-TEXT x y string) calls wdrawtext().
  722. LISPFUNN(stdwin_draw_text,3)
  723. { var reg6 sintL x = I_to_L(STACK_2);
  724.   var reg5 sintL y = I_to_L(STACK_1);
  725.   var reg1 object string = STACK_0;
  726.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  727.   check_init();
  728.   with_string(string,chars,len,
  729.     if (len > 0)
  730.       { begin_call();
  731.         wdrawtext(x,y,chars,len);
  732.         end_call();
  733.       }
  734.     );
  735.   skipSTACK(3);
  736.   value1 = NIL; mv_count=1; # returns NIL
  737. }
  738.  
  739. #                       Text measuring primitives
  740. #                       -------------------------
  741.  
  742. # (STDWIN::LINE-HEIGHT) calls wlineheight().
  743. LISPFUNN(stdwin_line_height,0)
  744. { check_init();
  745.   begin_call();
  746.  {var reg1 sintL h = wlineheight();
  747.   end_call();
  748.   value1 = L_to_I(h); mv_count=1;
  749. }}
  750.  
  751. # (STDWIN::CHAR-WIDTH char) calls wcharwidth().
  752. LISPFUNN(stdwin_char_width,1)
  753. { var reg1 object ch = popSTACK();
  754.   if (!string_char_p(ch))
  755.     { pushSTACK(ch); # Wert für Slot DATUM von TYPE-ERROR
  756.       pushSTACK(S(string_char)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  757.       pushSTACK(ch); pushSTACK(TheSubr(subr_self)->name);
  758.       //: DEUTSCH "~: Argument ~ ist kein String-Char."
  759.       //: ENGLISH "~: argument ~ is not a string-char"
  760.       //: FRANCAIS "~: L'argument ~ n'est pas un caractère de type STRING-CHAR."
  761.       fehler(type_error, GETTEXT("~: argument ~ is not a string-char"));
  762.     }
  763.   check_init();
  764.   begin_call();
  765.  {var reg2 sintL w = wcharwidth(char_code(ch));
  766.   end_call();
  767.   value1 = L_to_I(w); mv_count=1;
  768. }}
  769.  
  770. # (STDWIN::TEXT-WIDTH string) calls wtextwidth().
  771. LISPFUNN(stdwin_text_width,1)
  772. { var reg1 object string = popSTACK();
  773.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  774.  {var reg4 sintL w;
  775.   check_init();
  776.   with_string(string,chars,len,
  777.     { begin_call();
  778.       w = wtextwidth(chars,len);
  779.       end_call();
  780.     });
  781.   value1 = L_to_I(w); mv_count=1;
  782. }}
  783.  
  784. # (STDWIN::TEXT-BREAK string width) calls wtextbreak().
  785. LISPFUNN(stdwin_text_break,2)
  786. { var reg1 object string = STACK_1;
  787.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  788.  {var reg6 sintL width = I_to_L(STACK_0);
  789.   var reg4 sintL w;
  790.   check_init();
  791.   with_string(string,chars,len,
  792.     { begin_call();
  793.       w = wtextbreak(chars,len,width);
  794.       end_call();
  795.     });
  796.   value1 = L_to_I(w); mv_count=1;
  797.   skipSTACK(2);
  798. }}
  799.  
  800. #                             Text style
  801. #                             ----------
  802.  
  803. # (STDWIN::SET-TEXT-FONT font-name font-style font-size) sets the current font.
  804. LISPFUNN(stdwin_set_text_font,3)
  805. { var reg4 object string = STACK_2;
  806.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  807.  {var reg5 sintL style = I_to_L(STACK_1);
  808.   var reg6 sintL size = I_to_L(STACK_0);
  809.   check_init();
  810.   with_string_0(string,fontname,
  811.     { begin_call();
  812.       wsetfont(fontname);
  813.       switch (style)
  814.         { case 0: wsetplain();      break;
  815.           case 1: wsethilite();     break;
  816.           case 2: wsetinverse();    break;
  817.           case 3: wsetitalic();     break;
  818.           case 4: wsetbold();       break;
  819.           case 5: wsetbolditalic(); break;
  820.           case 6: wsetunderline();  break;
  821.           default: break;
  822.         }
  823.       wsetsize(size);
  824.       end_call();
  825.     });
  826.   skipSTACK(3);
  827.   value1 = NIL; mv_count=1; # returns NIL
  828. }}
  829.  
  830. #                               Events
  831. #                               ++++++
  832.  
  833. # returns an event as a set of multiple values (no consing!)
  834. # return_event(event);
  835.   local Values return_event (EVENT* ep);
  836.   local Values return_event(ep)
  837.     var reg1 EVENT* ep;
  838.     { # cf. stdwin/H/stdwin.h, definition of 'struct _event'
  839.       var reg2 uintC mvcount;
  840.       pushSTACK(L_to_I(ep->type));
  841.       pushSTACK(type_untype_object(machine_type,ep->window));
  842.       # the next values provide more specific information
  843.       switch (ep->type)
  844.         { case WE_CHAR:
  845.             pushSTACK(L_to_I(ep->u.character));
  846.             mvcount=3; break;
  847.           case WE_COMMAND:
  848.             pushSTACK(L_to_I(ep->u.command));
  849.             mvcount=3; break;
  850.           case WE_MENU:
  851.             pushSTACK(L_to_I(ep->u.m.id));
  852.             pushSTACK(L_to_I(ep->u.m.item));
  853.             mvcount=4; break;
  854.           case WE_DRAW:
  855.             pushSTACK(L_to_I(ep->u.area.left));
  856.             pushSTACK(L_to_I(ep->u.area.top));
  857.             pushSTACK(L_to_I(ep->u.area.right - ep->u.area.left));
  858.             pushSTACK(L_to_I(ep->u.area.bottom - ep->u.area.top));
  859.             mvcount=6; break;
  860.           case WE_MOUSE_DOWN: case WE_MOUSE_MOVE: case WE_MOUSE_UP:
  861.             pushSTACK(L_to_I(ep->u.where.h));
  862.             pushSTACK(L_to_I(ep->u.where.v));
  863.             pushSTACK(L_to_I(ep->u.where.clicks));
  864.             pushSTACK(L_to_I(ep->u.where.button));
  865.             pushSTACK(L_to_I(ep->u.where.mask));
  866.             mvcount=7; break;
  867.           case WE_LOST_SEL:
  868.             pushSTACK(L_to_I(ep->u.sel));
  869.             mvcount=3; break;
  870.           case WE_KEY:
  871.             pushSTACK(L_to_I(ep->u.key.code));
  872.             pushSTACK(L_to_I(ep->u.key.mask));
  873.             mvcount=4; break;
  874.           default:
  875.             mvcount=2; break;
  876.         }
  877.       STACK_to_mv(mvcount);
  878.     }
  879.  
  880. #                         STDWIN-generated events
  881. #                         -----------------------
  882.  
  883. # This section was written by Pierpaolo Bernardi <bernardp@cli.di.unipi.it>.
  884.  
  885. # (STDWIN::WINDOW-SET-TIMER win decisec) calls wsettimer().
  886. LISPFUNN(stdwin_window_set_timer,2)
  887. { var reg1 decisec = I_to_L(popSTACK());
  888.   var reg2 WINDOW* win = test_window(popSTACK());
  889.   begin_call();
  890.   wsettimer(win,decisec);
  891.   end_call();
  892.   value1 = NIL; mv_count = 1;
  893. }
  894.  
  895. #                           The input model
  896. #                           +++++++++++++++
  897.  
  898. # (STDWIN::GET-EVENT) calls wgetevent().
  899. # (STDWIN::GET-EVENT-NO-HANG) calls wpollevent().
  900.  
  901. # (STDWIN::GET-EVENT) calls wgetevent().
  902. LISPFUNN(stdwin_get_event,0)
  903. { check_init();
  904.  {var EVENT event;
  905.   begin_call();
  906.   wgetevent(&event);
  907.   end_call();
  908.   return_event(&event);
  909. }}
  910.  
  911. # (STDWIN::GET-EVENT-NO-HANG) calls wpollevent().
  912. LISPFUNN(stdwin_get_event_no_hang,0)
  913. { check_init();
  914.  {var EVENT event;
  915.   begin_call();
  916.   wpollevent(&event);
  917.   end_call();
  918.   return_event(&event);
  919. }}
  920.  
  921. #                  Getting and setting the active window
  922. #                  +++++++++++++++++++++++++++++++++++++
  923.  
  924. # (STDWIN::ACTIVE-WINDOW) calls wgetactive().
  925. # (STDWIN::SET-ACTIVE-WINDOW win) calls wsetactive().
  926.  
  927. # (STDWIN::ACTIVE-WINDOW) calls wgetactive().
  928. LISPFUNN(stdwin_active_window,0)
  929. { var reg1 WINDOW* win;
  930.   check_init();
  931.   begin_call();
  932.   win = wgetactive();
  933.   end_call();
  934.   value1 = (nullp(find_win(win)) ? NIL : type_untype_object(machine_type,win));
  935.   mv_count=1;
  936. }
  937.  
  938. # (STDWIN::SET-ACTIVE-WINDOW win) calls wsetactive().
  939. LISPFUNN(stdwin_set_active_window,1)
  940. { var reg1 WINDOW* win = test_window(STACK_0);
  941.   begin_call();
  942.   wsetactive(win);
  943.   end_call();
  944.   value1 = popSTACK(); mv_count=1; # returns win
  945. }
  946.  
  947. #                                  Menus
  948. #                                  +++++
  949.  
  950. # The documentation says that the menu id's should be in the range [1..255] and
  951. # unique within the application. We therefore manage the menu id's here.
  952.   #define menu_id_MAX  255
  953.   local unsigned int menu_id_max = 0; # maximum menu id that has been used for now
  954.   local MENU* menu_id[1+menu_id_MAX]; # menu_id[1..menu_id_max] are in use
  955.  
  956. # (STDWIN::MENU-CREATE title) calls wmenucreate().
  957. LISPFUNN(stdwin_menu_create,1)
  958. { var reg2 object string = popSTACK();
  959.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  960.   check_init();
  961.   # find a free menu id:
  962.  {var reg1 unsigned int id;
  963.   for (id = menu_id_max; id > 0; id--) { if (menu_id[id] == NULL) break; }
  964.   if (id == 0)
  965.     { if (menu_id_max < menu_id_MAX)
  966.         { id = ++menu_id_max; menu_id[id] = NULL; }
  967.         else
  968.         { pushSTACK(TheSubr(subr_self)->name);
  969.           //: DEUTSCH "~: STDWIN begrenzt die Anzahl der aktiven Menüs."
  970.           //: ENGLISH "~: STDWIN limits the number of active menus"
  971.           //: FRANCAIS "~ : STDWIN n'a qu'un nombre limité de menus."
  972.           fehler(error, GETTEXT("~: STDWIN limits the number of active menus"));
  973.     }   }
  974.   with_string_0(string,title,
  975.     { begin_call();
  976.       menu_id[id] = wmenucreate(id,title);
  977.       end_call();
  978.     });
  979.   value1 = fixnum(id); mv_count=1;
  980. }}
  981.  
  982. # test_menu(arg) checks that an argument is an STDWIN menu, and returns its id.
  983.   local int test_menu (object arg);
  984.   local int test_menu(arg)
  985.     var reg2 object arg;
  986.     { if (posfixnump(arg))
  987.         { var reg1 uintL id = posfixnum_to_L(arg);
  988.           if ((id > 0) && (id <= menu_id_max))
  989.             { var reg3 MENU* mp = menu_id[id];
  990.               if (!(mp == NULL))
  991.                 { return id; }
  992.         }   }
  993.       pushSTACK(arg);
  994.       pushSTACK(TheSubr(subr_self)->name);
  995.       //: DEUTSCH "~: Argument ~ ist kein STDWIN:MENU."
  996.       //: ENGLISH "~: argument ~ is not a STDWIN:MENU"
  997.       //: FRANCAIS "~ : L'argument ~ n'est pas de type STDWIN:MENU."
  998.       fehler(error, GETTEXT("~: argument ~ is not a STDWIN:MENU"));
  999.    }
  1000.  
  1001. # (STDWIN::MENU-DELETE menu) calls wmenudelete().
  1002. LISPFUNN(stdwin_menu_delete,1)
  1003. { var reg1 int id = test_menu(popSTACK());
  1004.   begin_call();
  1005.   wmenudelete(menu_id[id]);
  1006.   end_call();
  1007.   if (id==menu_id_max) { menu_id_max--; } else { menu_id[id] = NULL; }
  1008.   value1 = NIL; mv_count=1; # returns NIL
  1009. }
  1010.  
  1011. # (STDWIN::MENU-ATTACH window menu) calls wmenuattach().
  1012. LISPFUNN(stdwin_menu_attach,2)
  1013. { var reg2 WINDOW* win = test_window(STACK_1);
  1014.   var reg1 int id = test_menu(STACK_0);
  1015.   begin_call();
  1016.   wmenuattach(win,menu_id[id]);
  1017.   end_call();
  1018.   skipSTACK(2);
  1019.   value1 = NIL; mv_count=1; # returns NIL
  1020. }
  1021.  
  1022. # (STDWIN::MENU-DETACH window menu) calls wmenudetach().
  1023. LISPFUNN(stdwin_menu_detach,2)
  1024. { var reg2 WINDOW* win = test_window(STACK_1);
  1025.   var reg1 int id = test_menu(STACK_0);
  1026.   begin_call();
  1027.   wmenudetach(win,menu_id[id]);
  1028.   end_call();
  1029.   skipSTACK(2);
  1030.   value1 = NIL; mv_count=1; # returns NIL
  1031. }
  1032.  
  1033. # (STDWIN::MENU-SIZE menu) returns the number of items in a menu.
  1034. LISPFUNN(stdwin_menu_size,1)
  1035. { var reg1 int id = test_menu(popSTACK());
  1036.   value1 = L_to_I(((_FAKEMENU*)(menu_id[id]))->nitems); mv_count=1;
  1037. }
  1038.  
  1039. # (STDWIN::MENU-ADD-ITEM menu label [shortcut]) calls wmenuadditem().
  1040. LISPFUN(stdwin_menu_add_item,2,1,norest,nokey,0,NIL)
  1041. { var reg2 int id = test_menu(STACK_2);
  1042.   var reg1 object string = STACK_1;
  1043.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  1044.  {var reg3 object shortcut = STACK_0;
  1045.   var reg4 int sc;
  1046.   if (eq(shortcut,unbound) || nullp(shortcut)) { sc = -1; }
  1047.   elif (string_char_p(shortcut)) { sc = char_code(shortcut); }
  1048.   else { fehler_string_char(STACK_0); } # auch #\Control-x etc. zulassen??
  1049.   {var reg5 int result;
  1050.    with_string_0(string,label,
  1051.      { begin_call();
  1052.        result = wmenuadditem(menu_id[id],label,sc);
  1053.        end_call();
  1054.      });
  1055.    skipSTACK(3);
  1056.    value1 = L_to_I(result); mv_count=1; # returns the item's number
  1057. }}}
  1058.  
  1059. # test_item(id,arg) checks that an argument is a valid menu item.
  1060.   local int test_item (int id, object arg);
  1061.   local int test_item(id,arg)
  1062.     var reg1 int id;
  1063.     var reg1 object arg;
  1064.     { if (posfixnump(arg))
  1065.         { var reg1 uintL item = posfixnum_to_L(arg);
  1066.           if (item < ((_FAKEMENU*)(menu_id[id]))->nitems)
  1067.             { return item; }
  1068.         }
  1069.       pushSTACK(arg);
  1070.       pushSTACK(TheSubr(subr_self)->name);
  1071.       //: DEUTSCH "~: Argument ~ ist kein STDWIN:MENU-ITEM."
  1072.       //: ENGLISH "~: argument ~ is not a STDWIN:MENU-ITEM"
  1073.       //: FRANCAIS "~ : L'argument ~ n'est pas de type STDWIN:MENU-ITEM."
  1074.       fehler(error, GETTEXT("~: argument ~ is not a STDWIN:MENU-ITEM"));
  1075.     }
  1076.  
  1077. # (STDWIN::SET-MENU-ITEM-LABEL menu item-number label) calls wmenusetitem().
  1078. LISPFUNN(stdwin_set_menu_item_label,3)
  1079. { var reg1 object string = STACK_0;
  1080.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  1081.  {var reg2 int id = test_menu(STACK_2);
  1082.   var reg3 int item = test_item(id,STACK_1);
  1083.   with_string_0(string,label,
  1084.     { begin_call();
  1085.       wmenusetitem(menu_id[id],item,label);
  1086.       end_call();
  1087.     });
  1088.   value1 = STACK_0; mv_count=1; # returns the string
  1089.   skipSTACK(3);
  1090. }}
  1091.  
  1092. # (STDWIN::MENU-ITEM-ENABLE menu item-number) calls wmenuenable().
  1093. LISPFUNN(stdwin_menu_item_enable,2)
  1094. { var reg1 int id = test_menu(STACK_1);
  1095.   var reg2 int item = test_item(id,STACK_0);
  1096.   begin_call();
  1097.   wmenuenable(menu_id[id],item,TRUE);
  1098.   end_call();
  1099.   value1 = T; mv_count=1; # returns T
  1100.   skipSTACK(2);
  1101. }
  1102.  
  1103. # (STDWIN::MENU-ITEM-DISABLE menu item-number) calls wmenuenable().
  1104. LISPFUNN(stdwin_menu_item_disable,2)
  1105. { var reg1 int id = test_menu(STACK_1);
  1106.   var reg2 int item = test_item(id,STACK_0);
  1107.   begin_call();
  1108.   wmenuenable(menu_id[id],item,FALSE);
  1109.   end_call();
  1110.   value1 = NIL; mv_count=1; # returns NIL
  1111.   skipSTACK(2);
  1112. }
  1113.  
  1114. # (STDWIN::SET-MENU-ITEM-CHECKMARK menu item-number flag) calls wmenucheck().
  1115. LISPFUNN(stdwin_set_menu_item_checkmark,3)
  1116. { var reg1 int id = test_menu(STACK_2);
  1117.   var reg2 int item = test_item(id,STACK_1);
  1118.   var reg3 int flag = (nullp(STACK_0) ? FALSE : TRUE);
  1119.   begin_call();
  1120.   wmenucheck(menu_id[id],item,flag);
  1121.   end_call();
  1122.   value1 = STACK_0; mv_count=1; # returns flag
  1123.   skipSTACK(3);
  1124. }
  1125.  
  1126. #                            The text caret
  1127. #                            ++++++++++++++
  1128.  
  1129. # This section was written by Pierpaolo Bernardi <bernardp@cli.di.unipi.it>.
  1130.  
  1131. # (STDWIN::WINDOW-SET-CARET win h v) calls wsetcaret().
  1132. LISPFUNN(stdwin_window_set_caret,3)
  1133. { var reg2 object arg = STACK_2;
  1134.   var reg1 WINDOW* win = test_window(arg);
  1135.   var int h = I_to_L(STACK_1);
  1136.   var int v = I_to_L(STACK_0);
  1137.   begin_call();
  1138.   wsetcaret(win,h,v);
  1139.   end_call();
  1140.   skipSTACK(3);
  1141.   value1 = NIL; mv_count = 1;
  1142. }
  1143.  
  1144. # (STDWIN::WINDOW-NO-CARET win) calls wnocaret().
  1145. LISPFUNN(stdwin_window_no_caret,1)
  1146. { var reg1 WINDOW* win = test_window(popSTACK());
  1147.   begin_call();
  1148.   wnocaret(win);
  1149.   end_call();
  1150.   value1 = NIL; mv_count = 1;
  1151. }
  1152.  
  1153. #                            Dialogue tools
  1154. #                            ++++++++++++++
  1155.  
  1156. # (STDWIN::USER-MESSAGE message) calls wmessage().
  1157. LISPFUNN(stdwin_user_message,1)
  1158. { var reg1 object string = popSTACK();
  1159.   if (!stringp(string)) { fehler_string(string); } # muß ein String sein
  1160.   check_init();
  1161.   with_string_0(string,message,
  1162.     { begin_call();
  1163.       wmessage(message);
  1164.       end_call();
  1165.     });
  1166.   value1 = NIL; mv_count=1; # returns NIL
  1167. }
  1168.  
  1169. # (STDWIN::USER-ASK question [default-reply]) calls waskstr().
  1170. LISPFUN(stdwin_user_ask,1,1,norest,nokey,0,NIL)
  1171. { var reg8 object string1 = STACK_1;
  1172.   if (!stringp(string1)) { fehler_string(string1); } # muß ein String sein
  1173.  {var reg7 object string2 = (mstringp(STACK_0) ? STACK_0 : O(leer_string));
  1174.   check_init();
  1175.   with_string_0(string1,question,
  1176.     { with_string(string2,default_chars,default_len,
  1177.         { var reg6 uintL reply_len = default_len + 10000; # reicht hoffentlich
  1178.           # Buffer für die Antwort reservieren:
  1179.           var DYNAMIC_ARRAY(_EMA_,reply_chars,char,reply_len);
  1180.           # default in reply umkopieren:
  1181.           { var reg2 char* ptr1 = default_chars;
  1182.             var reg1 char* ptr2 = reply_chars;
  1183.             var reg3 uintL count;
  1184.             dotimesL(count,default_len, { *ptr2++ = *ptr1++; } );
  1185.             *ptr2 = '\0';
  1186.           }
  1187.           begin_call();
  1188.          {var reg1 int result = waskstr(question,reply_chars,reply_len);
  1189.           end_call();
  1190.           value1 = (result ? asciz_to_string(reply_chars) : NIL); mv_count=1;
  1191.           FREE_DYNAMIC_ARRAY(reply_chars);
  1192.         }});
  1193.     });
  1194.   skipSTACK(2);
  1195. }}
  1196.  
  1197. #endif
  1198.  
  1199. #ifdef STDWIN_MODULE
  1200.  
  1201. #                  STDWIN as a linkable module for CLISP
  1202. #                  =====================================
  1203.  
  1204. #undef LISPFUN
  1205. #define LISPFUN LISPFUN_F
  1206. #undef LISPSYM
  1207. #define LISPSYM(name,printname,package)  { package, printname },
  1208. #define stdwin  "STDWIN"
  1209.  
  1210. subr_ module__stdwin__subr_tab [65] = {
  1211.   LISPFUNN(stdwin_init,0)
  1212.   LISPFUNN(stdwin_done,0)
  1213.   LISPFUNN(stdwin_drawproc_alist,0)
  1214.   LISPFUNN(stdwin_wopen,2)
  1215.   LISPFUNN(stdwin_wclose,1)
  1216.   LISPFUNN(stdwin_scrollbar_p,0)
  1217.   LISPFUNN(stdwin_set_scrollbar_p,2)
  1218.   LISPFUNN(stdwin_default_window_size,0)
  1219.   LISPFUNN(stdwin_set_default_window_size,2)
  1220.   LISPFUNN(stdwin_default_window_position,0)
  1221.   LISPFUNN(stdwin_set_default_window_position,2)
  1222.   LISPFUNN(stdwin_screen_size,0)
  1223.   LISPFUNN(stdwin_window_size,1)
  1224.   LISPFUNN(stdwin_window_position,1)
  1225.   LISPFUNN(stdwin_window_document_size,1)
  1226.   LISPFUNN(stdwin_set_window_document_size,3)
  1227.   LISPFUNN(stdwin_window_title,1)
  1228.   LISPFUNN(stdwin_set_window_title,2)
  1229.   LISPFUNN(stdwin_set_window_cursor,2)
  1230.   LISPFUNN(stdwin_window_show,5)
  1231.   LISPFUNN(stdwin_window_origin,1)
  1232.   LISPFUNN(stdwin_set_window_origin,3)
  1233.   LISPFUNN(stdwin_window_change,5)
  1234.   LISPFUNN(stdwin_window_update,1)
  1235.   LISPFUNN(stdwin_begin_drawing,1)
  1236.   LISPFUNN(stdwin_end_drawing,1)
  1237.   LISPFUNN(stdwin_draw_line,4)
  1238.   LISPFUNN(stdwin_xor_line,4)
  1239.   LISPFUNN(stdwin_draw_box,4)
  1240.   LISPFUNN(stdwin_paint,4)
  1241.   LISPFUNN(stdwin_invert,4)
  1242.   LISPFUNN(stdwin_erase,4)
  1243.   LISPFUNN(stdwin_shade,5)
  1244.   LISPFUNN(stdwin_draw_circle,3)
  1245.   LISPFUNN(stdwin_xor_circle,3)
  1246.   LISPFUNN(stdwin_fill_circle,3)
  1247.   LISPFUNN(stdwin_draw_arc,6)
  1248.   LISPFUNN(stdwin_xor_arc,6)
  1249.   LISPFUNN(stdwin_fill_arc,6)
  1250.   LISPFUNN(stdwin_draw_char,3)
  1251.   LISPFUNN(stdwin_draw_text,3)
  1252.   LISPFUNN(stdwin_line_height,0)
  1253.   LISPFUNN(stdwin_char_width,1)
  1254.   LISPFUNN(stdwin_text_width,1)
  1255.   LISPFUNN(stdwin_text_break,2)
  1256.   LISPFUNN(stdwin_set_text_font,3)
  1257.   LISPFUNN(stdwin_window_set_timer,2)
  1258.   LISPFUNN(stdwin_get_event,0)
  1259.   LISPFUNN(stdwin_get_event_no_hang,0)
  1260.   LISPFUNN(stdwin_active_window,0)
  1261.   LISPFUNN(stdwin_set_active_window,1)
  1262.   LISPFUNN(stdwin_menu_create,1)
  1263.   LISPFUNN(stdwin_menu_delete,1)
  1264.   LISPFUNN(stdwin_menu_attach,2)
  1265.   LISPFUNN(stdwin_menu_detach,2)
  1266.   LISPFUNN(stdwin_menu_size,1)
  1267.   LISPFUN(stdwin_menu_add_item,2,1,norest,nokey,0,NIL)
  1268.   LISPFUNN(stdwin_set_menu_item_label,3)
  1269.   LISPFUNN(stdwin_menu_item_enable,2)
  1270.   LISPFUNN(stdwin_menu_item_disable,2)
  1271.   LISPFUNN(stdwin_set_menu_item_checkmark,3)
  1272.   LISPFUNN(stdwin_window_set_caret,3)
  1273.   LISPFUNN(stdwin_window_no_caret,1)
  1274.   LISPFUNN(stdwin_user_message,1)
  1275.   LISPFUN(stdwin_user_ask,1,1,norest,nokey,0,NIL)
  1276. };
  1277.  
  1278. uintC module__stdwin__subr_tab_size = 65;
  1279.  
  1280. subr_initdata module__stdwin__subr_tab_initdata[65] = {
  1281.   LISPSYM(stdwin_init,"INIT",stdwin)
  1282.   LISPSYM(stdwin_done,"DONE",stdwin)
  1283.   LISPSYM(stdwin_drawproc_alist,"DRAWPROC-ALIST",stdwin)
  1284.   LISPSYM(stdwin_wopen,"WOPEN",stdwin)
  1285.   LISPSYM(stdwin_wclose,"WCLOSE",stdwin)
  1286.   LISPSYM(stdwin_scrollbar_p,"SCROLLBAR-P",stdwin)
  1287.   LISPSYM(stdwin_set_scrollbar_p,"SET-SCROLLBAR-P",stdwin)
  1288.   LISPSYM(stdwin_default_window_size,"DEFAULT-WINDOW-SIZE",stdwin)
  1289.   LISPSYM(stdwin_set_default_window_size,"SET-DEFAULT-WINDOW-SIZE",stdwin)
  1290.   LISPSYM(stdwin_default_window_position,"DEFAULT-WINDOW-POSITION",stdwin)
  1291.   LISPSYM(stdwin_set_default_window_position,"SET-DEFAULT-WINDOW-POSITION",stdwin)
  1292.   LISPSYM(stdwin_screen_size,"SCREEN-SIZE",stdwin)
  1293.   LISPSYM(stdwin_window_size,"WINDOW-SIZE",stdwin)
  1294.   LISPSYM(stdwin_window_position,"WINDOW-POSITION",stdwin)
  1295.   LISPSYM(stdwin_window_document_size,"WINDOW-DOCUMENT-SIZE",stdwin)
  1296.   LISPSYM(stdwin_set_window_document_size,"SET-WINDOW-DOCUMENT-SIZE",stdwin)
  1297.   LISPSYM(stdwin_window_title,"WINDOW-TITLE",stdwin)
  1298.   LISPSYM(stdwin_set_window_title,"SET-WINDOW-TITLE",stdwin)
  1299.   LISPSYM(stdwin_set_window_cursor,"SET-WINDOW-CURSOR",stdwin)
  1300.   LISPSYM(stdwin_window_show,"WINDOW-SHOW",stdwin)
  1301.   LISPSYM(stdwin_window_origin,"WINDOW-ORIGIN",stdwin)
  1302.   LISPSYM(stdwin_set_window_origin,"SET-WINDOW-ORIGIN",stdwin)
  1303.   LISPSYM(stdwin_window_change,"WINDOW-CHANGE",stdwin)
  1304.   LISPSYM(stdwin_window_update,"WINDOW-UPDATE",stdwin)
  1305.   LISPSYM(stdwin_begin_drawing,"BEGIN-DRAWING",stdwin)
  1306.   LISPSYM(stdwin_end_drawing,"END-DRAWING",stdwin)
  1307.   LISPSYM(stdwin_draw_line,"DRAW-LINE",stdwin)
  1308.   LISPSYM(stdwin_xor_line,"XOR-LINE",stdwin)
  1309.   LISPSYM(stdwin_draw_box,"DRAW-BOX",stdwin)
  1310.   LISPSYM(stdwin_paint,"PAINT",stdwin)
  1311.   LISPSYM(stdwin_invert,"INVERT",stdwin)
  1312.   LISPSYM(stdwin_erase,"ERASE",stdwin)
  1313.   LISPSYM(stdwin_shade,"SHADE",stdwin)
  1314.   LISPSYM(stdwin_draw_circle,"DRAW-CIRCLE",stdwin)
  1315.   LISPSYM(stdwin_xor_circle,"XOR-CIRCLE",stdwin)
  1316.   LISPSYM(stdwin_fill_circle,"FILL-CIRCLE",stdwin)
  1317.   LISPSYM(stdwin_draw_arc,"DRAW-ARC",stdwin)
  1318.   LISPSYM(stdwin_xor_arc,"XOR-ARC",stdwin)
  1319.   LISPSYM(stdwin_fill_arc,"FILL-ARC",stdwin)
  1320.   LISPSYM(stdwin_draw_char,"DRAW-CHAR",stdwin)
  1321.   LISPSYM(stdwin_draw_text,"DRAW-TEXT",stdwin)
  1322.   LISPSYM(stdwin_line_height,"LINE-HEIGHT",stdwin)
  1323.   LISPSYM(stdwin_char_width,"CHAR-WIDTH",stdwin)
  1324.   LISPSYM(stdwin_text_width,"TEXT-WIDTH",stdwin)
  1325.   LISPSYM(stdwin_text_break,"TEXT-BREAK",stdwin)
  1326.   LISPSYM(stdwin_set_text_font,"SET-TEXT-FONT",stdwin)
  1327.   LISPSYM(stdwin_window_set_timer,"WINDOW-SET-TIMER",stdwin)
  1328.   LISPSYM(stdwin_get_event,"GET-EVENT",stdwin)
  1329.   LISPSYM(stdwin_get_event_no_hang,"GET-EVENT-NO-HANG",stdwin)
  1330.   LISPSYM(stdwin_active_window,"ACTIVE-WINDOW",stdwin)
  1331.   LISPSYM(stdwin_set_active_window,"SET-ACTIVE-WINDOW",stdwin)
  1332.   LISPSYM(stdwin_menu_create,"MENU-CREATE",stdwin)
  1333.   LISPSYM(stdwin_menu_delete,"MENU-DELETE",stdwin)
  1334.   LISPSYM(stdwin_menu_attach,"MENU-ATTACH",stdwin)
  1335.   LISPSYM(stdwin_menu_detach,"MENU-DETACH",stdwin)
  1336.   LISPSYM(stdwin_menu_size,"MENU-SIZE",stdwin)
  1337.   LISPSYM(stdwin_menu_add_item,"MENU-ADD-ITEM",stdwin)
  1338.   LISPSYM(stdwin_set_menu_item_label,"SET-MENU-ITEM-LABEL",stdwin)
  1339.   LISPSYM(stdwin_menu_item_enable,"MENU-ITEM-ENABLE",stdwin)
  1340.   LISPSYM(stdwin_menu_item_disable,"MENU-ITEM-DISABLE",stdwin)
  1341.   LISPSYM(stdwin_set_menu_item_checkmark,"SET-MENU-ITEM-CHECKMARK",stdwin)
  1342.   LISPSYM(stdwin_window_no_caret,"WINDOW-NO-CARET",stdwin)
  1343.   LISPSYM(stdwin_user_message,"USER-MESSAGE",stdwin)
  1344.   LISPSYM(stdwin_user_message,"USER-MESSAGE",stdwin)
  1345.   LISPSYM(stdwin_user_ask,"USER-ASK",stdwin)
  1346. };
  1347.  
  1348. void module__stdwin__init_function_1(module)
  1349.   var module_* module;
  1350.   { }
  1351.  
  1352. void module__stdwin__init_function_2(module)
  1353.   var module_* module;
  1354.   { }
  1355.  
  1356. #endif
  1357.  
  1358.