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