$ !---------------------------------------------------------------------------
$ !									     |
$ ! Copyright (c) 1996 Digital Equipment Corporation.  All rights reserved.  |
$ !									     |
$ !									     |
$ ! This command procedure creates example programs for LIB$Table_Parse      |
$ ! that are listed in the OpenVMS RTL Library (LIB$) Manual.  It creates    |
$ ! examples in DEC C, VAX C, BLISS and MACRO.  There is also a MACRO        |
$ ! program to define the state tables for the C examples.		     |
$ !									     |
$ !---------------------------------------------------------------------------
$ !
$ !
$ ! Create the Bliss example
$ !
$ create LIB$TABLE_PARSE_DOC_EXA_BLISS.B32
$ deck
MODULE CREATE_DIR (                        ! Create directory file
                IDENT = 'X-1',
                MAIN = CREATE_DIR) =
BEGIN

 !+
 ! This BLISS program accepts and parses the command line  
 ! of a CREATE/DIRECTORY command.  This program uses the 
 ! LIB$GET_FOREIGN call to acquire the command line from 
 ! the CLI and parse it with LIB$TPARSE/LIB$TABLE_PARSE, leaving the necessary 
 ! information in its global data base.  The command line is of 
 ! the following format: 
 !
 !      CREATE/DIR DEVICE:[MARANTZ.ACCOUNT.OLD]
 !                 /UIC=[2437,25]
 !                 /ENTRIES=100
 !                 /PROTECTION=(SYSTEM:R,OWNER:RWED,GROUP:R,WORLD:R)
 !
 ! The three qualifiers are optional.  Alternatively, the command
 ! may take the form
 !
 !       CREATE/DIR DEVICE:[202,31]
 !
 ! using any of the optional qualifiers.
 !-

 !+
 ! Global data, control blocks, etc.
 !-

LIBRARY 'SYS$LIBRARY:STARLET';
LIBRARY 'SYS$LIBRARY:TPAMAC.L32';

 !+
 ! Macro to make the TPARSE control block addressable as a block
 ! through the argument pointer.
 !-

MACRO
        TPARSE_ARGS =
                BUILTIN AP;
                MAP AP : REF BLOCK [,BYTE];
                %;
 !+
 ! Declare routines in this module.
 !-

FORWARD ROUTINE
        CREATE_DIR,                      ! Mail program
        BLANKS_OFF,                      ! No explicit blank processing
        CHECK_UIC,                       ! Validate and assemble UIC
        STORE_NAME,                      ! Store next directory name
        MAKE_UIC;                        ! Make UIC into directory name

 !+
 ! Define parser flag bits for flags longword.
 !-

LITERAL
        UIC_FLAG        = 0,                 ! /UIC seen
        ENTRIES_FLAG    = 1,                 ! /ENTRIES seen
        PROT_FLAG       = 2;                 ! /PROTECTION seen
OWN
 !+
 ! This is the LIB$GET_FOREIGN descriptor block to get the command line.
 !-

        COMMAND_DESC        : BLOCK [DSC$K_S_BLN, BYTE],
        COMMAND_BUFF        : VECTOR [256, BYTE],

 !+
 ! This is the TPARSE argument block.
 !-

        TPARSE_BLOCK        : BLOCK [TPA$K_LENGTH0, BYTE]
                INITIAL (TPA$K_COUNT0,     ! Longword count
                        TPA$M_ABBREV       ! Allow abbreviation
                        OR TPA$M_BLANKS),  ! Process spaces explicitly

 !+
 ! Parser global data:
 !-

        PARSER_FLAGS   : BITVECTOR [32], ! Keyword flags
        DEVICE_STRING  : VECTOR [2],     ! Device string descriptor
        ENTRY_COUNT,                     ! Space to preallocate
        FILE_PROTECT,                    ! Directory file protection
        UIC_GROUP,                       ! Temp for UIC group
        UIC_MEMBER,                      ! Temp for UIC member
        FILE_OWNER,                      ! Actual file owner UIC
        NAME_COUNT,                      ! Number of directory names
        UIC_STRING     : VECTOR [6, BYTE],   ! Buffer for string

        NAME_VECTOR    : BLOCKVECTOR [0, 2], ! Vector of descriptors

        DIRNAME1        : VECTOR [2],         ! Name descriptor 1
        DIRNAME2        : VECTOR [2],         ! Name descriptor 2
        DIRNAME3        : VECTOR [2],         ! Name descriptor 3
        DIRNAME4        : VECTOR [2],         ! Name descriptor 4
        DIRNAME5        : VECTOR [2],         ! Name descriptor 5
        DIRNAME6        : VECTOR [2],         ! Name descriptor 6
        DIRNAME7        : VECTOR [2],         ! Name descriptor 7
        DIRNAME8        : VECTOR [2];         ! Name descriptor 8

 !+
 ! Structure macro to reference the descriptor fields in the vector of
 ! descriptors.
 !-

MACRO
        STRING_COUNT       = 0, 0, 32, 0%,         ! Count field
        STRING_ADDR        = 1, 0, 32, 0%;         ! Address field

 !+
 ! TPARSE state table to parse the command line
 !-

$INIT_STATE        (UFD_STATE, UFD_KEY);

 !+
 ! Read over the command name (to the first blank in the command).
 !-

$STATE  (START,
        (TPA$_BLANK, , BLANKS_OFF),
        (TPA$_ANY, START)
        );
 !+
 ! Read device name string and trailing colon.
 !-

$STATE  (,
        (TPA$_SYMBOL,,,, DEVICE_STRING)
        );

$STATE  (,
        (':')
        );



 !+
 ! Read directory string, which is either a UIC string or a general
 ! directory string.
 !-

$STATE  (,
        ((UIC),, MAKE_UIC),
        ((NAME))
        );

 !+
 ! Scan for options until end of line is reached.
 !-

$STATE  (OPTIONS,
        ('/'),
        (TPA$_EOS, TPA$_EXIT)
        );

$STATE  (,
        ('UIC', PARSE_UIC,, 1^UIC_FLAG, PARSER_FLAGS),
        ('ENTRIES', PARSE_ENTRIES,, 1^ENTRIES_FLAG, PARSER_FLAGS),
        ('PROTECTION', PARSE_PROT,, 1^PROT_FLAG, PARSER_FLAGS)
        );

 !+
 ! Get file owner UIC.
 !-

$STATE  (PARSE_UIC,
        (':'),
        ('=')
        );

$STATE  (,
        ((UIC), OPTIONS)
        );
 !+
 ! Get number of directory entries.
 !-

$STATE  (PARSE_ENTRIES,
        (':'),
        ('=')

        );

$STATE  (,
        (TPA$_DECIMAL, OPTIONS,,, ENTRY_COUNT)
        );

 !+
 ! Get directory file protection. Note that the bit masks generate the
 ! protection in complement form. It will be uncomplemented by the main
 ! program.
 !-

$STATE  (PARSE_PROT,
        (':'),
        ('=')
        );

$STATE  (,
        ('(')
        );

$STATE  (NEXT_PRO,
        ('SYSTEM', SYPR),
        ('OWNER',  OWPR),
        ('GROUP',  GRPR),
        ('WORLD',  WOPR)
        );

$STATE  (SYPR,
        (':'),
        ('=')
        );

$STATE  (SYPR0,
        ('R', SYPR0,, %X'0001', FILE_PROTECT),
        ('W', SYPR0,, %X'0002', FILE_PROTECT),
        ('E', SYPR0,, %X'0004', FILE_PROTECT),
        ('D', SYPR0,, %X'0008', FILE_PROTECT),
        (TPA$_LAMBDA, ENDPRO)
        );

$STATE  (OWPR,
        (':'),
        ('=')
        );



$STATE  (OWPR0,
        ('R', OWPR0,, %X'0010', FILE_PROTECT),
        ('W', OWPR0,, %X'0020', FILE_PROTECT),
        ('E', OWPR0,, %X'0040', FILE_PROTECT),
        ('D', OWPR0,, %X'0080', FILE_PROTECT),
        (TPA$_LAMBDA, ENDPRO)
        );

$STATE  (GRPR,
        (':'),
        ('=')
        );

$STATE  (GRPR0,
        ('R', GRPR0,, %X'0100', FILE_PROTECT),
        ('W', GRPR0,, %X'0200', FILE_PROTECT),
        ('E', GRPR0,, %X'0400', FILE_PROTECT),
        ('D', GRPR0,, %X'0800', FILE_PROTECT),
        (TPA$_LAMBDA, ENDPRO)
        );

$STATE  (WOPR,
        (':'),
        ('=')
        );

$STATE  (WOPR0,
        ('R', WOPR0,, %X'1000', FILE_PROTECT),
        ('W', WOPR0,, %X'2000', FILE_PROTECT),
        ('E', WOPR0,, %X'4000', FILE_PROTECT),
        ('D', WOPR0,, %X'8000', FILE_PROTECT),
        (TPA$_LAMBDA, ENDPRO)
        );

$STATE  (ENDPRO,
        (', ', NEXT_PRO),
        (')', OPTIONS)
        );

 !+
 ! Subexpression to parse a UIC string.
 !-

$STATE  (UIC,

        ('[')
        );

$STATE  (,
        (TPA$_OCTAL,,,, UIC_GROUP)
        );

$STATE  (,
        (', ')
        );

$STATE  (,
        (TPA$_OCTAL,,,, UIC_MEMBER)
        );

$STATE  (,
        (']', TPA$_EXIT, CHECK_UIC)
        );

 !+
 ! Subexpression to parse a general directory string
 !-

$STATE  (NAME,
        ('[')
        );

$STATE  (NAME0,
        (TPA$_STRING,, STORE_NAME)
        );

$STATE  (,
        ('.', NAME0),
        (']', TPA$_EXIT)
        );

PSECT OWN = $OWN$;
PSECT GLOBAL = $GLOBAL$;



GLOBAL ROUTINE CREATE_DIR (START_ADDR, CLI_CALLBACK) =

BEGIN

 !+
 ! This program creates a directory. It gets the command 

 ! line from the CLI and parses it with TPARSE.
 !-

LOCAL
        STATUS,                 ! Status from LIB$TPARSE/LIB$TABLE_PARSE
        OUT_LEN  : WORD;        ! length of returned command line
EXTERNAL
        SS$_NORMAL;

EXTERNAL ROUTINE
        LIB$GET_FOREIGN   : ADDRESSING_MODE (GENERAL),
        LIB$TPARSE	  : ADDRESSING_MODE (GENERAL);

        COMMAND_DESC [DSC$W_LENGTH]  = 256;
        COMMAND_DESC [DSC$B_DTYPE]   = DSC$K_DTYPE_T;
        COMMAND_DESC [DSC$B_CLASS]   = DSC$K_CLASS_S;
        COMMAND_DESC [DSC$A_POINTER] = COMMAND_BUFF;



        STATUS = LIB$GET_FOREIGN (COMMAND_DESC,
                                %ASCID'COMMAND: ',
                                OUT_LEN
                                );
        IF NOT .STATUS
                THEN
                SIGNAL (STATUS);



 !+
 ! Copy the input string descriptor into the TPARSE control block
 ! and call TPARSE. Note that impure storage is assumed to be zero.
 !-



TPARSE_BLOCK[TPA$L_STRINGCNT] = .OUT_LEN;
TPARSE_BLOCK[TPA$L_STRINGPTR] = .COMMAND_DESC[DSC$A_POINTER];

STATUS = LIB$TPARSE (TPARSE_BLOCK, UFD_STATE, UFD_KEY);
IF NOT .STATUS
THEN
        RETURN .status;
RETURN SS$_NORMAL
END;                                         ! End of routine CREATE_DIR

 !+

 ! Parser action routines
 !-

 !+
 ! Shut off explicit blank processing after passing the command name.
 !-

ROUTINE BLANKS_OFF =
    BEGIN
    TPARSE_ARGS;

    AP[TPA$V_BLANKS] = 0;
    1
    END;

 !+
 ! Check the UIC for legal value range.
 !-

ROUTINE CHECK_UIC =
    BEGIN
    TPARSE_ARGS;

    IF .UIC_GROUP<16,16> NEQ 0
    OR .UIC_MEMBER<16,16> NEQ 0
    THEN RETURN 0;

    FILE_OWNER<0,16> = .UIC_MEMBER;
    FILE_OWNER<16,16> = .UIC_GROUP;
    1
    END;

 !+
 ! Store a directory name component.
 !-

ROUTINE STORE_NAME =
    BEGIN
    TPARSE_ARGS;

    IF .NAME_COUNT GEQU 8
    OR .AP[TPA$L_TOKENCNT] GTRU 9
    THEN RETURN 0;
    NAME_COUNT = .NAME_COUNT + 1;
    NAME_VECTOR [.NAME_COUNT, STRING_COUNT] = .AP[TPA$L_TOKENCNT];

    NAME_VECTOR [.NAME_COUNT, STRING_ADDR] = .AP[TPA$L_TOKENPTR];
    1
    END;

 !+
 ! Convert a UIC into its equivalent directory file name.
 !-

ROUTINE MAKE_UIC =
    BEGIN
    TPARSE_ARGS;

    IF .UIC_GROUP<8,8> NEQ 0
    OR .UIC_MEMBER<8,8> NEQ 0
    THEN RETURN 0;
    DIRNAME1[0] = 0;
    DIRNAME1[1] = UIC_STRING;
    $FAOL (CTRSTR = UPLIT (6, UPLIT BYTE ('!OB!OB')),
           OUTBUF = DIRNAME1,
           PRMLST = UIC_GROUP
           );
    1
    END;

END
ELUDOM                               ! End of module CREATE_DIR
$ eod
$
$ !
$ ! Create the DECC example
$ !
$ create LIB$TABLE_PARSE_DOC_EXA_DECC.C
$ deck
/*
** This DECC program accepts and parses the command line of a CREATE/DIRECTORY
** command.  This program uses the LIB$GET_FOREIGN call to acquire the command
** line from the CLI and parse it with LIB$TABLE_PARSE, leaving the necessary 
** information in its global data base.  The command line is of 
** the following format: 
**
**      CREATE/DIR DEVICE:[MARANTZ.ACCOUNT.OLD]
**                 /OWNER_UIC=[2437,25]
**                 /ENTRIES=100
**                 /PROTECTION=(SYSTEM:R,OWNER:RWED,GROUP:R,WORLD:R)
**
** The three qualifiers are optional.  Alternatively, the command
** may take the form:
**
**       CREATE/DIR DEVICE:[202,31]
**
** using any of the optional qualifiers.
**
** The source for this program can be found in:
**
**       SYS$EXAMPLES:LIB$TABLE_PARSE_DEMO.COM
**
*/

/*
** Specify the required header files
*/

# include "sys$library:tpadef"
# include "sys$library:descrip"
# include "sys$library:starlet"
# include "sys$library:lib$routines"

/*
** Specify macro definitions
*/

# define max_name_count 8
# define max_token_size 9
# define uic_string_size 6
# define command_buffer_size 256

/*
** Specify persistent data that's local to this module
*/

static
  union
    uic_union {
      __int32 bits;
      struct {
        char first;
        char second;
        } bytes;
      struct {
        __int16 first;
        __int16 second;
        } words;
      } 
      file_owner;                             /* Actual file owner UIC */

static
  int
    name_count;                               /* Number of directory names */

static
  char
    uic_string[ uic_string_size + 1 ];        /* Buffer for string */

static
  struct
    dsc$descriptor_s
      name_vector[ max_name_count ];          /* Vector of descriptors */

/*
** Specify persistent data that's global to this module.
** This data is referenced externally by the state table definitions.
*/

union
  uic_union
    uic_group,                                /* Temp for UIC group */
    uic_member;                               /* Temp for UIC member */

int
  parser_flags,                               /* Keyword flags */
  entry_count,                                /* Space to preallocate */
  file_protect;                               /* Directory file protection */

struct
  dsc$descriptor_s
    device_string =                           /* Device string descriptor */
      { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, (char *) 0 };

/*
** Specify the user action routines.
**
** Please note that if it were LIB$TPARSE being called, the user action 
** routines would have to be coded as follows:
**
**       int user_action_routine( __int32 psuedo_ap )
**         {
**         struct tpadef
**           *tparse_block = (tpadef *) (&psuedo_ap - 1);
**         printf( "Parameter value: %d\n",
**                 tparse_block->tpa$l_param
**                 );
**         }
*/

/*
** Shut off explicit blank processing after passing the command name.
*/

int blanks_off( struct tpadef *tparse_block ) {
  tparse_block->tpa$v_blanks = 0;
  return( 1 );
  }

/*
** Check the UIC for legal value range.
*/

int check_uic( struct tpadef *tparse_block ) {
  if ( (uic_group.words.second != 0) ||
       (uic_member.words.second != 0)
       )
    return( 0 );

  file_owner.words.first = uic_member.words.first;
  file_owner.words.second = uic_group.words.first;

  return( 1 );
  }

/*
** Store a directory name component.
*/

int store_name( struct tpadef *tparse_block ) {
  if ( (name_count >= max_name_count) ||
       (tparse_block->tpa$l_tokencnt > max_token_size)
       )
    return( 0 );

  name_vector[ name_count ].dsc$w_length = tparse_block->tpa$l_tokencnt;
  name_vector[ name_count ].dsc$b_dtype = DSC$K_DTYPE_T;
  name_vector[ name_count ].dsc$b_class = DSC$K_CLASS_S;
  name_vector[ name_count++ ].dsc$a_pointer = tparse_block->tpa$l_tokenptr;

  return( 1 );
  }

/*
** Convert a UIC into its equivalent directory file name.
*/

int make_uic( struct tpadef *tparse_block ) {

  $DESCRIPTOR( control_string, "!OB!OB" );
  $DESCRIPTOR( dirname, uic_string );

  if ( (uic_group.bytes.second != '\0') ||
       (uic_member.bytes.second != '\0')
       )
    return( 0 );

  sys$fao( &control_string,
           &dirname.dsc$w_length,
           &dirname,
           uic_group.bytes.first,
           uic_member.bytes.first
           );

  return( 1 );
  }

/*
** The main program section starts here.
*/

main( ) {

/*
** This program creates a directory. It gets the command
** line from the CLI and parses it with TPARSE.
*/

extern
  char
    ufd_state,
    ufd_key;

char
  command_buffer[ command_buffer_size + 1 ];

int
  status;

$DESCRIPTOR( prompt, "Command> " );
$DESCRIPTOR( command_descriptor, command_buffer );

struct
  tpadef
    tparse_block = { TPA$K_COUNT0,            /* Longword count */
                     TPA$M_ABBREV             /* Allow abbreviation */
                          |
                     TPA$M_BLANKS             /* Process spaces explicitly */
                     };

status = lib$get_foreign( &command_descriptor,
                          &prompt,
                          &command_descriptor.dsc$w_length
                          );

if ( (status & 1) == 0 )
  return( status );

/*
** Copy the input string descriptor into the LIB$TABLE_PARSE control block
** and then call LIB$TABLE_PARSE. Note that impure storage is assumed
** to be zero.
*/

tparse_block.tpa$l_stringcnt = command_descriptor.dsc$w_length;
tparse_block.tpa$l_stringptr = command_descriptor.dsc$a_pointer;

return( status = lib$table_parse( &tparse_block, &ufd_state, &ufd_key ) );

}
$ eod
$
$ !
$ ! Create the DEC C Tables file
$ !
$ create LIB$TABLE_PARSE_DOC_EXA_DECC_TABLES.MAR
$ deck
	.TITLE        CREATE_DIR_TABLES - Create Directory File (tables)
	.IDENT        "X-1"

;+
;
; This module defines the TPARSE state tables for sample program CREATE_DIR.C
; (which accepts and parses the command line of the CREATE/DIRECTORY command).
; This program contains the VMS call to acquire the command line from the
; command interpreter and parse it with TPARSE, leaving the necessary
; information in its global data base. The command line has the
; following format:
;
;        CREATE/DIR DEVICE:[MARANTZ.ACCOUNT.OLD]
;                /OWNER_UIC=[2437,25]
;                /ENTRIES=100
;                /PROTECTION=(SYSTEM:R,OWNER:RWED,GROUP:R,WORLD:R)
;
; The three qualifiers are optional. Alternatively, the command
; may take the form
;
;        CREATE/DIR DEVICE:[202,31]
;
; using any of the optional qualifiers.
;
;-

;+
;
; Global data, control blocks, etc.
;
;-
         .PSECT  IMPURE,WRT,NOEXE
;+
; Define control block offsets
;-

        $CLIDEF
        $TPADEF

	.EXTRN	BLANKS_OFF, -			; No explicit blank processing
		CHECK_UIC, -			; Validate and assemble UIC
		STORE_NAME, -			; Store next directory name
		MAKE_UIC			; Make UIC into directory name

;+
; Define parser flag bits for flags longword
;-

UIC_FLAG            = 1        ; /UIC seen
ENTRIES_FLAG        = 2        ; /ENTRIES seen
PROT_FLAG           = 4        ; /PROTECTION seen

        .SBTTL        Parser State Table

;+
; Assign values for protection flags to be used when parsing protection
; string.
;-

SYSTEM_READ_FLAG = ^X0001
SYSTEM_WRITE_FLAG = ^X0002
SYSTEM_EXECUTE_FLAG = ^X0004
SYSTEM_DELETE_FLAG = ^X0008
GROUP_READ_FLAG = ^X0001
GROUP_WRITE_FLAG = ^X0002
GROUP_EXECUTE_FLAG = ^X0004
GROUP_DELETE_FLAG = ^X0008
OWNER_READ_FLAG = ^X0001
OWNER_WRITE_FLAG = ^X0002
OWNER_EXECUTE_FLAG = ^X0004
OWNER_DELETE_FLAG = ^X0008
WORLD_READ_FLAG = ^X0001
WORLD_WRITE_FLAG = ^X0002
WORLD_EXECUTE_FLAG = ^X0004
WORLD_DELETE_FLAG = ^X0008

$INIT_STATE     UFD_STATE,UFD_KEY

;+
; Read over the command name (to the first blank in the command).
;-

        $STATE       START
        $TRAN        TPA$_BLANK,,BLANKS_OFF
        $TRAN        TPA$_ANY,START

;+
; Read device name string and trailing colon.
;-

        $STATE
        $TRAN        TPA$_SYMBOL,,,,DEVICE_STRING

        $STATE
        $TRAN        ':'
;+
; Read directory string, which is either a UIC string or a general
; directory string.
;-

        $STATE
        $TRAN        !UIC,,MAKE_UIC
        $TRAN        !NAME

;+
; Scan for options until end of line is reached
;-

        $STATE        OPTIONS
        $TRAN        '/'
        $TRAN        TPA$_EOS,TPA$_EXIT

        $STATE
        $TRAN        'OWNER_UIC',PARSE_UIC,,UIC_FLAG,PARSER_FLAGS
        $TRAN        'ENTRIES',PARSE_ENTRIES,,ENTRIES_FLAG,PARSER_FLAGS
        $TRAN        'PROTECTION',PARSE_PROT,,PROT_FLAG,PARSER_FLAGS

;+
; Get file owner UIC.
;-

        $STATE        PARSE_UIC
        $TRAN        ':'
        $TRAN        '='

        $STATE
        $TRAN        !UIC,OPTIONS

;+
; Get number of directory entries.
;-

        $STATE        PARSE_ENTRIES
        $TRAN        ':'
        $TRAN        '='

        $STATE
        $TRAN        TPA$_DECIMAL,OPTIONS,,,ENTRY_COUNT

;+
; Get directory file protection. Note that the bit masks generate the
; protection in complement form. It will be uncomplemented by the main
; program.
;-

        $STATE        PARSE_PROT
        $TRAN        ':'
        $TRAN        '='

        $STATE
        $TRAN        '('

        $STATE        NEXT_PRO
        $TRAN        'SYSTEM', SYPR
        $TRAN        'OWNER',  OWPR
        $TRAN        'GROUP',  GRPR
        $TRAN        'WORLD',  WOPR

        $STATE        SYPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        SYPRO
        $TRAN        'R',SYPRO,,SYSTEM_READ_FLAG,FILE_PROTECT
        $TRAN        'W',SYPRO,,SYSTEM_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',SYPRO,,SYSTEM_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',SYPRO,,SYSTEM_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        OWPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        OWPRO
        $TRAN        'R',OWPRO,,OWNER_READ_FLAG,FILE_PROTECT
        $TRAN        'W',OWPRO,,OWNER_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',OWPRO,,OWNER_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',OWPRO,,OWNER_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        GRPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        GRPRO
        $TRAN        'R',GRPRO,,GROUP_READ_FLAG,FILE_PROTECT
        $TRAN        'W',GRPRO,,GROUP_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',GRPRO,,GROUP_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',GRPRO,,GROUP_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        WOPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        WOPRO
        $TRAN        'R',WOPRO,,WORLD_READ_FLAG,FILE_PROTECT
        $TRAN        'W',WOPRO,,WORLD_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',WOPRO,,WORLD_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',WOPRO,,WORLD_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        ENDPRO
        $TRAN        <','>,NEXT_PRO
        $TRAN        ')',OPTIONS

;+
; Subexpression to parse a UIC string.
;-

        $STATE        UIC
        $TRAN        '['

        $STATE
        $TRAN        TPA$_OCTAL,,,,UIC_GROUP

        $STATE
        $TRAN        <','>        ; The comma character must be
                                  ;   surrounded by angle brackets
                                  ;   because MACRO restricts the use
                                  ;   of commas in arguments to macros.

        $STATE
        $TRAN        TPA$_OCTAL,,,,UIC_MEMBER

        $STATE
        $TRAN        ']',TPA$_EXIT,CHECK_UIC

;+
; Subexpression to parse a general directory string
;-

        $STATE        NAME
        $TRAN        '['

        $STATE        NAMEO
        $TRAN        TPA$_STRING,,STORE_NAME

        $STATE
        $TRAN        '.',NAMEO
        $TRAN        ']',TPA$_EXIT
        $END_STATE

	.END
$ eod
$
$ !
$ ! Create the Macro example
$ !
$ create LIB$TABLE_PARSE_DOC_EXA_MACRO.MAR
$ deck
	.TITLE        CREATE_DIR - Create Directory File
	.IDENT        "X-1"
;+
;
; This is a sample program that accepts and parses the command line
; of the CREATE/DIRECTORY command. This program contains the VMS
; call to acquire the command line from the command interpreter
; and parse it with TPARSE, leaving the necessary information in
; its global data base. The command line has the following format:
;
;        CREATE/DIR DEVICE:[MARANTZ.ACCOUNT.OLD]
;                /OWNER_UIC=[2437,25]
;                /ENTRIES=100
;                /PROTECTION=(SYSTEM:R,OWNER:RWED,GROUP:R,WORLD:R)
;
; The three qualifiers are optional. Alternatively, the command
; may take the form
;
;        CREATE/DIR DEVICE:[202,31]
;
; using any of the optional qualifiers.
;
;-

;+
;
; Global data, control blocks, etc.
;
;-
         .PSECT  IMPURE,WRT,NOEXE
;+
; Define control block offsets
;-
        $CLIDEF
        $TPADEF
;+
; Define parser flag bits for flags longword
;-

UIC_FLAG            = 1        ; /UIC seen
ENTRIES_FLAG        = 2        ; /ENTRIES seen
PROT_FLAG           = 4        ; /PROTECTION seen

;+
; LIB$GET_FOREIGN string descriptors to get the line to be parsed
;-

STRING_LEN = 256
STRING_DESC:
        .WORD STRING_LEN
        .BYTE DSC$K_DTYPE_T
        .BYTE DSC$K_CLASS_S
        .ADDRESS STRING_AREA
STRING_AREA:
        .BLKB STRING_LEN
PROMPT_DESC:
        .WORD PROMPT_LEN
        .BYTE DSC$K_DTYPE_T
        .BYTE DSC$K_CLASS_S
        .ADDRESS PROMPT

PROMPT:
        .ASCII /qualifiers: /
PROMPT_LEN = .-PROMPT



;+
; TPARSE argument block
;-

TPARSE_BLOCK:
         .LONG        TPA$K_COUNT0          ; Longword count
         .LONG        TPA$M_ABBREV!-        ; Allow abbreviation
                      TPA$M_BLANKS          ; Process spaces explicitly
         .BLKB        TPA$K_LENGTH0-8       ; Remainder set at run time
;+
; Parser global data
;-

RET_LEN:              .BLKW        1        ; LENGTH OF RETURNED COMMAND LINE
PARSER_FLAGS:         .BLKL        1        ; Keyword flags
DEVICE_STRING:        .BLKL        2        ; Device string descriptor
ENTRY_COUNT:          .BLKL        1        ; Space to preallocate
FILE_PROTECT:         .BLKL        1        ; Directory file protection
UIC_GROUP:            .BLKL        1        ; Temp for UIC group
UIC_MEMBER:           .BLKL        1        ; Temp for UIC member
UIC_STRING:           .BLKB        6        ; String to receive converted UIC
FILE_OWNER:           .BLKL        1        ; Actual file owner UIC
NAME_COUNT:           .BLKL        1        ; Number of directory names
DIRNAME1:             .BLKL        2        ; Name descriptor 1
DIRNAME2:             .BLKL        2        ; Name descriptor 2
DIRNAME3:             .BLKL        2        ; Name descriptor 3
DIRNAME4:             .BLKL        2        ; Name descriptor 4
DIRNAME5:             .BLKL        2        ; Name descriptor 5
DIRNAME6:             .BLKL        2        ; Name descriptor 6
DIRNAME7:             .BLKL        2        ; Name descriptor 7
DIRNAME8:             .BLKL        2        ; Name descriptor 8

         .SBTTL Main Program
;+
; This program gets the CREATE/DIRECTORY command line from 
; the command interpreter and parses it.
;-
         .PSECT  CODE,EXE,NOWRT
CREATE_DIR::
         .WORD   ^M<R2,R3,R4,R5>        ; Save registers

;+
; Call the command interpreter to obtain the command line.
;-
        PUSHAW  RET_LEN
        PUSHAQ  PROMPT_DESC
        PUSHAQ  STRING_DESC
        CALLS   #3,G^LIB$GET_FOREIGN    ; Call to get command line
        BLBC    R0, SYNTAX_ERR

;+
; Copy the input string descriptor into the TPARSE control block
; and call LIB$TPARSE/LIB$TABLE_PARSE. Note that impure storage is assumed to be zero.
;-
        MOVZWL        RET_LEN, TPARSE_BLOCK+TPA$L_STRINGCNT
        MOVAL         STRING_AREA, TPARSE_BLOCK+TPA$L_STRINGPTR
        PUSHAL        UFD_KEY
        PUSHAL        UFD_STATE
        PUSHAL        TPARSE_BLOCK
        CALLS         #3,G^LIB$TPARSE
        BLBC          R0,SYNTAX_ERR

;+
; Parsing is complete.
;
; You can include here code to process the string just parsed, to call
; another program to process the command, or to return control to
; a calling program, if any.
;-

SYNTAX_ERR:

;+
; Code to handle parsing errors.
;-

        RET

        .SBTTL        Parser State Table

;+
; Assign values for protection flags to be used when parsing protection
; string.
;-

SYSTEM_READ_FLAG = ^X0001
SYSTEM_WRITE_FLAG = ^X0002
SYSTEM_EXECUTE_FLAG = ^X0004
SYSTEM_DELETE_FLAG = ^X0008
GROUP_READ_FLAG = ^X0001
GROUP_WRITE_FLAG = ^X0002
GROUP_EXECUTE_FLAG = ^X0004
GROUP_DELETE_FLAG = ^X0008
OWNER_READ_FLAG = ^X0001
OWNER_WRITE_FLAG = ^X0002
OWNER_EXECUTE_FLAG = ^X0004
OWNER_DELETE_FLAG = ^X0008
WORLD_READ_FLAG = ^X0001
WORLD_WRITE_FLAG = ^X0002
WORLD_EXECUTE_FLAG = ^X0004
WORLD_DELETE_FLAG = ^X0008

$INIT_STATE     UFD_STATE,UFD_KEY

;+
; Read over the command name (to the first blank in the command).
;-

        $STATE       START
        $TRAN        TPA$_BLANK,,BLANKS_OFF
        $TRAN        TPA$_ANY,START
;+
; Read device name string and trailing colon.
;-

        $STATE
        $TRAN        TPA$_SYMBOL,,,,DEVICE_STRING

        $STATE
        $TRAN        ':'
;+
; Read directory string, which is either a UIC string or a general
; directory string.
;-

        $STATE
        $TRAN        !UIC,,MAKE_UIC
        $TRAN        !NAME

;+
; Scan for options until end of line is reached
;-

        $STATE        OPTIONS
        $TRAN        '/'
        $TRAN        TPA$_EOS,TPA$_EXIT

        $STATE
        $TRAN        'OWNER_UIC',PARSE_UIC,,UIC_FLAG,PARSER_FLAGS
        $TRAN        'ENTRIES',PARSE_ENTRIES,,ENTRIES_FLAG,PARSER_FLAGS
        $TRAN        'PROTECTION',PARSE_PROT,,PROT_FLAG,PARSER_FLAGS

;+
; Get file owner UIC.
;-

        $STATE        PARSE_UIC
        $TRAN        ':'
        $TRAN        '='

        $STATE
        $TRAN        !UIC,OPTIONS

;+
; Get number of directory entries.
;-

        $STATE        PARSE_ENTRIES
        $TRAN        ':'
        $TRAN        '='

        $STATE
        $TRAN        TPA$_DECIMAL,OPTIONS,,,ENTRY_COUNT

;+
; Get directory file protection. Note that the bit masks generate the
; protection in complement form. It will be uncomplemented by the main
; program.
;-

        $STATE        PARSE_PROT
        $TRAN        ':'
        $TRAN        '='

        $STATE
        $TRAN        '('

        $STATE        NEXT_PRO
        $TRAN        'SYSTEM', SYPR
        $TRAN        'OWNER',  OWPR
        $TRAN        'GROUP',  GRPR
        $TRAN        'WORLD',  WOPR

        $STATE        SYPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        SYPRO
        $TRAN        'R',SYPRO,,SYSTEM_READ_FLAG,FILE_PROTECT
        $TRAN        'W',SYPRO,,SYSTEM_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',SYPRO,,SYSTEM_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',SYPRO,,SYSTEM_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        OWPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        OWPRO
        $TRAN        'R',OWPRO,,OWNER_READ_FLAG,FILE_PROTECT
        $TRAN        'W',OWPRO,,OWNER_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',OWPRO,,OWNER_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',OWPRO,,OWNER_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        GRPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        GRPRO
        $TRAN        'R',GRPRO,,GROUP_READ_FLAG,FILE_PROTECT
        $TRAN        'W',GRPRO,,GROUP_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',GRPRO,,GROUP_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',GRPRO,,GROUP_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        WOPR
        $TRAN        ':'
        $TRAN        '='

        $STATE        WOPRO
        $TRAN        'R',WOPRO,,WORLD_READ_FLAG,FILE_PROTECT
        $TRAN        'W',WOPRO,,WORLD_WRITE_FLAG,FILE_PROTECT
        $TRAN        'E',WOPRO,,WORLD_EXECUTE_FLAG,FILE_PROTECT
        $TRAN        'D',WOPRO,,WORLD_DELETE_FLAG,FILE_PROTECT
        $TRAN        TPA$_LAMBDA,ENDPRO

        $STATE        ENDPRO
        $TRAN        <','>,NEXT_PRO
        $TRAN        ')',OPTIONS

;+
; Subexpression to parse a UIC string.
;-

        $STATE        UIC
        $TRAN        '['

        $STATE
        $TRAN        TPA$_OCTAL,,,,UIC_GROUP

        $STATE
        $TRAN        <','>        ; The comma character must be
                                  ;   surrounded by angle brackets
                                  ;   because MACRO restricts the use
                                  ;   of commas in arguments to macros.

        $STATE
        $TRAN        TPA$_OCTAL,,,,UIC_MEMBER

        $STATE
        $TRAN        ']',TPA$_EXIT,CHECK_UIC

;+
; Subexpression to parse a general directory string
;-
        $STATE        NAME
        $TRAN        '['

        $STATE        NAMEO
        $TRAN        TPA$_STRING,,STORE_NAME

        $STATE
        $TRAN        '.',NAMEO
        $TRAN        ']',TPA$_EXIT
        $END_STATE

        .SBTTL        Parser Action Routines
        .PSECT        CODE,EXE,NOWRT

;+
; Shut off explicit blank processing after passing the command name.
;-

BLANKS_OFF:
        .WORD        0                      ; No registers saved (or used)
        BBCC         #TPA$V_BLANKS,TPA$L_OPTIONS(AP),10$
10$:    RET

;+
; Check the UIC for legal value range.
;-

CHECK_UIC:
        .WORD       0                       ; No registers saved (or used)
        TSTW        UIC_GROUP+2             ; UIC components are 16 bits
        BNEQ        10$
        TSTW        UIC_MEMBER+2
        BNEQ        10$
        MOVW        UIC_GROUP,FILE_OWNER+2  ; Store actual UIC
        MOVW        UIC_MEMBER,FILE_OWNER   ;  after checking
        RET
10$:    CLRL        R0                      ; Value out of range - fail
        RET                                 ;  the transition

;+
; Store a directory name component.
;-

STORE_NAME:
        .WORD       0                       ; No registers saved (or used)
        MOVL        NAME_COUNT,R1           ; Get count of names so far
        CMPL        R1,#8                   ; Maximum of 8 permitted
        BGEQU       10$
        INCL        NAME_COUNT              ; Count this name
        MOVAQ       DIRNAME1[R1],R1         ; Address of next descriptor
        MOVQ        TPA$L_TOKENCNT(AP),(R1) ; Store the descriptor
        CMPL        (R1),#9                 ; Check the length of the name
        BGTRU       10$                     ; Maximum is 9
        RET
10$:    CLRL        R0                      ; Error in directory name
        RET

;+
; Convert a UIC into its equivalent directory file name.
;-

MAKE_UIC:
        .WORD       0                           ; No registers saved (or used)
        TSTB        UIC_GROUP+1                 ; Check UIC for byte values,
        BNEQ        10$                         ; Since UIC type directories
        TSTB        UIC_MEMBER+1                ; Are restricted to this form
        BNEQ        10$
        MOVL        #6,DIRNAME1                 ; Directory name is 6 bytes
        MOVAL       UIC_STRING,DIRNAME1+4       ; Point to string buffer
        $FAOL       CTRSTR=FAO_STRING,-         ; Convert UIC to octal string
                    OUTBUF=DIRNAME1,-
                    PRMLST=UIC_GROUP
        RET
10$:    CLRL        R0                          ; Range error - fail it
        RET

FAO_STRING:        .LONG       STRING_END-STRING_START
STRING_START:      .ASCII  '!OB!OB'
STRING_END:

	.END        CREATE_DIR
$ eod
$
$ !
$ ! Create the VAXC example
$ !
$ create LIB$TABLE_PARSE_DOC_EXA_VAXC.C
$ deck
/*
** This DECC program accepts and parses the command line of a CREATE/DIRECTORY
** command.  This program uses the LIB$GET_FOREIGN call to acquire the command
** line from the CLI and parse it with LIB$TABLE_PARSE, leaving the necessary 
** information in its global data base.  The command line is of 
** the following format: 
**
**      CREATE/DIR DEVICE:[MARANTZ.ACCOUNT.OLD]
**                 /UIC=[2437,25]
**                 /ENTRIES=100
**                 /PROTECTION=(SYSTEM:R,OWNER:RWED,GROUP:R,WORLD:R)
**
** The three qualifiers are optional.  Alternatively, the command
** may take the form:
**
**       CREATE/DIR DEVICE:[202,31]
**
** using any of the optional qualifiers.
**
** The source for this program can be found in:
**
**       SYS$EXAMPLES:LIB$TABLE_PARSE_DEMO.COM
**
*/

/*
** Specify the required header files
*/

# include "sys$library:tpadef"
# include "sys$library:descrip"
# include "sys$library:starlet"
# include "sys$library:lib$routines"

/*
** Specify structure definitions
*/

union  {
  long bits;
  struct {
    char first;
    char second;
    } bytes;
  struct {
    short first;
    short second;
    } words;
  } 
  uic_group,                                  /* Temp for UIC group */
  uic_member,                                 /* Temp for UIC member */
  file_owner;                                 /* Actual file owner UIC */

/*
** Specify static global data
*/

int
  parser_flags,                               /* Keyword flags */
  entry_count,                                /* Space to preallocate */
  file_protect,                               /* Directory file protection */
  name_count;                                 /* Number of directory names */

# define uic_string_size 6

char
  uic_string[ uic_string_size + 1 ];          /* Buffer for string */

struct
  dsc$descriptor_s
    device_string =                           /* Device string descriptor */
      { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, (char *) 0 },

    dirname1 =                                /* Name descriptor */
      { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, (char *) 0 },

    name_vector[ 1 ] =                        /* Vector of descriptors */
      { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, (char *) 0 };

/*
** Specify the user action routines.
**
** Please note that if it were LIB$TPARSE being called, the user action 
** routines would have to be coded as follows:
**
**       int user_action_routine( long psuedo_ap )
**         {
**         struct tpadef
**           *tparse_block = (tpadef *) (&psuedo_ap - 1);
**         printf( "Parameter value: %d\n",
**                 tparse_block->tpa$l_param
**                 );
**         }
*/

/*
** Shut off explicit blank processing after passing the command name.
*/

int blanks_off( struct tpadef *tparse_block ) {
  tparse_block->tpa$v_blanks = 0;
  return( 1 );
  }

/*
** Check the UIC for legal value range.
*/

int check_uic( struct tpadef *tparse_block ) {
  if ( (uic_group.words.second != 0) || (uic_member.words.second != 0) )
    return( 0 );

  file_owner.words.first = uic_member.words.first;
  file_owner.words.second = uic_group.words.first;

  return( 1 );
  }

/*
** Store a directory name component.
*/

int store_name( struct tpadef *tparse_block ) {
  if ( (name_count >= 8) || (tparse_block->tpa$l_tokencnt > 9) )
    return( 0 );

  name_count += 1;
  name_vector[ name_count ].dsc$w_length = tparse_block->tpa$l_tokencnt;
  name_vector[ name_count ].dsc$a_pointer = tparse_block->tpa$l_tokenptr;

  return( 1 );
  }

/*
** Convert a UIC into its equivalent directory file name.
*/

int make_uic( struct tpadef *tparse_block ) {

  $DESCRIPTOR( control_string, "!OB!OB" );

  if ( (uic_group.bytes.second != '\0') || (uic_member.bytes.second != '\0') )
    return( 0 );

  dirname1.dsc$w_length = uic_string_size;
  dirname1.dsc$a_pointer = &uic_string;
  sys$faol( &control_string,
            &dirname1,
            &uic_group
            );

  return( 1 );
  }

/*
** The main program section starts here.
*/

main( ) {

/*
** This program creates a directory. It gets the command
** line from the CLI and parses it with TPARSE.
*/

extern
  char
    ufd_state,
    ufd_key;

# define command_buffer_size 256

char
  command_buffer[ command_buffer_size + 1 ];

int
  status;

$DESCRIPTOR( prompt, "Command> " );

struct
  dsc$descriptor_s
    command_descriptor = { command_buffer_size,
                           DSC$K_DTYPE_T,
                           DSC$K_CLASS_S,
                           &command_buffer
                           };

struct
  tpadef
    tparse_block = { TPA$K_COUNT0,            /* Longword count */
                     TPA$M_ABBREV             /* Allow abbreviation */
                          |
                     TPA$M_BLANKS             /* Process spaces explicitly */
                     };

uic_string[ uic_string_size ] = '\0';
command_buffer[ command_buffer_size ] = '\0';

status = lib$get_foreign( &command_descriptor,
                          &prompt,
                          &command_descriptor.dsc$w_length
                          );

if ( (status & 1) == 0 )
  signal( status );

/*
** Copy the input string descriptor into the LIB$TABLE_PARSE control block
** and then call LIB$TABLE_PARSE. Note that impure storage is assumed
** to be zero.
*/

tparse_block.tpa$l_stringcnt = command_descriptor.dsc$w_length;
tparse_block.tpa$l_stringptr = command_descriptor.dsc$a_pointer;
tparse_block.tpa$l_param = 1;

return( status = lib$table_parse( &tparse_block, &ufd_state, &ufd_key ) );

}
$ eod
$
$ exit