mim/development/mim/vax/vs/vsops.mud

   1 <DEFINITIONS "VSOPS">
   2
   3 <INCLUDE "VSDEFS" "VSTYPES">
   4
   5 <USE "NEWSTRUC" "VSBASE">
   6
   7 <GDECL (OPLIST) <LIST [REST ATOM OP]>>
   8
   9 <NEWSTRUC OP VECTOR
  10           OP-NAME ATOM
  11           OP-CODE FIX
  12           OP-REPLY? <OR ATOM FALSE>
  13           OP-ARGS <VECTOR [REST ANY]>
  14           OP-STUFF? <OR ATOM FALSE>
  15           OP-FORCE? <OR ATOM FALSE>>
  16
  17 <SETG OPLIST ()>
  18
  19 <DEFINE COP ("TUPLE" STUFF "AUX" (REPLY?:<SPECIAL ATOM> STRING))
  20    <OP !.STUFF>>
  21
  22 <DEFINE FOP ("TUPLE" STUFF "AUX" (FORCE?:<SPECIAL ATOM> T))
  23    <OP !.STUFF>>
  24
  25 <DEFINE SOP (NAME CODE REPLY?:<SPECIAL ATOM> "TUPLE" STUFF)
  26    <OP .NAME .CODE !.STUFF>>
  27
  28 <DEFINE ROP ("TUPLE" STUFF "AUX" (REPLY?:<SPECIAL ATOM> T))
  29    <OP !.STUFF>>
  30
  31 <MSETG ARG-FUNC 1>
  32 <MSETG ARG-WINDOW 2>
  33 <NEWTYPE LONG FIX>
  34 <NEWTYPE SHORT FIX>
  35 <NEWTYPE BYTE FIX>
  36 <NEWTYPE COUNT-STRING FIX>
  37 <NEWTYPE COUNT FIX>
  38 <MSETG SEND-PACKET-WORD-LENGTH 6>
  39
  40 <DEFINE OP (NAME CODE "TUPLE" ARGDESC "AUX" (REPLY? <AND <ASSIGNED? REPLY?>
  41                                                          .REPLY?>)
  42             (FORCE? <AND <ASSIGNED? FORCE?> .FORCE?>)
  43             (SCT 0) (STUFF? <>) (STYPE <>) AVEC)
  44   <MSETG .NAME .CODE>
  45   <SET AVEC
  46        <MAPF ,VECTOR
  47         <FUNCTION (X "AUX" NUM)
  48            <COND (<==? .X F>
  49                   ,ARG-FUNC)
  50                  (<==? .X W>
  51                   ,ARG-WINDOW)
  52                  (<MEMQ .X '[B S L CS CB]>
  53                   <COND (<==? .X L>
  54                          <COND (<NOT <0? <MOD .SCT 4>>>
  55                                 <SET SCT <* </ <+ .SCT 4> 4> 4>>)>
  56                          <SET NUM <CHTYPE </ .SCT 4> LONG>>
  57                          <SET SCT <+ .SCT 4>>)
  58                         (<==? .X B>
  59                          <SET NUM <CHTYPE .SCT BYTE>>
  60                          <SET SCT <+ .SCT 1>>)
  61                         (T
  62                          <COND (<NOT <0? <MOD .SCT 2>>>
  63                                 <SET SCT <+ .SCT 1>>)>
  64                          <SET NUM <CHTYPE </ .SCT 2> SHORT>>
  65                          <SET SCT <+ .SCT 2>>)>
  66                   <COND (<MEMQ .X '[CS CB]>
  67                          <COND (<==? .X CS>
  68                                 <SET NUM <CHTYPE .NUM COUNT-STRING>>)
  69                                (T
  70                                 <SET NUM <CHTYPE .NUM COUNT>>)>
  71                          <SET STUFF? T>)>
  72                   .NUM)
  73                  (<==? .X STUFF>
  74                   <SET STUFF? T>
  75                   <MAPRET>)>>
  76         .ARGDESC>>
  77   <SETG OPLIST (.NAME <CHTYPE [.NAME .CODE .REPLY? .AVEC .STUFF? .FORCE?] OP>
  78                 !,OPLIST)>>
  79
  80 <COND
  81  (<GASSIGNED? OP>
  82   <SOP X-OPEN-WINDOW 1 LONG F W S S S S L L>
  83   <FOP X-MAP-WINDOW 2 W>
  84   <FOP X-UNMAP-WINDOW 3 W>
  85   <FOP X-MOVE-WINDOW 4 W S S>
  86   <FOP X-CHANGE-WINDOW 5 W S S>
  87   <FOP X-DESTROY-WINDOW 6 W>
  88   <ROP X-QUERY-WINDOW 7 W>
  89   <FOP X-RAISE-WINDOW 8 W>
  90   <FOP X-LOWER-WINDOW 9 W>
  91   <FOP X-CIRC-WINDOW 10 W>
  92   <FOP X-DESTROY-SUBWINDOWS 11 W>
  93   <FOP X-CHANGE-COLOR 12 W L L>
  94   <FOP X-CONFIGURE-WINDOW 13 W S S S S>
  95   <SOP X-OPEN-TRANSPARENCY 14 LONG W S S S S>
  96   <OP X-STORE-NAME 15 W CS>
  97   <COP X-FETCH-NAME 16 W>
  98   <OP X-SET-RESIZE-HINT 17 W S S S S>
  99   <ROP X-GET-RESIZE-HINT 18 W>
 100   <OP X-UNMAP-TRANSPARENT 19 W>
 101   <FOP X-REGISTER-CURSOR 30 F W L L B B B B>
 102   <FOP X-UNREGISTER-CURSOR 31 W>
 103   <ROP X-QUERY-MOUSE 32 W>
 104   <FOP X-SELECT-INPUT 50 F W>
 105   <ROP X-INTERPRET-LOCATOR 51 W L>
 106   <SOP X-GRAB-MOUSE 53 ERROR F W L L B B B B S>
 107   <SOP X-FOCUS-KEYBOARD 54 ERROR W>
 108   <FOP X-WARP-MOUSE 55 W S S>
 109   <ROP X-GRAB-BUTTON 56 ERROR F W L L B B B B S S>
 110   <OP X-CLEAR 70 W>
 111   <OP X-RASTER-FILL 71 F W S S S S>
 112   <OP X-RASTER-PUT 72 F W S S S S L>
 113   <OP X-RASTER-PATTERN 73 F W S S S S L>
 114   <OP X-RASTER-COPY 74 F W S S S S S S S S>
 115   <OP X-LINE 75 F W S S S S>
 116   <OP X-DRAW 76 F W S STUFF>
 117   <OP X-TEXT 77 F W S S L CB>
 118   <OP X-CLIPMODE 78 F W>
 119   <OP X-FEEP 79 F W>
 120   <OP X-DRAW-DASHED 80 F W S S S S STUFF>
 121   <OP X-BITS-PUT 81 F W S S S S STUFF>
 122   <SOP X-RASTER-SAVE 82 LONG W S S S S>
 123   <OP X-DRAW-FILLED 83 F W S L STUFF>
 124   <ROP X-SETUP 90 W>
 125   <SOP X-GET-FONT 91 LONG F W STUFF>
 126   <ROP X-QUERY-FONT 92 W L>
 127   <OP X-FREE-FONT 93 W L>
 128   <SOP X-STORE-RASTER 94 LONG W S S STUFF>
 129   <SOP X-STORE-PATTERN 95 LONG W STUFF>
 130   <OP X-FREE-RASTER 96 W L>
 131   <OP X-FREE-PATTERN 97 W L>
 132   <ROP X-TEXTWIDTH 98 W L S S S S S S>
 133   <FOP X-SHIFT-LOCK 99 W F>
 134   <FOP X-UNGRAB-MOUSE 100 W>
 135   <SOP X-STRING-WIDTH 101 SHORT W L CB>
 136   <FOP X-KEY-CLICK 102 W F>
 137   <FOP X-AUTO-REPEAT 103 W F>
 138   <FOP X-UNGRAB-BUTTON 104 W S>
 139   <FOP X-STORE-BYTES 105 W F CS>
 140   <COP X-FETCH-BYTES 106 W F>
 141   <OP X-ADD-HOST 107 W L>
 142   <OP X-REMOVE-HOST 108 W L>
 143   <COP X-CHAR-WIDTHS 109 W L>)>
 144
 145 <DEFMAC VSOP ('VS100 NAME "ARGS" ARGS "AUX" L OD ALIST AAL
 146               (COUNTER <>) (ARGL .ARGS) (FARGL <>) (AUXL ())
 147               RES (VALDECL <>) REPLY?)
 148   <COND (<SET L <MEMQ .NAME ,OPLIST>>
 149          <SET OD <2 .L>>
 150          <SET ALIST (<FORM O-FUNC&CODE '.PACKET <OP-CODE .OD>>)>
 151          <SET AAL .ALIST>
 152          <REPEAT ((ADESC <OP-ARGS .OD>) D TEMP)
 153             <COND (<EMPTY? .ADESC>
 154                    <COND (<AND <NOT <OP-STUFF? .OD>>
 155                                <NOT <EMPTY? .ARGL>>>
 156                           <ERROR TOO-MANY-ARGUMENTS-TO-VSOP .NAME .OD
 157                                  .ARGS>)>
 158                    <RETURN>)>
 159             <COND (<EMPTY? .ARGL>
 160                    <ERROR TOO-FEW-ARGUMENTS-TO-VSOP .NAME .OD .ARGS>)>
 161             <COND (<TYPE? <SET D <1 .ADESC>> FIX>
 162                    <COND (<==? .D ,ARG-FUNC>
 163                           <1 .ALIST
 164                              <FORM O-FUNC&CODE '.PACKET
 165                                    <COMBINE <OP-CODE .OD> <1 .ARGL>>>>)
 166                          (<==? .D ,ARG-WINDOW>
 167                           <SET AAL <REST <PUTREST .AAL
 168                                                   (<FORM O-WINDOW '.PACKET
 169                                                          <1 .ARGL>>)>>>)
 170                          (T
 171                           <ERROR BAD-VSOP-DESCRIPTOR .OD .D>)>)
 172                   (<TYPE? .D LONG>
 173                    <SET AAL <REST <PUTREST .AAL
 174                                            (<FORM <NTH ,LONGS
 175                                                        <+ <CHTYPE .D FIX> 1>>
 176                                                   '.PACKET
 177                                                   <1 .ARGL>>)>>>)
 178                   (<TYPE? .D SHORT>
 179                    <COND (<AND <0? <MOD <CHTYPE .D FIX> 2>>
 180                                <NOT <EMPTY? <REST .ADESC>>>
 181                                <NOT <EMPTY? <REST .ARGL>>>
 182                                <TYPE? <2 .ADESC> SHORT>>
 183                           <SET AAL
 184                                <REST
 185                                 <PUTREST .AAL
 186                                          (<FORM <NTH ,LONGS
 187                                                      <+ </ <CHTYPE .D FIX> 2>
 188                                                         1>>
 189                                                 '.PACKET
 190                                                 <COMBINE <1 .ARGL> <2 .ARGL>>>)>>>
 191                           <SET ARGL <REST .ARGL>>
 192                           <SET ADESC <REST .ADESC>>)
 193                          (T
 194                           <SET AAL
 195                                <REST
 196                                 <PUTREST .AAL
 197                                          (<FORM <NTH ,SHORTS
 198                                                      <+ <CHTYPE .D FIX> 1>>
 199                                                 '.PACKET
 200                                                 <1 .ARGL>>)>>>)>)
 201                   (<TYPE? .D BYTE>
 202                    <PROG ((OFFS <TUPLE .D <> <> <>>)
 203                           (ARGS <TUPLE <1 .ARGL> <> <> <>>) (CCT 1))
 204                       <COND (<AND <0? <MOD <CHTYPE .D FIX> 4>>
 205                                   <NOT <EMPTY? <REST .ADESC>>>
 206                                   <NOT <EMPTY? <REST .ARGL>>>
 207                                   <TYPE? <2 .ADESC> SHORT BYTE>>
 208                              <SET CCT 2>
 209                              <2 .OFFS <2 .ADESC>>
 210                              <2 .ARGS <2 .ARGL>>
 211                              <COND (<AND <TYPE? <2 .ADESC> BYTE>
 212                                          <NOT <EMPTY? <REST .ADESC 2>>>
 213                                          <NOT <EMPTY? <REST .ARGL 2>>>
 214                                          <TYPE? <3 .ADESC> SHORT BYTE>>
 215                                     <SET CCT 3>
 216                                     <3 .OFFS <3 .ADESC>>
 217                                     <3 .ARGS <3 .ARGL>>
 218                                     <COND (<AND <TYPE? <3 .ADESC> BYTE>
 219                                                 <NOT <EMPTY? <REST .ADESC 3>>>
 220                                                 <NOT <EMPTY? <REST .ARGL 3>>>
 221                                                 <TYPE? <4 .ADESC> BYTE>>
 222                                            <SET CCT 4>
 223                                            <4 .OFFS <4 .ADESC>>
 224                                            <4 .ARGS <4 .ARGL>>)>)>)
 225                             (<AND <0? <MOD <CHTYPE .D FIX> 2>>
 226                                   <NOT <EMPTY? <REST .ADESC>>>
 227                                   <NOT <EMPTY? <REST .ARGL>>>
 228                                   <TYPE? <2 .ADESC> BYTE>>
 229                              <2 .OFFS <2 .ADESC>>
 230                              <2 .ARGS <2 .ARGL>>
 231                              <SET CCT 2>)>
 232                       <COND (<1? .CCT>
 233                              <SET AAL <REST
 234                                        <PUTREST .AAL
 235                                                 (<FORM <NTH ,BYTE-MACS
 236                                                             <+ <CHTYPE .D FIX> 1>>
 237                                                        '.PACKET
 238                                                        <1 .ARGL>>)>>>)
 239                             (T
 240                              <SET AAL
 241                                   <REST
 242                                    <PUTREST .AAL
 243                                             (<COMBINE-HAIRY .OFFS .ARGS .CCT
 244                                                             <NTH ,SHORTS
 245                                                                  <+
 246                                                                   </ <CHTYPE .D FIX>
 247                                                                      2> 1>>
 248                                                             <NTH ,LONGS
 249                                                                  <+
 250                                                                   </ <CHTYPE .D FIX>
 251                                                                      4> 1>>>)>>>
 252                              <SET ARGL <REST .ARGL <- .CCT 1>>>
 253                              <SET ADESC <REST .ADESC <- .CCT 1>>>)>>)
 254                   (<TYPE? .D COUNT COUNT-STRING>
 255                    <SET COUNTER (.D <1 .ARGL>)>)
 256                   (T
 257                    <ERROR BAD-DESCRIPTOR .OD>)>
 258             <SET ARGL <REST .ARGL>>
 259             <SET ADESC <REST .ADESC>>>
 260          <COND (<==? <OP-REPLY? .OD> T>
 261                 <SET VALDECL '<OR FALSE UVECTOR>>
 262                 <SET REPLY? T>)
 263                (<==? <OP-REPLY? .OD> ERROR>
 264                 <SET VALDECL '<OR ATOM FALSE>>
 265                 <SET REPLY? ERROR>)
 266                (<==? <OP-REPLY? .OD> STRING>
 267                 <SET VALDECL '<OR STRING FALSE>>
 268                 <SET REPLY? STRING>)
 269                (<OP-REPLY? .OD>
 270                 <SET VALDECL '<OR FIX FALSE>>
 271                 <COND (<==? <OP-REPLY? .OD> LONG>
 272                        <SET REPLY? 1>)
 273                       (T
 274                        <SET REPLY? 2>)>)
 275                (T
 276                 <SET REPLY? <>>)>
 277          <COND (<NOT .COUNTER>
 278                 <COND (<==? <LENGTH .ARGL> 1>
 279                        <COND (<TYPE? <1 .ARGL> STRING UVECTOR>
 280                               <SET ARGL (<1 .ARGL> <LENGTH <1 .ARGL>>)>)
 281                              (T
 282                               <SET FARGL <1 .ARGL>>
 283                               <SET ARGL ('.FROB <FORM LENGTH '.FROB>)>)>)>
 284                 <SET AUXL (('PACKET:UVECTOR ',SEND-PACKET))>
 285                 <COND (.FARGL
 286                        <SET AUXL ((FROB .FARGL) !.AUXL)>)>
 287                 <SET RES
 288                    <FORM BIND .AUXL
 289                       !.ALIST
 290                       <FORM VSB-SEND .VS100 <COND (.REPLY? T)
 291                                                 (T
 292                                                  <OP-FORCE? .OD>)>
 293                             .REPLY? '.PACKET ,SEND-PACKET-WORD-LENGTH
 294                             !.ARGL>>>)
 295                (T
 296                 <SET AUXL (('PACKET:UVECTOR ',SEND-PACKET))>
 297                 <SET RES
 298                    <FORM BIND .AUXL
 299                       !.ALIST
 300                       <FORM <NTH ,SHORTS
 301                                  <+ <CHTYPE <1 .COUNTER> FIX> 1>>
 302                             '.PACKET
 303                             <2 .COUNTER>>
 304                       <FORM VSB-SEND .VS100
 305                             <COND (.REPLY? T)
 306                                   (T <OP-FORCE? .OD>)>
 307                             .REPLY?
 308                             '.PACKET ,SEND-PACKET-WORD-LENGTH
 309                             !<COND (<==? <LENGTH .ARGL> 1>
 310                                     (<1 .ARGL> <2 .COUNTER>))
 311                                    (T .ARGL)>>>>)>
 312          <COND (.VALDECL <CHTYPE [.RES .VALDECL] ADECL>)
 313                (T .RES)>)
 314         (T
 315          <ERROR NO-SUCH-VSOP!-ERRORS .NAME VSOP>)>>
 316
 317 <DEFINE COMBINE-HAIRY (OFFS:<PRIMTYPE VECTOR> ARGS:<PRIMTYPE VECTOR> CCT:FIX
 318                        SMAC LMAC)
 319    <SET OFFS <SUBSTRUC .OFFS 0 .CCT <REST .OFFS <- <LENGTH .OFFS> .CCT>>>>
 320    <SET ARGS <SUBSTRUC .ARGS 0 .CCT <REST .ARGS <- <LENGTH .ARGS> .CCT>>>>
 321    <MAPR <>
 322          <FUNCTION (V)
 323             <1 .V <REDUCE <1 .V>>>>
 324          .ARGS>
 325    <COND (<AND <TYPE? <1 .OFFS> BYTE>
 326                <TYPE? <2 .OFFS> SHORT>>
 327           <1 .OFFS <CHTYPE </ <CHTYPE <1 .OFFS> FIX> 2> SHORT>>
 328           <FORM .LMAC '.PACKET <COMBINE <1 .ARGS> <2 .ARGS>>>)
 329          (<==? .CCT 2>
 330           <FORM .SMAC '.PACKET <COMBINE-BYTES <1 .ARGS> <2 .ARGS>>>)
 331          (<==? .CCT 3>
 332           <COND (<TYPE? <3 .OFFS> SHORT>
 333                  <FORM .LMAC '.PACKET <COMBINE <COMBINE-BYTES <1 .ARGS>
 334                                                               <2 .ARGS>>
 335                                                <3 .ARGS>>>)
 336                 (T
 337                  <FORM .LMAC '.PACKET <COMBINE <COMBINE-BYTES <1 .ARGS>
 338                                                               <2 .ARGS>>
 339                                                <COMBINE-BYTES <3 .ARGS> 0>>>)>)
 340          (T
 341           <FORM .LMAC '.PACKET <COMBINE <COMBINE-BYTES <1 .ARGS> <2 .ARGS>>
 342                                         <COMBINE-BYTES <3 .ARGS> <4 .ARGS>>>>)>>
 343
 344 <DEFINE COMBINE-BYTES (X Y)
 345    <COND (<AND <TYPE? .X FIX>
 346                <TYPE? .Y FIX>>
 347           <PUTBITS .X <BITS 8 8> .Y>)
 348          (<AND <TYPE? .Y FIX>
 349                <0? .Y>>
 350           .X)
 351          (<AND <TYPE? .X FIX>
 352                <0? .X>>
 353           <FORM LSH .X 8>)
 354          (T
 355           <FORM PUTBITS .X <BITS 8 8> .Y>)>>
 356
 357 <DEFINE COMBINE (X Y)
 358    <SET X <REDUCE .X>>
 359    <SET Y <REDUCE .Y>>
 360    <COND (<AND <TYPE? .X FIX>
 361                <TYPE? .Y FIX>>
 362           <PUTLHW .X .Y>)
 363          (<AND <TYPE? .Y FIX>
 364                <0? .Y>>
 365           .X)
 366          (T
 367           <FORM PUTLHW .X .Y>)>>
 368
 369 <DEFINE REDUCE (X)
 370    <COND (<TYPE? .X FIX> .X)
 371          (T
 372           <COND (<TYPE? .X GVAL>)
 373                 (<AND <TYPE? .X FORM>
 374                       <==? <LENGTH .X> 2>
 375                       <==? <1 .X> GVAL>
 376                       <TYPE? <2 .X> ATOM>>
 377                  <SET X <CHTYPE <2 .X> GVAL>>)>
 378           <COND (<AND <TYPE? .X GVAL>
 379                       <MANIFEST? <CHTYPE .X ATOM>>>
 380                  <SET X <EVAL .X>>)>
 381           .X)>>
 382
 383 <SETG LONGS [O-LPAR0 O-LPAR1 O-LPAR2 O-LPAR3]>
 384 <SETG SHORTS [O-SPAR0 O-SPAR1 O-SPAR2 O-SPAR3 O-SPAR4 O-SPAR5 O-SPAR6
 385               O-SPAR7]>
 386 <SETG BYTE-MACS [O-BPAR0 O-BPAR1 O-BPAR2 O-BPAR3 O-BPAR4 O-BPAR5 O-BPAR6
 387                  O-BPAR7 O-BPAR8 O-BPAR9 O-BPAR10 O-BPAR11 O-BPAR12 O-BPAR13
 388                  O-BPAR14 O-BPAR15]>
 389
 390 <END-DEFINITIONS>