Trailing-Edge
-
PDP-10 Archives
-
tops20-v7-ft-dist1-clock
-
7-sources/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