COMPILATION LISTING OF SEGMENT apl_monadic_format_
	Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983
	Compiled at: Honeywell LCPD Phoenix, System M
	Compiled on: 11/29/83  1610.9 mst Tue
	    Options: optimize map

        1 /* ******************************************************
        2*   *                                                    *
        3*   *                                                    *
        4*   * Copyright (c) 1972 by Massachusetts Institute of   *
        5*   * Technology and Honeywell Information Systems, Inc. *
        6*   *                                                    *
        7*   *                                                    *
        8*   ****************************************************** */
        9 
       10 /* Program to implement monadic and dyadic APL format operators.
       11*   Written November 1978 by PG.
       12*   Modified 780312 by PG to fix 366 (monadic format miscalculates the number of columns required if one of
       13*	the elements rounds to zero, and some other element is nonzero.) The fix was to always reserve a
       14*	column for a possible leading zero. Bug 372 was fixed (format reserves a column for a negative sign
       15*	based on the sign of the unrounded value). Bug 371 (empty right args cause format to blow up) was
       16*	lessened by having format temporarily reject empty right arguments. Additionally, SCIENTIFIC_FMT was
       17*	modified to suppress the leading zero of an exponent.
       18*   Modified 790607 by PG to fix 400 (format should use same width for each column if a single format pair is used).
       19*   Modified 790809 by PG to fix 373 (format is supposed to return a result having the same rank as
       20*	the argument, for nonscalars).
       21*   Modified 790815 by PG to fix 371 (not handling empty arrays).
       22*   Modified 790913 by PG to add apl_print_value_ functions. All formatted output now goes thru this routine.
       23*   Modified 791127 by PG to recode scientific picture conversion so that it is inline.
       24*   Modified 800201 by PG to fix 444 (apl_print_value_ entry could reference beyond end of output buffer
       25*	if a vector_overflow occured, because the end-of-the-buffer test was skipped).
       26*   Modified 811210 by TO to make 'apl_print_value_' print integers of more
       27*	than qPP digits in scientific.
       28*   Modified 811210 by TO to use integer format if a column is fuzz-integral.
       29**/
       30 
       31 /* Known differences between this program and the IBM implementation:
       32*   1. We always print a leading zero for FIXED_DEC format. IBM always
       33*      prints one for monadic format; never prints one for dyadic format.
       34*   2. We keep leading whitespace after a vector_overflow, IBM does not.
       35*   3. We use either one or two digits in the exponent for SCIENTIFIC.
       36*      IBM always uses two.
       37*   4. We return empty results if given empty arguments. I'm not sure what
       38*      IBM does.
       39*   5. IBM assumes that each character occupies one print position (even BS).
       40*      We calculate the effect of each character separately.
       41**/
       42 
       43 /* format: style3 */
       44 apl_monadic_format_:
       45      procedure (operators_argument);
       46 
       47 /* automatic */
       48 
       49 declare	fmt_info_ptr	ptr,
       50 	check_if_column_fuzz_integral bit (1),
       51 	column_base	fixed bin,
       52 	column_length	fixed bin,
       53 	column_top	fixed bin,
       54 	colx		fixed bin,
       55 	current_rho_value	fixed bin (21),
       56 	data_elements	fixed bin (21),
       57 	dyadic		bit (1) aligned,
       58 	float_temp	float,
       59 	format		bit (1) aligned,		/* ON if format, OFF if print_value */
       60 	interval_between_elements
       61 			fixed bin,
       62 	interval_between_planes
       63 			fixed bin,
       64 	largest_possible_value
       65 			float,
       66 	left_pos		fixed bin,
       67 	left		ptr,
       68 	left_data_elements	fixed bin (21),
       69 	left_vb		ptr,
       70 	listx		fixed bin,		/* subscript of current member in list bead */
       71 	n_cols		fixed bin,
       72 	n_lines		fixed bin,
       73 	n_words		fixed bin (19),
       74 	plane_base	fixed bin,
       75 	pseudo_column_length
       76 			fixed bin,
       77 	result		ptr,
       78 	result_cols	fixed bin (21),
       79 	result_data_elements
       80 			fixed bin (21),
       81 	result_pos	fixed bin (21),
       82 	result_vb		ptr,
       83 	rhox		fixed bin,
       84 	right		ptr,
       85 	right_data_elements fixed bin (21),
       86 	right_rho_ptr	ptr,
       87 	right_rhorho	fixed bin,
       88 	right_vb		ptr,
       89 	round_buffer	char (21),
       90 	temp_result	ptr,
       91 	valx		fixed bin;
       92 
       93 /* based */
       94 
       95 declare	1 fmt_info	aligned based (fmt_info_ptr),
       96 	  2 global_max_value
       97 			float,			/* template value for entire array */
       98 	  2 global_negative_element
       99 			bit (1) aligned,		/* ON if any elements in array negative */
      100 	  2 col		(n_cols),
      101 	    3 max_value	float,			/* maximum absolute value */
      102 	    3 min_value	float,			/* minimum absolute value */
      103 	    3 max_abs_value float,			/* template value */
      104 	    3 negative_element
      105 			bit (1) aligned,		/* ON if any elements in column negative */
      106 	    3 fuzz_integral bit (1) aligned,		/* ON if all elements of column fuzz-integral */
      107 	    3 field_width	fixed bin,		/* number of columns total */
      108 	    3 precision	fixed bin,		/* number of digits (varies with type) */
      109 	    3 type	fixed bin;		/* which output format to use */
      110 
      111 declare	left_numeric_datum	(0:left_data_elements - 1) float based (left),
      112 	right_numeric_datum (0:right_data_elements - 1) float based (right),
      113 	right_rho		(right_rhorho) fixed bin (21) based (right_rho_ptr),
      114 	word_copy_overlay	(n_words) fixed bin (35) based;
      115 
      116 /* builtins */
      117 
      118 declare	(abs, addrel, binary, copy, currentsize, divide, floor, hbound, lbound, length, max, min, mod, null, rank, rtrim,
      119 	sign, size, string, substr, sum, trunc, verify)
      120 			builtin;
      121 
      122 /* conditions */
      123 
      124 declare	cleanup		condition;
      125 
      126 /* entries */
      127 
      128 declare	apl_system_error_	entry (fixed bin (35));
      129 
      130 /* external static */
      131 
      132 declare	(
      133 	apl_error_table_$domain,
      134 	apl_error_table_$length,
      135 	apl_error_table_$no_type_bits,
      136 	apl_error_table_$not_within_int_fuzz,
      137 	apl_error_table_$rank
      138 	)		fixed bin (35) external static;
      139 
      140 /* internal static */
      141 
      142 declare	(
      143 	SCIENTIFIC_FMT	initial (0),		/* use exponential form */
      144 	INTEGER_FMT	initial (1),		/* use integer form */
      145 	FIXED_DEC_FMT	initial (2)
      146 	)		fixed bin internal static;	/* use decimal form */
      147 
      148 declare	one_e		(0:38) float internal static
      149 			initial (1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11, 1e12, 1e13, 1e14, 1e15,
      150 			1e16, 1e17, 1e18, 1e19, 1e20, 1e21, 1e22, 1e23, 1e24, 1e25, 1e26, 1e27, 1e28, 1e29, 1e30, 1e31,
      151 			1e32, 1e33, 1e34, 1e35, 1e36, 1e37, 1e38);
      152 
      153 /* include files */
      154 
  1     1 /* ====== BEGIN INCLUDE SEGMENT	apl_number_data.incl.pl1 ================================== */
  1     2 
  1     3 /*
  1     4*   This include file contains information about the machine representation of numbers.
  1     5*   In all programs numbers should simply be declared 'float'.
  1     6*   All default statements should be in this include file.
  1     7*
  1     8*   This is the binary version.  The manifest constant Binary should be used by programs
  1     9*   that need to know whether we are using binary or decimal.
  1    10* */
  1    11 
  1    12 /* format: style3,initlm0,idind30 */
  1    13 
  1    14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63);
  1    15 
  1    16 declare	(
  1    17 	TheBiggestNumberWeveGot	float initial (0.1701411834604692317e+39),
  1    18 	TheSmallestNumberWeveGot	float initial (.1469367938527859385e-38),
  1    19 	Binary			bit (1) aligned initial ("1"b)
  1    20 	)			internal static options (constant);
  1    21 
  1    22 /* Number of characters in a number datum entry; used for copying float number arrays as strings.
  1    23*   (Obsolete! use array copies!) */
  1    24 
  1    25 declare	NumberSize		fixed binary precision (4) internal static initial (8);
  1    26 
  1    27 /* ------ END INCLUDE SEGMENT		apl_number_data.incl.pl1 ---------------------------------- */
      155 
  2     1 /* ====== BEGIN INCLUDE SEGMENT	apl_bead_format.incl.pl1 ================================== */
  2     2 
  2     3 declare 1 general_bead  		aligned based,	/* The Venerable Bead		*/
  2     4 	2 type 			unaligned,
  2     5 	  3 bead_type		unaligned,
  2     6 	    4 operator		bit (1),		/* ON if operator bead		*/
  2     7 	    4 symbol		bit (1),		/* ON if symbol bead		*/
  2     8 	    4 value		bit (1),		/* ON if value bead			*/
  2     9 	    4 function		bit (1),		/* ON if function bead		*/
  2    10 	    4 group		bit (1),		/* ON if group bead			*/
  2    11 	    4 label		bit (1),		/* ON if label bead			*/
  2    12 	    4 shared_variable	bit (1),		/* ON if shared variable bead 	*/
  2    13 	    4 lexed_function	bit (1),		/* ON if lexed function bead  	*/
  2    14 	  3 data_type		unaligned,
  2    15 	    4 list_value		bit (1),		/* ON if a list value bead		*/
  2    16 	    4 character_value	bit (1),		/* ON if a character value bead	*/
  2    17 	    4 numeric_value		bit (1),		/* ON if a numeric value bead		*/
  2    18 	    4 integral_value	bit (1),		/* ON if an integral value bead	*/
  2    19 	    4 zero_or_one_value	bit (1),		/* ON if a boolean value bead		*/
  2    20 	    4 complex_value		bit (1),		/* ON if a complex, numeric value bead   */
  2    21 	  3 unused_bits		bit (4) unaligned,	/* pad to 18 bits (for future use)	*/
  2    22 	2 size			bit (18) unaligned,	/* Number of words this bead occupies
  2    23*						   (used by bead storage manager)	*/
  2    24 	2 reference_count 		fixed binary (29);	/* Number of pointers which point
  2    25*						   to this bead (used by bead manager)	*/
  2    26 
  2    27 
  2    28 /* constant strings for initing type field in various beads */
  2    29 
  2    30 declare (
  2    31 	operator_type		init("100000000000000000"b),
  2    32 	symbol_type		init("010000000000000000"b),
  2    33     	value_type		init("001000000000000000"b),
  2    34 	function_type		init("000100000000000000"b),
  2    35 	group_type		init("000010000000000000"b),
  2    36 	label_type		init("001001000011000000"b),
  2    37 	shared_variable_type	init("001000100000000000"b),
  2    38 	lexed_function_type		init("000000010000000000"b),
  2    39 
  2    40 	list_value_type		init("000000001000000000"b),
  2    41 	character_value_type 	init("001000000100000000"b),
  2    42 	numeric_value_type		init("001000000010000000"b),
  2    43 	integral_value_type		init("001000000011000000"b),
  2    44 	zero_or_one_value_type	init("001000000011100000"b),
  2    45 	complex_value_type		init("001000000000010000"b),
  2    46 
  2    47 	not_integer_mask		init("111111111110011111"b),		/* to clear integral, zero_or_one bits */
  2    48 	not_zero_or_one_mask	init("111111111111011111"b)		/* to clear zero_or_one bit */
  2    49         ) bit(18) internal static;
  2    50 
  2    51 /* ------ END INCLUDE SEGMENT		apl_bead_format.incl.pl1 ---------------------------------- */
      156 
  3     1 /* ====== BEGIN INCLUDE SEGMENT	apl_characters.incl.pl1 =================================== */
  3     2 
  3     3 /*
  3     4* * This include file contains all the characters in the APL character set,
  3     5* * declared char(1)  [Instead of fixed bin as in the apl_character_codes.incl.pl1 file]
  3     6* *
  3     7*   Modified 780913 by PG to add CentSign
  3     8*   Modified 790319 by PG to add CommaHyphen
  3     9* */
  3    10 
  3    11 declare (
  3    12 	QBell		init(""),
  3    13 	QBackSpace	init(""),
  3    14 	QTab		init("	"),
  3    15 	QNewLine		init("
  3    16 "),
  3    17 	QSpace		init(" "),
  3    18 	QExclamation	init("!"),
  3    19 	QDollar		init("$"),
  3    20 	QApostrophe	init("'"),
  3    21 	QLeftParen	init("("),
  3    22 	QRightParen	init(")"),
  3    23 	QStar		init("*"),
  3    24 	QPlus		init("+"),
  3    25 	QComma		init(","),
  3    26 	QMinus		init("-"),
  3    27 	QPeriod		init("."),
  3    28 	QSlash		init("/"),
  3    29 	QZero		init("0"),
  3    30 	QOne		init("1"),
  3    31 	QTwo		init("2"),
  3    32 	QThree		init("3"),
  3    33 	QFour		init("4"),
  3    34 	QFive		init("5"),
  3    35 	QSix		init("6"),
  3    36 	QSeven		init("7"),
  3    37 	QEight		init("8"),
  3    38 	QNine		init("9"),
  3    39 	QColon		init(":"),
  3    40 	QSemiColon	init(";"),
  3    41 	QLessThan		init("<"),
  3    42 	QEqual		init("="),
  3    43 	QGreaterThan	init(">"),
  3    44 	QQuestion		init("?"),
  3    45 	QLetterA_		init("A"),
  3    46 	QLetterB_		init("B"),
  3    47 	QLetterC_		init("C"),
  3    48 	QLetterD_		init("D"),
  3    49 	QLetterE_		init("E"),
  3    50 	QLetterF_		init("F"),
  3    51 	QLetterG_		init("G"),
  3    52 	QLetterH_		init("H"),
  3    53 	QLetterI_		init("I"),
  3    54 	QLetterJ_		init("J"),
  3    55 	QLetterK_		init("K"),
  3    56 	QLetterL_		init("L"),
  3    57 	QLetterM_		init("M"),
  3    58 	QLetterN_		init("N"),
  3    59 	QLetterO_		init("O"),
  3    60 	QLetterP_		init("P"),
  3    61 	QLetterQ_		init("Q"),
  3    62 	QLetterR_		init("R"),
  3    63 	QLetterS_		init("S"),
  3    64 	QLetterT_		init("T"),
  3    65 	QLetterU_		init("U"),
  3    66 	QLetterV_		init("V"),
  3    67 	QLetterW_		init("W"),
  3    68 	QLetterX_		init("X"),
  3    69 	QLetterY_		init("Y"),
  3    70 	QLetterZ_		init("Z"),
  3    71 	QLeftBracket	init("["),
  3    72 	QBackSlash	init("\"),
  3    73 	QRightBracket	init("]"),
  3    74 	QUnderLine	init("_"),
  3    75 	QLetterA		init("a"),
  3    76 	QLetterB		init("b"),
  3    77 	QLetterC		init("c"),
  3    78 	QLetterD		init("d"),
  3    79 	QLetterE		init("e"),
  3    80 	QLetterF		init("f"),
  3    81 	QLetterG		init("g"),
  3    82 	QLetterH		init("h"),
  3    83 	QLetterI		init("i"),
  3    84 	QLetterJ		init("j"),
  3    85 	QLetterK		init("k"),
  3    86 	QLetterL		init("l"),
  3    87 	QLetterM		init("m"),
  3    88 	QLetterN		init("n"),
  3    89 	QLetterO		init("o"),
  3    90 	QLetterP		init("p"),
  3    91 	QLetterQ		init("q"),
  3    92 	QLetterR		init("r"),
  3    93 	QLetterS		init("s"),
  3    94 	QLetterT		init("t"),
  3    95 	QLetterU		init("u"),
  3    96 	QLetterV		init("v"),
  3    97 	QLetterW		init("w"),
  3    98 	QLetterX		init("x"),
  3    99 	QLetterY		init("y"),
  3   100 	QLetterZ		init("z"),
  3   101 	QLeftBrace	init("{"),
  3   102 	QVerticalBar	init("|"),
  3   103 	QRightBrace	init("}"),
  3   104 	QTilde		init("~"),
  3   105 	QLessOrEqual	init("�"),
  3   106 	QGreaterOrEqual	init("�"),
  3   107 	QNotEqual		init("�"),
  3   108 	QOrSign		init("�"),
  3   109 	QAndSign		init("�"),
  3   110 	QDivision		init("�"),
  3   111 	QEpsilon		init("�"),
  3   112 	QUpArrow		init("�"),
  3   113 	QDownArrow	init("�"),
  3   114 	QCircle		init("�"),
  3   115 	QCeiling		init("�"),
  3   116 	QFloor		init("�"),
  3   117 	QDelta		init("�"),
  3   118 	QSmallCircle	init("�"),
  3   119 	QQuad		init("�"),
  3   120 	QCap		init("�"),
  3   121 	QDeCode		init("�"),
  3   122 	QEnCode		init("�"),
  3   123 	QLeftLump		init("�"),
  3   124 	QRightLump	init("�"),
  3   125 	QCup		init("�"),
  3   126 	QNorSign		init("�"),
  3   127 	QNandSign		init("�"),
  3   128 	QCircleHyphen	init("�"),
  3   129 	QSlashHyphen	init("�"),
  3   130 	QDelTilde		init("�"),
  3   131 	QCircleStar	init("�"),
  3   132 	QCircleBar	init("�"),
  3   133 	QCircleBackSlash	init("�"),
  3   134 	QCircleSlash	init("�"),
  3   135 	QGradeDown	init("�"),
  3   136 	QGradeUp		init("�"),
  3   137 	QLamp		init("�"),
  3   138 	QQuadQuote	init("�"),
  3   139 	QIBeam		init("�"),
  3   140 	QBackSlashHyphen	init("�"),
  3   141 	QDomino		init("�"),
  3   142 	QDiaresis		init("�"),
  3   143 	QOmega		init("�"),
  3   144 	QIota		init("�"),
  3   145 	QRho		init("�"),
  3   146 	QTimes		init("�"),
  3   147 	QAlpha		init("�"),
  3   148 	QUpperMinus	init("�"),
  3   149 	QDel		init("�"),
  3   150 	QLeftArrow	init("�"),
  3   151 	QRightArrow	init("�"),
  3   152 	QDiamond		init("�"),
  3   153 	QZero_		init("�"),
  3   154 	QOne_		init("�"),
  3   155 	QTwo_		init("�"),
  3   156 	QThree_		init("�"),
  3   157 	QFour_		init("�"),
  3   158 	QFive_		init("�"),
  3   159 	QSix_		init("�"),
  3   160 	QSeven_		init("�"),
  3   161 	QEight_		init("�"),
  3   162 	QNine_		init("�"),
  3   163 	QDelta_		init("�"),
  3   164 	QMarkError	init("�"),
  3   165 	QExecuteSign	init("�"),
  3   166 	QFormatSign	init("�"),
  3   167 	QLeftTack		init("�"),
  3   168 	QRightTack	init("�"),
  3   169 	QLineFeed		init("�"),
  3   170 	QConditionalNewLine	init("�"),
  3   171 	QCentSign		init("�"),
  3   172 	QCommaHyphen	init("�")
  3   173      ) char(1) internal static options (constant);
  3   174 
  3   175 /* ------ END INCLUDE SEGMENT		apl_characters.incl.pl1 ----------------------------------- */
      157 
  4     1 /* ====== BEGIN INCLUDE SEGMENT	apl_list_bead.incl.pl1 ==================================== */
  4     2 
  4     3 declare	n_members fixed bin,
  4     4 
  4     5 	1 list_bead		aligned based,
  4     6 	  2 header		aligned like general_bead,
  4     7 	  2 number_of_members	fixed bin,
  4     8 	  2 members		dimension (n_members refer (list_bead.number_of_members)) aligned,
  4     9 	    3 member_ptr		unaligned pointer,
  4    10 	    3 bits		unaligned like operator_bead.bits_for_parse;
  4    11 
  4    12 /* ------ END INCLUDE SEGMENT		apl_list_bead.incl.pl1 ------------------------------------ */
      158 
  5     1 /* ====== BEGIN INCLUDE SEGMENT	apl_operator_bead.incl.pl1 ================================ */
  5     2 
  5     3 declare
  5     4 	1 operator_bead		aligned based,
  5     5 
  5     6 	  2 type			unaligned like general_bead.type,
  5     7 
  5     8 	  2 bits_for_lex		unaligned,
  5     9 	    3 allow_brackets	bit(1),		/* operator may have dimension info in brackets */
  5    10 	    3 allow_product		bit(1),		/* operator may be used in inner and outer product */
  5    11 	    3 allow_reduction	bit(1),		/* operator may be used in reduction and scan */
  5    12 	    3 special_assignment	bit(1),		/* doesn't use standard assignment operator */
  5    13 	    3 ignores_assignment	bit(1),		/* assignment has no effect */
  5    14 	    3 allow_subscripted_assignment
  5    15 				bit(1),		/* system variable that can be subscripted assigned */
  5    16 	    3 pad			bit(12),
  5    17 
  5    18 	  2 bits_for_parse		unaligned,
  5    19 	    3 stop_trace_control	bit(1),		/* next lexeme is function being stopped/traced
  5    20*						   (op1 tells which) */
  5    21 	    3 quad		bit(1),		/* this is a quad type */
  5    22 	    3 system_variable	bit(1),		/* this is a system variable, not an op */
  5    23 	    3 dyadic		bit(1),		/* operator may be dyadic */
  5    24 	    3 monadic		bit(1),		/* operator may be monadic */
  5    25 	    3 function		bit(1),		/* operator is a user defined function */
  5    26 	    3 semantics_valid	bit(1),		/* if semantics has been set */
  5    27 	    3 has_list		bit(1),		/* semantics is a list */
  5    28 	    3 inner_product		bit(1),		/* op2 is valid */
  5    29 	    3 semantics_on_stack	bit(1),		/* semantics points to value stack */
  5    30 	    3 is_external_function	bit(1),		/* semantics points to function bead for ext function */
  5    31 	    3 pad			bit(7),
  5    32 	    3 op2			fixed bin(8) unaligned,	/* secondary operator code */
  5    33 	    3 op1			fixed bin(8) unaligned,	/* primary operator code */
  5    34 	  2 type_code		fixed bin;	/* for parse */
  5    35 
  5    36 /* ------ END INCLUDE SEGMENT		apl_operator_bead.incl.pl1 -------------------------------- */
      159 
  6     1 /* ====== BEGIN INCLUDE SEGEMENT	apl_operators_argument.incl.pl1 =========================== */
  6     2 
  6     3 declare	1 operators_argument	aligned,
  6     4 	  2 operands (2)		aligned,		/* these are the operands to the operator to be executed.
  6     5*						   if operand (1).value is null, operator is monadic */
  6     6 	    3 value		pointer unaligned,	/* a pointer to the value bead for this operand */
  6     7 	    3 on_stack		bit (1) aligned,	/* ON if this value resides on the value stack */
  6     8 	  2 operator		aligned,		/* information about the operator to be executed */
  6     9 	    3 dimension		fixed bin,	/* (optional) dimension along which to operate */
  6    10 	    3 padding		bit (18) unaligned,	/* unused part of operator bead */
  6    11 	    3 op2			fixed bin (8) unal,	/* a modifier for op1, or a 2nd operator if inner product */
  6    12 	    3 op1			fixed bin (8) unal,	/* code for the actual operator to be executed */
  6    13 	  2 result		pointer unal,	/* (output) set by operator to point to result bead in stack */
  6    14 	  2 error_code		fixed bin (35),	/* (output) set before signaling apl_operator_error_ */
  6    15 	  2 where_error		fixed bin;	/* parseme index of where error was - parse sets to operator */
  6    16 
  6    17 /* ------ END INCLUDE SEGMENT		apl_operators_argument.incl.pl1 --------------------------- */
      160 
  7     1 /* ====== BEGIN INCLUDE SEGMENT	apl_value_bead.incl.pl1 =================================== */
  7     2 
  7     3 declare
  7     4 	number_of_dimensions fixed bin,
  7     5 
  7     6 	1 value_bead		aligned based,
  7     7 	2 header			aligned like general_bead,
  7     8 	2 total_data_elements	fixed binary (21),	/* length of ,[value] in APL		*/
  7     9 	2 rhorho			fixed binary,	/* number of dimensions of value	*/
  7    10 	2 data_pointer		pointer unaligned,	/* packed pointer to the data in value	*/
  7    11 	2 rho			fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho));
  7    12 						/* dimensions of value (zero-origin)	*/
  7    13 
  7    14 
  7    15 declare 1 character_data_structure	aligned based,	/* alignment trick for PL/I compiler	*/
  7    16 	2 character_datum		character (1) unaligned dimension (0:data_elements - 1);
  7    17 						/* actual elements of character array	*/
  7    18 
  7    19 declare   character_string_overlay	character (data_elements) aligned based;
  7    20 						/* to overlay on above structure	 */
  7    21 
  7    22 
  7    23 declare   numeric_datum		float aligned dimension (0:data_elements - 1) based;
  7    24 						/* actual elements of numeric array	*/
  7    25 
  7    26 declare	complex_datum		complex float aligned dimension (0:data_elements -1) based;
  7    27 
  7    28 declare	MAX_VALUE_BEAD_SIZE		fixed bin (19) init (261120) int static options (constant);
  7    29 
  7    30 /* ------ END INCLUDE SEGMENT		apl_value_bead.incl.pl1 ----------------------------------- */
      161 
  8     1 /* ====== BEGIN INCLUDE SEGMENT	apl_ws_info.incl.pl1 ====================================== */
  8     2 
  8     3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */
  8     4 
  8     5 /* automatic */
  8     6 
  8     7 declare	ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr);
  8     8 
  8     9 /* external static */
  8    10 
  8    11 declare	1 apl_static_$ws_info_ptr	external static aligned structure,
  8    12 	  2 static_ws_info_ptr	unaligned pointer;
  8    13 
  8    14 /* based */
  8    15 
  8    16 declare	1 ws_info			aligned based (ws_info_ptr),
  8    17 	  2 version_number		fixed bin,	/* version of this structure (3) */
  8    18 	  2 switches		unaligned,	/* mainly ws parameters */
  8    19 	    3 long_error_mode	bit,		/* if 1, long Multics format, else APL/360 format */
  8    20 	    3 debug_mode		bit,		/* if 1, system error causes escape to command level */
  8    21 	    3 canonicalize_mode	bit,		/* if 1, the editor canonicalizes user input */
  8    22 	    3 restrict_exec_command	bit,		/* if 1, the )EXEC command may not be used */
  8    23 	    3 restrict_debug_command	bit,		/* if 1, the )DEBUG command may not be used */
  8    24 	    3 restrict_external_functions
  8    25 				bit,		/* if 1, the )ZFN, )MFN, and )DFN commands may not be used */
  8    26 	    3 restrict_load		bit,		/* if 1, the )LOAD and )COPY commands may not be used */
  8    27 	    3 restrict_load_directory	bit,		/* if 1, no directory allowed in )LOAD or )COPY pathnames */
  8    28 	    3 restrict_save		bit,		/* if 1, the )SAVE command may not be used */
  8    29 	    3 restrict_save_directory	bit,		/* if 1, no directory allowed in )SAVE pathnames */
  8    30 	    3 off_hold		bit,		/* if 1, )OFF HOLD was typed, else just )OFF */
  8    31 	    3 transparent_to_signals	bit,		/* if 1, any conditions slip right past APL */
  8    32 	    3 meter_mode		bit,		/* if 1, metering may be done, else speed is all-important */
  8    33 	    3 restrict_msg_command	bit,		/* if 1, the )MSG command may not be used. */
  8    34 	    3 compatibility_check_mode
  8    35 				bit,		/* if 1, check for incompatible operators */
  8    36 	    3 no_quit_handler	bit,		/* if 1, do not trap QUITs. */
  8    37 						/* remaining 20 bits not presently used */
  8    38 
  8    39 	  2 values,				/* attributes of the workspace */
  8    40 	    3 digits		fixed bin,	/* number of digits of precision printed on output */
  8    41 	    3 width		fixed bin,	/* line length for formatted output */
  8    42 	    3 index_origin		fixed bin,	/* the index origin (0 or 1) */
  8    43 	    3 random_link		fixed bin(35),	/* seed for random number generator */
  8    44 	    3 fuzz		float,		/* comparison tolerance (relative fuzz) */
  8    45 	    3 float_index_origin	float,		/* the index origin	in floating point */
  8    46 	    3 number_of_symbols	fixed bin,	/* the number of symbol_beads currently in existence */
  8    47 	    3 maximum_value_stack_size
  8    48 				fixed bin (18),	/* maximum number of words in one segment of value stack */
  8    49 
  8    50 	  2 pointers,				/* pointers to various internal tables */
  8    51 	    3 symbol_table_ptr	unaligned pointer,	/* -> symbol_table (apl_symbol_table.incl.pl1) */
  8    52 	    3 current_parse_frame_ptr	unaligned pointer,	/* -> topmost parse frame */
  8    53 	    3 value_stack_ptr	unaligned pointer,	/* -> next free location on value stack */
  8    54 	    3 alloc_free_info_ptr	unaligned pointer,	/* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */
  8    55 
  8    56 	  2 time_invoked		fixed bin(71),	/* clock time that APL was entered */
  8    57 	  2 integer_fuzz		float,		/* the absolute fuzz used in checking for integers */
  8    58 	  2 user_number		fixed bin(35),	/* number under which the user is signed on */
  8    59 	  2 latent_expression	unaligned pointer,	/* -> value_bead for QuadLX */
  8    60 	  2 lock			char(32),		/* the lock currently set on this workspace (password) */
  8    61 	  2 wsid			char(100),	/* the workspace identification: name, number name, or clear ws */
  8    62 	  2 last_error_code		fixed bin(35),	/* last code passed to apl_error_ */
  8    63 	  2 signoff_lock		character (32),
  8    64 
  8    65 	  2 interrupt_info		aligned,		/* bits used by apl_interpreter_ to tell when to abort */
  8    66 	    3 dont_interrupt_parse	bit,		/* if 1, don't do a dirty stop because the parser is running */
  8    67 	    3 dont_interrupt_operator	bit,		/* if 1, don't do a dirty stop because an operator is running */
  8    68 	    3 dont_interrupt_storage_manager		/* if 1, don't stop because apl_storage_mngr_ is */
  8    69 				bit,		/*       munging his tables */
  8    70 	    3 unused_interrupt_bit	bit,		/* not presently used */
  8    71 	    3 dont_interrupt_command	bit,
  8    72 	    3 can_be_interrupted	bit,		/* if 1, OK to do a clean stop (we are between lines, reading) */
  8    73 	    3 clean_interrupt_pending	bit,		/* interrupt occured, break cleanly (between lines) */
  8    74 	    3 dirty_interrupt_pending	bit,		/* interrupt occured, break as soon as not inhibited */
  8    75 
  8    76 	  2 user_name		char (32),	/* process group id of user */
  8    77 	  2 immediate_input_prompt	char (32) varying,	/* normal input */
  8    78 	  2 evaluated_input_prompt	char (32) varying,	/* quad input */
  8    79 	  2 character_input_prompt	char (32) varying,	/* quad-quote input */
  8    80 	  2 vcpu_time		aligned,
  8    81 	    3 total		fixed bin (71),
  8    82 	    3 setup		fixed bin (71),
  8    83 	    3 parse		fixed bin (71),
  8    84 	    3 lex			fixed bin (71),
  8    85 	    3 operator		fixed bin (71),
  8    86 	    3 storage_manager	fixed bin (71),
  8    87 	  2 output_info		aligned,		/* data pertaining to output buffer */
  8    88 	    3 output_buffer_ptr	unal ptr,		/* ptr to output buffer */
  8    89 	    3 output_buffer_len	fixed bin (21),	/* length (bytes) of output buffer */
  8    90 	    3 output_buffer_pos	fixed bin (21),	/* index of next byte to write in */
  8    91 	    3 output_buffer_ll	fixed bin (21),	/* print positions used up so far */
  8    92 	  2 tab_width		fixed bin (21);	/* number of columns a tabs moves cursor */
  8    93 
  8    94 declare	output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr);
  8    95 
  8    96 /* internal static */
  8    97 
  8    98 declare	max_parse_stack_depth fixed bin int static init(64536);
  8    99 
  8   100 /* ------ END INCLUDE SEGMENT		apl_ws_info.incl.pl1 -------------------------------------- */
      162 
      163 
      164 /* program */
      165 
      166 /* apl_monadic_format_:
      167*     entry (operators_argument); */
      168 
      169 /* Perform argument validation and special-casing unique to the entry of invocation */
      170 
      171 	dyadic = "0"b;
      172 	go to join;
      173 
      174 apl_dyadic_format_:
      175      entry (operators_argument);
      176 
      177 	left_vb = operators_argument.operands (1).value;
      178 	left = left_vb -> value_bead.data_pointer;
      179 	left_data_elements = left_vb -> value_bead.total_data_elements;
      180 
      181 	if ^left_vb -> value_bead.numeric_value
      182 	then go to domain_error_left;
      183 
      184 	if left_vb -> value_bead.rhorho > 1
      185 	then go to rank_error_left;
      186 
      187 	dyadic = "1"b;
      188 
      189 /* Monadic and Dyadic Format merge here */
      190 
      191 join:
      192 	format = "1"b;
      193 	right_vb = operators_argument.operands (2).value;
      194 	right = right_vb -> value_bead.data_pointer;
      195 	right_data_elements = right_vb -> value_bead.total_data_elements;
      196 
      197 	if right_vb -> value_bead.character_value
      198 	then if dyadic
      199 	     then go to domain_error_right;
      200 	     else do;
      201 		     if operators_argument.operands (2).on_stack
      202 		     then do;
      203 			     operators_argument.result = right_vb;
      204 			     return;
      205 			end;
      206 
      207 		     n_words = binary (right_vb -> value_bead.size, 18);
      208 		     result_vb = apl_push_stack_ (n_words);
      209 		     result = addrel (result_vb, currentsize (right_vb -> value_bead));
      210 		     result_vb -> word_copy_overlay (*) = right_vb -> word_copy_overlay (*);
      211 		     result_vb -> value_bead.data_pointer = result;
      212 		     operators_argument.result = result_vb;
      213 		     return;
      214 		end;
      215 	else if ^right_vb -> value_bead.numeric_value
      216 	then go to domain_error_right;		/* neither chars nor numbers */
      217 
      218 	if dyadic
      219 	then if (left_data_elements ^= 1) & (left_data_elements ^= 2)
      220 	     then if right_vb -> value_bead.rhorho > 0
      221 		then if (left_data_elements ^= 2 * right_vb -> value_bead.rho (right_vb -> value_bead.rhorho))
      222 			| (left_data_elements = 0)
      223 		     then go to length_error;		/* right nonscalar */
      224 		     else ;
      225 		else go to length_error;		/* right scalar */
      226 
      227 	go to join2;
      228 
      229 apl_print_value_:
      230      entry (P_bead_ptr, P_add_nl, P_flush_buffer);
      231 
      232 /* parameters */
      233 
      234 declare	(
      235 	P_bead_ptr	ptr unal,
      236 	P_add_nl		bit (1) aligned,
      237 	P_flush_buffer	bit (1) aligned
      238 	)		parameter;
      239 
      240 /* automatic */
      241 
      242 declare	need_nl		bit (1) aligned;		/* ON if previous element was last one in the row */
      243 
      244 /* based */
      245 
      246 declare	right_chars	char (right_data_elements) based (right);
      247 
      248 /* program */
      249 
      250 	right_vb = P_bead_ptr;
      251 
      252 	if right_vb = null
      253 	then return;
      254 
      255 	if right_vb -> general_bead.list_value
      256 	then do;
      257 		do listx = lbound (right_vb -> list_bead.member_ptr, 1) to hbound (right_vb -> list_bead.member_ptr, 1);
      258 		     call apl_print_value_ (right_vb -> list_bead.member_ptr (listx), "0"b, "0"b);
      259 		end;
      260 
      261 		call print_value_epilogue;
      262 		return;
      263 	     end;
      264 
      265 	if ^right_vb -> general_bead.value
      266 	then call apl_system_error_ (apl_error_table_$no_type_bits);
      267 
      268 	if ^right_vb -> value_bead.character_value & ^right_vb -> value_bead.numeric_value
      269 	then call apl_system_error_ (apl_error_table_$no_type_bits);
      270 
      271 	right = right_vb -> value_bead.data_pointer;
      272 	right_data_elements = right_vb -> value_bead.total_data_elements;
      273 
      274 	on cleanup call clean_up;
      275 
      276 	if right_vb -> value_bead.character_value
      277 	then do;
      278 		if right_vb -> value_bead.rhorho = 0	/* scalar */
      279 		then call append_any_char (substr (right_chars, 1, 1));
      280 		else if right_vb -> value_bead.rhorho = 1
      281 		then do;				/* vector */
      282 			do valx = 1 to right_data_elements;
      283 			     call append_any_char (substr (right_chars, valx, 1));
      284 			end;
      285 		     end;
      286 		else do;				/* array */
      287 			column_length = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho - 1);
      288 			n_cols, interval_between_elements = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho);
      289 			interval_between_planes = interval_between_elements * column_length;
      290 
      291 /* walk through planes, then rows of right arg, then columns */
      292 
      293 			colx = 1;
      294 			need_nl = "0"b;
      295 			do plane_base = 0 repeat (plane_base + interval_between_planes)
      296 			     while (plane_base < right_data_elements);
      297 			     do valx = plane_base repeat (valx + 1) while (valx < plane_base + interval_between_planes);
      298 				if need_nl
      299 				then do;
      300 					call append_newline;
      301 					need_nl = "0"b;
      302 				     end;
      303 
      304 				call append_any_char (substr (right_chars, valx + 1, 1));
      305 				colx = colx + 1;
      306 
      307 				if colx > n_cols
      308 				then do;
      309 					colx = 1;
      310 					need_nl = "1"b;
      311 				     end;
      312 			     end;
      313 
      314 /* We have just finished one plane. Compute number of blank rows to put out. */
      315 
      316 			     call compute_blank_rows;
      317 
      318 			     do rhox = 1 to n_lines;
      319 				call append_newline;
      320 			     end;
      321 			end;
      322 		     end;
      323 
      324 		call print_value_epilogue;
      325 		return;
      326 	     end;
      327 
      328 	format = "0"b;
      329 	dyadic = "0"b;
      330 
      331 /* join format function to handle numeric cases */
      332 
      333 /* The format function and the numeric cases of print_value merge here.
      334*
      335*   Compute number of columns, and number of 'rows'  (hyper-rows in the
      336*   case of a multi-dimensional array */
      337 
      338 join2:
      339 	if right_vb -> value_bead.rhorho = 0
      340 	then n_cols, interval_between_elements = 1;
      341 	else n_cols, interval_between_elements = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho);
      342 
      343 	pseudo_column_length = 1;
      344 
      345 	do rhox = 1 to right_vb -> value_bead.rhorho - 1;
      346 	     pseudo_column_length = pseudo_column_length * right_vb -> value_bead.rho (rhox);
      347 	end;
      348 
      349 /* Note: either n_cols or pseudo_column_length, or both, can be zero; this indicates a null array */
      350 
      351 	n_words = size (fmt_info);
      352 	fmt_info_ptr = apl_push_stack_ (n_words);
      353 
      354 /* Save a copy of the right rho vector if right value_bead is on the stack,
      355*   because the right vb will get popped before the result is built, and we
      356*   want to be able to fill in the result bead completely, even though in one case
      357*   the result rho will be in exactly the same location as the right rho. It's easier
      358*   to make a copy than to figure it all out... */
      359 
      360 	if format
      361 	then do;
      362 		right_rhorho = right_vb -> value_bead.rhorho;
      363 
      364 		if operators_argument.operands (2).on_stack & right_rhorho > 0
      365 		then do;
      366 			n_words = size (right_rho);
      367 			right_rho_ptr = apl_push_stack_ (n_words);
      368 			right_rho (*) = right_vb -> value_bead.rho (*);
      369 		     end;
      370 		else right_rho_ptr = null;
      371 	     end;
      372 
      373 /* Scan the right argument one column at a time, computing the maximum absolute value,
      374*   the minimum absolute value, and the template value. Also determine if the column
      375*   is fuzz-integral.  */
      376 
      377 	if right_vb -> value_bead.zero_or_one_value
      378 	then do;
      379 		fmt_info.global_max_value = 1e0;	/* safe assumption */
      380 		fmt_info.global_negative_element = "0"b;
      381 
      382 		do colx = 1 to n_cols;
      383 		     fmt_info.col (colx).max_value = 1e0;
      384 						/* we assume... */
      385 		     fmt_info.col (colx).min_value = 0e0;
      386 						/* .. */
      387 		     fmt_info.col (colx).max_abs_value = 1e0;
      388 						/* .. */
      389 		     fmt_info.col (colx).negative_element = "0"b;
      390 						/* this one we are sure of  */
      391 		     fmt_info.col (colx).fuzz_integral = "1"b;
      392 		end;
      393 	     end;
      394 	else do;
      395 		fmt_info.global_max_value = -TheBiggestNumberWeveGot;
      396 		fmt_info.global_negative_element = "0"b;
      397 
      398 		do colx = 1 to n_cols;
      399 		     fmt_info.col (colx).max_value = -TheBiggestNumberWeveGot;
      400 		     fmt_info.col (colx).min_value = TheBiggestNumberWeveGot;
      401 		     fmt_info.col (colx).negative_element = "0"b;
      402 		     fmt_info.col (colx).fuzz_integral = "1"b;
      403 		     check_if_column_fuzz_integral = ^right_vb -> value_bead.integral_value;
      404 		     column_base = colx - 1;
      405 		     column_top = column_base + interval_between_elements * pseudo_column_length;
      406 
      407 		     do valx = column_base repeat (valx + interval_between_elements) while (valx < column_top);
      408 			if right_numeric_datum (valx) < 0e0
      409 			then fmt_info.col (colx).negative_element = "1"b;
      410 
      411 			fmt_info.col (colx).max_value =
      412 			     max (fmt_info.col (colx).max_value, abs (right_numeric_datum (valx)));
      413 			fmt_info.col (colx).min_value =
      414 			     min (fmt_info.col (colx).min_value, abs (right_numeric_datum (valx)));
      415 			if check_if_column_fuzz_integral
      416 			then if abs (right_numeric_datum (valx) -
      417 			     floor (right_numeric_datum (valx) + 0.5)) > ws_info.integer_fuzz
      418 			     then check_if_column_fuzz_integral, fmt_info.col (colx).fuzz_integral = "0"b;
      419 		     end;
      420 
      421 		     fmt_info.col (colx).max_abs_value = fmt_info.col (colx).max_value;
      422 		     fmt_info.global_max_value = max (fmt_info.global_max_value, fmt_info.col (colx).max_value);
      423 
      424 		     if fmt_info.col (colx).negative_element = "1"b
      425 		     then fmt_info.col (colx).max_abs_value = -abs (fmt_info.col (colx).max_abs_value);
      426 
      427 		     fmt_info.global_negative_element =
      428 			fmt_info.global_negative_element | fmt_info.col (colx).negative_element;
      429 		end;
      430 	     end;
      431 
      432 	if fmt_info.global_negative_element = "1"b
      433 	then fmt_info.global_max_value = -abs (fmt_info.global_max_value);
      434 
      435 /* Convert the user-specified formatting parameters (in the left argument) into field width,
      436*   precision, and type. If the user did not specify a field width, compute the default width. */
      437 
      438 	if dyadic
      439 	then if left_vb -> value_bead.total_data_elements <= 2
      440 						/* scalar, 1, or 2 elements */
      441 	     then begin;
      442 
      443 /* automatic temps */
      444 
      445 declare	(precision_temp, type_temp, width_temp)
      446 			fixed bin,
      447 	(precision_temp_fl, width_temp_fl)
      448 			float;
      449 
      450 		     if left_vb -> value_bead.total_data_elements = 1
      451 		     then do;
      452 			     width_temp_fl = 0e0;
      453 			     precision_temp_fl = left_numeric_datum (0);
      454 			end;
      455 		     else do;
      456 			     width_temp_fl = left_numeric_datum (0);
      457 			     precision_temp_fl = left_numeric_datum (1);
      458 			end;
      459 
      460 		     type_temp = 1 + sign (integerize (precision_temp_fl));
      461 		     precision_temp = abs (integerize (precision_temp_fl));
      462 
      463 		     if (type_temp = SCIENTIFIC_FMT & precision_temp > 19)
      464 			| (type_temp = FIXED_DEC_FMT & precision_temp > 57)
      465 		     then go to domain_error_left;
      466 
      467 		     width_temp = integerize (width_temp_fl);
      468 
      469 		     if (width_temp < 0) | (width_temp > 255)
      470 		     then go to domain_error_left;
      471 
      472 		     if width_temp = 0
      473 		     then width_temp = 1 + min_field_width (fmt_info.global_max_value, precision_temp, type_temp);
      474 
      475 		     do colx = 1 to n_cols;
      476 			fmt_info.col (colx).type = type_temp;
      477 			fmt_info.col (colx).precision = precision_temp;
      478 			fmt_info.col (colx).field_width = width_temp;
      479 		     end;
      480 		end;
      481 	     else do;
      482 		     left_pos = 0;
      483 		     do colx = 1 to n_cols;
      484 			float_temp = left_numeric_datum (left_pos + 1);
      485 			fmt_info.col (colx).type = 1 + sign (integerize (float_temp));
      486 			fmt_info.col (colx).precision = abs (integerize (float_temp));
      487 
      488 			if (fmt_info.col (colx).type = SCIENTIFIC_FMT & fmt_info.col (colx).precision > 19)
      489 			     | (fmt_info.col (colx).type = FIXED_DEC_FMT & fmt_info.col (colx).precision > 57)
      490 			then go to domain_error_left;
      491 
      492 			fmt_info.col (colx).field_width = integerize (left_numeric_datum (left_pos));
      493 
      494 			if (fmt_info.col (colx).field_width < 0) | (fmt_info.col (colx).field_width > 255)
      495 			then go to domain_error_left;
      496 
      497 			if fmt_info.col (colx).field_width = 0
      498 						/* user wants us to choose */
      499 			then fmt_info.col (colx).field_width =
      500 				1
      501 				+
      502 				min_field_width (fmt_info.col (colx).max_abs_value, fmt_info.col (colx).precision,
      503 				fmt_info.col (colx).type);
      504 
      505 			left_pos = left_pos + 2;
      506 		     end;
      507 		end;
      508 	else if ^right_vb -> value_bead.zero_or_one_value
      509 	then do;
      510 		largest_possible_value = one_e (ws_info.digits);
      511 						/* = 10 ** ws_info.digits */
      512 		do colx = 1 to n_cols;
      513 		     if (largest_possible_value <= fmt_info.col (colx).max_value)
      514 			| (fmt_info.col (colx).min_value < 1e-4 & fmt_info.col (colx).min_value > 0e0)
      515 			| (simple_log10 (fmt_info.col (colx).max_value) - simple_log10 (fmt_info.col (colx).min_value)
      516 			> 4)
      517 		     then do;
      518 			     fmt_info.col (colx).type = SCIENTIFIC_FMT;
      519 			     fmt_info.col (colx).precision = ws_info.digits;
      520 			end;
      521 		     else if fmt_info.col (colx).fuzz_integral
      522 		     then do;
      523 			     fmt_info.col (colx).type = INTEGER_FMT;
      524 			     fmt_info.col (colx).precision = 0;
      525 			end;
      526 		     else do;
      527 			     fmt_info.col (colx).type = FIXED_DEC_FMT;
      528 			     fmt_info.col (colx).precision = ws_info.digits;
      529 			end;
      530 
      531 		     fmt_info.col (colx).field_width =
      532 			1
      533 			+
      534 			min_field_width (fmt_info.col (colx).max_abs_value, fmt_info.col (colx).precision,
      535 			fmt_info.col (colx).type);
      536 		end;
      537 	     end;
      538 	else do colx = 1 to n_cols;
      539 		fmt_info.col (colx).type = INTEGER_FMT;
      540 		fmt_info.col (colx).precision = 0;
      541 		fmt_info.col (colx).field_width = 2;
      542 	     end;
      543 
      544 /* Compute the size of the result character matrix. We cannot overlay the
      545*   input operands, so it will be placed at the end of the stack. The size we
      546*   compute is correct for all dyadic cases, and for monadic arrays.
      547*   It is a little too large for monadic scalars and vectors, since they do
      548*   not include any leading white space (and dyadic does). The size of the
      549*   temporary is not that critical, and the result size will be corrected later. */
      550 
      551 	if (n_cols = 0) | (pseudo_column_length = 0)
      552 	then result_cols = 0;
      553 	else result_cols = sum (fmt_info.col (*).field_width);
      554 
      555 	if format
      556 	then do;
      557 		data_elements, result_data_elements = pseudo_column_length * result_cols;
      558 		n_words = size (character_data_structure);
      559 		temp_result = apl_push_stack_ (n_words);
      560 		result_pos = 1;
      561 	     end;
      562 
      563 /* Perform the conversion */
      564 
      565 	if right_vb -> value_bead.rhorho = 0		/* scalar */
      566 	then do;
      567 		colx = 1;
      568 		valx = 0;
      569 		call format_value (colx, valx, ^dyadic, ^dyadic, ^dyadic);
      570 
      571 		if format
      572 		then result_cols = result_pos - 1;	/* fixup for monadic case, noop for dyadic */
      573 	     end;
      574 	else if right_vb -> value_bead.rhorho = 1	/* vector */
      575 	then do;
      576 		do valx = 0 by 1 while (valx < right_data_elements);
      577 		     colx = valx + 1;
      578 		     call format_value (colx, valx, ^dyadic & (colx = 1), ^dyadic, ^dyadic & (colx = n_cols));
      579 		end;
      580 
      581 		if format
      582 		then result_cols = result_pos - 1;	/* fixup for monadic case, noop for dyadic */
      583 	     end;
      584 	else do;					/* array */
      585 		column_length = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho - 1);
      586 		interval_between_planes = interval_between_elements * column_length;
      587 
      588 /* walk through planes, then rows of right arg, then columns */
      589 
      590 		colx = 1;
      591 		need_nl = "0"b;
      592 		do plane_base = 0 repeat (plane_base + interval_between_planes) while (plane_base < right_data_elements);
      593 		     do valx = plane_base repeat (valx + 1) while (valx < plane_base + interval_between_planes);
      594 			if need_nl
      595 			then do;
      596 				call append_newline;
      597 				need_nl = "0"b;
      598 			     end;
      599 
      600 			call format_value (colx, valx, "0"b, ^dyadic, "0"b);
      601 
      602 			colx = colx + 1;
      603 			if colx > n_cols
      604 			then do;
      605 				colx = 1;
      606 				need_nl = ^format;
      607 			     end;
      608 		     end;
      609 
      610 /* We have just finished one plane. Compute number of blank rows to put out in the print_value case. */
      611 
      612 		     if ^format
      613 		     then do;
      614 			     call compute_blank_rows;
      615 
      616 			     do rhox = 1 to n_lines;
      617 				call append_newline;
      618 			     end;
      619 			end;
      620 		end;
      621 	     end;
      622 
      623 /* Pop input operands and temporary working space */
      624 
      625 	if ^format
      626 	then do;
      627 		call print_value_epilogue;
      628 		ws_info.value_stack_ptr = fmt_info_ptr;
      629 		return;
      630 	     end;
      631 
      632 	if operators_argument.operands (2).on_stack
      633 	then ws_info.value_stack_ptr = right_vb;
      634 	else if operators_argument.operands (1).on_stack
      635 	then ws_info.value_stack_ptr = left_vb;
      636 	else ws_info.value_stack_ptr = fmt_info_ptr;	/* Well, pop stuff we put there */
      637 
      638 /* Allocate result bead. Value_bead header is guaranteed not to overlay temp_result because fmt_info
      639*   is in between, and has at least one element of 10 words. */
      640 
      641 	if right_rhorho = 0
      642 	then number_of_dimensions = 1;
      643 	else number_of_dimensions = right_rhorho;
      644 
      645 	data_elements = result_pos - 1;
      646 	n_words = size (value_bead) + size (character_data_structure);
      647 	result_vb = apl_push_stack_ (n_words);
      648 	string (result_vb -> value_bead.type) = character_value_type;
      649 	result_vb -> value_bead.rhorho = number_of_dimensions;
      650 
      651 	if right_rhorho > 0
      652 	then if right_rho_ptr = null
      653 	     then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*);
      654 	     else result_vb -> value_bead.rho (*) = right_rho (*);
      655 
      656 	result_vb -> value_bead.rho (number_of_dimensions) = result_cols;
      657 
      658 	result_vb -> value_bead.total_data_elements = data_elements;
      659 	result = addrel (result_vb, size (value_bead));
      660 	result_vb -> value_bead.data_pointer = result;
      661 	result -> character_string_overlay = temp_result -> character_string_overlay;
      662 
      663 	operators_argument.result = result_vb;
      664 	return;
      665 
      666 /* Entrypoint to write out the current contents of the output buffer */
      667 
      668 apl_flush_buffer_:
      669      entry ();
      670 
      671 	on cleanup call clean_up;
      672 
      673 	call flush_buffer;
      674 	return;
      675 
      676 /* Entrypoint to append a newline to the output buffer, and then write it out */
      677 
      678 apl_flush_buffer_nl_:
      679      entry ();
      680 
      681 	on cleanup call clean_up;
      682 
      683 	call append_newline;
      684 	call flush_buffer;
      685 	return;
      686 
      687 /* Entrypoint to append a newline to the output buffer */
      688 
      689 apl_print_newline_:
      690      entry ();
      691 
      692 	on cleanup call clean_up;
      693 
      694 	call append_newline;
      695 	return;
      696 
      697 /* Entrypoint to print character data mixed in with normal APL output.
      698*   When called multiple times before apl_print_newline_, each additional
      699*   string is tabbed to the next margin. Assumptions: tabbing wanted, every char
      700*   takes one column to print (no BS, HT, NL in argument). */
      701 
      702 apl_print_string_:
      703      entry (P_string);
      704 
      705 /* parameters */
      706 
      707 declare	P_string		char (*);
      708 
      709 /* automatic */
      710 
      711 declare	n_pads		fixed bin (21);		/* number of blanks to insert to get to margin */
      712 
      713 /* program */
      714 
      715 	on cleanup call clean_up;
      716 
      717 	if ws_info.output_buffer_ll > 0		/* already stuff on line? */
      718 	then do;
      719 		n_pads = 8 - mod (ws_info.output_buffer_ll, 8);
      720 
      721 		if ws_info.output_buffer_ll + n_pads + length (P_string) > ws_info.width
      722 		then call append_newline;
      723 		else do;
      724 			if ws_info.output_buffer_pos + n_pads > length (output_buffer)
      725 			then call flush_buffer;
      726 
      727 			substr (output_buffer, ws_info.output_buffer_pos, n_pads) = "";
      728 			ws_info.output_buffer_pos = ws_info.output_buffer_pos + n_pads;
      729 			ws_info.output_buffer_ll = ws_info.output_buffer_ll + n_pads;
      730 		     end;
      731 	     end;
      732 
      733 	if ws_info.output_buffer_pos + length (P_string) > length (output_buffer)
      734 	then call flush_buffer;
      735 
      736 	substr (output_buffer, ws_info.output_buffer_pos, length (P_string)) = P_string;
      737 	ws_info.output_buffer_pos = ws_info.output_buffer_pos + length (P_string);
      738 	ws_info.output_buffer_ll = ws_info.output_buffer_ll + length (P_string);
      739 	return;
      740 
      741 /* Error exits. These actions are for the use of the format function
      742*   only...this mechanism does not work for apl_print_value_. */
      743 
      744 domain_error_left:
      745 	operators_argument.where_error = operators_argument.where_error + 2;
      746 
      747 domain_error_right:
      748 	operators_argument.where_error = operators_argument.where_error - 1;
      749 	operators_argument.error_code = apl_error_table_$domain;
      750 	return;
      751 
      752 length_error:
      753 	operators_argument.error_code = apl_error_table_$length;
      754 	return;
      755 
      756 not_within_int_fuzz_left:
      757 	operators_argument.where_error = operators_argument.where_error + 1;
      758 	operators_argument.error_code = apl_error_table_$not_within_int_fuzz;
      759 	return;
      760 
      761 rank_error_left:
      762 	operators_argument.where_error = operators_argument.where_error + 1;
      763 	operators_argument.error_code = apl_error_table_$rank;
      764 	return;
      765 
      766 /* Internal procedures */
      767 
      768 /* Subroutine to append a single character to the output buffer, incrementing output_buffer_ll appropriately */
      769 
      770 append_any_char:
      771      procedure (P_char);
      772 
      773 /* parameters */
      774 
      775 declare	P_char		char (1) parameter;
      776 
      777 /* automatic */
      778 
      779 declare	delta		fixed bin;
      780 
      781 /* internal static */
      782 
      783 declare	width		(0:511) fixed bin (8) unal internal static init ((6) 4, 0, 0, -1, -2, 0, 4, 0, -3, (2) 0,
      784 						/* 000-017 */
      785 			(5) 4, 0, (10) 4,		/* 020-037 */
      786 			(2) 1, (2) 4, 1, (2) 4, (9) 1,/* 040-057 */
      787 			(16) 1,			/* 060-077 */
      788 			4, (15) 1,		/* 100-117 */
      789 			(14) 1, 4, 1,		/* 120-137 */
      790 			4, (15) 1,		/* 140-157 */
      791 			(15) 1, 0,		/* 160-177 */
      792 			(48) 1,			/* 200-257 */
      793 			(11) 1, 0, (4) 1,		/* 260-277 */
      794 			0, 0, 1, (13) 4,		/* 300-317 */
      795 			(48) 4,			/* 320-377 */
      796 			(256) 4);			/* 400-777 */
      797 
      798 /* program */
      799 
      800 	if P_char = QNewLine
      801 	then do;
      802 		call append_newline;
      803 		return;
      804 	     end;
      805 
      806 	delta = width (rank (P_char));
      807 
      808 	if delta = -2				/* HT */
      809 	then delta = ws_info.tab_width - mod (ws_info.output_buffer_ll, ws_info.tab_width);
      810 						/* NB: should be ws_info.tab_width */
      811 	else if delta = -3				/* CR */
      812 	then delta = -ws_info.output_buffer_ll;
      813 
      814 	if ws_info.output_buffer_ll + delta > ws_info.width
      815 	then call vector_overflow;
      816 
      817 	if ws_info.output_buffer_pos > length (output_buffer)
      818 	then call flush_buffer;
      819 
      820 	substr (output_buffer, ws_info.output_buffer_pos, 1) = P_char;
      821 	ws_info.output_buffer_pos = ws_info.output_buffer_pos + 1;
      822 	ws_info.output_buffer_ll = ws_info.output_buffer_ll + delta;
      823 	return;
      824 
      825      end /* append_any_char */;
      826 
      827 /* Subroutine to append a newline to the output buffer */
      828 
      829 append_newline:
      830      procedure ();
      831 
      832 	if ws_info.output_buffer_pos > length (output_buffer)
      833 	then call flush_buffer;
      834 
      835 	substr (output_buffer, ws_info.output_buffer_pos, 1) = QNewLine;
      836 	ws_info.output_buffer_pos = ws_info.output_buffer_pos + 1;
      837 	ws_info.output_buffer_ll = 0;
      838 	return;
      839 
      840      end /* append_newline */;
      841 
      842 /* Subroutine to cancel any pending (unwritten) output if a nonlocal
      843*   goto is performed around us. Happens if user hits ATTN during output. */
      844 
      845 clean_up:
      846      procedure ();
      847 
      848 	ws_info.output_buffer_pos = 1;
      849 	ws_info.output_buffer_ll = 0;
      850 
      851      end /* clean_up */;
      852 
      853 /* Macro-subroutine to compute the number of blank rows to put
      854*   out between the planes of a multi-dimensional array. */
      855 
      856 compute_blank_rows:
      857      procedure ();
      858 
      859 	current_rho_value = divide (valx, interval_between_planes, 21, 0);
      860 	n_lines = 1;
      861 	do rhox = right_vb -> value_bead.rhorho - 2 to 1 by -1
      862 	     while (mod (current_rho_value, right_vb -> value_bead.rho (rhox)) = 0);
      863 
      864 	     current_rho_value = divide (current_rho_value, right_vb -> value_bead.rho (rhox), 21, 0);
      865 	     n_lines = n_lines + 1;
      866 	end;
      867 
      868 	if rhox < 1				/* no blank lines after last row */
      869 	then n_lines = 0;
      870 
      871      end /* compute_blank_rows */;
      872 
      873 /* Subroutine to write out the output buffer. Called when buffer fills
      874*   up, or when all output has been copied into the buffer */
      875 
      876 flush_buffer:
      877      procedure ();
      878 
      879 /* automatic */
      880 
      881 declare	code		fixed bin (35);
      882 
      883 /* entries */
      884 
      885 declare	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));
      886 
      887 /* internal static */
      888 
      889 declare	apl_static_$apl_output
      890 			ptr external static;
      891 
      892 /* program */
      893 
      894 	call iox_$put_chars (apl_static_$apl_output, (ws_info.output_buffer_ptr), ws_info.output_buffer_pos - 1, code);
      895 	ws_info.output_buffer_pos = 1;
      896 
      897 	return;
      898 
      899      end /* flush_buffer */;
      900 
      901 /* Subroutine to convert a single float bin (63) number to one of three character forms. */
      902 
      903 format_value:
      904      procedure (bv_colx, bv_valx, bv_suppress_leading_blanks, bv_blank_trailing_zeroes, bv_suppress_trailing_blanks);
      905 
      906 /* parameters */
      907 
      908 declare	(
      909 	bv_colx		fixed bin,
      910 	bv_valx		fixed bin,
      911 	bv_suppress_leading_blanks
      912 			bit (1) aligned,
      913 	bv_blank_trailing_zeroes
      914 			bit (1) aligned,
      915 	bv_suppress_trailing_blanks
      916 			bit (1) aligned
      917 	)		parameter;
      918 
      919 /* automatic */
      920 
      921 declare	char_value	char (60) varying,
      922 	decimal_value	float decimal (19),
      923 	exponent		fixed bin,
      924 	exponent_picture	picture "z9",
      925 	field_width	fixed bin,
      926 	1 fixed_picture,
      927 	  2 whole_part	picture "(38)z9v",
      928 	  2 dot		char (1),
      929 	  2 fractional_part picture "(57)9",
      930 	integer_picture	picture "-(38)z9",
      931 	integer_value	fixed dec (19),
      932 	n_leading_blanks	fixed bin (21),
      933 	new_value_width	fixed bin (21),		/* also used to hold n trailing blanks */
      934 	precision		fixed bin,
      935 	scientific_picture	picture "9.(18)9",
      936 	start_pos		fixed bin (21),
      937 	type		fixed bin,
      938 	value_width	fixed bin (21);
      939 
      940 /* entries */
      941 
      942 declare	apl_format_util_$round
      943 			entry (float decimal (19), fixed bin, char (21)),
      944 	apl_format_util_$round_fixed
      945 			entry (float decimal (19), fixed bin, char (21)),
      946 	apl_format_util_$split
      947 			entry (float decimal (19), fixed decimal (19), fixed bin, char (21));
      948 
      949 /* program */
      950 
      951 	field_width = fmt_info.col (bv_colx).field_width;
      952 	precision = fmt_info.col (bv_colx).precision;
      953 	type = fmt_info.col (bv_colx).type;
      954 
      955 	decimal_value = right_numeric_datum (bv_valx);
      956 
      957 	go to case (type);
      958 
      959 case (0):						/* SCIENTIFIC FORMAT */
      960 	if precision < 19			/* it is already rounded to 19 places... */
      961 	then call apl_format_util_$round (decimal_value, precision, round_buffer);
      962 
      963 	call apl_format_util_$split (decimal_value, integer_value, exponent, round_buffer);
      964 
      965 	scientific_picture = integer_value;
      966 	exponent_picture = exponent;
      967 
      968 	if integer_value < 0
      969 	then char_value = QUpperMinus;
      970 	else char_value = "";
      971 
      972 	if precision = 1
      973 	then do;
      974 		char_value = char_value || substr (scientific_picture, 1, 1);
      975 		new_value_width = 0;
      976 	     end;
      977 	else if bv_blank_trailing_zeroes
      978 	then do;
      979 		new_value_width = length (rtrim (scientific_picture, "0"));
      980 
      981 		if substr (scientific_picture, new_value_width, 1) = "."
      982 		then new_value_width = new_value_width - 1;
      983 
      984 		char_value = char_value || substr (scientific_picture, 1, new_value_width);
      985 		new_value_width = precision + 1 - new_value_width;
      986 						/* compute number of trailing blanks */
      987 	     end;
      988 	else do;
      989 		char_value = char_value || substr (scientific_picture, 1, precision + 1);
      990 		new_value_width = 0;
      991 	     end;
      992 
      993 	char_value = char_value || QLetterE;
      994 
      995 	if exponent < 0
      996 	then char_value = char_value || QUpperMinus;
      997 	else new_value_width = new_value_width + 1;	/* remember to pad char_value later. */
      998 
      999 	if substr (exponent_picture, 1, 1) = " "
     1000 	then do;
     1001 		char_value = char_value || substr (exponent_picture, 2, 1);
     1002 		new_value_width = new_value_width + 1;	/* remember to pad char_value later. */
     1003 	     end;
     1004 	else char_value = char_value || exponent_picture;
     1005 
     1006 	if ^bv_suppress_trailing_blanks
     1007 	then if new_value_width > 0
     1008 	     then char_value = char_value || copy (" ", new_value_width);
     1009 	     else ;
     1010 	else field_width = field_width - new_value_width; /* shorten field by the missing blanks */
     1011 
     1012 	go to end_case;
     1013 
     1014 case (1):						/* INTEGER FORMAT */
     1015 	if ^right_vb -> value_bead.integral_value
     1016 	then call apl_format_util_$round_fixed (decimal_value, 0, round_buffer);
     1017 
     1018 	integer_picture = decimal_value;
     1019 
     1020 	if substr (integer_picture, 1, 1) = "-"
     1021 	then char_value = QUpperMinus;
     1022 	else char_value = "";
     1023 
     1024 	n_leading_blanks = verify (substr (integer_picture, 2), " ") - 1;
     1025 	start_pos = 2 + n_leading_blanks;
     1026 	char_value = char_value || substr (integer_picture, start_pos);
     1027 
     1028 	go to end_case;
     1029 
     1030 case (2):						/* FIXED_DEC FORMAT */
     1031 	if ^right_vb -> value_bead.integral_value
     1032 	then call apl_format_util_$round_fixed (decimal_value, precision, round_buffer);
     1033 
     1034 	if decimal_value < 0e0
     1035 	then char_value = QUpperMinus;
     1036 	else char_value = "";
     1037 
     1038 	fixed_picture.whole_part = decimal_value;
     1039 
     1040 	if ^right_vb -> value_bead.integral_value
     1041 	then /* rescale fractional part to be an integer (a little extra hair here is worth
     1042*		   it to be able to use a simpler picture and get inline code). */
     1043 	     fixed_picture.fractional_part = (decimal_value - trunc (decimal_value)) * 1e57;
     1044 	else string (fixed_picture.fractional_part) = (57)"0";
     1045 
     1046 	fixed_picture.dot = ".";
     1047 
     1048 	n_leading_blanks = verify (string (fixed_picture), " ") - 1;
     1049 	start_pos = n_leading_blanks + 1;		/* step over leading blanks */
     1050 
     1051 /* Number of characters in result is #whole_digits + decimal point + #fractional_digits */
     1052 
     1053 	value_width = (length (fixed_picture.whole_part) - n_leading_blanks) + 1 + precision;
     1054 
     1055 	if bv_blank_trailing_zeroes
     1056 	then do;
     1057 		new_value_width = length (rtrim (substr (string (fixed_picture), start_pos, value_width), "0"));
     1058 		if substr (string (fixed_picture), start_pos + new_value_width - 1, 1) = "."
     1059 		then new_value_width = new_value_width - 1;
     1060 
     1061 		char_value = char_value || substr (string (fixed_picture), start_pos, new_value_width);
     1062 
     1063 		new_value_width = value_width - new_value_width;
     1064 						/* compute n trailing blanks */
     1065 
     1066 		if ^bv_suppress_trailing_blanks
     1067 		then if new_value_width > 0
     1068 		     then char_value = char_value || copy (" ", new_value_width);
     1069 		     else ;
     1070 		else field_width = field_width - new_value_width;
     1071 						/* shorten field by the missing blanks */
     1072 	     end;
     1073 	else char_value = char_value || substr (string (fixed_picture), start_pos, value_width);
     1074 
     1075 end_case:
     1076 	value_width = length (char_value);
     1077 
     1078 	if value_width > field_width
     1079 	then go to domain_error_right;
     1080 
     1081 	if bv_suppress_leading_blanks
     1082 	then field_width = value_width;
     1083 
     1084 	n_leading_blanks = field_width - value_width;
     1085 
     1086 	if ^format
     1087 	then do;
     1088 		if ws_info.output_buffer_ll + (n_leading_blanks + value_width) > ws_info.width
     1089 						/* Room on output line? */
     1090 		then call vector_overflow;
     1091 
     1092 		if ws_info.output_buffer_pos + (n_leading_blanks + value_width) > length (output_buffer)
     1093 						/* Room in buffer? */
     1094 		then call flush_buffer;
     1095 
     1096 		if n_leading_blanks > 0
     1097 		then do;
     1098 			substr (output_buffer, ws_info.output_buffer_pos, n_leading_blanks) = "";
     1099 			ws_info.output_buffer_pos = ws_info.output_buffer_pos + n_leading_blanks;
     1100 		     end;
     1101 
     1102 		substr (output_buffer, ws_info.output_buffer_pos, value_width) = char_value;
     1103 		ws_info.output_buffer_pos = ws_info.output_buffer_pos + value_width;
     1104 
     1105 		ws_info.output_buffer_ll = ws_info.output_buffer_ll + (n_leading_blanks + value_width);
     1106 	     end;
     1107 	else do;
     1108 		if n_leading_blanks > 0
     1109 		then do;
     1110 			substr (temp_result -> character_string_overlay, result_pos, n_leading_blanks) = "";
     1111 			result_pos = result_pos + n_leading_blanks;
     1112 		     end;
     1113 
     1114 		substr (temp_result -> character_string_overlay, result_pos, value_width) = char_value;
     1115 		result_pos = result_pos + value_width;
     1116 	     end;
     1117 
     1118 	return;
     1119 
     1120      end /* format_value */;
     1121 
     1122 /* Function to convert a floating-point value to a floating-point representation
     1123*   of an integer, in the usual APL way, or complain if it can't. */
     1124 
     1125 integerize:
     1126      procedure (bv_value) reducible returns (float);
     1127 
     1128 /* parameters */
     1129 
     1130 declare	bv_value		float;
     1131 
     1132 /* automatic */
     1133 
     1134 declare	trial_val		float;
     1135 
     1136 /* program */
     1137 
     1138 	trial_val = floor (bv_value + .5e0);
     1139 	if abs (bv_value - trial_val) < ws_info.integer_fuzz
     1140 	then return (trial_val);
     1141 
     1142 	go to not_within_int_fuzz_left;
     1143 
     1144      end /* integerize */;
     1145 
     1146 /* Function to compute the minimum number of columns it would take to represent
     1147*   a floating point argument in APL decimal format. */
     1148 
     1149 min_field_width:
     1150      procedure (bv_value, bv_digits, bv_type) returns (fixed bin);
     1151 
     1152 /* parameters */
     1153 
     1154 declare	(
     1155 	bv_value		float,
     1156 	bv_digits		fixed bin,
     1157 	bv_type		fixed bin
     1158 	)		parameter;
     1159 
     1160 /* automatic */
     1161 
     1162 declare	decimal_value	float dec (19),
     1163 	min_width		fixed bin,
     1164 	rounded_value	float;
     1165 
     1166 /* entries */
     1167 
     1168 declare	apl_format_util_$round_fixed
     1169 			entry (float decimal (19), fixed bin, char (21));
     1170 
     1171 /* program */
     1172 
     1173 	if (bv_digits ^= 0) & ^(bv_digits = 1 & bv_type = SCIENTIFIC_FMT)
     1174 	then min_width = 1;				/* account for decimal point */
     1175 	else min_width = 0;				/* no decimal point */
     1176 
     1177 	min_width = min_width + bv_digits;		/* account for fractional digits */
     1178 
     1179 	if bv_type = SCIENTIFIC_FMT
     1180 	then do;
     1181 		min_width = min_width + 4;		/* account for E+00 */
     1182 
     1183 		if bv_value < 0e0			/* account for sign; */
     1184 		then min_width = min_width + 1;	/* it cannot be rounded away */
     1185 	     end;
     1186 	else do;
     1187 		decimal_value = bv_value;		/* perform rounding in decimal to avoid overflows */
     1188 		call apl_format_util_$round_fixed (decimal_value, bv_digits, round_buffer);
     1189 
     1190 		if decimal_value > 1.701411834604692317e38
     1191 		then rounded_value = TheBiggestNumberWeveGot;
     1192 		else if decimal_value < -1.701411834604692317e38
     1193 		then rounded_value = -TheBiggestNumberWeveGot;
     1194 		else if (decimal_value < 1.469367938527859385e-39) & (decimal_value > 0e0)
     1195 		then rounded_value = TheSmallestNumberWeveGot;
     1196 		else if (decimal_value > -1.469367938527859385e-39) & (decimal_value < 0e0)
     1197 		then rounded_value = -TheSmallestNumberWeveGot;
     1198 		else rounded_value = decimal_value;
     1199 
     1200 /* account for digits in integer part...reserve one column for a possible leading zero,
     1201*   in case any elements in the column round to zero. Currently, we cannot tell if this
     1202*   will happen, so we are forced to assume it will. */
     1203 
     1204 		min_width = min_width + 1 + simple_log10 (abs (rounded_value));
     1205 
     1206 /* account for the sign. We know that if the sign rounds away on the template value,
     1207*   then it will round away on all values in the column, so it is proper (and necessary)
     1208*   to check the sign on the rounded value. */
     1209 
     1210 		if rounded_value < 0e0
     1211 		then min_width = min_width + 1;
     1212 	     end;
     1213 
     1214 	return (min_width);
     1215 
     1216      end /* min_field_width */;
     1217 
     1218 /* Subroutine to perform actions common to the end of the apl_print_value_ cases. */
     1219 
     1220 print_value_epilogue:
     1221      procedure;
     1222 
     1223 	if P_add_nl
     1224 	then call append_newline;
     1225 
     1226 	if P_flush_buffer
     1227 	then call flush_buffer;
     1228 
     1229      end /* print_value_epilogue */;
     1230 
     1231 /* Internal procedure to return (max (0, floor (log10 (value)))) */
     1232 
     1233 simple_log10:
     1234      procedure (bv_value) returns (fixed bin);
     1235 
     1236 /* parameters */
     1237 
     1238 declare	bv_value		float parameter;
     1239 
     1240 /* automatic */
     1241 
     1242 declare	result		fixed bin,
     1243 	value		float;
     1244 
     1245 /* program */
     1246 
     1247 	value = bv_value;
     1248 
     1249 	if value < 1e0				/* would result be negative? */
     1250 	then return (0);				/* yes */
     1251 
     1252 	do result = lbound (one_e, 1) to hbound (one_e, 1) - 1 while (value >= one_e (result + 1));
     1253 	end;
     1254 
     1255 	return (result);
     1256 
     1257      end /* simple_log10 */;
     1258 
     1259 /* Subroutine to perform the actions necessary when a line of (numeric)
     1260*   output exceeds the line length */
     1261 
     1262 vector_overflow:
     1263      procedure ();
     1264 
     1265 	call append_newline;
     1266 
     1267 	if ws_info.output_buffer_pos + 6 > length (output_buffer)
     1268 	then call flush_buffer;
     1269 
     1270 	substr (output_buffer, ws_info.output_buffer_pos, 6) = "";
     1271 	ws_info.output_buffer_pos = ws_info.output_buffer_pos + 6;
     1272 	ws_info.output_buffer_ll = ws_info.output_buffer_ll + 6;
     1273 	return;
     1274 
     1275      end /* vector_overflow */;
     1276 
  9     1 /* ====== BEGIN INCLUDE SEGMENT	apl_push_stack_fcn.incl.pl1 =============================== */
  9     2 
  9     3 /* format: style3 */
  9     4 apl_push_stack_:
  9     5      procedure (P_n_words) returns (ptr);
  9     6 
  9     7 /* Function to (1) double-word align ws_info.value_stack_ptr, and
  9     8*   (2) make sure allocation request will fit on current value stack.
  9     9*
  9    10*   Written 770413 by PG
  9    11*   Modified 780210 by PG to round allocations up to an even number of words.
  9    12**/
  9    13 
  9    14 /* parameters */
  9    15 
  9    16 declare	P_n_words		fixed bin (19) parameter;
  9    17 
  9    18 /* automatic */
  9    19 
  9    20 declare	block_ptr		ptr,
  9    21 	num_words		fixed bin (19);
  9    22 
  9    23 /* builtins */
  9    24 
  9    25 declare	(addrel, binary, rel, substr, unspec)
  9    26 			builtin;
  9    27 
  9    28 /* entries */
  9    29 
  9    30 declare	apl_get_value_stack_
  9    31 			entry (fixed bin (19));
  9    32 
  9    33 /* program */
  9    34 
  9    35 	num_words = P_n_words;
  9    36 
  9    37 	if substr (unspec (num_words), 36, 1) = "1"b	/* num_words odd */
  9    38 	then num_words = num_words + 1;
  9    39 
  9    40 	if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size
  9    41 	then call apl_get_value_stack_ (num_words);
  9    42 
  9    43 	block_ptr = ws_info.value_stack_ptr;
  9    44 	ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words);
  9    45 	return (block_ptr);
  9    46 
  9    47      end apl_push_stack_;
  9    48 
  9    49 /* ------ END INCLUDE SEGMENT		apl_push_stack_fcn.incl.pl1 ------------------------------- */
     1277 
     1278      end /* apl_monadic_format_ */;
	SOURCE FILES USED IN THIS COMPILATION.

LINE      NUMBER  DATE MODIFIED     NAME			PATHNAME
             0    11/29/83  1346.9  apl_monadic_format_.pl1           >special_ldd>on>apl.1129>apl_monadic_format_.pl1
155          1    03/27/82  0429.8  apl_number_data.incl.pl1          >ldd>include>apl_number_data.incl.pl1
156          2    03/27/82  0438.5  apl_bead_format.incl.pl1          >ldd>include>apl_bead_format.incl.pl1
157          3    03/27/82  0438.6  apl_characters.incl.pl1           >ldd>include>apl_characters.incl.pl1
158          4    03/27/82  0438.7  apl_list_bead.incl.pl1            >ldd>include>apl_list_bead.incl.pl1
159          5    03/27/82  0439.0  apl_operator_bead.incl.pl1        >ldd>include>apl_operator_bead.incl.pl1
160          6    03/27/82  0439.0  apl_operators_argument.incl.pl1   >ldd>include>apl_operators_argument.incl.pl1
161          7    03/27/82  0439.2  apl_value_bead.incl.pl1           >ldd>include>apl_value_bead.incl.pl1
162          8    03/27/82  0439.2  apl_ws_info.incl.pl1              >ldd>include>apl_ws_info.incl.pl1
1277         9    03/27/82  0429.8  apl_push_stack_fcn.incl.pl1       >ldd>include>apl_push_stack_fcn.incl.pl1
	NAMES DECLARED IN THIS COMPILATION.

IDENTIFIER	     OFFSET    LOC STORAGE CLASS   DATA TYPE		ATTRIBUTES AND REFERENCES
								(* indicates a set context)

NAMES DECLARED BY DECLARE STATEMENT.
FIXED_DEC_FMT                          constant        fixed bin(17,0)          initial dcl 142 ref 463 488 527
INTEGER_FMT                            constant        fixed bin(17,0)          initial dcl 142 ref 523 539
P_add_nl                               parameter       bit(1)                   dcl 234 ref 229 1223
P_bead_ptr                             parameter       pointer                  unaligned dcl 234 ref 229 250
P_char                                 parameter       char(1)                  unaligned dcl 775 ref 770 800 806 820
P_flush_buffer                         parameter       bit(1)                   dcl 234 ref 229 1226
P_n_words                              parameter       fixed bin(19,0)          dcl 9-16 ref 9-4 9-35
P_string                               parameter       char                     unaligned dcl 707 ref 702 721 733 736 736 737 738
QLetterE                        004647 constant        char(1)                  initial unaligned dcl 3-11 ref 993
QNewLine                               constant        char(1)                  initial unaligned dcl 3-11 ref 800 835
QUpperMinus                     004646 constant        char(1)                  initial unaligned dcl 3-11 ref 968 995 1020 1034
SCIENTIFIC_FMT                         constant        fixed bin(17,0)          initial dcl 142 ref 463 488 518 1173 1179
TheBiggestNumberWeveGot         000206 constant        float bin(63)            initial dcl 1-16 ref 395 399 400 1190 1192
TheSmallestNumberWeveGot        000204 constant        float bin(63)            initial dcl 1-16 ref 1194 1196
abs                                                    builtin function         dcl 118 ref 411 413 415 424 432 461 486 1139 1204
                                                                                  1204
addrel                                                 builtin function         dcl 118 in procedure "apl_monadic_format_" ref 209
                                                                                  659
addrel                                                 builtin function         dcl 9-25 in procedure "apl_push_stack_" ref 9-44
apl_error_table_$domain         000012 external static fixed bin(35,0)          dcl 132 ref 749
apl_error_table_$length         000014 external static fixed bin(35,0)          dcl 132 ref 752
apl_error_table_$no_type_bits   000016 external static fixed bin(35,0)          dcl 132 set ref 265* 268*
apl_error_table_$not_within_int_fuzz
                                000020 external static fixed bin(35,0)          dcl 132 ref 758
apl_error_table_$rank           000022 external static fixed bin(35,0)          dcl 132 ref 763
apl_format_util_$round          000032 constant        entry                    external dcl 942 ref 959
apl_format_util_$round_fixed    000040 constant        entry                    external dcl 1168 in procedure "min_field_width" ref
                                                                                  1188
apl_format_util_$round_fixed    000034 constant        entry                    external dcl 942 in procedure "format_value" ref
                                                                                  1014 1030
apl_format_util_$split          000036 constant        entry                    external dcl 942 ref 963
apl_get_value_stack_            000042 constant        entry                    external dcl 9-30 ref 9-40
apl_static_$apl_output          000030 external static pointer                  dcl 889 set ref 894*
apl_static_$ws_info_ptr         000024 external static structure                level 1 dcl 8-11
apl_system_error_               000010 constant        entry                    external dcl 128 ref 265 268
bead_type                              based           structure                level 3 packed unaligned dcl 2-3
binary                                                 builtin function         dcl 9-25 in procedure "apl_push_stack_" ref 9-40
binary                                                 builtin function         dcl 118 in procedure "apl_monadic_format_" ref 207
bits_for_parse            1            based           structure                level 2 packed unaligned dcl 5-3
block_ptr                       000504 automatic       pointer                  dcl 9-20 set ref 9-43* 9-45
bv_blank_trailing_zeroes               parameter       bit(1)                   dcl 908 ref 903 977 1055
bv_colx                                parameter       fixed bin(17,0)          dcl 908 ref 903 951 952 953
bv_digits                              parameter       fixed bin(17,0)          dcl 1154 set ref 1149 1173 1173 1177 1188*
bv_suppress_leading_blanks             parameter       bit(1)                   dcl 908 ref 903 1081
bv_suppress_trailing_blanks            parameter       bit(1)                   dcl 908 ref 903 1006 1066
bv_type                                parameter       fixed bin(17,0)          dcl 1154 ref 1149 1173 1179
bv_value                               parameter       float bin(63)            dcl 1130 in procedure "integerize" ref 1125 1138
                                                                                  1139
bv_value                               parameter       float bin(63)            dcl 1238 in procedure "simple_log10" ref 1233 1247
bv_value                               parameter       float bin(63)            dcl 1154 in procedure "min_field_width" ref 1149
                                                                                  1183 1187
bv_valx                                parameter       fixed bin(17,0)          dcl 908 ref 903 955
char_value                      000302 automatic       varying char(60)         dcl 921 set ref 968* 970* 974* 974 984* 984 989* 989
                                                                                  993* 993 995* 995 1001* 1001 1004* 1004 1006* 1006
                                                                                  1020* 1022* 1026* 1026 1034* 1036* 1061* 1061
                                                                                  1066* 1066 1073* 1073 1075 1102 1114
character_data_structure               based           structure                level 1 dcl 7-15 ref 558 646
character_string_overlay               based           char                     dcl 7-19 set ref 661* 661 1110* 1114*
character_value           0(09)        based           bit(1)                   level 5 packed unaligned dcl 7-3 set ref 197 268 276
character_value_type                   constant        bit(18)                  initial unaligned dcl 2-30 ref 648
check_if_column_fuzz_integral   000102 automatic       bit(1)                   unaligned dcl 49 set ref 403* 415 415*
cleanup                         000176 stack reference condition                dcl 124 ref 274 671 681 692 715
code                            000272 automatic       fixed bin(35,0)          dcl 881 set ref 894*
col                       4            based           structure                array level 2 dcl 95
column_base                     000103 automatic       fixed bin(17,0)          dcl 49 set ref 404* 405 407
column_length                   000104 automatic       fixed bin(17,0)          dcl 49 set ref 287* 289 585* 586
column_top                      000105 automatic       fixed bin(17,0)          dcl 49 set ref 405* 407
colx                            000106 automatic       fixed bin(17,0)          dcl 49 set ref 293* 305* 305 307 309* 382* 383 385
                                                                                  387 389 391* 398* 399 400 401 402 404 408 411 411
                                                                                  413 413 415 421 421 422 424 424 424 427* 475* 476
                                                                                  477 478* 483* 485 486 488 488 488 488 492 494 494
                                                                                  497 497 497 497 497* 512* 513 513 513 513 513 518
                                                                                  519 521 523 524 527 528 531 531 531 531* 538* 539
                                                                                  540 541* 567* 569* 577* 578* 578 578 590* 600*
                                                                                  602* 602 603 605*
copy                                                   builtin function         dcl 118 ref 1006 1066
current_rho_value               000107 automatic       fixed bin(21,0)          dcl 49 set ref 859* 861 864* 864
currentsize                                            builtin function         dcl 118 ref 209
data_elements                   000110 automatic       fixed bin(21,0)          dcl 49 set ref 557* 558 645* 646 658 661 661 1110
                                                                                  1114
data_pointer              4            based           pointer                  level 2 packed unaligned dcl 7-3 set ref 178 194
                                                                                  211* 271 660*
data_type                 0(08)        based           structure                level 4 in structure "value_bead" packed unaligned
                                                                                  dcl 7-3 in procedure "apl_monadic_format_"
data_type                 0(08)        based           structure                level 3 in structure "general_bead" packed unaligned
                                                                                  dcl 2-3 in procedure "apl_monadic_format_"
decimal_value                   000322 automatic       float dec(19)            dcl 921 in procedure "format_value" set ref 955*
                                                                                  959* 963* 1014* 1018 1030* 1034 1038 1040 1040
decimal_value                   000434 automatic       float dec(19)            dcl 1162 in procedure "min_field_width" set ref
                                                                                  1187* 1188* 1190 1192 1194 1194 1196 1196 1198
delta                           000246 automatic       fixed bin(17,0)          dcl 779 set ref 806* 808 808* 811 811* 814 822
digits                    2            based           fixed bin(17,0)          level 3 dcl 8-16 ref 510 519 528
divide                                                 builtin function         dcl 118 ref 859 864
dot                      11(27) 000333 automatic       char(1)                  level 2 packed unaligned dcl 921 set ref 1046*
dyadic                          000111 automatic       bit(1)                   dcl 49 set ref 171* 187* 197 218 329* 438 569 569
                                                                                  569 578 578 578 600
error_code                7            parameter       fixed bin(35,0)          level 2 dcl 6-3 set ref 749* 752* 758* 763*
exponent                        000330 automatic       fixed bin(17,0)          dcl 921 set ref 963* 966 995
exponent_picture                000331 automatic       picture(2)               unaligned dcl 921 set ref 966* 999 1001 1004
field_width              14            based           fixed bin(17,0)          array level 3 in structure "fmt_info" dcl 95
                                                                                  in procedure "apl_monadic_format_" set ref 478*
                                                                                  492* 494 494 497 497* 531* 541* 553 951
field_width                     000332 automatic       fixed bin(17,0)          dcl 921 in procedure "format_value" set ref 951*
                                                                                  1010* 1010 1070* 1070 1078 1081* 1084
fixed_picture                   000333 automatic       structure                level 1 packed unaligned dcl 921 set ref 1048 1057
                                                                                  1058 1061 1073
float_temp                      000112 automatic       float bin(63)            dcl 49 set ref 484* 485* 486*
floor                                                  builtin function         dcl 118 ref 415 1138
fmt_info                               based           structure                level 1 dcl 95 set ref 351
fmt_info_ptr                    000100 automatic       pointer                  dcl 49 set ref 351 352* 379 380 383 385 387 389 391
                                                                                  395 396 399 400 401 402 408 411 411 413 413 415
                                                                                  421 421 422 422 422 424 424 424 427 427 427 432
                                                                                  432 432 472 476 477 478 485 486 488 488 488 488
                                                                                  492 494 494 497 497 497 497 497 513 513 513 513
                                                                                  513 518 519 521 523 524 527 528 531 531 531 531
                                                                                  539 540 541 553 628 636 951 952 953
format                          000114 automatic       bit(1)                   dcl 49 set ref 191* 328* 360 555 571 581 606 612 625
                                                                                  1086
fractional_part          12     000333 automatic       picture(57)              level 2 packed unaligned dcl 921 set ref 1040* 1044*
fuzz_integral            13            based           bit(1)                   array level 3 dcl 95 set ref 391* 402* 415* 521
general_bead                           based           structure                level 1 dcl 2-3
global_max_value                       based           float bin(63)            level 2 dcl 95 set ref 379* 395* 422* 422 432* 432
                                                                                  472*
global_negative_element
                          2            based           bit(1)                   level 2 dcl 95 set ref 380* 396* 427* 427 432
hbound                                                 builtin function         dcl 118 ref 257 1252
header                                 based           structure                level 2 dcl 7-3
integer_fuzz             22            based           float bin(63)            level 2 dcl 8-16 ref 415 1139
integer_picture                 000364 automatic       picture(40)              unaligned dcl 921 set ref 1018* 1020 1024 1026
integer_value                   000376 automatic       fixed dec(19,0)          dcl 921 set ref 963* 965 968
integral_value            0(11)        based           bit(1)                   level 5 packed unaligned dcl 7-3 set ref 403 1014
                                                                                  1030 1040
interval_between_elements       000115 automatic       fixed bin(17,0)          dcl 49 set ref 288* 289 338* 341* 405 419 586
interval_between_planes         000116 automatic       fixed bin(17,0)          dcl 49 set ref 289* 297 321 586* 593 620 859
iox_$put_chars                  000026 constant        entry                    external dcl 885 ref 894
largest_possible_value          000120 automatic       float bin(63)            dcl 49 set ref 510* 513
lbound                                                 builtin function         dcl 118 ref 257 1252
left                            000124 automatic       pointer                  dcl 49 set ref 178* 453 456 457 484 492
left_data_elements              000126 automatic       fixed bin(21,0)          dcl 49 set ref 179* 218 218 218 218
left_numeric_datum                     based           float bin(63)            array dcl 111 set ref 453 456 457 484 492*
left_pos                        000122 automatic       fixed bin(17,0)          dcl 49 set ref 482* 484 492 505* 505
left_vb                         000130 automatic       pointer                  dcl 49 set ref 177* 178 179 181 184 438 450 634
length                                                 builtin function         dcl 118 ref 721 724 733 733 736 737 738 817 832 979
                                                                                  1053 1057 1075 1092 1267
list_bead                              based           structure                level 1 dcl 4-3
list_value                0(08)        based           bit(1)                   level 4 packed unaligned dcl 2-3 ref 255
listx                           000132 automatic       fixed bin(17,0)          dcl 49 set ref 257* 258*
max                                                    builtin function         dcl 118 ref 411 422
max_abs_value            10            based           float bin(63)            array level 3 dcl 95 set ref 387* 421* 424* 424 497*
                                                                                  531*
max_value                 4            based           float bin(63)            array level 3 dcl 95 set ref 383* 399* 411* 411 421
                                                                                  422 513 513*
maximum_value_stack_size
                         13            based           fixed bin(18,0)          level 3 dcl 8-16 ref 9-40
member_ptr                3            based           pointer                  array level 3 packed unaligned dcl 4-3 set ref 257
                                                                                  257 258*
members                   3            based           structure                array level 2 dcl 4-3
min                                                    builtin function         dcl 118 ref 413
min_value                 6            based           float bin(63)            array level 3 dcl 95 set ref 385* 400* 413* 413 513
                                                                                  513 513*
min_width                       000442 automatic       fixed bin(17,0)          dcl 1162 set ref 1173* 1175* 1177* 1177 1181* 1181
                                                                                  1183* 1183 1204* 1204 1210* 1210 1214
mod                                                    builtin function         dcl 118 ref 719 808 861
n_cols                          000133 automatic       fixed bin(17,0)          dcl 49 set ref 288* 307 338* 341* 351 382 398 475
                                                                                  483 512 538 551 553 578 603
n_leading_blanks                000403 automatic       fixed bin(21,0)          dcl 921 set ref 1024* 1025 1048* 1049 1053 1084*
                                                                                  1088 1092 1096 1098 1099 1105 1108 1110 1111
n_lines                         000134 automatic       fixed bin(17,0)          dcl 49 set ref 318 616 860* 865* 865 868*
n_pads                          000211 automatic       fixed bin(21,0)          dcl 711 set ref 719* 721 724 727 728 729
n_words                         000135 automatic       fixed bin(19,0)          dcl 49 set ref 207* 208* 210 351* 352* 366* 367*
                                                                                  558* 559* 646* 647*
need_nl                         000210 automatic       bit(1)                   dcl 242 set ref 294* 298 301* 310* 591* 594 597*
                                                                                  606*
negative_element         12            based           bit(1)                   array level 3 dcl 95 set ref 389* 401* 408* 424 427
new_value_width                 000404 automatic       fixed bin(21,0)          dcl 921 set ref 975* 979* 981 981* 981 984 985* 985
                                                                                  990* 997* 997 1002* 1002 1006 1006 1010 1057* 1058
                                                                                  1058* 1058 1061 1063* 1063 1066 1066 1070
null                                                   builtin function         dcl 118 ref 252 370 651
num_words                       000506 automatic       fixed bin(19,0)          dcl 9-20 set ref 9-35* 9-37 9-37* 9-37 9-40 9-40*
                                                                                  9-44
number_of_dimensions            000204 automatic       fixed bin(17,0)          dcl 7-3 set ref 641* 643* 646 649 656 659
number_of_members         2            based           fixed bin(17,0)          level 2 dcl 4-3 ref 257
numeric_value             0(10)        based           bit(1)                   level 5 packed unaligned dcl 7-3 set ref 181 215 268
on_stack                  1            parameter       bit(1)                   array level 3 dcl 6-3 ref 201 364 632 634
one_e                           000210 constant        float bin(63)            initial array dcl 148 ref 510 1252 1252 1252
operands                               parameter       structure                array level 2 dcl 6-3
operator_bead                          based           structure                level 1 dcl 5-3
operators_argument                     parameter       structure                level 1 dcl 6-3 set ref 44 174
output_buffer                          based           char                     unaligned dcl 8-94 set ref 724 727* 733 736* 817
                                                                                  820* 832 835* 1092 1098* 1102* 1267 1270*
output_buffer_len       171            based           fixed bin(21,0)          level 3 dcl 8-16 ref 724 727 733 736 817 820 832 835
                                                                                  1092 1098 1102 1267 1270
output_buffer_ll        173            based           fixed bin(21,0)          level 3 dcl 8-16 set ref 717 719 721 729* 729 738*
                                                                                  738 808 811 814 822* 822 837* 849* 1088 1105* 1105
                                                                                  1272* 1272
output_buffer_pos       172            based           fixed bin(21,0)          level 3 dcl 8-16 set ref 724 727 728* 728 733 736
                                                                                  737* 737 817 820 821* 821 832 835 836* 836 848*
                                                                                  894 895* 1092 1098 1099* 1099 1102 1103* 1103 1267
                                                                                  1270 1271* 1271
output_buffer_ptr       170            based           pointer                  level 3 packed unaligned dcl 8-16 ref 724 727 733
                                                                                  736 817 820 832 835 894 1092 1098 1102 1267 1270
output_info             170            based           structure                level 2 dcl 8-16
plane_base                      000136 automatic       fixed bin(17,0)          dcl 49 set ref 295* 295* 297 297* 321 592* 592* 593
                                                                                  593* 620
pointers                 14            based           structure                level 2 dcl 8-16
precision                15            based           fixed bin(17,0)          array level 3 in structure "fmt_info" dcl 95
                                                                                  in procedure "apl_monadic_format_" set ref 477*
                                                                                  486* 488 488 497* 519* 524* 528* 531* 540* 952
precision                       000405 automatic       fixed bin(17,0)          dcl 921 in procedure "format_value" set ref 952* 959
                                                                                  959* 972 985 989 1030* 1053
precision_temp                  000227 automatic       fixed bin(17,0)          dcl 445 set ref 461* 463 463 472* 477
precision_temp_fl               000232 automatic       float bin(63)            dcl 445 set ref 453* 457* 460* 461*
pseudo_column_length            000137 automatic       fixed bin(17,0)          dcl 49 set ref 343* 346* 346 405 551 557
rank                                                   builtin function         dcl 118 ref 806
rel                                                    builtin function         dcl 9-25 ref 9-40
result                          000140 automatic       pointer                  dcl 49 in procedure "apl_monadic_format_" set ref
                                                                                  209* 211 659* 660 661
result                          000462 automatic       fixed bin(17,0)          dcl 1242 in procedure "simple_log10" set ref 1252*
                                                                                  1252* 1255
result                    6            parameter       pointer                  level 2 in structure "operators_argument" packed
                                                                                  unaligned dcl 6-3 in procedure
                                                                                  "apl_monadic_format_" set ref 203* 212* 663*
result_cols                     000142 automatic       fixed bin(21,0)          dcl 49 set ref 551* 553* 557 571* 581* 656
result_data_elements            000143 automatic       fixed bin(21,0)          dcl 49 set ref 557*
result_pos                      000144 automatic       fixed bin(21,0)          dcl 49 set ref 560* 571 581 645 1110 1111* 1111 1114
                                                                                  1115* 1115
result_vb                       000146 automatic       pointer                  dcl 49 set ref 208* 209 210 211 212 647* 648 649 651
                                                                                  654 656 658 659 660 663
rho                       5            based           fixed bin(21,0)          array level 2 dcl 7-3 set ref 218 287 288 341 346
                                                                                  368 585 651* 651 654* 656* 861 864
rhorho                    3            based           fixed bin(17,0)          level 2 dcl 7-3 set ref 184 209 218 218 278 280 287
                                                                                  288 338 341 345 362 368 565 574 585 649* 651 654
                                                                                  861
rhox                            000150 automatic       fixed bin(17,0)          dcl 49 set ref 318* 345* 346* 616* 861* 861* 864*
                                                                                  868
right                           000152 automatic       pointer                  dcl 49 set ref 194* 271* 278 278 283 283 304 304 408
                                                                                  411 413 415 415 955
right_chars                            based           char                     unaligned dcl 246 ref 278 278 283 283 304 304
right_data_elements             000154 automatic       fixed bin(21,0)          dcl 49 set ref 195* 272* 278 278 282 283 283 295 304
                                                                                  304 576 592
right_numeric_datum                    based           float bin(63)            array dcl 111 ref 408 411 413 415 415 955
right_rho                              based           fixed bin(21,0)          array dcl 111 set ref 366 368* 654
right_rho_ptr                   000156 automatic       pointer                  dcl 49 set ref 366 367* 368 370* 651 654
right_rhorho                    000160 automatic       fixed bin(17,0)          dcl 49 set ref 362* 364 366 368 641 643 651 654
right_vb                        000162 automatic       pointer                  dcl 49 set ref 193* 194 195 197 203 207 209 210 215
                                                                                  218 218 218 250* 252 255 257 257 258 265 268 268
                                                                                  271 272 276 278 280 287 287 288 288 338 341 341
                                                                                  345 346 362 368 377 403 508 565 574 585 585 632
                                                                                  651 861 861 864 1014 1030 1040
round_buffer                    000164 automatic       char(21)                 unaligned dcl 49 set ref 959* 963* 1014* 1030* 1188*
rounded_value                   000444 automatic       float bin(63)            dcl 1162 set ref 1190* 1192* 1194* 1196* 1198* 1204
                                                                                  1204 1210
rtrim                                                  builtin function         dcl 118 ref 979 1057
scientific_picture              000406 automatic       picture(20)              unaligned dcl 921 set ref 965* 974 979 981 984 989
sign                                                   builtin function         dcl 118 ref 460 485
size                                                   builtin function         dcl 118 in procedure "apl_monadic_format_" ref 351
                                                                                  366 558 646 646 659
size                      0(18)        based           bit(18)                  level 3 in structure "value_bead" packed unaligned
                                                                                  dcl 7-3 in procedure "apl_monadic_format_" ref 207
start_pos                       000413 automatic       fixed bin(21,0)          dcl 921 set ref 1025* 1026 1049* 1057 1058 1061 1073
static_ws_info_ptr              000024 external static pointer                  level 2 packed unaligned dcl 8-11 ref 8-7
string                                                 builtin function         dcl 118 set ref 648* 1044* 1048 1057 1058 1061 1073
substr                                                 builtin function         dcl 9-25 in procedure "apl_push_stack_" ref 9-37
substr                                                 builtin function         dcl 118 in procedure "apl_monadic_format_" set ref
                                                                                  278 278 283 283 304 304 727* 736* 820* 835* 974
                                                                                  981 984 989 999 1001 1020 1024 1026 1057 1058 1061
                                                                                  1073 1098* 1102* 1110* 1114* 1270*
sum                                                    builtin function         dcl 118 ref 553
tab_width               174            based           fixed bin(21,0)          level 2 dcl 8-16 ref 808 808
temp_result                     000172 automatic       pointer                  dcl 49 set ref 559* 661 1110 1114
total_data_elements       2            based           fixed bin(21,0)          level 2 dcl 7-3 set ref 179 195 272 438 450 658*
trial_val                       000424 automatic       float bin(63)            dcl 1134 set ref 1138* 1139 1139
trunc                                                  builtin function         dcl 118 ref 1040
type                                   based           structure                level 3 in structure "value_bead" packed unaligned
                                                                                  dcl 7-3 in procedure "apl_monadic_format_" set ref
                                                                                  648*
type                            000414 automatic       fixed bin(17,0)          dcl 921 in procedure "format_value" set ref 953* 957
type                     16            based           fixed bin(17,0)          array level 3 in structure "fmt_info" dcl 95
                                                                                  in procedure "apl_monadic_format_" set ref 476*
                                                                                  485* 488 488 497* 518* 523* 527* 531* 539* 953
type                                   based           structure                level 3 in structure "list_bead" packed unaligned
                                                                                  dcl 4-3 in procedure "apl_monadic_format_"
type                                   based           structure                level 2 in structure "general_bead" packed unaligned
                                                                                  dcl 2-3 in procedure "apl_monadic_format_"
type_temp                       000230 automatic       fixed bin(17,0)          dcl 445 set ref 460* 463 463 472* 476
unspec                                                 builtin function         dcl 9-25 ref 9-37
value                     0(02)        based           bit(1)                   level 4 in structure "general_bead" packed unaligned
                                                                                  dcl 2-3 in procedure "apl_monadic_format_" ref 265
value                                  parameter       pointer                  array level 3 in structure "operators_argument"
                                                                                  packed unaligned dcl 6-3 in procedure
                                                                                  "apl_monadic_format_" ref 177 193
value                           000464 automatic       float bin(63)            dcl 1242 in procedure "simple_log10" set ref 1247*
                                                                                  1249 1252
value_bead                             based           structure                level 1 dcl 7-3 set ref 209 646 659
value_stack_ptr          16            based           pointer                  level 3 packed unaligned dcl 8-16 set ref 628* 632*
                                                                                  634* 636* 9-40 9-43 9-44* 9-44
value_width                     000415 automatic       fixed bin(21,0)          dcl 921 set ref 1053* 1057 1063 1073 1075* 1078 1081
                                                                                  1084 1088 1092 1102 1103 1105 1114 1115
values                    2            based           structure                level 2 dcl 8-16
valx                            000174 automatic       fixed bin(17,0)          dcl 49 set ref 282* 283 283* 297* 297* 304 304* 312
                                                                                  407* 407* 408 411 413 415 415* 419 568* 569* 576*
                                                                                  576* 577 578* 593* 593* 600* 608 859
verify                                                 builtin function         dcl 118 ref 1024 1048
where_error              10            parameter       fixed bin(17,0)          level 2 dcl 6-3 set ref 744* 744 747* 747 756* 756
                                                                                  761* 761
whole_part                      000333 automatic       picture(39)              level 2 packed unaligned dcl 921 set ref 1038* 1053
width                           000003 constant        fixed bin(8,0)           initial array unaligned dcl 783 in procedure
                                                                                  "append_any_char" ref 806
width                     3            based           fixed bin(17,0)          level 3 in structure "ws_info" dcl 8-16 in procedure
                                                                                  "apl_monadic_format_" ref 721 814 1088
width_temp                      000231 automatic       fixed bin(17,0)          dcl 445 set ref 467* 469 469 472 472* 478
width_temp_fl                   000234 automatic       float bin(63)            dcl 445 set ref 452* 456* 467*
word_copy_overlay                      based           fixed bin(35,0)          array dcl 111 set ref 210* 210
ws_info                                based           structure                level 1 dcl 8-16
ws_info_ptr                     000206 automatic       pointer                  initial dcl 8-7 set ref 415 510 519 528 628 632 634
                                                                                  636 717 719 721 721 724 724 724 727 727 727 728
                                                                                  728 729 729 733 733 733 736 736 736 737 737 738
                                                                                  738 8-7* 808 808 808 811 814 814 817 817 817 820
                                                                                  820 820 821 821 822 822 832 832 832 835 835 835
                                                                                  836 836 837 848 849 894 894 895 1088 1088 1092
                                                                                  1092 1092 1098 1098 1098 1099 1099 1102 1102 1102
                                                                                  1103 1103 1105 1105 1139 1267 1267 1267 1270 1270
                                                                                  1270 1271 1271 1272 1272 9-40 9-40 9-43 9-44 9-44
zero_or_one_value         0(12)        based           bit(1)                   level 5 packed unaligned dcl 7-3 set ref 377 508

NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED.
Binary                                 internal static bit(1)                   initial dcl 1-16
MAX_VALUE_BEAD_SIZE                    internal static fixed bin(19,0)          initial dcl 7-28
NumberSize                             internal static fixed bin(4,0)           initial dcl 1-25
QAlpha                                 internal static char(1)                  initial unaligned dcl 3-11
QAndSign                               internal static char(1)                  initial unaligned dcl 3-11
QApostrophe                            internal static char(1)                  initial unaligned dcl 3-11
QBackSlash                             internal static char(1)                  initial unaligned dcl 3-11
QBackSlashHyphen                       internal static char(1)                  initial unaligned dcl 3-11
QBackSpace                             internal static char(1)                  initial unaligned dcl 3-11
QBell                                  internal static char(1)                  initial unaligned dcl 3-11
QCap                                   internal static char(1)                  initial unaligned dcl 3-11
QCeiling                               internal static char(1)                  initial unaligned dcl 3-11
QCentSign                              internal static char(1)                  initial unaligned dcl 3-11
QCircle                                internal static char(1)                  initial unaligned dcl 3-11
QCircleBackSlash                       internal static char(1)                  initial unaligned dcl 3-11
QCircleBar                             internal static char(1)                  initial unaligned dcl 3-11
QCircleHyphen                          internal static char(1)                  initial unaligned dcl 3-11
QCircleSlash                           internal static char(1)                  initial unaligned dcl 3-11
QCircleStar                            internal static char(1)                  initial unaligned dcl 3-11
QColon                                 internal static char(1)                  initial unaligned dcl 3-11
QComma                                 internal static char(1)                  initial unaligned dcl 3-11
QCommaHyphen                           internal static char(1)                  initial unaligned dcl 3-11
QConditionalNewLine                    internal static char(1)                  initial unaligned dcl 3-11
QCup                                   internal static char(1)                  initial unaligned dcl 3-11
QDeCode                                internal static char(1)                  initial unaligned dcl 3-11
QDel                                   internal static char(1)                  initial unaligned dcl 3-11
QDelTilde                              internal static char(1)                  initial unaligned dcl 3-11
QDelta                                 internal static char(1)                  initial unaligned dcl 3-11
QDelta_                                internal static char(1)                  initial unaligned dcl 3-11
QDiamond                               internal static char(1)                  initial unaligned dcl 3-11
QDiaresis                              internal static char(1)                  initial unaligned dcl 3-11
QDivision                              internal static char(1)                  initial unaligned dcl 3-11
QDollar                                internal static char(1)                  initial unaligned dcl 3-11
QDomino                                internal static char(1)                  initial unaligned dcl 3-11
QDownArrow                             internal static char(1)                  initial unaligned dcl 3-11
QEight                                 internal static char(1)                  initial unaligned dcl 3-11
QEight_                                internal static char(1)                  initial unaligned dcl 3-11
QEnCode                                internal static char(1)                  initial unaligned dcl 3-11
QEpsilon                               internal static char(1)                  initial unaligned dcl 3-11
QEqual                                 internal static char(1)                  initial unaligned dcl 3-11
QExclamation                           internal static char(1)                  initial unaligned dcl 3-11
QExecuteSign                           internal static char(1)                  initial unaligned dcl 3-11
QFive                                  internal static char(1)                  initial unaligned dcl 3-11
QFive_                                 internal static char(1)                  initial unaligned dcl 3-11
QFloor                                 internal static char(1)                  initial unaligned dcl 3-11
QFormatSign                            internal static char(1)                  initial unaligned dcl 3-11
QFour                                  internal static char(1)                  initial unaligned dcl 3-11
QFour_                                 internal static char(1)                  initial unaligned dcl 3-11
QGradeDown                             internal static char(1)                  initial unaligned dcl 3-11
QGradeUp                               internal static char(1)                  initial unaligned dcl 3-11
QGreaterOrEqual                        internal static char(1)                  initial unaligned dcl 3-11
QGreaterThan                           internal static char(1)                  initial unaligned dcl 3-11
QIBeam                                 internal static char(1)                  initial unaligned dcl 3-11
QIota                                  internal static char(1)                  initial unaligned dcl 3-11
QLamp                                  internal static char(1)                  initial unaligned dcl 3-11
QLeftArrow                             internal static char(1)                  initial unaligned dcl 3-11
QLeftBrace                             internal static char(1)                  initial unaligned dcl 3-11
QLeftBracket                           internal static char(1)                  initial unaligned dcl 3-11
QLeftLump                              internal static char(1)                  initial unaligned dcl 3-11
QLeftParen                             internal static char(1)                  initial unaligned dcl 3-11
QLeftTack                              internal static char(1)                  initial unaligned dcl 3-11
QLessOrEqual                           internal static char(1)                  initial unaligned dcl 3-11
QLessThan                              internal static char(1)                  initial unaligned dcl 3-11
QLetterA                               internal static char(1)                  initial unaligned dcl 3-11
QLetterA_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterB                               internal static char(1)                  initial unaligned dcl 3-11
QLetterB_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterC                               internal static char(1)                  initial unaligned dcl 3-11
QLetterC_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterD                               internal static char(1)                  initial unaligned dcl 3-11
QLetterD_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterE_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterF                               internal static char(1)                  initial unaligned dcl 3-11
QLetterF_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterG                               internal static char(1)                  initial unaligned dcl 3-11
QLetterG_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterH                               internal static char(1)                  initial unaligned dcl 3-11
QLetterH_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterI                               internal static char(1)                  initial unaligned dcl 3-11
QLetterI_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterJ                               internal static char(1)                  initial unaligned dcl 3-11
QLetterJ_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterK                               internal static char(1)                  initial unaligned dcl 3-11
QLetterK_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterL                               internal static char(1)                  initial unaligned dcl 3-11
QLetterL_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterM                               internal static char(1)                  initial unaligned dcl 3-11
QLetterM_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterN                               internal static char(1)                  initial unaligned dcl 3-11
QLetterN_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterO                               internal static char(1)                  initial unaligned dcl 3-11
QLetterO_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterP                               internal static char(1)                  initial unaligned dcl 3-11
QLetterP_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterQ                               internal static char(1)                  initial unaligned dcl 3-11
QLetterQ_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterR                               internal static char(1)                  initial unaligned dcl 3-11
QLetterR_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterS                               internal static char(1)                  initial unaligned dcl 3-11
QLetterS_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterT                               internal static char(1)                  initial unaligned dcl 3-11
QLetterT_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterU                               internal static char(1)                  initial unaligned dcl 3-11
QLetterU_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterV                               internal static char(1)                  initial unaligned dcl 3-11
QLetterV_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterW                               internal static char(1)                  initial unaligned dcl 3-11
QLetterW_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterX                               internal static char(1)                  initial unaligned dcl 3-11
QLetterX_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterY                               internal static char(1)                  initial unaligned dcl 3-11
QLetterY_                              internal static char(1)                  initial unaligned dcl 3-11
QLetterZ                               internal static char(1)                  initial unaligned dcl 3-11
QLetterZ_                              internal static char(1)                  initial unaligned dcl 3-11
QLineFeed                              internal static char(1)                  initial unaligned dcl 3-11
QMarkError                             internal static char(1)                  initial unaligned dcl 3-11
QMinus                                 internal static char(1)                  initial unaligned dcl 3-11
QNandSign                              internal static char(1)                  initial unaligned dcl 3-11
QNine                                  internal static char(1)                  initial unaligned dcl 3-11
QNine_                                 internal static char(1)                  initial unaligned dcl 3-11
QNorSign                               internal static char(1)                  initial unaligned dcl 3-11
QNotEqual                              internal static char(1)                  initial unaligned dcl 3-11
QOmega                                 internal static char(1)                  initial unaligned dcl 3-11
QOne                                   internal static char(1)                  initial unaligned dcl 3-11
QOne_                                  internal static char(1)                  initial unaligned dcl 3-11
QOrSign                                internal static char(1)                  initial unaligned dcl 3-11
QPeriod                                internal static char(1)                  initial unaligned dcl 3-11
QPlus                                  internal static char(1)                  initial unaligned dcl 3-11
QQuad                                  internal static char(1)                  initial unaligned dcl 3-11
QQuadQuote                             internal static char(1)                  initial unaligned dcl 3-11
QQuestion                              internal static char(1)                  initial unaligned dcl 3-11
QRho                                   internal static char(1)                  initial unaligned dcl 3-11
QRightArrow                            internal static char(1)                  initial unaligned dcl 3-11
QRightBrace                            internal static char(1)                  initial unaligned dcl 3-11
QRightBracket                          internal static char(1)                  initial unaligned dcl 3-11
QRightLump                             internal static char(1)                  initial unaligned dcl 3-11
QRightParen                            internal static char(1)                  initial unaligned dcl 3-11
QRightTack                             internal static char(1)                  initial unaligned dcl 3-11
QSemiColon                             internal static char(1)                  initial unaligned dcl 3-11
QSeven                                 internal static char(1)                  initial unaligned dcl 3-11
QSeven_                                internal static char(1)                  initial unaligned dcl 3-11
QSix                                   internal static char(1)                  initial unaligned dcl 3-11
QSix_                                  internal static char(1)                  initial unaligned dcl 3-11
QSlash                                 internal static char(1)                  initial unaligned dcl 3-11
QSlashHyphen                           internal static char(1)                  initial unaligned dcl 3-11
QSmallCircle                           internal static char(1)                  initial unaligned dcl 3-11
QSpace                                 internal static char(1)                  initial unaligned dcl 3-11
QStar                                  internal static char(1)                  initial unaligned dcl 3-11
QTab                                   internal static char(1)                  initial unaligned dcl 3-11
QThree                                 internal static char(1)                  initial unaligned dcl 3-11
QThree_                                internal static char(1)                  initial unaligned dcl 3-11
QTilde                                 internal static char(1)                  initial unaligned dcl 3-11
QTimes                                 internal static char(1)                  initial unaligned dcl 3-11
QTwo                                   internal static char(1)                  initial unaligned dcl 3-11
QTwo_                                  internal static char(1)                  initial unaligned dcl 3-11
QUnderLine                             internal static char(1)                  initial unaligned dcl 3-11
QUpArrow                               internal static char(1)                  initial unaligned dcl 3-11
QVerticalBar                           internal static char(1)                  initial unaligned dcl 3-11
QZero                                  internal static char(1)                  initial unaligned dcl 3-11
QZero_                                 internal static char(1)                  initial unaligned dcl 3-11
complex_datum                          based           complex float bin(63)    array dcl 7-26
complex_value_type                     internal static bit(18)                  initial unaligned dcl 2-30
function_type                          internal static bit(18)                  initial unaligned dcl 2-30
group_type                             internal static bit(18)                  initial unaligned dcl 2-30
integral_value_type                    internal static bit(18)                  initial unaligned dcl 2-30
label_type                             internal static bit(18)                  initial unaligned dcl 2-30
lexed_function_type                    internal static bit(18)                  initial unaligned dcl 2-30
list_value_type                        internal static bit(18)                  initial unaligned dcl 2-30
max_parse_stack_depth                  internal static fixed bin(17,0)          initial dcl 8-98
n_members                              automatic       fixed bin(17,0)          dcl 4-3
not_integer_mask                       internal static bit(18)                  initial unaligned dcl 2-30
not_zero_or_one_mask                   internal static bit(18)                  initial unaligned dcl 2-30
numeric_datum                          based           float bin(63)            array dcl 7-23
numeric_value_type                     internal static bit(18)                  initial unaligned dcl 2-30
operator_type                          internal static bit(18)                  initial unaligned dcl 2-30
shared_variable_type                   internal static bit(18)                  initial unaligned dcl 2-30
symbol_type                            internal static bit(18)                  initial unaligned dcl 2-30
value_type                             internal static bit(18)                  initial unaligned dcl 2-30
zero_or_one_value_type                 internal static bit(18)                  initial unaligned dcl 2-30

NAMES DECLARED BY EXPLICIT CONTEXT.
apl_dyadic_format_              000454 constant        entry                    external dcl 174
apl_flush_buffer_               002506 constant        entry                    external dcl 668
apl_flush_buffer_nl_            002541 constant        entry                    external dcl 678
apl_monadic_format_             000442 constant        entry                    external dcl 44
apl_print_newline_              002575 constant        entry                    external dcl 689
apl_print_string_               002632 constant        entry                    external dcl 702
apl_print_value_                000603 constant        entry                    external dcl 229 ref 258
apl_push_stack_                 004437 constant        entry                    internal dcl 9-4 ref 208 352 367 559 647
append_any_char                 003010 constant        entry                    internal dcl 770 ref 278 283 304
append_newline                  003102 constant        entry                    internal dcl 829 ref 300 319 596 617 683 694 721 802
                                                                                  1223 1265
case                            000000 constant        label                    array(0:2) dcl 959 ref 957
clean_up                        003123 constant        entry                    internal dcl 845 ref 274 671 681 692 715
compute_blank_rows              003136 constant        entry                    internal dcl 856 ref 316 614
domain_error_left               002751 constant        label                    dcl 744 ref 181 463 469 488 494
domain_error_right              002755 constant        label                    dcl 747 set ref 197 215 1078
end_case                        004051 constant        label                    dcl 1075 ref 1012 1028
flush_buffer                    003175 constant        entry                    internal dcl 876 ref 673 684 724 733 817 832 1092
                                                                                  1226 1267
format_value                    003226 constant        entry                    internal dcl 903 ref 569 578 600
integerize                      004154 constant        entry                    internal dcl 1125 ref 460 461 467 485 486 492
join                            000501 constant        label                    dcl 191 ref 172
join2                           001075 constant        label                    dcl 338 ref 227
length_error                    002765 constant        label                    dcl 752 ref 218 218
min_field_width                 004175 constant        entry                    internal dcl 1149 ref 472 497 531
not_within_int_fuzz_left        002773 constant        label                    dcl 756 ref 1142
print_value_epilogue            004346 constant        entry                    internal dcl 1220 ref 261 324 627
rank_error_left                 003002 constant        label                    dcl 761 ref 184
simple_log10                    004362 constant        entry                    internal dcl 1233 ref 513 513 1204
vector_overflow                 004414 constant        entry                    internal dcl 1262 ref 814 1088

THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION.

STORAGE REQUIREMENTS FOR THIS PROGRAM.

	Object	Text	Link	Symbol	Defs	Static
Start          0       0      5174        5240    4655        5204
Length      5654    4655        44         400     316           0

BLOCK NAME	         STACK SIZE     TYPE		WHY NONQUICK/WHO SHARES STACK FRAME
apl_monadic_format_                 464 external procedure  is an external procedure.  
on unit on line 274                  64 on unit               
begin block on line 438                 begin block         shares stack frame of external procedure apl_monadic_format_.  
on unit on line 671                  64 on unit               
on unit on line 681                  64 on unit               
on unit on line 692                  64 on unit               
on unit on line 715                  64 on unit               
append_any_char                         internal procedure  shares stack frame of external procedure apl_monadic_format_.  
append_newline                          internal procedure  shares stack frame of external procedure apl_monadic_format_.  
clean_up                             64 internal procedure  is called by several nonquick procedures.  
compute_blank_rows                      internal procedure  shares stack frame of external procedure apl_monadic_format_.  
flush_buffer                            internal procedure  shares stack frame of external procedure apl_monadic_format_.  
format_value                            internal procedure  shares stack frame of external procedure apl_monadic_format_.  
integerize                              internal procedure  shares stack frame of external procedure apl_monadic_format_.  
min_field_width                         internal procedure  shares stack frame of external procedure apl_monadic_format_.  
print_value_epilogue                    internal procedure  shares stack frame of external procedure apl_monadic_format_.  
simple_log10                            internal procedure  shares stack frame of external procedure apl_monadic_format_.  
vector_overflow                         internal procedure  shares stack frame of external procedure apl_monadic_format_.  
apl_push_stack_                         internal procedure  shares stack frame of external procedure apl_monadic_format_.  

STORAGE FOR AUTOMATIC VARIABLES.

STACK FRAME                 LOC IDENTIFIER                  BLOCK NAME
apl_monadic_format_      000100 fmt_info_ptr                apl_monadic_format_
                         000102 check_if_column_fuzz_integral
                                                            apl_monadic_format_
                         000103 column_base                 apl_monadic_format_
                         000104 column_length               apl_monadic_format_
                         000105 column_top                  apl_monadic_format_
                         000106 colx                        apl_monadic_format_
                         000107 current_rho_value           apl_monadic_format_
                         000110 data_elements               apl_monadic_format_
                         000111 dyadic                      apl_monadic_format_
                         000112 float_temp                  apl_monadic_format_
                         000114 format                      apl_monadic_format_
                         000115 interval_between_elements   apl_monadic_format_
                         000116 interval_between_planes     apl_monadic_format_
                         000120 largest_possible_value      apl_monadic_format_
                         000122 left_pos                    apl_monadic_format_
                         000124 left                        apl_monadic_format_
                         000126 left_data_elements          apl_monadic_format_
                         000130 left_vb                     apl_monadic_format_
                         000132 listx                       apl_monadic_format_
                         000133 n_cols                      apl_monadic_format_
                         000134 n_lines                     apl_monadic_format_
                         000135 n_words                     apl_monadic_format_
                         000136 plane_base                  apl_monadic_format_
                         000137 pseudo_column_length        apl_monadic_format_
                         000140 result                      apl_monadic_format_
                         000142 result_cols                 apl_monadic_format_
                         000143 result_data_elements        apl_monadic_format_
                         000144 result_pos                  apl_monadic_format_
                         000146 result_vb                   apl_monadic_format_
                         000150 rhox                        apl_monadic_format_
                         000152 right                       apl_monadic_format_
                         000154 right_data_elements         apl_monadic_format_
                         000156 right_rho_ptr               apl_monadic_format_
                         000160 right_rhorho                apl_monadic_format_
                         000162 right_vb                    apl_monadic_format_
                         000164 round_buffer                apl_monadic_format_
                         000172 temp_result                 apl_monadic_format_
                         000174 valx                        apl_monadic_format_
                         000204 number_of_dimensions        apl_monadic_format_
                         000206 ws_info_ptr                 apl_monadic_format_
                         000210 need_nl                     apl_monadic_format_
                         000211 n_pads                      apl_monadic_format_
                         000227 precision_temp              begin block on line 438
                         000230 type_temp                   begin block on line 438
                         000231 width_temp                  begin block on line 438
                         000232 precision_temp_fl           begin block on line 438
                         000234 width_temp_fl               begin block on line 438
                         000246 delta                       append_any_char
                         000272 code                        flush_buffer
                         000302 char_value                  format_value
                         000322 decimal_value               format_value
                         000330 exponent                    format_value
                         000331 exponent_picture            format_value
                         000332 field_width                 format_value
                         000333 fixed_picture               format_value
                         000364 integer_picture             format_value
                         000376 integer_value               format_value
                         000403 n_leading_blanks            format_value
                         000404 new_value_width             format_value
                         000405 precision                   format_value
                         000406 scientific_picture          format_value
                         000413 start_pos                   format_value
                         000414 type                        format_value
                         000415 value_width                 format_value
                         000424 trial_val                   integerize
                         000434 decimal_value               min_field_width
                         000442 min_width                   min_field_width
                         000444 rounded_value               min_field_width
                         000462 result                      simple_log10
                         000464 value                       simple_log10
                         000504 block_ptr                   apl_push_stack_
                         000506 num_words                   apl_push_stack_

THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM.
r_g_a               r_e_as              r_le_a              alloc_cs            call_ext_in         call_ext_out
call_int_other      return              fl2_to_fx1          sign                bound_check_signal  mod_fx1
enable              shorten_stack       ext_entry           ext_entry_desc      int_entry           floor_fl
real_to_real_rd     trunc_dec

THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM.
apl_format_util_$round        apl_format_util_$round_fixed  apl_format_util_$round_fixed  apl_format_util_$split
apl_get_value_stack_          apl_system_error_             iox_$put_chars

THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM.
apl_error_table_$domain       apl_error_table_$length       apl_error_table_$no_type_bits
apl_error_table_$not_within_int_fuzz                        apl_error_table_$rank         apl_static_$apl_output
apl_static_$ws_info_ptr




   LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC   
 8    7 000432        44 000437       171 000450       172 000451       174 000452       177 000462       178 000465
    179 000467       181 000471       184 000474       187 000477       191 000501       193 000503       194 000507
    195 000511       197 000513       201 000520       203 000523       204 000524       207 000525       208 000530
    209 000532       210 000540       211 000546       212 000547       213 000552       215 000553       218 000556
    227 000576       229 000577       250 000611       252 000620       255 000624       257 000627       258 000637
    259 000656       261 000660       262 000661       265 000662       268 000674       271 000706       272 000711
    274 000714       276 000736       278 000741       280 000754       282 000756       283 000765       284 000774
    285 000776       287 000777       288 001001       289 001005       293 001007       294 001011       295 001012
    297 001017       298 001024       300 001026       301 001027       304 001030       305 001040       307 001041
    309 001044       310 001046       312 001050       316 001052       318 001053       319 001063       320 001064
    321 001066       324 001071       325 001072       328 001073       329 001074       338 001075       341 001104
    343 001107       345 001111       346 001121       347 001126       351 001130       352 001134       360 001136
    362 001140       364 001143       366 001152       367 001153       368 001155       369 001201       370 001202
    377 001204       379 001207       380 001211       382 001213       383 001223       385 001230       387 001232
    389 001234       391 001235       392 001237       393 001241       395 001242       396 001245       398 001247
    399 001257       400 001265       401 001267       402 001270       403 001272       404 001277       405 001302
    407 001310       408 001315       411 001326       413 001342       415 001351       419 001370       421 001373
    422 001401       424 001406       427 001417       429 001421       432 001423       438 001434       450 001442
    452 001446       453 001450       454 001452       456 001453       457 001455       460 001460       461 001466
    463 001473       467 001506       469 001513       472 001516       475 001537       476 001547       477 001554
    478 001561       479 001566       438 001570       482 001571       483 001572       484 001601       485 001607
    486 001622       488 001627       492 001642       494 001657       497 001663       505 001710       506 001712
    507 001714       508 001715       510 001720       512 001725       513 001735       518 002010       519 002015
    520 002020       521 002021       523 002026       524 002031       525 002032       527 002033       528 002036
    531 002041       536 002065       537 002067       538 002070       539 002077       540 002104       541 002105
    542 002107       551 002111       553 002117       555 002140       557 002142       558 002146       559 002151
    560 002153       565 002155       567 002160       568 002162       569 002163       571 002176       573 002203
    574 002204       576 002206       577 002213       578 002215       579 002236       581 002240       583 002245
    585 002246       586 002250       590 002252       591 002254       592 002255       593 002261       594 002266
    596 002270       597 002271       600 002272       602 002303       603 002304       605 002307       606 002311
    608 002314       612 002316       614 002320       616 002321       617 002331       618 002332       620 002334
    625 002337       627 002341       628 002342       629 002345       632 002346       634 002357       636 002366
    641 002371       643 002376       645 002377       646 002402       647 002411       648 002413       649 002416
    651 002421       654 002436       656 002461       658 002464       659 002466       660 002473       661 002474
    663 002501       664 002504       668 002505       671 002514       673 002536       674 002537       678 002540
    681 002547       683 002571       684 002572       685 002573       689 002574       692 002603       694 002625
    695 002626       702 002627       715 002646       717 002670       719 002673       721 002701       724 002707
    727 002714       728 002724       729 002725       733 002726       736 002734       737 002746       738 002747
    739 002750       744 002751       747 002755       749 002761       750 002764       752 002765       754 002772
    756 002773       758 002776       759 003001       761 003002       763 003004       764 003007       770 003010
    800 003012       802 003021       803 003022       806 003023       808 003033       811 003046       814 003053
    817 003060       820 003065       821 003076       822 003077       823 003101       829 003102       832 003103
    835 003110       836 003117       837 003120       838 003121       845 003122       848 003130       849 003134
    851 003135       856 003136       859 003137       860 003142       861 003144       864 003161       865 003164
    866 003165       868 003170       871 003174       876 003175       894 003176       895 003222       897 003225
    903 003226       951 003230       952 003235       953 003240       955 003242       957 003254       959 003256
    963 003274       965 003311       966 003315       968 003325       970 003336       972 003337       974 003342
    975 003351       976 003352       977 003353       979 003357       981 003371       984 003377       985 003411
    987 003414       989 003415       990 003431       993 003432       995 003441       997 003453       999 003454
   1001 003460      1002 003467      1003 003470      1004 003471      1006 003503      1009 003527      1010 003531
   1012 003533      1014 003534      1018 003553      1020 003562      1022 003573      1024 003574      1025 003605
   1026 003607      1028 003627      1030 003630      1034 003646      1036 003657      1038 003660      1040 003667
   1044 003715      1046 003720      1048 003722      1049 003733      1053 003735      1055 003742      1057 003746
   1058 003762      1061 003771      1063 004004      1066 004006      1069 004031      1070 004033      1072 004035
   1073 004036      1075 004051      1078 004053      1081 004055      1084 004062      1086 004065      1088 004067
   1092 004075      1096 004104      1098 004106      1099 004115      1102 004116      1103 004127      1105 004130
   1106 004132      1108 004133      1110 004135      1111 004142      1114 004143      1115 004152      1118 004153
   1125 004154      1138 004156      1139 004162      1142 004174      1149 004175      1173 004177      1175 004210
   1177 004211      1179 004213      1181 004215      1183 004217      1185 004222      1187 004223      1188 004233
   1190 004247      1192 004256      1194 004266      1196 004301      1198 004315      1204 004325      1210 004337
   1214 004342      1220 004346      1223 004347      1226 004354      1229 004361      1233 004362      1247 004364
   1249 004366      1252 004373      1253 004406      1255 004410      1262 004414      1265 004415      1267 004416
   1270 004424      1271 004433      1272 004435      1273 004436    9    4 004437    9   35 004441    9   37 004443
 9   40 004450    9   43 004465    9   44 004470    9   45 004477


                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL
and BULL HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture 
for managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by BULL HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved