Trailing-Edge
-
PDP-10 Archives
-
BB-KL11L-BM_1990
-
t20src/mxntxt.b36
There are 13 other files named mxntxt.b36 in the archive. Click here to see a list.
module NMUTXT ( ! Text formatting
ident = 'X04.08'
) =
begin
! COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1985, 1989.
! 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.
!++
! Facility: LSG DECnet Network Management
!
! Abstract: This module provides text formatting facilities. The main
! global routine (NMU$TEXT) is called with a text pattern, a
! set of parameter values and a output pointer. The pattern
! is interpreted (copying or processing directives) to generate
! the output string.
!
! Environment: TOPS10/TOPS20 user mode, MCB RSX task level
!
! Author: Steven M. Jenness, Creation date: 10-Oct-80
!
!--
!<BLF/SYNONYM %unquote =>
!<BLF/PAGE>
!
! Include files
!
library 'MXNLIB'; ! All required definitions
%if $TOPS20
%then
library 'MONSYM'; ! Monitor symbols
library 'MXJLNK'; ! JSYS linkage definitions
%fi
!
! Global routines
!
forward routine
NMU$TEXT_MANAGER; ! Define entry points
!
! Local routines
!
forward routine
TEXT_R, ! Recursive pattern interpreter
NEXT_PARM, ! Get next parameter value
CHAR_OUT, ! Send character to output stream
REPEAT : novalue, ! Repeat directive
PROCESS_DIRECTIVE : novalue, ! Directive processing routine
JUSTIFICATION : novalue, ! Field justification/fill
$C5TA : novalue, ! RAD50 to ASCII string
CVTC, ! Extract RAD50 character
NUMBER_CONVERSION : novalue, ! General binary to ASCII
$CBDAT : novalue, ! Binary to 2 digit DECIMAL
DATE_CONVERSION : novalue, ! Date
TIME_CONVERSION : novalue; ! Time
!
! Character codes
!
literal
SPACE = %C' ',
TAB = %C' ',
FORM_FEED = %O'14',
CARRIAGE_RETURN = %O'15',
LINE_FEED = %O'12',
NULL = %O'0';
!
! Own variables
!
own
TSB_SPACE : TEXT_STATE_BLOCK;
!
! External routines
!
external routine
NMU$MEMORY_MANAGER; ! Memory management routines
global routine %unquote NMU$TEXT (OUTPUT, OUTPUT_LIMIT, PATTERN, PARM_COUNT, PARM_LIST) =
!++
! Functional description:
!
!
! Formal parameters:
!
! .OUTPUT Address of byte pointer to output stream.
! .OUTPUT_LIMIT Max characters to output.
! .PATTERN Byte pointer to directive pattern.
! .PARM_COUNT Number of parameters in parameter list.
! .PARM_LIST Address of parameter list.
!
! Routine value:
!
! The number of characters sent to the output stream.
! If the interpretation/conversion failed, the character
! count is the negated.
!
! Side effects:
!
! The output byte pointer is updated to point to the
! end of the output stream.
!
!--
begin
local
TSB : ref TEXT_STATE_BLOCK,
RESULT;
!
! Allocate a text state block
!
TSB = TSB_SPACE;
!
! Changed back to statically allocated TSB since the TRACE_INFO
! macro used the NMU$TEXT routine to format it's output. This
! created a recursive loop when tracing was done in the memory
! manager.
!
! TSB = NMU$MEMORY_GET (TEXT_BLOCK_ALLOCATION);
!
!
! Initialize state block from calling parameters
!
TSB [PARAMETER_LIST] = .PARM_LIST;
TSB [PARAMETER_NEXT] = .PARM_LIST;
TSB [PARAMETER_COUNT] = .PARM_COUNT;
!
TSB [PATTERN_START] = .PATTERN;
TSB [PATTERN_PTR] = .PATTERN;
TSB [PATTERN_CHECKPOINT] = .PATTERN;
!
TSB [OUTPUT_ROUTINE] = CHAR_OUT;
TSB [OUTPUT_START] = ..OUTPUT;
TSB [OUTPUT_PTR] = ..OUTPUT;
TSB [OUTPUT_MAX] = .OUTPUT_LIMIT;
TSB [OUTPUT_COUNT] = 0;
TSB [OUTPUT_POSITION] = 0;
!
TSB [NULL_SUPPRESS] = $false;
!
! Call recursive interpreter
!
TEXT_R (.TSB);
!
! If a null is wanted at the end .. make the output string
! ASCIZ
!
if (.TSB [STATE] eql DONE) and ( not .TSB [NULL_SUPPRESS]) then CHAR_OUT (.TSB, 0);
!
! Return the final output pointer
!
.OUTPUT = .TSB [OUTPUT_PTR];
!
! Set the resulting count of output characters
! depending on the terminating state of the
! interpreter.
!
if .TSB [STATE] eql DONE
then RESULT = .TSB [OUTPUT_COUNT]
else RESULT = -.TSB [OUTPUT_COUNT];
!
! Release the text state block.
!
! NMU$MEMORY_RELEASE (.TSB, TEXT_BLOCK_ALLOCATION);
!
! Return resulting count of output characters
!
.RESULT
end; ! End of NMU$TEXT
routine TEXT_R (TSB) =
!++
! Functional description:
!
!
! Formal parameters:
!
! TSB Address of a text state block (see field definition
! above).
!
! Routine value:
!
! $TRUE Interpretation has been successful.
! $FALSE An error has been detected and interpretation aborted.
!
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
local
CHAR;
TSB [STATE] = TEXT_COPY;
while (.TSB [STATE] lss DONE) do
if (CHAR = ch$rchar_a (TSB [PATTERN_PTR])) eql 0
then
if .TSB [STATE] eql TEXT_COPY then TSB [STATE] = DONE else TSB [STATE] = ABORT
else
case .TSB [STATE] from STATE_MIN to STATE_MAX of
set
[TEXT_COPY] :
if .CHAR eql %C'%'
then
begin
TSB [STATE] = DIRECTIVE_START;
TSB [PATTERN_CHECKPOINT] = ch$plus (.TSB [PATTERN_PTR], -1);
end
else
CHAR_OUT (.TSB, .CHAR);
[DIRECTIVE_START] :
begin
TSB [FIELD_DEFAULT] = $true;
TSB [FIELD_NOWIDTH] = $true;
TSB [FIELD_REPEAT] = 1;
TSB [FIELD_WIDTH] = .TSB [OUTPUT_MAX] - .TSB [OUTPUT_COUNT];
TSB [FIELD_COUNT] = 0;
TSB [FIELD_JUSTIFY] = NO_FILL;
selectone .CHAR of
set
[%C'#'] :
begin
TSB [FIELD_DEFAULT] = $false;
TSB [STATE] = REPT_PARM;
TSB [FIELD_REPEAT] = NEXT_PARM (.TSB);
end;
[%C'('] :
TSB [STATE] = WIDTH_START;
[%C'0' to %C'9'] :
begin
TSB [FIELD_REPEAT] = .CHAR - %C'0';
TSB [FIELD_DEFAULT] = $false;
TSB [STATE] = REPT_VALUE;
end;
[otherwise] :
PROCESS_DIRECTIVE (.TSB, .CHAR);
tes;
end;
[REPT_PARM] :
if .CHAR eql %C'(' then TSB [STATE] = WIDTH_START else PROCESS_DIRECTIVE (.TSB, .CHAR);
[REPT_VALUE] :
if .CHAR eql %C'('
then
TSB [STATE] = WIDTH_START
else
if ((.CHAR lss %C'0') or (.CHAR gtr %C'9'))
then
PROCESS_DIRECTIVE (.TSB, .CHAR)
else
TSB [FIELD_REPEAT] = (.TSB [FIELD_REPEAT]*10) + .CHAR - %C'0';
[WIDTH_START] :
selectone .CHAR of
set
[%C'#'] :
begin
TSB [STATE] = WIDTH_PARM;
TSB [FIELD_WIDTH] = NEXT_PARM (.TSB);
TSB [FIELD_NOWIDTH] = $false;
end;
[%C'0' to %C'9'] :
begin
TSB [FIELD_WIDTH] = .CHAR - %C'0';
TSB [STATE] = WIDTH_VALUE;
TSB [FIELD_NOWIDTH] = $false;
end;
[otherwise] :
TSB [STATE] = ABORT;
tes;
[WIDTH_PARM] :
selectone .CHAR of
set
[%C')'] :
TSB [STATE] = WIDTH_END;
[%C'L'] :
begin
TSB [STATE] = JUSTIFY_FIELD;
TSB [FIELD_JUSTIFY] = LEFT_JUSTIFY;
end;
[%C'R'] :
begin
TSB [STATE] = JUSTIFY_FIELD;
TSB [FIELD_JUSTIFY] = RIGHT_JUSTIFY;
end;
[%C'C'] :
begin
TSB [STATE] = JUSTIFY_FIELD;
TSB [FIELD_JUSTIFY] = CENTER_FILL;
end;
[otherwise] :
TSB [STATE] = ABORT;
tes;
[WIDTH_VALUE] :
selectone .CHAR of
set
[%C')'] :
TSB [STATE] = WIDTH_END;
[%C'L'] :
begin
TSB [STATE] = JUSTIFY_FIELD;
TSB [FIELD_JUSTIFY] = LEFT_JUSTIFY;
end;
[%C'R'] :
begin
TSB [STATE] = JUSTIFY_FIELD;
TSB [FIELD_JUSTIFY] = RIGHT_JUSTIFY;
end;
[%C'C'] :
begin
TSB [STATE] = JUSTIFY_FIELD;
TSB [FIELD_JUSTIFY] = CENTER_FILL;
end;
[%C'0' to %C'9'] :
TSB [FIELD_WIDTH] = (.TSB [FIELD_WIDTH]*10) + .CHAR - %C'0';
[otherwise] :
TSB [STATE] = ABORT;
tes;
[JUSTIFY_FIELD] :
if .CHAR eql %C')' then TSB [STATE] = WIDTH_END else TSB [STATE] = ABORT;
[WIDTH_END] :
PROCESS_DIRECTIVE (.TSB, .CHAR);
tes;
if .TSB [STATE] eql DONE then $true else $false
end; ! End of TEXT_R
routine CHAR_OUT (TSB, CHAR) =
!++
! Functional description:
!
! Writes a character into the output stream if there is still
! room in the output buffer. If output overflow would occur with
! this call the output is not done and the output count is not
! updated.
!
!
! Formal parameters: none
!
! TSB Text state block.
! CHAR Character to output.
!
! Routine value:
!
! $TRUE if character was successfully output.
! $FALSE if output overflow occured.
!
! Side effects:
!
! If a character was written into the output buffer the
! OUTPUT_COUNT field of the TSB is incremented.
! If the total output buffer overflowed, the state
! is changed to BUFFER_OVERFLOW.
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
!
! Check if character should really be output.
! Check all overflows: buffer and field.
!
if .TSB [STATE] leq DONE
then
begin
if .TSB [OUTPUT_COUNT] geq .TSB [OUTPUT_MAX]
then
begin
TSB [STATE] = BUFFER_OVERFLOW;
return $false;
end
else
if (.TSB [STATE] neq TEXT_COPY) and (.TSB [STATE] lss DONE)
then
begin
TSB [FIELD_COUNT] = .TSB [FIELD_COUNT] + 1;
if .TSB [FIELD_COUNT] gtr .TSB [FIELD_WIDTH]
then
begin
TSB [FIELD_OVERFLOW] = $true;
return $false;
end;
end;
!
! Adjust horizontal position value
!
if .CHAR geq SPACE
then TSB [OUTPUT_POSITION] = .TSB [OUTPUT_POSITION] + 1
else
if .CHAR eql CARRIAGE_RETURN
then TSB [OUTPUT_POSITION] = 0;
!
! Write character to output buffer
!
TSB [OUTPUT_COUNT] = .TSB [OUTPUT_COUNT] + 1;
ch$wchar_a (.CHAR, TSB [OUTPUT_PTR]);
$true
end
else
$false
end; ! End of CHAR_OUT
routine NEXT_PARM (TSB) =
!++
! Functional description:
!
!
! Formal parameters:
!
! TSB Text state block (see format above).
!
! Routine value:
!
! Next value in parameter list (if any).
!
! Side effects:
!
! The state is changed to ABORT if the parameter list
! is overflowed.
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
bind
PARM_LIST = .TSB [PARAMETER_NEXT] : vector;
if .TSB [PARAMETER_COUNT] leq 0
then
TSB [STATE] = ABORT
else
begin
TSB [PARAMETER_COUNT] = .TSB [PARAMETER_COUNT] - 1;
TSB [PARAMETER_NEXT] = PARM_LIST [1];
.PARM_LIST [0]
end
end; ! End of NEXT_PARM
routine PROCESS_DIRECTIVE (TSB, CHAR) : novalue =
!++
! Functional description:
!
!
! Formal parameters:
!
! .TSB Text state block address
! .CHAR Directive character
!
! Routine value: none
! Side effects:
!
! The state may be changed to ABORT if a failure
! during directive processing occurs.
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
TSB [FIELD_SIGNED] = $false;
TSB [FIELD_ZERO_SUPPRESS] = $true;
TSB [FIELD_OVERFLOW] = $false;
TSB [OUTPUT_CHECKPOINT] = .TSB [OUTPUT_COUNT];
selectone .CHAR of
set
!
! Insert a '%' into the output stream
!
[%C'%'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
while (REPT = .REPT - 1) geq 0 do
CHAR_OUT (.TSB, %C'%');
end;
!
! Bypass some parameters
!
[%C'+'] :
begin
bind
REPT = TSB [FIELD_REPEAT],
PARM_LIST = .TSB [PARAMETER_NEXT] : vector;
if (PARM_LIST [.REPT] lss .TSB [PARAMETER_LIST]) or (.TSB [PARAMETER_COUNT] - .REPT) leq 0
then
TSB [STATE] = ABORT
else
begin
TSB [PARAMETER_NEXT] = PARM_LIST [.REPT];
TSB [PARAMETER_COUNT] = .TSB [PARAMETER_COUNT] - .REPT;
end;
end;
!
! Back up over some parameters
!
[%C'-'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
bind
PARM_LIST = .TSB [PARAMETER_NEXT] : vector;
if (PARM_LIST [-.REPT] lss .TSB [PARAMETER_LIST]) or (.TSB [PARAMETER_COUNT] + .REPT) leq 0
then
TSB [STATE] = ABORT
else
begin
TSB [PARAMETER_NEXT] = PARM_LIST [-.REPT];
TSB [PARAMETER_COUNT] = .TSB [PARAMETER_COUNT] + .REPT;
end;
end;
!
! Insert one or more CR/LF pairs
!
[%C'/'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
while (REPT = .REPT - 1) geq 0 do
begin
CHAR_OUT (.TSB, CARRIAGE_RETURN);
CHAR_OUT (.TSB, LINE_FEED)
end;
end;
!
! Transfer character string to output stream.
!
[%C'A'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
local
CHAR,
PTR;
PTR = NEXT_PARM (.TSB);
if .TSB [FIELD_DEFAULT]
then
while (CHAR = ch$rchar_a (PTR)) neq 0 do
CHAR_OUT (.TSB, .CHAR)
else
while (REPT = .REPT - 1) geq 0 do
CHAR_OUT (.TSB, ch$rchar_a (PTR));
end;
!
! Display character item as unsigned octal number.
!
! If the rept count is less than zzero then a pointer
! to the character stream to use as a separator.
!
! Next parameter item is a pointer to characters for
! conversion.
!
[%C'B'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
local
PTR,
COUNT_SAVE,
WIDTH_SAVE,
SEP_PTR;
if (.REPT lss 0)
then
begin
SEP_PTR = NEXT_PARM (.TSB);
REPT = -.REPT;
end
else
SEP_PTR = ch$asciz (' ');
PTR = NEXT_PARM (.TSB);
if (.TSB [STATE] lss DONE) and (.REPT gtr 0)
then
begin
WIDTH_SAVE = .TSB [FIELD_WIDTH];
TSB [FIELD_RADIX] = 8;
TSB [FIELD_ZERO_SUPPRESS] = $false;
while (REPT = .REPT - 1) geq 0 do
begin
TSB [FIELD_WIDTH] = 3;
COUNT_SAVE = .TSB [FIELD_COUNT];
TSB [FIELD_COUNT] = 0;
NUMBER_CONVERSION (.TSB, ch$rchar_a (PTR));
TSB [FIELD_WIDTH] = .WIDTH_SAVE;
TSB [FIELD_COUNT] = .COUNT_SAVE + 3;
if .REPT gtr 0
then
begin
local NPTR, CHAR;
NPTR = .SEP_PTR;
while (CHAR = ch$rchar_a (NPTR)) neq 0
do CHAR_OUT (.TSB, .CHAR);
end
end;
end;
end;
!
! Output character represented by integer value
!
[%C'C'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
CHAR = NEXT_PARM (.TSB);
while (REPT = .REPT - 1) geq 0
do
CHAR_OUT (.TSB, .CHAR);
end;
!
! Display parameter as signed decimal.
!
[%C'D'] :
begin
TSB [FIELD_SIGNED] = $true;
TSB [FIELD_RADIX] = 10;
REPEAT (.TSB);
end;
!
! Insert character string while editing undisplayable
! characters to the character '.'.
!
[%C'E'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
local
CHAR,
PTR;
PTR = NEXT_PARM (.TSB);
while (REPT = .REPT - 1) geq 0 do
begin
CHAR = ch$rchar_a (PTR);
if .CHAR lss SPACE or .CHAR gtr 125 then CHAR = %C'.';
CHAR_OUT (.TSB, .CHAR)
end;
end;
!
! Display parameter as unsigned Hexadecimal (zero suppressed).
!
[%C'H'] :
begin
TSB [FIELD_RADIX] = 16;
REPEAT (.TSB);
end;
!
! Recurse to interpret a indirect pattern
!
[%C'I'] :
begin
local
SAVE_P_STATE,
SAVE_P_PTR,
SAVE_P_START,
SAVE_P_CHKPNT;
SAVE_P_PTR = .TSB [PATTERN_PTR];
SAVE_P_START = .TSB [PATTERN_START];
SAVE_P_CHKPNT = .TSB [PATTERN_CHECKPOINT];
SAVE_P_STATE = .TSB [STATE];
TSB [PATTERN_START] = NEXT_PARM (.TSB);
if .TSB [STATE] neq ABORT
then
begin
TSB [PATTERN_PTR] = .TSB [PATTERN_START];
TSB [PATTERN_CHECKPOINT] = .TSB [PATTERN_START];
TEXT_R (.TSB);
TSB [PATTERN_PTR] = .SAVE_P_PTR;
TSB [PATTERN_CHECKPOINT] = .SAVE_P_CHKPNT;
if .TSB [STATE] neq ABORT
THEN
TSB [STATE] = .SAVE_P_STATE;
end;
TSB [PATTERN_START] = .SAVE_P_START;
end;
!
! Interpret TOPS20 specific error code.
!
[%C'J'] :
%if $TOPS20
%then
begin
DECLARE_JSYS (ERSTR)
local
CODE,
COUNT,
RETPTR;
CODE <0, 18> = NEXT_PARM (.TSB);
CODE <18, 18> = $FHSLF;
COUNT <0, 18> = 0;
COUNT <18, 18> = .TSB [FIELD_WIDTH];
case $$ERSTR (.TSB [OUTPUT_PTR], .CODE, .COUNT; RETPTR)
from 0 to 2 of
set
[0] : 0; ! Undefined error number
[1] : TSB [FIELD_OVERFLOW] = $true;
[2] :
begin
local CPYCNT;
CPYCNT = ch$diff (.RETPTR, .TSB [OUTPUT_PTR]);
TSB [OUTPUT_COUNT] = .TSB [OUTPUT_COUNT] + .CPYCNT;
TSB [OUTPUT_POSITION] = .TSB [OUTPUT_POSITION] + .CPYCNT;
TSB [OUTPUT_PTR] = .RETPTR;
end;
tes;
end;
%else
0;
%fi
!
! Display character item as unsigned HEXADECIMAL number.
!
! If the rept count is less than zero then a pointer
! to the character stream to use as a separator.
!
! Next parameter item is a pointer to characters for
! conversion.
!
[%C'K'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
local
PTR,
COUNT_SAVE,
WIDTH_SAVE,
SEP_PTR;
if (.REPT lss 0)
then
begin
SEP_PTR = NEXT_PARM (.TSB);
REPT = -.REPT;
end
else
SEP_PTR = ch$asciz (' ');
PTR = NEXT_PARM (.TSB);
if (.TSB [STATE] lss DONE) and (.REPT gtr 0)
then
begin
WIDTH_SAVE = .TSB [FIELD_WIDTH];
TSB [FIELD_RADIX] = 16;
TSB [FIELD_ZERO_SUPPRESS] = $false;
while (REPT = .REPT - 1) geq 0 do
begin
TSB [FIELD_WIDTH] = 2;
COUNT_SAVE = .TSB [FIELD_COUNT];
TSB [FIELD_COUNT] = 0;
NUMBER_CONVERSION (.TSB, ch$rchar_a (PTR));
TSB [FIELD_WIDTH] = .WIDTH_SAVE;
TSB [FIELD_COUNT] = .COUNT_SAVE + 2;
if .REPT gtr 0
then
begin
local NPTR, CHAR;
NPTR = .SEP_PTR;
while (CHAR = ch$rchar_a (NPTR)) neq 0
do CHAR_OUT (.TSB, .CHAR);
end
end;
end;
end;
!
! Display parameter as unsigned decimal (this assumes
! that the value is positive only).
!
[%C'M'] :
begin
TSB [FIELD_RADIX] = 10;
REPEAT (.TSB);
end;
!
! Set suppress null at end of output flag
!
[%C'N'] :
TSB [NULL_SUPPRESS] = $true;
!
! Display parameter as signed octal.
!
[%C'O'] :
begin
TSB [FIELD_RADIX] = 8;
TSB [FIELD_SIGNED] = $true;
REPEAT (.TSB);
end;
!
! Display parameter as unsigned octal (this assumes that the
! value is positive only).
!
[%C'P'] :
begin
TSB [FIELD_ZERO_SUPPRESS] = $false;
TSB [FIELD_RADIX] = 8;
REPEAT (.TSB);
end;
!
! Translate parameter from RAD50 format to ASCII.
!
[%C'R'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
while (REPT = .REPT - 1) geq 0 do
$C5TA (.TSB, NEXT_PARM (.TSB));
end;
!
! Insert one or more spaces.
!
[%C'S'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
while (REPT = .REPT - 1) geq 0 do
CHAR_OUT (.TSB, %C' ');
end;
!
! Tab to specified column.
!
[%C'T'] :
begin
bind
COLUMN = TSB [FIELD_REPEAT],
POSITION = TSB [OUTPUT_POSITION];
if not .TSB [FIELD_NOWIDTH]
then POSITION = .TSB [FIELD_WIDTH] + .POSITION;
while ((.POSITION lss .COLUMN) and (.TSB [STATE] lss DONE))
do
CHAR_OUT (.TSB, SPACE);
end;
!
! Display next parameter as unsigned decimal.
! no zero suppression is done.
!
[%C'U'] :
begin
TSB [FIELD_RADIX] = 10;
TSB [FIELD_ZERO_SUPPRESS] = $false;
REPEAT (.TSB);
end;
!
! Insert character string while quoting undisplayable
! characters by the character '^V'.
!
[%C'V'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
local
CHAR,
PTR;
PTR = NEXT_PARM (.TSB);
while (REPT = .REPT - 1) geq 0 do
begin
CHAR = ch$rchar_a (PTR);
if ((.CHAR lss %c'A') or (.CHAR gtr %c'Z')) and
((.CHAR lss %c'0') or (.CHAR gtr %c'9')) and
(.CHAR neq %c'-')
then CHAR_OUT (.TSB, 22);
CHAR_OUT (.TSB, .CHAR)
end;
end;
!
! Counted string output.
!
[%C'X'] :
begin
local
PTR,
COUNT;
PTR = NEXT_PARM (.TSB);
COUNT = ch$rchar_a (PTR);
while (COUNT = .COUNT - 1) geq 0
do CHAR_OUT (.TSB, ch$rchar_a (PTR));
end;
!
! Date conversion.
!
[%C'Y'] :
DATE_CONVERSION (.TSB, NEXT_PARM (.TSB));
!
! Time conversion.
!
[%C'Z'] :
TIME_CONVERSION (.TSB, NEXT_PARM (.TSB), .TSB [FIELD_REPEAT]);
!
! Call user supplied routine.
!
[%C'@'] :
BEGIN
bind routine
USER_ROUTINE = NEXT_PARM (.TSB);
USER_ROUTINE (.TSB);
end;
!
! Insert one or more form-feeds.
!
[%C'^'] :
begin
bind
REPT = TSB [FIELD_REPEAT];
while (REPT = .REPT - 1) geq 0 do
CHAR_OUT (.TSB, FORM_FEED);
end;
!
! Invalid character - abort processing
!
[otherwise] :
TSB [STATE] = ABORT;
tes;
JUSTIFICATION (.TSB);
if .TSB [STATE] lss DONE then TSB [STATE] = TEXT_COPY;
end; ! End of PROCESS_DIRECTIVE
routine JUSTIFICATION (TSB) : novalue =
!++
! Functional description:
!
!
! Formal parameters:
!
! TSB Address of text state block
!
! Routine value: none
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
if .TSB [STATE] lss DONE
then
if .TSB [FIELD_OVERFLOW]
then
begin
local
PTR;
TSB [OUTPUT_PTR] = ch$plus (.TSB [OUTPUT_START], .TSB [OUTPUT_CHECKPOINT]);
TSB [STATE] = TEXT_COPY;
incr INDEX from 1 to .TSB [FIELD_WIDTH] do
CHAR_OUT (.TSB, SPACE);
end
else
if .TSB [FIELD_WIDTH] gtr .TSB [FIELD_COUNT]
then
case .TSB [FIELD_JUSTIFY] from NO_FILL to CENTER_FILL of
set
[NO_FILL] :
1;
[LEFT_JUSTIFY] :
while .TSB [FIELD_COUNT] lss .TSB [FIELD_WIDTH] do
CHAR_OUT (.TSB, SPACE);
[RIGHT_JUSTIFY] :
if (.TSB [OUTPUT_CHECKPOINT] + .TSB [FIELD_WIDTH]) gtr .TSB [OUTPUT_MAX]
then
TSB [STATE] = BUFFER_OVERFLOW
else
begin
local
DST_PTR,
SRC_PTR,
CHAR;
DST_PTR = ch$plus (.TSB [OUTPUT_START],
.TSB [OUTPUT_CHECKPOINT] + .TSB [FIELD_WIDTH]);
SRC_PTR = .TSB [OUTPUT_PTR];
incr INDEX from 1 to .TSB [FIELD_COUNT] do
begin
CHAR = ch$rchar (SRC_PTR = ch$plus (.SRC_PTR, -1));
ch$wchar (.CHAR, (DST_PTR = ch$plus (.DST_PTR, -1)));
end;
DST_PTR = ch$plus (.TSB [OUTPUT_START], .TSB [OUTPUT_CHECKPOINT]);
incr INDEX from .TSB [FIELD_COUNT] to .TSB [FIELD_WIDTH] - 1 do
ch$wchar_a (SPACE, DST_PTR);
TSB [OUTPUT_PTR] = ch$plus (.TSB [OUTPUT_START],
.TSB [FIELD_WIDTH] + .TSB [OUTPUT_CHECKPOINT]);
TSB [OUTPUT_COUNT] = .TSB [OUTPUT_CHECKPOINT] + .TSB [FIELD_WIDTH];
end;
[CENTER_FILL] :
begin
local
LEFT_FILL,
RIGHT_FILL,
DST_PTR,
SRC_PTR,
CHAR;
LEFT_FILL = (.TSB [FIELD_WIDTH] - .TSB [FIELD_COUNT])/2;
RIGHT_FILL = .TSB [FIELD_WIDTH] - .TSB [FIELD_COUNT] - .LEFT_FILL;
DST_PTR = ch$plus (.TSB [OUTPUT_START],
.TSB [OUTPUT_CHECKPOINT] + .TSB [FIELD_COUNT] + .LEFT_FILL);
SRC_PTR = .TSB [OUTPUT_PTR];
incr INDEX from 1 to .TSB [FIELD_COUNT] do
begin
CHAR = ch$rchar (SRC_PTR = ch$plus (.SRC_PTR, -1));
ch$wchar (.CHAR, (DST_PTR = ch$plus (.DST_PTR, -1)));
end;
DST_PTR = ch$plus (.TSB [OUTPUT_START], .TSB [OUTPUT_CHECKPOINT]);
incr INDEX from 1 to .LEFT_FILL do
ch$wchar_a (SPACE, DST_PTR);
DST_PTR = ch$plus (.TSB [OUTPUT_START],
.TSB [OUTPUT_CHECKPOINT] + .TSB [FIELD_COUNT] + .LEFT_FILL);
incr INDEX from 1 to .RIGHT_FILL do
ch$wchar_a (SPACE, DST_PTR);
TSB [OUTPUT_PTR] = ch$plus (.TSB [OUTPUT_START],
.TSB [FIELD_WIDTH] + .TSB [OUTPUT_CHECKPOINT]);
TSB [OUTPUT_COUNT] = .TSB [OUTPUT_CHECKPOINT] + .TSB [FIELD_WIDTH];
end;
tes;
end; ! End of JUSTIFY_FIELD
routine $C5TA (TSB, VALUE) : novalue =
!++
! Functional description:
!
! Convert from a RAD50 value to an ASCII string. This routine
! converts a 16 bit value (3 characters) on -11 and -32 bit
! machines and a fullword value (5 characters) on -36 bit
! machines.
!
! Formal parameters:
!
! .TSB Address of text state block.
! .VALUE The value to convert.
!
! Routine value: none
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
literal
RESULT_LENGTH = %bliss36
(5) %bliss32
(3) %bliss16
(3);
local
CHAR : vector [RESULT_LENGTH], ! Temporary holding area for characters
WORKING_VALUE;
WORKING_VALUE = .VALUE;
!
! Extract character by character
!
incra INDEX from 0 to RESULT_LENGTH - 1 do
CHAR [.INDEX] = CVTC (WORKING_VALUE);
!
! Output characters in reverse order from extraction
!
decra INDEX from RESULT_LENGTH - 1 to 0 do
CHAR_OUT (.TSB, .CHAR [.INDEX]);
end; ! End of $C5TA
routine CVTC (VALUE_ADR) =
!++
! Functional description:
!
! Reduce RAD50 value to components.
!
! Formal parameters:
!
! .VALUE_ADR Address of RAD50 value to reduce
!
! Routine value:
!
! The next character extracted from ..VALUE_ADR
!
! Side effects: none
!
! ..VALUE_ADR Returned with one character removed
!
!--
begin
bind
RAD50_SET = ch$ptr (uplit (
%bliss16 (%ascii ' ABCDEFGHIJKLMNOPQRSTUVWXYZ$.%0123456789')
%bliss32 (%ascii ' ABCDEFGHIJKLMNOPQRSTUVWXYZ$.%0123456789')
%bliss36 (%ascii ' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$%')));
local
CHAR;
CHAR = ..VALUE_ADR mod %O'50'; ! Pull the next character
.VALUE_ADR = ..VALUE_ADR/%O'50'; ! and divide it out.
ch$rchar (ch$plus (RAD50_SET, .CHAR))
end; ! End of CVTC
routine REPEAT (TSB) : novalue =
!++
! Functional description:
!
! This routine "repeats" the given conversion
! the specified number of times.
!
! Formal parameters:
!
! .TSB Address of text state block.
!
! Routine value: none
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
bind
REPT = TSB [FIELD_REPEAT];
while ((REPT = .REPT - 1) geq 0) and (.TSB [STATE] lss DONE) do
begin
TSB [FIELD_COUNT] = 0;
TSB [OUTPUT_CHECKPOINT] = .TSB [OUTPUT_COUNT];
NUMBER_CONVERSION (.TSB, NEXT_PARM (.TSB));
JUSTIFICATION (.TSB);
end;
TSB [FIELD_JUSTIFY] = NO_FILL;
end; ! End of REPEAT
routine NUMBER_CONVERSION (TSB, VALUE) : novalue =
!++
! Functional description:
!
! Convert from a binary integer value to a ASCII string. The
! options for conversion are:
!
! RADIX Radix for conversion.
! SIGNED Whether value is to be interpreted as signed.
! ZERO_SUPPRESS Leading zero suppression.
!
! Formal parameters:
!
! .TSB Address of text state block.
! .VALUE The value to convert.
!
! Routine value: none
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
bind
RADIX = TSB [FIELD_RADIX];
local
CHAR : vector [32], ! Holding area for remainders
CHAR_ADR, ! Character position index
FIELD_LENGTH, ! Length of receiving field
WORKING_VALUE; ! This is our copy of his number.
FIELD_LENGTH = min (32, .TSB [FIELD_WIDTH] - .TSB [FIELD_COUNT]);
WORKING_VALUE =
(if .TSB [FIELD_SIGNED] and (.VALUE lss 0)
then
begin
CHAR_OUT (.TSB, %C'-'); ! Insert a minus sign
-.VALUE ! Make positive.
end
else .VALUE); ! Copy the number.
!+
! Divide the value to death to get the individual digits.
!-
incra CHAR_ADR from CHAR [0] to CHAR [.FIELD_LENGTH - 1] by %upval do
begin
.CHAR_ADR = .WORKING_VALUE mod .RADIX; ! Save the remainder
WORKING_VALUE = .WORKING_VALUE/.RADIX; ! and do the division.
!+
! Now turn the number into a digit. If the radix allows digits beyond 9,
! map them up to 'A' through 'Z'.
!-
.CHAR_ADR = ..CHAR_ADR + (if ..CHAR_ADR gtr 9 then %C'A' - 10 else %C'0');
!+
! If we haven't run out of room in the output field, then check
! for significant digit runout. If finished, shorten the field.
!-
if (.WORKING_VALUE eql 0) and .TSB [FIELD_ZERO_SUPPRESS]
then exitloop (FIELD_LENGTH = (.CHAR_ADR - CHAR [0])/%upval + 1);
end;
!+
! The digits are extracted, output them.
!-
while (FIELD_LENGTH = .FIELD_LENGTH - 1) geq 0 do
CHAR_OUT (.TSB, .CHAR [.FIELD_LENGTH]);
end; ! End of NUMBER_CONVERSION
routine $CBDAT (TSB, VALUE) : novalue =
!++
! Functional description:
!
! Convert from a binary integer value to a 2 digit ASCII
! DECIMAL string. This is useful for time and date string
! conversions.
!
! Formal parameters:
!
! .TSB Address of text state block.
! .VALUE The value to convert.
!
! Routine value: none
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK;
literal
RADIX = 10;
local
WIDTH_SAVE;
WIDTH_SAVE = .TSB [FIELD_WIDTH];
TSB [FIELD_WIDTH] = min (.TSB [FIELD_COUNT] + 2, .WIDTH_SAVE);
TSB [FIELD_RADIX] = RADIX;
NUMBER_CONVERSION (.TSB, .VALUE);
TSB [FIELD_WIDTH] = .WIDTH_SAVE;
end; ! End of $CBDAT
routine DATE_CONVERSION (TSB, DATE_BLOCK) : novalue =
!++
! Functional description:
!
! Output the given date in the form: dd-mmm-yy.
!
! Formal parameters:
!
! .TSB Address of text state block
! .DATE_BLOCK[0] Year
! .DATE_BLOCK[1] Month (1-12)
! .DATE_BLOCK[2] Day (1-31)
!
! Routine value: none
! Side effects: none
!
!--
begin
map
DATE_BLOCK : ref vector [3];
local
MONTH_PTR;
bind
MONTH = uplit (
ch$ptr (uplit('JAN')), ch$ptr (uplit('FEB')),
ch$ptr (uplit('MAR')), ch$ptr (uplit('APR')),
ch$ptr (uplit('MAY')), ch$ptr (uplit('JUN')),
ch$ptr (uplit('JUL')), ch$ptr (uplit('AUG')),
ch$ptr (uplit('SEP')), ch$ptr (uplit('OCT')),
ch$ptr (uplit('NOV')), ch$ptr (uplit('DEC')))
: vector [12];
!
! Output day
!
$CBDAT (.TSB, .DATE_BLOCK [2]);
CHAR_OUT (.TSB, %C'-');
!
! Output month
!
MONTH_PTR = .MONTH [.DATE_BLOCK [1] - 1];
CHAR_OUT (.TSB, ch$rchar_a (MONTH_PTR));
CHAR_OUT (.TSB, ch$rchar_a (MONTH_PTR));
CHAR_OUT (.TSB, ch$rchar_a (MONTH_PTR));
CHAR_OUT (.TSB, %C'-');
!
! Output year
!
$CBDAT (.TSB, .DATE_BLOCK [0]);
end; ! End of DATE_CONVERSION
routine TIME_CONVERSION (TSB, TIM_BLOK, FORMAT) : novalue =
!++
! Functional description:
!
! Output the given time in the form HH:MM:SS.S where
! the resolution is controlled by the FORMAT parameter.
!
! Formal parameters:
!
! .TSB Address of text state block.
! .TIM_BLOK[0] Hour in day.
! .TIM_BLOK[1] Minute in hour.
! .TIM_BLOK[2] Second in minute.
! .TIM_BLOK[3] Tick in second.
! .TIM_BLOK[4] Number of ticks in a second.
! .FORMAT Indicates the format to use:
! 0 or 1 - HH
! 2 - HH:MM
! 3 - HH:MM:SS
! 4 or 5 - HH:MM:SS.S
!
! Routine value: none
! Side effects: none
!
!--
begin
map
TSB : ref TEXT_STATE_BLOCK,
TIM_BLOK : ref vector [5];
TSB [FIELD_ZERO_SUPPRESS] = $false;
select .FORMAT of
set
[0 TO 5] :
$CBDAT (.TSB, .TIM_BLOK [0]);
[2 TO 5] :
begin
CHAR_OUT (.TSB, %C':');
$CBDAT (.TSB, .TIM_BLOK [1]);
end;
[3 TO 5] :
begin
CHAR_OUT (.TSB, %C':');
$CBDAT (.TSB, .TIM_BLOK [2]);
end;
[4 TO 5] :
begin
CHAR_OUT (.TSB, %C'.');
$CBDAT (.TSB, ((.TIM_BLOK [3]*100)/.TIM_BLOK [4]));
end;
tes;
end; ! End of TIME_CONVERSION
end ! End of module NMUTXT
eludom
! Local Modes:
! Mode:BLISS
! Auto Save Mode:0
! Comment Column:40
! Comment Rounding:+1
! End: