mim/development/mim/vax/tty/termprs.mud

   1
   2 <PACKAGE "TERMPRS">
   3
   4 <ENTRY PARSE-TERMCAP PARSE-TERM-TYPE>
   5
   6 <L-FLOAD "TTYTYPES.MUD">
   7
   8 <L-FLOAD "TTYOPS.MUD">
   9
  10 <SETG CRLF-STRING "
  11 ">
  12
  13 <SETG CRLF-LEN <LENGTH ,CRLF-STRING>>
  14
  15 "Write a TTY-DESC to the supplied file.  This produces a format that can be
  16  read by the TTY package."
  17
  18 <DEFINE WRITE-TTY-DESC (FN DESC
  19                         "AUX" (DEV "USR") (SNM "MIM/TTYS") (NM2 "") CH
  20                               (BUFSTR <STACK <ISTRING 256>>))
  21    #DECL ((DESC) TTY-DESC (FN) STRING (CH) <OR CHANNEL FALSE> (BUFSTR) STRING
  22           (DEV SNM NM2) <SPECIAL STRING>)
  23    <SET CH <CHANNEL-OPEN PARSE .FN>>
  24    <SET FN <CHANNEL-OP .CH NAME>>
  25    <CHANNEL-CLOSE .CH>
  26    <COND
  27     (<SET CH <CHANNEL-OPEN DISK .FN "CREATE" "ASCII">>
  28      <CHANNEL-OP .CH WRITE-BYTE <CHTYPE <LENGTH <TD-NAME .DESC>> CHARACTER>>
  29      <CHANNEL-OP .CH WRITE-BUFFER <TD-NAME .DESC>>
  30      <CHANNEL-OP .CH WRITE-BYTE <CHTYPE <TD-HEIGHT .DESC> CHARACTER>>
  31      <CHANNEL-OP .CH WRITE-BYTE <CHTYPE <TD-WIDTH .DESC> CHARACTER>>
  32      <CHANNEL-OP .CH WRITE-BYTE <TD-PADCHR .DESC>>
  33      <CHANNEL-OP .CH WRITE-BYTE <CHTYPE <TD-CRPAD .DESC> CHARACTER>>
  34      <CHANNEL-OP .CH WRITE-BYTE <CHTYPE <TD-LFPAD .DESC> CHARACTER>>
  35      <CHANNEL-OP .CH WRITE-BYTE <CHTYPE <LENGTH <TD-PRIMOPS .DESC>> CHARACTER>>
  36      <CHANNEL-OP .CH
  37                  WRITE-BYTE
  38                  <CHTYPE <MAPF ,+
  39                                <FUNCTION (X) <COND (.X 1) (0)>>
  40                                <TD-PRIMOPS .DESC>>
  41                          CHARACTER>>
  42      <PROG ((ID 1))
  43        #DECL ((ID) FIX)
  44        <MAPF <>
  45         <FUNCTION (X "AUX" (TLEN 0) NLEN)
  46            #DECL ((X) <OR FALSE TTY-OP> (TLEN) FIX)
  47            <COND
  48             (.X
  49              <SET BUFSTR <TOP .BUFSTR>>
  50              <1 .BUFSTR <CHTYPE .ID CHARACTER>>
  51              <SET TLEN 2>
  52              <COND (<TYPE? .X VECTOR>
  53                     <2 .BUFSTR <CHTYPE <LENGTH .X> CHARACTER>>
  54                     <MAPF <>
  55                           <FUNCTION (PART)
  56                                   <SET NLEN
  57                                        <WRITE-PART .PART <REST .BUFSTR 2>>>
  58                                   <SET TLEN <+ .TLEN .NLEN>>
  59                                   <SET BUFSTR <REST .BUFSTR .NLEN>>>
  60                           .X>)
  61                    (T
  62                     <2 .BUFSTR <CHTYPE 1 CHARACTER>>
  63                     <SET NLEN <WRITE-PART .X <REST .BUFSTR 2>>>
  64                     <SET TLEN <+ .TLEN .NLEN>>)>
  65              <CHANNEL-OP .CH WRITE-BYTE <CHTYPE .TLEN CHARACTER>>
  66              <CHANNEL-OP .CH WRITE-BUFFER <TOP .BUFSTR> .TLEN>)>
  67            <SET ID <+ .ID 1>>>
  68         <TD-PRIMOPS .DESC>>>
  69      <CLOSE .CH>)>>
  70
  71 <DEFINE WRITE-PART (PART BUF "OPTIONAL" (PAD 0) "AUX" (CHRS 0))
  72    #DECL ((PART) <OR TTY-ELT STRING TTY-OUT> (CHRS) FIX (BUF) STRING (PAD) FIX)
  73    <COND
  74     (<TYPE? .PART STRING>
  75      <1 .BUF <CHTYPE .PAD CHARACTER>>
  76      <2 .BUF <CHTYPE <+ <LENGTH .PART> 2> CHARACTER>>
  77      <3 .BUF <ASCII 1>>
  78      <4 .BUF <CHTYPE <LENGTH .PART> CHARACTER>>
  79      <MAPR <>
  80            <FUNCTION (X Y) #DECL ((X Y) STRING) <1 .X <1 .Y>>>
  81            <REST .BUF 4>
  82            .PART>
  83      <+ 4 <LENGTH .PART>>)
  84     (<TYPE? .PART TTY-OUT> <WRITE-PART <TO-STRING .PART> .BUF <TO-PAD .PART>>)
  85     (<TYPE? .PART TTY-ELT>
  86      <1 .BUF <CHTYPE .PAD CHARACTER>>
  87      <3 .BUF <CHTYPE <LENGTH .PART> CHARACTER>>
  88      <PROG ((TBUF <REST .BUF 3>) (LEN 0))
  89            <MAPF <>
  90                  <FUNCTION (FROB)
  91                          #DECL ((FROB) <OR STRING FIX>)
  92                          <COND (<TYPE? .FROB FIX>
  93                                 <1 .TBUF <CHTYPE .FROB CHARACTER>>
  94                                 <SET TBUF <REST .TBUF>>
  95                                 <SET LEN <+ .LEN 1>>)
  96                                (T
  97                                 <1 .TBUF <CHTYPE <LENGTH .FROB> CHARACTER>>
  98                                 <MAPR <>
  99                                       <FUNCTION (X Y)
 100                                               #DECL ((X Y) STRING)
 101                                               <1 .X <1 .Y>>>
 102                                       <REST .TBUF>
 103                                       .FROB>
 104                                 <SET TBUF <REST .TBUF <+ <LENGTH .FROB> 1>>>
 105                                 <SET LEN <+ .LEN 1 <LENGTH .FROB>>>)>>
 106                  .PART>
 107            <2 .BUF <CHTYPE .LEN CHARACTER>>
 108            <+ .LEN 3>>)>>
 109
 110 "Parse a TERMCAP file, making new files for each terminal described."
 111
 112 <SETG NAME-VEC
 113       '["dumb"
 114         "GLASS"
 115         "arpanet"
 116         "NVT"
 117         "c100rv"
 118         "C100"
 119         "c100"
 120         "C100"
 121         "h19"
 122         "H19"
 123         "altoh19"
 124         "H19"
 125         "cdc456"
 126         "CDC456"
 127         "cdc456tst"
 128         "CDC456"
 129         "dm1520"
 130         "DM1520"
 131         "dm1521"
 132         "DM1521"
 133         "dm2500"
 134         "DM2500"
 135         "dm3025"
 136         "DM3025"
 137         "3045"
 138         "DM3045"
 139         "dt80"
 140         "DT80"
 141         "dt80132"
 142         "DT80"
 143         "h1552"
 144         "H1552"
 145         "h1552rv"
 146         "H1552"
 147         "h1500"
 148         "H1500"
 149         "h1510"
 150         "H1500"
 151         "ibm"
 152         "IBM"
 153         "tab132"
 154         "TAB132"
 155         "tab132w"
 156         "TAB132"
 157         "tab132rv"
 158         "TAB132"
 159         "tab132wrv"
 160         "TAB132"
 161         "vc404"
 162         "VC404"
 163         "vc404s"
 164         "VC404"
 165         "vc404na"
 166         "VC404"
 167         "vc404sna"
 168         "VC404"
 169         "vc303a"
 170         "VC303"
 171         "vc303"
 172         "VC303"
 173         "aaadb"
 174         "AAA"
 175         "aa"
 176         "AAA"
 177         "aaajek"
 178         "AAA"
 179         "aaa"
 180         "AAA"
 181         "datapoint"
 182         "DATAPOINT"
 183         "vi200"
 184         "VI200"
 185         "vi200rvic"
 186         "VI200"
 187         "vi200f"
 188         "VI200"
 189         "vi200rv"
 190         "VI200"
 191         "vi200ic"
 192         "VI200"
 193         "regent"
 194         "REGENT"
 195         "regent100"
 196         "REGENT"
 197         "regent20"
 198         "REGENT"
 199         "regent25"
 200         "REGENT"
 201         "regent40"
 202         "REGENT"
 203         "regent60"
 204         "REGENT"
 205         "regent60na"
 206         "REGENT"
 207         "c108"
 208         "C108"
 209         "c100rvpp"
 210         "C100"
 211         "c100rvna"
 212         "C100"
 213         "c100s"
 214         "C100"
 215         "c100rvs"
 216         "C100"
 217         "c100-1200"
 218         "C100"
 219         "vt100n"
 220         "VT100"
 221         "vt100"
 222         "VT100"
 223         "vt100v"
 224         "VT100V"
 225         "vt125"
 226         "VT125"
 227         "ovt100"
 228         "VT100"
 229         "vt132"
 230         "VT132"
 231         "vt50"
 232         "VT50"
 233         "dw1"
 234         "LA30"
 235         "vt50h"
 236         "VT50"
 237         "vt100s"
 238         "VT100"
 239         "vt100w"
 240         "VT100"
 241         "vt52"
 242         "VT52"
 243         "bg"
 244         "BBN"
 245         "bbn"
 246         "BBN"
 247         "nvt52"
 248         "VT52"
 249         "vt52big"
 250         "VT52"
 251         "spdp"
 252         "SUPDUP"
 253         "dw2"
 254         "LA36"
 255         "hp"
 256         "HP2645"
 257         "h19A"
 258         "H19A"
 259         "h19bs"
 260         "H19"
 261         "h19us"
 262         "H19"
 263         "h19u"
 264         "H19"]>
 265
 266 <DEFINE GET-STANDARD-NAME (NAME "AUX" TV)
 267         #DECL ((NAME) STRING (TV) <OR VECTOR FALSE>)
 268         <COND (<SET TV <MEMBER .NAME ,NAME-VEC>> <2 .TV>)
 269               (<MAPF ,STRING
 270                      <FUNCTION (X)
 271                              #DECL ((X) CHARACTER)
 272                              <COND (<AND <G=? <ASCII .X> <ASCII !\a>>
 273                                          <L=? <ASCII .X> <ASCII !\z>>>
 274                                     <ASCII <+ <ASCII .X>
 275                                               <- <ASCII !\A> <ASCII !\a>>>>)
 276                                    (.X)>>
 277                      .NAME>)>>
 278
 279 <DEFINE PARSE-TERM-TYPE ("AUX" (VEC <CALL GETS ENVIR>) ST)
 280         <COND (<SET ST <GET-ENV-STR "TERMCAP" .VEC>>
 281                <PARSE-TERMCAP "FOO" .ST>)
 282               (#FALSE ("TERMCAP ENTRY NOT IN ENVIRONMENT"))>>
 283
 284 <DEFINE GET-NEXT-STRING (CH
 285                          "AUX" (BUF <STACK <ISTRING 512>>)
 286                                (CUR <CHANNEL-OP .CH ACCESS>) CT)
 287    #DECL ((CHANNEL) CHANNEL (BUF) STRING (CUR) FIX)
 288    <REPEAT OLOOP (TS (TBUF .BUF))
 289      <COND
 290       (<SET CT <CHANNEL-OP .CH READ-BUFFER .TBUF>>
 291        <COND (<0? .CT> <RETURN <>>)>
 292        <SET CT <- 512 <- <LENGTH .TBUF> .CT>>>
 293        <COND (<N==? .CT 512> <SUBSTRUC .BUF 0 .CT <REST .BUF <- 512 .CT>>>)>
 294        <PROG ((TS .BUF))
 295              <COND (<SET TS <MEMQ !\: .TS>>
 296                     <COND (<==? <LENGTH .TS> 1>
 297                            <1 .BUF !\:>
 298                            <SET TBUF <REST .BUF>>
 299                            <AGAIN .OLOOP>)>
 300                     <COND (<==? <2 .TS> <ASCII 10>>
 301                            <SET BUF
 302                                 <ISTRING <- <CHANNEL-OP .CH ACCESS>
 303                                             <- <LENGTH .TS> 2>
 304                                             .CUR>>>
 305                            <CHANNEL-OP .CH ACCESS .CUR>
 306                            <CHANNEL-OP .CH READ-BUFFER .BUF>
 307                            <RETURN .BUF .OLOOP>)>
 308                     <SET TS <REST .TS>>
 309                     <AGAIN>)
 310                    (<SET TBUF .BUF>)>>)
 311       (<RETURN .CT>)>>>
 312
 313 <DEFINE PARSE-TERMCAP ("OPTIONAL" (FN "/ETC/TERMCAP") ST "AUX" (CH <>) DESCS)
 314    #DECL ((FN ST) STRING (CH) <OR CHANNEL FALSE>)
 315    <COND
 316     (<OR <ASSIGNED? ST>
 317          <AND <SET CH <CHANNEL-OPEN DISK .FN "READ" "ASCII">>
 318               <RESET .CH>>>
 319      <COND (<NOT <ASSIGNED? ST>> <SET ST "">)>
 320      <SET DESCS
 321       <MAPF ,VECTOR
 322        <FUNCTION ("AUX" DSTR TSS TS NAME STDNAME TS1 TS2 NS)
 323           #DECL ((TS) <OR STRING FALSE> (TSS NAME STDNAME) STRING)
 324           <COND (<EMPTY? .ST>
 325                  <COND (<OR <NOT .CH> <NOT <SET NS <GET-NEXT-STRING .CH>>>>
 326                         <MAPSTOP>)
 327                        (T <SET ST .NS>)>)>
 328           <COND (<==? <1 .ST> !\#>
 329                  <COND (<SET TS <MEMBER ,CRLF-STRING .ST>>
 330                         <SET ST <REST .TS ,CRLF-LEN>>
 331                         <MAPRET>)
 332                        (<MAPSTOP>)>)>
 333           <SET TSS <MEMQ !\| .ST>>
 334           <SET TS1 <MEMQ !\| <REST .TSS>>>
 335           <SET TS2 <MEMQ !\: <REST .TSS>>>
 336           <COND (<AND .TS1 .TS2>
 337                  <COND (<L? <LENGTH .TS1> <LENGTH .TS2>> <SET TS1 .TS2>)>)
 338                 (<SET TS1 <OR .TS1 .TS2>>)
 339                 (<SET TS1 "">)>
 340           <SET NAME <SUBSTRUC <REST .TSS> 0 <- <LENGTH .TSS> 1 <LENGTH .TS1>>>>
 341           <SET STDNAME <GET-STANDARD-NAME .NAME>>
 342           <SET ST <MEMQ !\: .TSS>>
 343           <SET DSTR
 344            <MAPF ,STRING
 345             <FUNCTION ("AUX" CHR NUM)
 346                <COND (<AND <G=? <LENGTH .ST> 2>
 347                            <==? <1 .ST> !\:>
 348                            <OR <==? <2 .ST> <ASCII 10>>
 349                                <==? <2 .ST> <ASCII 13>>>>
 350                       <SET ST <REST .ST 2>>
 351                       <COND (<AND <NOT <EMPTY? .ST>> <==? <1 .ST> <ASCII 10>>>
 352                              <SET ST <REST .ST>>)>
 353                       <MAPSTOP !\:>)>
 354                <COND (<EMPTY? .ST> <MAPSTOP>)>
 355                <COND
 356                 (<==? <1 .ST> <ASCII 10>> <SET ST <REST .ST>> <MAPRET>)
 357                 (<==? <1 .ST> <ASCII 13>> <SET ST <REST .ST>> <MAPRET>)
 358                 (<==? <1 .ST> <ASCII 92>>
 359                  <COND
 360                   (<MEMQ <SET CHR <2 .ST>> "01234567">
 361                    <SET NUM 0>
 362                    <MAPR <>
 363                          <FUNCTION (STR "AUX" (CHR <1 .STR>))
 364                                  #DECL ((CHR) CHARACTER (STR) STRING)
 365                                  <COND (<MEMQ .CHR "01234567">
 366                                         <SET NUM
 367                                              <+ <* .NUM 8>
 368                                                 <- <ASCII .CHR> <ASCII !\0>>>>)
 369                                        (T <SET ST .STR> <MAPLEAVE>)>>
 370                          <REST .ST>>
 371                    <COND (<==? .NUM 128> <SET NUM 0>)
 372                          (<==? .NUM <ASCII !\:>> <MAPRET "\\;">)>
 373                    <ASCII .NUM>)
 374                   (T
 375                    <SET ST <REST .ST 2>>
 376                    <COND (<==? .CHR <ASCII 10>> <MAPRET>)
 377                          (<==? .CHR <ASCII 13>> <MAPRET>)
 378                          (<==? .CHR !\E> <ASCII 27>)
 379                          (<==? .CHR !\n> <ASCII 10>)
 380                          (<==? .CHR !\r> <ASCII 13>)
 381                          (<==? .CHR !\t> <ASCII 9>)
 382                          (<==? .CHR !\b> <ASCII 8>)
 383                          (<==? .CHR !\f> <ASCII 12>)
 384                          (T .CHR)>)>)
 385                 (<==? <1 .ST> !\^>
 386                  <SET CHR <2 .ST>>
 387                  <SET ST <REST .ST 2>>
 388                  <CHTYPE <ANDB .CHR 31> CHARACTER>)
 389                 (T <SET CHR <1 .ST>> <SET ST <REST .ST>> .CHR)>>>>
 390           [.NAME .STDNAME .DSTR]>>>
 391      <SET ST "">
 392      <MAPF <>
 393            <FUNCTION (STDESC "AUX" DESC)
 394                    #DECL ((STDESC) <VECTOR [3 STRING]>)
 395                    <SET DESC <MAKE-DESC <2 .STDESC> <3 .STDESC> .DESCS>>
 396                    <WRITE-TTY-DESC <1 .STDESC> .DESC>>
 397            .DESCS>
 398      T)>>
 399
 400 <DEFINE GET-NUM (TARG MAIN "OPTIONAL" (AUX <>) (DEF 0) "AUX" (NUM 0) TS)
 401         #DECL ((TARG MAIN) STRING (AUX TS) <OR STRING FALSE> (NUM) FIX)
 402         <COND (<AND <SET TS <MEMBER .TARG .MAIN>>
 403                     <==? <NTH .TS <+ <LENGTH .TARG> 1>> !\#>>
 404                <SET TS <REST .TS <+ <LENGTH .TARG> 1>>>
 405                <MAPF <>
 406                      <FUNCTION (C)
 407                              #DECL ((C) CHARACTER)
 408                              <COND (<==? .C !\:> <MAPLEAVE>)>
 409                              <SET NUM
 410                                   <+ <* .NUM 10> <- <ASCII .C> <ASCII !\0>>>>>
 411                      .TS>
 412                .NUM)
 413               (.AUX <GET-NUM .TARG .AUX <> .DEF>)
 414               (.DEF)>>
 415
 416 <DEFINE GET-STR (TARG MAIN "OPTIONAL" (AUX <>) (DEF <>) "AUX" TS (QUOTE <>))
 417         #DECL ((TARG MAIN) STRING (AUX TS) <OR FALSE STRING>)
 418         <COND (<SET TS <MEMBER .TARG .MAIN>>
 419                <SET TS <REST .TS <LENGTH .TARG>>>
 420                <COND (<==? <1 .TS> !\@> "")
 421                      (T
 422                       <MAPF ,STRING
 423                             <FUNCTION (C)
 424                                     #DECL ((C) CHARACTER)
 425                                     <COND (.QUOTE
 426                                            <SET QUOTE <>>
 427                                            <COND (<==? .C !\;> !\:) (.C)>)
 428                                           (<==? .C <ASCII 92>>
 429                                            <SET QUOTE T>
 430                                            <MAPRET>)
 431                                           (<==? .C !\:> <MAPSTOP>)
 432                                           (.C)>>
 433                             <REST .TS>>)>)
 434               (.AUX <GET-STR .TARG .AUX <> .DEF>)
 435               (.DEF)>>
 436
 437 <DEFINE GET-AUX-DESC (NAME DESCS)
 438         #DECL ((NAME) STRING
 439                (DESCS) <VECTOR [REST <VECTOR STRING STRING STRING>]>)
 440         <MAPF <>
 441               <FUNCTION (DD) <COND (<=? .NAME <1 .DD>> <MAPLEAVE <3 .DD>>)>>
 442               .DESCS>>
 443
 444 <SETG OP-VEC
 445       [[,TTY-FWD GET-TTY-OP ":nd"]
 446        [,TTY-BCK GET-TTY-BCK]
 447        [,TTY-UP GET-TTY-OP ":up"]
 448        [,TTY-DWN GET-TTY-OP ":do"]
 449        [,TTY-HRZ GET-TTY-OP ":ch" ":cm"]
 450        [,TTY-VRT GET-TTY-OP ":cv" ":cm"]
 451        [,TTY-MOV GET-TTY-OP ":cm"]
 452        [,TTY-HOM GET-TTY-HOME]
 453        [,TTY-HMD GET-TTY-HOMD]
 454        [,TTY-CLR GET-TTY-CLR]
 455        [,TTY-CEW GET-TTY-OP ":cd"]
 456        [,TTY-CEL GET-TTY-OP ":ce"]
 457        [,TTY-ERA GET-TTY-ERA]
 458        [,TTY-BEC GET-TTY-BEC]
 459        [,TTY-IL GET-TTY-OP ":al"]
 460        [,TTY-DL GET-TTY-OP ":dl"]
 461        [,TTY-IC GET-TTY-OP ":ic"]
 462        [,TTY-DC GET-TTY-OP ":dc"]
 463        [,TTY-DS GET-TTY-OP ":cs"]
 464        [,TTY-SU GET-TTY-OP ":sf"]
 465        [,TTY-SD GET-TTY-OP ":sr"]]>
 466
 467 <GDECL (OP-VEC) <VECTOR [REST VECTOR]>>
 468
 469 <DEFINE MAKE-DESC (STDNAME DESC DESCS
 470                    "AUX" (CUR-NAME .STDNAME) HEIGHT WIDTH PAD CRPAD LFPAD AUXN
 471                          (AUX <>) OPS)
 472         #DECL ((STDNAME DESC) STRING (HEIGHT WIDTH CRPAD LFPAD) FIX
 473                (PAD) <OR STRING CHARACTER> (CUR-NAME) <SPECIAL STRING>)
 474         <COND (<SET AUXN <GET-STR ":tc" .DESC>>
 475                <SET AUX <GET-AUX-DESC .AUXN .DESCS>>)>
 476         <SET HEIGHT <GET-NUM ":li" .DESC .AUX>>
 477         <SET WIDTH <GET-NUM ":co" .DESC .AUX>>
 478         <COND (<TYPE? <SET PAD <GET-STR ":pc" .DESC .AUX <ASCII 0>>> STRING>
 479                <SET PAD <1 .PAD>>)>
 480         <SET CRPAD <GET-NUM ":dC" .DESC .AUX 0>>
 481         <SET LFPAD <GET-NUM ":dN" .DESC .AUX 0>>
 482         <SET OPS <IVECTOR ,MAX-TTY-OP <>>>
 483         <MAPF <>
 484               <FUNCTION (OD)
 485                       #DECL ((OD) <VECTOR FIX ATOM [REST ANY]>)
 486                       <PUT .OPS
 487                            <1 .OD>
 488                            <APPLY ,<2 .OD> .DESC .AUX !<REST .OD 2>>>>
 489               ,OP-VEC>
 490         <CHTYPE [.STDNAME .HEIGHT .WIDTH .PAD .CRPAD .LFPAD .OPS] TTY-DESC>>
 491
 492 <DEFINE GET-TTY-OP (MAIN AUX TARG "OPTIONAL" (OTH <>) "AUX" TS)
 493         #DECL ((MAIN TARG) STRING (OTH AUX) <OR STRING FALSE>)
 494         <COND (<AND <SET TS <GET-STR .TARG .MAIN .AUX <>>> <NOT <EMPTY? .TS>>>
 495                <MAKE-OP .TS>)
 496               (.OTH <GET-TTY-OP .MAIN .AUX .OTH>)>>
 497
 498 <DEFINE GET-TTY-BCK (MAIN AUX)
 499         <COND (<OR <MEMBER ":bs" .MAIN> <MEMBER ":bs" .AUX>>
 500                <STRING <ASCII 8>>)
 501               (<GET-TTY-OP .MAIN .AUX ":bc">)>>
 502
 503 <DEFINE GET-TTY-CLR (MAIN AUX "AUX" HO CD)
 504         <COND (<GET-TTY-OP .MAIN .AUX ":cl">)
 505               (<AND <SET HO <GET-TTY-HOME .MAIN .AUX>>
 506                     <SET CD <GET-TTY-OP .MAIN .AUX ":cd">>>
 507                <MERGE-OPS .HO .CD>)>>
 508
 509 <DEFINE GET-TTY-ERA (MAIN AUX "AUX" BS)
 510         <COND (<SET BS <GET-TTY-BCK .MAIN .AUX>> <MERGE-OPS .BS " ">)>>
 511
 512 <DEFINE GET-TTY-BEC (MAIN AUX "AUX" BS)
 513         <COND (<SET BS <GET-TTY-BCK .MAIN .AUX>>
 514                <MERGE-OPS <MERGE-OPS .BS " "> .BS>)>>
 515
 516 <DEFINE GET-TTY-HOME (MAIN AUX "AUX" TS)
 517         <COND (<GET-TTY-OP .MAIN .AUX ":ho">)
 518               (<SET TS <GET-STR ":cm" .MAIN .AUX <>>> <MAKE-OP .TS 0 0>)>>
 519
 520 <DEFINE GET-TTY-HOMD (MAIN AUX "AUX" TS)
 521         <COND (<GET-TTY-OP .MAIN .AUX ":ll">)
 522               (<=? .CUR-NAME "VS100"> <>)
 523               (<SET TS <GET-STR ":cm" .MAIN .AUX <>>>
 524                <MAKE-OP .TS 0 <- <GET-NUM ":li" .MAIN .AUX> 1>>)>>
 525
 526 <DEFINE MERGE-OPS (OP1 OP2)
 527         #DECL ((OP1 OP2) <OR STRING TTY-OUT VECTOR TTY-ELT>)
 528         <COND
 529          (<AND <TYPE? .OP1 STRING> <TYPE? .OP2 STRING>> <STRING .OP1 .OP2>)
 530          (<AND <TYPE? .OP1 TTY-ELT> <TYPE? .OP2 TTY-ELT>>
 531           <CHTYPE [!.OP1 !.OP2] TTY-ELT>)
 532          (<AND <TYPE? .OP1 TTY-OUT> <TYPE? .OP2 TTY-OUT>> [.OP1 .OP2 ""])
 533          (<AND <TYPE? .OP2 TTY-OUT> <TYPE? .OP1 STRING TTY-ELT>>
 534           <COND (<TYPE? <TO-STRING .OP2> STRING>
 535                  <COND (<TYPE? .OP1 STRING>
 536                         <TO-STRING .OP2 <STRING .OP1 <TO-STRING .OP2>>>)
 537                        (<TO-STRING .OP2 <CHTYPE [!.OP1 .OP2] TTY-ELT>>)>)
 538                 (T
 539                  <COND (<TYPE? .OP1 STRING>
 540                         <TO-STRING .OP2
 541                                    <CHTYPE [.OP1 !<TO-STRING .OP2>] TTY-ELT>>)
 542                        (T
 543                         <TO-STRING .OP2
 544                                    <CHTYPE [!.OP1 !<TO-STRING .OP2>]
 545                                            TTY-ELT>>)>)>)
 546          (<AND <TYPE? .OP1 TTY-OUT STRING TTY-ELT>
 547                <TYPE? .OP2 TTY-OUT STRING TTY-ELT>>
 548           <COND (<AND <TYPE? .OP1 STRING> <TYPE? .OP2 TTY-ELT>>
 549                  <CHTYPE [.OP1 !.OP2] TTY-ELT>)
 550                 (<AND <TYPE? .OP1 TTY-ELT> <TYPE? .OP2 STRING>>
 551                  <CHTYPE [!.OP1 .OP2] TTY-ELT>)
 552                 (T [.OP1 .OP2 ""])>)
 553          (<AND <TYPE? .OP1 VECTOR> <EMPTY? <NTH .OP1 <LENGTH .OP1>>>>
 554           <PUT .OP1
 555                <LENGTH .OP1>
 556                <COND (<TYPE? .OP2 VECTOR> <2 .OP2>) (.OP2)>>)
 557          (<ERROR CANT-MERGE .OP1 .OP2>)>>
 558
 559 <DEFINE MAKE-OP (STR "OPTIONAL" (X <>) (Y <>) "AUX" (PAD 0))
 560         #DECL ((STR) STRING (X Y) <OR FIX FALSE> (PAD) FIX)
 561         <COND (<EMPTY? .STR>
 562                <>)
 563               (<MEMQ <1 .STR> "0123456789">
 564                <MAPR <>
 565                      <FUNCTION (ST "AUX" (C <1 .ST>))
 566                              #DECL ((ST) STRING (C) CHARACTER)
 567                              <COND (<==? .C !\*>
 568                                     <SET PAD <- .PAD>>
 569                                     <SET STR <REST .ST>>
 570                                     <MAPLEAVE>)
 571                                    (<AND <G=? <ASCII .C> <ASCII !\0>>
 572                                          <L=? <ASCII .C> <ASCII !\9>>>
 573                                     <SET PAD
 574                                          <+ <* .PAD 10>
 575                                             <- <ASCII .C> <ASCII !\0>>>>)
 576                                    (T <SET STR .ST> <MAPLEAVE>)>>
 577                      .STR>)>
 578         <COND (<EMPTY? .STR> <>)
 579               (<==? .PAD 0> <GET-TTY-ELTS .STR .X .Y>)
 580               (<G? .PAD 0> <CHTYPE [<GET-TTY-ELTS .STR .X .Y> .PAD] TTY-OUT>)
 581               (T
 582                ["" <CHTYPE [<GET-TTY-ELTS .STR .X .Y> <- .PAD>] TTY-OUT> ""])>>
 583
 584 <DEFINE GET-TTY-ELTS (STR
 585                       "OPTIONAL" (X <>) (Y <>)
 586                       "AUX" (X-FIRST? <>) (FIRST-USED? <>) (LAST-START .STR)
 587                             (INC? <>) (BCD? <>) TE (SST .STR))
 588    #DECL ((STR) STRING (LAST-START) <OR STRING FALSE> (TE) VECTOR
 589           (BCD? INC? X-FIRST? FIRST-USED?) <OR ATOM FALSE>
 590           (X Y) <OR FIX FALSE>)
 591    <COND
 592     (<NOT <MEMQ !\% .STR>> .STR)
 593     (T
 594      <SET TE
 595       <MAPF ,VECTOR
 596        <FUNCTION ("AUX" C ANUM NS)
 597                <COND (<EMPTY? .STR>
 598                       <COND (<N==? .SST .STR> <MAPSTOP .SST>) (<MAPSTOP>)>)>
 599                <COND
 600                 (<N==? <SET C <1 .STR>> !\%> <SET STR <REST .STR>> <MAPRET>)
 601                 (<N==? .SST .STR>
 602                  <SET NS <SUBSTRUC .SST 0 <- <LENGTH .SST> <LENGTH .STR>>>>
 603                  <SET SST .STR>
 604                  <MAPRET .NS>)
 605                 (T
 606                  <SET C <2 .STR>>
 607                  <SET STR <REST .STR 2>>
 608                  <SET SST .STR>
 609                  <COND (<==? .C !\%> <MAPRET "%">)
 610                        (<==? .C !\r> <SET X-FIRST? <NOT .X-FIRST?>> <MAPRET>)
 611                        (<==? .C !\i> <SET INC? T> <MAPRET>)
 612                        (<==? .C !\B> <SET BCD? T> <MAPRET>)>
 613                  <COND (.X-FIRST?
 614                         <COND (.FIRST-USED? <SET ANUM ,TTY-Y-POS>)
 615                               (T <SET FIRST-USED? T> <SET ANUM ,TTY-X-POS>)>)
 616                        (T
 617                         <COND (.FIRST-USED? <SET ANUM ,TTY-X-POS>)
 618                               (T <SET FIRST-USED? T> <SET ANUM ,TTY-Y-POS>)>)>
 619                  <COND (.INC?
 620                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-INC-ARG> FIX>>)>
 621                  <COND (.BCD?
 622                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-BCD-ARG> FIX>>)>
 623                  <COND (<==? .C !\d>
 624                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-DECIMAL> FIX>>)
 625                        (<==? .C !\2>
 626                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-RJD2> FIX>>)
 627                        (<==? .C !\3>
 628                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-RJD3> FIX>>)
 629                        (<==? .C !\.>
 630                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-LITERAL> FIX>>)
 631                        (<==? .C !\+>
 632                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-LIT+> FIX>>
 633                         <SET STR <REST .STR>>
 634                         <SET SST .STR>)
 635                        (T
 636                         <PRINC "WARNING -- unknown descriptor `">
 637                         <PRINC .C>
 638                         <PRINC "' in ">
 639                         <PRINC .CUR-NAME>
 640                         <CRLF>
 641                         <SET ANUM <CHTYPE <ORB .ANUM ,TTY-UNKNOWN> FIX>>)>
 642                  <COND (<AND .X <0? <CHTYPE <ANDB .ANUM ,TTY-X/Y> FIX>>>
 643                         <MAPRET <PROCESS-ARG .ANUM .X>>)
 644                        (<AND .Y <NOT <0? <CHTYPE <ANDB .ANUM ,TTY-X/Y> FIX>>>>
 645                         <MAPRET <PROCESS-ARG .ANUM .Y>>)>
 646                  .ANUM)>>>>
 647      <COND (<REPEAT ((TV .TE))
 648                     <COND (<EMPTY? .TV> <RETURN <>>)
 649                           (<NOT <TYPE? <1 .TV> STRING>> <RETURN T>)>
 650                     <SET TV <REST .TV>>>
 651             <CHTYPE .TE TTY-ELT>)
 652            (<STRING !.TE>)>)>>
 653
 654 <DEFINE PROCESS-ARG (ANUM ARG "AUX" TS)
 655         #DECL ((ANUM ARG) FIX (TS) STRING)
 656         <COND (<NOT <0? <CHTYPE <ANDB .ANUM ,TTY-INC-ARG> FIX>>>
 657                <SET ARG <+ .ARG 1>>)>
 658         <COND (<NOT <0? <CHTYPE <ANDB .ANUM ,TTY-BCD-ARG> FIX>>>
 659                <SET ARG <+ <* 16 </ .ARG 10>> <MOD .ARG 10>>>)>
 660         <SET ANUM <CHTYPE <ANDB .ANUM ,TTY-ARG-DESC> FIX>>
 661         <COND (<==? .ANUM ,TTY-LITERAL> <STRING <ASCII .ARG>>)
 662               (<==? .ANUM ,TTY-LIT+> <STRING <ASCII <+ .ARG 32>>>)
 663               (<==? .ANUM ,TTY-DECIMAL> <UNPARSE .ARG>)
 664               (<==? .ANUM ,TTY-RJD2> <UNPARSE .ARG>)
 665               (<==? .ANUM ,TTY-RJD3> <UNPARSE .ARG>)>>
 666
 667 <ENDPACKAGE>