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_] link sp_cos,|[cosine_radians_] link sp_sin,|[sine_radians_] link sp_tan,|[tangent_radians_] link sp_cot,|[cotangent_radians_] link sp_atn,|[arc_tangent_radians_] link sp_exp,|[exponential_] link sp_log,|[log_base_e_] link sp_pwr,|[single_power_single_] link sp_clg,|[log_base_10_] link ep_sqr,|[double_square_root_] link ep_cos,|[double_cosine_radians_] link ep_sin,|[double_sine_radians_] link ep_tan,|[double_tangent_radians_] link ep_cot,|[double_cotangent_radians_] link ep_atn,|[double_arc_tangent_radians_] link ep_exp,|[double_exponential_] link ep_log,|[double_log_base_e_] link ep_pwr,|[double_power_double_] link ep_clg,|[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_](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_](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_](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_](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_](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_](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_](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_](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_](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_](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_](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_](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_](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_](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 |[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 |[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_](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_](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_](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_](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 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 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 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 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