Google
 

Trailing-Edge - PDP-10 Archives - BB-JF18A-BM - sources/diu/fao.b36
There are 4 other files named fao.b36 in the archive. Click here to see a list.
!
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1985, 1986.
!	ALL RIGHTS RESERVED.
!
!	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!	COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!	THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!	ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!	AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!	SOFTWARE IS HEREBY TRANSFERRED.
!
!	THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!	NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!	EQUIPMENT CORPORATION.
!
!	DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!
!	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!
!  26-Sep-85 asp  Merge in Doug's changes

MODULE fao =
BEGIN

LIBRARY 'bli:xport';

%IF %SWITCHES(TOPS20)
%THEN
    LIBRARY 'tops20';
%ELSE
    LIBRARY 'bli:tendef';
%FI

!++
!
!	FAO accepts the following directives:
!
!     Directive		  Operation		Arguments/comments
!
!	!AD		Insert string		(1) string length
!						(2) string pointer
!
!	!AF		Insert string, print	(1) string length
!			 non-printing as "."	(2) string pointer
!
!	!AS		Insert string		(1) address of XPORT
!						    string descriptor
!
!	!AZ		Insert string		(1) pointer to ASCIZ string
!
!	!E		Insert error string	(1) T-20 error code, or 0
!						    for last error
!
!	!J		Convert JFN to filespec	(1) T-20 JFN
!
!	!OB		Convert 9 bits, octal	(1) number
!	!OW		Convert 18 bits "   "	      "
!	!OL		Convert 36 bits "   "	      "
!	!OH		Print word as n,,n	      "
!
!	!XB		Convert 9 bits, hex	(1) number
!	!XW		Convert 18 bits "  "	      "
!	!XL		Convert 36 bits "  "	      "
!
!	!UB		Convert 9 bits unsigned	(1) number
!	!UW		Convert 18 bits   "	      "
!	!UL		Convert 36 bits   "	      "
!
!	!SB		Convert 9 bits signed	(1) number
!	!SW		Convert 18 bits   "	      "
!	!SL		Convert 36 bits   "	      "
!
!	!ZB		Convert 9 bits 0-filled	(1) number
!	!ZW		Convert 18 bits   "	      "
!	!ZL		Convert 36 bits   "	      "
!
!	!%D		Insert date and time	(1) Internal date-time,
!			as 12-Dec-1984 08:44:23	    or 0 for current time
!
!	!%T		Insert date and time	(1) Internal date-time,
!			as 08:44:23		    or 0 for current time
!
!	!V		Output version number	(1) Version number
!			as MM.mm(eeee)-w
!
!	NOTE: Any of the above directives may be written as
!	      !nDD, as !12AZ, or !5SL, where the number n
!	      represents the number of characters to be output
!	      for this directive.  In the first example ("!12AZ"),
!	      an ASCIZ string will be inserted and either truncated
!	      on the right or blank-filled (as needed) to 12 characters.
!	      The second example outputs a number right-justified
!	      in a 5-character blank-filled field.  If the number won't
!	      fit, 5 *'s are output.
!
!
!	!%S		Insert "S" or "s" if 	No argument, sensitive
!			last number converted	  to case of last alphabetic
!			was not 1		  character output
!
!	!%P		Insert uppercase "S"	Always uppercase
!			if last number NEQ 1
!	!%p		Insert lowercase "s"	Always lowercase
!			if last number NEQ 1
!
!	!%^x		Output CTRL-x
!
!	!!		Output a "!"
!	!/		Output a <CR><LF>
!	!^		Output a <FF>
!	!_		Output a <TAB>
!
!	!-		Backup 1 argument
!	!+		Skip 1 argument
!
!	NOTE: Any of the above (yes, all the way to the top) may
!	      be written with repetition counts as !n(DD), as
!	      !4(AZ), !3(/), or !2(-), for instance.  Example 1
!	      inserts 4 ASCIZ strings in a row, example 2 writes
!	      out 3 CRLFs, and the last example backs up over 2
!	      arguments in the parameter list.
!
!	      The directives which may take a field width may be
!	      repeated as !n(mDD); !4(12AZ), for instance, would
!	      write out 4 ASCIZ strings, each truncated or filled
!	      to 12 characters, as needed.
!
!	!n*x		Output a character (x) n times
!
!	!n<		Begin a field of width n
!	!>		End a fixed-width field
!
!--

    $field
    faoflags =
	SET
	fao$v_dirwid = [$bit],			! Width of directive specified
	fao$v_dirrep = [$bit],			! Repeated directive specified
	fao$v_field = [$bit],			! Width of field specified
	fao$v_uppercase = [$bit],		! Last character was uppercase
	fao$v_plural = [$bit]			! Last number was NEQ 1
	TES;

FIELD
    t20arg$r_fields =
	SET
	t20arg$a_address = [0, 0, 23, 0],	! Arg address (w/ indirect bit)
	t20arg$v_type = [0, 23, 4, 0]		! Argument type
	TES;

LITERAL
    t20arg$k_integer = %O'2',
    t20arg$k_octal = %O'6',
    t20arg$k_string = %O'15',
    t20arg$k_asciz = %O'17';

MACRO
    $t20_argument =
 BLOCK [1] FIELD (t20arg$r_fields) %;

FIELD
    t20str$r_fields =
	SET
	t20str$a_pointer = [0, 0, 36, 0],	! Pointer to string
	t20str$g_length = [1, 0, 24, 0]		! Length of string
	TES;

MACRO
    $t20_string =
 BLOCK [2] FIELD (t20str$r_fields) %;

%IF %SWITCHES(TOPS10)
%THEN
BUILTIN
    UUO;

MACRO
    GETTAB_UUO(a) = UUO(1, %O'47', a, %O'41') %,
    FILOP$_UUO(a) = UUO(1, %O'47', a, %O'155') %;

LITERAL
    _CNDTM = %O'000053000011',	! GETTAB argument for current date/time
    $FOFIL = %O'33',		! Symbols for FILOP. UUO
    $FOFDV = 1,
    $FOFFN = 2,
    $FOFEX = 3,
    $FOFPP = 4,
    $FOFSF = 5;

EXTERNAL ROUTINE
    $CNTDT;

%FI

GLOBAL LITERAL
    ss$_normal = 1,
    ss$_bufferovf = 2;

FORWARD ROUTINE
    faol,
    fetch_parameter,
    advance_control_character : NOVALUE,
    test_control_character,
    read_control_character,
    do_directive,
    insert_directive,
    i_string,
    i_error,
    i_jfns,
    i_octal,
    i_signed,
    i_unsigned,
    i_hex,
    i_zerofilled,
    i_version,
    parse_number,
    outchr : NOVALUE,
%IF %SWITCHES(TOPS10)
%THEN
    filstr,
    sixbit_to_ascii,
    date_to_string : NOVALUE,
%FI
    system_directive;

OWN
    fao_parms : VECTOR [30],			! Parms for SYSFAO
    status,					! Status to return
    char,					! Most recently read character
    flags : BLOCK [1] FIELD (faoflags),
    ctrptr,					! Pointer to control string
    ctrlen,					! Length of control string
    outptr,					! Pointer to output string
    outspc,			! Current space remaining in output buffer
    tmplen,				! Temporary to hold output length
    prmlst : REF VECTOR,			! Parameter list
    prmptr,					! Pointer to parameter list
    repcnt,					! Repeat count for directive
    repchr,					! Character to be repeated
    fldwid,					! Width of field left to fill
    dirwid;			! Width of field for specific directive
GLOBAL ROUTINE sysfao : NOVALUE FORTRAN_SUB =
    BEGIN

    BUILTIN
	ACTUALPARAMETER,
	ACTUALCOUNT,
	ARGPTR;

    LOCAL
	status,
	ctrstr : $str_descriptor (class = fixed),
	outlen : $str_descriptor (class = fixed),
	outbuf : $str_descriptor (class = fixed),
	tmpdsc : REF $t20_string,
	cur_parm : $t20_argument,
	prmcount;

    !
    !   Set up the string descriptors
    !
    $str_desc_init (descriptor = ctrstr, class = fixed, string = (0, 0));
    $str_desc_init (descriptor = outbuf, class = fixed, string = (0, 0));
    !
    !   Set up the control string
    !
    cur_parm = ACTUALPARAMETER (1);

    IF .cur_parm [t20arg$v_type] NEQ t20arg$k_string	! Must be string
    THEN
	RETURN 0;

    tmpdsc = .cur_parm [t20arg$a_address];	! Address of string
    ctrstr [str$a_pointer] = .tmpdsc [t20str$a_pointer];
    ctrstr [str$h_length] = .tmpdsc [t20str$g_length];
    !
    !   Set up the output length
    !
    cur_parm = ACTUALPARAMETER (2);

    IF .cur_parm [t20arg$v_type] NEQ t20arg$k_integer	!
    THEN
	RETURN 0;

    outlen = .cur_parm [t20arg$a_address];	! Address of word
    !
    !   Set up the output buffer
    !
    cur_parm = ACTUALPARAMETER (3);

    IF .cur_parm [t20arg$v_type] NEQ t20arg$k_string	! Must be string
    THEN
	RETURN 0;

    tmpdsc = .cur_parm [t20arg$a_address];	! Address of string
    outbuf [str$a_pointer] = .tmpdsc [t20str$a_pointer];
    outbuf [str$h_length] = .tmpdsc [t20str$g_length];
    !
    !   Finally, set up the argument list
    !
    prmcount = 0;

    INCR i FROM 4 TO ACTUALCOUNT () DO
	BEGIN
	cur_parm = ACTUALPARAMETER (.i);

	IF .cur_parm [t20arg$v_type] EQL t20arg$k_string	! Special
	THEN
	    BEGIN
	    tmpdsc = .cur_parm [t20arg$a_address];	! Get the address
	    fao_parms [.prmcount] = .tmpdsc [t20str$g_length];
	    prmcount = .prmcount + 1;
	    fao_parms [.prmcount] = .tmpdsc [t20str$a_pointer];
	    prmcount = .prmcount + 1;
	    END
	ELSE
	    BEGIN
	    fao_parms [.prmcount] = .(.cur_parm [t20arg$a_address]);
	    prmcount = .prmcount + 1;
	    END;

	END;

    status = faol (ctrstr, .outlen, outbuf, fao_parms);
    RETURN;
    END;					! End SYSFAO
GLOBAL ROUTINE faol (p_ctrstr, p_outlen, p_outbuf, p_prmlst) =
    BEGIN

    BIND
	ctrstr = .p_ctrstr : $str_descriptor (class = bounded),
	outlen = .p_outlen,			! Length of output string
	outbuf = .p_outbuf : $str_descriptor (class = bounded);

    !
    !   Initialize some things
    !
    status = ss$_normal;			! All's well to start
    ctrptr = .ctrstr [str$a_pointer];
    ctrlen = .ctrstr [str$h_length];
    outptr = .outbuf [str$a_pointer];

    SELECTONE .outbuf [str$b_class] OF
	SET

	[str$k_class_z, str$k_class_f, str$k_class_d] :
						! Unknown, fixed, dynamic
	    outspc = .outbuf [str$h_length];

	[str$k_class_b, str$k_class_db] : 	! Bounded, dynamic bounded
	    outspc = .outbuf [str$h_maxlen] - .outbuf [str$h_pfxlen];
	TES;

    prmlst = .p_prmlst;
    flags = fldwid = dirwid = tmplen = prmptr = repchr = 0;
    repcnt = 1;
    !
    !   Start in on the control string
    !

    UNTIL .ctrlen EQL 0 DO
	BEGIN
	char = read_control_character ();

	SELECTONE .char OF
	    SET

	    [%C'!'] :
		BEGIN
		repcnt = 1;
		dirwid = 0;
		flags [fao$v_dirwid] = 0;
		do_directive ();
		END;

	    [%C'A' TO %C'Z'] :
		BEGIN
		flags [fao$v_uppercase] = 1;	! For !%S directive
		outchr (.char);
		END;

	    [%C'a' TO %C'z'] :
		BEGIN
		flags [fao$v_uppercase] = 0;	! For !%S directive
		outchr (.char);
		END;

	    [OTHERWISE] :
		outchr (.char);
	    TES;

	END;				! End of reading control string

    IF outlen NEQ 0				! Only if user wants it
    THEN
	outlen = .tmplen;			! Return the length

    SELECTONE .outbuf [str$b_class] OF
	SET

	[str$k_class_b, str$k_class_db] : 	! Bounded, dynamic bounded
	    outbuf [str$h_length] = .tmplen;	! Set bounded length

	[OTHERWISE] : 				! Don't bother with others
	;
	TES;

    RETURN .status;
    END;					! End FAOL
ROUTINE fetch_parameter =
    BEGIN
    prmptr = .prmptr + 1;
    RETURN .prmlst [.prmptr - 1];
    END;
ROUTINE test_control_character =
    BEGIN
    RETURN CH$RCHAR (.ctrptr);
    END;					! End TEST_CONTROL_CHARACTER
ROUTINE advance_control_character : NOVALUE =
    BEGIN
    ctrptr = CH$PLUS (.ctrptr, 1);
    ctrlen = .ctrlen - 1;
    END;				! End ADVANCE_CONTROL_CHARACTER
ROUTINE read_control_character =
    BEGIN
    ctrlen = .ctrlen - 1;
    RETURN CH$RCHAR_A (ctrptr);
    END;					! End READ_CONTROL_CHARACTER
ROUTINE do_directive =
    BEGIN
    char = test_control_character ();		! Get the directive character

    SELECTONE .char OF
	SET

	[%C'A', %C'E', %C'O', %C'X', %C'Z', %C'U', %C'S', %C'V', %C'J'] :
	    RETURN insert_directive ();

	[%C'/'] :
	    BEGIN
	    advance_control_character ();

	    INCR i FROM 1 TO .repcnt DO
		BEGIN
		outchr (%O'15');
		outchr (%O'12');
		END;

	    END;

	[%C'_'] :
	    BEGIN
	    advance_control_character ();

	    INCR i FROM 1 TO .repcnt DO
		outchr (%O'11');

	    END;

	[%C'^'] :
	    BEGIN
	    advance_control_character ();

	    INCR i FROM 1 TO .repcnt DO
		outchr (%O'14');

	    END;

	[%C'!'] :
	    BEGIN
	    advance_control_character ();

	    INCR i FROM 1 TO .repcnt DO
		outchr (%C'!');

	    END;

	[%C'-'] :
	    BEGIN
	    advance_control_character ();

	    INCR i FROM 1 TO .repcnt DO
		BEGIN

		IF .prmptr GTR 0		! Can we back up?
		THEN
		    prmptr = .prmptr - 1
		ELSE
		    RETURN 0;

		END;

	    END;

	[%C'+'] :
	    BEGIN
	    advance_control_character ();
	    prmptr = .prmptr + .repcnt;
	    END;

	[%C'%'] :
	    BEGIN
	    advance_control_character ();
	    RETURN system_directive ();
	    END;

	[%C'0' TO %C'9', %C'#'] :
	    RETURN parse_number ();

	[%C'>'] :
	    BEGIN
	    advance_control_character ();
	    flags [fao$v_field] = 0;

	    INCR i FROM 1 TO .fldwid DO
		outchr (%C' ');

	    fldwid = 0;
	    END;

	[OTHERWISE] :
	    RETURN 0;
	TES;

    RETURN 1;
    END;					! End DO_DIRECTIVE
ROUTINE insert_directive =
    BEGIN
    char = read_control_character ();		! Get the directive

    SELECTONE .char OF
	SET

	[%C'A'] :
	    RETURN i_string ();

	[%C'E'] :
	    RETURN i_error ();

	[%C'J'] :
	    RETURN i_jfns ();

	[%C'O'] :
	    RETURN i_octal ();

	[%C'S'] :
	    RETURN i_signed ();

	[%C'U'] :
	    RETURN i_unsigned ();

	[%C'V'] :
	    RETURN i_version ();

	[%C'X'] :
	    RETURN i_hex ();

	[%C'Z'] :
	    RETURN i_zerofilled ();
	TES;

    RETURN 1;
    END;					! End INSERT_DIRECTIVE
ROUTINE i_string =
    BEGIN

    LOCAL
	stringtype,		! Identifying character for string type
	filling,				! Length to fill with spaces
	strlen,					! Length of string to copy
	strptr;					! Pointer to inserted string

    stringtype = read_control_character ();

    INCR i FROM 1 TO .repcnt DO
	BEGIN

	!
	!   Set up the string length and pointer
	!

	SELECTONE .stringtype OF
	    SET

	    [%C'D', %C'F'] :
		BEGIN
		!
		!   Set up some necessaries
		!
		strlen = fetch_parameter ();
		strptr = fetch_parameter ();
		END;

	    [%C'S'] :
		BEGIN

		LOCAL
		    str_desc : REF $str_descriptor (class = bounded);

		!
		!   Get the descriptor and then fetch the
		!   length and pointer from the descriptor.
		!
		str_desc = fetch_parameter ();
		strlen = .str_desc [str$h_length];
		strptr = .str_desc [str$a_pointer];
		END;

	    [%C'Z'] :
		BEGIN

		LOCAL
		    tmpptr;

		!
		!   Fetch the string pointer, and then
		!   determine the string length by
		!   finding the null (presumably within
		!   the first 2000 characters).
		!
		strptr = fetch_parameter ();
		tmpptr = CH$FIND_CH (2000, .strptr, %O'0');

		IF CH$FAIL (.tmpptr) THEN RETURN 0;

		strlen = CH$DIFF (.tmpptr, .strptr);
		END;
	    TES;

	!
	!   If we have a specified width for this
	!   directive, we should set it up.
	!

	IF .flags [fao$v_dirwid]		! Specified output width?
	THEN
	    BEGIN
	    strlen = MIN (.dirwid, .strlen);	! Length to copy
	    filling = .dirwid - .strlen;	! Length to fill
	    END;

	!
	!   Output the string
	!

	INCR i FROM 1 TO .strlen DO
	    BEGIN

	    LOCAL
		strchr;

	    strchr = CH$RCHAR_A (strptr);

	    IF .stringtype EQL %C'F'		! Convert non-print chars?
	    THEN
		BEGIN

		IF .strchr LSS %C' '		! Non-printing?
		THEN
		    outchr (%C'.')
		ELSE
		    outchr (.strchr);

		END
	    ELSE
		outchr (.strchr);		! Put out any character

	    END;

	!
	!   Fill the string, if necessary
	!

	IF .flags [fao$v_dirwid]		! Width specified?
	THEN

	    INCR i FROM 1 TO .filling DO 	! Fill the string
		outchr (%C' ');			! Output a blank

	END;

    RETURN 1;
    END;					! End I_STRING
ROUTINE i_error =
    BEGIN

    MACRO
	$xwd (lh, rh) =
 (((lh) AND %O'777777')^18 OR ((rh) AND %O'777777')) %;

    LITERAL
	$fhslf = %O'400000',
	errbuf_len = 120;

    LOCAL
	tmpptr,
	errcod,
	strlen,
	strptr,
	filling,
	errbuf : VECTOR [CH$ALLOCATION (errbuf_len)];

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	errcod = fetch_parameter ();

	IF .errcod EQL 0 THEN errcod = -1;	! Default to last error

    %IF %SWITCHES(TOPS20)
    %THEN
	erstr (CH$PTR (errbuf), 		!
	    $xwd ($fhslf, .errcod), 		!
	    $xwd (-errbuf_len, 0); 		!
	    tmpptr);				! Save pointer
	strptr = CH$PTR (errbuf);
	strlen = CH$DIFF (.tmpptr, .strptr);
    %ELSE	! TOPS-10
	CH$WCHAR(%C'?', CH$PTR(errbuf));
	strlen = 1;
    %FI

	!
	!   If we have a specified width for this
	!   directive, we should set it up.
	!

	IF .flags [fao$v_dirwid]		! Specified output width?
	THEN
	    BEGIN
	    strlen = MIN (.dirwid, .strlen);	! Length to copy
	    filling = .dirwid - .strlen;	! Length to fill
	    END;

	!
	!   Output the string
	!

	INCR i FROM 1 TO .strlen DO
	    BEGIN

	    LOCAL
		strchr;

	    strchr = CH$RCHAR_A (strptr);
	    outchr (.strchr);			! Put out any character
	    END;

	!
	!   Fill the string, if necessary
	!

	IF .flags [fao$v_dirwid]		! Width specified?
	THEN

	    INCR i FROM 1 TO .filling DO 	! Fill the string
		outchr (%C' ');			! Output a blank

	END;

    RETURN 1;
    END;					! End I_ERROR
ROUTINE i_jfns =
    BEGIN

    LITERAL
	jfnbuf_len = 120;

    LOCAL
	tmpptr,
	jfn,
	strlen,
	strptr,
	filling,
	jfnbuf : VECTOR [CH$ALLOCATION (jfnbuf_len)];

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	jfn = fetch_parameter ();
    %IF %SWITCHES(TOPS20)
    %THEN
	jfns (CH$PTR (jfnbuf), 			!
	    .jfn, 				!
	    0; tmpptr);				! Save pointer
	strptr = CH$PTR (jfnbuf);
	strlen = CH$DIFF (.tmpptr, .strptr);
    %ELSE	! TOPS-10
	strptr = CH$PTR (jfnbuf);
	BEGIN
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			 STRING = (jfnbuf_len, .strptr));
	    strlen = filstr (desc, .jfn);
	END;
    %FI

	!
	!   If we have a specified width for this
	!   directive, we should set it up.
	!

	IF .flags [fao$v_dirwid]		! Specified output width?
	THEN
	    BEGIN
	    strlen = MIN (.dirwid, .strlen);	! Length to copy
	    filling = .dirwid - .strlen;	! Length to fill
	    END;

	!
	!   Output the string
	!

	INCR i FROM 1 TO .strlen DO
	    BEGIN

	    LOCAL
		strchr;

	    strchr = CH$RCHAR_A (strptr);
	    outchr (.strchr);			! Put out any character
	    END;

	!
	!   Fill the string, if necessary
	!

	IF .flags [fao$v_dirwid]		! Width specified?
	THEN

	    INCR i FROM 1 TO .filling DO 	! Fill the string
		outchr (%C' ');			! Output a blank

	END;

    RETURN 1;
    END;					! End I_JFNS
ROUTINE i_octal =
    BEGIN

    LITERAL
	numbuf_len = 16;		! Maximum 1-word number (octal)

    LOCAL
	datatype,				! "Type" of data to convert
	value,					! Number to convert
	numbuf : VECTOR [CH$ALLOCATION (numbuf_len)],
	numlen,					! Length of converted number
	numptr,					! Pointer to number
	filling,				! Length of blank filling
	length;					! Length of number to output

    datatype = read_control_character ();	! Get the datasize determination

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	value = fetch_parameter ();		! Get the value to output

	IF .value EQL 1				! Set or clear "plural" flag
	THEN
	    flags [fao$v_plural] = 0
	ELSE
	    flags [fao$v_plural] = 1;

	SELECTONE .datatype OF
	    SET

	    [%C'B'] :
		BEGIN
		length = 3;
		value = .value<0, 9>;
		END;

	    [%C'H'] :
		length = 14;

	    [%C'W'] :
		BEGIN
		length = 6;
		value = .value<0, 18>;
		END;

	    [%C'L', %C'G'] :
		BEGIN
		length = 12;
		END;

	    [OTHERWISE] :
		RETURN 0;
	    TES;

	IF .datatype EQL %C'H'			! As halfwords
	THEN
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    nout (CH$PTR (numbuf), 		! Destination
		.value<18, 18>, 		! Left half
		no_mag OR 8; 			! Format (no fill)
		numptr);			! Save pointer
	    CH$WCHAR_A (%C',', numptr);		! Write a comma
	    CH$WCHAR_A (%C',', numptr);		! Write another comma
	    nout (.numptr, 			! Destination
		.value<0, 18>, 			! Left half
		no_mag OR no_lfl OR no_zro OR 6^18 OR 8; 	! Format
		numptr);			! Save pointer
	    numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
	%ELSE	! TOPS-10
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			STRING = (numbuf_len, CH$PTR(numbuf)));
	    $STR_COPY(TARGET = desc,
		STRING = $STR_CONCAT(
			$STR_ASCII(.value<18, 18>, UNSIGNED, BASE8),
			',,',
			$STR_ASCII(.value<0, 18>,
				LEADING_ZERO, UNSIGNED, BASE8, LENGTH = 6)));
	    numlen = .desc[STR$H_LENGTH];
	%FI
	    END
	ELSE
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    nout (CH$PTR (numbuf), 		! Destination
		.value, 			! Number to output
		no_mag OR no_lfl OR no_zro OR .length^18 OR 8;
						! Formatting
		numptr);			! Save pointer
	    numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
	%ELSE	! TOPS-10
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			STRING = (numbuf_len, CH$PTR(numbuf)));
	    $STR_COPY(TARGET = desc,
		STRING = $STR_ASCII(.value,
			LEADING_BLANK, UNSIGNED, BASE8, LENGTH = .length));
	    numlen = .desc[STR$H_LENGTH];
	%FI
	    END;


	!
	!   Output the filling, if any
	!

	IF .flags [fao$v_dirwid]		! Width for directive?
	THEN
	    BEGIN
	    length = MIN (.numlen, .dirwid);
	    filling = .dirwid - .length;
	    END
	ELSE
	    BEGIN
	    length = .numlen;
	    filling = 0;
	    END;

	INCR fillit FROM 1 TO .filling DO
	    outchr (%C' ');

	!
	!   Output as much of the number as the user wanted.
	!

	numptr = CH$PTR (numbuf, .numlen - .length);

	INCR numit FROM 1 TO .length DO
	    outchr (CH$RCHAR_A (numptr));

	END;					! End loop

    RETURN 1;
    END;
ROUTINE i_signed =
    BEGIN

    LITERAL
	numbuf_len = 13;		! Maximum 1-word number (decimal)

    LOCAL
	datatype,				! "Type" of data to convert
	value,					! Number to convert
	numbuf : VECTOR [CH$ALLOCATION (numbuf_len)],
	numlen,					! Length of number written
	numptr;					! Pointer to number

    datatype = read_control_character ();	! Get the datasize determination

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	value = fetch_parameter ();		! Get the value to output

	IF .value EQL 1				! Set or clear "plural" flag
	THEN
	    flags [fao$v_plural] = 0
	ELSE
	    flags [fao$v_plural] = 1;

	SELECTONE .datatype OF
	    SET

	    [%C'B'] :
		value = .value<0, 9, 1>;

	    [%C'W', %C'H'] :
		value = .value<0, 18, 1>;

	    [%C'L', %C'G'] :
	    ;

	    [OTHERWISE] :
		RETURN 0;
	    TES;

	IF .flags [fao$v_dirwid]		! Width for directive?
	THEN
	    BEGIN				! Use fixed width
	%IF %SWITCHES(TOPS20)
	%THEN
	    nout (CH$PTR (numbuf), 		! Destination
		.value, 			! Number to output
		no_lfl OR no_oov OR no_ast OR .dirwid^18 OR 10;
						! Formatting
		numptr);			! Save pointer
	    numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
	%ELSE	! TOPS-10
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			STRING = (numbuf_len, CH$PTR(numbuf)));
	    $STR_COPY(TARGET = desc,
		STRING = $STR_ASCII(.value,
			LEADING_BLANK, BASE10, LENGTH = .dirwid));
	    numlen = .desc[STR$H_LENGTH];
	%FI
	    END
	ELSE
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    nout (CH$PTR (numbuf), 		! Destination
		.value, 			! Formatting
		10; 				! Number to output
		numptr);			! Save pointer
	    numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
	%ELSE	! TOPS-10
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			STRING = (numbuf_len, CH$PTR(numbuf)));
	    $STR_COPY(TARGET = desc,
		STRING = $STR_ASCII(.value, BASE10));
	    numlen = .desc[STR$H_LENGTH];
	%FI
	    END;

	!
	!   Output as much of the number as the user wanted.
	!

	numptr = CH$PTR (numbuf);

	INCR numit FROM 1 TO .numlen DO
	    outchr (CH$RCHAR_A (numptr));

	END;					! End loop

    RETURN 1;
    END;
ROUTINE i_unsigned =
    BEGIN

    LITERAL
	numbuf_len = 13;		! Maximum 1-word number (decimal)

    LOCAL
	datatype,				! "Type" of data to convert
	value,					! Number to convert
	numbuf : VECTOR [CH$ALLOCATION (numbuf_len)],
	numlen,					! Length of number written
	numptr;					! Pointer to number

    datatype = read_control_character ();	! Get the datasize determination

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	value = fetch_parameter ();		! Get the value to output

	IF .value EQL 1				! Set or clear "plural" flag
	THEN
	    flags [fao$v_plural] = 0
	ELSE
	    flags [fao$v_plural] = 1;

	SELECTONE .datatype OF
	    SET

	    [%C'B'] :
		value = .value<0, 9>;

	    [%C'W', %C'H'] :
		value = .value<0, 18>;

	    [%C'L', %C'G'] :
	    ;

	    [OTHERWISE] :
		RETURN 0;
	    TES;

	IF .flags [fao$v_dirwid]		! Width for directive?
	THEN
	    BEGIN				! Use fixed width
	%IF %SWITCHES(TOPS20)
	%THEN
	    nout (CH$PTR (numbuf), 		! Destination
		.value, no_mag OR no_lfl OR no_oov OR no_ast OR
						! Formatting
		.dirwid^18 OR 10; 		! Width and base
		numptr);			! Save pointer
	    numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
	%ELSE	! TOPS-10
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			STRING = (numbuf_len, CH$PTR(numbuf)));
	    $STR_COPY(TARGET = desc,
		STRING = $STR_ASCII(.value,
			LEADING_BLANK, UNSIGNED, BASE10, LENGTH = .dirwid));
	    numlen = .desc[STR$H_LENGTH];
	%FI
	    END
	ELSE
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    nout (CH$PTR (numbuf), 		! Destination
		.value, no_mag OR 10; 		! Formatting
		numptr);			! Save pointer
	    numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
	%ELSE	! TOPS-10
	    LOCAL
		desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	    $STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
			STRING = (numbuf_len, CH$PTR(numbuf)));
	    $STR_COPY(TARGET = desc,
		STRING = $STR_ASCII(.value, UNSIGNED, BASE10));
	    numlen = .desc[STR$H_LENGTH];
	%FI
	    END;

	!
	!   Output as much of the number as the user wanted.
	!

	numptr = CH$PTR (numbuf);

	INCR numit FROM 1 TO .numlen DO
	    outchr (CH$RCHAR_A (numptr));

	END;					! End loop

    RETURN 1;
    END;
ROUTINE i_hex =
    BEGIN

    LITERAL
	numbuf_len = 10;			! Maximum 1-word number (hex)

    LOCAL
	datatype,				! "Type" of data to convert
	value,					! Number to convert
	numbuf : VECTOR [CH$ALLOCATION (numbuf_len)],
	numlen,					! Length of converted number
	numptr,					! Pointer to number
	filling,				! Length of blank filling
	length;					! Length of number to output

    datatype = read_control_character ();	! Get the datasize determination

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	value = fetch_parameter ();		! Get the value to output

	IF .value EQL 1				! Set or clear "plural" flag
	THEN
	    flags [fao$v_plural] = 0
	ELSE
	    flags [fao$v_plural] = 1;

	SELECTONE .datatype OF
	    SET

	    [%C'B'] :
		BEGIN
		length = 3;
		value = .value<0, 9>;
		END;

	    [%C'W', %C'H'] :
		BEGIN
		length = 5;
		value = .value<0, 18>;
		END;

	    [%C'L', %C'G'] :
		BEGIN
		length = 9;
		END;

	    [OTHERWISE] :
		RETURN 0;
	    TES;

	IF .flags [fao$v_dirwid]		! Width for directive?
	THEN
	    BEGIN
	    length = MIN (.length, .dirwid);
	    filling = .dirwid - .length;
	    END
	ELSE
	    filling = 0;

    %IF %SWITCHES(TOPS20)
    %THEN
	nout (CH$PTR (numbuf), 			! Destination
	    .value, no_mag OR no_lfl OR no_zro OR numbuf_len^18 OR 16;
						! Formatting
	    numptr);				! Save pointer
	numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
    %ELSE	! TOPS-10
	BEGIN
	LOCAL
	    desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	$STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
		    STRING = (numbuf_len, CH$PTR(numbuf)));
	$STR_COPY(TARGET = desc,
		STRING = $STR_ASCII(.value,
		    LEADING_ZERO, UNSIGNED, BASE16, LENGTH = numbuf_len));
	numlen = .desc[STR$H_LENGTH];
	END;
    %FI
	!
	!   Output the filling, if any
	!

	INCR fillit FROM 1 TO .filling DO
	    outchr (%C' ');

	!
	!   Output as much of the number as the user wanted.
	!

	numptr = CH$PTR (numbuf, .numlen - .length);

	INCR numit FROM 1 TO .length DO
	    outchr (CH$RCHAR_A (numptr));

	END;					! End loop

    RETURN 1;
    END;
ROUTINE i_zerofilled =
    BEGIN

    LITERAL
	numbuf_len = 13;		! Maximum 1-word number (decimal)

    LOCAL
	datatype,				! "Type" of data to convert
	value,					! Number to convert
	numbuf : VECTOR [CH$ALLOCATION (numbuf_len)],
	numlen,					! Length of converted number
	numptr,					! Pointer to number
	filling,				! Length of blank filling
	length;					! Length of number to output

    datatype = read_control_character ();	! Get the datasize determination

    INCR i FROM 1 TO .repcnt DO
	BEGIN
	value = fetch_parameter ();		! Get the value to output

	IF .value EQL 1				! Set or clear "plural" flag
	THEN
	    flags [fao$v_plural] = 0
	ELSE
	    flags [fao$v_plural] = 1;

	SELECTONE .datatype OF
	    SET

	    [%C'B'] :
		BEGIN
		value = .value<0, 9>;
		END;

	    [%C'W', %C'H'] :
		BEGIN
		value = .value<0, 18>;
		END;

	    [%C'L', %C'G'] :
	    ;

	    [OTHERWISE] :
		RETURN 0;
	    TES;

    %IF %SWITCHES(TOPS20)
    %THEN
	nout (CH$PTR (numbuf), 			! Destination
	    .value, no_oov OR no_ast OR no_mag OR no_lfl OR 	!
	    no_zro OR 10; 	! Formatting
	    numptr);				! Save pointer
	numlen = CH$DIFF (.numptr, CH$PTR (numbuf));! Check length of number
    %ELSE	! TOPS-10
	BEGIN
	LOCAL
	    desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	$STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
		    STRING = (numbuf_len, CH$PTR(numbuf)));
	$STR_COPY(TARGET = desc,
	    STRING = $STR_ASCII(.value,
		    LEADING_ZERO, UNSIGNED, BASE10));
	numlen = .desc[STR$H_LENGTH];
	END;
    %FI
	!
	!   Output the filling, if any
	!

	IF .flags [fao$v_dirwid]		! Width for directive?
	THEN
	    BEGIN
	    numlen = MIN (.numlen, .dirwid);
	    filling = .dirwid - .numlen;
	    END
	ELSE
	    filling = 0;

	INCR fillit FROM 1 TO .filling DO
	    outchr (%C'0');

	!
	!   Output as much of the number as the user wanted.
	!

	numptr = CH$PTR (numbuf);

	INCR numit FROM 1 TO .numlen DO
	    outchr (CH$RCHAR_A (numptr));

	END;					! End loop

    RETURN 1;
    END;
ROUTINE i_version =
    BEGIN

    LITERAL
	verbuf_len = 20;

    LOCAL
	tmpptr,
	versn : monword,
	strlen,
	strptr,
	filling,
	verbuf : VECTOR [CH$ALLOCATION (verbuf_len)];

    INCR i FROM 1 TO .repcnt DO
	BEGIN
    %IF %SWITCHES(TOPS20)
    %THEN
	versn = fetch_parameter ();
	tmpptr = CH$PTR (verbuf);		! Set up pointer
	nout (.tmpptr, .versn [vi_maj], 8; tmpptr);	! Output major version
    %ELSE	! TOPS-10
	LOCAL
	    desc : $STR_DESCRIPTOR(CLASS = BOUNDED);
	versn = fetch_parameter ();
	tmpptr = CH$PTR (verbuf);		! Set up pointer
	$STR_DESC_INIT(DESCRIPTOR = desc, CLASS = BOUNDED,
		    STRING = (verbuf_len, CH$PTR(verbuf)));
	$STR_COPY(TARGET = desc,
	    STRING = $STR_ASCII(.versn [vi_maj], BASE8, LEADING_BLANK));
    %FI

	IF .versn [vi_min] NEQ 0		! Minor version?
	THEN
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    CH$WCHAR_A (%C'.', tmpptr);		! Punctuate it
	    nout (.tmpptr, .versn [vi_min], 8; tmpptr);	! Minor version
	%ELSE	! TOPS-10
	    $STR_APPEND(TARGET = desc,
		STRING = $STR_CONCAT(
			'.',
			$STR_ASCII(.versn [vi_min], BASE8, LEADING_BLANK)));
	%FI
	    END;

	IF .versn [vi_edn] NEQ 0		! Edit number?
	THEN
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    CH$WCHAR_A (%C'(', tmpptr);		! Start edit number
	    nout (.tmpptr, .versn [vi_edn], 8; tmpptr);
	    CH$WCHAR_A (%C')', tmpptr);		! End edit number
	%ELSE	! TOPS-10
	    $STR_APPEND(TARGET = desc,
		STRING = $STR_CONCAT(
			'(',
			$STR_ASCII(.versn [vi_edn], BASE8, LEADING_BLANK),
			')'));
	%FI
	    END;

	IF .versn [vi_who] NEQ 0		! "Who did it"?
	THEN
	    BEGIN
	%IF %SWITCHES(TOPS20)
	%THEN
	    CH$WCHAR_A (%C'-', tmpptr);		! Start "who"
	    nout (.tmpptr, .versn [vi_who], 8; tmpptr);
	%ELSE	! TOPS-10
	    $STR_APPEND(TARGET = desc,
		STRING = $STR_CONCAT(
				'-',
				$STR_ASCII(.versn [vi_who], BASE8,
						LEADING_BLANK)));
	%FI
	    END;

	strptr = CH$PTR (verbuf);
    %IF %SWITCHES(TOPS20)
    %THEN
	strlen = CH$DIFF (.tmpptr, .strptr);
    %ELSE
	strlen = .desc[STR$H_LENGTH];
    %FI

	!
	!   If we have a specified width for this
	!   directive, we should set it up.
	!

	IF .flags [fao$v_dirwid]		! Width for directive?
	THEN
	    BEGIN
	    strlen = MIN (.strlen, .dirwid);
	    filling = .dirwid - .strlen;
	    END
	ELSE
	    filling = 0;

	!
	!   Output the string
	!

	INCR i FROM 1 TO .strlen DO
	    BEGIN

	    LOCAL
		strchr;

	    strchr = CH$RCHAR_A (strptr);
	    outchr (.strchr);			! Put out any character
	    END;

	!
	!   Fill the string, if necessary
	!

	IF .flags [fao$v_dirwid]		! Width specified?
	THEN

	    INCR i FROM 1 TO .filling DO 	! Fill the string
		outchr (%C' ');			! Output a blank

	END;

    RETURN 1;
    END;					! End I_VERSION
ROUTINE parse_number =
    BEGIN

    LOCAL
	number;

    char = read_control_character ();
    !
    !   This character is guaranteed to be a # or a digit.
    !

    IF .char EQL %C'#'		! A variable repeat count or field width
    THEN
	BEGIN
	number = fetch_parameter ();
	char = test_control_character ();
	END
    ELSE
	BEGIN
	number = .char - %C'0';
	char = test_control_character ();

	UNTIL (.char LSS %C'0') OR (.char GTR %C'9') DO
	    BEGIN
	    advance_control_character ();
	    number = (.number*10) + (.char - %C'0');
	    char = test_control_character ();
	    END;

	END;

    SELECTONE .char OF
	SET

	[%C'A', %C'O', %C'E', %C'X', %C'Z', %C'U', %C'S'] :
	    BEGIN
	    dirwid = .number;
	    flags [fao$v_dirwid] = 1;
	    RETURN insert_directive ();
	    END;

	[%C'<'] :
	    BEGIN
	    fldwid = .number;
	    flags [fao$v_field] = 1;
	    advance_control_character ();
	    END;

	[%C'%'] :
	    BEGIN
	    advance_control_character ();
	    flags [fao$v_dirwid] = 1;
	    dirwid = .number;
	    RETURN system_directive ();
	    END;

	[%C'('] :
	    BEGIN
	    advance_control_character ();
	    repcnt = .number;
	    char = test_control_character ();

	    SELECTONE .char OF
		SET

		[%C'A', %C'E', %C'O', %C'X', %C'Z', %C'U', %C'S'] :
		    BEGIN

		    LOCAL
			status;

		    status = insert_directive ();
		    char = read_control_character ();	! Eat assumed ")"
		    RETURN .status;
		    END;

		[%C'/', %C'_', %C'^', %C'!', %C'-', %C'+'] :
		    BEGIN

		    LOCAL
			status;

		    status = do_directive ();
		    char = read_control_character ();	! Eat ")"
		    RETURN .status;
		    END;

		[%C'#', %C'0' TO %C'9'] :
		    BEGIN

		    LOCAL
			status;

		    char = read_control_character ();
		    !
		    !   This character is guaranteed to be a # or a digit.
		    !

		    IF .char EQL %C'#'	! A variable repeat count or field width
		    THEN
			BEGIN
			number = fetch_parameter ();
			char = test_control_character ();
			END
		    ELSE
			BEGIN
			number = .char - %C'0';
			char = test_control_character ();

			UNTIL (.char LSS %C'0') OR (.char GTR %C'9') DO
			    BEGIN
			    advance_control_character ();
			    number = (.number*10) + (.char - %C'0');
			    char = test_control_character ();
			    END;

			END;

		    dirwid = .number;
		    flags [fao$v_dirwid] = 1;
		    status = do_directive ();
		    char = read_control_character ();	! Eat assumed ")"
		    RETURN .status;
		    END;

		[%C'%'] :
		    BEGIN
		    advance_control_character ();
		    system_directive ();
		    END;

		[OTHERWISE] :
		    RETURN 0;			! Must be an error
		TES;

	    repcnt = 1;
	    END;

	[%C'*'] : 				! VMS V4 repetition
	    BEGIN
	    repcnt = .number;
	    advance_control_character ();	! Skip "*"
	    repchr = read_control_character ();	! Get the character

	    INCR i FROM 1 TO .repcnt DO
		outchr (.repchr);

	    repcnt = 1;
	    END;

	[OTHERWISE] : 			! VMS V3 and earlier repetition
	    BEGIN
	    repcnt = .number;
	    repchr = read_control_character ();

	    INCR i FROM 1 TO .repcnt DO
		outchr (.repchr);

	    repcnt = 1;
	    END;
	TES;

    RETURN 1;
    END;					! End PARSE_NUMBER
ROUTINE outchr (charout) : NOVALUE =
    BEGIN

    !
    !   Keep track of the case of the last
    !   character that we output.
    !

    SELECTONE .charout OF
	SET

	[%C'A' TO %C'Z'] :
	    flags [fao$v_uppercase] = 1;

	[%C'a' TO %C'z'] :
	    flags [fao$v_uppercase] = 0;

	[OTHERWISE] :
	;					! No change
	TES;

    IF .flags [fao$v_field]			! Outputting a field?
    THEN
	BEGIN

	IF .fldwid GTR 0			! Space left in the field?
	THEN
	    BEGIN				! Outputting a field
	    fldwid = .fldwid - 1;		! Decrement field width

	    IF .outspc GTR 0			! Room left in buffer?
	    THEN
		BEGIN
		outspc = .outspc - 1;		! Decrement space left
		CH$WCHAR_A (.charout, outptr);	! Write the character
		tmplen = .tmplen + 1;		! Increment string length
		END
	    ELSE
		BEGIN
		status = ss$_bufferovf;		! Buffer overflow
		END;

	    END;

	END
    ELSE
	BEGIN					! Not outputting a field

	IF .outspc GTR 0			! Still need buffer space, though
	THEN
	    BEGIN
	    outspc = .outspc - 1;		! Decrement space left
	    CH$WCHAR_A (.charout, outptr);	! Write the character
	    tmplen = .tmplen + 1;		! Increment string length
	    END
	ELSE
	    BEGIN
	    status = ss$_bufferovf;		! Buffer overflow
	    END;

	END;

    END;					! End OUTCHR
%IF %SWITCHES(TOPS10)
%THEN
ROUTINE filstr (p_desc, jfn) =
    BEGIN
    LOCAL
	filop_arg_blk : VECTOR[2],
	file_spec_blk : VECTOR[$FOFSF + 1 + 5];

    REGISTER
	t1;

    BIND
	file_spec_sfd_blk = file_spec_blk[$FOFSF] : VECTOR[5],
	desc = .p_desc : $STR_DESCRIPTOR(CLASS = BOUNDED);

    filop_arg_blk[0] = .jfn ^ 18 + $FOFIL;
    filop_arg_blk[1] = ($FOFSF + 1 + 5) ^ 18 + file_spec_blk[0];

    t1 = 2 ^ 18 + filop_arg_blk[0];
    IF NOT FILOP$_UUO(t1)
    THEN
	RETURN 0;

    sixbit_to_ascii(file_spec_blk[$FOFDV], desc);
    $STR_APPEND(TARGET = desc, STRING = ':');

    sixbit_to_ascii(file_spec_blk[$FOFFN], desc);
    $STR_APPEND(TARGET = desc, STRING = '.');

    sixbit_to_ascii(file_spec_blk[$FOFEX], desc);

    $STR_APPEND(TARGET = desc,
	STRING = $STR_CONCAT(
	    '[',
	    $STR_ASCII(.(file_spec_blk[$FOFPP])<18,18>, BASE8, LEADING_BLANK),
	    ',',
	    $STR_ASCII(.(file_spec_blk[$FOFPP])<0,18>, BASE8, LEADING_BLANK)));

    INCR i FROM 0 TO 4
    DO
	BEGIN
	IF .file_spec_sfd_blk[.i] EQL 0
	THEN
	    EXITLOOP;

	$STR_APPEND(TARGET = desc, STRING = ',');
	sixbit_to_ascii(file_spec_sfd_blk[.i], desc);
	END;

    $STR_APPEND(TARGET = desc, STRING = ']');

    RETURN .desc[STR$H_LENGTH];
    END;					! End FILSTR
ROUTINE sixbit_to_ascii (P_SIXBIT_WORD, ASCII_DESCR) =
!++
! FUNCTIONAL DESCRIPTION:
!	Append a SIXBIT word to a BOUNDED  ASCII string descriptor
!	(ignore sixbit blanks)
!
! FORMAL PARAMETERS:
!
!	P_SIXBIT_WORD: the address of a word
!	ASCII_DESCR: Pointer to an  ASCII string descriptor
!
! ROUTINE VALUE:
!	Count of characters copied
!
!--
    BEGIN
    LOCAL
	s_ptr,
	a_ptr,
	chr;

    BIND SIXBIT_WORD = .P_SIXBIT_WORD;
    MAP ASCII_DESCR : REF $STR_DESCRIPTOR(CLASS=BOUNDED);

    s_ptr = CH$PTR(SIXBIT_WORD,0,6);	! Pointer to sixbit word
    a_ptr = CH$PLUS(.ASCII_DESCR[STR$A_POINTER],
	.ASCII_DESCR[STR$H_LENGTH]);! Pointer to ASCII string

    INCR i FROM 1 TO MIN(6, .ASCII_DESCR[STR$H_MAXLEN]
				- .ASCII_DESCR[STR$H_PFXLEN]
				- .ASCII_DESCR[STR$H_LENGTH])
    DO
	BEGIN
	chr = CH$RCHAR_A(s_ptr);
	IF .chr EQL 0			! If sixbit blank
	THEN
	    RETURN(.i - 1);		! Done, return char count
	chr = .chr + %C' ';		! Convert to ASCII
	CH$WCHAR_A(.chr, a_ptr);
	ASCII_DESCR[STR$H_LENGTH] = .ASCII_DESCR[STR$H_LENGTH] + 1;
	END;
    RETURN(6)				! Return char count
    END;				! End of sixbit_to_ascii
ROUTINE date_to_string (date_time, p_descr) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!   Convert internal date/time to string.
!
! FORMAL PARAMETERS:
!   date_time           - date and time in universal internal format
!                         (-1 means now)
!   p_descr             - pointer to descriptor to receive string
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    OWN
	montab: VECTOR[12] INITIAL(
		%ASCII'-Jan-',
		%ASCII'-Feb-',
		%ASCII'-Mar-',
		%ASCII'-Apr-',
		%ASCII'-May-',
		%ASCII'-Jun-',
		%ASCII'-Jul-',
		%ASCII'-Aug-',
		%ASCII'-Sep-',
		%ASCII'-Oct-',
		%ASCII'-Nov-',
		%ASCII'-Dec-');

    LOCAL
	time,
	date,
	day,
	month,
	year,
	hour,
	minute,
	second;

    BIND
        descr = .p_descr : $STR_DESCRIPTOR ();
    !
    ! If date/time is -1, that means now.  Get NOW from monitor
    !
    IF .date_time EQL -1
    THEN
	BEGIN
	REGISTER t1;
	t1 = _CNDTM;
	GETTAB_UUO(t1);
	date_time = .t1;
	END;
    !
    ! Convert universal date/time to internal format
    !
    $CNTDT(.date_time, time, date);

    day = .date MOD 31 + 1;
    month = (.date / 31) MOD 12;
    year = (((.date / (12 * 31)) + 64) MOD 100) + 1900;
    time = .time / 1000 + (IF .time MOD 1000 GEQ 500 THEN 1 ELSE 0);
    second = .time MOD 60;
    minute = (.time / 60) MOD 60;
    hour = .time / (60 * 60);
    !
    ! Now, build the string
    !
    $STR_COPY(TARGET=descr,
	STRING=$STR_CONCAT(
		$STR_ASCII(.day, LENGTH=2, BASE10, LEADING_BLANK),
		(5,CH$PTR(montab[.month])),
		$STR_ASCII(.year),
		' ',
		$STR_ASCII(.hour, LENGTH=2,, BASE10, LEADING_BLANK),
		':',
		$STR_ASCII(.minute, LENGTH=2, BASE10, LEADING_ZERO),
		':',
		$STR_ASCII(.second, LENGTH=2, BASE10, LEADING_ZERO)));

    END;                                ! End of date_to_string
%FI
ROUTINE system_directive =
    BEGIN

    MACRO
	$xwd (lh, rh) =
 (((lh) AND %O'777777')^18 OR ((rh) AND %O'777777')) %;

    LITERAL
	datbuf_len = 20;

    LOCAL
	cchar,					! Control character for output
	action,
	tmpptr,
	dattim,
	strlen,
	strptr,
	filling,
	datbuf : VECTOR [CH$ALLOCATION (datbuf_len)];

    action = read_control_character ();
    !
    !   If the action is to put out a control
    !   character (e.g., ^G or <BEL>), then
    !   get that character now.
    !

    IF .action EQL %C'^'			! Control char output?
    THEN
	cchar = read_control_character ();	! Get the character

    INCR i FROM 1 TO .repcnt DO
	BEGIN

	SELECTONE .action OF
	    SET

	    [%C'^'] : 				! Put out a control character
		BEGIN
		outchr (.cchar AND %O'37');
		END;

	    [%C'S'] :

		IF .flags [fao$v_plural]	! Output an "S" if plural
		THEN

		    IF .flags [fao$v_uppercase]	! "S" or "s"?
		    THEN
			outchr (%C'S')		! Uppercase
		    ELSE
			outchr (%C's');		! Lowercase

	    [%C'P'] :

		IF .flags [fao$v_plural]	! Output an "S" if plural
		THEN
		    outchr (%C'S');		! Uppercase

	    [%C'p'] :

		IF .flags [fao$v_plural]	! Output an "S" if plural
		THEN
		    outchr (%C's');		! Lowercase

	    [%C'T', %C'D'] :
		BEGIN
		dattim = fetch_parameter ();

		IF .dattim EQL 0 THEN dattim = -1;	! Default to last error

	    %IF %SWITCHES(TOPS20)
	    %THEN
		odtim (CH$PTR (datbuf), 	!
		    .dattim, 			!
		    (IF .action EQL %C'T' THEN ot_nda ELSE ot_4yr); 	!
		    tmpptr);			! Save returned pointer
		strptr = CH$PTR (datbuf);
		strlen = CH$DIFF (.tmpptr, .strptr);
	    %ELSE
		BEGIN
		LOCAL
		    desc : $STR_DESCRIPTOR();
		$STR_DESC_INIT(DESCRIPTOR = desc,
			STRING = (datbuf_len, CH$PTR(datbuf)));
		date_to_string(.dattim, desc);
		strptr = (IF .action EQL %C'D'
			THEN CH$PTR(datbuf) ELSE CH$PLUS(CH$PTR(datbuf), 12));
		strlen = .desc[STR$H_LENGTH] - (IF .action EQL %C'D'
						THEN 0 ELSE 12);
		END;
	    %FI

		!
		!   If we have a specified width for this
		!   directive, we should set it up.
		!

		IF .flags [fao$v_dirwid]	! Specified output width?
		THEN
		    BEGIN
		    strlen = MIN (.dirwid, .strlen);	! Length to copy
		    filling = .dirwid - .strlen;	! Length to fill
		    END;

		!
		!   Output the string
		!

		INCR i FROM 1 TO .strlen DO
		    BEGIN

		    LOCAL
			strchr;

		    strchr = CH$RCHAR_A (strptr);
		    outchr (.strchr);		! Put out any character
		    END;

		!
		!   Fill the string, if necessary
		!

		IF .flags [fao$v_dirwid]	! Width specified?
		THEN

		    INCR i FROM 1 TO .filling DO 	! Fill the string
			outchr (%C' ');		! Output a blank

		END;

	    [OTHERWISE] :
		RETURN 0;
	    TES;

	END;

    RETURN 1;
    END;					! End SYSTEM_DIRECTIVE
END

ELUDOM
						! End module FAO