mim/development/mim/vax/nvs/vsbase.mud

   1 <PACKAGE "VSBASE">
   2
   3 <ENTRY SEND-PACKET RECEIVE-PACKET VSB-SEND VSB-DUMP VSB-WAIT
   4        VSB-DEBUG? VSB-PLIST>
   5
   6 <ENTRY PROCESS-EVENT NORMAL-KEYS FUNCTION-KEYS GET-EVENT FREE-MOUSE-EVENTS
   7        FREE-WINDOW-EVENTS ANY-INPUT? MOUSE-GRABBED? REDISPLAY-ICON
   8        FREE-RECTANGLES CURRENT-ROOT-ID>
   9
  10 <USE "NETBASE">
  11
  12 <INCLUDE "VSTYPES" "VSUTYPES">
  13 <INCLUDE-WHEN <COMPILING? "VSBASE"> "VSDEFS" "VSUDEFS" "VSOPS">
  14
  15 <SETG VSB-DEBUG? <>>
  16 <GDECL (VSB-DEBUG?) <OR ATOM !<FALSE>>
  17        (VSB-PLIST REST-PLIST) LIST>
  18
  19 <SETG SEND-PACKET <IUVECTOR 6>>
  20 <SETG RECEIVE-PACKET <IUVECTOR 6>>
  21 <GDECL (RECEIVE-PACKET SEND-PACKET) <UVECTOR [6 FIX]>>
  22
  23 <DEFINE VSB-SEND (VS:VS FORCE?:<OR ATOM FALSE> REPLY?:<OR ATOM FIX FALSE>
  24                   "TUPLE" STUFF
  25                   "AUX" (CHN:<CHANNEL 'NETWORK> <VS-CHANNEL .VS>)
  26                   (RES:<OR FIX FALSE> 0) NVAL)
  27    <VS-REQ .VS <+ <VS-REQ .VS> 1>>
  28    <COND (,VSB-DEBUG?
  29           <COND (<NOT <GASSIGNED? VSB-PLIST>>
  30                  <SETG VSB-PLIST (0)>
  31                  <SETG REST-PLIST ,VSB-PLIST>)>
  32           <SETG REST-PLIST <REST <PUTREST ,REST-PLIST
  33                                           (<VS-REQ .VS>
  34                                            <SUBSTRUC <1 .STUFF>:UVECTOR>)>
  35                                  2>>)>
  36    <SET NVAL
  37     <COND (<OR <NOT <VS-BUFFER .VS>>
  38               <AND .FORCE? <0? <VS-BCT .VS>>>>
  39           <COND (<REPEAT ((ST .STUFF) LEN OBJ)
  40                     <COND (<EMPTY? .ST> <RETURN T>)>
  41                     <COND
  42                      (<1? <LENGTH .ST>>
  43                       <COND (<NOT <SET LEN <CHANNEL-OP .CHN WRITE-BUFFER
  44                                                        <SET OBJ <1 .ST>>>>>
  45                              <RETURN <>>)>)
  46                      (T
  47                       <COND (<NOT <SET LEN <CHANNEL-OP .CHN WRITE-BUFFER
  48                                                        <SET OBJ <1 .ST>>
  49                                                        <2 .ST>>>>
  50                              <RETURN <>>)>
  51                       <SET ST <REST .ST 2>>)>
  52                     <COND (<AND <TYPE? .OBJ STRING BYTES>
  53                                 <NOT <0? <MOD .LEN:FIX 4>>>>
  54                            <CHANNEL-OP .CHN WRITE-BUFFER
  55                                        "   "
  56                                        <- 4 <MOD .LEN:FIX 4>>>)>>
  57                  <COND (.REPLY? <VSB-WAIT .VS .REPLY?>)>)>)
  58          (T
  59           <REPEAT (OBJ:<OR <PRIMTYPE STRING> <PRIMTYPE UVECTOR>>
  60                    LEN:<OR FIX FALSE> NRES)
  61              <COND (<EMPTY? .STUFF>
  62                     <COND (.FORCE?
  63                            <COND (<VSB-DUMP .VS>
  64                                   <COND (.REPLY?
  65                                          <RETURN <VSB-WAIT .VS .REPLY?>>)>
  66                                   <RETURN .RES>)
  67                                  (T <RETURN .NRES>)>)>
  68                     <RETURN .RES>)>
  69              <SET OBJ <1 .STUFF>>
  70              <COND (<==? <LENGTH .STUFF> 1>
  71                     <SET LEN <>>
  72                     <SET STUFF <REST .STUFF>>)
  73                    (T
  74                     <SET LEN <2 .STUFF>>
  75                     <SET STUFF <REST .STUFF 2>>)>
  76              <COND (<SET NRES <STUFF .OBJ .LEN .VS>>
  77                     <SET RES <+ .RES .NRES>>)
  78                    (T
  79                     <RETURN .NRES>)>>)>>
  80    <COND (<AND <NOT .REPLY?> ,VSB-DEBUG?>
  81           <VSOP .VS X-QUERY-WINDOW
  82                 <COND (<ASSIGNED? CURRENT-ROOT-ID>
  83                        .CURRENT-ROOT-ID)
  84                       (T
  85                        <VW-ID <CHANNEL-DATA <VS-TOPCHAN .VS>>>)>>)>
  86    .NVAL>
  87
  88 <DEFINE STUFF ST (OBJ:<OR <PRIMTYPE STRING> <PRIMTYPE UVECTOR>>
  89                LEN:<OR FIX FALSE> VS:VS "OPT" (ALLOW-ODD?  <>)
  90                "AUX" (BUF:STRING <VS-BUFFER .VS>)
  91                (CT <VS-BCT .VS>) NOBJ:STRING RES NRES
  92                (CH:<CHANNEL 'NETWORK> <VS-CHANNEL .VS>))
  93    <COND (<==? <ANDB <CALL TYPE .OBJ> *7*> 6>
  94           <COND (.LEN
  95                  <SET RES .LEN>
  96                  <SET LEN <* 4 .LEN>>)
  97                 (T
  98                  <SET RES <LENGTH .OBJ:<PRIMTYPE UVECTOR>>>
  99                  <SET LEN <* 4 .RES>>)>
 100           <SET NOBJ <CALL OBJECT <TYPE-C STRING>
 101                           <* 4 <LENGTH .OBJ:<PRIMTYPE UVECTOR>>>
 102                           <CALL VALUE .OBJ>>>)
 103          (T
 104           <COND (.LEN
 105                  <SET RES .LEN>)
 106                 (T
 107                  <SET RES <SET LEN <LENGTH .OBJ:<PRIMTYPE STRING>>>>)>
 108           <SET NOBJ <CHTYPE .OBJ:<PRIMTYPE STRING> STRING>>)>
 109    <COND (<AND <G? .LEN <LENGTH .BUF>> <NOT <0? .CT>>>
 110           <COND (<NOT <SET NRES <VSB-DUMP .VS>>>
 111                  <RETURN .NRES .ST>)>
 112           <SET BUF <VS-BUFFER .VS>>
 113           <SET CT 0>)>
 114    <COND (<G? .LEN <LENGTH .BUF>>
 115           <COND (<CHANNEL-OP .CH WRITE-BUFFER .NOBJ .LEN>
 116                  <COND (<AND <NOT .ALLOW-ODD?> <NOT <0? <MOD .LEN 4>>>>
 117                         <STUFF "   " <- 4 <MOD .LEN 4>> .VS T>)>
 118                  .RES)>)
 119          (T
 120           <SUBSTRUC .NOBJ 0 .LEN .BUF>
 121           <VS-BUFFER .VS <REST .BUF .LEN>>
 122           <VS-BCT .VS <+ .CT .LEN>>
 123           <COND (<AND <NOT .ALLOW-ODD?> <NOT <0? <MOD .LEN 4>>>>
 124                  <STUFF "   " <- 4 <MOD .LEN 4>> .VS T>)>
 125           .RES)>>
 126
 127 <DEFINE VSB-DUMP (VS:VS "AUX" (CHN:<CHANNEL 'NETWORK> <VS-CHANNEL .VS>)
 128                   (BUF:STRING <VS-BUFFER .VS>) (CT:FIX <VS-BCT .VS>))
 129    <COND (<G? .CT 0>
 130           <COND (<CHANNEL-OP .CHN WRITE-BUFFER <SET BUF <VS-BUFFER-TOP .VS>>
 131                              .CT>
 132                  <VS-BUFFER .VS .BUF>
 133                  <VS-BCT .VS 0>)>)
 134          (T)>>
 135
 136 <DEFINE VSB-WAIT (VS:VS "OPT" (RACT <>) (NOT-REALLY?:<OR ATOM FALSE> <>)
 137                   "AUX" (CH:<CHANNEL 'NETWORK> <VS-CHANNEL .VS>) (ANY? <>)
 138                   (P:UVECTOR ,RECEIVE-PACKET) (REQ <VS-REQ .VS>) CODE)
 139    <PROG (RES)
 140       <COND (.NOT-REALLY?
 141              <SET RES <AND <CHANNEL-OP .CH INPUT-WAITING>
 142                            <CHANNEL-OP .CH READ-BUFFER .P>>>)
 143             (T
 144              <SET RES <CHANNEL-OP .CH READ-BUFFER .P>>)>
 145       <COND
 146        (.RES
 147         <COND (<==? <SET CODE <VSI-CODE .P>> ,X-ERROR>
 148                ; "Error packet"
 149                <COND (<OR <NOT .RACT>
 150                           <N==? <I-LPAR0 .P> .REQ>>
 151                       ; "Out-of-band error"
 152                       <VSB-REPORT-ERROR .VS .P>
 153                       ; "Report, then try again"
 154                       <AGAIN>)
 155                      (T
 156                       ; "Error in response to request, so return it"
 157                       <CHTYPE (<VSERR-ERRCODE .P> <VSERR-REQCODE .P>
 158                                <NTH ,VS-ERRORS <VSERR-ERRCODE .P>>) FALSE>)>)
 159               (<==? .CODE ,X-REPLY>
 160                <COND (<NOT .RACT>
 161                       <AGAIN>)
 162                      (<==? .RACT ERROR>)
 163                      (<==? .RACT T> .P)
 164                      (<==? .RACT STRING>
 165                       <PROG ((LEN <I-SPAR0 .P>) ST:STRING)
 166                          <COND (<NOT <GASSIGNED? RANDOM-STRING>>
 167                                 <SET ST <SETG RANDOM-STRING <ISTRING .LEN>>>)
 168                                (<L? <LENGTH <SET ST ,RANDOM-STRING>> .LEN>
 169                                 <SET ST <SETG RANDOM-STRING <ISTRING .LEN>>>)
 170                                (<G? <LENGTH .ST> .LEN>
 171                                 <SET ST <REST .ST <- <LENGTH .ST> .LEN>>>)>
 172                          <CHANNEL-OP .CH READ-BUFFER .ST>
 173                          <COND (<NOT <0? <MOD .LEN 4>>>
 174                                 <CHANNEL-OP .CH READ-BUFFER ,GSTRING
 175                                             <- 4 <MOD .LEN 4>>>)>
 176                          .ST>)
 177                      (<==? .RACT 1> <I-LPAR0 .P>)
 178                      (T <I-SPAR0 .P>)>)
 179               (.RACT
 180                <PROCESS-EVENT .VS .P>
 181                <AGAIN>)
 182               (T
 183                <COND (<NOT <PROCESS-EVENT .VS .P>> <AGAIN>)
 184                      (T
 185                       <SET ANY? T>
 186                       ; "This hack enables optimization of mouse-moved events"
 187                       <COND (.NOT-REALLY? <AGAIN>)>)>)>)
 188        (<=? .RES #FALSE(4)>
 189         <AGAIN>)
 190        (.NOT-REALLY?
 191         .ANY?)
 192        (T
 193         <ERROR VS100-CONNECTION-DIED!-ERRORS .CH VSB-WAIT>
 194         <AGAIN>)>>>
 195
 196 <SETG GSTRING <ISTRING 3>>
 197
 198 <DEFINE VSB-REPORT-ERROR (VS:VS PACKET:UVECTOR)
 199    <COND (<TYPE? <INTERRUPT "VS-ERROR" .VS <VSERR-ERRCODE .PACKET>
 200                             <VSERR-REQCODE .PACKET>
 201                             <VSERR-REQNUM .PACKET>
 202                             <VSERR-REQFUNC .PACKET>
 203                             <OR <GET-WINDOW .VS <VSERR-WINDOW .PACKET>>
 204                                 <VSERR-WINDOW .PACKET>>>
 205                  DISMISS>)
 206          (T
 207           <ERROR RANDOM-ERROR-FROM-X!-ERRORS
 208                  <NTH ,VS-ERRORS <VSERR-ERRCODE .PACKET>>
 209                  <VSERR-REQCODE .PACKET>
 210                  <VSERR-REQNUM .PACKET>
 211                  <VSERR-REQFUNC .PACKET>
 212                  <OR <GET-WINDOW .VS <VSERR-WINDOW .PACKET>>
 213                      <VSERR-WINDOW .PACKET>>>)>>
 214 \f
 215 <GDECL (FREE-MOUSE-EVENTS) <LIST [REST MOUSE-EVENT]>
 216        (FREE-WINDOW-EVENTS) <LIST [REST WINDOW-EVENT]>
 217        (FREE-RECTANGLES) <LIST [REST WE-RECTANGLE]>>
 218 <COND (<NOT <GASSIGNED? FREE-MOUSE-EVENTS>>
 219        <SETG FREE-MOUSE-EVENTS ()>
 220        <SETG FREE-WINDOW-EVENTS ()>
 221        <SETG FREE-CELLS ()>
 222        <SETG FREE-RECTANGLES ()>)>
 223
 224 <DEFINE PROCESS-EVENT PE (VS:VS P:UVECTOR "AUX" WID:FIX (SW:ANY <>)
 225                        W:<OR VSCHAN FALSE> ML KIND:FIX (OUT <>) TL:<OR LIST FALSE>
 226                        ME:MOUSE-EVENT WE:WINDOW-EVENT MB:FIX VW:VSW NME
 227                        OWE:<OR WINDOW-EVENT FALSE>)
 228    <COND (<==? <SET KIND <VSI-CODE .P>> ,KEY-RELEASED>
 229           <RETURN <> .PE>)>
 230    <COND (<NOT <0? <SET WID <VSI-SUBWINDOW .P>>>>
 231           <COND (<NOT <SET W <GET-WINDOW .VS .WID>>>
 232                  <SET SW .WID>
 233                  <SET WID <VSI-WINDOW .P>>
 234                  <SET W <GET-WINDOW .VS .WID>>)>)
 235          (T
 236           <SET W <GET-WINDOW .VS <VSI-WINDOW .P>>>)>
 237    <COND
 238     (<AND .W
 239           <CHANNEL-OPEN? .W>
 240           <OR <N==? .W <VS-TOPCHAN .VS>>
 241               <AND <ASSIGNED? MOUSE-GRABBED?>
 242                    .MOUSE-GRABBED?>>>
 243      <COND
 244       (<AND .SW <NOT <EMPTY? <SET ML <VW-MENU-WINDS <CHANNEL-DATA .W>:VSW>>>>>
 245        <REPEAT ()
 246           <COND (<==? <MW-ID <1 .ML>> .SW>
 247                  <SET SW <1 .ML>>
 248                  <RETURN>)>
 249           <COND (<EMPTY? <SET ML <REST .ML>>> <RETURN>)>>)>
 250      <COND
 251       (<==? .KIND ,KEY-PRESSED>
 252        <COND
 253         (<SET OUT <TRANSLATE-KEY .VS
 254                                  <ANDB <VSI-DETAIL .P>
 255                                        %<XORB <ORB ,X-LEFT-MASK
 256                                                    ,X-MIDDLE-MASK
 257                                                    ,X-RIGHT-MASK>
 258                                               -1>>>>
 259          <COND (<EMPTY? <SET TL ,FREE-CELLS>>
 260                 <SET OUT (.OUT)>)
 261                (T
 262                 <SETG FREE-CELLS <REST .TL>>
 263                 <1 .TL .OUT>
 264                 <SET OUT .TL>
 265                 <PUTREST .TL ()>)>)
 266         (<RETURN <> .PE>)>)
 267       (<OR <==? .KIND ,BUTTON-PRESSED>
 268            <==? .KIND ,BUTTON-RELEASED>>
 269        <SET ME <NULL-MOUSE-EVENT>>
 270        <SET MB <ANDB <VSI-DETAIL .P> *377*>>
 271        <ME-KIND .ME <COND (<==? .KIND ,BUTTON-PRESSED>
 272                            <COND (<0? .MB> ,ME-RIGHT-PRESSED)
 273                                  (<1? .MB> ,ME-MIDDLE-PRESSED)
 274                                  (T ,ME-LEFT-PRESSED)>)
 275                           (<0? .MB>
 276                            ,ME-RIGHT-RELEASED)
 277                           (<1? .MB>
 278                            ,ME-MIDDLE-RELEASED)
 279                           (T ,ME-LEFT-RELEASED)>>
 280        <ME-STATE .ME <LSH <VSI-DETAIL .P> -8>>
 281        <ME-X .ME <VSI-X .P>>
 282        <ME-Y .ME <VSI-Y .P>>
 283        <ME-TIME .ME <VSI-TIME .P>>
 284        <ME-WINDOW .ME .W>
 285        <ME-SUBWINDOW .ME .SW>
 286        <ME-LOCATOR .ME <I-LPAR4 .P>>
 287        <VS-LAST-MOUSE .VS .ME>
 288        <SET OUT <1 <ME-CELL .ME> .ME>>)
 289       (<AND <==? .KIND ,MOUSE-MOVED>
 290             <SET NME <VS-LAST-MOUSE .VS>>
 291             <==? <ME-KIND .NME> ,ME-MOVED>>
 292        <ME-X .NME <VSI-X .P>>
 293        <ME-Y .NME <VSI-Y .P>>)
 294       (<OR <==? .KIND ,MOUSE-MOVED>
 295            <==? .KIND ,ENTER-WINDOW>
 296            <==? .KIND ,LEAVE-WINDOW>>
 297        <COND (<==? <ANDB <VSI-DETAIL .P> *377*> 2>
 298               ; "Intermediate event when moving around hierarchy"
 299               <RETURN <> .PE>)>
 300        <SET ME <NULL-MOUSE-EVENT>>
 301        <ME-KIND .ME <COND (<==? .KIND ,MOUSE-MOVED>
 302                            ,ME-MOVED)
 303                           (<==? .KIND ,ENTER-WINDOW>
 304                            ,ME-ENTER-WINDOW)
 305                           (T
 306                            ,ME-LEAVE-WINDOW)>>
 307        <ME-STATE .ME <LSH <VSI-DETAIL .P> -8>>
 308        <ME-X .ME <VSI-X .P>>
 309        <ME-Y .ME <VSI-Y .P>>
 310        <ME-TIME .ME <VSI-TIME .P>>
 311        <ME-WINDOW .ME .W>
 312        <ME-SUBWINDOW .ME .SW>
 313        <ME-LOCATOR .ME <I-LPAR4 .P>>
 314        <VS-LAST-MOUSE .VS .ME>
 315        <SET OUT <1 <ME-CELL .ME> .ME>>)
 316       (<==? .KIND ,UNMAP-WINDOW>
 317        <SET WE <NULL-WINDOW-EVENT>>
 318        <WE-KIND .WE ,WE-UNMAP-WINDOW>
 319        <WE-WINDOW .WE .W>
 320        <WE-SUBWINDOW .WE .SW>
 321        <VW-REDISPLAY <CHANNEL-DATA .W:CHANNEL>:VSW <>>
 322        <ADD-CHANGE .WE 0 0 0 0>
 323        <SET OUT <1 <WE-CELL .WE> .WE>>)
 324       (<AND <OR <==? .KIND ,EXPOSE-WINDOW>
 325                 <==? .KIND ,EXPOSE-REGION>
 326                 <==? .KIND ,EXPOSE-COPY>>
 327             <N==? .W <VS-TOPCHAN .VS>>>
 328        <COND (<COND (<AND <TYPE? .SW MENU-WINDOW>
 329                           <TEST-VW-MODE <MW-BITS .SW> ,VWM-UNSEEN>>
 330                      <MW-BITS .SW <ANDB <MW-BITS .SW>
 331                                         <XORB ,VWM-UNSEEN -1>>>)
 332                     (<AND .W
 333                           <SET VW <CHANNEL-DATA .W:VSCHAN>>
 334                           <TEST-VW-MODE <VW-OUTMODE .VW> ,VWM-UNSEEN>>
 335                      <VW-OUTMODE .VW <ANDB <VW-OUTMODE .VW>
 336                                            <XORB ,VWM-UNSEEN -1>>>)>
 337               ; "Discard exposed events for new windows..."
 338               <RETURN <> .PE>)>
 339        <COND (<NOT <SET OWE <VW-REDISPLAY <SET VW <CHANNEL-DATA .W>>>>>
 340               <SET WE <NULL-WINDOW-EVENT>>)
 341              (T
 342               <SET WE .OWE>)>
 343        <COND (<==? .KIND ,EXPOSE-WINDOW>
 344               <COND (.OWE
 345                      ; "If full redisplay, we can nuke previous saved
 346                         events"
 347                      <VW-REDISPLAY .VW <>>
 348                      <RECYCLE-RECTANGLES <WE-CHANGES .OWE>>
 349                      <WE-CHANGES .OWE ()>)>
 350               <COND (<OR <N==? <I-SPAR4 .P> <VW-WIDTH .VW>>
 351                          <N==? <I-SPAR5 .P> <VW-HEIGHT .VW>>>
 352                      <SET KIND ,WE-RESIZE-WINDOW>
 353                      <WE-OLDH .WE <VW-HEIGHT .VW>>
 354                      <WE-OLDW .WE <VW-WIDTH .VW>>
 355                      <VW-WIDTH .VW <I-SPAR4 .P>>
 356                      <VW-HEIGHT .VW <I-SPAR5 .P>>)
 357                     (T
 358                      <SET KIND ,WE-EXPOSE-WINDOW>)>
 359               <ADD-CHANGE .WE 0 0 <VW-WIDTH .VW> <VW-HEIGHT .VW>>)
 360              (<==? .KIND ,EXPOSE-COPY>
 361               <SET KIND ,WE-EXPOSE-COPY>
 362               <COND (.OWE
 363                      <VW-REDISPLAY .VW <>>
 364                      <SET WE <NULL-WINDOW-EVENT>>)>
 365               <ADD-CHANGE .WE <I-SPAR8 .P> <I-SPAR9 .P>
 366                           <I-SPAR4 .P> <I-SPAR5 .P>>)
 367              (T
 368               <SET KIND ,WE-EXPOSE-REGION>
 369               ; "Remember this guy in case we need to catch some events later"
 370               <VW-REDISPLAY .VW .WE>
 371               <ADD-CHANGE .WE <I-SPAR8 .P> <I-SPAR9 .P>
 372                           <I-SPAR4 .P> <I-SPAR5 .P>>)>
 373        <COND (.OWE
 374               ; "This event is already on the queue, so don't return it"
 375               <WE-KIND .OWE .KIND>
 376               <SET OUT <>>)
 377              (T
 378               <WE-KIND .WE .KIND>
 379               <WE-WINDOW .WE .W>
 380               <WE-SUBWINDOW .WE .SW>
 381               <SET OUT <1 <WE-CELL .WE> .WE>>)>)>
 382      <COND (.OUT
 383             <COND (<EMPTY? <SET TL <VS-ILIST .VS>>>
 384                    <VS-IBUFFER .VS .OUT>
 385                    <VS-ILIST .VS .OUT>)
 386                   (T
 387                    <PUTREST .TL .OUT>
 388                    <VS-ILIST .VS <REST .TL>>)>)>)>>
 389
 390 <DEFINE ADD-CHANGE (WE:WINDOW-EVENT TOP:FIX LEFT:FIX WIDTH:FIX HEIGHT:FIX
 391                     "AUX" (L:LIST <WE-CHANGES .WE>) (LL:LIST ,FREE-RECTANGLES)
 392                     REC:WE-RECTANGLE CELL:LIST)
 393    <COND (<EMPTY? .LL>
 394           <SET CELL
 395                (<SET REC <CHTYPE <UVECTOR
 396                                   .TOP .LEFT .WIDTH .HEIGHT>
 397                                  WE-RECTANGLE>>)>)
 398          (T
 399           <SET CELL .LL>
 400           <SETG FREE-RECTANGLES <REST .LL>>
 401           <PUTREST .CELL ()>
 402           <REC-TOP <SET REC <1 .CELL>> .TOP>
 403           <REC-LEFT .REC .LEFT>
 404           <REC-WIDTH .REC .WIDTH>
 405           <REC-HEIGHT .REC .HEIGHT>)>
 406    <WE-CHANGES .WE <PUTREST .CELL .L>>>
 407
 408 <DEFINE RECYCLE-RECTANGLES (L:LIST)
 409    <COND (<NOT <EMPTY? .L>>
 410           <PUTREST <REST .L <- <LENGTH .L> 1>> ,FREE-RECTANGLES>
 411           <SETG FREE-RECTANGLES .L>)>>
 412
 413 <DEFINE ANY-INPUT? (VS:VS)
 414    <OR <NOT <EMPTY? <VS-IBUFFER .VS>>>
 415        <CHANNEL-OP <VS-CHANNEL .VS> INPUT-WAITING>>>
 416
 417 <DEFINE GET-WINDOW (VS:VS WID:FIX "VALUE" <OR VSCHAN FALSE>)
 418   <REPEAT ((L:<LIST [REST FIX VSCHAN]> <VS-ALL .VS>))
 419      <COND (<EMPTY? .L> <RETURN <>>)>
 420      <COND (<==? <1 .L> .WID> <RETURN <2 .L>>)>
 421      <SET L <REST .L 2>>>>
 422
 423 <DEFINE GET-EVENT (VS:VS "OPT" (WAIT?:<OR ATOM FALSE> T)
 424                    "AUX" L TL (W:<OR VSCHAN FALSE> <>) FROB TCHN VW:VSW)
 425    <PROG ()
 426       <COND (<EMPTY? <SET L <VS-IBUFFER .VS>>>
 427              <COND (.WAIT?
 428                     <VSB-DUMP .VS>
 429                     <VSB-WAIT .VS <>>
 430                     <SET L <VS-IBUFFER .VS>>)
 431                    (<NOT <VSB-WAIT .VS <> T>>
 432                     <RETURN <>>)
 433                    (T
 434                     <SET L <VS-IBUFFER .VS>>)>)>
 435       <VS-IBUFFER .VS <SET TL <REST .L>>>
 436       <COND (<EMPTY? .TL>
 437              <VS-ILIST .VS .TL>)>
 438       <COND (<TYPE? <SET FROB <1 .L>> FIX CHARACTER>
 439              <SETG FREE-CELLS <PUTREST .L ,FREE-CELLS>>
 440              .FROB)
 441             (<TYPE? .FROB MOUSE-EVENT>
 442              <COND (<AND <==? <ME-KIND .FROB> ,ME-MOVED>
 443                          <==? .FROB <VS-LAST-MOUSE .VS>>>
 444                     <VSB-WAIT .VS <> T>)>
 445              <COND (<==? .FROB <VS-LAST-MOUSE .VS>>
 446                     <VS-LAST-MOUSE .VS <>>)>
 447              <COND (<CHANNEL-OPEN? <ME-WINDOW .FROB>>
 448                     <ME-CELL .FROB <1 .L 1>>)
 449                    (T
 450                     <1 <SETG FREE-MOUSE-EVENTS
 451                              <PUTREST <ME-CELL .FROB> ,FREE-MOUSE-EVENTS>>
 452                        .FROB>
 453                     <AGAIN>)>)
 454             (<TYPE? .FROB WINDOW-EVENT>
 455              <COND (<CHANNEL-OPEN? <SET TCHN <WE-WINDOW .FROB>>>
 456                     <COND (<VW-REAL <SET VW <CHANNEL-DATA .TCHN:CHANNEL>>:VSW>
 457                            ; "Handle window events for icons"
 458                            <CHANNEL-OP .TCHN:VSCHAN REDISPLAY-ICON>
 459                            <VW-REDISPLAY .VW <>>
 460                            <1 <SETG FREE-WINDOW-EVENTS
 461                                     <PUTREST <WE-CELL .FROB>
 462                                              ,FREE-WINDOW-EVENTS>>
 463                               .FROB>
 464                            <RECYCLE-RECTANGLES <WE-CHANGES .FROB>>
 465                            <AGAIN>)>
 466                     <COND (<==? <VW-REDISPLAY .VW>
 467                                 .FROB>
 468                            <VSB-WAIT .VS <> T>
 469                            <VW-REDISPLAY .VW <>>)>
 470                     <WE-CELL .FROB <1 .L 1>>)
 471                    (T
 472                     <RECYCLE-RECTANGLES <WE-CHANGES .FROB>>
 473                     <1 <SETG FREE-WINDOW-EVENTS
 474                              <PUTREST <WE-CELL .FROB> ,FREE-WINDOW-EVENTS>>
 475                        .FROB>
 476                     <AGAIN>)>)>
 477       .FROB>>
 478
 479 <DEFINE NULL-MOUSE-EVENT ("AUX" (L:LIST ,FREE-MOUSE-EVENTS) ME:MOUSE-EVENT)
 480    <COND (<EMPTY? .L>
 481           <CHTYPE [0 0 0 0 0 ,OUTCHAN <> 0 (1)] MOUSE-EVENT>)
 482          (T
 483           <SET ME <1 .L>>
 484           <ME-CELL .ME <1 .L 1>>
 485           <SETG FREE-MOUSE-EVENTS <REST .L>>
 486           <PUTREST .L ()>
 487           .ME)>>
 488
 489 <DEFINE NULL-WINDOW-EVENT ("AUX" (L:LIST ,FREE-WINDOW-EVENTS) WE:WINDOW-EVENT)
 490    <COND (<EMPTY? .L>
 491           <CHTYPE [0 ,OUTCHAN 0 () (1) 0 0] WINDOW-EVENT>)
 492          (T
 493           <SET WE <1 .L>>
 494           <WE-CELL .WE <1 .L 1>>
 495           <SETG FREE-WINDOW-EVENTS <REST .L>>
 496           <PUTREST .L ()>
 497           .WE)>>
 498
 499 <DEFINE TRANSLATE-KEY (VS:VS DETAIL:FIX "AUX" (KEYNO:FIX <ANDB .DETAIL 255>)
 500                        (MAPS:<OR VECTOR FALSE> <VS-MAPS .VS>)
 501                        MAP KEY:<OR KEY FALSE> NUM:FIX)
 502    <COND (<NOT .MAPS> <>)
 503          (<AND <G=? .KEYNO ,KEY-MIN-SHIFT>
 504                <L=? .KEYNO ,KEY-MAX-SHIFT>>
 505           ; "Throw away shift key events"
 506           <>)
 507          (T
 508           <COND (<AND <G=? .KEYNO ,KEY-MIN-NORM>
 509                       <L=? .KEYNO ,KEY-MAX-NORM>>
 510                  <SET MAP <1 .MAPS>>)
 511                 (T
 512                  <SET MAP <2 .MAPS>>)>
 513           <SET KEYNO <- .KEYNO <1 .MAP> -1>>
 514           <COND
 515            (<AND <L=? .KEYNO <LENGTH <2 .MAP>:VECTOR>>
 516                  <SET KEY <NTH <2 .MAP>:VECTOR .KEYNO>>>
 517             <COND (<NOT <0? <ANDB .DETAIL ,X-CONTROL-MASK>>>
 518                    <COND (<NOT <0? <ANDB .DETAIL ,X-SHIFT-MASK>>>
 519                           <SET NUM <KD-CS .KEY>>)
 520                          (T
 521                           <SET NUM <KD-CTRL .KEY>>)>)
 522                   (<NOT <0? <ANDB .DETAIL ,X-SHIFT-MASK>>>
 523                    <SET NUM <KD-SHIFT .KEY>>)
 524                   (<NOT <0? <ANDB .DETAIL ,X-SHIFT-LOCK-MASK>>>
 525                    <SET NUM <KD-LOCK .KEY>>)
 526                   (T
 527                    <SET NUM <KD-NORM .KEY>>)>
 528             <COND (<G=? .NUM 0> <CHTYPE .NUM CHARACTER>)
 529                   (T <- .NUM>)>)>)>>
 530
 531 <ENDPACKAGE>