



		    basic_file_name_.alm            11/18/82  1708.9rew 11/18/82  1631.6        7029



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" This program does nothing.  It exists so that basic_runtime_ can
"	call basic_file_name_(file_name)
" thus giving the Student Basic System a chance to change the
" file name by providing a replacement for this routine
"
	segdef	basic_file_name_
basic_file_name_:
	short_return
	end




		    basic_find_proc_.pl1            09/11/84  1252.9rew 09/11/84  1223.8       26532



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* Procedure to find subprogram for basic

   Initial Version: 21 October 1973 by BLW */
/* modified 12/75 by M. Weaver for FAST */

/* format: style2 */

basic_find_proc_:
     proc (bo_stack_pt);

	dcl     bo_stack_pt		 ptr;

	dcl     based_vs		 char (168) based varying,
	        (path, dir)		 char (168),
	        (seg, ent)		 char (32),
	        n			 fixed bin,
	        bo_pt		 ptr;

	dcl     (addr, index, length, null, search, substr)
				 builtin;

	dcl     fast_related_data_$in_dfast
				 bit (1) aligned ext;
	dcl     fast_related_data_$in_fast_or_dfast
				 bit (1) aligned ext;

	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35)),
	        dfast_run_unit_manager_$find_entry_value
				 entry (char (32), ptr, fixed bin (35)),
	        fast_run_unit_manager_$find_entry_value
				 entry (char (32), ptr, fixed bin (35)),
	        hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)),
	        expand_path_	 entry (ptr, fixed bin, ptr, ptr, fixed bin (35));

%include basic_operator_frame;

	bo_pt = bo_stack_pt;

	if search (pr (1) -> based_vs, "<>") ^= 0
	then do;

/* We have a path name, attempt to initiate specified segment */

		if fast_related_data_$in_fast_or_dfast
		then do;				/* don't allow pathnames in fast */
			pr (2) = null;
			return;
		     end;

		path = pr (1) -> based_vs;

		call expand_path_ (addr (path), length (pr (1) -> based_vs), addr (dir), addr (seg), q_reg);

		if q_reg ^= 0
		then return;

		call hcs_$initiate_count (dir, seg, seg, n, 1, pr (2), q_reg);

		if pr (2) = null
		then return;

		n = index (seg, "$");

		if n = 0
		then ent = seg;
		else do;
			ent = substr (seg, n + 1);
			substr (seg, n) = "";
		     end;
	     end;
	else do;

/* not a path name */

		n = index (pr (1) -> based_vs, "$");

		if n = 0
		then do;
			seg = pr (1) -> based_vs;
			ent = pr (1) -> based_vs;
		     end;
		else do;
			if fast_related_data_$in_fast_or_dfast
			then do;
				pr (2) = null;
				return;
			     end;
			seg = substr (pr (1) -> based_vs, 1, n - 1);
			ent = substr (pr (1) -> based_vs, n + 1);
		     end;
	     end;

	if fast_related_data_$in_dfast
	then call dfast_run_unit_manager_$find_entry_value (ent, pr (2), q_reg);
	else if fast_related_data_$in_fast_or_dfast
	then call fast_run_unit_manager_$find_entry_value (ent, pr (2), q_reg);
	else call hcs_$make_ptr (null, seg, ent, pr (2), q_reg);
     end;




		    basic_matrix_.pl1               09/11/84  1252.9rew 09/11/84  1223.8       82755



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/* format: style2 */

basic_matrix_:
     proc (bo_stack_pt);

/* modified 5/77 by Melanie Weaver  to increase internal precision */

	dcl     (bo_stack_pt, bo_pt, sink_pt, source_pt, p1, p2, p3)
				 ptr,
	        copy		 bit (1) aligned,
	        t			 float bin (63),
	        accuracy		 float bin (63) static,
	        (i, j, k, m, n, p, row_max, col_max)
				 fixed bin;

	dcl     (abs, addr, hbound, max, min)
				 builtin;

	dcl     basic_matrix_double_	 entry (ptr);

	dcl     string_area		 area (65536) based (string_segment);

	dcl     C			 (0:row_max, 0:col_max) float bin based,
	        C_transpose		 (0:col_max, 0:row_max) float bin based;

	dcl     vector_m		 (0:m) float bin based,
	        vector_n		 (0:n) float bin based,
	        vector_p		 (0:p) float bin based,
	        matrix_mn		 (0:m, 0:n) float bin based,
	        matrix_mp		 (0:m, 0:p) float bin based,
	        matrix_pn		 (0:p, 0:n) float bin based;

%include basic_operator_frame;
%include basic_symbols;

	bo_pt = bo_stack_pt;
	if precision_lng ^= 1
	then do;
		call basic_matrix_double_ (bo_stack_pt);
		return;
	     end;
	goto switch (q_reg);

/* inverse */

switch (1):
	row_max = pr (2) -> current_bounds (1) - 1;
	if row_max <= 0
	then goto array_error;

	begin;

	     dcl	   space		      (row_max * row_max),
		   LU		      (row_max, row_max) float bin (63) aligned based (addr (space));

	     dcl	   P		      (100) fixed bin,
		   (B, X, R, DX, scales)  dim (100) float bin (63),
		   (i, j, e, k, pividx)   fixed bin,
		   (ajj, norm_row, biggest, size, multiplier, pivot)
				      float bin (63);

	     dcl	   (
		   scale_factor	      init (1.0e6),
		   maxval		      init (1.0e6),
		   minval		      init (1.0e-6)
		   )		      float bin static;

	     dcl	   (ap, ainvp)	      ptr;

	     dcl	   A		      (0:row_max, 0:row_max) float bin based (ap),
		   A_inverse	      (0:row_max, 0:row_max) float bin based (ainvp);

	     if row_max > hbound (P, 1)
	     then goto array_error;

	     ap = pr (1) -> array_dope.data;

	     if pr (1) ^= pr (2)
	     then ainvp = pr (2) -> array_dope.data;
	     else allocate A_inverse in (string_area);

/* Initialize LU decomposition */

	     do i = 1 to row_max;
		P (i) = i;
		norm_row = 0.0e0;

		do j = 1 to row_max;
		     LU (i, j) = A (i, j);
		     norm_row = max (norm_row, abs (LU (i, j)));
		end;

		if norm_row = 0.0e0
		then goto singular;

		scales (i) = 1.0 / norm_row;
	     end;

/* Perform Gaussian elimination with partial pivoting and scaling */

	     determinant = 1.0e0;

	     do k = 1 to row_max - 1;
		biggest = 0.0e0;

		do i = k to row_max;
		     size = abs (LU (P (i), k)) * scales (P (i));

		     if size > biggest
		     then do;
			     biggest = size;
			     pividx = i;
			end;
		end;

		if biggest = 0.0e0
		then goto singular;

		if pividx ^= k
		then do;

/* Change sign of determinant and interchange
		        permutation elements */

			determinant = -determinant;

			j = P (k);
			P (k) = P (pividx);
			P (pividx) = j;
		     end;

		pivot = LU (P (k), k);

		do i = k + 1 to row_max;
		     LU (P (i), k), multiplier = LU (P (i), k) / pivot;

		     if multiplier ^= 0.0e0
		     then do j = k + 1 to row_max;
			     LU (P (i), j) = LU (P (i), j) - multiplier * LU (P (k), j);
			end;
		end;

	     end;

	     if LU (P (row_max), row_max) = 0
	     then goto singular;

/* Determine inverse and compute determinant */

	     e = 0;
	     do j = 1 to row_max;

		do i = 1 to row_max;
		     B (i) = 0;
		end;

		B (j) = 1.0e0;

/* Solve AX = B for X */

		call solve (X, B);

/* Improve the solution */

		call improve;

/* Solution is column j of inverse */

		do i = 1 to row_max;
		     A_inverse (i, j) = X (i);
		end;

		ajj = LU (P (j), j);

		if abs (determinant) > maxval / max (ajj, 1.0e0)
		then do;
			e = e + 1;
			determinant = determinant / scale_factor;
		     end;

		if abs (determinant) < minval / min (ajj, 1.0e0)
		then do;
			e = e - 1;
			determinant = determinant * scale_factor;
		     end;

		determinant = determinant * ajj;
	     end;

/* Correct exponent of determinant */

	     do i = 1 to e by +1;
		determinant = determinant * scale_factor;
	     end;

	     do i = -1 to e by -1;
		determinant = determinant / scale_factor;
	     end;

/* ALL THRU */

	     goto inverse_done;

solve:
     proc (X, B);

	dcl     (B, X)		 dim (100) float bin (63),
	        dot		 float bin (63),
	        (i, j)		 fixed bin;

	do i = 1 to row_max;
	     dot = 0.0e0;

	     do j = 1 to i - 1;
		dot = dot + LU (P (i), j) * X (j);
	     end;

	     X (i) = B (P (i)) - dot;
	end;

	do i = row_max by -1 to 1;
	     dot = 0.0e0;

	     do j = i + 1 to row_max;
		dot = dot + LU (P (i), j) * X (j);
	     end;

	     X (i) = (X (i) - dot) / LU (P (i), i);
	end;

     end;

improve:
     proc;

	dcl     (i, j, iterations)	 fixed binary,
	        (norm_x, norm_dx, t)	 float bin (63),
	        dot		 float bin (63);	/* MUST BE DOUBLE PRECISION */

	dcl     max_iterations	 float bin static init (16),
						/* about 2*log10(epsilon) */
	        epsilon		 float bin static init (1e-8);

	norm_x = 0.0e0;

	do i = 1 to row_max;
	     norm_x = max (norm_x, abs (X (i)));
	end;

	if norm_x = 0.0e0
	then do;
		accuracy = epsilon;
		return;
	     end;

	do iterations = 1 to max_iterations;
	     do i = 1 to row_max;

		dot = 0.0e0;

		do j = 1 to row_max;
		     dot = dot + A (i, j) * X (j);
		end;

		R (i) = B (i) - dot;
	     end;

	     call solve (DX, R);

	     norm_dx = 0.0e0;

	     do i = 1 to row_max;
		t = X (i);
		X (i) = X (i) + DX (i);
		norm_dx = max (norm_dx, abs (X (i) - t));
	     end;

	     if iterations = 1
	     then accuracy = max (norm_dx / norm_x, epsilon);

	     if norm_dx <= epsilon * norm_x
	     then return;
	end;

	goto singular;
     end;

singular:
	     determinant = 0.0e0;

inverse_done:
	     if pr (1) = pr (2)
	     then do;
		     pr (2) -> array_dope.data -> A_inverse = A_inverse;
		     free A_inverse in (string_area);
		end;
	end;

	q_reg = 0;
	return;

/* transpose */

switch (2):
	row_max = pr (2) -> current_bounds (1) - 1;
	if row_max <= 0
	then goto array_error;

	col_max = pr (2) -> current_bounds (2) - 1;
	if col_max <= 0
	then goto array_error;

	source_pt = pr (1) -> array_dope.data;

	if pr (1) ^= pr (2)
	then sink_pt = pr (2) -> array_dope.data;
	else allocate C set (sink_pt) in (string_area);

	do i = 1 to row_max;
	     do j = 1 to col_max;
		sink_pt -> C (i, j) = source_pt -> C_transpose (j, i);
	     end;
	end;

	if pr (1) = pr (2)
	then do;
		pr (2) -> array_dope.data -> C = sink_pt -> C;
		free sink_pt -> C in (string_area);
	     end;

	q_reg = 0;
	return;

/* vector (1 x n) = vector (1 x p) * matrix (p x n) */

switch (3):
	p = pr (3) -> array_dope.current_bounds (1) - 1;
	n = pr (3) -> array_dope.current_bounds (2) - 1;

	call get_matrix_pointers;

	if copy
	then allocate vector_n set (p2) in (string_area);

	do j = 1 to n;
	     t = 0.0e0;

	     do k = 1 to p;
		t = t + p1 -> vector_p (k) * p3 -> matrix_pn (k, j);
	     end;

	     p2 -> vector_n (j) = t;
	end;

	if copy
	then do;
		pr (2) -> array_dope.data -> vector_n = p2 -> vector_n;
		free p2 -> vector_n in (string_area);
	     end;

	q_reg = 0;
	return;

/* vector (m x 1) = matrix (m x p) * vector (p x 1) */

switch (4):
	m = pr (1) -> array_dope.current_bounds (1) - 1;
	p = pr (1) -> array_dope.current_bounds (2) - 1;

	call get_matrix_pointers;

	if copy
	then allocate vector_m set (p2) in (string_area);

	do i = 1 to m;
	     t = 0.0e0;

	     do k = 1 to p;
		t = t + p1 -> matrix_mp (i, k) * p3 -> vector_p (k);
	     end;

	     p2 -> vector_m (i) = t;
	end;

	if copy
	then do;
		pr (2) -> array_dope.data -> vector_m = p2 -> vector_m;
		free p2 -> vector_m in (string_area);
	     end;

	q_reg = 0;
	return;

/* matrix (m x n) = matrix (m x p) * matrix (p x n) */

switch (5):
	m = pr (2) -> array_dope.current_bounds (1) - 1;
	n = pr (2) -> array_dope.current_bounds (2) - 1;
	p = pr (1) -> array_dope.current_bounds (2) - 1;

	call get_matrix_pointers;

	if copy
	then allocate matrix_mn set (p2) in (string_area);
	do i = 1 to m;
	     do j = 1 to n;
		t = 0.0e0;

		do k = 1 to p;
		     t = t + p1 -> matrix_mp (i, k) * p3 -> matrix_pn (k, j);
		end;

		p2 -> matrix_mn (i, j) = t;
	     end;
	end;

	if copy
	then do;
		pr (2) -> array_dope.data -> matrix_mn = p2 -> matrix_mn;
		free p2 -> matrix_mn in (string_area);
	     end;

	q_reg = 0;
	return;

/* errors */

array_error:
	q_reg = 139;

get_matrix_pointers:
     proc;

	p1 = pr (1) -> array_dope.data;
	p3 = pr (3) -> array_dope.data;

	copy = (pr (1) = pr (2)) | (pr (3) = pr (2));

	if ^copy
	then p2 = pr (2) -> array_dope.data;

     end;

     end;




		    basic_matrix_double_.pl1        09/11/84  1252.9rew 09/11/84  1223.8       81432



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/* format: style2 */

basic_matrix_double_:
     proc (bo_stack_pt);

	dcl     (bo_stack_pt, bo_pt, sink_pt, source_pt, p1, p2, p3)
				 ptr,
	        copy		 bit (1) aligned,
	        t			 float bin (63),
	        accuracy		 float bin (63) static,
	        (i, j, k, m, n, p, row_max, col_max)
				 fixed bin;

	dcl     (abs, addr, hbound, max, min)
				 builtin;

	dcl     string_area		 area (65536) based (string_segment);

	dcl     C			 (0:row_max, 0:col_max) float bin (63) based,
	        C_transpose		 (0:col_max, 0:row_max) float bin (63) based;

	dcl     vector_m		 (0:m) float bin (63) based,
	        vector_n		 (0:n) float bin (63) based,
	        vector_p		 (0:p) float bin (63) based,
	        matrix_mn		 (0:m, 0:n) float bin (63) based,
	        matrix_mp		 (0:m, 0:p) float bin (63) based,
	        matrix_pn		 (0:p, 0:n) float bin (63) based;

%include basic_operator_frame;
%include basic_symbols;

	bo_pt = bo_stack_pt;
	goto switch (q_reg);

/* inverse */

switch (1):
	row_max = pr (2) -> current_bounds (1) - 1;
	if row_max <= 0
	then goto array_error;

	begin;

	     dcl	   space		      (row_max * row_max * 2),
		   LU		      (row_max, row_max) float bin (63) aligned based (addr (space));

	     dcl	   P		      (100) fixed bin,
		   (B, X, R, DX, scales)  dim (100) float bin (63),
		   (i, j, e, k, pividx)   fixed bin,
		   (ajj, norm_row, biggest, size, multiplier, pivot)
				      float bin (63);

	     dcl	   (
		   scale_factor	      init (1.0e6),
		   maxval		      init (1.0e6),
		   minval		      init (1.0e-6)
		   )		      float bin (63) static;

	     dcl	   (ap, ainvp)	      ptr;

	     dcl	   A		      (0:row_max, 0:row_max) float bin (63) based (ap),
		   A_inverse	      (0:row_max, 0:row_max) float bin (63) based (ainvp);

	     if row_max > hbound (P, 1)
	     then goto array_error;

	     ap = pr (1) -> array_dope.data;

	     if pr (1) ^= pr (2)
	     then ainvp = pr (2) -> array_dope.data;
	     else allocate A_inverse in (string_area);

/* Initialize LU decomposition */

	     do i = 1 to row_max;
		P (i) = i;
		norm_row = 0.0e0;

		do j = 1 to row_max;
		     LU (i, j) = A (i, j);
		     norm_row = max (norm_row, abs (LU (i, j)));
		end;

		if norm_row = 0.0e0
		then goto singular;

		scales (i) = 1.0 / norm_row;
	     end;

/* Perform Gaussian elimination with partial pivoting and scaling */

	     determinant = 1.0e0;

	     do k = 1 to row_max - 1;
		biggest = 0.0e0;

		do i = k to row_max;
		     size = abs (LU (P (i), k)) * scales (P (i));

		     if size > biggest
		     then do;
			     biggest = size;
			     pividx = i;
			end;
		end;

		if biggest = 0.0e0
		then goto singular;

		if pividx ^= k
		then do;

/* Change sign of determinant and interchange
		        permutation elements */

			determinant = -determinant;

			j = P (k);
			P (k) = P (pividx);
			P (pividx) = j;
		     end;

		pivot = LU (P (k), k);

		do i = k + 1 to row_max;
		     LU (P (i), k), multiplier = LU (P (i), k) / pivot;

		     if multiplier ^= 0.0e0
		     then do j = k + 1 to row_max;
			     LU (P (i), j) = LU (P (i), j) - multiplier * LU (P (k), j);
			end;
		end;

	     end;

	     if LU (P (row_max), row_max) = 0
	     then goto singular;

/* Determine inverse and compute determinant */

	     e = 0;
	     do j = 1 to row_max;

		do i = 1 to row_max;
		     B (i) = 0;
		end;

		B (j) = 1.0e0;

/* Solve AX = B for X */

		call solve (X, B);

/* Improve the solution */

		call improve;

/* Solution is column j of inverse */

		do i = 1 to row_max;
		     A_inverse (i, j) = X (i);
		end;

		ajj = LU (P (j), j);

		if abs (determinant) > maxval / max (ajj, 1.0e0)
		then do;
			e = e + 1;
			determinant = determinant / scale_factor;
		     end;

		if abs (determinant) < minval / min (ajj, 1.0e0)
		then do;
			e = e - 1;
			determinant = determinant * scale_factor;
		     end;

		determinant = determinant * ajj;
	     end;

/* Correct exponent of determinant */

	     do i = 1 to e by +1;
		determinant = determinant * scale_factor;
	     end;

	     do i = -1 to e by -1;
		determinant = determinant / scale_factor;
	     end;

/* ALL THRU */

	     goto inverse_done;

solve:
     proc (X, B);

	dcl     (B, X)		 dim (100) float bin (63),
	        dot		 float bin (63),
	        (i, j)		 fixed bin;

	do i = 1 to row_max;
	     dot = 0.0e0;

	     do j = 1 to i - 1;
		dot = dot + LU (P (i), j) * X (j);
	     end;

	     X (i) = B (P (i)) - dot;
	end;

	do i = row_max by -1 to 1;
	     dot = 0.0e0;

	     do j = i + 1 to row_max;
		dot = dot + LU (P (i), j) * X (j);
	     end;

	     X (i) = (X (i) - dot) / LU (P (i), i);
	end;

     end;

improve:
     proc;

	dcl     (i, j, iterations)	 fixed binary,
	        (norm_x, norm_dx, t)	 float bin (63),
	        dot		 float bin (63);	/* MUST BE DOUBLE PRECISION */

	dcl     max_iterations	 float bin static init (16),
						/* about 2*log10(epsilon) */
	        epsilon		 float bin static init (1e-8);

	norm_x = 0.0e0;

	do i = 1 to row_max;
	     norm_x = max (norm_x, abs (X (i)));
	end;

	if norm_x = 0.0e0
	then do;
		accuracy = epsilon;
		return;
	     end;

	do iterations = 1 to max_iterations;
	     do i = 1 to row_max;

		dot = 0.0e0;

		do j = 1 to row_max;
		     dot = dot + A (i, j) * X (j);
		end;

		R (i) = B (i) - dot;
	     end;

	     call solve (DX, R);

	     norm_dx = 0.0e0;

	     do i = 1 to row_max;
		t = X (i);
		X (i) = X (i) + DX (i);
		norm_dx = max (norm_dx, abs (X (i) - t));
	     end;

	     if iterations = 1
	     then accuracy = max (norm_dx / norm_x, epsilon);

	     if norm_dx <= epsilon * norm_x
	     then return;
	end;

	goto singular;
     end;

singular:
	     determinant = 0.0e0;

inverse_done:
	     if pr (1) = pr (2)
	     then do;
		     pr (2) -> array_dope.data -> A_inverse = A_inverse;
		     free A_inverse in (string_area);
		end;
	end;

	q_reg = 0;
	return;

/* transpose */

switch (2):
	row_max = pr (2) -> current_bounds (1) - 1;
	if row_max <= 0
	then goto array_error;

	col_max = pr (2) -> current_bounds (2) - 1;
	if col_max <= 0
	then goto array_error;

	source_pt = pr (1) -> array_dope.data;

	if pr (1) ^= pr (2)
	then sink_pt = pr (2) -> array_dope.data;
	else allocate C set (sink_pt) in (string_area);

	do i = 1 to row_max;
	     do j = 1 to col_max;
		sink_pt -> C (i, j) = source_pt -> C_transpose (j, i);
	     end;
	end;

	if pr (1) = pr (2)
	then do;
		pr (2) -> array_dope.data -> C = sink_pt -> C;
		free sink_pt -> C in (string_area);
	     end;

	q_reg = 0;
	return;

/* vector (1 x n) = vector (1 x p) * matrix (p x n) */

switch (3):
	p = pr (3) -> array_dope.current_bounds (1) - 1;
	n = pr (3) -> array_dope.current_bounds (2) - 1;

	call get_matrix_pointers;

	if copy
	then allocate vector_n set (p2) in (string_area);

	do j = 1 to n;
	     t = 0.0e0;

	     do k = 1 to p;
		t = t + p1 -> vector_p (k) * p3 -> matrix_pn (k, j);
	     end;

	     p2 -> vector_n (j) = t;
	end;

	if copy
	then do;
		pr (2) -> array_dope.data -> vector_n = p2 -> vector_n;
		free p2 -> vector_n in (string_area);
	     end;

	q_reg = 0;
	return;

/* vector (m x 1) = matrix (m x p) * vector (p x 1) */

switch (4):
	m = pr (1) -> array_dope.current_bounds (1) - 1;
	p = pr (1) -> array_dope.current_bounds (2) - 1;

	call get_matrix_pointers;

	if copy
	then allocate vector_m set (p2) in (string_area);

	do i = 1 to m;
	     t = 0.0e0;

	     do k = 1 to p;
		t = t + p1 -> matrix_mp (i, k) * p3 -> vector_p (k);
	     end;

	     p2 -> vector_m (i) = t;
	end;

	if copy
	then do;
		pr (2) -> array_dope.data -> vector_m = p2 -> vector_m;
		free p2 -> vector_m in (string_area);
	     end;

	q_reg = 0;
	return;

/* matrix (m x n) = matrix (m x p) * matrix (p x n) */

switch (5):
	m = pr (2) -> array_dope.current_bounds (1) - 1;
	n = pr (2) -> array_dope.current_bounds (2) - 1;
	p = pr (1) -> array_dope.current_bounds (2) - 1;

	call get_matrix_pointers;

	if copy
	then allocate matrix_mn set (p2) in (string_area);
	do i = 1 to m;
	     do j = 1 to n;
		t = 0.0e0;

		do k = 1 to p;
		     t = t + p1 -> matrix_mp (i, k) * p3 -> matrix_pn (k, j);
		end;

		p2 -> matrix_mn (i, j) = t;
	     end;
	end;

	if copy
	then do;
		pr (2) -> array_dope.data -> matrix_mn = p2 -> matrix_mn;
		free p2 -> matrix_mn in (string_area);
	     end;

	q_reg = 0;
	return;

/* errors */

array_error:
	q_reg = 139;

get_matrix_pointers:
     proc;

	p1 = pr (1) -> array_dope.data;
	p3 = pr (3) -> array_dope.data;

	copy = (pr (1) = pr (2)) | (pr (3) = pr (2));

	if ^copy
	then p2 = pr (2) -> array_dope.data;

     end;

     end;




		    basic_operator_names_.alm       09/11/84  1252.9rew 09/11/84  1223.8       41265



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
"
" Modified: 	15 May 1984 by DWL to document sst$ being used by mid$
" Modified:	22 May 1984 by DWL to include left$
" Modified:	23 May 1984 by DWL to include right$

	name	basic_operator_names_
	segdef	basic_operator_names_

basic_operator_names_:
	equ	first_n,0

first:
	zero	0,first_n
last:
	zero	0,first_n+last_normal-first_normal-1)
first_special:
	zero	0,0
last_special:
	zero	0,0
number_special:
	zero	0,0

	macro	normal
	use	text
	zero	s&2,&l1
	use	data
s&2:	aci	"&1"
	&end

	use	text
first_normal:
	normal	illegal,0
	normal	string_assign,1
	normal	string_concatenate,2
	normal	string_compare,3
	normal	len_fun,4
	normal	pos_fun,5
	normal	chr_fun,6
	normal	clk_fun,7
	normal	dat_fun,8
	normal	usr_fun,9
	normal	str_fun,10
	normal	seg_fun,11
	normal	mid_fun,12	"sst_fun is also 12 but mid_fun is more common
	normal	max_fun,13
	normal	min_fun,14
	normal	change_from_string,15
	normal	change_to_string,16
	normal	argcnt,17
	normal	argval,18
	normal	illegal,19
	normal	stop_op,20
	normal	on_op,21
	normal	gosub_op,22
	normal	on_gosub_op,23
	normal	sub_call_op,24
	normal	std_sub_call_op,25
	normal	return_op,26
	normal	sub_exit_op,27
	normal	fun_call_op,28
	normal	global_fun_call_op,29
	normal	fun_return_op,30
	normal	list_sub_op,31
	normal	table_sub_op,32
	normal	inv_table_sub_op,33
	normal	error_in_statement,34
	normal	missing_line,35
	normal	unclosed_for,36
	normal	illegal,37
	normal	undefined_function,38
	normal	subend_op,39
	normal	use_tty,40
	normal	setup_fcb,41
	normal	scratch,42
	normal	margin,43
	normal	reset_data,44
	normal	numeric_write,45
	normal	string_write,46
	normal	numeric_read,47
	normal	string_read,48
	normal	numeric_print,49
	normal	string_print,50
	normal	print_new_line,51
	normal	tab_for_comma,52
	normal	tab_fun,53
	normal	spc_fun,54
	normal	check_eof,55
	normal	numeric_input,56
	normal	string_input,57
	normal	linput,58
	normal	end_input,59
	normal	lof_fun,60
	normal	loc_fun,61
	normal	mar_fun,62
	normal	numeric_data_read,63
	normal	string_data_read,64
	normal	per_fun,65
	normal	typ_fun,66
	normal	use_fcb,67
	normal	print_using_start,68
	normal	print_using_end,69
	normal	print_using_numeric,70
	normal	print_using_string,71
	normal	hps_fun,72
	normal	lin_fun,73
	normal	tst_fun,74
	normal	num_fun,75
	normal	file_fun,76
	normal	end_print,77
	normal	reset_ascii,78
	normal	reset_random,79
	normal	abs_fun,80
	normal	int_fun,81
	normal	mod_fun,82
	normal	randomize,83
	normal	rnd_fun,84
	normal	sgn_fun,85
	normal	tim_fun,86
	normal	val_fun,87
	normal	sqr_fun,88
	normal	cos_fun,89
	normal	sin_fun,90
	normal	cot_fun,91
	normal	tan_fun,92
	normal	atn_fun,93
	normal	exp_fun,94
	normal	log_fun,95
	normal	clg_fun,96
	normal	pwr_fun,97
	normal	pwri_fun,98
	normal	illegal,99
	normal	det_fun,100
	normal	con_fun,101
	normal	idn_fun,102
	normal	inv_fun,103
	normal	trn_fun,104
	normal	zer_fun,105
	normal	nul_fun,106
	normal	list_redim_op,107
	normal	table_redim_op,108
	normal	inv_table_redim_op,109
	normal	mat_numeric_input,110
	normal	mat_string_input,111
	normal	mat_numeric_print,112
	normal	mat_string_print,113
	normal	mat_numeric_read,114
	normal	mat_string_read,115
	normal	mat_numeric_write,116
	normal	mat_string_write,117
	normal	mat_linput_op,118
	normal	mat_numeric_data_read,119
	normal	mat_string_data_read,120
	normal	mat_print_using_numeric,121
	normal	mat_print_using_string,122
	normal	mat_assign_numeric,123
	normal	mat_add,124
	normal	mat_sub,125
	normal	mat_scalar_mult,126
	normal	dot_product,127
	normal	mat_assign_string,128
	normal	mat_mult_vm,129
	normal	mat_mult_mv,130
	normal	mat_mult_mm,131
	normal	setdigits_op,132
	normal	ep_sqr_fun,133
	normal	ep_cos_fun,134
	normal	ep_sin_fun,135
	normal	ep_cot_fun,136
	normal	ep_tan_fun,137
	normal	ep_atn_fun,138
	normal	ep_exp_fun,139
	normal	ep_log_fun,140
	normal	ep_clg_fun,141
	normal	ep_pwr_fun,142
	normal	ep_pwri_fun,143
	normal	ep_mod_fun,144
	normal	new_fun_call_op,145
	normal	new_global_fun_call_op,146
	normal	new_fun_return_op,147
	normal	new_string_data_read,148
	normal	left_fun,149
	normal 	right_fun,150
	use	text
last_normal:

	join	/text/text,data

	end




		    basic_operators_.alm            11/05/86  1542.2r w 11/04/86  1039.3      600651



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"
"	Operators segment for Multics BASIC
"	Inital Version:	Spring 1973 by BLW
"	Modified:		18 March 1974 by BLW to fix bug 017
"	Modified:		28 March 1974 by BLW to fix bugs 018 & 021
"	Modified:		19 July 1974 by BLW to fix bugs 034, 034, 035, & 041
"	Modified:		5 August 1974 by BLW to preserve EAQ around string assignment
"	Modified:		16 August 1974 by BLW to fix bug 046
"	Modified:		27 August 1974 by BLW to fix bug 047
"	Modified:		9 July by J.M. Broughton for debuggers to find op return loc
"	Modified:		30 April 1976 by MBW  to add macros for extended precision and fix bugs 060, 062
"	Modified:		8 December 1976 by MBW to correct references to string segment
"	Modified:		24 January 1977 by MBW to fix bugs 063 and 065
"	Modified:		26 January 1977 by MBW to pass char strings as char (*) to non-basic progs
"	Modified:		14 July 1977 by MBW to convert to alm and fix bug 075 (ep list assign)
"	Modified:		23 September 1977 by MBW to fix bugs 078 and 079
"	Modified:		25 May 1978 by MBW to fix bug 081
"	Modified:		24 November 1980 by MBW to fix bugs 087 and 091
"	Modified:		1 April 1980 by MBW to reference strings thru pr5 and call functions with pr3
"	Modified:		15 July 1981 by MBW to fix bug 098 (using temp3 to store return loc)
"	Modified:		11 September 1981 by MBW to fix bug 102 (string data relocation)
"	Modified:		15 May 1984 by DWL to document use of sst$ for mid$
"	Modified:		22 May 1984 by DWL to add left$
"	Modified:		23 May 1984 by DWL to add right$
"
	tempd	print_using_ptr
"
	tempd	abort_label(2),conversion_label(2),size_label(2),on_units(6)
	tempd	program_header,text_base_ptr,string_segment
	tempd	fcb_pt
	tempd	arglist1(2),runtime_arglist(2)
	tempd	cpu_start,determinant
	temp	fcb(17),file_number,number,pdl,program_header_offset
	temp	numeric_data_pos,string_data_pos,random
	temp	math_block,last_frame,next_frame,number_read,pu_pos,pu_length
	temp	definitions,fn_temp1,fn_temp2,entryname,flags,string_value
	tempd	temp1,temp2,temp3
"
"	temp3 doubles as the return pt to the actual program when a call is
"	performed, its location must be the same as for ep basic for use by debuggers
"
	bool	program_header_equ,102	should be equal to program_header
	equ	args,128
	equ	math_block_size,32	size of storage block for math routines
"
	include	stack_header
	include	stack_frame
"
	link	sp_sqr,<square_root_>|[square_root_]
	link	sp_cos,<sine_>|[cosine_radians_]
	link	sp_sin,<sine_>|[sine_radians_]
	link	sp_tan,<tangent_>|[tangent_radians_]
	link	sp_cot,<tangent_>|[cotangent_radians_]
	link	sp_atn,<arc_tangent_>|[arc_tangent_radians_]
	link	sp_exp,<exponential_>|[exponential_]
	link	sp_log,<logarithm_>|[log_base_e_]
	link	sp_pwr,<power_>|[single_power_single_]
	link	sp_clg,<logarithm_>|[log_base_10_]
	link	ep_sqr,<double_square_root_>|[double_square_root_]
	link	ep_cos,<double_sine_>|[double_cosine_radians_]
	link	ep_sin,<double_sine_>|[double_sine_radians_]
	link	ep_tan,<tangent_>|[double_tangent_radians_]
	link	ep_cot,<tangent_>|[double_cotangent_radians_]
	link	ep_atn,<double_arc_tangent_>|[double_arc_tangent_radians_]
	link	ep_exp,<double_exponential_>|[double_exponential_]
	link	ep_log,<double_logarithm_>|[double_log_base_e_]
	link	ep_pwr,<power_>|[double_power_double_]
	link	ep_clg,<double_logarithm_>|[double_log_base_10_]
"
"	definition of basic program header
"
	equ	bph.version,0
	equ	bph.numeric_storage,1
	equ	bph.string_storage,2
	equ	bph.numeric_data,3
	equ	bph.string_data,4
	equ	bph.incoming_args,5
	equ	bph.outgoing_args,6
	equ	bph.numeric_scalars,7
	equ	bph.string_scalars,8
	equ	bph.numeric_arrays,9
	equ	bph.string_arrays,10
	equ	bph.functions,11
	equ	bph.statement_map,12
	equ	bph.precision_ind,13
	equ	bph.definitions,13
"
"	definition of basic array dope
"
	equ	array_dope.data,0
	equ	array_dope.original_bounds,2
	equ	array_dope.current_bounds,4
"
"	definitiion of basic array symbols
"
	equ	array_symbol.name,0
	equ	array_symbol.location,0
	equ	array_symbol.offset,1
	equ	array_symbol.bounds,2
	equ	array_symbol_size,3
	bool	array_symbol_param,400000
"
"	definition of definition block
"
	equ	def_head.forward,0		0-17
	equ	def_head.backward,0		18-35
"
	equ	def.forward,0		0-17
	equ	def.backward,0		18-35
	equ	def.value,1		0-17
	equ	def.flags,1		18-32
	equ	def.class,1		33-35
	equ	def.symbol,2		0-17
	equ	def.segname,2		18-35
"
	bool	def_flag.new,400000		dl
	bool	def_flag.ignore,200000	dl
	bool	def_flag.entry,100000	dl
	bool	def_flag.retain,040000	dl
	bool	def_flag.descriptors,020000	dl
"
"	definition of on-unit body
"
	equ	on_name,0
	equ	on_body,2
	equ	on_size,4
	equ	on_next,5
"
	bool	blank,40
"
	equ	pdl_size,256
	equ	fn_size,256
	equ	fn_extend_size,64
"
	bool	n_scalar_type,414000
	bool	n_list_type,414100
	bool	n_table_type,414200
	bool	char_type,524000
	bool	vs_char_type,530000
"
	bool	erase_packed_bit,775777
	bool	ignore_handler,020000
	bool	use_handler,757777
"
	bool	dim_1,000100
	bool	dim_2,000200
"
	equ	descriptor.type,0
	equ	descriptor.lower_1,1
	equ	descriptor.upper_1,2
	equ	descriptor.multiplier_1,3
	equ	descriptor.lower_2,4
	equ	descriptor.upper_2,5
	equ	descriptor.multiplier_2,6
"
	bool	eax7,627000
"
"
"	macros for code which is different for single and double precision
"
	macro	transfer_vector
&1operator_table:
	zero	0			0
	tra	&1string_assign		1
	tra	string_concatenate		2
	tra	string_compare		3
	tra	len_fun			4
	tra	pos_fun			5
	tra	chr_fun			6
	tra	clk_fun			7
	tra	dat_fun			8
	tra	usr_fun			9
	tra	str_fun			10
	tra	seg_fun			11
	tra	sst_fun			12, also used by mid$
	tra	&1max_fun			13
	tra	&1min_fun			14
	tra	change_from_string		15
	tra	change_to_string		16
	tra	argcnt			17
	tra	argval			18
	zero	0
	tra	stop_op			20
	tra	on_op			21
	tra	gosub_op			22
	tra	on_gosub_op		23
	tra	sub_call_op		24
	tra	std_sub_call_op		25
	tra	return_op			26
	tra	sub_exit_op		27
	tra	&1fun_call_op		28
	tra	&1global_fun_call_op	29
	tra	&1fun_return_op		30
	tra	&1list_sub_op		31
	tra	&1table_sub_op		32
	tra	&1inv_table_sub_op		33
	tra	error_in_statement		34
	tra	missing_line		35
	tra	unclosed_for		36
	zero	0			37
	tra	undefined_function		38
	tra	subend_op			39
	tra	use_tty			40
	tra	setup_fcb			41
	tra	scratch			42
	tra	margin			43
	tra	reset_data		44
	tra	numeric_write		45
	tra	string_write		46
	tra	&1numeric_read		47
	tra	string_read		48
	tra	numeric_print		49
	tra	string_print		50
	tra	print_new_line		51
	tra	tab_for_comma		52
	tra	tab_fun			53
	tra	spc_fun			54
	tra	check_eof			55
	tra	&1numeric_input		56
	tra	string_input		57
	tra	linput			58
	tra	end_input			59
	tra	lof_fun			60
	tra	loc_fun			61
	tra	mar_fun			62
	tra	&1numeric_data_read		63
	tra	string_data_read		64
	tra	per_fun			65
	tra	typ_fun			66
	tra	use_fcb			67
	tra	print_using_start		68
	tra	print_using_end		69
	tra	&1print_using_numeric	70
	tra	print_using_string		71
	tra	hps_fun			72
	tra	lin_fun			73
	tra	tst_fun			74
	tra	num_fun			75
	tra	file_fun			76
	tra	end_print			77
	tra	reset_ascii		78
	tra	reset_random		79
	tra	abs_fun			80
	tra	int_fun			81
	tra	&1mod_fun			82
	tra	randomize			83
	tra	rnd_fun			84
	tra	sgn_fun			85
	tra	tim_fun			86
	tra	&1val_fun			87
	tra	&1sqr_fun			88
	tra	&1cos_fun			89
	tra	&1sin_fun			90
	tra	&1cot_fun			91
	tra	&1tan_fun			92
	tra	&1atn_fun			93
	tra	&1exp_fun			94
	tra	&1log_fun			95
	tra	&1clg_fun			96
	tra	&1pwr_fun			97
	tra	&1pwri_fun		98
	zero	0
	tra	det_fun			100
	tra	&1con_fun			101
	tra	&1idn_fun			102
	tra	inv_fun			103
	tra	&1trn_fun			104
	tra	&1zer_fun			105
	tra	nul_fun			106
	tra	list_redim_op		107
	tra	table_redim_op		108
	tra	inv_table_redim_op		109
	tra	mat_numeric_input		110
	tra	mat_string_input		111
	tra	mat_numeric_print		112
	tra	mat_string_print		113
	tra	mat_numeric_read		114
	tra	mat_string_read		115
	tra	mat_numeric_write		116
	tra	mat_string_write		117
	tra	mat_linput_op		118
	tra	mat_numeric_data_read	119
	tra	mat_string_data_read	120
	tra	mat_print_using_numeric	121
	tra	mat_print_using_string	122
	tra	&1mat_assign_numeric	123
	tra	&1mat_add			124
	tra	&1mat_sub			125
	tra	&1mat_scalar_mult		126
	tra	&1dot_product		127
	tra	mat_assign_string		128
	tra	mat_mult_vm		129
	tra	mat_mult_mv		130
	tra	mat_mult_mm		131
	tra	setdigits_op		132
	tra	ep_sqr_fun		133
	tra	ep_cos_fun		134
	tra	ep_sin_fun		135
	tra	ep_cot_fun		136
	tra	ep_tan_fun		137
	tra	ep_atn_fun		138
	tra	ep_exp_fun		139
	tra	ep_log_fun		140
	tra	ep_clg_fun		141
	tra	ep_pwr_fun		142
	tra	ep_pwri_fun		143
	tra	ep_mod_fun		144
	tra	&1new_fun_call_op		145
	tra	&1new_global_fun_call_op	146
	tra	&1new_fun_return_op		147
	tra	new_string_data_read	148
	tra	left_fun			149
	tra	right_fun			150
	&end
	macro	string_assign
"	string assignment, entered with pointer to lhs in bb and pointer to rhs in ab
"
&1string_assign:
	&2	temp1		save EAQ
	ldq	10,dl
"
&1ss1:	tsx0	invoke_runtime
&1ss2:	&3	temp1
	tra	text_base_ptr,*7
	&end
	macro	max
"
"	operator to return max(arg1,arg2,...,argn)
"	entered with
"		ldq	n,dl
"		tsx7	ap|max_fun
"		fld	arg1
"		fld	arg2
"		...
"		fld	argn
"
&1max_fun:
	epp2	text_base_ptr,*7	get ptr to arg list
	eax0	0,ql		save number of args
	eax1	0,ql		save return point
	xec	pr2|-1,0		get last arg
&1max1:	sbx0	1,du		count down
	tze	pr2|0,1		return with result in eaq
	&2	temp1
	xec	pr2|-1,0		get next arg
	&3	temp1
	tpl	2,ic
	&4	temp1
	tra	&1max1
	&end
	macro	min
"
"	operator to return min(arg1,arg,...,argn)
"	entered with same calling sequence as max
"
&1min_fun:
	epp2	text_base_ptr,*7
	eax0	0,ql
	eax1	0,ql
	xec	pr2|-1,0
&1min1:	sbx0	1,du
	tze	pr2|0,1
	&2	temp1
	xec	pr2|-1,0
	&3	temp1
	tmi	2,ic
	&4	temp1
	tra	&1min1
"
	&end
"
	macro	fun_call_op
"
"	operator to call a user defined function, entered with
"		epplb	entry
"		tsx7	fun_call_op
"		vfd	36/fun_call_word
"		fld	arg1		numeric
"		eppab	arg2		string
"	entry point is
"	entry:	vfd	36/fun_call_word
"		vfd	36/fun_local_word
"		[first executable instruction]
"
&1fun_call_op:
	stx4	fn_temp1		use current display as next fn display
	sprplp	fn_temp2		use current value as next value of program header pt
"
"	at this point:
"		lp -> current program header
"		fn_temp1 = new function display value
"		fn_temp2 = packed ptr to new program header
"
&1fun_call:
	sprplp	temp1
	ldq	temp1
	stq	pdl,id		put current program header pt on pdl
	ttn	pdl_full
	eppbp	text_base_ptr,*7	get ptr to fun call word
	ldq	lb|0		get expected call word
	cmpq	bp|0		check with actual
	tnz	fn_call_error	error if not the same
	lda	0,dl		get number of args
	lls	5
	sta	temp1		save
	eppap	bp|1,al		get ptr to return loc
	sprpap	temp2
	ldq	temp2
	stq	pdl,id		put on pdl
	ttn	pdl_full
	stx4	pdl,id		put fn display on pdl
	ttn	pdl_full
	stx6	pdl,id		put current frame offset on pdl
	ttn	pdl_full
	stz	pdl,id		put in fence of 0
	ttn	pdl_full
	ldq	lb|1		get local word
	lda	0,dl		get number of locals
	lls	5
	sta	temp2		save
	ada	temp1		get number args + locals
	ada	2,dl		add 1 for return arg + 1 to make even
	ana	=o777776,dl	make multiple of 2
	lls	&4
	ldx7	next_frame	get next frame offset
	ada	next_frame	update next frame offset
	sta	next_frame
	cmpa	last_frame	have we exceeded available space
	tmoz	&1fc1
	eppap	sb|stack_header.stack_end_ptr,*	get ptr to end of stack
	eppap	ap|fn_extend_size	extend stack
	spriap	sb|stack_header.stack_end_ptr
	spriap	sp|stack_frame.next_sp
	eaa	fn_extend_size
	asa	last_frame
&1fc1:	eax1	&2		init arg copy loop
	eax2	1
	eppap	sp|0,7		get ptr to next frame
	stz	ap|0		init return value
	lxl0	temp1		get number of args
	tze	&1fc5		skip if zero
	ldq	lb|0		get call word
	lls	5		shift to position
&1fc2:	qls	1		check next arg
	stq	temp3
	tmi	&1fc4		minus means string arg
	xec	bp|0,2		load the arg value
	&3	ap|0,1		and save in frame
&1fc3:	adx1	&2,du		account for position
	adx2	1,du
	sbx0	1,du		count down
	tze	&1fc5		and skip if no more args
	ldq	temp3		do next arg
	tra	&1fc2
&1fc4:	xec	bp|0,2		string arg, get ptr
	epp3	ap|0,1		get ptr to target
	stz	3|0		clear string temp (important!)
	ldq	10,dl		get action code
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	tra	&1fc3		go do next arg
	ife	&1,sp_
sp_fc5:	lxl0	temp2		get number of locals
	ifend
	ife	&1,ep_
ep_fc5:	ldq	temp2		get number of locals
	qls	1		double for number of words
	eax0	0,ql
	ifend
	tze	&1fc7		skip if no locals
&1fc6:	stz	ap|0,1		zero local
	sbx0	1,du
	tze	&1fc7
	adx1	1,du
	tra	&1fc6
&1fc7:	eppap	&1operator_table	restore ptr to operators
	ldx4	fn_temp1		get new fn display
	eax6	0,7		get new fn offset
	lprplp	fn_temp2		get new program header pt
	sprilp	program_header
	spbplp	text_base_ptr	set text base ptr also
	eax7	lp|0		set program header offset
	stx7	program_header_offset
	tra	lb|2		and enter function
	&end
"
	macro	global_fun_call_op
"
"	operator to call global function
"		epplb	entry_info
"		tsx7	global_fun_call_op
"		vfd	36/fun_call_word
"		fld	arg1		numeric
"		eppab	arg2		string
"	entry info is
"		word 0	packed ptr to entry pt
"		word 1	packed ptr to stack frame of parent
"
&1global_fun_call_op:
	eaa	sp|0		get rel(parent stack) - rel(our stack)
	neg	0
	sta	fn_temp1
	lxl0	lb|1
	asx0	fn_temp1		save as new display value
	lprpbp	lb|1		get ptr to parent stack frame of fun
	eppbp	bp|program_header_equ,*	load ptr to program header
	sprpbp	fn_temp2		save packed ptr to program header
	lprplb	lb|0		get ptr to entry pt
	tra	&1fun_call		join common code
	&end
"
	macro	fun_return_op
"
"	operator to return from function, entered with
"		epplb	entry
"		tsx7	fun_return_op
"
&1fun_return_op:
	ldq	pdl,di		pop pdl
	ttn	fn_return_error
	tnz	&1fun_return_op	skip gosub return
	eppap	sp|0,6		get ptr to this frame
	eax1	&2		init arg, local loop
	ldq	lb|0		get call word
	lda	0,dl		extract number of args
	lls	5
	eax0	0,al
	tze	&1fr3		skip if no args
&1fr1:	qls	1		check next arg
	tpl	&1fr2		plus means numeric
	stq	temp2
	eppab	ap|0,1		get ptr to string word
	ldq	28,dl
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	ldq	temp2
&1fr2:	adx1	&2,du
	sbx0	1,du		check next arg
	tnz	&1fr1
&1fr3:	ldq	lb|1		get local word
	lda	0,dl
	lls	5		get number of locals
	eax0	0,al
	tze	&1fr6		skip if none
&1fr4:	qls	1
	tpl	&1fr5
	stq	temp2
	eppab	ap|0,1		get ptr to string word
	ldq	28,dl
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	ldq	temp2
&1fr5:	sbx0	1,du
	tze	&1fr6
	adx1	&2,du
	tra	&1fr4
&1fr6:	stx6	next_frame	reset end of stack
	ldx6	pdl,di		pop function stack
	ldx4	pdl,di		restore display from pdl
	ldq	lb|0		check mode of return value
	qls	5
	tmi	&1fr7		minus is string
	&3	ap|0		load numeric value
	tra	&1fr8		and return
&1fr7:	eppab	string_value	set string ptr
	szn	ab|0		is string_value word zero
	tze	&1fr7a		yes, don't have to deallocate it
	ldq	28,dl		no, deallocate it
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
&1fr7a:	ldq	ap|0		get function value
	stq	ab|0		set string value
	fld	=0.0,du		get 0 numeric value
&1fr8:	eppap	&1operator_table	restore ptr to operators
	lprpbp	pdl,di		get return pt from pdl
	lprplp	pdl,di		get program header pt from pdl
	sprilp	program_header	restore stack frame
	spbplp	text_base_ptr
	eax7	lp|0		set program header offset
	stx7	program_header_offset
	fcmp	=0.0,du		set indicators
	tra	bp|0		return to caller
	&end
"
	macro	new_fun_call_op
"
"	operator to call a user defined function, entered with
"		epp3	entry
"		tsx7	fun_call_op
"		vfd	36/fun_call_word
"		fld	arg1		numeric
"		eppab	arg2		string
"	entry point is
"	entry:	vfd	36/fun_call_word
"		vfd	36/fun_local_word
"		[first executable instruction]
"
&1new_fun_call_op:
	stx4	fn_temp1		use current display as next fn display
	sprplp	fn_temp2		use current value as next value of program header pt
"
"	at this point:
"		lp -> current program header
"		fn_temp1 = new function display value
"		fn_temp2 = packed ptr to new program header
"
&1new_fun_call:
	sprplp	temp1
	ldq	temp1
	stq	pdl,id		put current program header pt on pdl
	ttn	pdl_full
	eppbp	text_base_ptr,*7	get ptr to fun call word
	ldq	pr3|0		get expected call word
	cmpq	bp|0		check with actual
	tnz	fn_call_error	error if not the same
	lda	0,dl		get number of args
	lls	5
	sta	temp1		save
	eppap	bp|1,al		get ptr to return loc
	sprpap	temp2
	ldq	temp2
	stq	pdl,id		put on pdl
	ttn	pdl_full
	stx4	pdl,id		put fn display on pdl
	ttn	pdl_full
	stx6	pdl,id		put current frame offset on pdl
	ttn	pdl_full
	stz	pdl,id		put in fence of 0
	ttn	pdl_full
	ldq	pr3|1		get local word
	lda	0,dl		get number of locals
	lls	5
	sta	temp2		save
	ada	temp1		get number args + locals
	ada	2,dl		add 1 for return arg + 1 to make even
	ana	=o777776,dl	make multiple of 2
	lls	&4
	ldx7	next_frame	get next frame offset
	ada	next_frame	update next frame offset
	sta	next_frame
	cmpa	last_frame	have we exceeded available space
	tmoz	&1nfc1
	eppap	sb|stack_header.stack_end_ptr,*	get ptr to end of stack
	eppap	ap|fn_extend_size	extend stack
	spriap	sb|stack_header.stack_end_ptr
	spriap	sp|stack_frame.next_sp
	eaa	fn_extend_size
	asa	last_frame
&1nfc1:	spri3	temp3		save, may need pr3 for string handling
	eax1	&2		init arg copy loop
	eax2	1
	eppap	sp|0,7		get ptr to next frame
	stz	ap|0		init return value
	lxl0	temp1		get number of args
	tze	&1nfc5		skip if zero
	ldq	pr3|0		get call word
	lls	5		shift to position
&1nfc2:	qls	1		check next arg
	stq	temp2+1
	tmi	&1nfc4		minus means string arg
	xec	bp|0,2		load the arg value
	&3	ap|0,1		and save in frame
&1nfc3:	adx1	&2,du		account for position
	adx2	1,du
	sbx0	1,du		count down
	tze	&1nfc5		and skip if no more args
	ldq	temp2+1		do next arg
	tra	&1nfc2
&1nfc4:	xec	bp|0,2		string arg, get ptr
	epp3	ap|0,1		get ptr to target
	stz	pr3|0		clear string temp (important!)
	ldq	10,dl		get action code
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	tra	&1nfc3		go do next arg
	ife	&1,sp_
sp_nfc5:	lxl0	temp2		get number of locals
	ifend
	ife	&1,ep_
ep_nfc5:	ldq	temp2		get number of locals
	qls	1		double for number of words
	eax0	0,ql
	ifend
	tze	&1nfc7		skip if no locals
&1nfc6:	stz	ap|0,1		zero local
	sbx0	1,du
	tze	&1nfc7
	adx1	1,du
	tra	&1nfc6
&1nfc7:	eppap	&1operator_table	restore ptr to operators
	ldx4	fn_temp1		get new fn display
	eax6	0,7		get new fn offset
	lprplp	fn_temp2		get new program header pt
	sprilp	program_header
	spbplp	text_base_ptr	set text base ptr also
	eax7	lp|0		set program header offset
	stx7	program_header_offset
	epp3	temp3,*		restore ptr to entry
	tra	pr3|2		and enter function
	&end
"
	macro	new_global_fun_call_op
"
"	operator to call global function
"		epp3	entry_info
"		tsx7	global_fun_call_op
"		vfd	36/fun_call_word
"		fld	arg1		numeric
"		eppab	arg2		string
"	entry info is
"		word 0	packed ptr to entry pt
"		word 1	packed ptr to stack frame of parent
"
&1new_global_fun_call_op:
	eaa	sp|0		get rel(parent stack) - rel(our stack)
	neg	0
	sta	fn_temp1
	lxl0	pr3|1
	asx0	fn_temp1		save as new display value
	lprpbp	pr3|1		get ptr to parent stack frame of fun
	eppbp	bp|program_header_equ,*	load ptr to program header
	sprpbp	fn_temp2		save packed ptr to program header
	lprp3	pr3|0		get ptr to entry pt
	tra	&1new_fun_call		join common code
	&end
"
	macro	new_fun_return_op
"
"	operator to return from function, entered with
"		epp3	entry
"		tsx7	fun_return_op
"
&1new_fun_return_op:
	ldq	pdl,di		pop pdl
	ttn	fn_return_error
	tnz	&1new_fun_return_op	skip gosub return
	eppap	sp|0,6		get ptr to this frame
	eax1	&2		init arg, local loop
	ldq	pr3|0		get call word
	lda	0,dl		extract number of args
	lls	5
	eax0	0,al
	tze	&1nfr3		skip if no args
&1nfr1:	qls	1		check next arg
	tpl	&1nfr2		plus means numeric
	stq	temp2
	eppab	ap|0,1		get ptr to string word
	ldq	28,dl
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	ldq	temp2
&1nfr2:	adx1	&2,du
	sbx0	1,du		check next arg
	tnz	&1nfr1
&1nfr3:	ldq	pr3|1		get local word
	lda	0,dl
	lls	5		get number of locals
	eax0	0,al
	tze	&1nfr6		skip if none
&1nfr4:	qls	1
	tpl	&1nfr5
	stq	temp2
	eppab	ap|0,1		get ptr to string word
	ldq	28,dl
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	ldq	temp2
&1nfr5:	sbx0	1,du
	tze	&1nfr6
	adx1	&2,du
	tra	&1nfr4
&1nfr6:	stx6	next_frame	reset end of stack
	ldx6	pdl,di		pop function stack
	ldx4	pdl,di		restore display from pdl
	ldq	pr3|0		check mode of return value
	qls	5
	tmi	&1nfr7		minus is string
	&3	ap|0		load numeric value
	tra	&1nfr8		and return
&1nfr7:	eppab	string_value	set string ptr
	szn	ab|0		is string_value word zero
	tze	&1nfr7a		yes, don't have to deallocate it
	ldq	28,dl		no, deallocate it
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
&1nfr7a:	ldq	ap|0		get function value
	stq	ab|0		set string value
	fld	=0.0,du		get 0 numeric value
&1nfr8:	eppap	&1operator_table	restore ptr to operators
	lprpbp	pdl,di		get return pt from pdl
	lprplp	pdl,di		get program header pt from pdl
	sprilp	program_header	restore stack frame
	spbplp	text_base_ptr
	eax7	lp|0		set program header offset
	stx7	program_header_offset
	fcmp	=0.0,du		set indicators
	tra	bp|0		return to caller
	&end
"
	macro	list_sub_op
"
"	validate list subscript, for x(i)
"		fld	i
"		eppbp	x_dope
"		tsx7	list_sub_op
"
&1list_sub_op:
	ufa	=71b25,du		convert to integer in ql
	cmpq	bp|array_dope.current_bounds
	trc	subscript_error
	ife	&1,ep_
	qls 	1
	ifend
	eppbp	bp|array_dope.data,*ql	get ptr to element
	tra	text_base_ptr,*7	and return
	&end
"
	macro	table_sub_op
"
"	validate table subscript, for x(i,j)
"		fld	i
"		eppbp	x_dope
"		tsx7	table_sub_op
"		fld	j
"
&1table_sub_op:
	ufa	=71b25,du		convert to integer in qu
	cmpq	bp|array_dope.current_bounds
	trc	subscript_error
	mpy	bp|array_dope.current_bounds+1
	stq	temp1
	xec	text_base_ptr,*7
	ufa	=71b25,du
	cmpq	bp|array_dope.current_bounds+1
	trc	subscript_error
	adlq	temp1
	ife	&1,ep_
	qls	1
	ifend
	eppbp	bp|array_dope.data,*ql
	adx7	1,du
	tra	text_base_ptr,*7
&end
"
	macro	inv_table_sub_op
"
"	validate table subscript, for x(i,j)
"		fld	j
"		eppbp	x_dope
"		tsx7	inv_table_sub_op
"		fld	i
"
&1inv_table_sub_op:
	ufa	=71b25,du
	cmpq	bp|array_dope.current_bounds+1
	trc	subscript_error
	stq	temp1
	xec	text_base_ptr,*7
	ufa	=71b25,du
	cmpq	bp|array_dope.current_bounds
	trc	subscript_error
	mpy	bp|array_dope.current_bounds+1
	adlq	temp1
	ife	&1,ep_
	qls	1
	ifend
	eppbp	bp|array_dope.data,*ql
	adx7	1,du
	tra	text_base_ptr,*7
	&end
"
	macro	numeric_read
"
"	operator to read numeric value, return value in EAQ
"
&1numeric_read:
	ldq	35,dl		reading random file
&1nr1:	tsx0	invoke_runtime
	&2	temp1
	tra	text_base_ptr,*7
	&end
"
	macro	numeric_data_read
"
&1numeric_data_read:
	lxl0	numeric_data_pos
	cmpx0	numeric_data_pos
	trc	out_of_data
	&2	text_base_ptr,*0
	adx0	&3,du
	sxl0	numeric_data_pos
	tra	text_base_ptr,*7
	&end
"
	macro	numeric_input
"
"	input numeric value, result left in EAQ
"
&1numeric_input:
	ldq	14,dl
	tsx0	invoke_runtime
	&2	temp1
	tra	text_base_ptr,*7
	&end
"
	macro	print_using_numeric
"
&1print_using_numeric:
	&2	temp1
	ldq	57,dl
	tra	call_runtime
	&end
"
	macro	mod_fun
"
"	mod
"		fld	a
"		tsx7	mod_fun
"		fld	b
"
&1mod_fun:
	&2	temp1		save a
	xec	text_base_ptr,*7	get b
	tze	&1mf1		return a if b = 0
	&2	temp2
	&3	temp1		a/b
	ufa	=71b25,du
	fad	=71b25,du		int(a/b)
	&4	temp2		int(a/b)*b
	fneg	0		-int(a/b)*b
&1mf1:	adx7	1,du
	&5	temp1		a-int(a/b)*b
	tra	text_base_ptr,*7
	&end
"
	macro	val_fun
"
"	val(a$)
"
&1val_fun:
	ldq	27,dl
	tra	&1nr1
	&end
"
	macro	math_functions
"
"	math functions
"		fld	x
"		tsx7	math_function
"
&1sqr_fun:
	eax0	&1sqr
"
&1fun2:	lprp2	math_block	get ptr to storage block for math routines
	epp3	text_base_ptr,*7	store return location
	spri3	temp3		in case we get error
	epplp	sp|stack_frame.lp_ptr,*
	stx4	sp|stack_frame.regs+2	save in case used by function
	sxl7	sp|stack_frame.regs+3	save for error handler
	fad	=0.0,du			set indicators
	tsp3	lp|0,0*
	ldx4	sp|stack_frame.regs+2	restore x4 for user function
	lxl7	sp|stack_frame.regs+3	in case of error
	epp0	&1operator_table	in case there was a math error
	epplp	program_header,*
	fad	=0.0,du			set indicators
	tra	text_base_ptr,*7
"
&1cos_fun:
	eax0	&1cos
	tra	&1fun2
"
&1sin_fun:
	eax0	&1sin
	tra	&1fun2
"
&1cot_fun:
	eax0	&1cot
	tra	&1fun2
"
&1tan_fun:
	eax0	&1tan
	tra	&1fun2
"
&1atn_fun:
	eax0	&1atn
	tra	&1fun2
"
&1exp_fun:
	eax0	&1exp
	tra	&1fun2
"
&1log_fun:
	eax0	&1log
	tra	&1fun2
"
&1clg_fun:
	eax0	&1clg
	tra	&1fun2
"
	&end
"
	macro	power_functions
"
"	operator to evaluate a ** b, entered with
"		fld	a
"		tsx0	pwr_fun
"		fld	b
"
&1pwr_fun:
	&2	temp1		save a
	xec	text_base_ptr,*7	get b
	&2	temp2		and save it
&1fun3:	eax0	&1pwr
"
	&3	temp1
	epp1	temp2
	adx7	1,du
	tra	&1fun2
"
"	operator to evaluate a ** b, entered with
"		fld	b
"		tsx0	pwri_fun
"		fld	a
"
&1pwri_fun:
	&2	temp2		save b
	xec	text_base_ptr,*7	get a
	&2	temp1		and save it
	tra	&1fun3		join pwr code
"
	&end
"
	macro	zer_con_funs
"
"	operators to do
"		mat A = zer
"		mat A = con
"	entered with pr2 pointing at dope for A.
"
&1zer_fun:
	&2	&3		get value
	tra	&1con_fun+1
"
&1con_fun:
	&2	&4		get value
"
	lxl1	2|array_dope.current_bounds
	sbx1	1,du		get row bound
	tmoz	array_error
	lxl2	2|array_dope.current_bounds+1
	tmi	&1con_list
	sbx2	1,du		get col bound
	tmoz	array_error
	epp2	2|array_dope.data,*
	ife	&1,sp_
	eax3	2,2
	ifend
	ife	&1,ep_
	eaq	2,2
	qls	1
	eax3	0,qu
	xec	0,0
	ifend
	stx2	temp3		save col bound
&1ct1:	ldx2	temp3		col = col bound
&1ct2:	&5	2|0,3		set A(row,col)
	adx3	&6,du
	sbx2	1,du		col = col - 1
	tpnz	&1ct2
	adx3	&6,du		skip over col 0
	sbx1	1,du		row = row - 1
	tpnz	&1ct1
	tra	text_base_ptr,*7
"
&1con_list:
	epp2	2|array_dope.data,*
	ife	&1,ep_
	eaq	0,1
	qls	1
	eax1	0,qu
	xec	0,0
	ifend
	&5	2|0,1		set all but 0 element
	sbx1	&6,du
	tpnz	-2,ic
	tra	text_base_ptr,*7
"
	ife	&1,ep_
load0:	fld	=0.0,du
load1:	fld	=1.0,du
	ifend
"
	&end
"
	macro	idn_fun
"
"	operator to do
"		mat A = idn
"	entered with pr2 -> dope for A
"
&1idn_fun:
	ldq	2|array_dope.current_bounds
	cmpq	2|array_dope.current_bounds+1
	tnz	array_error	matrix must be square
	eax1	-1,ql
	tmoz	array_error
	eax2	0,1
	epp2	2|array_dope.data,*
	ife	&1,sp_
	eax3	2,2
	ifend
	ife	&1,ep_
	eaq	2,2
	qls	1
	eax3	0,qu
	ifend
	stx2	temp3
&1id1:	ldx2	temp3
	stx1	temp2
&1id2:	&2	=0.0d0		assume 0 element
	cmpx2	temp2		is row = col
	tnz	2,ic
	&2	=1.0d0		yes, get 1
	&3	2|0,3
	adx3	&4,du
	sbx2	1,du
	tpnz	&1id2
	adx3	&4,du
	sbx1	1,du
	tpnz	&1id1
	tra	text_base_ptr,*7
"
	&end
"
	macro	mat_assign_numeric
"
"	operator to do mat A = B
"	entered with pr2 -> dope for A and pr1 -> dope for B
"
&1mat_assign_numeric:
	eax0	&1nop
	ldaq	1|array_dope.current_bounds
	cmpq	0,dl
	tmi	&1list_assign
&1table_assign:
	mpy	1|array_dope.current_bounds
	stq	temp3
	ldq	2|array_dope.original_bounds
	mpy	2|array_dope.original_bounds+1
	cmpq	temp3
	tmi	redim_error
	ldaq	1|array_dope.current_bounds
	eax1	-1,al
	tmoz	array_error
	eax2	-1,ql
	tmoz	array_error
	staq	2|array_dope.current_bounds
	epp2	2|array_dope.data,*
	epp1	1|array_dope.data,*
	ife	&1,sp_
	eax3	2,2
	ifend
	ife	&1,ep_
	eaq	2,2
	qls	1
	eax3	0,qu
	ifend
	stx2	temp3
&1ta1:	ldx2	temp3
&1ta2:	&2	1|0,3
	xec	0,0
	&3	2|0,3
	adx3	&4,du
	sbx2	1,du
	tpnz	&1ta2
	adx3	&4,du
	sbx1	1,du
	tpnz	&1ta1
	tra	text_base_ptr,*7
"
&1list_assign:
	cmpa	2|array_dope.original_bounds
	tpnz	redim_error
	sta	2|array_dope.current_bounds
	ife	&1,ep_
	als	1
	ifend
	eax3	-&4,al
	tmoz	array_error
	epp1	1|array_dope.data,*
	epp2	2|array_dope.data,*
	&2	1|0,3
	xec	0,0
	&3	2|0,3
	sbx3	&4,du
	tpnz	-4,ic
	tra	text_base_ptr,*7
"
	&end
"
"
	macro	mat_add_sub
"
"	operator to do
"		mat A = B + C
"		mat A = B - C
"	entered with pr2 -> dope for A, pr1 -> dope for B,
"	pr3 -> dope for C
"
&1mat_add:
	eax0	&1fad
	tra	&1mat_sub+1
"
&1mat_sub:
	eax0	&1fsb
"
	ldaq	1|array_dope.current_bounds
	cmpq	0,dl
	tmi	&1list_sub
	cmpaq	3|array_dope.current_bounds
	tnz	array_error
	epp3	3|array_dope.data,*
	tra	&1table_assign
"
&1list_sub:
	cmpa	3|array_dope.current_bounds
	tnz	array_error
	epp3	3|array_dope.data,*
	tra	&1list_assign
"
	&end
"
	macro	mat_scalar_mult
"
"	operator to do
"		mat A = (expression)*B
"	entered with expression in EAQ, pr2 -> dope for A and
"	pr1 -> dope for B
"
&1mat_scalar_mult:
	&2	temp1
	eax0	&1fmp
	tra	&1mat_assign_numeric+1
"
&1nop:	nop	0,du
&1fad:	fad	3|0,3
&1fsb:	fsb	3|0,3
&1fmp:	fmp	temp1
"
	&end
"
	macro	dot_product
"
"	operator to form
"		mat dot_product = A * B
"	entered with pr1 -> dope for A and pr3 -> dope for B
"	returns with value in EAQ
"
&1dot_product:
	lda	1|array_dope.current_bounds
	cmpa	3|array_dope.current_bounds
	tnz	array_error
	ada	-&2,dl
	eax1	0,al		store bounds for indexing
	tmoz	array_error
	epp1	1|array_dope.data,*
	epp3	3|array_dope.data,*
	fld	=0.0,du
&1dot:	dfst	temp1
	&3	1|0,1
	&4	3|0,1
	dfad	temp1
	sbx1	&2,du
	tpnz	&1dot
	&5	=0.0,du		set indicators
	tra	text_base_ptr,*7
"
	&end
"
	macro	trn_fun
"
"	operator to do
"		mat A = trn(B)
"
&1trn_fun:
	ldq	1|array_dope.current_bounds+1
	tmi	&1mat_assign_numeric
	mpy	1|array_dope.current_bounds
	stq	temp3
	ldq	2|array_dope.original_bounds
	mpy	2|array_dope.original_bounds+1
	cmpq	temp3
	tmi	redim_error
	lda	1|array_dope.current_bounds+1
	ldq	1|array_dope.current_bounds
	staq	2|array_dope.current_bounds
	ldq	2,dl
	tra	call_matrix
"
	&end
"
"
"	Run-time transfer vector for Multics BASIC
"	Following locations cannot be changed since they are directly referenced
"	from compiled programs
"
	transfer_vector	sp_
	transfer_vector	ep_
"
"	End of section which cannot be modified
"
"	string operations and functions
"
	string_assign	sp_,fst,fld
"
"	concatenate, entered with pointer to left side in ab and pointer to right side in bb
"
string_concatenate:
	ldq	12,dl
	tra	call_runtime
"
"	string comparison, entered with pointer to lhs in ab and pointer to rhs in bb
"
string_compare:
	lda	ab|0		is lhs constant?
	cana	=o777777,du
	tze	sc1		yes, skip
	epbpab	string_segment,*	get ptr to beg of string segment
	eppab	ab|0,au		variable, get ptr to varying string
	eppab	ab|1
	lda	ab|0		and pickup variable length
sc1:	ldq	bb|0		is rhs constant?
	canq	=o777777,du
	tze	sc2		yes, skip
	epbpbb	string_segment,*	get ptr to beg of string segment
	eppbb	bb|0,qu		variable, get ptr to varying string
	eppbb	bb|1
	ldq	bb|0		and pickup variable length
sc2:	cmpc	(pr,rl),(pr,rl),fill(blank)
	desc9a	bb|1,ql
	desc9a	ab|1,al
	tze	text_base_ptr,*7	return if =
	trc	3,ic		convert carry indicator into negative indicator
	ldq	1,dl		turn off negative indicator
	tra	text_base_ptr,*7
	lcq	1,dl		set negative indicator
	tra	text_base_ptr,*7
"
"	return length of string pointed at by ab
"
len_fun:
	lda	ab|0		get string word
	tze	len1		zero means null string
	cana	=o777777,du	is this constant
	tze	len1		yes, length already in a
	epbpab	string_segment,*	no, get ptr to string block
	eppab	ab|0,au
	lda	ab|1		and pick up length from that
len1:	lde	=35b25,du		float length
	ldq	0,dl
	fad	=0.0,du
	tra	text_base_ptr,*7	and return
"
"	pos(a$,b$,n), a$ in ab, b$ in bb, n in EAQ
"
pos_fun:	fst	temp1
	ldq	17,dl
pos1:	tsx0	invoke_runtime
pos2:	fld	temp1
	tra	text_base_ptr,*7
"
"	chr$(x)
"
chr_fun:	fst	temp1
	ldq	18,dl
	tra	call_runtime
"
"	clk$
"
clk_fun:	ldq	19,dl
	tra	call_runtime
"
"	dat$
"
dat_fun:	ldq	20,dl
	tra	call_runtime
"
"	usr$
"
usr_fun:	ldq	21,dl
	tra	call_runtime
"
"	str$(x)
"
str_fun:	dfst	temp1
	ldq	22,dl
	tra	call_runtime
"
"	left$(a$,i), a$ in ab, i in EAQ
"
left_fun:	fst	temp1
	ldq	134,dl
	tra 	call_runtime
"
"	right$(a$,i), a$ in ab, i in EAQ
"
right_fun:
	fst	temp1
	ldq	135,dl
	tra	call_runtime
"
"	seg$(a$,i,j), a$ in ab, i in EAQ, j at text_base_ptr,7*
"
seg_fun:	fst	temp1
	xec	text_base_ptr,*7
	fst	temp2
	ldq	23,dl
	adx7	1,du
	tra	call_runtime
"
"	sst(a$,i,n) and mid$(a$,i,n)
"
sst_fun:
mid_fun:	fst	temp1
	xec	text_base_ptr,*7
	fst	temp2
	ldq	24,dl
	adx7	1,du
	tra	call_runtime
"
	max	sp_,fst,fcmp,fld
"
	min	sp_,fst,fcmp,fld
"
"	operators to change from string to numeric array, and vice versa
"	entered with pr1 -> string, pr2 -> array, element size in eaq
"
change_from_string:
	fst	temp1
	ldq	43,dl
	tra	call_runtime
"
change_to_string:
	fst	temp1
	ldq	44,dl
	tra	call_runtime
"
"	function to return number of Multics arguments of current subprogram
"
argcnt:	lda	sp|stack_frame.arg_ptr,*	get 2*n_args in au
	ars	18+1
	tra	len1		go float result and return
"
"	arg$(x) returns string for argument number x or "" if specified
"	argument doesn't exist
"
argval:	ufa	=35b25,du		fix arg number
	tmoz	return_null_string	return null if invalid number
	als	1
	eax1	0,al		save 2*arg number
	epp2	sp|stack_frame.arg_ptr,*	get arglist ptr
	cmpx1	2|0		check arg desired
	tpnz	return_null_string	return null if arg number too bit
	lda	2|1		are there any descriptors
	tze	return_null_string	nope
	epp1	2|0,au		get ptr to descriptors
	lxl0	2|0		is there extra ptr in middle of arg list
	canx0	8,du
	tze	2,ic
	epp1	1|2		yes, skip over extra ptr
	lda	1|0,1*		get descriptor
	ana	=o7777,dl		extract size
	cmpa	=4096,dl		use max of 4095 chars
	tmi	2,ic
	lda	=4095,dl
	epp2	2|0,1*		get ptr to string
	ldq	65,dl
	tra	call_runtime	go setup string value
"
return_null_string:
	epp1	=0
	tra	text_base_ptr,*7
"
"	control operations
"
subend_op:
stop_op:
	ldq	1,dl		get stop code
	tsx0	invoke_runtime
"
	even
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sp|stack_frame.prev_sp,*
	epbpsb	sp|0
	eppap	sp|stack_frame.operator_ptr,*
	rtcd	sp|stack_frame.return_ptr
"
"	operator to do on statement, entered with
"		fld	number
"		tsx7	on_op
"		dec	number_of_transfers+1
"		tra	l1-*,ic
"		tra	l2-*,ic
"		...
"
on_op:
	ufa	=35b25,du		fix number in al
	tmoz	on_error
	eppbp	text_base_ptr,*7
	cmpa	bp|0		make sure transfer is valid
	tmoz	bp|0,al
"
on_error:	ldq	101,dl		go print error and abort run
	tra	error1
"
"	operator to do gosub statement
"		eppbp	location
"		tsx7	gosub_op
"
gosub_op:
	stx7	pdl,id		save return address
	ttn	pdl_full
	tra	bp|0		and then transfer to routine
"
pdl_full:
	ldq	130,dl
	tra	error1
"
"	operator to do on with gosub
"		fld	number
"		tsx7	on_gosub_op
"		dec	number_of_transfers+1
"		tra	l1-*,ic
"		tra	l2-*,ic
"		...
"
on_gosub_op:
	ufa	=35b25,du		fix number in al
	tmoz	on_error
	eppab	text_base_ptr,*7
	cmpa	ab|0
	tpnz	on_error		make sure number in range
	eppbp	ab|0,al		get ptr to transfer
	adwpbp	bp|0		remove ic modification
	lda	ab|0		get number of transfers
	eax7	ab|0,al		compute return point
	tra	gosub_op		and join gosub code
"
"	subprogram call operator
"		epp1	subprogram_name
"		tsx7	call_op
"		vfd	18/2*n_args,54/0
"		itb	arg1
"		itb	arg2
"		...
"		itb	argn
"	where byte1 of word1 of itb gives arg type
"
sub_call_op:
std_sub_call_op:
	lda	1|0		is string constant
	cana	=o777777,du
	tze	sco1		yes, skip
	epbp1	string_segment,*	get ptr to beg of string segment
	epp1	1|0,au		get ptr to string value
	epp1	1|1
	lda	1|0		get string length
sco1:	spri1	print_using_ptr	save ptr to name of entry
"
"	pr1 points at name of entry to be called, length of name in al
"	search definitions chain of this segment first
"
	lprp2	definitions	get ptr to definitions
	ldx2	2|def_head.forward	get offset of first def
check_def:
	ldq	2|def.flags,2
	canq	def_flag.entry,dl	skip if not entry def
	tze	next_def
	ldx3	2|def.symbol,2	get ptr to acc for symbol
	epp3	2|0,3
	ldq	3|0		extract acc size
	qrs	27
	cmpc	(pr,rl),(pr,rl),fill(blank)	check names
	desc9a	1|1,al
	desc9a	3|0(1),ql
	tnz	next_def
"
"	found the definition, make sure class = 0
"
	ldq	2|def.class,2
	anq	7,dl
	tnz	next_def
	ldq	2|def.value,2	get ptr to entry
	epp2	text_base_ptr,*qu
	tra	have_entry
"
"	go on to next definition
"
next_def:	ldx2	2|def.forward,2
	szn	2|0,2		is this trailer of 0
	tnz	check_def		no, keep looking
"
"	call runtime to find entry
"
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_find_proc_>|[basic_find_proc_](runtime_arglist)
	epplp	program_header,*
	cmpq	0,dl
	tnz	subprogram_not_found
"
"	ptr to entry is in pr2, special handling needed if not BASIC
"	check number of arguments supplied against number wanted
"
have_entry:
	epp0	text_base_ptr,*7	get ptr to arglist
	eax1	ignore_handler
	orsx1	flags		calling prog not interested in conditions
	lxl0	2|0		get opcode from entry word
	cmpx0	eax7,du		is this eax7
	tnz	not_basic		no, can't possibly be basic
	lda	2|-1		get word containing descriptor in upper
	cana	=o400000,dl	is this basic entry
	tze	not_basic
	lda	2|3		basic, get ptr to program header of new entry
	epp1	2|-1,al
	lxl0	1|bph.incoming_args	get 2*n_args wanted
	cmpx0	0|0		compare with number supplied
	tnz	wrong_number_of_args
	ldx0	1|bph.incoming_args	get ptr to arg type array
	epp1	1|0,0
"
"	extend our stack frame to include all of frame of called sub
"
	segdef	call_op_begin	denotes section of code where x7 nonvalid
call_op_begin:
	ldx7	2|0		get stack size
	eax3	pdl_size+math_block_size+fn_size,7	ead space for pdl and fn frames
	epp3	sb|stack_header.stack_end_ptr,*
	epp4	3|0,3
	spri4	sb|stack_header.stack_end_ptr
	spri4	sp|stack_frame.next_sp
	spri4	pr3|stack_frame.next_sp	set now so we can reuse pr4
"
"	pr3 points at where new frame will be, sp still points at old frame
"	now copy args into new frame and check type of each arg as we do it
"	Note: pr5, x4 and x6 may be referenced by arg ITB(s)
"
	eax0	0
	eax1	0
arg_copy:
	cmpx0	0|0		are we done
	tpl	arg_copy_done	yes
	epp4	0|2,0		get ptr to arg ITB pair
	cmpc	(pr),(pr,x1)	check arg type
	desc9a	pr4|0(1),1
	desc9a	pr1|0,1
	tnz	wrong_arg_type	error if mismatch
	epp4	pr4|0,*		arg ok, get ptr to arg
	spri4	3|args,0		store ptr in new frame
	adx0	2,du		update for next arg
	adx1	1,du
	tra	arg_copy		and repeat until done
arg_copy_done:
	epp4	0|2,0		get ptr to return location
	spri4	temp3		save for use when we return
	epp4	sp|0		save ptr to current stack frame
	epp2	2|3		fake "tsp2" for subsequent entry code
	sprisp	3|stack_frame.prev_sp	set up new frame
	spri3	sp|stack_frame.next_sp
	segdef	new_frame		denotes section where in new stack
new_frame:
	eppsp	3|0		stack frame now belongs to called sub
	stz	flags		clear flags
	spri0	sp|stack_frame.arg_ptr
	stz	temp1
	stx0	temp1		save 2*n_args in upper
	eaq	-args,7		compute number of words to zero
	sbq	temp1		adjusting for ptr words
	tze	sub_go		skip if nothing to zero
	epp1	sp|args,0
	qls	2
	mlr	(),(pr,rl),fill(0)
	vfd	36/0
	desc9a	1|0,qu
"
sub_go:	sreg	sp|stack_frame.regs
	stcd	pr4|stack_frame.return_ptr	set real return ptr in old frame
	tra	init_stack	join standard entry sequence
	segdef	call_op_end
call_op_end:
"
"	control returns here after subprogram finishes, return to real caller
"
sub_done:	epp4	program_header,*
	ldx3	pr4|bph.string_storage
	epp5	sp|0,3			load to start of string vars
	ldx5	pr4|bph.precision_ind
	xec	load_op_tbl_ptr,5
	lreg	sp|stack_frame.regs
	eax1	use_handler		turn off ignore flag
	ansx1	flags		so we will handle conditions again
	tra	temp3,*
"
"
"	this procedure being called is not written in basic, we'll have to
"	generate a standard Multics argument list.  extend stack by enough
"	to hold an arg pointer and a desc pointer for each argument.
"
not_basic:
	lda	0|0		get number of args * 2
	tze	no_args		easy if no args
	epp3	sb|stack_header.stack_end_ptr,*
	epp1	3|2,au		get ptr to where descriptor ptrs will go
	als	1
	ada	2+15,du		form 4*n_args+2 and make multiple of 16
	ana	=o7777760,du
	sta	fn_temp1		save size of extension in upper
	asa	sb|stack_header.stack_end_ptr+1  extend stack
	asa	sp|stack_frame.next_sp+1
"
"	at this point:
"		pr0 -> arg list in basic program
"		pr1 -> where descriptors should go
"		pr2 -> entry point of procedure being called
"		pr3 -> where argument list should go
"		pr5 -> where string variables are stored
"
	spri2	temp3		save so can use pr2 as a temp
	eax0	0		init arg copy loop
	eax1	0		amount of free space is 0
	ldx5	4|bph.precision_ind
"
ac_loop:	cmpx0	0|0		have all args been copied?
	tpl	ac_done		yes, skip
	ldq	0|2,0		extract arg type code
	qrl	18
	anq	=o77,dl
	epp2	0|2,0*		get ptr to basic arg
	tra	*-1,ql		dispatch to handle arg type
	tra	n_scalar
	tra	s_scalar
	tra	n_list
	tra	s_list
	tra	n_table
	tra	s_table
	tra	n_fun
	tra	s_fun
	tra	file
"
"	arg is numeric scalar, pass ptr directly to arg and use
"	constant float bin(27) descriptor
"
n_scalar:	spri2	3|2,0		save arg ptr
	epp2	float_bin_desc,5
	spri2	1|0,0		save desc ptr
	adx0	2,du		go do next arg
	tra	ac_loop
"
"	arg is string scalar, treat as char(*) where * is
"	current length
"
s_scalar:	ldq	66,dl		go call runtime to make string value unique
	sprp4	fn_temp2	
	epp4	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	lprp4	fn_temp2	
	lda	pr2|0		get string word
	epbp2	string_segment,*	get ptr to beg of string segment
	epp2	pr2|0,au		get ptr to string block
	epp2	pr2|2		get ptr to chars
	spri2	pr3|2,0		save arg ptr
	cmpx1	1,du		is there one word in free block
	tpl	2,ic		yes, skip
	tsx2	extend_by_16	no, extend stack by 16
	ldq	pr2|-1		get string length
	orq	char_type,du	make descriptor
	stq	4|0		save descriptor in free space
	spri4	1|0,0		store ptr to descriptor
	epp4	4|1		update free space ptr
	sbx1	1,du		and free space count
	adx0	2,du		go do next arg
	tra	ac_loop
"
"	arg is numeric list, treat as (*) float bin
"
n_list:	cmpx1	4,du		are there 4 words free
	tpl	2,ic
	tsx2	extend_by_16	no, extend stack by 16
	ldq	float_bin_desc,5
	orq	dim_1,du		insert dim flag in descriptor
	stq	4|descriptor.type
	stz	4|descriptor.lower_1	lb1 = 0
	ldq	pr2|array_dope.current_bounds
	sbq	1,dl
	stq	4|descriptor.upper_1	ub1 = our upper bound
	xec	s1b,5
	stq	4|descriptor.multiplier_1	m1 = 1
	spri4	1|0,0		save ptr to descriptor
	epp4	4|4		adjust free space
	sbx1	4,du
n_list_1:	epp2	pr2|array_dope.data,*	get ptr to data
	spri2	3|2,0		save arg ptr
	adx0	2,du		update for next arg
	tra	ac_loop
s1b:	ldq	1,dl
	ldq	2,dl
"
"	arg is numeric table, treat as(*,*) float bin
"
n_table:	cmpx1	7,du		are there 7 words free
	tpl	2,ic
	tsx2	extend_by_16	no, extend stack by 16
	ldq	float_bin_desc
	orq	dim_2,du		insert dim flag in descriptor
	stq	4|descriptor.type
	stz	4|descriptor.lower_1	lb1 = 0
	ldq	pr2|array_dope.current_bounds+1
	qls	0,5
	stq	4|descriptor.multiplier_2	m2 = ub1 + 1
	qrs	0,5
	sbq	1,dl
	stq	4|descriptor.upper_1	ub1 = our 2nd upper
	xec	s1b,5
	stq	4|descriptor.multiplier_1	m1 = 1
	stz	4|descriptor.lower_2	lb2 = 0
	ldq	pr2|array_dope.current_bounds
	sbq	1,dl
	stq	4|descriptor.upper_2	ub2 = our 1st upper
	spri4	1|0,0		save ptr to descriptor
	epp4	4|7		update free space
	sbx1	7,du
	tra	n_list_1
"
"	extend stack by 16 words
"
extend_by_16:
	epp4	sb|stack_header.stack_end_ptr,*  get ptr to end of stack
	eax1	16		extend stack by 16 words
	asx1	sb|stack_header.stack_end_ptr+1
	asx1	sp|stack_frame.next_sp+1
	asx1	fn_temp1		remember additional exension
	tra	0,2		return
"
"	a string list or table is invalid
"
s_list:
s_table:	ldq	153,dl
	tra	error2
"
"	a string or numeric function is invalid
"
n_fun:
s_fun:	ldq	154,dl
	tra	error2
"
"	a file is invalid
"
file:	ldq	155,dl
	tra	error2
"
"	all args have been copied, finish up new arg list and make call
"
ac_done:	lda	0|0		get 2*n_args
	eaq	0,au		indicate descriptors present
	ora	4,dl		insert pl1 code
	staq	3|0		set head of new arg list
	epp2	pr3|0		get ptr to new arg list in temp
	epp3	pr0|2,0		get ptr to return point
	epp0	pr2|0		copy ptr to new arg list
	epp2	temp3,*		restore pr2 for actual call
non_basic_go:
	spri3	temp3
	sreg	sp|stack_frame.regs
	stcd	sp|stack_frame.return_ptr
	callsp	2|0		jump to proc
"
"	return from called proc
"
	lcx0	fn_temp1		get - extension size
	asx0	sb|stack_header.stack_end_ptr+1  remove stack extension
	asx0	sp|stack_frame.next_sp+1
	tra	sub_done
"
"	call has no args
"
no_args:	epp3	pr0|2		get ptr to real return pt
	stz	fn_temp1		stack not extended
	tra	non_basic_go	use same arg ptr
"
float_bin_desc:
	oct	414000000033
	oct	420000000077
"
wrong_number_of_args:
	ldq	150,dl
	tra	error2
"
wrong_arg_type:
	ldq	151,dl
"
error2:	stq	number
	epp1	print_using_ptr,*	get ptr to name of subprogram
	ldq	2,dl
	tsx0	invoke_runtime
	tra	stop_op
"
subprogram_not_found:
	ldq	152,dl
	tra	error2
"
"	operator to do gosub return
"
return_op:
	ldq	pdl,di		pop pdl
	tnz	text_base_ptr,*qu	it is return point if non-zero
"
	ldq	102,dl		error, return without gosub
	tra	error1		go print error and abort run
"
sub_exit_op:
	tra	not_yet
"
	new_fun_call_op	sp_,1,fst,18
"
fn_call_error:
	ldq	128,dl
	tra	error1
"
"
	new_global_fun_call_op	sp_
"
	new_fun_return_op	sp_,1,fld
"
fn_return_error:
	ldq	129,dl
	tra	error1
"
	list_sub_op	sp_
"
	table_sub_op	sp_
"
	inv_table_sub_op	sp_
"
subscript_error:
	ldq	100,dl
"
error1:	stq	number
	ldq	2,dl
	tsx0	invoke_runtime
	tra	stop_op
"
error_in_statement:
	ldq	111,dl
	tra	error1
"
missing_line:
	ldq	112,dl
	tra	error1
"
unclosed_for:
	ldq	113,dl
	tra	error1
"
undefined_function:
	ldq	127,dl
	tra	error1
"
"	I/O operations
"
use_tty:
	ldx5	=0,du
	sxl5	file_number
	lprpbp	fcb		set fcb_pt
	spribp	fcb_pt
	tra	text_base_ptr,*7
"
"	operator to set up fcb, entered with file number in eaq
"
setup_fcb:
	ufa	=35b25,du		fix file number
	tmi	invalid_file_number
	cmpa	16,dl		complain if bad
	tpnz	invalid_file_number
	eax5	0,al
	sxl5	file_number
	ldq	fcb,al
	cmpq	=o007777000001
	tze	invalid_file_number	error if null
	lprpbp	fcb,al
	spribp	fcb_pt		set fcb_pt
	tra	text_base_ptr,*7		and return
"
"	operator to store ptr to parameter fcb.  entered with fcb ptr
"	in pr2 and file number in eaq
"
use_fcb:
	ufa	=35b25,du
	sprpbp	fcb,al
	tra	text_base_ptr,*7
"
invalid_file_number:
	ldq	135,dl
	tra	error1
"
"	operator to scratch file
"
scratch:
	ldq	31,dl
	tra	call_runtime
"
"	operator to set file margin, entered with margin in eaq
"
margin:
	fst	temp1
	ldq	30,dl
	tra	call_runtime
"
"	reset reading of data
"
reset_data:
	eppab	program_header,*
	tsx0	init_data
	tra	text_base_ptr,*7
"
"	operator to write numeric value in eaq into random file
"
numeric_write:
	dfst	temp1
	ldq	34,dl
	tra	call_runtime
"
"	operator to write string value specified by ab into random file
"
string_write:
	ldq	36,dl
	tra	call_runtime
"
	numeric_read	sp_,fld
"
	numeric_data_read	sp_,fld,1
"
out_of_data:
	ldq	103,dl		go print error and abort trun
	tra	error1
"
"	operator to read string value, return string ptr in ab
"
string_read:
	ldq	37,dl		reading random file
	tra	call_runtime
"
new_string_data_read:
	lxl0	string_data_pos
	cmpx0	string_data_pos
	trc	out_of_data
	ldq	text_base_ptr,*0
	adx0	1,du
	sxl0	string_data_pos
	eppab	program_header,*ql
	tra	text_base_ptr,*7
"
"	print numeric value in eaq
"
numeric_print:
	dfst	temp1
	ldq	3,dl
"
call_runtime:
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	tra	text_base_ptr,*7
"
string_print:
	ldq	4,dl
	tra	call_runtime
"
"	finish current line
"
print_new_line:
	ldq	7,dl
	tra	call_runtime
"
"	move to next column which is multiple of 15
"
tab_for_comma:
	ldq	5,dl
	tra	call_runtime
"
"	tab to column whose value is in eaq
"
tab_fun:
	fst	temp1
	ldq	8,dl
	tra	call_runtime
"
"	space by number of columns given in eaq
"
spc_fun:
	fst	temp1
	ldq	9,dl
	tra	call_runtime
"
	numeric_input	sp_,fld
"
"	input string value, pointer to result left in ab
"
string_input:
	ldq	15,dl
	tra	call_runtime
"
linput:
	ldq	13,dl
	tra	call_runtime
"
"	terminate current input statement
"
end_input:
	ldq	16,dl
	tra	call_runtime
"
lof_fun:
	fst	temp1
	ldq	38,dl
	tra	pos1
"
loc_fun:
	fst	temp1
	ldq	39,dl
	tra	pos1
"
mar_fun:
	fst	temp1
	ldq	40,dl
	tra	pos1
"
check_eof:
	fst	temp1
	ldq	41,dl
	tra	pos1
"
per_fun:
	fst	temp1
	ldq	64,dl
	tra	pos1
"
typ_fun:
	fst	temp1
	ldq	42,dl
	tra	pos1
"
print_using_start:
	ldq	56,dl
	tra	call_runtime
"
print_using_end:
	ldq	59,dl
	tra	call_runtime
"
	print_using_numeric	sp_,fst
"
print_using_string:
	ldq	58,dl
	tra	call_runtime
"
"	hps
"
hps_fun:
	fst	temp1
	ldq	25,dl
	tra	pos1
"
lin_fun:
	tra	not_yet
"
"	tst(a$)
"
tst_fun:
	ldq	26,dl
	tra	pos1
"
num_fun:
	lda	number_read
	tra	len1
"
"	operator to "open" file, entered with file name specified by pr(1)
"	and file number in eaq
"
file_fun:
	fst	temp1
	ldq	29,dl
	tra	call_runtime
"
reset_ascii:
	ldq	32,dl
	tra	call_runtime
"
reset_random:
	lxl5	file_number	file 0 means internal data
	tze	reset_data
	fst	temp1
	ldq	33,dl
	tra	call_runtime
"
end_print:
	ldq	6,dl
	tra	call_runtime
"
"	Numeric functions
"
"	absolute value
"		fld	x
"		tsx7	abs_fun
"
abs_fun:
	fad	=0.0,du		make sure indicators are set right
	tpl	text_base_ptr,*7
	fneg	0
	tra	text_base_ptr,*7
"
"	integer part
"		fld	x
"		tsx7	int_fun
"
int_fun:
	fst	temp1		save for range check
	ufa	=71b25,du		get integer in AQ
	fad	=71b25,du		float again
	tnz	text_base_ptr,*7	if non-zero, all done
	fld	temp1		must check arg for range -.5 to 0
	tmi	3,ic		if arg negative, answer is -1.0
	fld	=0.0,du		answer is really 0.0
	tra	text_base_ptr,*7	return
	fld	=-1.0,du
	tra	text_base_ptr,*7	return
"
	mod_fun	sp_,fst,fdi,fmp,fad
"
randomize:
	epplp	sp|stack_frame.lp_ptr,*
	call	<clock_>|[clock_](arglist1)
	epplp	program_header,*
	ldq	temp1+1		use low-order clock value
	stq	random
	tra	text_base_ptr,*7	and return
"
"	operator to return pseudo-random number in eaq
"
rnd_fun:
	ldq	random		get last random number
	mpy	random_multiplier
	adl	random_addend
	cmpq	0,dl
	tpl	2,ic		make sure it is positive
	erq	=o400000,du
	stq	random		save for next time
	lda	0,dl		treat as binary fraction
	lde	=36b25,du
	fad	=0.0,du		float it
	tra	text_base_ptr,*7	and return
"
"	signum
"		fld	x
"		tsx7	sgn_fun
"
sgn_fun:
	tze	text_base_ptr,*7
	tmi	3,ic
	fld	=1.0,du
	tra	text_base_ptr,*7
	fld	=-1.0,du
	tra	text_base_ptr,*7
"
tim_fun:
	epplp	sp|stack_frame.lp_ptr,*
	call	<virtual_cpu_time_>|[virtual_cpu_time_](arglist1)
	epplp	program_header,*
	ldaq	temp1
	sbaq	cpu_start
	lde	=71b25,du
	fad	=0.0,du
	fdv	=1.0e6
	tra	text_base_ptr,*7
"
	val_fun	sp_
"
	math_functions	sp_
"
	power_functions	sp_,fst,fld
"
"	matrix functions
"
det_fun:
	szn	determinant	make sure inv was called
	tze	array_error
	dfld	determinant
	tra	text_base_ptr,*7
"
array_error:
	ldq	139,dl
	tra	error1
"
	zer_con_funs	sp_,fld,(=0.0,du),(=1.0,du),fst,1
"
	idn_fun	sp_,fld,fst,1
"
	mat_assign_numeric	sp_,fld,fst,1
"
"	operator to do
"		mat a$ = b$
"
mat_assign_string:
	ldaq	1|array_dope.current_bounds
	cmpq	0,dl
	tmi	string_list_assign
	mpy	1|array_dope.current_bounds+1
	stq	temp3
	ldq	2|array_dope.original_bounds
	mpy	2|array_dope.original_bounds+1
	cmpq	temp3
	tmi	redim_error
	ldaq	1|array_dope.current_bounds
	staq	2|array_dope.current_bounds
mas:	ldq	63,dl
	tra	call_runtime
"
string_list_assign:
	cmpa	2|array_dope.original_bounds
	tpnz	redim_error
	sta	2|array_dope.current_bounds
	tra	mas
"
	mat_add_sub	sp_
"
	mat_scalar_mult	sp_,fst
"
	dot_product	sp_,1,fld,fmp,fcmp
"
"	operator to do
"		mat A = inv(B)
"
inv_fun:
	ldq	1|array_dope.current_bounds
	cmpq	1|array_dope.current_bounds+1
	tnz	array_error	must be sequare
	mpy	1|array_dope.current_bounds+1
	stq	temp3
	ldq	2|array_dope.original_bounds
	mpy	2|array_dope.original_bounds+1
	cmpq	temp3
	tmi	redim_error
	ldaq	1|array_dope.current_bounds
	staq	2|array_dope.current_bounds
	ldq	1,dl
"
call_matrix:
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_matrix_>|[basic_matrix_](runtime_arglist)
	epplp	program_header,*
	cmpq	0,dl
	tnz	error1
	tra	text_base_ptr,*7
"
	trn_fun	sp_
"
"	operator to do
"		mat A = B * C
"	when A and B are vectors and C is a matrix
"
mat_mult_vm:
	ldq	1|array_dope.current_bounds
	cmpq	3|array_dope.current_bounds
	tnz	array_error
	ldq	3|array_dope.current_bounds+1
	cmpq	2|array_dope.original_bounds
	tpnz	redim_error
	stq	2|array_dope.current_bounds
	ldq	3,dl
	tra	call_matrix
"
"	operator to do
"		mat A = B * C
"	when A and C are vectors and B is a matrix
"
mat_mult_mv:
	ldq	1|array_dope.current_bounds+1
	cmpq	3|array_dope.current_bounds
	tnz	array_error
	ldq	1|array_dope.current_bounds
	cmpq	2|array_dope.original_bounds
	tpnz	redim_error
	stq	2|array_dope.current_bounds
	ldq	4,dl
	tra	call_matrix
"
"	operator to do
"		mat A = B * C
"	when A, B and C are all matrices
"
mat_mult_mm:
	ldq	1|array_dope.current_bounds+1
	cmpq	3|array_dope.current_bounds
	tnz	array_error
	ldq	1|array_dope.current_bounds
	mpy	3|array_dope.current_bounds+1
	stq	temp3
	ldq	2|array_dope.original_bounds
	mpy	2|array_dope.original_bounds+1
	cmpq	temp3
	tmi	redim_error
	lda	1|array_dope.current_bounds
	ldq	3|array_dope.current_bounds+1
	staq	2|array_dope.current_bounds
	ldq	5,dl
	tra	call_matrix
"
nul_fun:
	ldq	62,dl
	tra	call_runtime
"
"	operator to redimension list
"		epp2	dope
"		fld	new_bound
"		tsx7	list_redim
"
list_redim_op:
	ufa	=35b25,du		fix bound
	tmoz	redim_error
	ada	1,dl		get number of elements
	cmpa	bp|array_dope.original_bounds
	tpnz	redim_error
	sta	bp|array_dope.current_bounds
	tra	text_base_ptr,*7
"
redim_error:
	ldq	137,dl
	tra	error1
"
"	operator to redimension table
"		epp2	dope
"		fld	new_bound1
"		tsx7	table_redim
"		fld	new_bound2
"
table_redim_op:
	ufa	=71b25,du
	tmoz	redim_error
	adq	1,dl
	stq	temp1
	xec	text_base_ptr,*7
	ufa	=71b25,du
	tmoz	redim_error
	adq	1,dl
	stq	temp2
	mpy	temp1
redim:	stq	temp3
	ldq	bp|array_dope.original_bounds
	mpy	bp|array_dope.original_bounds+1
	cmpq	temp3
	tmi	redim_error
	lda	temp1
	ldq	temp2
	staq	bp|array_dope.current_bounds
	adx7	1,du
	tra	text_base_ptr,*7
"
"	operator to redimension table inversely
"		epp2	dope
"		fld	new_bound2
"		tsx7	inv_table_redim
"		fld	new_bound1
"
inv_table_redim_op:
	ufa	=71b25,du
	tmoz	redim_error
	adq	1,dl
	stq	temp2
	xec	text_base_ptr,*7
	ufa	=71b25,du
	tmoz	redim_error
	adq	1,dl
	stq	temp1
	mpy	temp2
	tra	redim
"
"	matrix I/O operators entered with pr2 -> dope
"
mat_numeric_input:
	ldq	45,dl
	tra	mnp
"
mat_string_input:
	ldq	46,dl
	tra	mnp
"
mat_numeric_print:
	ldq	47,dl
mnp:	lda	text_base_ptr,*7	get format control | redim switch
	tsx0	invoke_runtime
	adx7	1,du
	tra	text_base_ptr,*7
"
mat_string_print:
	ldq	48,dl
	tra	mnp
"
mat_numeric_read:
	ldq	49,dl
	tra	call_runtime
"
mat_string_read:
	ldq	50,dl
	tra	call_runtime
"
mat_numeric_write:
	ldq	51,dl
	tra	call_runtime
"
mat_string_write:
	ldq	52,dl
	tra	call_runtime
"
mat_linput_op:
	ldq	55,dl
	tra	call_runtime
"
mat_numeric_data_read:
	ldq	53,dl
	tra	call_runtime
"
mat_string_data_read:
	ldq	54,dl
	tra	call_runtime
"
mat_print_using_numeric:
	ldq	60,dl
	tra	call_runtime
"
mat_print_using_string:
	ldq	61,dl
	tra	call_runtime
"
"	operator to reset default number length
"
setdigits_op:
	ufa	=35b25,du		convert to integer
	tmoz	invalid_number_length
	cmpa	19,dl
	tpnz	invalid_number_length
	eax1	0,al
	sxl1	flags
	tra	text_base_ptr,*7
"
invalid_number_length:
	ldq	166,dl
	stq	number
	ldq	2,dl
	tra	call_runtime
"
string_data_read:
	lxl0	string_data_pos
	cmpx0	string_data_pos
	trc	out_of_data
	ldq	text_base_ptr,*0
	adx0	1,du
	sxl0	string_data_pos
	eppab	text_base_ptr,*ql
	tra	text_base_ptr,*7
"
not_yet:	ldq	99,dl
	tra	error1
"
	segdef	enter_proc
enter_proc:
	lda	=o400000,du	indicate called from non-basic
	eaq	0,7		don't get extra space at end of frame
	tra	save
"
	segdef	enter_main
enter_main:
	lda	=o200000,du	indicate main program
	eaq	pdl_size+math_block_size+fn_size,7	add extra space at end of frame
"
save:	eppbb	sb|stack_header.stack_end_ptr,*
	sprisp	bb|stack_frame.prev_sp
	eppab	bb|0,qu
	spriab	bb|stack_frame.next_sp
	spriab	sb|stack_header.stack_end_ptr
	eppsp	bb|0
	spriap	sp|stack_frame.arg_ptr
	sta	flags		initialize flags
"
"	zero out user area in stack
"
	eaq	-args,7		compute number of words to zero
	tze	init_stack	skip if no variables
	qls	2		get number of chars
	mlr	(),(pr,rl),fill(0)
	vfd	36/0
	desc9a	sp|args,qu
"
"	setup entry ptr and language type code in stack frame
"
init_stack:
	eawpbp	bp|-3
	spribp	sp|stack_frame.entry_ptr
	spbpbp	text_base_ptr
	lda	5,du
	sta	sp|stack_frame.translator_id
"
"	setup ptr to basic program header 
"
	lda	bp|3
	eppab	bp|-1,al
	spriab	program_header
	eaa	ab|0		save in case program is bound
	sta	program_header_offset
"
"	initialize precision indicator
"
	ldx5	1,du
	adx5	ab|bph.precision_ind
	stx5	file_number
	sbx5	1,du		restore precision indicator
"
"	initialize digit count
"
	ldx1	6,du
	sxl1	flags
"
"	get ptr to definitions section
"
	lxl1	ab|bph.definitions
	tze	3,ic		zero means regular object
	eppap	ab|0,1		non-zero means defs relative to header
	tra	4,ic
	epaq	ab|0		have object segment, get linkage ptr
	lprplp	sb|stack_header.lot_ptr,*au
	eppap	lp|0,*		get ptr to defs from head of linkage
	sprpap	definitions	save definitions ptr
"
"	store ptr to acc string giving name of this subprogram
"
	lda	bp|-1		get def offset in au
	lda	ap|def.symbol,au	get acc offset in au
	epp4	ap|0,au		get ptr to acc
	sprp4	entryname		and save
"
"	store ptr to our linkage section
"
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	sprilp	sp|stack_frame.lp_ptr
"
"	set up abort label
"
	eppap	stop_op
	spriap	abort_label
	sprisp	abort_label+2
"
"	initialize conversion_label & size_label to "null"
"
	stz	conversion_label
	stz	size_label
"
"	establish default handler and cleanup procedures
"
	eaa	sp|0		get offset of this frame
	neg	0		get -offset
	eppbb	on_units		get ptr to first unit
	stz	bb|on_next	clear next ptr
	eppap	cleanup		fill in name
	spriap	bb|on_name
	ldq	7,dl		and length
	stq	bb|on_size
	eppap	<basic_runtime_>|[cleanup]	fill in body ptr
	spriap	bb|on_body
	eax2	bb|0,au		get offset of this unit relative to frame
	eppbb	bb|6		get ptr to next unit
	stz	bb|on_next	set next ptr
	stx2	bb|on_next
	eppap	unclaimed_signal	fill in name
	spriap	bb|on_name
	ldq	16,dl		and length
	stq	bb|on_size
	eppap	<basic_runtime_>|[default]	fill in body ptr
	spriap	bb|on_body
	eax2	bb|0,au		get offset of this unit relative to frame
	stz	sp|stack_frame.on_unit_rel_ptrs
	stx2	sp|stack_frame.on_unit_rel_ptrs	establish chain
	lda	=o100,dl		turn on flag that says chain exists
	orsa	sp|stack_frame.prev_sp
"
"	setup arglist for use in calling basic_runtime_ & basic_matrix_
"	and arglist for calling virtual_cpu_time_
"
	eppap	temp1
	spriap	arglist1+2
	eppap	abort_label+2
	spriap	runtime_arglist+2
	fld	1*2048,dl
	staq	arglist1
	staq	runtime_arglist
"
"	call basic_runtime_ to do any further initialization
"
	ldq	0,dl
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
"
"	set up array dope
"
	lda	ab|bph.numeric_arrays
	tsx0	setup_arrays
	lda	ab|bph.string_arrays
	tsx0	setup_arrays
"
"	initialize random number generator
"
	lda	initial_random
	sta	random
"
"	indicate inv not called
"
	stz	determinant
"
"	init num function
"
	stz	number_read
"
"	convert arg list if we were called from non-basic program
"
	szn	flags
	tmi	call_from_non_basic
"
"	set up push down list at end of stack
"
setup_pdl:
	eppap	sp|0,7		get ptr to start of pdl
	eaa	ap|0		get offset
	ora	pdl_size*64,dl	form tally word
	sta	pdl		and save
"
"	store word of zeros so we can detect return without gosub
"
	stz	pdl,id
"
"	initialize math block and function frame area
"
	eaa	sp|0		get offset of this stack frame
	sta	temp1		and save
	eppap	ap|pdl_size	get ptr to end of pdl
	sprpap	math_block	save ptr to math block
	eppap	ap|math_block_size	skip over math block
	eaa	ap|0		get offset
	sba	temp1		relative to start of frame
	sta	next_frame
	ada	fn_size,du
	sta	last_frame
"
"	initialize numeric and string data position
"
	tsx0	init_data
"
"	all done with initialization, start user program
"
	call	<virtual_cpu_time_>|[virtual_cpu_time_](arglist1)
	ldaq	temp1
	staq	cpu_start
"
"
	epplp	program_header,*
	ldx3	pr4|bph.string_storage
	epp5	sp|0,3		load ptr to start of string variables
	ldx5	pr4|bph.precision_ind
	xec	load_op_tbl_ptr,5	get ptr to correct op table
	eax4	0		init fn display
	eax6	0		init fn frame offset
	tra	bp|4		start program
"
load_op_tbl_ptr:
	epp0	sp_operator_table
	epp0	ep_operator_table
"
call_from_non_basic:
	stz	fn_temp1		init extension count
	lxl0	1|bph.incoming_args	get number of args expected * 2
	tze	args_thru		trivial if no args expected
	epp0	sp|stack_frame.arg_ptr,*	get ptr to our arglist
	cmpx0	0|0		compare against number provided
	tnz	incorrect_number_of_args	complain if wrong number of args
	ldq	0|1		are descriptors present
	tze	no_descriptors	no, complain
	epp3	0|2,qu		get ptr to start of descriptors
	lxl0	0|0		is there an extra ptr in arglist
	canx0	8,du
	tze	2,ic
	epp3	3|2		yes, skip over extra ptr
	ldx0	1|bph.incoming_args	get ptr to arg type array
	epp1	1|0,0
	eax0	0		init list position
	eax1	0		zero free space initially
	eax3	-1		init arg count
"
"	at this point
"		pr0 -> arglist
"		pr3 -> descriptors
"	process each arg and convert to appropriate basic type
"
loop_ac:	cmpx0	0|0		are we done with args
	tpl	args_done		yes, go finish up
	adx3	1,du		update arg position
	epp5	3|0,0*		get ptr to descriptor
	ldx4	5|0		get lhs of descriptor
	mrl	(pr,x3),(pr),fill(0)	extract type code for this arg
	desc9a	1|0,1
	desc9a	fn_temp2,4
	lda	fn_temp2		get expected type
	tra	*-1,al		and dispatch on it
	tra	scalar_n
	tra	scalar_s
	tra	list_n
	tra	list_s
	tra	table_n
	tra	table_s
	tra	fun_n
	tra	fun_s
	tra	file1
"
"	all args transformed, update x7 by amount stack was extended
"	extend stack to get space for pdl, math block, and functions
"	and rejoin normal code
"
args_done:
	epp1	program_header,*	restore program header ptr
	epp2	sp|stack_frame.entry_ptr,*	restore ptr to entry point
	epp4	sp|stack_frame.lp_ptr,*	restore ptr to our linkage
"
args_thru:
	adx7	fn_temp1
	eax1	pdl_size+math_block_size+fn_size
	asx1	sb|stack_header.stack_end_ptr+1
	asx1	sp|stack_frame.next_sp+1
	tra	setup_pdl
"
"
"	expected arg is numeric scalar
"
scalar_n:
	cmpx4	n_scalar_type,du	check type from descriptor
	tnz	incorrect_arg_type
	epp5	0|2,0*		type ok, get ptr to variable
	spri5	sp|args,0		store ptr to arg
	adx0	2,du		and go do next arg
	tra	loop_ac
"
"	expected arg is string scalar
"
scalar_s:
	lda	5|0		get descriptor size
	ana	=o777777,dl
	epp2	0|2,0*		get ptr to characters
	cmpa	4096,dl		complain if length too long
	tpl	incorrect_arg_type
	cmpx1	2,du		get space for string word
	tpl	2,ic
	tsx2	extend_by_16
	sta	4|1		save descriptor size
	anx4	erase_packed_bit,du	erase packed bit in descriptor lhs
	cmpx4	char_type,du	skip if arg is non-varying
	tze	convert_string
	cmpx4	vs_char_type,du	complain if not varying
	tnz	incorrect_arg_type
"
"	arg is varying char string
"
	lda	2|-1		get current length
	eax4	1		remember varying
	stx4	4|1
"
convert_string:
	spri4	sp|args,0		args is our string word
	sbx1	2,du		account for space
	ldq	65,dl		go to run-time to make string value
	sprp1	fn_temp2		pr1 will get changed by basic_runtime_, so save it
	epp4	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epp4	sp|args,0*		restore free ptr
	epp0	sp|stack_frame.arg_ptr,*	restore arglist ptr
	ldq	1|0		get string word
	stq	4|0		and save
	stz	1|0		prevent deallocation
	lprp1	fn_temp2
	epp4	4|2		account for space
	adx0	2,du		and go do next arg
	tra	loop_ac
"
"	arg is numeric list
"
list_n:	cmpx4	n_list_type,du	check type
	tnz	incorrect_arg_type
	ldq	5|descriptor.multiplier_1	make sure array is connected
	cmpq	1,dl
	tnz	incorrect_arg_type
	lda	5|descriptor.upper_1	fill in bounds
	sba	5|descriptor.lower_1
	ada	1,dl
	lcq	1,dl
set_dope:
	cmpx1	6,du		get dope space
	tpl	2,ic
	tsx2	extend_by_16
	staq	4|array_dope.original_bounds
	staq	4|array_dope.current_bounds
	epp2	0|2,0*		get ptr to data
	spri2	4|array_dope.data	save in dope vector
	spri4	sp|args,0		arg points to dope vector
	epp4	4|6		account for free space used
	sbx1	6,du
	adx0	2,du		go do next arg
	tra	loop_ac
"
"	arg is numeric table
"
table_n:
	cmpx4	n_table_type,du	check type
	tnz	incorrect_arg_type
	ldq	5|descriptor.multiplier_1	make sure array is connected
	cmpq	1,dl
	tnz	incorrect_arg_type
	ldq	5|descriptor.upper_1
	sbq	5|descriptor.lower_1
	adq	1,dl
	cmpq	5|descriptor.multiplier_2
	tnz	incorrect_arg_type
	lda	5|descriptor.upper_2
	sba	5|descriptor.lower_2
	ada	1,dl
	tra	set_dope
"
incorrect_number_of_args:
	ldq	160,dl
	tra	error3
"
incorrect_arg_type:
	ldq	161,dl
error3:	stq	number
	lprp1	entryname
	ldq	2,dl
	tsx0	invoke_runtime
	tra	stop_op
"
no_descriptors:
	ldq	162,dl
	tra	error3
"
list_s:
table_s:
	ldq	163,dl
	tra	error3
"
fun_n:
fun_s:
	ldq	164,dl
	tra	error3
"
file1:	ldq	165,dl
	tra	error3
"
"	int subroutine to setup array dope
"
setup_arrays:
	tze	0,0
	eppap	ab|0,au		get ptr to start of array_symbols
"
array_loop:
	lda	ap|0		get 1st word of array symbol
	tze	0,0		zero means done
	cana	array_symbol_param,dl
	tnz	next_array	skip if parameter
	epplb	sp|0,al		get ptr to array dope
	ldq	ap|array_symbol.offset
	eppbb	sp|0,ql		get ptr to actual data location
	spribb	lb|array_dope.data	set data ptr
	lda	ap|array_symbol.bounds	get bounds in upper,lower
	lrs	18		unpack
	qrs	18
	staq	lb|array_dope.current_bounds
	staq	lb|array_dope.original_bounds
next_array:
	eppap	ap|array_symbol_size	do next array symbol
	tra	array_loop
	segdef	end_entry_ops
end_entry_ops:
"
"	int subroutine to call runtime
"
invoke_runtime:
	epplp	sp|stack_frame.lp_ptr,*
	call	<basic_runtime_>|[basic_runtime_](runtime_arglist)
	epplp	program_header,*
	tra	0,0
"
"	int subroutine to initialize data reading
"
init_data:
	ldx1	ab|bph.numeric_data
	adx1	program_header_offset
	sxl1	numeric_data_pos
	lxl1	ab|bph.numeric_data
	adx1	ab|bph.numeric_data
	adx1	program_header_offset
	stx1	numeric_data_pos
"
	ldx1	ab|bph.string_data
	adx1	program_header_offset
	sxl1	string_data_pos
	lxl1	ab|bph.string_data
	adx1	ab|bph.string_data
	adx1	program_header_offset
	stx1	string_data_pos
"
	tra	0,0
"
"	constants for random number generator
"
initial_random:
	oct	201451444176
"
random_multiplier:
	dec	27182818285
"
random_addend:
	dec	31415926535
"
cleanup:	aci	"cleanup"
"
unclaimed_signal:
	aci	"unclaimed_signal"
"
" 	extended precision operators that are different from single precision operators
"
	string_assign	ep_,dfst,dfld
"
	max		ep_,dfst,dfcmp,dfld
"
	min		ep_,dfst,dfcmp,dfld
"
	new_fun_call_op	ep_,2,dfst,19
"
	new_global_fun_call_op	ep_
"
	new_fun_return_op	ep_,2,dfld
"
	list_sub_op	ep_
"
	table_sub_op	ep_
"
	inv_table_sub_op	ep_
"
	numeric_read	ep_,dfld
"
	numeric_data_read	ep_,dfld,2
"
	numeric_input	ep_,dfld
"
	print_using_numeric	ep_,dfst
"
	mod_fun		ep_,dfst,dfdi,dfmp,dfad
"
	val_fun	ep_
"
	math_functions	ep_
"
	power_functions	ep_,dfst,dfld
"
	zer_con_funs	ep_,eax0,load0,load1,dfst,2
"
	idn_fun		ep_,dfld,dfst,2
"
	mat_assign_numeric	ep_,dfld,dfst,2
"
	mat_add_sub	ep_
"
	mat_scalar_mult	ep_,dfst
"
	dot_product	ep_,2,dfld,dfmp,dfcmp
"
	trn_fun		ep_
"
	fun_call_op	sp_,1,fst,18
"
	global_fun_call_op	sp_
"
	fun_return_op	sp_,1,fld
"
	fun_call_op	ep_,2,dfst,19
"
	global_fun_call_op	ep_
"
	fun_return_op	ep_,2,dfld
"
	segdef	end_basic_operators
end_basic_operators:
	end




		    basic_runtime_.pl1              09/11/84  1252.9rew 09/11/84  1223.9      971685



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* Runtime system for Multics BASIC

   Initial Version: 12 November 1973 by BLW
	Modified: 20 January 1974 by BLW to use iox_
	Modified: 12 March 1974 by BLW to fix bug013 
	Modified: 17 March 1974 by BLW to fix bug015
	Modified: 28 March 1974 by BLW to fix bug022 
	Modified:  2 April 1974 by BLW to fix bug025 
	Modified: 22 April 1974 by BLW to fix bug026, bug027, bug028, and bug029
	Modified: 23 July 1974 by BLW to fix bugs 038 and 042
	Modified: 27 August 1974 by BLW to fix bug 047
	Modified: January 1976 by MBW to use iox_ more extensively
	Modified: May 1976 by MBW to add double precision capabilities
	Modified: 21 January 1977 by MBW to fix bug 064
	Modified:	18 February 1977 by MBW to fix bug 066
	Modified: 7 March 1977 by MBW to fix bug 067
	Modified: 6 July 1977 by MBW to fix bug 074
	Modified: 29 July 1977 by MBW to change file opening strategy
	Modified: 4 August 1977 by MBW to reset margins when changing file types
	Modified: 25 May 1978 by MBW to not reset tty margin automatically
	Modified: 29 December 1983 by MBW to fix switch(66) and to not try to close unused file
          Modified: 24 April 1984 by AH, 103: Fix the implied minus sign
                        in the PRINT USING statement.
	Modified: 15 May 1984 by DWL to document use of sst$ for mid$
	Modified: 22 May 1984 by DWL to add new switch 134 for left$
	Modified: 23 May 1984 by DWL to add new switch 135 for right$
	Modified: 28 May 1984 by DWL to fix ep error on switch 134 (201),
	          and switch 135 (202) for left$, right$
*/

basic_runtime_: proc(bo_stack_pt);

dcl	bo_stack_pt ptr;

dcl	(bo_pt,p1,p2,p3,p4,program_header_pt) ptr,
	ans char(28) varying,
	ch aligned char(1),
	c6 char(6),
	c8 char(8),
	c12 char(12),
	user_name char(22),
	c32 char(32),
	c64 char(64),
	dir char(168),
	ent char(32),
	(no_input,mat_input) bit(1),
	seg_no bit(18),
	(buff_size,old_buff_size) fixed bin(21),
	code fixed(35),
	bit_length fixed bin(5),
	file_lng fixed bin (34),
	(i,k,loc,m,n,tab_size) fixed bin;

dcl	ascii_size_op char (5) varying static;

dcl	sys_info$max_seg_size fixed bin ext;

dcl	vfx fixed bin(35),
	vbs bit(36) aligned based(addr(vfx));

dcl	double_vfx fixed bin(71),
	double_vbs bit(72) aligned based(addr(double_vfx));

dcl	entry_variable entry variable,
	1 ev		based(addr(entry_variable)),
	2 location	ptr,
	2 stack		ptr;

dcl (	max_string_size	init(4096),
	max_buffer_size	init(4096),
	default_buffer_size	init(128),
	area_header_size	init(24),
	bits_per_char	init(9)) fixed bin static;

dcl	based_vs char(4096) varying based;

dcl	1 varying		aligned based,
	2 len		fixed bin,
	2 chars		char(1);

dcl	1 change		aligned based,
	2 str(n)		bit(bit_length) unaligned;

dcl	float_bin(0:10) float bin based;

dcl	double_float_bin(0:10) float bin(63) based;

dcl	double_bit_word(0:10) bit(72) aligned based;

dcl	fix_bin(0:10) fixed bin based;

dcl	bit_word(0:10) bit(36) aligned based;


dcl	char_string char(n) based unaligned;

dcl	varying_char_string char(n) varying based;

dcl	header_numbers (2) char(1) unaligned static init("1", "2");

dcl	typ_name(5) char(8) varying int static
	init("any", "tty", "terminal", "numeric", "string");

dcl	per_name(7) char(8) varying int static
	init("input","linput","read","print","reset","scratch","write");

dcl	per_bits(7) bit(5) aligned int static
	init("01100"b,	/* input */
	     "01100"b,	/* linput */
	     "00011"b,	/* read */
	     "01100"b,	/* print */
	     "00111"b,	/* reset */
	     "00111"b,	/* scratch */
	     "00011"b);	/* write */

dcl	NL char(1) static init("
"),
	white_space char(2) static init(" 	"),	/* space, HT */
	amp_NL char(2) static init("&
"),
	comma_NL char(2) static init(",
");

dcl	(ioa_,ioa_$nnl,com_err_) entry options(variable),
	basic_file_name_ entry(char(168) aligned),
	timer_manager_$cpu_call entry(fixed bin(71),bit(2),entry),
	timer_manager_$reset_cpu_call entry(entry),
	hcs_$make_seg entry(char(*),char(*),char(*),fixed bin(5),ptr,fixed(35)),
	assign_round_ options(variable),
	area_ entry(fixed bin,ptr),
	user_info_ entry(char(*),char(*),char(*)),
	hcs_$delentry_file entry(char(*),char(*),fixed(35)),
	hcs_$del_dir_tree entry(char(*),char(*),fixed(35)),
	cu_$stack_frame_ptr entry returns(ptr),
	get_pdir_ entry(char(168)),
	expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed(35)),
	hcs_$status_ entry(char(*),char(*),fixed bin,ptr,ptr,fixed(35)),
	iox_$open entry(ptr, fixed bin, bit(1) aligned, fixed bin(35)),
	iox_$control entry(ptr, char(*), ptr, fixed bin(35)),
	iox_$close entry(ptr, fixed bin(35)),
	iox_$detach_iocb entry( ptr, fixed bin(35)),
	iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35)),
	iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)),
	iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
	iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
	iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)),
	vfile_status_ entry (char(*), char(*), ptr, fixed bin(35)),
	convert_old_basic_file_ entry (char(*), char(*), fixed bin(35)),
	iox_$find_iocb entry(aligned char(*),ptr,fixed(35)),
	iox_$attach_iocb entry(ptr,char(*),fixed(35)),
	iox_$destroy_iocb entry(ptr,fixed(35));

dcl	iox_$user_output ptr ext,
	iox_$user_input ptr ext;

dcl (	error_table_$end_of_info,
	error_table_$fulldir,
	error_table_$no_operation,
	error_table_$not_done,
	error_table_$long_record,
	error_table_$noentry) fixed bin(35) ext static;

dcl	fast_related_data_$basic_area_p ptr ext;
dcl	fast_related_data_$in_fast_or_dfast bit(1) aligned ext;

dcl	buffer char(buffer_size) based(buffer_pt),
	1 buffer_pair	based(buffer_pt),
	2 buff1		char(old_buff_size),
	2 buff2		char(old_buff_size);

dcl	string_seg ptr;

dcl	(field_length,field_start,precision,scale,exp_length,digit_count,
	 digit_pos,field_pos) fixed bin;

dcl	1 print_using_bits unaligned,
	2 (left_just,right_just)	bit(1),
	2 have_dollar		bit(1),
	2 (have_plus,have_minus)	bit(1),
	2 have_exp		bit(1),
	2 have_decimal		bit(1);

dcl	pu_string char(pu_length) aligned based(print_using_pt);

dcl	fixed_dec_1 fixed dec(1),
	fixed_dec_1_overlay char(2) aligned based(addr(fixed_dec_1));

dcl	fixed_dec_2 fixed dec(2),
	fixed_dec_2_overlay char(3) aligned based(addr(fixed_dec_2));

dcl	(abs,addr,addrel,bit,convert,date,divide,fixed,hbound,oncode,baseno,reverse,string,ptr,
	 float,index,length,null,substr,verify,search,rel,unspec,time,max,min,mod,rtrim) builtin;

dcl	1 param_info_aligned	based,
	2 param_type(1)		bit(9) unaligned;

dcl	basic_error_messages_$ aligned ext,
	1 message_overlay	aligned based(addr(basic_error_messages_$)),
	2 index_block(0:500),
	  3 loc		fixed bin,
	  3 sev		fixed bin,
	  3 len		fixed bin,
	2 skip		unal char(k),
	2 message		unal char(index_block(error_number).len-1);

dcl	1 basic_string	aligned based,
	2 count		fixed bin,
	2 value		char(n) varying;

dcl	1 string_word	aligned based,
	2 offset		bit(18) unaligned,
	2 ignored		bit(18) unaligned;

dcl	1 arg_info	aligned based,
	2 string_word	bit(36),			/* string word used for local copy */
	2 type		fixed bin(17) unal,		/* 0 = fixed, 1 = varying */
	2 length		fixed bin(17) unal;		/* length of original string arg */

dcl	word fixed bin based aligned;

dcl	1 arglist		aligned based,
	2 arg_count	fixed bin(16) unaligned,
	2 skip		bit(54) unaligned,
	2 arg_ptr(10)	ptr;

dcl	string_area area(65536) based(string_segment);

dcl	info(20) fixed bin(35);		/* storage for vfile_status_ */

dcl	1 position_info aligned,
	2 next_position fixed bin(34),
	2 last_position fixed bin(34);

dcl	1 margin_info aligned,
	2 old_max_recl fixed bin(21),
	2 new_max_recl fixed bin(21);

dcl	string_buffer char(4096) aligned;

dcl	1 map(100)	aligned based,
	2 location	bit(18) unaligned,
	2 line		bit(18) unaligned;

dcl	have_conversion_label bit(36) aligned based(addr(conversion_label));

dcl	have_size_label bit(36) aligned based(addr(size_label));

	/* following block of words will be used as the fcb for tty.  it is
	   declared "big enough" instead of via like attribute so we
	   can make unqualified references to basic_fcb */

dcl	tty_fcb(32) fixed bin(71) static;

%include basic_operator_frame;
%include basic_fcb;

%include vfs_info;
%include basic_program_header;
%include basic_symbols;
%include basic_param_types;
%include iocb;
%include status_info_branch;

	bo_pt = bo_stack_pt;
	goto switch(q_reg + (precision_lng-1)*67);

	/* initialize */

switch(0):
switch(67):
	if fast_related_data_$basic_area_p = null
	then do;

	     /* first time in process */

	     call hcs_$make_seg("","basic_string_segment_","",01011b,string_seg,code);

	     if string_seg = null
	     then do;
		call com_err_(0,"basic","Could not make string segment");
		goto abort_label;
		end;

	     call area_(sys_info$max_seg_size + area_header_size,string_seg);

	     fast_related_data_$basic_area_p = string_seg;

	     fcb_pt = addr(tty_fcb);
	     owner = null;
	     margin = 75;
	     open_mode = Ascii_input_output;
	     end;

	string_segment = fast_related_data_$basic_area_p;
	string_value = "0"b;

	if fast_related_data_$in_fast_or_dfast then ascii_size_op = " -ssf";
	else ascii_size_op = " ";

	do i = 1 to 16;
	     fcb(i) = null;
	     end;

	fcb_pt = addr(tty_fcb);
	fcb(0) = fcb_pt;

	if owner = null then owner = bo_pt;

	buffer_pos = 0;
	buffer_pt = addr(file_name);
	buffer_size = length(file_name);

	file_type = tty_file;

	last_operation = 0;

	program_header_pt = program_header;

	if time_limit ^= 0.0e0
	then do;

	     /* Set up cpu timer to go off after specified time limit.  Since we may
	        have several basic programs active, we fill in the stack part of the
	        entry variable to indicate which program set up the timer;  this will
	        be used to turn off timer at end of execution. */

	     entry_variable = cpu_limit;
	     ev.stack = bo_pt;

	     call timer_manager_$cpu_call(time_limit * 1.0e6,"10"b,entry_variable);
	     end;

	return;

	/* cleanup */

switch(1):
switch(68):
	call tidy_up("1"b);
	return;

	/* print error message */

switch(2): switch(69):
	call print_error(error_number);
	return;

	/* numeric print */

switch(3): switch(70):
	call check_print;
	call numeric_print;
	return;

	/* string print */

switch(4): switch(71):
	call check_print;
	p1 = get_string_ptr(pr(1));
	call string_print;
	return;

	/* tab to next multiple of 15 */

switch(5): switch(72):
	call check_print;
	tab_size = max(15, number_length+8);
	call tab(divide(line_pos + tab_size,tab_size,17,0)*tab_size);
	return;

	/* end print */

switch(6): switch(73):
	call check_print;
	call force_buffer;
	return;

	/* print new line */

switch(7): switch(74):
	call check_print;
	call print_new_line;
	return;

	/* tab function */

switch(8): switch(75):
	call check_print;
	call tab(fixed(temp(1)));
	return;

	/* spc function */

switch(9): switch(76):
	call check_print;
	call tab(fixed(temp(1)) + line_pos);
	return;

	/* string assign, pr(1) is right side, pr(3) is left side */

switch(10): switch(77):
	call string_assign;
	pr(1) = addr(pr(3) -> string_word);
	return;

	/* string compare, pr(1) is left side, pr(3) is right side */

switch(11): switch(78):
	p1 = get_string_ptr(pr(1));
	p2 = get_string_ptr(pr(3));

	if p1 = p2
	then do;
	     temp(1) = 0;
	     return;
	     end;

	if p1 -> based_vs < p2 -> based_vs
	then temp(1) = -1;
	else if p1 -> based_vs = p2 -> based_vs
	     then temp(1) = 0;
	     else temp(1) = +1;

	return;

	/* concatenation, pr(1) is left side, pr(3) is right side */

switch(12): switch(79):
	p1 = get_string_ptr(pr(1));
	p2 = get_string_ptr(pr(3));

	n = length(p1 -> based_vs) + length(p2 -> based_vs);

	if n > max_string_size
	then do;
	     call print_error(104);
	     goto abort_label;
	     end;

	call allocate_string;

	p3 -> basic_string.value = p1 -> based_vs || p2 -> based_vs;

	call return_string;
	return;

	/* linput */

switch(13): switch(80):
	call check_input;
	call linput;
	call return_string;
	return;

	/* numeric input */

switch(14): switch(81):
	call check_input;
	mat_input = "0"b;

	call numeric_input;

	do while(no_input);
	     call get_input(-107);
	     call numeric_input;
	     end;

	return;

	/* string input */

switch(15): switch(82):
	call check_input;
	mat_input = "0"b;

	call string_input;

	do while(no_input);
	     call get_input(-107);
	     call string_input;
	     end;

	call return_string;
	return;

	/* end input */

switch(16): switch(83):
	call end_input;
	return;

	/* pos(a$,b$,n); pr(1) gives a$, pr(3) gives b$, n in temp(1) */

switch(17): switch(84):
	i = fixed(temp(1));

	if i <= 0
	then do;

return_0:	     temp(1) = 0;
	     return;
	     end;

	p1 = get_string_ptr(pr(1));

	if i > length(p1 -> based_vs) then goto return_0;

	p2 = get_string_ptr(pr(3));

	n = index(substr(p1 -> based_vs,i),p2 -> based_vs);

	if n = 0 then goto return_0;

	temp(1) = n + i - 1;
	return;

	/* chr$(n) */

switch(18): switch(85):
	unspec(ch) = bit(fixed(temp(1),9),9) & "001111111"b;

	n = 1;
	call allocate_string;
	p3 -> basic_string.value = ch;

	call return_string;
	return;

	/* clk$ */

switch(19): switch(86):
	c12 = time();

	c8 = substr(c12,1,2) || ":" || substr(c12,3,2) || ":" || substr(c12,5,2);

	call use_c8;
	return;

	/* dat$ */

switch(20): switch(87):
	c6 = date();

	c8 = substr(c6,3,2) || "/" || substr(c6,5,2) || "/" || substr(c6,1,2);
	call use_c8;
	return;

	/* usr$ */

switch(21): switch(88):
	call user_info_(user_name,c8,c8);

	n = index(user_name," ") - 1;
	if n < 0 then n = length(user_name);
	call allocate_string;
	p3 -> basic_string.value = substr(user_name,1,n);
	call return_string;
	return;

	/* str$(x) */

switch(22):
	call convert_number;

	n = length(ans);
	call allocate_string;
	p3 -> basic_string.value = ans;
	call return_string;
	return;

	/* seg$(a$,i,j) */

switch(23): switch(90):
	i = fixed(temp(1));
	n = fixed(temp(2)) - i + 1;
	goto sst;

	/* sst$(a$,i,n) and mid$(a$,i,n) */

switch(24): switch(91):
	i = fixed(temp(1));
	n = fixed(temp(2));

sst:	p1 = get_string_ptr(pr(1));

right_entry:
	if i < 1 then n = 0;

	n = max(min(n,length(p1 -> based_vs) - i + 1),0);

	call allocate_string;
	p3 -> basic_string.value = substr(p1 -> based_vs,i,n);
	call return_string;
	return;

	/* hps */

switch(25): switch(92):
	call get_file_number("01100"b);

	temp(1) = fcb(n) -> line_pos;
	return;

	/* tst(a$) */

switch(26):
	temp(1) = float(fixed(convert_string(),1),1);
	return;

	/* val(a$) */

switch(27):
	if convert_string() then return;

	call print_error(124);
	goto abort_label;

	/* deallocate string specified by pr(1) */

switch(28): switch(95):
	call deallocate_string(pr(1));
	return;

	/* file */

switch(29): switch(96):
	file_number = fixed(temp(1));

	if file_number = 0 then goto invalid_file_number;
	if file_number > 16 then goto invalid_file_number;

	fcb_pt = fcb(file_number);

	if fcb_pt ^= null then call close_file("0"b);	/* but save iocb */
	else do;
	     quits_disabled = "1"b;
	     allocate basic_fcb in(string_area);
	     quits_disabled = "0"b;

	     if had_quit then call signal_quit;

	     fcb(file_number) = fcb_pt;
	     seg_pt = null;			/* do not have iocb yet */
	     owner = bo_pt;
	     end;

	string(basic_fcb.bits) = "0"b;
	file_type = undefined_file;
	open_mode = Not_open;
	write_permission = "0"b;
	margin = -1;
	io_ops_since_margin = -1;
	buffer_pt = null;

	p1 = get_string_ptr(pr(1));

	if p1 -> based_vs = "*"
	then do;

	     /* Create unique name for segment in process directory */

	     call get_pdir_(dir);

	     n = index(dir," ");
	     if n = 0 then n = length(dir) + 1;

	     file_name = substr(dir,1,n-1) || ">" || unique();

	     temporary_file = "1"b;
	     write_permission = "1"b;
	     end;
	else do;
	     file_name = p1 -> based_vs;

	     call open_file;
	     end;

	last_operation = file_op;

	return;

	/* margin */

switch(30): switch(97):
	n = fixed(temp(1));
	if n < 0 then goto invalid_margin;
	if n > 4095 then goto invalid_margin;

	if file_type = numeric_file
	then do;			/* if empty, just set margin variable and hope that next
				   use will change file type */
	     call iox_$control (seg_pt, "read_position", addr(position_info), code);
	     if position_info.last_position > 0
	     then if n ^= 1 then goto invalid_margin;
	     end;
	else if file_type = string_file
	     then do;
		call check_random_string(String_update);  /* be sure it's open correctly */
		margin_info.new_max_recl = n;
		call iox_$control (seg_pt, "max_rec_len", addr(margin_info), code);
		if code =  error_table_$no_operation
		then if n ^= margin_info.old_max_recl
		     then go to invalid_margin;
		end;

	margin = n;
	io_ops_since_margin = -1;
	return;

	/* scratch */

switch(31): switch(98):
	if file_number = 0 then goto invalid_file_number;

	/* seg_pt = null should imply that file is nonexistent */

	if seg_pt = null then return;
	if file_type = undefined_file then return;

	if file_type = ascii_file then do;
	     call zap_file;			/* can't open for input_output if attached to record_stream */
	     call attach_ascii;
	     buffer_pos = buffer_length;
	     end;
	else do;
	     if open_mode < Ascii_input then do;	/* not open or open for input only */
		if file_type = numeric_file then call open_random (Numeric_input_output);
		else call open_random (String_update);
		end;
	     call iox_$position (seg_pt, -1, 0, code);
	     call iox_$control (seg_pt, "truncate", null, code);
	     end;

	last_operation = scratch_op;
	return;

	/* reset ascii */

switch(32): switch(99):
	if file_number = 0 then goto invalid_file_number;

	if (file_type ^= undefined_file) & (open_mode ^= Not_open)
	then do;
	     if open_mode = Ascii_output then return;	/* can't reset output only */
	     call check_ascii (Ascii_input);
	     call reset_ascii;
	     end;

	return;

	/* reset random */

switch(33): switch(100):
	n = fixed(temp(1));

	if file_type = tty_file then goto invalid_file_number;
	if file_type = undefined_file then do;
	     if n = 0 then return;		/* file will start at 0 when it's created */
	     else goto pointer_error;
	     end;
	if file_type = ascii_file then goto type_and_usage_conflict;

	if open_mode = Not_open then do;	/* must open first */
	     if file_type = numeric_file then i = Numeric_input;
	     else i = String_input;
	     call open_random (i);
	     end;

	if n < 0 then goto pointer_error;
	if file_type = numeric_file then buff_size = n*precision_lng*4;
	else if file_type = string_file then buff_size = n;
	call iox_$position  (seg_pt, 2, buff_size, code);
	if code ^= 0 then goto pointer_error;

	last_operation = reset_op;
	return;

	/* numeric write */

switch(34):
	call check_random_numeric (Numeric_input_output);
	call numeric_write;
	return;

	/* numeric read */

switch(35):
	call check_random_numeric (Numeric_input);
	call numeric_read;
	return;

	/* string write */

switch(36): switch(103):
	call check_random_string (String_update);
	p1 = get_string_ptr(pr(1));
	call string_write;
	return;

	/* string read */

switch(37): switch(104):
	call check_random_string (String_input);
	call string_read;
	call return_string;
	return;

	/* lof function */

switch(38): switch(105):
	call get_file_number("10011"b);

	if n = 0 then goto invalid_file_number;
	temp(1) = length_of_file (fcb(n) -> seg_pt);
	return;

	/* loc function */

switch(39): switch(106):
	call get_file_number("10011"b);

	if n = 0 then goto invalid_file_number;
	if (fcb(n) -> seg_pt = null)
	| (file_type = undefined_file)
	| (open_mode = Not_open)
	then do;
	     temp(1) = 0;
	     return;
	     end;

	call iox_$control (fcb(n)->seg_pt, "read_position", addr(position_info), code);
	if code ^= 0 then goto invalid_file_number;

	if fcb(n)->file_type = numeric_file
	then temp(1) = divide(position_info.next_position, (precision_lng*4), 21, 0);
	else temp(1) = position_info.next_position;

	return;

	/* mar function */

switch(40): switch(107):
	call get_file_number("11111"b);

	temp(1) = fcb(n) -> margin;
	return;

	/* check eof for file specified by temp(1)
	   result temp(1) = 0 => more, ^= 0 -> eof */

switch(41): switch(108):
	call get_file_number("11111"b);

	if n = 0 then temp(1) = 0;
	else do;
	     file_number = n;
	     fcb_pt = fcb(n);

	     if open_mode = Not_open 
	     then do;
		file_lng = length_of_file (seg_pt);
		if file_lng > 0 then temp(1) = 0;
		else temp(1) = 1;
		end;

	     else do;
		call iox_$control (seg_pt, "read_position", addr(position_info), code);
		if code ^= 0
		then temp(1) = 1;		/* assume unopen file is empty */
		else if position_info.next_position < position_info.last_position
		     then temp(1) = 0;
		     else do;
			temp(1) = 1;
			if file_type = ascii_file
			then if buffer_pos < buffer_length
			     then temp(1) = 0;
			end;
		end;
	     end;

	return;

	/* typ(n,str) where n in temp(1) and str given by pr(1) */

switch(42): switch(109):
	p1 = get_string_ptr(pr(1));

	do i = 1 to hbound(typ_name,1);
	     if p1 -> based_vs = typ_name(i) then goto typ_ok;
	     end;

	temp(1) = -1;
	return;

typ_ok:	n = fixed(temp(1));

	if n < 0 then goto invalid_file_number;
	if n > 16 then goto invalid_file_number;

	if fcb(n) = null then temp(1) = 0;
	else if i = 1 | (fcb(n) -> file_type = undefined_file & i ^= 2)
	     then temp(1) = 1;
	     else temp(1) = float(fixed(fcb(n) -> file_type = i,1),1);

	return;

	/* change from string given by pr(1) to array given by pr(2) */

switch(43):
	bit_length = fixed(temp(1));
	if bit_length <= 0 then goto change_error;
	if bit_length > 27 then goto change_error;

	p1 = get_string_ptr(pr(1));

	n = divide(length(p1 -> based_vs) * bits_per_char,bit_length,17,0);

	if n > pr(2) -> current_bounds(1) then goto change_error;

	p2 = pr(2) -> array_dope.data;
	p2 -> float_bin(0) = n;

	p1 = addr(p1 -> varying.chars);

	do i = 1 to n;
	     p2 -> float_bin(i) = float(fixed(p1 -> change.str(i),27),27);
	     end;

	return;

	/* change to string given by pr(1) from array given by pr(2) */

switch(44):
	bit_length = fixed(temp(1));
	if bit_length <= 0 then goto change_error;
	if bit_length > 27 then goto change_error;

	call deallocate_string(pr(1));

	p2 = pr(2) -> array_dope.data;
	m = p2 -> float_bin(0);
	if m > pr(2) -> current_bounds(1) then goto change_error;

	n = divide(m*bit_length + bits_per_char-1,bits_per_char,17,0);

	call allocate_string;

	pr(1) -> bit_word(0) = rel(p3);
	p1 = addr(p3 -> basic_string.value);

	p1 -> varying.len = n;
	p1 = addr(p1 -> varying.chars);

	do i = 1 to m;
	     vfx = p2 -> float_bin(i);

	     if vfx < 0 then goto change_error;
	     if substr(vbs,1,36-bit_length) then goto change_error;

	     p1 -> change.str(i) = substr(vbs,37-bit_length,bit_length);
	     end;

	/* zero out any remaining bits in last ASCII character */

	n = n*bits_per_char - m*bit_length;
	if n ^= 0 then substr(p1 -> change.str(i),1,n) = "0"b;

	return;

	/* mat numeric input */

switch(45):
	call check_input;
	mat_input = "1"b;
	number_read = 0;
	call mat_loop(1);
	return;

	/* mat string input */

switch(46):
	call check_input;
	mat_input = "1"b;
	number_read = 0;
	call mat_loop(2);
	return;

	/* mat numeric print */

switch(47):
	call check_print;

	if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1);

	call print_new_line;
	call mat_loop(3);
	return;

	/* mat string print */

switch(48):
	call check_print;

	if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1);

	call print_new_line;
	call mat_loop(4);
	return;

	/* mat numeric read */

switch(49):
	call check_random_numeric (Numeric_input);
	call mat_loop(7);
	return;

	/* mat string read */

switch(50):
	call check_random_string (String_input);
	call mat_loop(8);
	return;

	/* mat numeric write */

switch(51):
	call check_random_numeric (Numeric_input_output);
	call mat_loop(9);
	return;

	/* mat string write */

switch(52):
	call check_random_string (String_update);
	call mat_loop(10);
	return;

	/* mat numeric data read */

switch(53):
	call mat_loop(5);
	return;

	/* mat string data read */

switch(54):
	call mat_loop(6);
	return;

	/* mat linput */

switch(55):
	call mat_loop(11);
	call end_input;
	return;

	/* start print using */

switch(56): switch(123):
	call check_print;

	p1 = get_string_ptr(pr(1));
	pu_length = length(p1 -> based_vs);

	if pu_length = 0 then goto zero_print_using;

	quits_disabled = "1"b;
	allocate pu_string in(string_area);
	quits_disabled = "0"b;

	if had_quit then call signal_quit;

	pu_string = p1 -> based_vs;
	pu_pos = 0;

	return;

	/* print using numeric */

switch(57):
	call print_using_numeric;
	return;

	/* print using string */

switch(58): switch(125):
	p1 = get_string_ptr(pr(1));
	call print_using_string;
	return;

	/* end print using */

switch(59): switch(126):
	call get_next_field("1"b);

	quits_disabled = "1"b;
	free pu_string in(string_area);
	quits_disabled = "0"b;

	if had_quit then call signal_quit;

	return;

	/* mat print using numeric */

switch(60):
	call mat_loop(12);
	return;

	/* mat print using string */

switch(61):
	call mat_loop(13);
	return;

	/* mat a$ = nul$ */

switch(62):
	call mat_loop(14);
	return;

	/* mat a$ = b$ */

switch(63):
	p4 = pr(1) -> array_dope.data;
	call mat_loop(15);
	return;

	/* per(n,str) where n in temp(1) and str given by pr(1) */

switch(64): switch(131):
	p1 = get_string_ptr(pr(1));

	do i = 1 to hbound(per_name,1);
	     if p1 -> based_vs = per_name(i) then goto per_ok;
	     end;

	temp(1) = -1;
	return;

per_ok:	n = fixed(temp(1));

	if n < 0 then goto invalid_file_number;
	if n > 16 then goto invalid_file_number;

	if fcb(n) = null then temp(1) = 0;
	else temp(1) = float(fixed(substr(per_bits(i),fcb(n) -> file_type,1),1));

	if i > 3				/*  check for output permission */
	then if file_type ^= undefined_file
	     then if  ^write_permission
		then temp(1) = 0;

	return;

	/* create string value from string pointed at by pr(2) and whose
	   length is in a_reg */

switch(65): switch(132):
	n = a_reg;
	call allocate_string;
	p3 -> basic_string.value = pr(2) -> char_string;
	call return_string;
	return;

	/* make the string word pointed at by pr(2) specify a unique string value */

switch(66): switch(133):
	p1 = get_string_ptr(pr(2));
	n = length(p1 -> based_vs);

	if (n = 0) | (addrel(p1,-1) -> basic_string.count ^= 1)
	then do;

	     /* The string value is shared, we have to make unique copy */

	     call allocate_string;
	     p3 -> basic_string.value = p1 -> based_vs;

	     call deallocate_string(pr(2));

	     pr(2) -> string_word.offset = rel(p3);
	     end;

	return;

	/* str$(x) */

switch(89):
	call d_convert_number;

	n = length(ans);
	call allocate_string;
	p3 -> basic_string.value = ans;
	call return_string;
	return;

	/* tst(a$) */

switch(93):

	temp(1) = float(fixed(d_convert_string(),1),1);
	return;

	/* val(a$) */

switch(94):
	if d_convert_string() then return;

	call print_error(124);
	goto abort_label;

	/* numeric write */

switch(101):
	call check_random_numeric (Numeric_input_output);
	call d_numeric_write;
	return;

	/* numeric read */

switch(102):
	call check_random_numeric (Numeric_input);
	call d_numeric_read;
	return;

	/* change from string given by pr(1) to array given by pr(2) */

switch(110):
	bit_length = fixed(temp(1));
	if bit_length <= 0 then goto change_error;
	if bit_length > 63 then goto change_error;

	p1 = get_string_ptr(pr(1));

	n = divide(length(p1 -> based_vs) * bits_per_char,bit_length,17,0);

	if n > pr(2) -> current_bounds(1) then goto change_error;

	p2 = pr(2) -> array_dope.data;
	p2 -> double_float_bin(0) = n;

	p1 = addr(p1 -> varying.chars);

	do i = 1 to n;
	     p2 -> double_float_bin(i) = float(fixed(p1 -> change.str(i),63),63);
	     end;

	return;

	/* change to string given by pr(1) from array given by pr(2) */

switch(111):
	bit_length = fixed(temp(1));
	if bit_length <= 0 then goto change_error;
	if bit_length > 63 then goto change_error;

	call deallocate_string(pr(1));

	p2 = pr(2) -> array_dope.data;
	m = p2 -> double_float_bin(0);
	if m > pr(2) -> current_bounds(1) then goto change_error;

	n = divide(m*bit_length + bits_per_char-1,bits_per_char,17,0);

	call allocate_string;

	pr(1) -> bit_word(0) = rel(p3);
	p1 = addr(p3 -> basic_string.value);

	p1 -> varying.len = n;
	p1 = addr(p1 -> varying.chars);

	do i = 1 to m;
	     double_vfx = p2 -> double_float_bin(i);

	     if double_vfx < 0 then goto change_error;
	     if substr(double_vbs,1,72-bit_length) then goto change_error;

	     p1 -> change.str(i) = substr(double_vbs,73-bit_length,bit_length);
	     end;

	/* zero out any remaining bits in last ASCII character */

	n = n*bits_per_char - m*bit_length;
	if n ^= 0 then substr(p1 -> change.str(i),1,n) = "0"b;

	return;

	/* mat numeric input */

switch(112):
	call check_input;
	mat_input = "1"b;
	number_read = 0;
	call d_mat_loop(1);
	return;

	/* mat string input */

switch(113):
	call check_input;
	mat_input = "1"b;
	number_read = 0;
	call d_mat_loop(2);
	return;

	/* mat numeric print */

switch(114):
	call check_print;

	if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1);

	call print_new_line;
	call d_mat_loop(3);
	return;

	/* mat string print */

switch(115):
	call check_print;

	if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1);

	call print_new_line;
	call d_mat_loop(4);
	return;

	/* mat numeric read */

switch(116):
	call check_random_numeric (Numeric_input);
	call d_mat_loop(7);
	return;

	/* mat string read */

switch(117):
	call check_random_string (String_input);
	call d_mat_loop(8);
	return;

	/* mat numeric write */

switch(118):
	call check_random_numeric (Numeric_input_output);
	call d_mat_loop(9);
	return;

	/* mat string write */

switch(119):
	call check_random_string (String_update);
	call d_mat_loop(10);
	return;

	/* mat numeric data read */

switch(120):
	call d_mat_loop(5);
	return;

	/* mat string data read */

switch(121):
	call d_mat_loop(6);
	return;

	/* mat linput */

switch(122):
	call d_mat_loop(11);
	call end_input;
	return;

	/* print using numeric */

switch(124):
	call d_print_using_numeric;
	return;

	/* mat print using numeric */

switch(127):
	call d_mat_loop(12);
	return;

	/* mat print using string */

switch(128):
	call d_mat_loop(13);
	return;

	/* mat a$ = nul$ */

switch(129):
	call d_mat_loop(14);
	return;

	/* mat a$ = b$ */

switch(130):
	p4 = pr(1) -> array_dope.data;
	call d_mat_loop(15);
	return;

switch(134):
switch(201):
	/* left$ */
	/* used code from sst$ but initialize first */
	i = 1;
	n = fixed (temp(1));
	goto sst;
switch(135):
switch(202):
	/* right$ */
	/* use sst$ but initialize first */
	n = fixed(temp(1));

	/* Determine length and count back */

	p1 = get_string_ptr(pr(1));
	i = length(p1 -> based_vs) - n + 1;
	if i <= 0 then i = 1;
	goto right_entry;
	

	/* errors */

invalid_margin:
	n = 131;

err:	call print_error(n);
	goto abort_label;

type_and_usage_conflict:
	n = 132;
	goto err;

end_of_file:
	n = 133;
	goto err;

file_error:
	n = 134;
	goto err;

invalid_file_number:
	n = 135;
	goto err;

pointer_error:
	n = 136;
	goto err;

change_error:
	n = 138;
	goto err;

array_error:
	n = 139;
	goto err;

out_of_data:
	n = 103;
	goto err;

zero_print_using:
	n = 141;
	goto err;

print_using_error:
	n = 142;
	goto err;

incorrect_format_for_file_input:
	n = 145;
	goto err;

open_error:
	n = 147;
	goto err;

cannot_write:
	n = 148;
	goto err;

input_line_too_long:
	n = 149;
	goto err;

iox_error:
	n = 158;
	goto err;

close_error:
	n = 157;
	file_type = undefined_file;
	goto err;

cannot_read:
	n = 156;
	goto err;

cannot_scratch:
	n = 159;
	goto err;

default:	entry(mc_ptr,name,co_ptr,info_ptr,continue);

dcl	(mc_ptr,co_ptr,info_ptr) ptr,
	name char(*) unaligned,
	continue bit(1) aligned;

%include mc;

dcl	oncode_values(20) fixed bin static init(5,8,9,10,11,12,13,16,33,46,17,18,6,19,20,21,22,23,47,63);

dcl	math_message(20) fixed bin static init(114,115,116,117,118,119,120,121,122,123,95,96,
					114,115,116,117,120,119,122,123);

dcl	convert_new_oncode_ entry (fixed bin (35)) returns (fixed bin (35));
dcl	cond char(32);

	/* get ptr to stack frame of basic program in which fault occurred
	   by fishing it out of our argument list */

	p1 = cu_$stack_frame_ptr() -> arglist_ptr;
	bo_pt = p1 -> arglist.arg_ptr(p1 -> arglist.arg_count + 1);

	if ignore_handler then go to refuse;
	cond = name;

	if cond = "error"
	then do;
	     n = convert_new_oncode_ (oncode());

	     if n < 5 then goto refuse;
	     if precision_lng = 1 then if n > 46 then go to refuse;
	     else if n > 63 then go to refuse;

	     if n = 17 then return;

	     do i = 1 to hbound(oncode_values,1);
		if oncode_values(i) = n then goto math_error;
		end;

refuse:	     continue = "1"b;
	     return;

math_error:    call print_error(math_message(i));

	     return;
	     end;

	if have_conversion_label
	then do;
	     if cond = "conversion" then goto conversion_label;
	     if cond = "underflow" then goto conversion_label;
	     if cond = "overflow" then goto conversion_label;
	     end;

	if have_size_label
	then do;
	     if cond = "size" then goto size_label;
	     if cond = "fixedoverflow" then goto size_label;
	     end;

	if cond = "overflow"
	then do;
	     call restart_with_infinity(125,precision_lng);

	     /* the eovf indicator must be turned off here because it isn't later;
	        otherwise it can mess up interpretatio of later faults */

	     if mc_ptr ^= null then addr(mc_ptr->mc.scu(0))->scu.ir.eovf = "0"b;

	     return;
	     end;

	if cond = "zerodivide"
	then do;
	     call restart_with_infinity(144,precision_lng);
	     return;
	     end;

	if cond = "underflow"
	then do;
	     call get_mc_info;

	     call error_print(140);

	     /* turn off eufl indicator here because it's not turned off automatically */

	     if mc_ptr ^= null then addr(mc_ptr->mc.scu(0))->scu.ir.eufl = "0"b;

	     /* the FIM has already advanced the location counter and
	        put 0.0e0 in the eaq, so all we have to do is return */

	     return;
	     end;

	if cond = "lockup"
	then do;
	     mcp = mc_ptr;
	     scup = addr(mc.scu);

	     if baseno(program_header) ^= "000"b || scu.psr then goto refuse;

	     loc = fixed(scu.ilc,18);
	     call error_print(126);

	     goto abort_label;
	     end;

	if cond = "area"
	then do;
	     loc = fixed(basic_operators_frame.xr(7),18) - 1;

	     call error_print(143);

	     goto abort_label;
	     end;

	if cond = "stringsize" then return;

	if cond = "quit"
	then if quits_disabled
	     then do;
		had_quit = "1"b;
		return;
		end;
	     else goto refuse;

	goto refuse;

cpu_limit: entry(mc_ptr);

	/* cpu limit reached, get ptr to stack frame of basic program by
	   fishing it out of our arg list */

	p1 = cu_$stack_frame_ptr() -> arglist_ptr;
	bo_pt = p1 -> arglist.arg_ptr(p1 -> arglist.arg_count + 1);

	call get_mc_info;

	call error_print(146);

	goto abort_label;

cleanup:  entry;

	/* get ptr to stack frame of basic program by fishing it out of our arg list */

	p1 = cu_$stack_frame_ptr() -> arglist_ptr;
	bo_pt = p1 -> arglist.arg_ptr(p1 -> arglist.arg_count + 1);

	call tidy_up("0"b);
	return;

close_basic_file: entry(fn);

dcl	fn float bin;

	/* This entry is called by a basic sub-program to close a specified file.
	   We get the pointer to the stack frame of the basic program by taking
	   one step backwards in the stack */

	bo_pt = cu_$stack_frame_ptr() -> prev_sp;

	file_number = fixed(fn);

	if file_number <= 0 then return;
	if file_number > 16 then return;

	fcb_pt = fcb(file_number);

	if fcb_pt ^= null then call close_file("1"b);

	return;

	/* This procedure determines the location at which a fault occurred
	   by looking in machine conditions provided by signal.  If no
	   machine conditions are available, the condition is refused.
	   If the fault happened in the basic program, the ilc is used;
	   otherwise, the point of entry into basic_operators_ is used. */

get_mc_info:   proc;

	     mcp = mc_ptr;
	     if mcp = null then goto refuse;

	     scup = addr(mc.scu);

	     seg_no = "000"b || scu.psr;

	     if seg_no = baseno(program_header) then loc = fixed(scu.ilc,18);
	     else loc = fixed(basic_operators_frame.xr(7),18) - 1;

	     end;

	/* This procedure is called when the default handler wishes to
	   restart executing with the instruction after the one which
	   caused a fault. */

restart:	     proc;

	     scu.ilc = bit(fixed(fixed(scu.ilc, 18) + 1,18), 18);
	     scu.rfi = "1"b;
	     scu.if = "0"b;

	     end;

	/* This procedure is called to restart instruction after one causing
	   fault with value of + infinity in EAQ.  The argument gives error
	   message to be printed. */

restart_with_infinity: proc(errno,prec_lng);

dcl	errno fixed bin;
dcl	prec_lng fixed bin unaligned;

	     call get_mc_info;

	     call error_print(errno);

	     /* set result to + infinity */

	     if prec_lng = 1 then do;		/* single precision */
		mc.e = "01111111"b;
		mc.a = "011111111111111111111111111000000000"b;
		mc.q = "0"b;
		end;

	     else do;			/* extended precision*/
		mc.e = "01111111"b;
		mc.a = "011111111111111111111111111111111111"b;
		mc.q = "111111111111111111111111111000000000"b;
		end;

	     /* restart with instruction after one causing fault */

	     call restart;
	     end;

	/* This procedure is called to straighten up after program finishes. */

tidy_up:	     proc(normal);

dcl	     normal bit(1) aligned;

	     program_header_pt = program_header;

	     if time_limit ^= 0.0e0
	     then do;

		/* Turn off cpu timer */

		entry_variable = cpu_limit;
		ev.stack = bo_pt;

		call timer_manager_$reset_cpu_call(entry_variable);
		end;

	     call cleanup_strings;

	     if non_basic_caller
	     then do;

		/* If any of the arguments of this subprogram are string scalars,
		   we have to copy current value of string argument into original
		   argument and then free the basic string value */

		p1 = addrel(program_header_pt,incoming_args.location);

		do i = 1 to fixed(substr(incoming_args.number,1,17),17);
		     if fixed(p1 -> param_type(i),9) = string_scalar_param
		     then do;
			p2 = arg(i);
			p3 = get_string_ptr(p2);
			p4 = arglist_ptr -> arg_ptr(i);

			n = p2 -> arg_info.length;
			if p2 -> arg_info.type = 0 then p4 -> char_string = p3 -> based_vs;
			else addrel(p4,-1) -> varying_char_string = p3 -> based_vs;

			call deallocate_string(p2);
			end;
		     end;
		end;

	     call close_all_files(normal);
	     end;

	/* This procedure is called to perform a string assignment.  PR3
	   points at target and PR1 points at source.  If the target string
	   is non-null, the reference count on the string block is decremented
	   and the block is freed if the count reached zero.  If the source
	   is a null string, the target word is zeroed.  If the source string
	   is a constant, it must be copied into the string segment.  The
	   target word gets set to the offset of the string block in the
	   string segment.  For a normal assignment of the form
			let a$ = b$
	   the string words of both variables will "point" to same block
	   in string storage. */

string_assign: proc;

	     /* don't do anything if we have a$ = a$ */

	     if pr(1) = pr(3) then return;

	     /* drop reference count and free (if necessary) current value of left side */
     
	     call deallocate_string(pr(3));
     
	     if pr(1) -> word = 0
	     then do;
     
		/* right side is null string */
     
		pr(3) -> word = 0;
		return;
		end;
     
	     if pr(1) -> string_word.offset
	     then do;
     
		/* right side is variable, bump its reference count */
     
		p1 = ptr(string_segment,pr(1) -> string_word.offset);
     
		p1 -> basic_string.count = p1 -> basic_string.count + 1;
     
		pr(3) -> string_word.offset = pr(1) -> string_word.offset;
		end;
	     else do;
     
		/* right side is constant, copy it into string segment */
     
		n = length(pr(1) -> based_vs);
		call allocate_string;
     
		p3 -> basic_string.value = pr(1) -> based_vs;
     
		pr(3) -> string_word.offset = rel(p3);
		end;
	     end;

	/* This procedure is called to allocate a string block;  the size of
	   the string is contained in the global variable "n".  The reference
	   count of the new block (pointed at by global variable p3) is set to 1. */

allocate_string: proc;

	     quits_disabled = "1"b;
	     allocate basic_string in(string_area) set(p3);
	     quits_disabled = "0"b;

	     if had_quit then call signal_quit;

	     p3 -> basic_string.count = 1;

	     end;

	/* This procedure is called to deallocate the string specified by the
	   string variable pointed at by arg sp.  The reference count on the string
	   block is decremented and the block is freed if the count reached zero.
	   The string variable is set to zero which indicates a null value. */

deallocate_string: proc(sp);

dcl	     (sp,bsp) ptr;

	     if sp -> string_word.offset
	     then do;
		bsp = ptr(string_segment,sp -> string_word.offset);
		bsp -> basic_string.count = bsp -> basic_string.count - 1;

		if bsp -> basic_string.count = 0
		then do;
		     quits_disabled = "1"b;
		     free bsp -> basic_string in(string_area);
		     quits_disabled = "0"b;

		     if had_quit then call signal_quit;
		     end;

		string(sp -> string_word) = (36)"0"b;
		end;
     
	     end;

	/* This procedure contains entries for printing run-time error messages
	   whose text is stored in basic_error_messages_.  A negative message
	   number indicates that no trailing <NL> is desired.  The "print_error"
	   entry gets its line number from the value of index register 7 at last
	   entry into basic_operators_ while the "error_print" entry uses the
	   value of the global variable "loc" to find the line number. */

print_error:   proc(num);

dcl	     (num,ln,save_file_number,et) fixed bin,
	     main bit(1),
	     save_fcb_pt ptr,
	     ev entry variable options(variable);

	     ln = get_line_number();

com:	     save_file_number = file_number;
	     save_fcb_pt = fcb_pt;

	     file_number = 0;
	     fcb_pt = fcb(0);

	     if last_operation = print_op
	     then if line_pos ^= 0
		then call print_new_line;

	     file_number = save_file_number;
	     fcb_pt = save_fcb_pt;

	     error_number = abs(num);

	     et = index_block(error_number).sev;
	     main = et = 4 | main_program;

	     if main
	     then if num < 0 then ev = ioa_$nnl; else ev = ioa_;
		else ev = ioa_$nnl;

	     if et = 3
	     then do;
		if file_number ^= 0 then call ioa_$nnl("File ""^a"": ",file_name);
		et = 2;
		end;

	     k = index_block(error_number).loc;
	     if k = -1 then call ev("RUNTIME ERROR ^d in ^d",error_number,ln);
	     else if et = 2
		then call ev(message,ln);
		else if et = 1
		     then call ev(message,pr(1) -> based_vs,ln);
		     else call ev(message,pr(1),ln);

	     if ^main
	     then do;
		if num < 0 then ev = ioa_$nnl; else ev = ioa_;

		call ev(" of subprogram ""^A""",addrel(entryname,0));	/* pass UNPACKED ptr */
		end;

	     if num < 0 then call ioa_$nnl("? ");
	     return;

error_print:   entry(num);

	     ln = obtain_line_number();
	     goto com;
	     end;

	/* This procedure is called to convert an object program location into
	   a line number;  it does a binary search on the statement map.  The
	   "get_line_number" entry uses the value of index register 7 at last
	   entry into basic_operators_ while the "obtain_line_number" entry
	   uses the value in the global variable "loc".  In either case, the
	   location is adjusted to be an offset with respect to the program
	   header and that is the value actually used in the search. */

get_line_number: proc returns(fixed bin);

dcl	     (lower,upper,i,map_loc) fixed bin,
	     mp ptr;

	     loc = fixed(xr(7),18) - 1;

obtain_line_number: entry returns(fixed bin);

	     loc = loc - fixed(program_header_offset,18);

	     lower = 1;
	     upper = fixed(program_header -> basic_program_header.statement_map.number,18);

	     mp = addrel(program_header,program_header -> basic_program_header.statement_map.location);

	     do while(lower <= upper);
		i = divide(lower+upper,2,17,0);

		map_loc = fixed(mp -> map(i).location,18);

		if loc < map_loc
		then upper = i - 1;
		else if loc = map_loc then do;
		     /* skip over any remark lines */
		     do while(loc = fixed(mp->map(i+1).location,18)); i = i+1; end;
		     return(fixed(mp -> map(i).line,18));
		     end;
		     else if loc < fixed(mp -> map(i+1).location,18)
			then return(fixed(mp -> map(i).line,18));
			else lower = i + 1;

		end;

	     return(-1);
	     end;

	/* This procedure is called at the end of execution, just prior to
	   a return, to clean up all string variables.  Each string variable
	   has its string block reference count decremented;  the block is freed
	   if the count reached zero.  Note that we cannot just free each block
	   since the same block may be referenced by more than one variable and
	   in fact, such references may be from other programs.  It is for the
	   convenience of this procedure that all string variables are stored in
	   a contiguous block. */

cleanup_strings: proc;

dcl	     i fixed bin,
	     p ptr;

	     p = addrel(bo_pt,program_header -> basic_program_header.string_storage.location);

	     do i = 1 to fixed(program_header -> basic_program_header.string_storage.number,18);
		call deallocate_string(p);

		p = addrel(p,1);
		end;

	     /* if the string temporary contains a value, free it */

	     call deallocate_string(addr(string_value));
	     end;


	/* This procedure is called to convert the value in the global variable
	   "temp(1)" from float binary(27) to the appropriate string representation
	   in I, F, or E format according to the rules of the language;
	   the converted value is placed in the global variable "ans". */

convert_number: proc;
     
dcl	     abs_value float bin,
	     (k,j,ndigits) fixed bin,
	     dec_value float dec(6),
	     fixed_dec_value fixed dec(9),
	     exp fixed bin;
     
dcl	     1 dec_value_overlay aligned based(addr(dec_value)),
	     2 sign	char(1) unaligned,
	     2 digits	char(6) unaligned,
	     2 skip	bit(1) unaligned,
	     2 exponent	fixed bin(7) unaligned;
     
dcl	     fixed_digits char(10) aligned based(addr(fixed_dec_value));

	     if temp(1) = 0
	     then do;
		ans = " 0";
		return;
		end;
     
	     abs_value = abs(temp(1));
     
	     if temp(1) < 0 then ans = "-"; else ans = " ";
     
	     if abs_value < 134217728	/* 2 ** 27 */
	     then if float(fixed(abs_value)) = abs_value
		then do;
     
		     /* integer format */
     
		     fixed_dec_value = convert(fixed_dec_value,abs_value);
     
		     k = verify(substr(fixed_digits,2),"0");
		     ans = ans || substr(fixed_digits,k+1);
		     return;
		     end;
     
	     /* we assume that the following conversion is ROUNDED
	        and normalized to the left */
     
	     dec_value = convert(dec_value,abs_value);
     
	     k = verify(reverse(digits),"0");
	     ndigits = 7 - k;
     
	     exp = exponent + k - 1;
     
	     if exp >= 0
	     then do;

		if exp + ndigits <= 8
		then do;

		     /* due to rounding integer is closest approximation */

		     ans = ans || substr(digits,1,ndigits);

		     if exp > 0 then ans = ans || substr("00000000",1,exp);

		     return;
		     end;

		/* exponential format */

e_format:		ans = ans || substr(digits,1,1);
		ans = ans || ".";
		ans = ans || substr(digits,2,ndigits-1);
		ans = ans || " E";

		exp = exp + ndigits - 1;
     
		if abs(exp) < 10
		then do;
		     fixed_dec_1 = convert(fixed_dec_1,exp);
		     ans = ans || fixed_dec_1_overlay;
		     end;
		else do;
		     fixed_dec_2 = convert(fixed_dec_2,exp);
		     ans = ans || fixed_dec_2_overlay;
		     end;
     
		return;
		end;
     
	     j = ndigits + exp;
     
	     if j <= 0
	     then do;
		if ndigits - j > 6 then goto e_format;
     
		ans = ans || "0.";
		if j ^= 0 then ans = ans || substr("00000000",1,abs(j));
		ans = ans || substr(digits,1,ndigits);
		end;
	     else do;
		ans = ans || substr(digits,1,j);
		ans = ans || ".";
		ans = ans || substr(digits,j+1,ndigits-j);
		end;
     
	     end;

	     /* This function converts the BASIC string specified by pr(1)
	        to a numeric value in temp(1).  "1"b is returned if no
	        error was found and "0"b is returned if the string was
	        erroneous.  The conversion is attempted twice;  if the
	        first attempt fails, we try again with all white space removed
	        from the string.  This logic attempts to optimize the
	        simple cases that do not have embedded white space. */

convert_string: proc returns(bit(1) aligned);

dcl	     good_string bit(1) aligned;

	     p1 = get_string_ptr(pr(1));
	     good_string = "0"b;

	     conversion_label = first_error;
	     temp(1) = convert(temp(1),p1 -> based_vs);

ok:	     good_string = "1"b;

done:	     have_conversion_label = (36)"0"b;
	     return(good_string);

	     /* had error first time, try again if string contains white space */

first_error:   if search(p1 -> based_vs,white_space) = 0 then goto done;

	     conversion_label = done;

		begin;

dcl		copy char(length(p1 -> based_vs)),
		(i,j) fixed bin;

		copy = "";
		j = 0;

		do i = 1 to length(p1 -> based_vs);
		     if index(white_space,substr(p1 -> based_vs,i,1)) = 0
		     then do;

			/* current char not white space, copy it */

			j = j + 1;
			substr(copy,j,1) = substr(p1 -> based_vs,i,1);
			end;
		     end;

		temp(1) = convert(temp(1),copy);
		end;

	     goto ok;
	     end;

	/* This procedure is called to obtain a pointer to the string block
	   specified by the string variable pointed at by the argument ptr "sp".
	   If the specified string variable is zero, a pointer to the zero
	   length varying string is returned. */

get_string_ptr: proc(sp) returns(ptr);

dcl	     sp ptr,
	     null_vs char(1) varying static init("");

	     if sp -> word = 0 then return(addr(null_vs));

	     if sp -> string_word.offset
	     then return(addr(ptr(string_segment,sp -> string_word.offset) -> basic_string.value));

	     return(sp);
	     end;

	/* This procedure is called to make sure that a PRINT-type operation
	   is valid on the file specified by the global variable "fcb_pt".
	   The file must be ASCII (or TTY);  if the last operation was not
	   a PRINT, the file is converted to PRINT and the buffers set up. */

check_print:   proc;

	     call check_ascii (Ascii_output);

	     if last_operation ^= print_op
	     then do;

		if file_number = 0 then seg_pt = iox_$user_output;

		buffer_pos, line_pos = 0;
		last_operation = print_op;
		end;

	     end;

	/* This procedure is called to make sure that a INPUT-type operation
	   is valid on the file specified by the global variable "fcb_pt".
	   The file must be ASCII (or TTY);  if the last operation was not
	   a INPUT, the file is converted to INPUT and more input is gotten. */

check_input:   proc;

	     call check_ascii (Ascii_input);

	     if last_operation ^= input_op
	     then do;
		if file_number = 0 then seg_pt = iox_$user_input;

		last_operation = input_op;
		buffer_pos = buffer_length;
		end;

	     if buffer_pos >= buffer_length
	     then do;
		if file_number = 0 then call prompt;

		call get_input(0);
		end;

	     end;

	/* This procedure repositions an ascii file to its beginning */

reset_ascii:   proc;

	     call seg_pt -> iocb.position(seg_pt,-1,0,code);

	     if code ^= 0
	     then if code ^= error_table_$no_operation
		then goto iox_error;

	     buffer_pos = buffer_length;

	     last_operation = reset_op;
	     end;

	/* This procedure prints an input prompt on terminal */

prompt:	     proc;

	     substr(buffer,1,2) = "? ";
	     call iox_$user_output -> iocb.put_chars(iox_$user_output,buffer_pt,2,code);

	     end;

	/* This procedure is called to make sure that ASCII-type operations
	   are valid on the file specified by the global variable "fcb_pt".
	   If the file is not ASCII or TTY, it can be converted to ASCII if
	   it empty but an error is issued if it is non-empty. */

check_ascii:   proc (new_mode);

dcl	new_mode fixed bin;

	     io_ops_since_margin = io_ops_since_margin + 1;

	     if file_type = tty_file then return;

	     if open_mode = new_mode then return;
	     if open_mode = Ascii_input_output then return;
	     if file_type = ascii_file then do;		/* open the wrong way--close and reopen */
		call open_ascii (new_mode);
		return;
		end;

	     /* can convert file to ascii if it is empty */

	     /* be sure file is empty */
	     if length_of_file (seg_pt) > 0 then goto type_and_usage_conflict;

	     if file_type >= numeric_file
	     then call zap_file;

	     if io_ops_since_margin > 0 then do;
		margin = -1;		/* reset so we don't use old margin */
		io_ops_since_margin = 0;
		end;

	     call attach_ascii;
	     call open_ascii (new_mode);

	     last_operation = 0;
	     end;

	/* This procedure is called to make sure that the file specified by
	   the global variable "fcb_pt" is RANDOM-NUMERIC.  If not, it
	   is converted if empty or an error is issued if it is non-empty. */

check_random_numeric: proc (new_mode);

dcl	new_mode fixed bin;

	     io_ops_since_margin = io_ops_since_margin + 1;

	     if open_mode = new_mode then return;
	     if open_mode = Numeric_input_output then return;
	     if file_type = numeric_file then do;	/* close and reopen the right way */
		call open_random (new_mode);
		return;
		end;

	     if must_be_ascii then goto type_and_usage_conflict;
	     /* be sure file is empty before converting type */

	     if open_mode = Ascii_output then goto type_and_usage_conflict;
						/* can't be empty if open for stream_output */
	     if length_of_file (seg_pt) > 0 then goto type_and_usage_conflict;

	     /* if file used to be some other type, we must get rid of
	        vfile header or vfile won't allow random numeric use */

	     if file_type = string_file then call zap_file;
	     else if file_type = ascii_file then call close_vfile;

	     call attach_numeric;
	     call open_random(new_mode);		/* this should create file if it doesn't already exist  */

	     margin = 1;
	     io_ops_since_margin = 0;
	     end;

	/* This procedure is called to make sure that the file specified by
	   the global variable "fcb_pt" is RANDOM-STRING.  If not, it is
	   converted if empty or an error is issued if it is non-empty. */

check_random_string: proc (new_mode);

dcl	new_mode fixed bin;

	     io_ops_since_margin = io_ops_since_margin + 1;

	     if open_mode = new_mode then return;
	     if open_mode = String_update then return;
	     if file_type = string_file then do;
		call open_random (new_mode);
		return;
		end;

	     if must_be_ascii then goto type_and_usage_conflict;

	      /* be sure file is empty before converting type */

	     if open_mode = Ascii_output then goto type_and_usage_conflict;
						/* can't be empty if open for ascii output */
	     if length_of_file (seg_pt) > 0 then goto type_and_usage_conflict;

	     if file_type = numeric_file then call zap_file;	/* get rid of old vfile header */
	     else if file_type = ascii_file then call close_vfile;

	     if (io_ops_since_margin > 0) | (margin < 0) then do;
		margin = 12;
		io_ops_since_margin = 0;
		end;

	     call attach_string;
	     call open_random (new_mode);	/* this should create file if it doesn't already exist */

	     end;

	/* This function returns the length of a file attached through vfile_.
	   If the file is not attached, or not attached through vfile_,
	   0 is returned.  The length is in units appropriate to the type of file.  */

length_of_file: proc (iocbptr) returns (fixed bin (34));

dcl	iocbptr ptr;

	     if iocbptr = null then return (0);

	     info (1) = vfs_version_1;
	     call iox_$control (iocbptr, "file_status", addr (info), code);
	     if code ^= 0 then return (0);

	     file_lng = uns_info.end_pos;		/* this works for blocked files too */
	     if file_lng ^= 0
	     then if uns_info.type = 1			/* unstructured */
		then if uns_info.flags.header_present		/* numeric */
		     then file_lng = divide (file_lng, (precision_lng*4), 34, 0);

	     return (file_lng);

	     end;


	/* This procedure is called to completely wipe out an empty file so that
	   its type can be changed.  We must get rid of the vfile header so vfile
	   won't give us an error.  We don't do this during scratch op because
	   then we want header (with margin) to stay around. */

zap_file: proc;

	     call close_vfile;
	     if code ^= 0 then goto close_error;

	     /* truncate by  opening for stream_output without append */

	     call iox_$attach_iocb (seg_pt, "vfile_ " || file_name, code);

	     if code = 0 then do;
		attached_by_us = "1"b;
		call iox_$open (seg_pt, stream_output, "0"b, code);
		if code = 0 then opened_by_us = "1"b;
		end;

	     if code ^= 0 then goto open_error;

	     call close_vfile;		/* close this special opening */

	     end;

	/* This procedure allocates a buffer for an ASCII file */

get_ascii_buffer: proc;

	     file_type = ascii_file;
	     if margin < 0 then margin = 75;

	     buff_size, buffer_size = default_buffer_size;

	     quits_disabled = "1"b;
	     allocate buffer in(string_area);
	     quits_disabled = "0"b;

	     if had_quit then call signal_quit;

	     end;

	/* This procedure is called to force the contents of the print
	   buffer of the ASCII or TTY file specified by the global variable
	   "fcb_pt". */

force_buffer:  proc;

	     call seg_pt -> iocb.put_chars(seg_pt,buffer_pt,buffer_pos,code);
	     if code ^= 0 then goto iox_error;


	     buffer_pos = 0;
	     end;

	/* This procedure places a <NL> at the end of the print buffer of
	   the file specified by the global variable "fcb_pt" and then
	   forces the buffer. */

print_new_line: proc;

	     if buffer_pos = buffer_size then call force_buffer;

	     buffer_pos = buffer_pos + 1;
	     substr(buffer,buffer_pos,1) = NL;

	     call force_buffer;

	     line_pos = 0;
	     end;

	/* This procedure appends the varying string pointed at by the
	   global variable "p1" to the PRINT buffer of the ASCII (or TTY)
	   file specified by the global variable "fcb_pt".  In the case of
	   the "string_print" entry, the value of "p1" was set by the caller;
	   in the case of the "numeric_print" entry, the value in global
	   variable "temp(1)" is converted to string form and "p1" is set
	   to point at the result of the conversion.  This routine worries
	   about the situations where the string to be PRINTed does not
	   fit in the space left on the line and where the string is too
	   big for a completely empty line. */

numeric_print: proc;

	     if precision_lng = 1 then call convert_number;
	     else call d_convert_number;
	     ans = ans || " ";
	     p1 = addr(ans);

string_print:  entry;

	     if margin ^= 0
	     then if line_pos + length(p1 -> based_vs) > margin
		then call print_new_line;

	     do i = 0 repeat(i + k) while("1"b);
		n = length(p1 -> based_vs) - i;

		k = buffer_size - buffer_pos;
		if margin ^= 0 then k = min(k,margin - line_pos);

		if k >= n
		then do;
		     substr(buffer,buffer_pos + 1,n) = substr(p1 -> based_vs,i+1,n);
		     buffer_pos = buffer_pos + n;
		     line_pos = line_pos + n;
		     return;
		     end;

		substr(buffer,buffer_pos+1,k) = substr(p1 -> based_vs,i+1,k);
		buffer_pos = buffer_pos + k;
		line_pos = line_pos + k;

		if line_pos = margin then call print_new_line;
		else call force_buffer;
		end;

	     end;

	/* This procedure is called to close the file specified by the
	   global variable "fcb_pt".  A <NL> is placed at the end of a
	   PRINT file if needed.  A scratch file is deleted;  the bit
	   count of a non-scratch segment is computed and the file
	   is released. */

close_file:    proc(destroy);

dcl	destroy bit(1) aligned;

	     if last_operation = close_op then return;

	     if last_operation = print_op
	     then if line_pos ^= 0
		then call print_new_line;

	     code = 0;

	     call close_vfile;
	     if destroy
		then if code = 0
		     then if ^must_be_ascii
			     then call iox_$destroy_iocb (seg_pt, code);

	     if code ^= 0 then call print_error(157);

	     if temporary_file then do;

		/* A temporary file gets deleted after closing */

		call expand_path_(addr(file_name),length(file_name),addr(dir),addr(ent),code);
		call hcs_$delentry_file(dir,ent,code);

		if code = error_table_$fulldir
		then do;

		     /* file is multi-segment-file */

		     call hcs_$del_dir_tree(dir,ent,code);

		     if code = 0 then call hcs_$delentry_file(dir,ent,code);
		     end;

		/* ignore other error codes */
		end;

	     last_operation = close_op;
	     end;

	/* This procedure is called to close all files belonging to
	   the current object program;  any files received as parameters
	   will not be closed.  If the TTY belongs to this object program
	   and the closing is NORMAL, a <NL> will be appended to the
	   TTY output. */

close_all_files: proc(normal);

dcl	     normal bit(1) aligned;

	     do i = 1 to 16;
		fcb_pt = fcb(i);

		if fcb_pt ^= null
		then if owner = bo_pt
		     then do;
			if fcb_pt -> basic_fcb.seg_pt ^= null
			then call close_file("1"b);

			quits_disabled = "1"b;
			free basic_fcb in(string_area);
			quits_disabled = "0"b;

			if had_quit then call signal_quit;
			end;
		end;

	     if normal
	     then do;
		fcb_pt = fcb(0);

		if owner = bo_pt
		then do;
		     if last_operation = print_op
		     then if line_pos ^= 0
			then call print_new_line;

		     owner = null;
		     end;

		end;
	     end;

	/* This procedure is called to get a line of input for an INPUT
	   operation on the file specified by the global variable "fcb_pt".
	   A non-zero argument indicates an error message to be printed if
	   the file is actually the TTY. */

get_input:     proc(en);

dcl	     en fixed bin;

	     if file_type = tty_file
	     then if en ^= 0
		then call print_error(en);

	     call read_line;

	     if code = error_table_$end_of_info then goto end_of_file;
	     end;

	/* This procedure is called to read a complete line of input from
	   an ASCII file.  If the line is too long for the buffer associated
	   with the file, a new buffer of twice the size is obtained and
	   another read is done.  */

read_line:     proc;

dcl	     bp ptr,
	     bl fixed bin(21);

	     call seg_pt -> iocb.get_line(seg_pt,buffer_pt,buffer_size,buffer_length,code);

	     do while(code ^= 0);
		if code ^= error_table_$long_record then return;

		if file_type = tty_file then goto input_line_too_long;
		if buffer_size >= max_buffer_size then goto input_line_too_long;

		old_buff_size = buffer_size;
		buffer_size = 2 * old_buff_size;

		quits_disabled = "1"b;
		allocate buffer in(string_area) set(bp);
		substr(bp -> buffer,1,old_buff_size) = substr(buffer,1,old_buff_size);
		free buffer in(string_area);
		buffer_pt = bp;
		quits_disabled = "0"b;

		if had_quit then call signal_quit;

		call seg_pt -> iocb.get_line(seg_pt,addr(buff2),old_buff_size,bl,code);

		buffer_length = buffer_length + bl;
		end;

	     buffer_pos = 0;
	     end;

	/* This procedure is called to open the file whose name is in fcb
	   specified by global variable fcb_pt.  If the file name begins
	   with ":", it is a Multics switch name;  otherwise, the file name
	   specifies a segment or msf in storage system.  If the file exists,
	   open_file attempts to determine type so it can open file
	   appropriately;  if file doesn't exist, we can't create it */

open_file:     proc;

	     /* Give special operating system a chance to change file name */

	     call basic_file_name_(file_name);

	     if substr(file_name,1,1) = ":"
	     then do;
     
		/* file name is Multics switch name */

		if fast_related_data_$in_fast_or_dfast then go to open_error;	/* don't allow this mode in FAST */
     
		must_be_ascii = "1"b;
     
		n = index(file_name," ");
		if n = 0 then n = length(file_name) + 1;

		call iox_$find_iocb(substr(file_name,2,n-1),seg_pt,code);
		if code ^= 0 then goto open_error;

		/* we must attach using description given in file name
		   if iocb is not already attached */

		if seg_pt -> iocb.attach_descrip_ptr = null
		then do;
		     if n > length(file_name) then goto open_error;

		     do while(substr(file_name,n,1) = " ");
			if n >= length(file_name) then goto open_error;
			n = n + 1;
			end;

		     call iox_$attach_iocb(seg_pt,substr(file_name,n),code);
		     if code ^= 0 then goto open_error;

		     attached_by_us = "1"b;
		     end;
		file_type = ascii_file;

		/* open file if not already open, if already open, determine mode */

		p4 = seg_pt -> iocb.open_descrip_ptr;

		if p4 ^= null
		then do;
		     if substr(p4 -> based_vs,1,6) ^= "stream" then goto open_error;

		     n = index(p4 -> based_vs," ") - 1;
		     if n < 0 then n = length(p4 -> based_vs);

		     if index(substr(p4 -> based_vs,1,n),"input") ^= 0 then open_mode = Ascii_input;
		     if index(substr(p4 -> based_vs,1,n),"output") ^= 0 then do;
			if open_mode = Ascii_input
			then open_mode = Ascii_input_output;
			else open_mode = Ascii_output;
			write_permission = "1"b;
			end;

		     end;

		call get_ascii_buffer;
		end;
	     else do;
     
		/* file is segment or msf in storage system */
     
		must_be_ascii = "0"b;
     
		call expand_path_(addr(file_name),length(file_name),addr(dir),addr(ent),code);
     
		if code ^= 0 then goto file_error;
     
		call hcs_$status_(dir,ent,1,addr(status_info_branch),null,code);
     
		if code ^= 0
		then do;
     
		     /* if file does not exist, we cannot create it until
		        we know what type it is to be. */
     
		     if code ^= error_table_$noentry then goto open_error;
		     write_permission = "1"b;		/* can write if we create */
     
		     return;
		     end;
     
		write_permission = substr (mode,4,1);
		if status_info_branch.type = "10"b	/* directory */
		then do;
		     must_be_ascii = "1"b;		/* to keep close from truncating */
		     call attach_ascii;
		     end;
		else do;
     
		     /* we must have at least 'r' permission on segment */

		     if substr(mode,2,1) = "0"b then goto open_error;
     
		     /* determine type and open */

		     info(1) = vfs_version_1;			/* set version number */
		     call vfile_status_ (dir, ent, addr(info), code);
		     if code ^= 0 then go to open_error;	/* can't do anything */


		      /* check for old format random files and convert if necessary */

		      if uns_info.type = 1
		     then if ^uns_info.flags.header_present
			then do;

			     call convert_old_basic_file_ (dir, ent, code);
			     if code = 0 then do;

				call ioa_ ("Converted file ^a to new format.", file_name);
				call vfile_status_(dir, ent, addr(info), code);
				end;

			     else if code =  error_table_$not_done
				then do;
				     call attach_ascii;
				     return;
				     end;
				else do;
				     call ioa_ ("Unable to convert old format file ^a to new format.", file_name);
				     go to open_error;
				     end;

			     end;

		     if blk_info.type = 3 then do;
			margin = blk_info.max_rec_len;
			call attach_string;
			end;

		     else if uns_info.type ^= 1
			then goto type_and_usage_conflict;
			else do;
			     if ^uns_info.flags.header_present then call attach_ascii;

			     else do;
				if uns_info.header_id ^= precision_lng then goto type_and_usage_conflict;
				margin = 1;
				call attach_numeric;
				end;
			     end;
		     end;
     
		end;
     
	     end;

	/* This procedure specifies the attachment options for a terminal format file.
	   Opening is done when the file is actually referenced. */

attach_ascii:  proc;

	     call attach_vfile ("vfile_ " || rtrim(file_name) || " -append " || ascii_size_op);

	     call get_ascii_buffer;

	     file_type = ascii_file;

	     end;

	/* This procedure specifies the attachment options for a random numeric file.
	   Opening is done when the file is actually referenced. */

attach_numeric:  proc;

	     call attach_vfile ("vfile_ " || rtrim(file_name) || " -no_trunc -header " || header_numbers(precision_lng) || " -ssf");

	     file_type = numeric_file;

	     end;

	/* This procedure specifies the attachment options for a random string file.
	   Opening is done when the file is actually referenced. */

attach_string:  proc;

dcl	k fixed bin;
dcl	fixed_dec_value fixed dec(7);
dcl	fixed_digits char(8) aligned based(addr(fixed_dec_value));

	     fixed_dec_value = convert(fixed_dec_value, margin);
	     k = verify (substr (fixed_digits, 2), "0");

	     call attach_vfile ("vfile_ " || rtrim(file_name) || " -blocked " || substr(fixed_digits, k+1)  || " -ssf");

	     file_type = string_file;

	     end;

	/* This procedure is called to attach a file via the vfile_
	   IO module using a unique stream name of the form basic.xxxx */

attach_vfile:  proc(attach_descrip);

dcl	     attach_descrip char(*);

	     attached_by_us = "1"b;

	     if seg_pt = null then do;
		call iox_$find_iocb(unique(),seg_pt,code);
		if code ^= 0 then goto open_error;
		end;

	     call iox_$attach_iocb (seg_pt, attach_descrip, code);
	     if code ^= 0 then goto open_error;

	     end;

	/* This procedure returns a string of the form
		basic.nnnnnn
	   where the decimal number nnnnnn is incremented
	   by 1 each time unique is called. */

unique:	     proc returns(char(12));

dcl	     unique_count fixed dec(6) static init(0),
	     1 unique_value static,
	     2 header	char(6) init("basic."),
	     2 count	picture "999999";

	     unique_count = unique_count + 1;
	     unique_value.count = unique_count;

	     return(string(unique_value));
	     end;

	     /* This procedure opens an ascii file.  If the file is already open, it must
	        be closed first. */

open_ascii:    proc (new_open_mode);

dcl	new_open_mode fixed bin;

	     if open_mode > Not_open then do;
		if ^opened_by_us then goto open_error;
		call iox_$close (seg_pt, code);
		if code ^= 0 then goto open_error;
		end;

	     call iox_$open (seg_pt, open_types (new_open_mode), "0"b, code);
	     if code ^= 0 then goto open_error;

	     opened_by_us = "1"b;
	     open_mode = new_open_mode;
	     end;


	     /* This procedure opens a random numeric or string file.  If the file is already open,
	        the current position must be remembered, the file must be closed, and the
	        position must be restored after reopening. */

open_random:   proc (new_open_mode);

dcl	new_open_mode fixed bin;

	     if open_mode > Not_open then do;
		if ^opened_by_us then goto open_error;
		call iox_$control (seg_pt, "read_position", addr(position_info), code);
		if code ^= 0 then goto open_error;
		buff_size = position_info.next_position;
		call iox_$close (seg_pt, code);
		if code ^= 0 then goto open_error;
		end;

	     call iox_$open (seg_pt, open_types (new_open_mode), "0"b, code);
	     if code ^= 0 then goto open_error;

	     opened_by_us = "1"b;			/* set so we can close */

	     if open_mode > Not_open then do;
		call iox_$position (seg_pt, 2, buff_size, code);
		if code ^= 0 then goto pointer_error;
		end;

	     open_mode = new_open_mode;

	     end;


	/* This procedure is called to close a file.  The file is closed
	   and detached (if we opened or attached), and for ascii files
	   the buffer is freed.  */

close_vfile:   proc;

	     if seg_pt ^= null then do;		/* sometimes this gets called with seg_pt=null! */
	     if seg_pt -> iocb.open_descrip_ptr ^= null & opened_by_us
	     then do;
		call seg_pt -> iocb.close(seg_pt,code);
		if code ^= 0 then return;
		opened_by_us = "0"b;
		open_mode = Not_open;
		end;

	     if seg_pt -> iocb.attach_descrip_ptr ^= null & attached_by_us
	     then do;
		call seg_pt -> iocb.detach_iocb(seg_pt,code);
		if code ^= 0 then return;
		attached_by_us = "0"b;
		end;
	     end;

	     if buffer_pt ^= null then do;
		quits_disabled = "1"b;
		free buffer in(string_area);
		buffer_pt = null;
		quits_disabled = "0"b;
	     end;

	     if had_quit then call signal_quit;

	     file_type = undefined_file;
	     end;


	/* This procedure is called to tab to the indicated position on
	     the PRINT file specified by the global variable "fcb_pt". */

tab:	     proc(new_pos);

dcl	     new_pos fixed bin;

	     if margin = 0 then n = new_pos;
	     else n = mod(new_pos, margin);

	     n = n - line_pos;

	     do while(n > 0);
		k = min(buffer_size - buffer_pos,n);
		substr(buffer,buffer_pos+1,k) = "";
		buffer_pos = buffer_pos + k;

		if buffer_pos = buffer_size then call force_buffer;

		n = n - k;
		end;

	     line_pos = new_pos;
	     end;

	/* This procedure sets the global variable "n" to the file number
	   specified by the global variable "temp(1)".  An error is issued
	   if the file number is invalid, no file exists for the specified
	   number, or if the file is of the wrong type as indicated by the
	   argument "ok_type". */

get_file_number: proc(ok_type);

dcl	     ok_type bit(5) aligned;

	     n = fixed(temp(1));

	     if n < 0 then goto invalid_file_number;
	     if n > 16 then goto invalid_file_number;

	     if fcb(n) = null then goto invalid_file_number;

	     if substr(ok_type,fcb(n) -> file_type,1) = "0"b then goto invalid_file_number;
	     end;

	/* This procedure writes the value in the global variable "temp(1)"
	   into the next position in the RANDOM NUMERIC file specified
	   by the global variable "fcb_pt".  An endfile is generated if the
	   max length of the file is exceeded. */

numeric_write: proc;

	     call iox_$put_chars (seg_pt, addr(temp(1)), 4, code);

	     if code ^= 0 then goto end_of_file;	/* msg should really reflect code */

	     end;

	/* This procedure writes the varying string pointed at by the
	   global variable "p1" into the next position in the RANDOM
	   STRING file specified by the global variable "fcb_pt". 
	   An endfile is generated if the max length of the file is exceeded. */

string_write:  proc;

	     call iox_$write_record (seg_pt, addrel(p1,1), min(length(p1->based_vs), margin), code);

	     if code ^= 0 then goto end_of_file;	/* should improve to use code */

	     end;

	/* This procedures sets the global variable "temp(1)" to the value
	   in the next position in the RANDOM NUMERIC file specified by
	   the global variable "fcb_pt". */

numeric_read:  proc;

	     call iox_$get_chars (seg_pt, addr(temp(1)), 4, buff_size, code);

	     if code ^= 0 then go to end_of_file;

	     end;

	/* This procedure sets the global variable "p1" to point to
	   the next string in the RANDOM STRING file specified by
	   the global variable "fcb_pt".  A new string block is allocated. */

string_read:   proc;

	     call iox_$read_record (seg_pt, addr(string_buffer), 4096, buff_size, code);
	     if code ^= 0 then goto end_of_file;

	     n = buff_size;
	     call allocate_string;
	     p3 -> basic_string.value = substr(string_buffer, 1, n);

	     end;

	/* This procedure is called when a string value is to be returned
	   to the object program.  The global variable "string_value" is set to
	   the offset of the string block in the string segment and PR1
	   is set to point at "string_value". */

return_string: proc;

	     call deallocate_string(addr(string_value));

	     string_value = rel(p3);
	     pr(1) = addr(string_value);

	     end;

	/* This procedure is called to read a numeric value from the
	   file specified by the global variable "fcb_pt".  The "conversion"
	   condition is handled by setting the global variable "conversion_label"
	   before the conversion;  after the conversion is completed the
	   global label is set to "null" by zeroing out the first word.
	   The value read will be stored in the global variable "temp(1)". */

numeric_input: proc;

	     no_input = "1"b;

num:	     if buffer_pos >= buffer_length - 1 then return;

	     n = 0;
	     do while(buffer_pos < buffer_length);
		buffer_pos = buffer_pos + 1;

		ch = substr(buffer,buffer_pos,1);

		if ch = "," then goto ni_done;
		if ch = NL then goto ni_done;

		if mat_input
		then if substr(buffer,buffer_pos,2) = amp_NL
		     then do;

			/* make sure we see & at beginning of next request */

			buffer_pos = buffer_pos - 1;
			goto ni_done;
			end;

		if search(ch,white_space) = 0
		then do;
		     n = n + 1;
		     substr(c32,n,1) = ch;
		     end;
		end;

	     /* there was no NL at end of input line */

	     if file_type ^= tty_file then goto incorrect_format_for_file_input;

	     call get_input(-110);
	     goto num;

ni_done:	     if n = 0
	     then do;
		if ch = "," then goto num;
		if ch ^= "&" then return;

		if file_type = tty_file then call prompt;

		call get_input(0);
		goto num;
		end;

	     if file_type = tty_file
	     then if substr(c32,1,1) = "s" | substr(c32,1,1) = "S"
		then do;
		     call print_error(109);
		     goto abort_label;
		     end;

	     conversion_label = bad_ni;

	     if precision_lng = 1 then temp(1) = convert(temp(1),substr(c32,1,n));
	     else d_temp(1) = convert(d_temp(1),substr(c32,1,n));

	     have_conversion_label = "0"b;
	     no_input = "0"b;
	     return;

bad_ni:	     if file_type ^= tty_file then goto incorrect_format_for_file_input;

     /* special case this message because an extra string  is printed */
	     call ioa_$nnl ("Incorrect numeric input in ^d, retype beginning with ^a^/?",
		get_line_number(), substr(c32, 1,  n));
	     call get_input(0);
	     goto num;
	     end;

	/* This procedure is called to read a string value from the file
	   specified by the global variable "fcb_pt".  The global variable
	   "p3" will point to the string block for the new value. */

string_input:  proc;

	     no_input = "1"b;

str:	     if buffer_pos >= buffer_length - 1 then return;

	     n = verify(substr(buffer,buffer_pos+1,buffer_length-buffer_pos),white_space);

	     if n = 0
	     then do;
		if file_type ^= tty_file then goto incorrect_format_for_file_input;

		call get_input(-110);
		goto str;
		end;

	     buffer_pos = buffer_pos + n;

	     if substr(buffer,buffer_pos,1) = """"
	     then do;

		/* pick up quoted string */

		buffer_pos = buffer_pos + 1;

		k = index(substr(buffer,buffer_pos,buffer_length-buffer_pos+1),"""");

		if k = 0
		then do;
si_bad:		     if file_type ^= tty_file then goto incorrect_format_for_file_input;

		     call ioa_$nnl ("Incorrect string input  in ^d, retype beginning with ^a^/?",
			get_line_number(), substr(buffer, buffer_pos-1, buffer_length-buffer_pos+1));
		     call get_input(0);
		     goto str;
		     end;

		n = k-1;
		end;
	     else do;

		/* pick up string terminated by a comma or NL */

		k = search(substr(buffer,buffer_pos,buffer_length-buffer_pos+1),comma_NL);

		if k = 0 then goto si_bad;

		n, k = k - 1;

		if n = 0
		then if substr(buffer,buffer_pos,1) = ","
		     then goto str;
		     else return;

		if mat_input
		then if substr(buffer,buffer_pos+k-1,2) = amp_NL
		     then if k > 1 then n = n - 1;
			else do;
			     call get_input(0);
			     goto str;
			     end;

		end;

	     call allocate_string;
	     p3 -> basic_string.value = substr(buffer,buffer_pos,n);

	     buffer_pos = buffer_pos + k;

	     no_input = "0"b;
	     end;

	/* This procedure is called to do a LINPUT operation on the file
	   specified by the global variable "fcb_pt".  The global variable
	   "p3" will be set to point to the string block for the line that
	   was read. */

linput:	     proc;

	     n = buffer_length - buffer_pos - 1;
	     if n < 0 then n = 0;

	     call allocate_string;

	     p3 -> basic_string.value = substr(buffer,buffer_pos+1,n);

	     buffer_pos = buffer_length;
	     end;

	/* The procedure is called when an 8 character string is to be
	   returned to the object program;  the value to be used is in
	   the global variable "c8". */

use_c8:	     proc;

	     n = 8;
	     call allocate_string;
	     p3 -> basic_string.value = c8;
	     call return_string;
	     end;

	/* This procedure is called to do the looping required to do the
	   matrix operation indicated by the argument "action_code".
	   Global variable PR2 points at the array dope. */

mat_loop:      proc(action_code);

dcl	     action_code fixed bin;

dcl	     (row,row_max,col,col_max,i) fixed bin,
	     data_pt ptr,
	     vector bit(1) aligned;

	     row_max = pr(2) -> current_bounds(1) - 1;
	     if row_max <= 0 then goto array_error;

	     col_max = pr(2) -> current_bounds(2);
	     if col_max = 0 then goto array_error;

	     if col_max < 0
	     then do;
		vector = "1"b;
		col_max = 1;
		i = 1;

		if action_code <= 2
		then if a_reg = 0
		     then row_max = pr(2) -> original_bounds(1) - 1;
		end;
	     else do;
		vector = "0"b;
		col_max = col_max - 1;
		i = col_max + 2;
		end;

	     data_pt = pr(2) -> array_dope.data;

	     do row = 1 to row_max;
		do col = 1 to col_max;

		     goto mat(action_code);

		     /* numeric input */

mat(1):		     call numeric_input;

		     if no_input
		     then do;
			if vector & a_reg = 0
			then do;
			     pr(2) -> current_bounds(1) = number_read + 1;
			     return;
			     end;

			do while(no_input);
			     call get_input(-107);
			     call numeric_input;
			     end;
			end;

		     number_read = number_read + 1;

		     data_pt -> float_bin(i) = temp(1);
		     goto next_mat;

		     /* string input */

mat(2):		     call string_input;

		     if no_input
		     then do;
			if vector & a_reg = 0
			then do;
			     pr(2) -> current_bounds(1) = number_read + 1;
			     return;
			     end;

			do while(no_input);
			     call get_input(-107);
			     call string_input;
			     end;
			end;

		     call deallocate_string(addr(data_pt -> bit_word(i)));

		     number_read = number_read + 1;

		     data_pt -> bit_word(i) = rel(p3);
		     goto next_mat;

		     /* numeric print */

mat(3):		     temp(1) = data_pt -> float_bin(i);
		     call numeric_print;

		     call mat_print_format_check;
		     goto next_mat;

		     /* string print */

mat(4):		     p1 = get_string_ptr(addr(data_pt -> bit_word(i)));
		     call string_print;

		     call mat_print_format_check;
		     goto next_mat;

		     /* numeric data read */

mat(5):		     if numeric_data.start >= numeric_data.finish then goto out_of_data;

		     data_pt -> float_bin(i) = text_base_ptr -> float_bin(numeric_data.start);

		     numeric_data.start = numeric_data.start + 1;
		     goto next_mat;

		     /* string data read */

mat(6):		     if string_data.start >= string_data.finish then goto out_of_data;

		     call deallocate_string(addr(data_pt -> bit_word(i)));

		     p1 = addr(text_base_ptr -> bit_word(text_base_ptr -> fix_bin(string_data.start)));
		     n = length(p1 -> based_vs);

		     call allocate_string;
		     p3 -> basic_string.value = p1 -> based_vs;

		     data_pt -> bit_word(i) = rel(p3);

		     string_data.start = string_data.start + 1;
		     goto next_mat;

		     /* numeric read */

mat(7):		     call numeric_read;
		     data_pt -> float_bin(i) = temp(1);
		     goto next_mat;

		     /* string read */

mat(8):		     call deallocate_string(addr(data_pt -> bit_word(i)));

		     call string_read;
		     data_pt -> bit_word(i) = rel(p3);
		     goto next_mat;

		     /* numeric write */

mat(9):		     temp(1) = data_pt -> float_bin(i);
		     call numeric_write;
		     goto next_mat;

		     /* string write */

mat(10):		     p1 = get_string_ptr(addr(data_pt -> bit_word(i)));
		     call string_write;
		     goto next_mat;

		     /* linput */

mat(11):		     call deallocate_string(addr(data_pt -> bit_word(i)));

		     call check_input;	/* get next line */
		     call linput;

		     data_pt -> bit_word(i) = rel(p3);
		     goto next_mat;

		     /* numeric print using */

mat(12):		     temp(1) = data_pt -> float_bin(i);
		     call print_using_numeric;
		     call mat_print_using_check;
		     goto next_mat;

		     /* string print using */

mat(13):		     p1 = get_string_ptr(addr(data_pt -> bit_word(i)));
		     call print_using_string;
		     call mat_print_using_check;
		     goto next_mat;

		     /* set string matrix to nul */

mat(14):		     call deallocate_string(addr(data_pt -> bit_word(i)));
		     data_pt -> bit_word(i) = "0"b;
		     goto next_mat;

		     /* mat a$ = b$ */

mat(15):		     pr(3) = addr(data_pt -> bit_word(i));
		     pr(1) = addr(p4 -> bit_word(i));
		     call string_assign;
		     goto next_mat;

next_mat:		     i = i + 1;
		     end;

		if ^ vector then i = i + 1;
		end;

mat_print_format_check: proc;

		if col ^= col_max then call mat_print_format;
		else if vector
		     then if row ^= row_max
			then call mat_print_format;
			else call print_new_line;
		     else call print_new_line;

		end;

mat_print_format:   proc;

		if a_reg = 0 then call print_new_line;
		else if a_reg = 1
		     then call tab(divide(line_pos + 15,15,17,0)*15);

		end;

mat_print_using_check: proc;

		if col = col_max
		then if ^ vector
		     then do;
			call print_new_line;
			pu_pos = 0;
			end;

		end;

	     end;

	/* This procedure is called at the end of an INPUT operation on
	   the file specified by the global variable "fcb_pt".  It
	   verifies that no unexpected data values were provided. */

end_input:     proc;

	     if buffer_pos < buffer_length
	     then if verify(substr(buffer,buffer_pos+1,buffer_length-buffer_pos-1),", ") ^= 0
		then call print_error(108);
     
	     buffer_pos = buffer_length;
	     end;

	/* This procedure writes its string argument, a character at a
	   time, into the file indicated by the global variable "fcb_pt". */

put_string:    proc(s);

dcl	     s char(*) aligned;

dcl	     si fixed bin;

	     do si = 1 to length(s);
		call put_char(substr(s,si,1));
		end;

	     end;

	/* This procedure writes a single character into the print buffer
	   of the file specified by the global variable "fcb_pt". */

put_char:      proc(c);

dcl	     c char(1) aligned;

	     if buffer_pos = buffer_size then call force_buffer;

	     if margin ^= 0
	     then if line_pos = margin
		then call print_new_line;

	     line_pos = line_pos + 1;

	     buffer_pos = buffer_pos + 1;
	     substr(buffer,buffer_pos,1) = c;

	     end;


	/* This procedure is called to identify the next field in a
	   PRINT USING string;  the argument indicates if this is the
	   end of the PRINT USING operation.  Data about the field that
	   was found is left in the global variables "field_length", "field_start",
	   "precision", "scale", "exp_length", "left_just", and "right_just".
	   Any characters that precede the start of the field are written
	   into the output buffer of the file specified by global variable
	   "fcb_pt". */

get_next_field: proc(end_scan);

dcl	     end_scan bit(1) aligned;

dcl	     here_before bit(1);

	     here_before = "0"b;

	     field_length,
	     field_start,
	     precision,
	     scale,
	     exp_length = 0;

	     string(print_using_bits) = "0"b;

next_char:     pu_pos = pu_pos + 1;

	     if pu_pos > pu_length
	     then do;
		if field_start ^= 0 then goto end_field;

		if end_scan then return;

		if here_before then goto print_using_error;

		here_before = "1"b;
		call print_new_line;
		pu_pos = 0;
		goto next_char;
		end;

	     goto case(index("<>$+-#^.",substr(pu_string,pu_pos,1)));

	     /* not special character */

case(0):	     if field_start = 0 then call put_char(substr(pu_string,pu_pos,1));
	     else field_length = field_length + 1;

	     goto next_char;

	     /* < */

case(1):	     if field_start ^= 0 then goto end_field;

	     left_just = "1"b;

case1a:	     field_start = pu_pos;
	     field_length = field_length + 1;
	     goto next_char;

	     /* > */

case(2):	     if field_start ^= 0 then goto end_field;

	     right_just = "1"b;
	     goto case1a;

	     /* $ */

case(3):	     if field_start ^= 0 then goto end_field;

	     have_dollar = "1"b;

	     field_start = pu_pos;
	     field_length = field_length + 1;

	     /* make sure $ is followed by + or - */

	     if pu_pos = pu_length then goto print_using_error;

	     if substr(pu_string,pu_pos+1,1) = "+" then have_plus = "1"b;
	     else do;
		have_minus = "1"b;		/* - is assumed when there is no control */
		if substr(pu_string,pu_pos+1, 1) ^= "-" then go to next_char;
		end;

	     pu_pos = pu_pos + 1;

	     field_length = field_length + 1;
	     goto next_char;

	     /* + */

case(4):	     if field_start ^= 0 then goto end_field;

	     have_plus = "1"b;
	     goto case1a;

	     /* - */

case(5):	     if field_start ^= 0 then goto end_field;

	     have_minus = "1"b;
	     goto case1a;

	     /* # */

case(6):	     if exp_length ^= 0 then goto end_field;

	     if field_start = 0 then goto print_using_error;

	     field_length = field_length + 1;
	     precision = precision + 1;

	     if have_decimal then scale = scale + 1;
	     goto next_char;

	     /* ^ */

case(7):	     if field_start = 0 then goto print_using_error;

	     exp_length = exp_length + 1;
	     field_length = field_length + 1;
	     goto next_char;

	     /* . */

case(8):	     if field_start = 0 then call put_char(ch);
	     else do;
		if have_decimal then goto print_using_error;

		have_decimal = "1"b;
		field_length = field_length + 1;
		end;

	     goto next_char;

end_field:     if exp_length ^= 0
	     then do;
		if exp_length ^= 5 then goto print_using_error;
		have_exp = "1"b;
		end;

	     pu_pos = pu_pos - 1;
	     end;

	/* This procedure is called to put out the numeric value in the
	   global variable "temp(1)" on file specified by global variable
	   "fcb_pt" according to the next field in the PRINT USING string.
	   The "size" condition is handled by setting the global label
	   variable "size_label" which is recognized by the default
	   handler;  the label is reset after the conversion by setting
	   its first word to zero. */

print_using_numeric: proc;

dcl	     zero_surpression bit(1),
	     exp fixed bin,
	     float_sign aligned char(1);

dcl	     1 decimal_value	based(addr(c64)) aligned,
	     2 sign		char(1) unal,
	     2 digit(precision)	char(1) unal,
	     2 skip		bit(1) unal,
	     2 exponent		fixed bin(7) unal;

	     call get_next_field("0"b);

	     if left_just then goto print_using_error;
	     if right_just then goto print_using_error;

	     if scale > 38 then goto punt;

	     if exp_length = 0
	     then do;

		/* f format */

		if have_minus
		then if temp(1) >= 0
		     then precision = precision + 1;

		if precision = 0 then goto punt;

		size_label = punt;

		call assign_round_(addr(c64),18,fixed(scale * 1000000000000000000b + precision,35),
		 addr(temp(1)),6,27);

		have_size_label = (36)"0"b;
		end;
	     else do;

		/* e format, we assume the following conversion
		   produces a left justified result */

		if precision = 0 then precision = 1;

		call assign_round_(addr(c64),20,precision,addr(temp(1)),6,27);

		if temp(1) = 0 then exp = 0;
		else exp = exponent + scale;
		end;

	     zero_surpression = ^ have_exp;

	     digit_count = 0;
	     digit_pos = 0;

	     do field_pos = field_start to field_start+field_length - 1;
		ch = substr(pu_string,field_pos,1);
		goto case(index("$+-#^.",ch));

case(0):		if zero_surpression then ch = " ";
		goto place;

		/* $ */

case(1):		goto next;

		/* + */

case(2):		float_sign = decimal_value.sign;

		if have_exp then call put_char(float_sign);

		goto next;

		/* - */

case(3):		if temp(1) < 0 then goto case(2);

		float_sign = " ";

		if have_exp
		then do;
		     call put_char(float_sign);
		     goto next;
		     end;

		/* # */

case(4):		digit_pos = digit_pos + 1;
		ch = digit(digit_pos);

		if zero_surpression
		then if ch ^= "0" | digit_pos = precision - scale | have_exp
		     then call end_surpression;
		     else ch = " ";
		else digit_count = digit_count + 1;

		if digit_count > 8 then ch = "?";

		goto place;

		/* ^ */

case(5):		call put_string(" E");

		if abs(exp) < 10
		then do;
		     fixed_dec_1 = convert(fixed_dec_1,exp);
		     call put_string(fixed_dec_1_overlay);
		     call put_char(" ");
		     end;
		else do;
		     fixed_dec_2 = convert(fixed_dec_2,exp);
		     call put_string(fixed_dec_2_overlay);
		     end;

		field_pos = field_pos + 4;
		goto next;

		/* . */

case(6):		if zero_surpression
		then do;
		     call end_surpression;
		     if float_sign = " " then call put_char("0");
		     end;

place:		call put_char(ch);

next:		end;

		return;

punt:		have_size_label = (36)"0"b;

		do field_pos = field_start to field_start+field_length - 1;
		     ch = substr(pu_string,field_pos,1);

		     if index("$+-#^",ch) ^= 0 then ch = "*";

		     call put_char(ch);
		     end;


end_surpression:	proc;

		if have_dollar then call put_char("$");

		if float_sign ^= " " then call put_char(float_sign);

		zero_surpression = "0"b;
		end;

	     end;

	/* This procedure is called to output the string value specified by
	   the global pointer "p1" on the file specified by the global
	   variable "fcb_pt" according to the next field in the PRINT USING
	   string. */

print_using_string: proc;

dcl	     (n_spaces,s_pos) fixed bin;

	     call get_next_field("0"b);

	     if right_just
	     then do;
		n_spaces = precision + 1 - length(p1 -> based_vs);

		if n_spaces >= 0 then s_pos = 0;
		else s_pos = - n_spaces;
		end;
	     else if left_just
		then n_spaces, s_pos = 0;
		else goto print_using_error;

	     do field_pos = field_start to field_start + field_length - 1;
		ch = substr(pu_string,field_pos,1);

		if index("<>#",ch) ^= 0
		then if n_spaces > 0
		     then do;
			ch = " ";
			n_spaces = n_spaces - 1;
			end;
		     else do;
			s_pos = s_pos + 1;

			if s_pos > length(p1 -> based_vs) then ch = " ";
			else ch = substr(p1 -> based_vs,s_pos,1);
			end;

		call put_char(ch);
		end;

	     end;

	/* This procedure is called to resignal the quit condition because
	   a quit occurred while quits were inhibited */

signal_quit:   proc;

dcl	     quit condition;

	     had_quit = "0"b;
	     signal quit;

	     end;


	/* This procedure is called to convert the value in the global variable
	   "temp(1)" from float binary(27) to the appropriate string representation
	   in I, F, or E format according to the rules of the language;
	   the converted value is placed in the global variable "ans". */

d_convert_number: proc;
     
dcl	     abs_value float bin(63),
	     (k,j,ndigits,num_size) fixed bin,
	     fixed_dec_value fixed dec(9),
	     exp fixed bin;
     
dcl	     1 c64_overlay aligned based(addr(c64)),
	     2 sign	char(1) unaligned,
	     2 digits	char(num_size) unaligned,
	     2 skip	bit(1) unaligned,
	     2 exponent	fixed bin(7) unaligned;
     
dcl	     fixed_digits char(10) aligned based(addr(fixed_dec_value));

	     if d_temp(1) = 0
	     then do;
		ans = " 0";
		return;
		end;
     
	     abs_value = abs(d_temp(1));
     
	     if d_temp(1) < 0 then ans = "-"; else ans = " ";
     
	     if abs_value < 134217728	/* 2 ** 27 */
	     then if float(fixed(abs_value)) = abs_value
		then do;
     
		     /* integer format */
     
		     fixed_dec_value = convert(fixed_dec_value,abs_value);
     
		     k = verify(substr(fixed_digits,2),"0");
		     ans = ans || substr(fixed_digits,k+1);
		     return;
		     end;
     
	     /* we assume that the following conversion is ROUNDED
	        and normalized to the left */
     
	     num_size = number_length;		/* copy for faster accessing */
	     call assign_round_(addr(c64),20,num_size,addr(d_temp(1)),8,63);
     
	     k = verify(reverse(digits),"0");
	     ndigits = num_size - k + 1;
     
	     exp = exponent + k - 1;
     
	     if exp >= 0
	     then do;

		if (exp + ndigits) = num_size
		then do;

		     /* due to rounding integer is closest approximation */
		     /* type 1234560 */

		     ans = ans || substr(digits,1,ndigits);

		     ans = ans || ".";		/* indicate integer is approximation */
		     return;
		     end;

		/* exponential format */

e_format:		ans = ans || substr(digits,1,1);
		ans = ans || ".";
		ans = ans || substr(digits,2,ndigits-1);
		ans = ans || " E";

		exp = exp + ndigits - 1;
     
		if abs(exp) < 10
		then do;
		     fixed_dec_1 = convert(fixed_dec_1,exp);
		     ans = ans || fixed_dec_1_overlay;
		     end;
		else do;
		     fixed_dec_2 = convert(fixed_dec_2,exp);
		     ans = ans || fixed_dec_2_overlay;
		     end;
     
		return;
		end;
     
	     j = ndigits + exp;
     
	     if j <= 0
	     then do;
		if ndigits - j > num_size then goto e_format;	/* type .0123456 */
		/* type .000123 */
     
		ans = ans || "0.";
		if j ^= 0 then ans = ans || substr("0000000000000000000",1,abs(j));
		ans = ans || substr(digits,1,ndigits);
		end;
	     else do;
		/* type 1.23456 */
		ans = ans || substr(digits,1,j);
		ans = ans || ".";
		ans = ans || substr(digits,j+1,ndigits-j);
		end;
     
	     end;

	     /* This function converts the BASIC string specified by pr(1)
	        to a numeric value in temp(1).  "1"b is returned if no
	        error was found and "0"b is returned if the string was
	        erroneous.  The conversion is attempted twice;  if the
	        first attempt fails, we try again with all white space removed
	        from the string.  This logic attempts to optimize the
	        simple cases that do not have embedded white space. */

d_convert_string: proc returns(bit(1) aligned);

dcl	     good_string bit(1) aligned;

	     p1 = get_string_ptr(pr(1));
	     good_string = "0"b;

	     conversion_label = first_error;
	     d_temp(1) = convert(d_temp(1),p1 -> based_vs);

ok:	     good_string = "1"b;

done:	     have_conversion_label = (36)"0"b;
	     return(good_string);

	     /* had error first time, try again if string contains white space */

first_error:   if search(p1 -> based_vs,white_space) = 0 then goto done;

	     conversion_label = done;

		begin;

dcl		copy char(length(p1 -> based_vs)),
		(i,j) fixed bin;

		copy = "";
		j = 0;

		do i = 1 to length(p1 -> based_vs);
		     if index(white_space,substr(p1 -> based_vs,i,1)) = 0
		     then do;

			/* current char not white space, copy it */

			j = j + 1;
			substr(copy,j,1) = substr(p1 -> based_vs,i,1);
			end;
		     end;

		d_temp(1) = convert(d_temp(1),copy);
		end;

	     goto ok;
	     end;

	/* This procedure writes the value in the global variable "temp(1)"
	   into the next position in the RANDOM NUMERIC file specified
	   by the global variable "fcb_pt".  An endfile is generated if the
	   max length of the file is exceeded. */

d_numeric_write: proc;

	     call iox_$put_chars(seg_pt, addr(d_temp(1)), 8, code);

	     if code ^= 0 then goto end_of_file;

	     end;

	/* This procedures sets the global variable "temp(1)" to the value
	   in the next position in the RANDOM NUMERIC file specified by
	   the global variable "fcb_pt". */

d_numeric_read:  proc;

	     call iox_$get_chars(seg_pt, addr(d_temp(1)), 8, buff_size, code);

	     if code ^= 0 then goto end_of_file;

	     end;

	/* This procedure is called to do the looping required to do the
	   matrix operation indicated by the argument "action_code".
	   Global variable PR2 points at the array dope. */

d_mat_loop:      proc(action_code);

dcl	     action_code fixed bin;

dcl	     (row,row_max,col,col_max,i) fixed bin,
	     data_pt ptr,
	     vector bit(1) aligned;

	     row_max = pr(2) -> current_bounds(1) - 1;
	     if row_max <= 0 then goto array_error;

	     col_max = pr(2) -> current_bounds(2);
	     if col_max = 0 then goto array_error;

	     if col_max < 0
	     then do;
		vector = "1"b;
		col_max = 1;
		i = 1;

		if action_code <= 2
		then if a_reg = 0
		     then row_max = pr(2) -> original_bounds(1) - 1;
		end;
	     else do;
		vector = "0"b;
		col_max = col_max - 1;
		i = col_max + 2;
		end;

	     data_pt = pr(2) -> array_dope.data;

	     do row = 1 to row_max;
		do col = 1 to col_max;

		     goto mat(action_code);

		     /* numeric input */

mat(1):		     call numeric_input;

		     if no_input
		     then do;
			if vector & a_reg = 0
			then do;
			     pr(2) -> current_bounds(1) = number_read + 1;
			     return;
			     end;

			do while(no_input);
			     call get_input(-107);
			     call numeric_input;
			     end;
			end;

		     number_read = number_read + 1;

		     data_pt -> double_float_bin(i) = d_temp(1);
		     goto next_mat;

		     /* string input */

mat(2):		     call string_input;

		     if no_input
		     then do;
			if vector & a_reg = 0
			then do;
			     pr(2) -> current_bounds(1) = number_read + 1;
			     return;
			     end;

			do while(no_input);
			     call get_input(-107);
			     call string_input;
			     end;
			end;

		     call deallocate_string(addr(data_pt -> double_bit_word(i)));

		     number_read = number_read + 1;

		     data_pt -> double_bit_word(i) = rel(p3);
		     goto next_mat;

		     /* numeric print */

mat(3):		     d_temp(1) = data_pt -> double_float_bin(i);
		     call numeric_print;

		     call mat_print_format_check;
		     goto next_mat;

		     /* string print */

mat(4):		     p1 = get_string_ptr(addr(data_pt -> double_bit_word(i)));
		     call string_print;

		     call mat_print_format_check;
		     goto next_mat;

		     /* numeric data read */

mat(5):		     if numeric_data.start >= numeric_data.finish then goto out_of_data;

		     data_pt -> double_float_bin(i) = addr(text_base_ptr -> float_bin(numeric_data.start)) -> double_float_bin(0);

		     numeric_data.start = numeric_data.start + 2;
		     goto next_mat;

		     /* string data read */

mat(6):		     if string_data.start >= string_data.finish then goto out_of_data;

		     call deallocate_string(addr(data_pt -> double_bit_word(i)));

		     p1 = addr(text_base_ptr -> bit_word(text_base_ptr -> fix_bin(string_data.start)));
		     n = length(p1 -> based_vs);

		     call allocate_string;
		     p3 -> basic_string.value = p1 -> based_vs;

		     data_pt -> double_bit_word(i) = rel(p3);

		     string_data.start = string_data.start + 1;
		     goto next_mat;

		     /* numeric read */

mat(7):		     call d_numeric_read;
		     data_pt -> double_float_bin(i) = d_temp(1);
		     goto next_mat;

		     /* string read */

mat(8):		     call deallocate_string(addr(data_pt -> double_bit_word(i)));

		     call string_read;
		     data_pt -> double_bit_word(i) = rel(p3);
		     goto next_mat;

		     /* numeric write */

mat(9):		     d_temp(1) = data_pt -> double_float_bin(i);
		     call d_numeric_write;
		     goto next_mat;

		     /* string write */

mat(10):		     p1 = get_string_ptr(addr(data_pt -> double_bit_word(i)));
		     call string_write;
		     goto next_mat;

		     /* linput */

mat(11):		     call deallocate_string(addr(data_pt -> double_bit_word(i)));

		     call check_input;	/* get next line */
		     call linput;

		     data_pt -> double_bit_word(i) = rel(p3);
		     goto next_mat;

		     /* numeric print using */

mat(12):		     d_temp(1) = data_pt -> double_float_bin(i);
		     call d_print_using_numeric;
		     call mat_print_using_check;
		     goto next_mat;

		     /* string print using */

mat(13):		     p1 = get_string_ptr(addr(data_pt -> double_bit_word(i)));
		     call print_using_string;
		     call mat_print_using_check;
		     goto next_mat;

		     /* set string matrix to nul */

mat(14):		     call deallocate_string(addr(data_pt -> double_bit_word(i)));
		     data_pt -> double_bit_word(i) = "0"b;
		     goto next_mat;

		     /* mat a$ = b$ */

mat(15):		     pr(3) = addr(data_pt -> double_bit_word(i));
		     pr(1) = addr(p4 -> double_bit_word(i));
		     call string_assign;
		     goto next_mat;

next_mat:		     i = i + 1;
		     end;

		if ^ vector then i = i + 1;
		end;

mat_print_format_check: proc;

		if col ^= col_max then call mat_print_format;
		else if vector
		     then if row ^= row_max
			then call mat_print_format;
			else call print_new_line;
		     else call print_new_line;

		end;

mat_print_format:   proc;

		if a_reg = 0 then call print_new_line;
		else if a_reg = 1
		     then do;
			     tab_size = max(15,number_length+8);
			     call tab(divide(line_pos + tab_size, tab_size, 17, 0)*tab_size);
			     end;

		end;

mat_print_using_check: proc;

		if col = col_max
		then if ^ vector
		     then do;
			call print_new_line;
			pu_pos = 0;
			end;

		end;

	     end;

	/* This procedure is called to put out the numeric value in the
	   global variable "temp(1)" on file specified by global variable
	   "fcb_pt" according to the next field in the PRINT USING string.
	   The "size" condition is handled by setting the global label
	   variable "size_label" which is recognized by the default
	   handler;  the label is reset after the conversion by setting
	   its first word to zero. */

d_print_using_numeric: proc;

dcl	     zero_surpression bit(1),
	     exp fixed bin,
	     float_sign aligned char(1);

dcl	     1 decimal_value	based(addr(c64)) aligned,
	     2 sign		char(1) unal,
	     2 digit(precision)	char(1) unal,
	     2 skip		bit(1) unal,
	     2 exponent		fixed bin(7) unal;

	     call get_next_field("0"b);

	     if left_just then goto print_using_error;
	     if right_just then goto print_using_error;

	     if scale > 38 then goto punt;

	     if exp_length = 0
	     then do;

		/* f format */

		if have_minus
		then if d_temp(1) >= 0
		     then precision = precision + 1;

		if precision = 0 then goto punt;

		size_label = punt;

		call assign_round_(addr(c64),18,fixed(scale * 1000000000000000000b + precision,35),
		 addr(temp(1)),8,27);

		have_size_label = (36)"0"b;
		end;
	     else do;

		/* e format, we assume the following conversion
		   produces a left justified result */

		if precision = 0 then precision = 1;

		call assign_round_(addr(c64),20,precision,addr(temp(1)),8,27);

		if d_temp(1) = 0 then exp = 0;
		else exp = exponent + scale;
		end;

	     zero_surpression = ^ have_exp;

	     digit_count = 0;
	     digit_pos = 0;

	     do field_pos = field_start to field_start+field_length - 1;
		ch = substr(pu_string,field_pos,1);
		goto case(index("$+-#^.",ch));

case(0):		if zero_surpression then ch = " ";
		goto place;

		/* $ */

case(1):		goto next;

		/* + */

case(2):		float_sign = decimal_value.sign;

		if have_exp then call put_char(float_sign);

		goto next;

		/* - */

case(3):		if d_temp(1) < 0 then goto case(2);

		float_sign = " ";

		if have_exp
		then do;
		     call put_char(float_sign);
		     goto next;
		     end;

		/* # */

case(4):		digit_pos = digit_pos + 1;
		ch = digit(digit_pos);

		if zero_surpression
		then if ch ^= "0" | digit_pos = precision - scale | have_exp
		     then call end_surpression;
		     else ch = " ";
		else digit_count = digit_count + 1;

		if digit_count > number_length+2 then ch = "?";

		goto place;

		/* ^ */

case(5):		call put_string(" E");

		if abs(exp) < 10
		then do;
		     fixed_dec_1 = convert(fixed_dec_1,exp);
		     call put_string(fixed_dec_1_overlay);
		     call put_char(" ");
		     end;
		else do;
		     fixed_dec_2 = convert(fixed_dec_2,exp);
		     call put_string(fixed_dec_2_overlay);
		     end;

		field_pos = field_pos + 4;
		goto next;

		/* . */

case(6):		if zero_surpression
		then do;
		     call end_surpression;
		     if float_sign = " " then call put_char("0");
		     end;

place:		call put_char(ch);

next:		end;

		return;

punt:		have_size_label = (36)"0"b;

		do field_pos = field_start to field_start+field_length - 1;
		     ch = substr(pu_string,field_pos,1);

		     if index("$+-#^",ch) ^= 0 then ch = "*";

		     call put_char(ch);
		     end;


end_surpression:	proc;

		if have_dollar then call put_char("$");

		if float_sign ^= " " then call put_char(float_sign);

		zero_surpression = "0"b;
		end;

	     end;

	end;






		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


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
