/* REXX:  ASCII translator, originally written in stoneage I'm still */
/* modifying this code, the last addition is LOW showing a table of  */
/* only US ASCII char.s, because text windows are often too small.   */

   signal on novalue name TRAP
   parse arg INPUT                     /* arguments                  */
   parse upper source . . NAME         /* program name               */

   AS =     'NUL SOH STX ETX EOT ENQ ACK BEL'   /* DEL aka ^?  (*IX) */
   AS = AS  'BS  HT  LF  VT  FF  CR  SO  SI '   /* HT  aka TAB (all) */
   AS = AS  'DLE DC1 DC2 DC3 DC4 NAK SYN ETB'   /* LF  aka EOL (*IX) */
   AS = AS  'CAN EM  SUB ESC FS  GS  RS  US '   /* SUB aka EOF (DOS) */
   /* DEL (127) handled separately, FF (12) listed too as \xFF (255) */

   FLAG = 0 ;  LAST = 0                /* FLAG no range; LAST output */
   BOXM = '-'
   BOXP = '+'
   BOXB = '|'
   SKIP = '00 07 08 09 0A 0D 0E 1A 1B'x         /* avoid side effect */
   EXPO = 'NAME WORD AS BOXB BOXM BOXP SKIP'    /* global variables  */

   if INPUT = '' then INPUT = USAGE()
   say
   do while INPUT > ''
      parse var INPUT WORD INPUT
      if left( WORD, 1 ) = '"' then do       /* get rid of "?"    */
         parse var WORD '"' THIS '"' X       /* (shell escape)    */
         if THIS > '' & X = '' then WORD = THIS
      end
      select
         when WORD = '^>' then WORD = '>'    /* shell escape      */
         when WORD = '^<' then WORD = '<'    /* shell escape      */
         when WORD = '^|' then WORD = '|'    /* shell escape      */
         otherwise nop
      end
      THIS = translate( WORD )               /* upper case        */
      select                           /* ----------------------- */
         when THIS = '...' | THIS = '..'  then  FLAG = 1
         when THIS = '256' | THIS = 'LOW' then do
            do X = -3 to 0    /* 000 .. 015 after 3 header lines  */
               say TABLE( X )
            end X
            say TABLE( 16 )   /* 000 .. 015 symbolic: ASCII names */
            say TABLE( 17 )   /* 016 .. 031 symbolic: ASCII names */
            do X = 1 to 7 + 8 * ( THIS = '256' )
               if X = 8 then say TABLE( -1 ) ;  say TABLE( X )
            end X             /* 016 .. 255 graphical  (16 lines) */
         end                           /* end of TABLE            */
         when THIS = 'ALL'    then do  /* ----------------------- */
            say SPLIT() SPLIT()        /* 36 / 2 lines            */
            do X = 0 to 31 by 2
               say SPLIT( X ) SPLIT( X + 1 )
            end X
            say SPLIT( 32 ) SPLIT( 127 )
         end                           /* end ASCII control codes */
         when THIS = 'ISO'    then do  /* ----------------------- */
            X =   '  7   8   9  10  11  12  13  27  34  35'
            X = X ' 39  63  91  92  93  94 123 124 125 126'
            say SPLIT() SPLIT( 0 )     /* incl. invalid \e        */
            do while X > ''            /* even item number        */
               parse var X THIS WORD X
               say SPLIT( THIS ) SPLIT( WORD )
            end
         end                           /* end of ISO C sequences  */
         when THIS = 'IBM'    then do  /* ----------------------- */
            do X = -3 to -1   ;  say TABLE( X ) ;  end X
            say CODES(  9,                        11    13 14    )
            say CODES( 10,                   9                   )
            say CODES( 11,           5 6 7 8            13 14    )
            say CODES( 12,             6 7                    15 )
            say CODES( 13, 0 1 2 3 4 5 6 7 8            13 14    )
            say CODES( 14, 0   2 3 4 5   7 8 9 10 11 12 13 14 15 )
            say CODES( 15, 0   2 3 4 5   7   9    11 12          )
         end                           /* end of codepage 437/850 */
         otherwise                     /* ----------------------- */
            THIS = DECODE( WORD )      /* decode input word       */
            if FLAG & ( LAST > THIS )  then do X = LAST-2 to THIS by -1
               say ASCII( X )          /* descending range        */
            end X
            else if FLAG               then do X = LAST     to THIS
               say ASCII( X )          /*  ascending range        */
            end  X
            else do
               say ASCII( THIS )       /* here FF is ambiguous:   */
               if translate( WORD ) = 'FF' then say ASCII( 255 )
            end
            FLAG = 0 ;  LAST = THIS + 1
      end                              /* end of select THIS      */
   end                                 /* end do while INPUT > '' */
   exit 0                              /* no error detected       */

USAGE:   procedure expose (EXPO) /* ----------------------------- */
   X = x2c( 0D0A )   ;  CRLF = X
   X = X || 'usage:' NAME '<argument> [...]'      CRLF
   X = X || 'where <argument> can have the form:' BOXB
   X = X || '  cc    hexadecimal digits 00 .. FE' CRLF
   X = X || '  c     a printable ASCII character' BOXB
   X = X || '  cc    ASCII code symbol (e.g. CR)' CRLF
   X = X || '  \c    C escape sequence (e.g. \r)' BOXB
   X = X || '  ccc   ASCII code symbol like ACK ' CRLF
   X = X || '  ^c    ^@ .. ^_ or ^? control code' BOXB
   X = X || '  ..    indicates argument subrange' CRLF
   X = X || '  ??c   ANSI C trigraphs (e.g. ??/)' BOXB
   X = X || '  ...   indicates argument subrange' CRLF
   X = X || '  \ccc  octal  sequence (e.g. \015)' BOXB
   X = X || '  ALL   list 33 ASCII control codes' CRLF
   X = X || '  \xcc  C hex. sequence (e.g. \x0D)' BOXB
   X = X || '  IBM   difference codepage 437/850' CRLF
   X = X || '  ccc   3 decimal digits 000 .. 255' BOXB
   X = X || '  ISO   list 20 ISO C sequences    ' CRLF
   X = X || '  256   256 untranslated characters' BOXB
   X = X || '  LOW   128 char.s: strict US ASCII' CRLF
   X = X || 'For codes above 127 DEL the current '
   X = X || 'codepage is used.  Caveat: \e is no C.' CRLF
   X = X || 'Except from lists like ALL or 256 the '
   X = X || 'result shows all translations as in:'   CRLF
   X = X || ASCII( 7 ) CRLF   ;  X = X || ASCII( 8 ) CRLF
   X = X || ASCII( 9 ) CRLF   ;  say X || copies( BOXM, 73 )
   call charout /**/,'enter argument(s): '
   parse pull INPUT        ;  return INPUT

SPLIT:   procedure expose (EXPO) /* ----------------------------- */
   if arg() = 1 then do
      X = ASCII( arg( 1 ))
      parse var X . X.1 ' = ' X.2 ' = ' X.3 ' = ' X.4 ' = ' X.5
      X = '= aka graphical not C'
      do while X > ''                  /* get rid of verbose text */
         parse var X Y X   ;  Z = wordpos( Y, X.5 )
         do while Z > 0
            X.5 = space( delword( X.5, Z, 1 ))
            Z = wordpos( Y, X.5 )
         end
      end
      X = right( X.1, 5 ) '|' X.2 '|' X.3 '|' X.4 '|' X.5
   end
   else X = 'ASCII | hex. | dec | oct. | aka'
   return left( X, 39 )

CODES:   procedure expose (EXPO) /* ----------------------------- */
   LINE = TABLE( arg( 1 ))
   do I = 0 to 15
      if wordpos( I, arg( 2 )) > 0 then iterate I
      LINE = overlay( ' ', LINE, 14 + 4 * I + 2 * ( 7 < I ))
   end I
   if arg( 1 ) = 9 | arg( 1 ) = 10 then do
      if arg( 1 ) = 9   then I = ' CodePage 437 vs 850 differences'
                        else I = ' (characters 000..154 identical)'
      LINE = overlay( I, LINE, 12 )
   end
   return LINE

TABLE:   procedure expose (EXPO) /* ----------------------------- */
   select
      when arg( 1 ) = -3 then do          /* 1st header line: */
         LINE = '    oct   ' || BOXB copies( ' ', 31 ) BOXB || ''
         return LINE '10  11  12  13  14  15  16  17 ' BOXB
      end
      when arg( 1 ) = -2 then do          /* 2nd header line: */
         LINE = 'dec    hex' || BOXB
         LINE = LINE ' 0   1   2   3   4   5   6   7 ' BOXB || ''
         return LINE ' 8   9   A   B   C   D   E   F ' BOXB
      end
      when arg( 1 ) = -1 then do          /* 3rd header line: */
         LINE = copies( BOXM, 10 ) || BOXP || copies( BOXM, 33 )
         return LINE || BOXP || copies( BOXM, 33 ) || BOXP
      end
      when arg( 1 ) <  4 then LINE = '0'  /* octal 000 .. 077 */
      when arg( 1 ) <  8 then LINE = '1'  /* octal 100 .. 177 */
      when arg( 1 ) < 12 then LINE = '2'  /* octal 200 .. 277 */
      when arg( 1 ) < 16 then LINE = '3'  /* octal 300 .. 377 */
      when arg( 1 ) = 16 then do       /* ASCII 000 .. 015 */
         LINE = '  0 000 00' || BOXB || '.'           /* decimal '.' */
         LINE = LINE || subword( AS,  1, 8 ) BOXB ''  /* octal range */
         LINE = LINE || subword( AS,  9, 2 ) || ' .'  /* decimal '.' */
         return LINE || subword( AS, 11, 6 ) '' BOXB  /* octal range */
      end
      when arg( 1 ) = 17 then do       /* ASCII 016 .. 031 */
         LINE = ' 16 020 10' || BOXB || ' '
         LINE = LINE || subword( AS, 17, 4 ) || '.'   /* decimal '.' */
         LINE = LINE || subword( AS, 21, 4 ) BOXB ''  /* octal range */
         LINE = LINE || subword( AS, 25, 6 ) || ' .'  /* decimal '.' */
         return LINE || subword( AS, 31, 2 ) '' BOXB  /* octal range */
      end
      otherwise nop
   end
   LINE =      right( 16 * arg( 1 ), 3 ) LINE
   LINE = LINE || 2 * arg( 1 ) // 8 || '0'
   LINE = LINE d2x( arg( 1 )) || '0' || BOXB

   do X = 16 * arg( 1 ) to 16 * arg( 1 ) + 15
      if sign( X // 10 )
         then LINE = LINE || ' '
         else LINE = LINE || '.'       /* decimal marker */
      if 0 < verify( d2c( X ), SKIP )
         then LINE = LINE d2c( X ) || ' '
         else LINE = LINE || '^' || d2c( X + 64 ) ''
      if X // 16 = 7
         then LINE = LINE BOXB         /* octal range */
   end X
   return LINE BOXB

ASCII:   procedure expose (EXPO) /* ----------------------------- */
   parse arg D                         /* 0..255 (leading 0 okay) */
   select                              /* A = also known as       */
      when D =   0 then A = '= C \0'
      when D =   7 then A = '= C \a'                  /* Alert */
      when D =   8 then A = '= C \b'                  /* BS */
      when D =   9 then A = '= C \t = aka TAB'
      when D =  10 then A = '= C \n = aka EOL'        /* New line */
      when D =  11 then A = '= C \v'                  /* VT */
      when D =  12 then A = '= C \f'                  /* FF */
      when D =  13 then A = '= C \r'                  /* Return */
      when D =  26 then A = '= aka EOF'               /* only DOS */
      when D =  27 then A = '= aka \e not C'          /* ESC */
      when D =  32 then A = "= graphical '" || d2c(D) || "'"
      when D =  34 then A = '= C \"'                  /* " */
      when D =  35 then A = '= C ??='                 /* # */
      when D =  39 then A = "= C \'"                  /* ' */
      when D =  63 then A = '= C \?'                  /* ? */
      when D =  91 then A = '= C ??('                 /* [ */
      when D =  92 then A = '= C ??/ = C \\'          /* \ */
      when D =  93 then A = '= C ??)'                 /* ] */
      when D =  94 then A = "= C ??'"                 /* ^ */
      when D = 123 then A = '= C ??<'                 /* { */
      when D = 124 then A = '= C ??!'                 /* | */
      when D = 125 then A = '= C ??>'                 /* } */
      when D = 126 then A = '= C ??-'                 /* ~ */
      when D = 127 then A = "= ^? = graphical '" || d2c(D) || "'"
      when D < 256 then A = ''                        /* no AKA */
      otherwise   exit FAIL( D )
   end
   C = "'" || d2c( D ) || "'"          /* default: character */
   if D = 127 then C = 'DEL'           /* replace symbol */
   if D =  39 then C = '"' || "'" || '"'
   if D =  32 then C = ' SP'           /* replace symbol */
   if D <  32 then do                  /* replace symbol */
      C = '= ^' || d2c( D + 64 )       /* control code logic */
      if 0 < verify( d2c( D ), SKIP )  /* skip non-printable */
         then C = C "= graphical '" || d2c( D ) || "'"
      A = C A                          /* symbol and AKA */
      C = right( word( AS, D + 1 ), 3 )
   end
   H = right( d2x( D ), 2, '0' ) ;  D = right( D, 3 )
   Q = D // 8  ; O = ( D - Q ) % 8
   P = O // 8  ; O = ( O - P ) % 8
   C = C '= \x' || H '=' D '= \' || O || P || Q A
   if D < 128  then  return 'ASCII' C
               else  return '     ' C

DECODE:  procedure expose (EXPO) /* ----------------------------- */
   parse arg X
   T = translate( X )   ;  R = wordpos( T, AS ) ;  L = length( X )
   select
      when L = 0     then  return 32
      when L = 1     then  return c2d( X )
      when 0 < R     then  return R - 1
      when L = 2 & datatype( T, 'X' )  then return x2d( X )
      when L = 3 & datatype( T, 'W' )  then return X
      when T = 'DEL' then  return 127
      when T = '\A'  then  return   7  /* aka Alarm */
      when T = '\B'  then  return   8  /* BS, BackSpace */
      when T = 'TAB' then  return   9  /* HT, Hor. Tab */
      when T = '\T'  then  return   9  /* aka Tabstop */
      when T = '\N'  then  return  10  /* aka Newline */
      when T = 'EOL' then  return  10  /* only for *IX */
      when T = '\V'  then  return  11  /* VT, Vert. Tab */
      when T = '\F'  then  return  12  /* FF, FormFeed */
      when T = '\R'  then  return  13  /* CR, Return */
      when T = 'EOF' then  return  26  /* only for DOS */
      when T = '\E'  then  return  27  /* ESC (not C) */
      when T = 'SP'  then  return  32  /* SPace, blank */
      when X = '\"'  then  return  34  /* " in strings */
      when X = '??=' then  return  35  /* # ISO 6 bits */
      when X = "\'"  then  return  39  /* ' in char.s */
      when X = '\?'  then  return  63  /* ? literally */
      when X = '??(' then  return  91  /* [ ISO 6 bits */
      when X = '\\'  then  return  92  /* \ un-escaped */
      when X = '??/' then  return  92  /* \ ISO 6 bits */
      when X = '??)' then  return  93  /* ] ISO 6 bits */
      when X = "??'" then  return  94  /* ^ ISO 6 bits */
      when X = '??<' then  return 123  /* { ISO 6 bits */
      when X = '??!' then  return 124  /* | ISO 6 bits */
      when X = '??>' then  return 125  /* } ISO 6 bits */
      when X = '??-' then  return 126  /* ~ ISO 6 bits */
      when X = '^?'  then  return 127  /* only for *IX */
      otherwise
         parse var X T 2 X
         select                     /* split X in Type & characters */
            when length( X ) < 1 then nop    /* too less  characters */
            when length( X ) > 3 then nop    /* too many  characters */
            when ( T = '^' ) & ( 1 = length( X )) then do
               X = c2d( translate( X )) - 64
               if ( 0 <= X ) & ( X < 32 ) then return X
            end                              /* ^@,A ... Z,[,\,],^,_ */
            when ( translate( T ) = 'X' ) then do
               if datatype( X, 'X' ) then return x2d( X )
            end
            when ( T = '\' ) & ( 'x' = left( X, 1 )) then do
               X = substr( X, 2, 2, '.' )    /* \x00 ... FF (ANSI C) */
               if datatype( X, 'X' ) then return x2d( X )
            end
            when ( T = '\' ) & ( verify( X, '01234567' ) = 0 ) then do
               if X > 377 then exit FAIL( X )
               X = right( X, 3, '0' )        /* \0 ... 377 (octal C) */
               return 64 * left(X,1) + 8 * substr(X,2,1) + right(X,1)
            end
            otherwise nop                    /* drop to exit FAIL(X) */
         end
   end
   exit FAIL( X )

FAIL:    procedure expose (EXPO) /* ----------------------------- */
   NAME = WORD 'unknown, try char C, hex XX, dec DDD, oct \OOO, or AKA'
   if trace() <> 'N' then do
      NAME = 'parser state' arg( 1 ) || x2c( 0A ) || NAME
      exit TRAP( NAME )
   end
   say NAME ;  return 1

/* see <URL:http://purl.net/xyzzy/rexxtrap.htm>, (c) F. Ellermann */

TRAP:                            /* select REXX exception handler */
   call trace 'O' ;  trace N           /* don't trace interactive */
   parse source TRAP                   /* source on separate line */
   TRAP = x2c( 0D ) || right( '+++', 10 ) TRAP || x2c( 0D0A )
   TRAP = TRAP || right( '+++', 10 )   /* = standard trace prefix */
   TRAP = TRAP strip( condition( 'c' ) 'trap:' condition( 'd' ))
   select
      when wordpos( condition( 'c' ), 'ERROR FAILURE' ) > 0 then do
         if condition( 'd' ) > ''      /* need an additional line */
            then TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
         TRAP = TRAP '(RC' rc || ')'   /* any system error codes  */
         if condition( 'c' ) = 'FAILURE' then rc = -3
      end
      when wordpos( condition( 'c' ), 'HALT SYNTAX'   ) > 0 then do
         if condition( 'c' ) = 'HALT' then rc = 4
         if condition( 'd' ) > '' & condition( 'd' ) <> rc then do
            if condition( 'd' ) <> errortext( rc ) then do
               TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
               TRAP = TRAP errortext( rc )
            end                        /* future condition( 'd' ) */
         end                           /* may use errortext( rc ) */
         else  TRAP = TRAP errortext( rc )
         rc = -rc                      /* rc < 0: REXX error code */
      end
      when condition( 'c' ) = 'NOVALUE'  then rc = -2 /* dubious  */
      when condition( 'c' ) = 'NOTREADY' then rc = -1 /* dubious  */
      otherwise                        /* force non-zero whole rc */
         if datatype( value( 'RC' ), 'W' ) = 0 then rc = 1
         if rc = 0                             then rc = 1
         if condition() = '' then TRAP = TRAP arg( 1 )
   end                                 /* direct: TRAP( message ) */

   TRAP = TRAP || x2c( 0D0A ) || format( sigl, 6 )
   signal on syntax name TRAP.SIGL     /* throw syntax error 3... */
   if 0 < sigl & sigl <= sourceline()  /* if no handle for source */
      then TRAP = TRAP '*-*' strip( sourceline( sigl ))
      else TRAP = TRAP '+++ (source line unavailable)'
TRAP.SIGL:                             /* ...catch syntax error 3 */
   if abbrev( right( TRAP, 2 + 6 ), x2c( 0D0A )) then do
      TRAP = TRAP '+++ (source line unreadable)'   ;  rc = -rc
   end
   select
      when 0 then do                   /* in pipes STDERR: output */
         parse version TRAP.REXX       /* REXX/Personal: \dev\con */
         if abbrev( TRAP.REXX, 'REXXSAA ' ) |                /**/ ,
            6 <= word( TRAP.REXX, 2 )  then  TRAP.REXX = 'STDERR'
                                       else  TRAP.REXX = '\dev\con'
         signal on syntax name TRAP.FAIL
         call lineout TRAP.REXX , TRAP /* fails if no more handle */
      end
      when 0 then do                   /* OS/2 PM or ooREXX on NT */
         signal on syntax name TRAP.FAIL
         call RxMessageBox translate( TRAP, ' ', x2c( 0D )), /**/ ,
            'Trap' time(),, 'ERROR'
      end
      otherwise   say TRAP ; trace ?L  /* interactive Label trace */
   end

   if condition() = 'SIGNAL' then signal TRAP.EXIT
TRAP.CALL:  return rc                  /* continue after CALL ON  */
TRAP.FAIL:  say TRAP ;  rc = 0 - rc    /* force TRAP error output */
TRAP.EXIT:  exit   rc                  /* exit for any SIGNAL ON  */