REXX Tips & Tricks:Sample source code

This section contains some sample source code. (see also Using the samples)

Using ANSI sequences

This section contains some routines for the display and for redefining of keys using ANSI sequences. (see also ANSI ESC Sequences)

Check if ANSI is active - 1 -

 
/* sample routine to check if ANSI is activated                       */
/*                                                                    */
/* see also Check if ANSI is active - 2 -                             */
/*                                                                    */

  i = CheckAnsi()
  if i = 1 then
    say "ANSI is activated"
  else
    if i = 0 then
      say "ANSI is not activated."
    else
      say "Error detecting ANSI."

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if ANSI is activated                               */
/*                                                                    */
/* call:     CheckAnsi                                                */
/*                                                                    */
/* where:    -                                                        */
/*                                                                    */
/* returns:  1 - ANSI support detected                                */
/*           0 - no ANSI support available                            */
/*          -1 - error detecting ansi                                 */
/*                                                                    */
/* note:     Tested with the German and the US version of OS/2 3.0    */
/*                                                                    */
/*                                                                    */
CheckAnsi: PROCEDURE
  thisRC = -1

  trace off
                        /* install a local error handler              */
  SIGNAL ON ERROR Name InitAnsiEnd

  "@ANSI 2>NUL | rxqueue 2>NUL"

  thisRC = 0

  do while queued() <> 0
    queueLine = lineIN( "QUEUE:" )
    if pos( " on.", queueLine ) <> 0 | ,                       /* USA */
       pos( " (ON).", queueLine ) <> 0 then                    /* GER */
      thisRC = 1
  end /* do while queued() <> 0 */

InitAnsiEnd:
RETURN thisRC

Check if ANSI is active - 2 -

/* sample routine to check if ANSI is activated (using REXXUTIL)      */
/* based on a idea and code of Erik Schneller                         */
/* (see EMail Addresses)                                              */
/*                                                                    */
/* see also Check if ANSI is active - 1 -                             */
/*                                                                    */
  i = CheckAnsi()
  if i = 1 then
    say "ANSI is activated"
  else
    if i = 0 then
      say "ANSI is not activated."
    else
      say "Error detecting ANSI."

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if ANSI is activated                               */
/*                                                                    */
/* call:     CheckAnsi                                                */
/*                                                                    */
/* where:    -                                                        */
/*                                                                    */
/* returns:  1 - ANSI support detected                                */
/*           0 - no ANSI support available                            */
/*          -1 - error detecting ansi                                 */
/*                                                                    */
/* note:     Tested with the German and the US version of OS/2 3.0    */
/*           based on a idea and code of Erik Schneller               */
/*           (see EMail Addresses)                                    */
/*                                                                    */
/*                                                                    */
CheckAnsi: PROCEDURE
  thisRC = -1

                        /* install a local error handler              */
  SIGNAL ON ERROR Name InitAnsiEnd

                    /* register the function SysCurPos from REXXUTIL  */
  call rxFuncAdd "SysCurPos", "REXXUTIL", "SysCurPos"

                    /* get and save the current cursor position       */
  curPos = SysCurPos()

                    /* write a CR/LF and the ANSI code for CursorUp   */
  call charOut , D2C(13) || "1B"x || "[1A"

                    /* now get the current cursor position            */
  NewPos=SysCurPos()

                    /* compare the new position to the old position   */
  if LEFT( NewPos,2 ) == LEFT( curPos,2 ) THEN
  do
                    /* ANSI support is OFF                            */
     thisRC = 0

                /* goto the begin of the line and delete the garbage  */
     call CharOut, D2C(13) || copies( " ",4 ) || D2C(13)
  end /* if left( ... */
  else
  do
                    /* ANSI support is ON                             */

                    /* restore the old cursor position                */
    call CharOut , "1B"x || "[B"
    thisRC = 1
  end /* else */

InitAnsiEnd:
RETURN thisRC

Get the current cursor position

 
/* sample routine to get the current cursor position with plain REXX  */
/* and ANSI commands                                                  */
/* Original code is from the ANSICD package from Jamie Hoglund        */

  parse value GetCursorPos() with col row
  say "At program start the cursor was at " || ,
      "Column " || col || ", Row " || row || "."
exit 0

/* ------------------------------------------------------------------ */
/* function: Get the current cursor position                          */
/*                                                                    */
/* call:     GetCursorPos                                             */
/*                                                                    */
/* returns:  col row                                                  */
/*                                                                    */
/* note:     This function works only for display sizes up to 200 for */
/*           columns or rows. The upper left corner is 1,1.           */
/*           The REXXUTIL function SysCurPos uses zero based values   */
/*           (the upper left corner is 0,0).                          */
/*           Caution:                                            v2.90*/
/*           The REXX Queue must be empty for this code to work!      */
/*           If the REXX Queue is not empty, you can use code         */
/*           like                                                     */
/*             - create a new                                         */
/*             - make the new queue the default queue                 */
/*             - call GetCursorPos                                    */
/*             - make the old queue the default queue again           */
/*             - delete the new queue                                 */
/*                                                                    */
GetCursorPos: PROCEDURE
  usedChars = ":;<=>?@ABCD"

  Rc = Charout(,D2C(27) || "[6n")
  Pull Q

                                                             /* v2.30 */
  parse var q 3 y1 +1 y2 +1 3 row +2 6 x1 +1 x2 +1 6 col +2 .

  if pos( y1, usedChars ) <> 0 then
    row = 10 || y2

  if pos( x1, usedChars ) <> 0 then
    col = 10 || x2

return col row

Get the current screen size

/* sample routine to get the current screensize for textmode windows  */
/* without using REXXUTIL functions.                                  */

  parse value GetDisplaySize() with columns rows
  say "The current OS/2 window size is " || ,
      rows || " rows and " || columns || " columns."
exit 0

/* ------------------------------------------------------------------ */
/* function: Get the current display size                             */
/*                                                                    */
/* call:     GetDisplaySize                                           */
/*                                                                    */
/* returns:  columns rows                                             */
/*                                                                    */
/* note:     This function works only for display sizes up to 200 for */
/*           columns or rows. The upper left corner is 1,1.           */
/*           The REXXUTIL function SysCurPos uses zero based values   */
/*           (the upper left corner is 0,0).                          */
/*                                                                    */
GetDisplaySize: PROCEDURE expose thisPos

  usedChars = ":;<=>?@ABCD"

                    /* save current cursor position                   */
  rc = CharOut(, D2C(27) || '[' || "6n")
  pull curPos

                    /* try to set the cursor to the position 200,200  */
  rc = CharOut(, D2C(27) || '[' || "200;200H" )

                    /* get cursor position                            */
  rc = CharOut(, D2C(27) || '[' || "6n")
  pull tPos

                    /* restore current cursor position                */
  rc = CharOut(, substr( curPos,1, length( curPos)-1) || "H" )

                                                             /* v2.30 */
  parse var tPos 3 y1 +1 y2 +1 3 rows +2 6 x1 +1 x2 +1 6 cols +2 .

  if pos( y1, usedChars ) <> 0 then
    rows = 10 || y2

  if pos( x1, usedChars ) <> 0 then
    cols = 10 || x2

RETURN cols rows

Redefine some keys

/* sample code to do some key remapping with ANSI sequences           */
/* see also ANSI ESC Sequences ,                                      */
/* Key codes for key redefinitions and                                */
/* Using function keys                                                */
/*                                                                    */
/* Note: Turning extended keys off is NOT necessary for key     v1.60 */
/*       remapping. This information in RXT&T v1.50 was wrong.  v1.60 */


                        /* set F1 key to HELP<RETURN>                 */
  call CharOut , '1B'x || '[0;59;"HELP";13p'

                        /* set ALT-F10 to EXIT (without RETURN)       */
  call CharOut , '1B'x || '[0;113;"EXIT";p'

                        /* set "A" to ABER (without RETURN)           */
                        /* corrected in RXT&T v1.60                   */
  call CharOut , '1B'x || '[65;"ABER";p'

                        /* reset F1 key to F1                         */
  call CharOut , '1B'x || '[0;59;0;59;p'

Using function keys

To use function keys without the REXXUTIL functions, redefine them with a trailing CR (see also ANSI ESC Sequences, Key codes for key redefinitions, and download RxLBox for a working example):

 
/* sample key redefinitons                                            */

                    /* new definitons for the function keys           */
  keys.0 = 0
  i = keys.0

  i=i+1; keys.i.__org = '59'; keys.i.__new = 'F1'
  i=i+1; keys.i.__org = '60'; keys.i.__new = 'F2'
  i=i+1; keys.i.__org = '61'; keys.i.__new = 'F3'
  i=i+1; keys.i.__org = '62'; keys.i.__new = 'F4'
  i=i+1; keys.i.__org = '63'; keys.i.__new = 'F5'
  i=i+1; keys.i.__org = '64'; keys.i.__new = 'F6'
  i=i+1; keys.i.__org = '65'; keys.i.__new = 'F7'
  i=i+1; keys.i.__org = '66'; keys.i.__new = 'F8'
  i=i+1; keys.i.__org = '67'; keys.i.__new = 'F9'
  i=i+1; keys.i.__org = '68'; keys.i.__new = 'F10'

  keys.0 = i

                    /* ANSI esc sequence                              */
  ansi.__ESC = '1B'x

                    /* special character to detect function keys      */
  specialChar = 'FE'x

                    /* install error handler for CTRL-BREAK           */
  signal on halt

                    /* redefine the function keys                     */
  do i = 1 to keys.0
    call CharOut , ansi.__ESC || '[0;' || keys.i.__org || ';' || ,
        '"' || specialChar || keys.i.__New || specialChar || '"' || ,
        ';13p'
  end /* do i = 1 to keys.0 */

                    /* test the new key definitons                    */
  do forever
    call LineOut, 'Test the function key redefinitions'
    call CharOut, 'Enter a string (F10 to end): '
    userInput = lineIn()

                    /* test for function keys                         */
    parse var UserInput part1 (specialChar) fKey (specialChar) part2

    UserInput = part1 || part2

    say 'Userinput was: "' || UserInput || '"'

    if fkey = '' then
      say 'No function key pressed.'
    else
      say 'Function key "' || fkey || '" pressed.'

    if fkey = 'F10' then
      leave

  end /* do forever */

ProgramEnd:
                    /* undo the key redefinitons                      */
  do i = 1 to keys.0
    call CharOut , ansi.__ESC || '[0;' || keys.i.__org || ';' || ,
         '0;' || keys.i.__org || ';p'
  end /* do i = 1 to keys.0 */

exit

/* error handler for CTRL-BREAK                                       */

Halt:
  say
  say 'Program aborted by the user!'
  signal ProgramEnd

Use ANSI for a password input routine

/* sample input routine for passwords using ANSI sequences to hide    */
/* the input (stolen from a message on a public CompuServe forum)     */
/*                                                                    */

  myPassWord = GetPassword( "Please enter the password: " )

  say "You entered the password: " || myPassword

exit

/* ------------------------------------------------------------------ */
/* function: get a password from the user (without showing it on the  */
/*           screen)                                                  */
/*                                                                    */
/* call:     GetPassword( {prompt} )                                  */
/*                                                                    */
/* where:    prompt - prompt string                                   */
/*                    def.: none                                      */
/*                                                                    */
/* returns:  the entered password                                     */
/*                                                                    */
/* note:     This code only works with ANSI enabled                   */
/*                                                                    */
/*                                                                    */
GetPassword: PROCEDURE
  parse arg prompt

                    /* show the prompt (if any) and set the screen    */
                    /* attributes to notvisible                       */
  call CharOut , prompt || "1B"x || "[8m"

                    /* get the user input                             */
  parse pull password
                    /* reset the screen attributes                    */
  call CharOut , "1B"x || "[0m"

RETURN password

Using the lower right corner of the display

To print a character to the lower right corner of the screen without scrolling you must turn off the word wrap function of the ANSI driver (see also ANSI ESC Sequences):

/* code to show how to use the lower right corner of the display      */

                    /* ESC code for ANSI sequences                    */
  ansi.__ESC = "1B"x

                    /* ANSI sequences to position the cursor in the   */
                    /* upper right corner                             */
  ansi.__Pos0 = ansi.__ESC || "[1;1H"

                    /* ANSI code to turn word wrap off                */
  ansi.__WordWrapOff = ansi.__ESC || "[7l"

                    /* ANSI code to turn word wrap on                 */
  ansi.__WordWrapOn  = ansi.__ESC || "[7h"

                    /* empty line for the menu frame                  */
  Menu.__emptyLine   = "º" || copies( " ", 78 ) || "º"

                    /* separator lines for the menu frame             */
  Menu.__FrameLine1  = copies( "Í", 78 )
  Menu.__FrameLine2  = copies( "Ä", 76 )

                    /* menu frame                                     */
  Menu.__MenuMask = ,
     ansi.__Pos0                          || ,  /* position cursor    */
     ansi.__WordWrapOn                    || ,  /* turn word wrap on! */
     "É"  || Menu.__FrameLine1 || "»"     || ,  /* menu frame         */
     Menu.__emptyLine                     || ,
     Menu.__emptyLine                     || ,
     "º " || Menu.__FrameLine2 || " º"    || ,
     Menu.__emptyLine                     || ,
     "Ì"  || Menu.__FrameLine1 || "¹"     || ,
     copies( Menu.__emptyLine, 14 )       || ,
     "Ì"  || Menu.__FrameLine1 || "¹"     || ,
     Menu.__emptyLine                     || ,
     "º " || Menu.__FrameLine2 || " º"    || ,
     Menu.__emptyLine                     || ,
     ansi.__WordWrapOff                   || ,  /* turn word wrap off */
     "È"  || Menu.__FrameLine1 || "¼"     || ,  /* last menu line     */
     ansi.__Pos0                          || ,  /* position cursor    */
     ansi.__WordWrapOn                          /* turn word wrap on  */

                    /* clear the screen                               */
  'cls'
                    /* show the menu frame                            */
  call CharOut , Menu.__MenuMask

                    /* position the cursor in the middle of the       */
                    /* screen                                         */
  call CharOut , ansi.__ESC || "[12;30H"

                    /* wait for a key from the user                   */
  "@pause"

Date converting

Unpack packed data

Unpack routine from Steve Pitts (see EMail Addresses) Captured from a message in a public CompuServe Forum

/* ------------------------------------------------------------------ */
/* function: unpack routine for packed data (from mainframes)         */
/*                                                                    */
/* call:     unpack packed_str {,num_dec}                             */
/*                                                                    */
/* where:    packed_str = the packed data                             */
/*           num_dec = number of decimals (def.: 0)                   */
/*                                                                    */
/*                                                                    */
/* returns:  the unpacked number or "" in case of an error            */
/*                                                                    */
Unpack: PROCEDURE
  parse arg packed_str, num_dec

  if num_dec = "" then
    num_dec=0

                        /* Convert packed data to hex and split into  */
                        /* number and sign portions                   */
  hex_str=c2x( packed_str )
  dec_str=left( hex_str, length( hex_str )-1 )
  packed_sign=right( hex_str, 1 )

                        /* Check that sign and numeric portions have  */
                        /* valid values                               */
  if verify( packed_sign, "ABCDEF" ) > 0 then
    return ""

  if verify( dec_str, "0123456789" ) > 0 then
    return ""

                        /* Are there enough digits for the decimal    */
                        /* point??                                    */
  if num_dec > length( dec_str ) then
    return ""

                        /* If sign portion indicates a negative       */
                        /* number then oblige                         */
  if pos( packed_sign, "BD" ) > 0 then
    dec_str=0-dec_str

                        /* If there is a decimal point then add it at */
                        /* the appropriate place                      */
  if num_dec > 0 then
    dec_str=insert( ".", dec_str, length( dec_str )-num_dec )

RETURN dec_str

EBCDIC to ASCII & ASCII to EBCDIC

captured from a message in a public CompuServe Forum Author: Dick Goran, (see EMail Addresses)

(see also RXGWA1 - ASCII <-> EBCDIC)

The tables below can be used with the REXX TRANSLATE() instruction:

/**********************************************************************/
/*       EBCDIC To ASCII & ASCII To EBCDIC Translate Tables           */
/**********************************************************************/
EBCDIC_OUT = XRANGE(000, 003) ||, /* NUL SOH STX ETX                  */
             XRANGE(055, 055) ||, /* EOT                              */
             XRANGE(045, 047) ||, /* ENQ ACK BEL                      */
             XRANGE(022, 022) ||, /* BS                               */
             XRANGE(005, 005) ||, /* HT                               */
             XRANGE(037, 037) ||, /* LF                               */
             XRANGE(011, 018) ||, /* VT FF CR SO SI DLE DC1 DC2       */
             XRANGE(000, 000) ||, /* DC3                              */
             XRANGE(060, 061) ||, /* DC4 NAK                          */
             XRANGE(050, 050) ||, /* SYN                              */
             XRANGE(038, 038) ||, /* ETB                              */
             XRANGE(024, 025) ||, /* CAN EM                           */
             XRANGE(063, 063) ||, /* SUB                              */
             XRANGE(039, 039) ||, /* ESC                              */
             XRANGE(028, 031) ||, /* FS GS RS US                      */
             XRANGE(090, 090) ||, /* !                                */
             XRANGE(127, 127) ||, /* "                                */
             XRANGE(123, 123) ||, /* #                                */
             XRANGE(091, 091) ||, /* $                                */
             XRANGE(108, 108) ||, /* %                                */
             XRANGE(080, 080) ||, /* &                                */
             XRANGE(125, 125) ||, /* '                                */
             XRANGE(077, 077) ||, /* (                                */
             XRANGE(093, 093) ||, /* )                                */
             XRANGE(092, 092) ||, /* *                                */
             XRANGE(078, 078) ||, /* +                                */
             XRANGE(107, 107) ||, /* ,                                */
             XRANGE(096, 096) ||, /* -                                */
             XRANGE(075, 075) ||, /* .                                */
             XRANGE(097, 097) ||, /* /                                */
             XRANGE(240, 249) ||, /* 0 - 9                            */
             XRANGE(122, 122) ||, /* :                                */
             XRANGE(094, 094) ||, /* ;                                */
             XRANGE(076, 076) ||, /* <                                */
             XRANGE(126, 126) ||, /* =                                */
             XRANGE(110, 110) ||, /* >                                */
             XRANGE(111, 111) ||, /* ?                                */
             XRANGE(124, 124) ||, /* @                                */
             XRANGE(193, 201) ||, /* A - I                            */
             XRANGE(209, 217) ||, /* J - R                            */
             XRANGE(226, 233) ||, /* S - Z                            */
             XRANGE(173, 173) ||, /* [                                */
             XRANGE(224, 224) ||, /* \                                */
             XRANGE(189, 189) ||, /* ]                                */
             XRANGE(095, 095) ||, /* ^                                */
             XRANGE(109, 109) ||, /* _                                */
             XRANGE(121, 121) ||, /* `                                */
             XRANGE(129, 137) ||, /* a - i                            */
             XRANGE(145, 153) ||, /* j - r                            */
             XRANGE(162, 169) ||, /* s - z                            */
             XRANGE(139, 139) ||, /* {                                */
             XRANGE(106, 106) ||, /* |                                */
             XRANGE(155, 155) ||, /* }                                */
             XRANGE(161, 161) ||, /* ~                                */
             XRANGE(007, 007)     /* DEL                              */

 ASCII_OUT = XRANGE(000, 003) ||, /* NUL SOH STX ETX                  */
             XRANGE(000, 000) ||, /* PF                               */
             XRANGE(009, 009) ||, /* HT                               */
             XRANGE(000, 000) ||, /* LC                               */
             XRANGE(127, 127) ||, /* DEL                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* SMM                              */
             XRANGE(011, 018) ||, /* VT CR SO SI DLE DC1 DC2          */
             XRANGE(000, 000) ||, /* TM                               */
             XRANGE(000, 000) ||, /* RES                              */
             XRANGE(000, 000) ||, /* NL                               */
             XRANGE(008, 008) ||, /* BS                               */
             XRANGE(000, 000) ||, /* IL                               */
             XRANGE(024, 025) ||, /* CAN EM                           */
             XRANGE(000, 000) ||, /* CC                               */
             XRANGE(000, 000) ||, /* CU1                              */
             XRANGE(028, 031) ||, /* FS GS RS US                      */
             XRANGE(000, 000) ||, /* DS                               */
             XRANGE(000, 000) ||, /* SOS                              */
             XRANGE(028, 028) ||, /* FS                               */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* BYP                              */
             XRANGE(010, 010) ||, /* LF                               */
             XRANGE(023, 023) ||, /* ETB                              */
             XRANGE(027, 027) ||, /* ESC                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* SM                               */
             XRANGE(000, 000) ||, /* CU2                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(005, 007) ||, /* ENQ ACK BEL                      */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(022, 022) ||, /* SYN                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* PN                               */
             XRANGE(000, 000) ||, /* RS                               */
             XRANGE(000, 000) ||, /* UC                               */
             XRANGE(004, 004) ||, /* EOT                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* CU3                              */
             XRANGE(020, 020) ||, /* DC4                              */
             XRANGE(021, 021) ||, /* NAK                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(026, 026) ||, /* SUB                              */
             XRANGE(032, 032) ||, /* space                            */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* cent sign                        */
             XRANGE(046, 046) ||, /* .                                */
             XRANGE(060, 060) ||, /* <                                */
             XRANGE(040, 040) ||, /* (                                */
             XRANGE(043, 043) ||, /* +                                */
             XRANGE(033, 033) ||, /* |                                */
             XRANGE(038, 038) ||, /* &                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(033, 033) ||, /* !                                */
             XRANGE(036, 036) ||, /* $                                */
             XRANGE(042, 042) ||, /* *                                */
             XRANGE(041, 041) ||, /* )                                */
             XRANGE(059, 059) ||, /* ;                                */
             XRANGE(000, 000) ||, /* not symbol                       */
             XRANGE(045, 045) ||, /* -                                */
             XRANGE(047, 047) ||, /* /                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(124, 124) ||, /* |                                */
             XRANGE(044, 044) ||, /* ,                                */
             XRANGE(037, 037) ||, /* %                                */
             XRANGE(095, 095) ||, /* _                                */
             XRANGE(062, 062) ||, /* >                                */
             XRANGE(063, 063) ||, /* ?                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(096, 096) ||, /* `                                */
             XRANGE(058, 058) ||, /* :                                */
             XRANGE(035, 035) ||, /* #                                */
             XRANGE(064, 064) ||, /* @                                */
             XRANGE(039, 039) ||, /* '                                */
             XRANGE(061, 061) ||, /* =                                */
             XRANGE(034, 034) ||, /* "                                */
             XRANGE(097, 105) ||, /* a - i                            */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(106, 114) ||, /* j - r                            */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(126, 126) ||, /* ~                                */
             XRANGE(115, 122) ||, /* s - z                            */
             COPIES(192 - 170, D2C(0)) ||,
             XRANGE(123, 123) ||, /* {                                */
             XRANGE(065, 073) ||, /* A - I                            */
             COPIES(209 - 202, D2C(0)) ||,
             XRANGE(074, 082) ||, /* J - R                            */
             COPIES(224 - 218, D2C(0)) ||,
             XRANGE(092, 092) ||, /* \                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(083, 090) ||, /* S - Z                            */
             COPIES(240 - 234, D2C(0)) ||,
             XRANGE(048, 057) ||, /* J - R                            */
             COPIES(256 - 250, D2C(0))

Uppercase & Lowercase including German "Umlaute"

/* sample code to translate a string to uppercase or lowercase which  */
/* also handles the German "Umlaute"                                  */
/* Note that there's an country-dependent uppercase translation v1.80 */
/* routine in the new REXXUTIL DLL. Object-Oriented REXX             */
    say "Lower() " lower( "AbcdEF Ö Ä Ü ß 1234567890" )
    say "Upper() " upper( "aBcDef ö ä ü ß 1234567890" )
exit

/* ------------------------------------------------------------------ */
/* function: Convert a char or string to uppercase                    */
/*                                                                    */
/* call:     Upper string                                             */
/*                                                                    */
/* where:    string - string to convert                               */
/*                                                                    */
/* returns:  the converted string                                     */
/*                                                                    */
/* note:     This implementation handles German "Umlaute"             */
/*                                                                    */
Upper: PROCEDURE
  parse arg thisString

RETURN translate( thisString, "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß" ,,
                              "abcdefghijklmnopqrstuvwxyzäöüß" )

/* ------------------------------------------------------------------ */
/* function: Convert a char or string to lowercase                    */
/*                                                                    */
/* call:     Lower string                                             */
/*                                                                    */
/* where:    string - string to convert                               */
/*                                                                    */
/* returns:  the converted string                                     */
/*                                                                    */
/* note:     This implementation handles German "Umlaute"             */
/*                                                                    */
Lower: PROCEDURE
  parse arg thisString

RETURN translate( thisString,  "abcdefghijklmnopqrstuvwxyzäöüß" ,,
                               "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß" )

Date converting routine - 1 -

Captured from a message in a public CompuServe Forum

Note from the author from the PL/1 version

Julian (sense 1) date routines, handling Julian (sense 2) and Gregorian calendars. Algorithm is valid from 4713 B.C. to 19,999 A.D. This version is known to be free of errors.

Based on Pascal code copyright 1985 by Michael A. Covington, published in P.C. Tech Journal, December 1985, based on formulae appearing in Astronomical Formulae for Calculators by Jean Meeus. Reconversion to normal Julian epoch, integer arithmetic, 4000-year correction, and translation to PL/I by John W. Kennedy

Historical exceptions _not_ allowed for in this module: Until Julius Caesar established the Julian calendar in 45 B.C., calendars were irregular. This module assumes the Julian calendar back to 4713 B.C. The Julian calendar was altered in 8 B.C. From 45 B.C. to 8 B.C., the months were Jan=31, Feb=29(30), Mar=31, Apr=30, May=31, Jun=30, Jul=31, Aug=30, Sep=31, Oct=30, Nov=31, Dec=30 This module assumes the month lengths as we know them. Leap years from 45 B.C. to 8 A.D. were miscalculated: (45, 42, 39, 36, 33, 30, 27, 24, 21, 18, 15, 12, 9, then none at all until 8 A.D.) This module assumes leap years every four years, as they were meant to have been. January 1 was not always the first day of the year. The United Kingdom, in particular, started the year on March 25 until 1752. (However, the year ended on December 31, leaving the days between in limbo.) This module assumes January 1 is the first day of the year. Leap-year day was originally done by having February 24 (25 from 45 to 8 B.C.) twice. This module assumes Leap-year day is February 29.

The "Transition" argument is the first Julian date to be considered as belonging to the Gregorian calendar. Usual values are: 2299161 = October 5/15, 1582, as in Rome, or 2361222 = September 3/14, 1752, as in the United Kingdom and the American colonies

/* sample routines to convert dates                                   */

  call Charout , "Enter a date in the format dd.mm.yyyy: "
  curDMYDate = lineIn()

  curJulianDate = DMYToJulian( curDMYDate )
  say "DMYToJulian(" || curDMYDate || ") is " || curJulianDate

  say "JulianToDMY(" || curJulianDate || ") is " || ,
      JulianToDMY( curJulianDate )

exit 0

/* ------------------------------------------------------------------ */
/* function: Convert a date from Julian to DMY                        */
/*                                                                    */
/* call:     JulianToDMY julianDate {trans}                           */
/*                                                                    */
/* where:    julianDate - the date in julian format                   */
/*           trans - see note above                                   */
/*                                                                    */
/* returns:  the date in the format dd.mm.yyyy                        */
/*                                                                    */
/*                                                                    */
JulianToDMY: PROCEDURE
  Arg J Trans

  if Trans = "" then
    Trans = 2299161

  if J < Trans then
    A = J
  Else
  do
    AA = J - 1721120
    AC = Trunc(AA / 1460969)
    AB = 31 * AC
    AA = AA - AC * 1460969
    AC = Trunc(AA / 146097)
    AB = AB + 3 * AC
    AA = AA - AC * 146097
    if AA = 146096 then
      AB = AB + 3
    Else
      AB = AB + Trunc(AA / 36524)
    A = J + (AB - 2)
  end
  B = A + 1524
  C = Trunc((20 * B - 2442) / 7305)
  D = Trunc(1461 * C / 4)
  EE = B - D
  E = Trunc(10000 * EE / 306001)
  YMDD = EE - Trunc(306001 * E / 10000)
  if E >= 14 then
    YMDM = E - 13
  else
    YMDM = E - 1
  if YMDM > 2 then
    Y = C - 4716
  else
    Y = C - 4715
  if Y < 1 then
    YMDY = Y - 1
  else
    YMDY = Y

RETURN YMDD || '.' || YMDM || '.' || YMDY

/* ------------------------------------------------------------------ */
/* function: Convert a date from DMY to Julian                        */
/*                                                                    */
/* call:     DMYToJulian dmyDate {trans}                              */
/*           trans - see note above                                   */
/*                                                                    */
/* where:    dmyDate - the date in the format dd.mm.yyyy              */
/*                                                                    */
/* returns:  the date in Julian format                                */
/*                                                                    */
/*                                                                    */
DMYToJulian: PROCEDURE
  parse arg dmyDate trans

  parse var dmyDate YMDD "." YMDM "." YMDY

  if Trans = "" then
    Trans = 2299161

  AY = YMDY
  if YMDY < 0 then
    Y = YMDY + 4717
  else
    Y = YMDY + 4716
  if YMDM < 3 then
  do
    M = YMDM + 12
    Y = Y - 1
    AY = AY - 1
  end
  else
    M = YMDM
  D = Trunc((1461 * Y) / 4) + Trunc((153 * (M + 1)) / 5) + YMDD - 1524
  G = D + 2 - Trunc(AY / 100) + Trunc(AY / 400) - Trunc(AY / 4000)
  if G >= Trans then
    thisRC = G
  else
    thisRC = D

RETURN thisRC

Date converting routine - 2 -

/* sample routine to convert a date in the format dd/mm/yy into the   */
/* base date format                                                   */
/*                                                                    */
/* Description from the author:                                       */
/*   routine to convert a date passed in YY/MM/DD format (assumes the */
/*   date is 19YY/MM/DD ) to Base date format which is based upon an  */
/*   imaginary calendar date of 1/1/0001 it then assumes there is a   */
/*   leap year every 4 years and every 400 years but not if the year  */
/*   is divisble by 100                                               */
/*                                                                    */
/* Note: I do NOT know the author of this code.                       */
/*       I found this code on an IBM BBS.                             */
/*                                                                    */

  do forever
    say ""
    say "Test the routine CalcBaseDate against the REXX function date"
    say "  Note that the REXX function date only handles dates AFTER"
    say "  the 01.01.1980!"
    say "Enter a date to convert (dd.mm.yy, RETURN to end):"
    testDate = strip( lineIn() )

    if testDate = "" then
      leave

    say "  result of CalcBaseDate( """ || testDate || """) is: " || ,
         CalcBaseDate( testDate )

                        /* save the current date                      */
    oldDate = date( "E" )

                        /* set the current date to the testdate to    */
                        /* test the routine CalcBaseDate against the  */
                        /* REXX function date( B )                    */
    "@date " testDate
    say "  result of the REXX function date( ""B"" ) is: " || ,
         date( "B" )

                        /* restore the current date                   */
    "@date " oldDate
  end /* do forever */
exit 0

/* ------------------------------------------------------------------ */
/* function: Convert a date in the format dd.mm.yy into the base date */
/*           format                                                   */
/*                                                                    */
/* usage:    CalcBaseDate dateToConvert                               */
/*                                                                    */
/* where:    dateToConvert - date to convert in the format dd.mm.yy   */
/*                                                                    */
/* returns:  the date in base date format                             */
/*                                                                    */
CalcBaseDate: PROCEDURE

                        /* initialize routine                         */
  NonLeap.   = 31
  NonLeap.0  = 12
  NonLeap.2  = 28
  NonLeap.4  = 30
  NonLeap.6  = 30
  NonLeap.9  = 30
  NonLeap.11 = 30

                /* grab parameter and store it in cyear cmonth cdate  */
  parse arg cdate "." cmonth "." cyear .

                /* grab year and convert it to YYYY                   */
                /* simulate the behaviour of the REXX function date() */
  if length( cyear ) <= 2 then
    if cyear < 80 then
      fullyear = "20" || cyear
    else
      fullyear = "19" || cyear
  else
    fullyear = cyear

  numyears = fullyear -1
  basedays = numyears * 365
  QuadCentury = numyears % 400
  Century = numyears % 100
  LeapYears = numyears % 4
  basedays = basedays + (((LeapYears - Century) + QuadCentury) - 1)

  do i = 1 to (cmonth -1)
    if i <> "2" then
      basedays = basedays + NonLeap.i
    else /* find if it's a leap year or not */
      if (fullyear // 4) > 0 then
        basedays=basedays + 28
      else
        if ((fullyear // 100) = 0) & ((fullyear // 400) > 0) then
        do
                        /* century not divisble by 400                */
          basedays = basedays + 28
        end /* if */
        else
        do
                        /* quad century or regular leap year          */
          basedays = basedays + 29
        end /* else */
  end /* do */

  basedays = basedays + cdate
return basedays

Convert values from/to INTEL format

On Intel processors words and doublewords are saved in the so-called INTEL format (LSB - last signifcant byte first). To use them, you must convert them into the MSB format (MSB - most significant byte first). Before using the following routine, you must convert the value into a hex string (see Get the display resolution for an example).

 
/* ------------------------------------------------------------------ */
/* function: Convert an WORD or DWORD from LSB format to MSB format   */
/*           and vice versa                                           */
/*                                                                    */
/* call:     LSB2MSB inputHexString                                   */
/*                                                                    */
/* where:    inputHexstring - input value as hexstring                */
/*                            (e.g. "3412", "78563412")               */
/*                                                                    */
/* output:   value in MSB format as hexstring                         */
/*           (e.g. "1234", "12345678")                                */
/*                                                                    */
LSB2MSB: PROCEDURE
  HexZiffer = arg(1)                                         /* v3.00 */
  Len = Length(HexZiffer)                                    /* v3.00 */
  If (Len // 2) then                                         /* v3.00 */
     HexZiffer = Right(HexZiffer, Len + 1, '0')              /* v3.00 */
  RETURN strip( translate( "12345678",,                      /* v3.00 */
                           HexZiffer, "78563412" ) )         /* v3.00 */

Formatting numbers

/* sample routine to format a number into the format                  */
/*  nnn.nnn.nnn                                                       */
/* and vice versa                                                     */
/*                                                                    */
/* Source: I found routines of this type in various messages on the   */
/*         IBM REXX forums                                            */
/*         (see also EdmREXX - misc. functions for REXX)              */
/*                                                                    */
  do forever

    call CharOut , "Enter a number (RETURN to end): "
    thisNumber = lineIn()
    if thisNumber = "" then
      leave
    else
    do
      thatNumber = FormatNumber( thisNumber )
      call LineOut , "Result of FormatNumber( " || thisNumber || " ) is " ,
                     thatNumber

      call LineOut , "Result of UnFormatNumber( " || thatNumber || " ) is " ,
                     UnFormatNumber( thatNumber )
    end /* else */
  end /* do forever */

exit

/* ------------------------------------------------------------------ */
/* function: Format a number like 123456789.44 into the format        */
/*           123,456,789.44                                           */
/*                                                                    */
/* call:     FormatNumber number_to_format                            */
/*                                                                    */
/* where:    number_to_format                                         */
/*                                                                    */
/* returns:  the formatted number                                     */
/*                                                                    */
/* note:     works for all numbers up to (but not including)          */
/*           1.000,000,000,000,000.0                                  */
/*                                                                    */
/* Author:   Graham Ewart                                             */
/*                                                                    */
FormatNumber: PROCEDURE expose (exposeList)
  parse value arg(1) with whole "." decs

  formattedNumber = strip( reverse( translate( "abc,def,ghi,jkl,mno",,
                                   reverse(whole),,
                                   "abcdefghijklmno",",")),"L",",")

  if decs <> "" then
    formattedNumber = formattedNumber || "." || decs
RETURN formattedNumber

/* ------------------------------------------------------------------ */
/* function: Unformat a number like 123,456,789.44 into the format    */
/*           123456789.44                                             */
/*                                                                    */
/* call:     UnFormatNumber number_to_unformat                        */
/*                                                                    */
/* where:    number_to_unformat                                       */
/*                                                                    */
/* returns:  the unformatted number                                   */
/*                                                                    */
/* note:     works for all numbers                                    */
/*                                                                    */
UnFormatNumber: PROCEDURE

RETURN space( translate( arg(1), " ", "," ) , 0, )

Convert ASCII 850 string into/from ISO 8859-1 (1004) string

 
/* ------------------------------------------------------------------ */
/* function: Convert an ASCII 850 string into an ISO 8859-1           */
/*           (1004) string and vice versa                             */
/*                                                                    */
/* call:     PC_ISOB thisString, outP                                 */
/*                                                                    */
/* where:    thisString - the string to convert                       */
/*           outP - function code, either                             */
/*                    1004 to convert to ISO                          */
/*                  or                                                */
/*                     850 to convert to ASCII                        */
/*                                                                    */
/* output:   the converted string                                     */
/*                                                                    */
/* Notes:    Note that this not a complete codepage conversion.       */
/*           We only care about the letters.                          */
/*                                                                    */
/* Author:   Oliver Heidelbach (see EMail Addresses)                  */
/*                                                                    */
PC_ISO: PROCEDURE

  PARSE ARG thisString, outp

  aISO = 'a1 a2 a3 bf c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf d0',
         'd1 d2 d3 d4 d5 d6 d8 d9 da db dc dd de df e0 e1 e2 e3 e4 e5 e6',
         'e7 e8 e9 ea eb ec ed ee ef f0 f1 f2 f3 f4 f5 f6 f8 f9 fa fb fc',
         'fd fe ff'

  aPC =  'ad bd 9c a8 b7 b5 b6 c7 8e 8f 92 80 d4 90 d2 d3 de d6 d7 d8 d1',
         'a5 d2 d3 d4 e5 99 d8 eb e9 ea 9a ed e8 e1 85 a0 83 c6 84 86 91',
         '87 8a 82 88 89 8d a1 8c 8b d0 a4 95 a2 93 e4 94 9b 97 a3 96 81',
         'ec e7 98'

  if outp = 1004 then
    convbuf = Translate(thisString, X2C(aISO), X2C(aPC))
  else
    if outp = 850 then
      convbuf = Translate(thisString, X2C(aPC), X2C(aISO))

RETURN convbuf

Convert Microsoft/IEEE Float binary into a string in Classic REXX

(see also Convert Microsoft/IEEE Float binary into a string in Object REXX)

/**********************************************************************/
/* These routines are the original work of Thos Davis                 */
/* (see EMail Addresses)                                              */
/* and to the best of his knowledge do not include any copyrighted    */
/* materials.                                                         */
/*                                                                    */
/* These routines are hereby released into the Public Domain          */
/**********************************************************************/
/* Microsoft/IEEE Float binary:                                       *
  +--------------------------------------------------------------------+
  |bit |0 1 2 3 4 5 6 7 8 9 A B C D E F 0 1 2 3 4 5 6 7 8 9 A B C D E F|
  +====+=============================================+=+===============+
  |MKS |              mantissa                       |s|   exponent    |
  +----+---------------------------------------------+-+-------------+-|
  |IEEE|              mantissa                       |    exponent   |s|
  +--------------------------------------------------+---------------+-+
                                                                      */
/* In both cases, the mantissa is the lower (least significant)       */
/* 23 bits (plus an implied value of 1 for bit 24, the most           */
/* significant bit of the mantissa), the sign is one bit, and         */
/* the exponent is 8 bits.                                            */
/*                                                                    */
/* Because the mantissa has a 'virtual bit' whose value is always 1,  */
/* the exponent is used to determine if the value is 0.               */
/*                                                                    */
/* IEEE Double Float binary is the same format as the single Float    */
/* but the mantissa is 52 bits long (for 53 bits of significant       */
/* binary digits [is that bigits?] after including the 'virtual 1'    */
/* most significant bit) and the exponent is 11 bits long.            */
/*                                                                    */
/* !!! I M P O R T A N T !!!                                          */
/*                                                                    */
/* NUMERIC DIGITS should be set to about 16 to get the full value of  */
/* Doubles. If these procedures are made into ROUTINES, it will be    */
/* necessary to add the NUMERIC DIGITS setting to DoubleToString and  */
/* GeneralFloat.                                                      */
/*                                                                    */
/* !!! A L S O   I M P O R T A N T !!!                                */
/*                                                                    */
/* These functions do not recognize the special values                */
/*    +INF    plus infinity                                           */
/*    -INF    minus infinity                                          */
/*    +NAN    not a number                                            */
/*    -NAN    not a number                                            */
/*                                                                    */

mksToString: procedure
  TheFloat = arg(1)

                    /* mks is the format used in older versions of    */
                    /* MicroSoft BASIC and is, for some bizarre       */
                    /* reason, used as the index value in the QWK     */
                    /* BBS message packing scheme                     */

                    /* Intel uses different BYTE ordering and BIT     */
                    /* ordering so byte strings must be REVERSED to   */
                    /* make all ordering the same                     */
    bFloat = Reverse( TheFloat )

                    /* There is no c2b function                       */
    bFloat = x2b( c2x( bFloat ) )

                    /* make sure its 32 bits long                     */
    bFloat = Right( bFloat, 32, '0' )
    fMantissa = '1' || Right( bFloat, 23 )
    fExponent = Left( bFloat, 8 )
    fSign = SubStr( bFloat, 9, 1 )

                    /* I found the magicNumber values by trial and    */
                    /* error                                          */
    magicNumber = 152

return GeneralFloat( fSign, fMantissa, fExponent, magicNumber )


FloatToString: procedure
  TheFloat = arg(1)

    bFloat = Reverse( TheFloat )
    bFloat = x2b( c2x( bFloat ) )
    bFloat = Right( bFloat, 32, '0' )
    fMantissa = '1' || Right( bFloat, 23 )
    fExponent = SubStr( bFloat, 2, 8 )
    fSign = Left( bFloat, 1 )
    magicNumber = 150
return GeneralFloat( fSign, fMantissa, fExponent, magicNumber )


DoubleToString: procedure
  TheDouble = arg(1)

    bDouble = Reverse( TheDouble )
    bDouble = x2b( c2x( bDouble ) )
    bDouble = Right( bDouble, 64, '0' )
    dMantissa = '1' || Right( bDouble, 52 )
    dExponent = SubStr( bDouble, 2, 11 )
    dSign = Left( bDouble, 1 )
    magicNumber = 1075
return GeneralFloat( dSign, dMantissa, dExponent, magicNumber )


GeneralFloat: procedure
  theSign = arg(1)
  theMantissa = arg(2)
  theExponent = arg(3)
  magicNumber = arg(4)

    if theExponent = 0 then
        ascFloat = 0
    else
      do
        decMantissa = x2d( b2x( theMantissa ) )
        decExponent = x2d( b2x( theExponent ) )
        ascFloat = decMantissa * ( 2 ** ( decExponent - magicNumber ))
      end

    if theSign then
        ascFloat = '-'ascFloat

return ascFloat

AN ADDENDUM

While converting from binary fractions to decimal fractions has some inherent inaccuracies, the REXX procedures I gave have some additional ones built in. REXX does not use binary arithmetic (at least it is not supposed to). Instead it uses decimal methods modeled on human arithmetic systems. This gives better results for decimal numbers, but tends to make arithmetic with binary fractions somewhat less accurate.

Because of this, and because I use arithmetic on the numbers when converting, _sometimes_ 'conversion artifacts' will be introduced which result in a representation slightly greater or less than the value which is returned by standard C library functions (e.g. printf() ). For example 0.5 decimal (1/2), which is 0.1 binary, should translate perfectly from one system to the other, will be translated from the double to 0.5000000000000002 using DoubleToString. Likewise 0.0625 decimal (1/16), which is 0.0001 binary, is translated as 0.06250000000000001.

Additionally, the results are dependent on the value of NUMERIC DIGITS. For example: 1.0 is translated by FloatToString() as 0.99999999999 when NUMERIC DIGITS is set to 11 (decimal), and 0.5 (decimal) is translated by DoubleToString as 0.49999999999999999999 when NUMERIC DIGITS is 20.

It is important to note that the actual value stored in the file is not changed.

If it is important to see very precise translations, these procedures may not be for you. However, with the information on the format of the numbers, you may be able to devise your own conversion procedures.

Additionally, I did not include the IEEE +INFINITY, -INFINITY, +NOT-A-NUMBER, and -NOT-A-NUMBER, because I do not have documentation on these values. However, based on actual conversions by Borland's C++ for OS/2 (version 1.5), I am led to believe that an exponent whose bits are all set to 1 indicates a SPECIAL VALUE. If the exponent is all ones, and the mantissa (with the virtual bit) has only its most significant bit set to 1, then that is INFINITY (+/- depending on the sign), and if the two most significant bits (including the virtual bit) are both set to 1 and no other bits in the mantissa are set to 1, then that is NOT-A-NUMBER. If the other bits are set to 1, I don't know what that means.

I use a test for the special exponent in my own routines (I use ObjectREXX) and then call SpecialFloat if it matches. If you use this type of procedure, then it may be necessary for your program to test for these values before performing additional math on them! I do not know if the MicroSoft Format used by early versions of BASIC has any special values.

::ROUTINE FloatToString PUBLIC
    ...

    if fExponent = '11111111' then
      return SpecialFloat( fSign, fMantissa, 'S' )
    else
      return GeneralFloat( ... )


::ROUTINE SpecialFloat
  use arg theSign, theMantissa, theType

    SELECT
      WHEN theType = 'S' then lenMantissa = 24
      WHEN theType = 'D' then lenMantissa = 53
    END

    SELECT
      WHEN theMantissa = '1'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'INFINITY'
      WHEN theMantissa = '11'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'NOT-A-NUMBER'
      OTHERWISE
        ieeeSpecial = 'UNKNOWN-MEANING'
    END /* SELECT */

    if theSign then
      ieeeSpecial = '-'ieeeSpecial
    else
      ieeeSpecial = '+'ieeeSpecial

    return 'IEEE:' ieeeSpecial

Convert Microsoft/IEEE Float binary into a string in Object REXX

(see also Convert Microsoft/IEEE Float binary into a string in Classic REXX; especially the addendum)

/**********************************************************************/
/* These routines are the original work of Thos Davis                 */
/* (see EMail Addresses)                                              */
/* and to the best of his knowledge do not include any copyrighted    */
/* materials.                                                         */
/*                                                                    */
/* These routines are hereby released into the Public Domain          */
/**********************************************************************/
/* Microsoft/IEEE Float binary:                                       *
 +--------------------------------------------------------------------+
 |bit |0 1 2 3 4 5 6 7 8 9 A B C D E F 0 1 2 3 4 5 6 7 8 9 A B C D E F|
 +====+=============================================+=+===============+
 |MKS |              mantissa                       |s|   exponent    |
 +----+---------------------------------------------+-+-------------+-|
 |IEEE|              mantissa                       |    exponent   |s|
 +--------------------------------------------------+---------------+-+
                                                                      */
/* In both cases, the mantissa is the lower (least significant)       */
/* 23 bits (plus an implied value of 1 for bit 24, the most           */
/* significant bit of the mantissa), the sign is one bit, and         */
/* the exponent is 8 bits.                                            */
/*                                                                    */
/* Because the mantissa has a 'virtual bit' whose value is always 1,  */
/* the exponent is used to determine if the value is 0.               */
/*                                                                    */
/* IEEE Double Float binary is the same format as the single Float    */
/* but the mantissa is 52 bits long (for 53 bits of significant       */
/* binary digits [is that bigits?] after including the 'virtual 1'    */
/* most significant bit) and the exponent is 11 bits long.            */
/*                                                                    */
/* !!! I M P O R T A N T !!!                                          */
/*                                                                    */
/* NUMERIC DIGITS should be set to about 16 to get the full value of  */
/* Doubles                                                            */
/*                                                                    */
/* !!! A L S O   I M P O R T A N T !!!                                */
/*                                                                    */
/* These functions may not correctly recognize the special values     */
/*    +INF    plus infinity                                           */
/*    -INF    minus infinity                                          */
/*    +NAN    not a number                                            */
/*    -NAN    not a number                                            */
/*                                                                    */

::ROUTINE mksToString PUBLIC
  use arg TheFloat

                    /* mks is the format used in older versions of    */
                    /* MicroSoft BASIC and is, for some bizarre       */
                    /* reason, used as the index value in the QWK     */
                    /* BBS message packing scheme                     */

  if TheFloat~Length \= 4 then
    return 'NOT-A-FLOAT'

    bFloat = TheFloat~Reverse~c2x~x2b~Right(32,'0')
    fMantissa = '1' || bFloat~Right(23)
    fExponent = bFloat~Left( 8 )
    fSign = bFloat~SubStr( 9, 1 )
    magicNumber = 152
    return GeneralFloat( fSign, fMantissa, fExponent, magicNumber, Digits() )


::ROUTINE FloatToString PUBLIC
  use arg TheFloat

  if TheFloat~Length \= 4 then
    return 'NOT-A-FLOAT'

    bFloat = TheFloat~Reverse~c2x~x2b~Right(32,'0')
    fMantissa = '1' || bFloat~Right(23)
    fExponent = bFloat~SubStr( 2, 8 )
    fSign = bFloat~Left(1)
    magicNumber = 150

                    /* IS SPECIAL VALUE                               */
    if fExponent = '11111111' then
      return SpecialFloat( fSign, fMantissa, 'S' )
    else
      return GeneralFloat( fSign, fMantissa, fExponent, magicNumber, Digits() )


::ROUTINE DoubleToString PUBLIC
  use arg TheDouble
  NUMERIC DIGITS 16

  if TheFloat~Length \= 8 then
    return 'NOT-A-FLOAT'

    bDouble = TheDouble~Reverse~c2x~x2b~Right(64,'0')
    dMantissa = '1' || bDouble~Right(52)
    dExponent = bDouble~SubStr( 2, 11 )
    dSign = bDouble~Left(1)
    magicNumber = 1075

                    /* IS SPECIAL VALUE                               */
    if dExponent = '11111111111' then
      return SpecialFloat( dSign, dMantissa, 'D' )
    else
      return GeneralFloat( dSign, dMantissa, dExponent, magicNumber, Digits() )


::ROUTINE GeneralFloat
  use arg theSign, theMantissa, theExponent, magicNumber, numdigits
  NUMERIC DIGITS numdigits

    if theExponent = 0 then
        ascFloat = 0
    else
        ascFloat = (theMantissa~b2x~x2d) * ( 2 ** ( (theExponent~b2x~x2d) - magicNumber ))

    if theSign then
        ascFloat = '-'ascFloat

    return ascFloat


::ROUTINE SpecialFloat
  use arg theSign, theMantissa, theType

    SELECT
      WHEN theType = 'S' then lenMantissa = 24
      WHEN theType = 'D' then lenMantissa = 53
    END

    SELECT
      WHEN theMantissa = '1'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'INFINITY'
      WHEN theMantissa = '11'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'NOT-A-NUMBER'
      OTHERWISE
        ieeeSpecial = 'UNKNOWN-MEANING'
    END /* SELECT */

    if theSign then
      ieeeSpecial = '-'ieeeSpecial
    else
      ieeeSpecial = '+'ieeeSpecial

    return 'IEEE:' ieeeSpecial

Determine what day of the week a date falls on

 
/* sample code to determine what day of the week a date falls on      */
/*                                                                    */
/* Source: Found in a message in a public news group                  */
/*                                                                    */

  do forever
    say 'Enter the date in the format dd.mm.yyyy (<return> to exit):'
    thisDate = strip( translate( lineIn() ) )
    if thisDate = '' then
      leave
    say 'The day of the week for the ' || thisDate || ,
        ' is: ' || dayOfTheWeek( thisDate )
  end /* do forever */
exit

/* ------------------------------------------------------------------ */
/* function: Determine what day of the week a date falls on           */
/*                                                                    */
/* call:     dayOfTheWeek = DayOfTheWeek( thisDate )                  */
/*                                                                    */
/* where:    thisDate - date in the format dd.mm.yyyy                 */
/*                                                                    */
/* returns:  the name of the day or ERROR in case of an error         */
/*                                                                    */
/*                                                                    */
DayOfTheWeek: PROCEDURE

                    /* install a local error handler                  */
  signal on syntax name DayOfTheWeekError

  sep = '.'
  parse arg dd (sep) mm (sep) year

  days = "Sunday Monday Tuesday Wednesday Thursday Friday Saturday"
  magic = 6 2 3 6 1 4 6 2 5 0 3 5
  parse var year cent +2 yr
  leap = year // 4 = 0 & (yr\=0 | cent//4=0)
  dow=yr + yr%4 + (6-2*(cent//4)) + word(magic,mm) + dd
  if mm < 3 & \leap then
    dow=dow+1
  dow = dow // 7
return word(days,dow+1)

DayOfTheWeekError:
  return 'ERROR'