mim/development/mim/vax/mimlib/press.mud

   1 <PACKAGE "PRESS">
   2
   3 <USE-WHEN <COMPILING? "PRESS"> "BACKQUOTE">
   4 <USE "NEWSTRUC">
   5
   6 <ENTRY PRESS SET-X SET-Y SHOW-CHARACTERS FONT FONT-NUMBER SHOW-RECTANGLE
   7        SHOW-OBJECT SET-SPACE-X SET-SPACE-Y RESET-SPACE SPACE ONLY-ON-COPY
   8        SHOW-CHARACTER-IMMEDIATE NEW-ENTITY NEW-PAGE MOVETO DRAWTO DRAWCURVE>
   9
  10 <NEW-CHANNEL-TYPE PRESS                         DEFAULT
  11                   OPEN                          PRESS-OPEN
  12                   CLOSE                         PRESS-CLOSE
  13                   SET-X                         PRESS-SET-X
  14                   SET-Y                         PRESS-SET-Y
  15                   SHOW-CHARACTERS               PRESS-SHOW-CHARACTERS
  16                   SHOW-CHARACTER-IMMEDIATE      PRESS-SHOW-CHARACTER-IMMEDIATE
  17                   FONT                          PRESS-FONT
  18                   SHOW-RECTANGLE                PRESS-SHOW-RECTANGLE
  19                   ;"These operations not implemented by stupid dover."
  20                   ;SHOW-OBJECT                  ;PRESS-SHOW-OBJECT
  21                   ;SET-SPACE-X                  ;PRESS-SET-SPACE-X
  22                   ;SET-SPACE-Y                  ;PRESS-SET-SPACE-Y
  23                   ;RESET-SPACE                  ;PRESS-RESET-SPACE
  24                   SPACE                         PRESS-SPACE
  25                   ONLY-ON-COPY                  PRESS-ONLY-ON-COPY
  26                   NEW-ENTITY                    PRESS-NEW-ENTITY
  27                   NEW-PAGE                      PRESS-NEW-PAGE>
  28
  29 <NEWSTRUC PRESS-CHAN    VECTOR
  30           DISK-CHAN     <CHANNEL 'DISK>
  31           FONTS         <VECTOR [16 <OR FALSE VECTOR>]>
  32           DATA-START    FIX
  33           PAGE-START    FIX
  34           COMMANDS      QUEUE
  35           ENTITIES      QUEUE
  36           PAGES         QUEUE>
  37
  38 <DEFINE PRINT-PRESS-CHAN (PC)
  39    #DECL ((PC) PRESS-CHAN)
  40    <PRIN1 <DISK-CHAN .PC>>>
  41
  42 <COND (<GASSIGNED? PRINT-PRESS-CHAN>
  43        <PRINTTYPE PRESS-CHAN ,PRINT-PRESS-CHAN>)>
  44
  45 <NEWSTRUC QUEUE         VECTOR
  46           LIST-Q        LIST
  47           LAST-Q        LIST>
  48
  49 <DEFINE NEW-Q () <CHTYPE [() ()] QUEUE>>
  50
  51 <DEFINE ENQ (Q OBJ "AUX" LQ)
  52    #DECL ((Q) QUEUE (LQ) <LIST ANY>)
  53    <SET LQ (.OBJ)>
  54    <COND (<EMPTY? <LIST-Q .Q>> <LIST-Q .Q .LQ> <LAST-Q .Q .LQ>)
  55          (ELSE <PUTREST <LAST-Q .Q> .LQ> <LAST-Q .Q .LQ>)>
  56    .Q>
  57
  58 <DEFINE RESET-Q (Q) #DECL ((Q) QUEUE) <LIST-Q .Q ()> <LAST-Q .Q ()> .Q>
  59
  60 <NEWTYPE BYTE FIX>
  61 <NEWTYPE LONG FIX>
  62
  63 <DEFINE PRESS-OPEN (STYPE OPR NAME)
  64    #DECL ((NAME) STRING)
  65    <CHTYPE [<CHANNEL-OPEN DISK .NAME "CREATE" "8BIT">
  66             <IVECTOR 16 %<>>
  67             0
  68             0
  69             <NEW-Q>
  70             <NEW-Q>
  71             <NEW-Q>]
  72            PRESS-CHAN>>
  73
  74 <DEFINE PRESS-SET-X (CHAN OPER NUM
  75                      "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
  76    #DECL ((CHAN) <CHANNEL 'PRESS> (NUM) FIX (CMDS) QUEUE)
  77    <ENQ .CMDS #BYTE *000000000356*>
  78    <ENQ .CMDS <CHTYPE .NUM WORD>>
  79    .NUM>
  80
  81 <DEFINE PRESS-SET-Y (CHAN OPER NUM
  82                      "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
  83    #DECL ((CHAN) <CHANNEL 'PRESS> (NUM) FIX (CMDS) QUEUE)
  84    <ENQ .CMDS #BYTE *000000000357*>
  85    <ENQ .CMDS <CHTYPE .NUM WORD>>
  86    .NUM>
  87
  88 <DEFINE PRESS-SHOW-CHARACTER-IMMEDIATE (CHAN OPER CHAR
  89                                         "AUX"
  90                                         (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
  91    #DECL ((CHAN) <CHANNEL 'PRESS> (CHAR) <OR CHARACTER FIX> (CMDS) QUEUE)
  92    <ENQ .CMDS #BYTE *363*>
  93    <ENQ .CMDS <CHTYPE .CHAR BYTE>>
  94    .CHAR>
  95
  96 <DEFINE PRESS-SHOW-CHARACTERS (CHAN OPER STR "OPT" LEN
  97                                "AUX"
  98                                (DATA <CHANNEL-DATA .CHAN>)
  99                                (CMDS <COMMANDS .DATA>)
 100                                (DCHAN:<CHANNEL 'DISK> <DISK-CHAN .DATA>))
 101    #DECL ((CHAN) <CHANNEL 'PRESS> (STR) <OR STRING BYTES>
 102           (CMDS) QUEUE (LEN) FIX)
 103    <COND (<NOT <ASSIGNED? LEN>>
 104           <COND (<TYPE? .STR STRING>
 105                  <SET LEN <LENGTH .STR>>)
 106                 (ELSE
 107                  <SET LEN <LENGTH .STR>>)>)>
 108    <COND (<0? .LEN>)
 109          (<1? .LEN>
 110           <ENQ .CMDS #BYTE *363*>
 111           <ENQ .CMDS <CHTYPE .CHAR BYTE>>)
 112          (ELSE
 113           <WRITE-STRING .DCHAN .STR .LEN>
 114           <COND (<L=? .LEN 32>
 115                  <ENQ .CMDS <CHTYPE <- .LEN 1> BYTE>>)
 116                 (ELSE
 117                  <ENQ .CMDS #BYTE *000000000360*>
 118                  <ENQ .CMDS <CHTYPE .LEN BYTE>>)>)>
 119    .LEN>
 120
 121 <DEFINE PRESS-FONT (CHAN OPER FONT
 122                     "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
 123    #DECL ((CHAN) <CHANNEL 'PRESS> (FONT) STRING (CMDS) QUEUE)
 124    <ENQ .CMDS <CHTYPE <+ 112 <FONT-NUMBER .CHAN .FONT>> BYTE>>
 125    .FONT>
 126
 127 ;<DEFINE PRESS-SET-SPACE-X (CHAN OPER NUM
 128                             "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
 129     #DECL ((CHAN) <CHANNEL 'PRESS> (NUM) FIX (CMDS) QUEUE)
 130     <ENQ .CMDS #BYTE *000000000364*>
 131     <ENQ .CMDS <CHTYPE .NUM WORD>>
 132     .NUM>
 133
 134 ;<DEFINE PRESS-SET-SPACE-Y (CHAN OPER NUM
 135                             "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
 136     #DECL ((CHAN) <CHANNEL 'PRESS> (NUM) FIX (CMDS) QUEUE)
 137     <ENQ .CMDS #BYTE *000000000365*>
 138     <ENQ .CMDS <CHTYPE .NUM WORD>>
 139     .NUM>
 140
 141 ;<DEFINE PRESS-RESET-SPACE (CHAN OPER
 142                             "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
 143     #DECL ((CHAN) <CHANNEL 'PRESS> (CMDS) QUEUE)
 144     <ENQ .CMDS #BYTE *000000000366*>
 145     T>
 146
 147 <DEFINE PRESS-SPACE (CHAN OPER)
 148    #DECL ((CHAN) <CHANNEL 'PRESS>)
 149    <ENQ <COMMANDS <CHANNEL-DATA .CHAN>> #BYTE *000000000367*>
 150    T>
 151
 152 <DEFINE PRESS-SHOW-RECTANGLE (CHAN OPER WIDTH HEIGHT
 153                               "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
 154    #DECL ((CHAN) <CHANNEL 'PRESS> (WIDTH HEIGHT) FIX (CMDS) QUEUE)
 155    <ENQ .CMDS #BYTE *000000000376*>
 156    <ENQ .CMDS <CHTYPE .WIDTH WORD>>
 157    <ENQ .CMDS <CHTYPE .HEIGHT WORD>>
 158    T>
 159
 160 ;<DEFINE PRESS-SHOW-OBJECT (CHAN OPER "TUPLE" MOVES
 161                             "AUX"
 162                             (DATA <CHANNEL-DATA .CHAN>)
 163                             (CMDS <COMMANDS .DATA>)
 164                             (DCHAN:<CHANNEL 'DISK> <DISK-CHAN .DATA>)
 165                             START)
 166     #DECL ((CHAN) <CHANNEL 'PRESS> (MOVES) <TUPLE [REST <LIST ATOM>]>
 167            (CMDS) QUEUE (START) FIX)
 168     <SET START <MY-ACCESS .DCHAN>>
 169     <MAPF %<>
 170           <FUNCTION (MV "AUX" (ATM <1 .MV>))
 171              #DECL ((MV) <LIST ATOM> (ATM) ATOM)
 172              <COND (<==? .ATM MOVETO>
 173                     <WRITE-WORD .DCHAN 0>
 174                     <WRITE-WORD .DCHAN <2 .MV>>
 175                     <WRITE-WORD .DCHAN <3 .MV>>)
 176                    (<==? .ATM DRAWTO>
 177                     <WRITE-WORD .DCHAN 1>
 178                     <WRITE-WORD .DCHAN <2 .MV>>
 179                     <WRITE-WORD .DCHAN <3 .MV>>)
 180                    (<==? .ATM DRAWCURVE>
 181                     <WRITE-WORD .DCHAN 2>
 182                     <WRITE-FLOAT .DCHAN <2 .MV>>
 183                     <WRITE-FLOAT .DCHAN <3 .MV>>
 184                     <WRITE-FLOAT .DCHAN <4 .MV>>
 185                     <WRITE-FLOAT .DCHAN <5 .MV>>
 186                     <WRITE-FLOAT .DCHAN <6 .MV>>
 187                     <WRITE-FLOAT .DCHAN <7 .MV>>)>>
 188           .MOVES>
 189     <ENQ .CMDS #BYTE *373*>
 190     <ENQ .CMDS <CHTYPE <- <MY-ACCESS .DCHAN> .START> WORD>>
 191     T>
 192
 193 <DEFINE PRESS-ONLY-ON-COPY (CHAN OPER "OPT" (NUM 0)
 194                             "AUX" (CMDS <COMMANDS <CHANNEL-DATA .CHAN>>))
 195    #DECL ((CHAN) <CHANNEL 'PRESS> (CMDS) QUEUE)
 196    <ENQ .CMDS #BYTE *355*>
 197    <ENQ .CMDS <CHTYPE .NUM BYTE>>
 198    .NUM>
 199
 200 <DEFINE FONT-NUMBER (CHAN STR "AUX" (FONT <PARSE-FONT-NAME .STR>))
 201    #DECL ((CHAN) <CHANNEL 'PRESS> (STR) STRING (FONT) VECTOR)
 202    <MAPR %<>
 203          <FUNCTION (RFN "AUX" (THIS <1 .RFN>))
 204             #DECL ((RFN) <VECTOR [REST <OR VECTOR FALSE>]>
 205                    (THIS) <OR VECTOR FALSE>)
 206             <COND (<NOT .THIS>
 207                    <1 .RFN .FONT>
 208                    <MAPLEAVE <- 16 <LENGTH .RFN>>>)
 209                   (<=? .THIS .FONT>
 210                    <MAPLEAVE <- 16 <LENGTH .RFN>>>)>>
 211          <FONTS <CHANNEL-DATA .CHAN>>>>
 212
 213 <DEFINE PRESS-NEW-ENTITY (CHAN OPER
 214                           "AUX" (DATA <CHANNEL-DATA .CHAN>)
 215                           (DCHAN:<CHANNEL 'DISK> <DISK-CHAN .DATA>)
 216                           (CMDS <COMMANDS .DATA>) (EL <ENTITIES .DATA>)
 217                           BCMDS BTRLR END-OF-DATA)
 218    #DECL ((CHAN) <CHANNEL 'PRESS> (DATA) PRESS-CHAN (EL CMDS) QUEUE
 219           (BCMDS BTRLR) BYTES (END-OF-DATA) FIX)
 220    <COND (<NOT <EMPTY? <LIST-Q .CMDS>>>
 221           <COND (<1? <MOD <BYTE-LENGTH <LIST-Q .CMDS>> 2>>
 222                  <ENQ .CMDS #BYTE *000000000377*>)>
 223           <SET END-OF-DATA <MY-ACCESS .DCHAN>>
 224           <SET BCMDS <MAKE-BYTES !<LIST-Q .CMDS!>>>
 225           <SET BTRLR
 226                <MAKE-BYTES #BYTE *000000000000*
 227                            #BYTE *000000000000*
 228                            <CHTYPE <- <PAGE-START .DATA>
 229                                       <DATA-START .DATA>> LONG>
 230                            <CHTYPE <- .END-OF-DATA <DATA-START .DATA>>
 231                                    LONG>
 232                            #WORD *000000000000*
 233                            #WORD *000000000000*
 234                            #WORD *000000000000*
 235                            #WORD *000000000000*
 236                            #WORD *000000052126*
 237                            #WORD *000000066444*
 238                            <CHTYPE </ <+ <LENGTH .BCMDS> 24> 2> WORD>>>
 239           <ENQ .EL .BCMDS>
 240           <ENQ .EL .BTRLR>
 241           <DATA-START .DATA .END-OF-DATA>
 242           <RESET-Q .CMDS>)>
 243    T>
 244
 245 <DEFINE PRESS-NEW-PAGE (CHAN OPER "AUX" (DATA <CHANNEL-DATA .CHAN>)
 246                         (DCHAN:<CHANNEL 'DISK> <DISK-CHAN .DATA>)
 247                         (EL <ENTITIES .DATA>) PAGE-END END-OF-EL)
 248    #DECL ((CHAN) <CHANNEL 'PRESS> (PAGE-END END-OF-EL) FIX)
 249    <PRESS-NEW-ENTITY .CHAN .OPER>
 250    <COND (<NOT <EMPTY? <LIST-Q .EL>>>
 251           <COND (<1? <MOD <MY-ACCESS .DCHAN> 2>> <WRITE-BYTE .DCHAN 0>)>
 252           <WRITE-WORD .DCHAN 0>
 253           <MAPF %<>
 254                 <FUNCTION (BUF) #DECL ((BUF) BYTES)
 255                    <WRITE-BYTES .DCHAN .BUF>>
 256                 <LIST-Q .EL>>
 257           <SET END-OF-EL <MY-ACCESS .DCHAN>>
 258           <SET PAGE-END <NEXT-RECORD .DCHAN>>
 259           <ENQ <PAGES .DATA>
 260                <MAKE-BYTES #WORD *000000000000*
 261                            <CHTYPE </ <PAGE-START .DATA> 512> WORD>
 262                            <CHTYPE </ <- .PAGE-END <PAGE-START .DATA>>
 263                                       512>
 264                                    WORD>
 265                            <CHTYPE </ <- .PAGE-END .END-OF-EL> 2>
 266                                    WORD>>>
 267           <PAGE-START .DATA .PAGE-END>
 268           <DATA-START .DATA .PAGE-END>
 269           <RESET-Q .EL>)>
 270    T>
 271
 272 <SETG PADDING <IBYTES 117 255>>
 273
 274 <DEFINE PRESS-CLOSE (CHAN OPER "AUX" (DATA <CHANNEL-DATA .CHAN>)
 275                      (DCHAN:<CHANNEL 'DISK> <DISK-CHAN .DATA>)
 276                      FONT-DIR-START PART-DIR-START
 277                      DOC-DIR-START (PAGE-COUNT 0))
 278    #DECL ((CHAN) <CHANNEL 'PRESS>)
 279    <PRESS-NEW-PAGE .CHAN .OPER>
 280    <SET FONT-DIR-START <MY-ACCESS .DCHAN>>
 281    <COND (<NOT <1 <FONTS .DATA>>>
 282           <1 <FONTS .DATA> '["HELVETICA" 12 0]>)>
 283    <MAPR %<>
 284          <FUNCTION (RFONTS "AUX" (FONT <1 .RFONTS>))
 285             #DECL ((FONT) <OR FALSE <VECTOR STRING FIX FIX>>)
 286             <COND (.FONT
 287                    <WRITE-WORD .DCHAN 16>
 288                    <WRITE-BYTE .DCHAN 0>
 289                    <WRITE-BYTE .DCHAN <- 16 <LENGTH .RFONTS>>>
 290                    <WRITE-BYTE .DCHAN 0>
 291                    <WRITE-BYTE .DCHAN 255>
 292                    <WRITE-BCPL .DCHAN <1 .FONT>>
 293                    <MY-ACCESS .DCHAN
 294                               <+ <MY-ACCESS .DCHAN>
 295                                  <- 19 <LENGTH <1 .FONT>>>>>
 296                    <WRITE-BYTE .DCHAN <3 .FONT>>
 297                    <WRITE-BYTE .DCHAN 0>
 298                    <WRITE-WORD .DCHAN <2 .FONT>>
 299                    <WRITE-WORD .DCHAN 0>)
 300                   (ELSE <MAPLEAVE>)>>
 301          <FONTS .DATA>>
 302
 303    <SET PART-DIR-START <NEXT-RECORD .DCHAN>>
 304    <MAPF %<>
 305          <FUNCTION (PAGE)
 306             <SET PAGE-COUNT <+ .PAGE-COUNT 1>>
 307             <WRITE-BYTES .DCHAN .PAGE>>
 308          <LIST-Q <PAGES .DATA>>>
 309    <WRITE-WORD .DCHAN 1>
 310    <WRITE-WORD .DCHAN </ .FONT-DIR-START 512>>
 311    <WRITE-WORD .DCHAN </ <- .PART-DIR-START .FONT-DIR-START> 512>>
 312    <WRITE-WORD .DCHAN 0>
 313
 314    <SET DOC-DIR-START <NEXT-RECORD .DCHAN>>
 315    <WRITE-WORD .DCHAN 27183>
 316    <WRITE-WORD .DCHAN <+ </ .DOC-DIR-START 512> 1>>
 317    <WRITE-WORD .DCHAN <+ .PAGE-COUNT 1>>
 318    <WRITE-WORD .DCHAN </ .PART-DIR-START 512>>
 319    <WRITE-WORD .DCHAN </ <- .DOC-DIR-START .PART-DIR-START> 512>>
 320    <WRITE-WORD .DCHAN </ .DOC-DIR-START 512>>
 321    <WRITE-LONG .DCHAN 0>
 322    <WRITE-WORD .DCHAN 1>
 323    <WRITE-WORD .DCHAN 1>
 324    <WRITE-WORD .DCHAN -1>
 325    <WRITE-WORD .DCHAN -1>
 326    <WRITE-WORD .DCHAN -1>
 327    <WRITE-BYTES .DCHAN ,PADDING>
 328    <WRITE-BCPL .DCHAN "FOO.PRESS">
 329    <MY-ACCESS .DCHAN <+ .DOC-DIR-START 154>>
 330    <WRITE-BCPL .DCHAN "SAM">
 331    <MY-ACCESS .DCHAN <+ .DOC-DIR-START 170>>
 332    <WRITE-BCPL .DCHAN "TODAY">
 333    <MY-ACCESS .DCHAN <+ .DOC-DIR-START 511>>
 334    <WRITE-BYTE .DCHAN 0>
 335    <CLOSE <DISK-CHAN .DATA>>
 336    .CHAN>
 337
 338 <DEFMAC MY-ACCESS ('DCHAN "OPT" 'NUM)
 339    <COND (<ASSIGNED? NUM>
 340           `<CHANNEL-OP ~.DCHAN ACCESS ~.NUM>)
 341          (ELSE
 342           `<CHANNEL-OP ~.DCHAN ACCESS>:FIX)>>
 343
 344 <DEFINE NEXT-RECORD (DCHAN "AUX" N)
 345    #DECL ((DCHAN) <CHANNEL 'DISK> (N) FIX)
 346    <SET N <* <+ </ <MY-ACCESS .DCHAN> 512> 1> 512>>
 347    <MY-ACCESS .DCHAN .N>
 348    .N>
 349
 350 <DEFMAC WRITE-BYTE ('DCHAN 'NUM)
 351    `<CHANNEL-OP ~.DCHAN WRITE-BYTE ~.NUM>>
 352
 353 <DEFMAC WRITE-WORD ('DCHAN 'NUM)
 354    `<BIND ((DCHAN ~.DCHAN) (NUM ~.NUM))
 355        #DECL ((DCHAN) <CHANNEL 'DISK> (NUM) FIX)
 356        <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .NUM -8>>
 357        <CHANNEL-OP .DCHAN WRITE-BYTE .NUM>>>
 358
 359 <DEFMAC WRITE-LONG ('DCHAN 'NUM)
 360    `<BIND ((DCHAN ~.DCHAN) (NUM ~.NUM))
 361        #DECL ((DCHAN) <CHANNEL 'DISK> (NUM) FIX)
 362        <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .NUM -24>>
 363        <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .NUM -16>>
 364        <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .NUM -8>>
 365        <CHANNEL-OP .DCHAN WRITE-BYTE .NUM>>>
 366
 367 <DEFINE WRITE-FLOAT (DCHAN NUM "AUX" (FX <CHTYPE .NUM FIX>))
 368    #DECL ((DCHAN) <CHANNEL 'DISK> (NUM) FLOAT
 369           (FX) FIX)
 370    <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .FX -28>>
 371    <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .FX -20>>
 372    <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .FX -12>>
 373    <CHANNEL-OP .DCHAN WRITE-BYTE <LSH .FX -4>>>
 374
 375 <DEFMAC WRITE-BYTES ('DCHAN 'B)
 376    `<CHANNEL-OP ~.DCHAN WRITE-BUFFER ~.B>>
 377
 378 <DEFINE WRITE-STRING (DCHAN S "OPT" LEN)
 379    #DECL ((DCHAN) <CHANNEL 'DISK> (S) <OR STRING BYTES> (LEN))
 380    <COND (<TYPE? .S BYTES>
 381           <COND (<NOT <ASSIGNED? LEN>> <SET LEN <LENGTH .S>>)>
 382           <CHANNEL-OP .DCHAN WRITE-BUFFER .S .LEN>)
 383          (ELSE
 384           <REPEAT ((I 1))
 385              #DECL ((I) FIX)
 386              <CHANNEL-OP .DCHAN WRITE-BYTE <CHTYPE <1 .S> FIX>>
 387              <COND (<G? <SET I <+ .I 1>> .LEN> <RETURN>)>>)>>
 388
 389 <DEFMAC WRITE-BCPL ('DCHAN 'S)
 390    `<BIND ((DCHAN ~.DCHAN) (S ~.S))
 391        #DECL ((DCHAN) <CHANNEL 'DISK> (S) STRING)
 392        <CHANNEL-OP .DCHAN WRITE-BYTE <LENGTH .S>>
 393        <MAPF %<>
 394              <FUNCTION (C)
 395                 #DECL ((C) CHARACTER)
 396                 <CHANNEL-OP .DCHAN WRITE-BYTE <ASCII .C>>>
 397              .S>>>
 398
 399 <DEFINE MAKE-BYTES ("TUPLE" T)
 400    #DECL ((T) <TUPLE [REST <OR BYTE WORD LONG>]>)
 401    <MAPF ,BYTES
 402          <FUNCTION (N)
 403             <COND (<TYPE? .N BYTE> <MAPRET <CHTYPE .N FIX>>)
 404                   (<TYPE? .N WORD>
 405                    <MAPRET <LSH .N -8> <CHTYPE .N FIX>>)
 406                   (<TYPE? .N LONG>
 407                    <MAPRET <LSH .N -24>
 408                            <LSH .N -16>
 409                            <LSH .N -8>
 410                            <CHTYPE .N FIX>>)>>
 411          .T>>
 412
 413 <DEFINE BYTE-LENGTH (L)
 414    #DECL ((L) <LIST [REST <OR BYTE WORD LONG>]>)
 415    <MAPF ,+
 416          <FUNCTION (N)
 417             <COND (<TYPE? .N BYTE> 1)
 418                   (<TYPE? .N WORD> 2)
 419                   (<TYPE? .N LONG> 4)>>
 420          .L>>
 421
 422 <DEFINE PARSE-FONT-NAME (STR "AUX" (SIZE 0))
 423    #DECL ((STR) STRING (SIZE) FIX)
 424    [<MAPR ,STRING
 425           <FUNCTION (RSTR "AUX" (C <1 .RSTR>) (N <ASCII .C>))
 426              <COND (<AND <G=? .N 48> <L=? .N 57>>
 427                     <SET STR .RSTR>
 428                     <MAPSTOP>)
 429                    (<AND <G=? .N 97> <L=? .N 122>>
 430                     <MAPRET <ASCII <+ .N -32>>>)
 431                    (ELSE <MAPRET .C>)>>
 432           .STR>
 433     <MAPR %<>
 434           <FUNCTION (RSTR "AUX" (C <1 .RSTR>) (N <ASCII .C>))
 435              <COND (<AND <G=? .N 48> <L=? .N 57>>
 436                     <SET STR .RSTR>
 437                     <SET SIZE <+ <* 10 .SIZE> <- .N 48>>>)
 438                    (ELSE <SET STR .RSTR> <MAPLEAVE .SIZE>)>>
 439           .STR>
 440     <MAPF ,+
 441           <FUNCTION (C)
 442              <COND (<OR <==? .C !\B> <==? .C !\b>> 2)
 443                    (<OR <==? .C !\L> <==? .C !\l>> 4)
 444                    (<OR <==? .C !\I> <==? .C !\i>> 1)
 445                    (<OR <==? .C !\C> <==? .C !\c>> 6)
 446                    (<OR <==? .C !\E> <==? .C !\e>> 12)
 447                    (ELSE 0)>>
 448           .STR>]>
 449
 450 <ENDPACKAGE>