PNOTICE_apl.alm 02/06/85 1132.5r w 02/06/85 1132.5 2853 dec 1 "version 1 structure dec 1 "no. of pnotices dec 3 "no. of STIs dec 100 "lgth of all pnotices + no. of pnotices acc "Copyright (c) 1972 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc." aci "C1APLM0B0000" aci "C2APLM0B0000" aci "C3APLM0B0000" end  apl.pl1 11/29/83 1637.3r w 11/29/83 1346.2 103545 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Command program for Version 2 APL Modified 19 January 1974 by PG to call apl_attach_streams_. Modified 740322 by PG to properly return code in subsystem entry. Modified in July 1974 by G. Gordon Benedict to remove change_ops call and to change call to create_apl_workspace_ to be a call to apl_create_workspace_. Modified 741017 by PG for -temp_dir option, and recursive capability. Modified 750904 by PG to make -terminal_type (-ttp) synonym for -device. Modified 761006 by PG to add -iip to aid Questa. Modified 780901 by PG to delete -iip (didn't really help), and fix bug 329. Modified 790110 by WMY to fix bug 363 (apl_subsystem_ dies if there is no continue workspace for the user). Modified 790213 by WMY to call file system to untie all files upon exiting APL. Modified 790322 by PG to update -ttp error message to include latest terminal types. Modified 791219 by PG to print version number before trying to autoload the ws. Modified 800411 by PG to say adieu! Modified 800814 by WMY to refuse gracefully when invoked as an active function (bug 464). Modified 811210 by TO to include CR in input prompt. */ apl: v2apl: procedure (); /* Check for invocation as an active function and complain */ call cu_$af_arg_count ((0), code); if code ^= error_table_$not_act_fnc then do; call active_fnc_err_ (0, "apl", "Cannot be called as an active function."); return; end; autoload_ws = "continue"; autoload_lock = ""; devicename = ""; temporary_segments_dir = get_pdir_ (); string (command_options.flags) = ""b; command_options.user_number = 100; do argno = 1 to cu_$arg_count (); call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then go to nomoreargsIguess; if arg = "-db" | arg = "-debug" then flags.debug_mode = "1"b; else if arg = "-nqh" | arg = "-no_quit_handler" then flags.no_quit_handler = "1"b; else if arg = "-bfe" | arg = "-brief_errors" | arg = "-bf" | arg = "-brief" /* -bf, -brief for compat. */ then flags.long_error_mode = "0"b; else if arg = "-lge" | arg = "-long_errors" | arg = "-lg" | arg = "-long" /* -lg, -long for compat. */ then flags.long_error_mode = "1"b; else if arg = "-ck" | arg = "-check" then flags.compatibility_check_mode = "1"b; else if arg = "-meter" then flags.meter_mode = "1"b; else if arg = "-ttp" | arg = "-terminal_type" then do; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then do; call com_err_ (code, "apl", "-terminal_type must be followed by terminal name. Possible names are: 1050, 2741, CORR2741, 1030, TEK4013, TEK4015, TN300, ARDS, ASCII, TTY33, TTY38, TYPEPAIRED, BITPAIRED, TELERAY11, LA36."); return; end; devicename = arg; end; else if arg = "-user_number" then do; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then do; call com_err_ (code, "apl", "-user_number must be followed by a decimal integer."); return; end; command_options.user_number = cv_dec_check_ (arg, code); if code ^= 0 | command_options.user_number <= 0 then do; call com_err_ (0, "apl", "Invalid user number. ^a", arg); return; end; end; else if arg = "-temp_dir" | arg = "-td" then do; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then do; call com_err_ (code, "apl", "-temp_dir must be followed by directory pathname."); return; end; call absolute_pathname_ (arg, temporary_segments_dir, code); if code ^= 0 then do; call com_err_ (code, "apl", "^a", arg); return; end; end; else if substr (arg, 1, 1) = "-" /* must be misspelled control arg */ then do; call com_err_ (error_table_$badopt, "apl", "^a", arg); return; end; else do; autoload_ws = before (arg, ":"); autoload_lock = after (arg, ":"); end; end; nomoreargsIguess: save_ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr; /* copy old ws info ptr into our stack frame. */ on cleanup call clean_up; /* handler to revert I/O streams & throw away ws. */ apl_static_$immediate_input_prompt = byte (13) || (6)" "; /* kludge */ call initialize_apl (temporary_segments_dir, devicename, code); /* create the workspace, attach the dim. */ if code ^= 0 then do; call com_err_ (code, "apl", "Unable to initialize apl."); apl_static_$ws_info_ptr.static_ws_info_ptr = save_ws_info_ptr; /* just in case */ return; end; ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr; /* refresh auto copy */ string (ws_info.switches) = string (command_options.flags); ws_info.user_number = command_options.user_number; call ioa_$ioa_switch (apl_static_$apl_output, "apl ^a^/", apl_static_$version_number); call apl_load_command_$autoload (autoload_ws, autoload_lock, code); if code ^= 0 & code ^= apl_error_table_$cant_autoload then do; call com_err_ (code, "apl", "^a", autoload_ws); call clean_up; return; end; call apl_parse_; if ws_info.signoff_lock ^= "" then call ioa_$ioa_switch (apl_static_$apl_output, "apl: signoff lock ignored."); call clean_up; return; clean_up: procedure (); call apl_file_system_$untie_all_files; if detach_streams /* if we attached them, we detach them. */ then do; call apl_detach_streams_ (code); if code ^= 0 then call com_err_ (code, "apl", "While detaching apl I/O streams."); end; if apl_static_$ws_info_ptr.static_ws_info_ptr ^= null then call apl_dispose_of_storage_ (); apl_static_$ws_info_ptr.static_ws_info_ptr = save_ws_info_ptr; /* restore old ws info ptr. */ end; initialize_apl: procedure (a_temp_dir, a_devicename, a_code); declare ( a_devicename char (*), a_temp_dir char (*), a_code fixed bin (35) ) parameter; call apl_segment_manager_$set_temp_dir (a_temp_dir); call apl_attach_streams_ (a_devicename, a_code); if a_code = error_table_$ionmat then do; detach_streams = "0"b; a_code = 0; end; else detach_streams = "1"b; if a_code ^= 0 /* attach the streams now because apl_create_workspace_ will look */ then return; /* at line length, etc. anyway, guy probably changed typeball before hitting return on the apl command */ call apl_create_workspace_ (); end initialize_apl; /*** this entry is for use by the APL closed subsystem ***/ apl_subsystem_: entry (a_user_number, a_switches, a_initial_ws, a_initial_ws_lock, a_terminal_type, a_temporary_segments_dir, a_signoff_lock, a_result); dcl a_user_number fixed bin (35) parameter, /* .. */ a_switches bit (*) aligned parameter, /* = string(ws_info.switches) (Input) */ a_initial_ws char (*) parameter, /* workspace to load (Input) */ a_initial_ws_lock char (*) parameter, /* lock of workspace to load (Input) */ a_terminal_type char (*) parameter, /* terminal conversion table to use. (Input) */ a_temporary_segments_dir char (*) parameter, /* directory in which to put workspace segments. */ a_signoff_lock char (*) parameter, /* user-specified signoff lock (Output) - "*" = nolock */ a_result fixed bin parameter; /* termination code (Output) 0 = normal termination apl_error_table_$cant_load_ws, apl_error_table_$off_hold */ /* Note: the following code is secure since no amount of fiddling with the quit button can have any effect until apl is entered */ save_ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr; on cleanup call clean_up; if a_temporary_segments_dir = "" then temporary_segments_dir = get_pdir_ (); else temporary_segments_dir = a_temporary_segments_dir; apl_static_$immediate_input_prompt = (6)" "; call initialize_apl (temporary_segments_dir, a_terminal_type, code); if code ^= 0 then do; a_result = code; return; /* no clean_up necessary. */ end; ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr; /* refresh auto copy */ ws_info.user_number = a_user_number; string (ws_info.switches) = a_switches; ws_info.switches.transparent_to_signals = "0"b; /* no you don't! */ if a_initial_ws = "" then autoload_ws = "continue"; else autoload_ws = a_initial_ws; call apl_load_command_$autoload (autoload_ws, a_initial_ws_lock, code); /* If the ws could not be loaded, it is a "security violation" unless no ws was explicitly specified. */ if code ^= 0 then if ^(code = apl_error_table_$cant_autoload & a_initial_ws = "") then do; a_result = code; call clean_up; return; end; call ioa_$ioa_switch (apl_static_$apl_output, "apl ^a^/", apl_static_$version_number); call apl_parse_ (); a_signoff_lock = ws_info.signoff_lock; if ws_info.off_hold then a_result = apl_error_table_$off_hold; else a_result = 0; call clean_up; return; /* entries */ declare absolute_pathname_ entry (char (*), char (*), fixed bin (35)), apl_create_workspace_ entry (), apl_load_command_$autoload entry (char (*), char (*), fixed bin (35)), apl_segment_manager_$set_temp_dir entry (char (*)), get_pdir_ entry () returns (char (168) aligned), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin), cu_$af_arg_count entry (fixed bin, fixed bin(35)), cu_$arg_count entry () returns (fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (24), fixed bin (35)), active_fnc_err_ entry() options(variable), com_err_ entry options (variable), ioa_$ioa_switch entry options (variable), apl_file_system_$untie_all_files entry, (apl_parse_, apl_dispose_of_storage_) entry (), apl_attach_streams_ entry (char (*), fixed bin (35)), apl_detach_streams_ entry (fixed bin (35)); /* conditions */ declare cleanup condition; /* builtins */ declare (after, before, null, string, substr) builtin; /* automatic */ declare argno fixed bin, argp ptr, argl fixed bin (24), autoload_lock char (32), autoload_ws char (168), code fixed bin (35), detach_streams bit (1) aligned initial ("1"b), devicename char (16), save_ws_info_ptr ptr unaligned, temporary_segments_dir char (168), 1 command_options aligned, 2 flags unaligned like ws_info.switches, 2 user_number fixed bin (35); /* based */ declare arg char (argl) unaligned based (argp); /* external static */ declare ( apl_error_table_$cant_autoload fixed bin (35), apl_error_table_$off_hold fixed bin (35), apl_static_$immediate_input_prompt char (32) varying, error_table_$not_act_fnc fixed bin (35), error_table_$badopt fixed bin (35), error_table_$ionmat fixed bin (35), apl_static_$version_number char (5), apl_static_$apl_output pointer ) external static; /* include files */ %include apl_number_data; %include apl_ws_info; end;  apl_arrow_operators_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 173574 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_arrow_operators_: procedure; /* * apl_arrow_operators_ * * this module contains the 'take' and 'drop' operators for APL. * * fast vector case written 7/20/73 by DAM * general case added 7/27/73 by DAM * modified 73.9.26 by DAM to avoid bugs in size builtin * (Note: this program should be rewritten to avoid the present excessive duplication of code.) * Modified 770207 by PG to fix case(2) to set value_bead.data_pointer if right arg is on stack (bug 266). * Modified 770222 by PG to fix case(3) so that overtaking of a numeric vector works (bug 268). Modified 780209 by PG to use apl_push_stack_ (bug 278). Modified 781118 by PG to fix bug 281 (overtaking a scalar failed because result characters overwrote rho vector!) */ dcl result_vb pointer, /* -> value_bead for result */ result pointer, /* -> value array for result */ right_vb pointer, /* -> value_bead of right operand */ right pointer, /* -> value array of right operand */ rhorho fixed bin, /* rhorho of the result, also of the right operand */ right_rho fixed bin(21), /* when right opnd is a vector, this is its length */ left_vb pointer, /* -> value_bead for left operand */ left pointer, /* -> value array for left operand */ data_elements fixed bin(21); /* total_data_elements of the result, used by aggregate moves */ dcl characters bit (1) aligned, /* "1"b if right opnd and result are character, "0"b if they are numeric */ numeric_data (data_elements) float aligned based, /* used for aggregate moves -- numeric_datum generates lousy code */ fixnum fixed bin(21), /* random fixed-binary number, usually derives from left opnd */ float_temp float; dcl (apl_error_table_$rank, apl_error_table_$length, apl_error_table_$domain) fixed bin(35) external; dcl i fixed bin; /* do-loop index (only) */ dcl case fixed bin; dcl character_string_overlay_right char(right_rho) aligned based, /* used for aggregate moves */ numeric_datum_right (right_rho) aligned float based; /* .. */ dcl special_character char(1) aligned, /* used by special scalar hacks as a buffer */ special_number float aligned; /* .. */ dcl (abs, addr, addrel, fixed, floor, rel, size, substr, string, unspec) builtin; dcl take_not_drop bit(1) aligned, /* "1"b => take operator, "0"b => drop operator (entry switch) */ n_words fixed bin(19), /* number of words to push on stack */ Some_Words (n_words) bit(36) aligned based; /* used to move value bead header */ /* declarations for the general case (loop algorithm instead of EIS algorithm) */ dcl cur_in_pos fixed bin(21), /* current position in input operand */ cur_out_pos fixed bin(21), /* current position in result */ cur_rho fixed bin, /* current dimension being worked on: index into orders */ orders_ptr pointer, 1 orders(rhorho) aligned based(orders_ptr), /* this stuff controls execution of the general case */ 2 pre_skip_or_pad fixed bin(21), /* -=skip this many from input, +=pad this many of output */ 2 take_amount fixed bin(21), /* then take this many from next dimension or data if last */ 2 post_skip_or_pad fixed bin(21), /* then skip this many or pad as above */ 2 repeat_count fixed bin(21), /* number of times left to do this dimension */ 2 rho fixed bin (21); /* rho of result */ dcl padskip fixed bin(21), /* -=skip, +=pad on this dimension, has to be multiplied by times reduction of rhos to the right. */ prodp pointer, /* -> value bead whose rho has to get times-reduced */ pre_not_post bit(1), /* "1"b pre-pad or skip, "0"b post-pad or skip */ take_amt fixed bin(21), /* number of things to take on this dimension */ j fixed bin; /* bunch of stupid declarations needed because PL/I does not allow substr on arrays as well as strings */ dcl numeric_data_for_take(orders(cur_rho).take_amount) float aligned based, numeric_data_for_pre_pad(orders(cur_rho).pre_skip_or_pad) float aligned based, numeric_data_for_post_pad(orders(cur_rho).post_skip_or_pad) float aligned based; /* include files */ %include apl_number_data; %include apl_bead_format; %include apl_value_bead; %include apl_operators_argument; %include apl_ws_info; /* program */ apl_take_: entry(operators_argument); take_not_drop = "1"b; go to join; apl_drop_: entry(operators_argument); take_not_drop = "0"b; join: /* pick up pointers to args, set variables in auto, and check types */ left_vb = operands(1).value; left = left_vb -> value_bead.data_pointer; if left_vb -> value_bead.rhorho >= 2 then go to rank_error_left; /* left arg is vector (or scalar coerced to vector ) */ right_vb = operands(2).value; rhorho = right_vb -> value_bead.rhorho; right = right_vb -> value_bead.data_pointer; if right_vb -> value_bead.data_type.character_value then characters = "1"b; else characters = "0"b; if left_vb -> value_bead.data_type.numeric_value then; /* left arg must be number */ else go to domain_error_left; /* find which case it is */ if left_vb -> value_bead.total_data_elements = 1 then if rhorho = 0 then case = 1; /* left scalar, right scalar */ else if rhorho > 1 then go to length_error_left; /* right arg must be vector */ else case = 2; else if left_vb -> value_bead.total_data_elements ^= rhorho then go to length_error_left; else case = 3; /* left vector (general case) */ go to arrow_op (case); /* dispatch */ arrow_op (1): /* case of vector, but right arg is scalar so coerce it to a vector */ if operands(2).on_stack /* if not on stack, will work. but if on stack need room for rho */ then if characters then do; special_character = right -> character_datum(0); right = addr(special_character); end; else do; /* numeric scalar */ special_number = right -> numeric_datum(0); right = addr(special_number); end; /* pretend right arg was really a vector */ /* vector case - left arg is of length 1 and right arg is vector or scalar this is handled as a seperate case so that code can be used which compiles into EIS instructions, making the vector case (most used) much faster than the general case */ /* first get a copy of left arg as an integer in the variable 'fixnum' */ arrow_op (2): if left_vb -> value_bead.data_type.integral_value then fixnum = fixed(left -> numeric_datum(0)); else do; float_temp = floor(left -> numeric_datum(0) + 0.5); if abs(float_temp - left -> numeric_datum(0)) > integer_fuzz then go to domain_error_left; /* barf if not integer */ if abs(float_temp) >= 1e21b then go to domain_error_left; fixnum = fixed(float_temp, 21); end; /* compute size of result */ right_rho = right_vb -> value_bead.total_data_elements; data_elements = abs(fixnum); if ^take_not_drop then do; data_elements = right_rho - data_elements; /* ssq for drop */ if data_elements < 0 then data_elements = 0; /* if dropping all, produce empty */ end; /* if left opnd is on stack, flush it now, leaving just right opnd or nothing */ if operands(1).on_stack then value_stack_ptr = left_vb; /* Allocate result value_bead. Result can overlay right operand. */ if operators_argument.operands (2).on_stack /* right arg on stack */ then ws_info.value_stack_ptr = right_vb; /* pop it & overlay */ number_of_dimensions = 1; n_words = size (value_bead); if characters then n_words = n_words + size (character_string_overlay); else n_words = n_words + size (numeric_datum) + 1; result_vb = apl_push_stack_ (n_words); string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type); result_vb -> value_bead.rhorho = number_of_dimensions; result = addrel (result_vb, size (value_bead)); if ^ characters then if substr(rel(result), 18, 1) then result = addrel(result, 1); result_vb -> value_bead.data_pointer = result; /* now set up rho of result -- since rho of right opnd is saved in right_rho, is OK to overlay */ result_vb -> value_bead.rho(1) = data_elements; result_vb -> value_bead.total_data_elements = data_elements; if data_elements = 0 then go to exit; /* there is nothing to move in */ /* now do the actual operation for take or drop in the scalar,vector case */ if fixnum > 0 then if take_not_drop /* TAKE */ then if result ^= right /* not overlay, must move data in */ then if characters then result -> character_string_overlay = right -> character_string_overlay_right; /* truncates or pads automatically */ else if data_elements <= right_rho then result -> numeric_data(*) = right -> numeric_data(*); /* move & truncate */ else do; if right_rho > 0 then /* avoid EIS bug */ result -> numeric_datum_right(*) = right -> numeric_datum_right(*); /* move... */ pos_take_num_pad: do i = right_rho by 1 while (i <= data_elements); /* then pad */ result -> numeric_datum(i) = 0e0; end; end; else if data_elements > right_rho /* overlaying, the data is already there so just pad if necc. */ then if characters then substr(result -> character_string_overlay, right_rho+1, data_elements-right_rho) = ""; else go to pos_take_num_pad; else; else /* DROP */ if characters then result -> character_string_overlay = substr(right -> character_string_overlay_right, fixnum+1, right_rho-fixnum); else result -> numeric_data(*) = addr(right -> numeric_datum(fixnum)) -> numeric_data(*); else /* fixnum < 0 */ if take_not_drop /* TAKE */ then if -fixnum <= right_rho /* if no padding required */ then if characters then result -> character_string_overlay = substr(right -> character_string_overlay_right, right_rho+fixnum+1, data_elements); else result -> numeric_data(*) = addr(right -> numeric_datum(right_rho+fixnum)) -> numeric_data(*); else /* padding required - is MRL so use do loop to move */ if characters then do; do i = data_elements-1 by -1 to -fixnum-right_rho; /* move chars up to make room for pad */ result -> character_datum(i) = right -> character_datum(i+fixnum+right_rho); end; substr(result -> character_string_overlay, 1, -fixnum-right_rho) = ""; /* then pad */ end; else do; do i = data_elements-1 by -1 to -fixnum-right_rho; /* move numbers up to make room for pad */ result -> numeric_datum(i) = right -> numeric_datum(i+fixnum+right_rho); end; do i = i by -1 to 0; result -> numeric_datum(i) = 0e0; /* then pad */ end; end; else /* DROP, with fixnum < 0 */ if right_vb ^= result /* if not yet copied in, copy it in */ then if characters then result -> character_string_overlay = right -> character_string_overlay; else result -> numeric_data(*) = right -> numeric_data(*); else; /* already copied in, just mung vb. but that's already been done */ go to exit; /* * left opnd has more than one element, this is the general (array) case */ arrow_op (3): /* allocate space for array of orders to be executed later, and for result value_bead header */ n_words = size (orders); orders_ptr = apl_push_stack_ (n_words); /* fill orders from left operand */ do i = rhorho by -1 while (i > 0); if left_vb -> value_bead.integral_value then float_temp = left -> numeric_datum(i-1); else do; float_temp = floor(left -> numeric_datum(i-1) + 0.5); if abs(float_temp - left -> numeric_datum(i-1)) > integer_fuzz then go to domain_error_left; /* check for integer */ end; if abs(float_temp) >= 1e21b then go to domain_error_left; fixnum = fixed(float_temp, 21); if take_not_drop then do; if fixnum >= 0 then do; pre_not_post = "0"b; padskip = fixnum - right_vb -> value_bead.rho(i); /* - => skip, + => pad */ if padskip <= 0 then take_amt = fixnum; else take_amt = right_vb -> value_bead.rho(i); end; else do; /* fixnum < 0 */ pre_not_post = "1"b; padskip = -fixnum - right_vb -> value_bead.rho(i); /* - => skip, + => pad */ if padskip < 0 then take_amt = -fixnum; else take_amt = right_vb -> value_bead.rho(i); end; orders(i).take_amount = take_amt; orders (i).rho = abs (fixnum); end; else do; /* DROP */ /* padskip = -min(abs(fixnum), right_vb -> value_bead.rho(i)); */ /* - => skip, amount to be dropped but not more than there is */ /* due to bad code, the following statement is substituted instead */ if abs(fixnum) < right_vb -> value_bead.rho(i) then padskip = -abs(fixnum); else padskip = - right_vb -> value_bead.rho(i); take_amt = right_vb -> value_bead.rho(i) + padskip; pre_not_post = (fixnum >= 0); orders (i).rho, orders (i).take_amount = take_amt; end; if padskip < 0 /* compute amount to pad or skip */ then do j = i by 1 while (j < rhorho); padskip = padskip * right_vb -> value_bead.rho(j+1); end; else do j = i by 1 while (j < rhorho); padskip = padskip * orders (j + 1).rho; end; if pre_not_post then do; orders(i).pre_skip_or_pad = padskip; orders(i).post_skip_or_pad = 0; end; else do; orders(i).pre_skip_or_pad = 0; orders(i).post_skip_or_pad = padskip; end; end; /* now fill the rest of the result value bead header (rho was just computed) */ data_elements = 1; do j = 0 by 1 while (j < rhorho); data_elements = data_elements * orders (j+1).rho; end; /* allocate space for the result value bead */ number_of_dimensions = rhorho; n_words = size (value_bead); if characters then n_words = n_words + size (character_string_overlay); else n_words = n_words + size (numeric_datum) + 1; result_vb = apl_push_stack_ (n_words); string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type); result_vb -> value_bead.rhorho = rhorho; result_vb -> value_bead.total_data_elements = data_elements; do j = 0 by 1 while (j < rhorho); result_vb -> value_bead.rho (j + 1) = orders (j + 1).rho; end; result = addrel (result_vb, size (value_bead)); if ^characters then if substr (rel (result), 18, 1) then result = addrel (result, 1); result_vb -> value_bead.data_pointer = result; /* proceed to compute the result by following the orders */ cur_in_pos, cur_out_pos = 0; cur_rho = 1; orders(1).repeat_count = 1; enter_new_rho: continue_this_rho: /* do any pre padding or skipping */ if orders(cur_rho).pre_skip_or_pad < 0 then cur_in_pos = cur_in_pos + (-orders(cur_rho).pre_skip_or_pad); else if orders(cur_rho).pre_skip_or_pad > 0 then do; if characters then substr(result -> character_string_overlay, cur_out_pos + 1, orders(cur_rho).pre_skip_or_pad) = ""; /* else addr(result -> numeric_datum(cur_out_pos)) -> numeric_data_for_pre_pad = 0.0e0; */ /* due to poor code for the preceding statement, the following has been substitued */ else do j = 0 by 1 while (j < orders(cur_rho).pre_skip_or_pad); result -> numeric_datum(cur_out_pos + j) = 0.0e0; end; cur_out_pos = cur_out_pos + orders(cur_rho).pre_skip_or_pad; end; /* take */ if cur_rho = rhorho then do; if characters then substr(result -> character_string_overlay, cur_out_pos+1, orders(cur_rho).take_amount) = substr(right -> character_string_overlay, cur_in_pos+1, orders(cur_rho).take_amount); else addr(result -> numeric_datum(cur_out_pos)) -> numeric_data_for_take = addr(right -> numeric_datum(cur_in_pos)) -> numeric_data_for_take; cur_out_pos = cur_out_pos + orders(cur_rho).take_amount; cur_in_pos = cur_in_pos + orders(cur_rho).take_amount; end; else do; /* take from next dimension to the right */ cur_rho = cur_rho + 1; orders(cur_rho).repeat_count = orders(cur_rho-1).take_amount; go to enter_new_rho; end; leave_old_rho: /* do any post padding or skipping */ if orders(cur_rho).post_skip_or_pad < 0 then cur_in_pos = cur_in_pos + (-orders(cur_rho).post_skip_or_pad); else if orders(cur_rho).post_skip_or_pad > 0 then do; if characters then substr (result -> character_string_overlay, cur_out_pos + 1, orders(cur_rho).post_skip_or_pad) = ""; /* else addr(result -> numeric_datum(cur_out_pos)) -> numeric_data_for_post_pad = 0.0e0; */ /* due to poor code generated for the preceding statement, the following has been substituted */ else do j = 0 by 1 while (j < orders(cur_rho).post_skip_or_pad); result -> numeric_datum(cur_out_pos + j) = 0.0e0; end; cur_out_pos = cur_out_pos + orders(cur_rho).post_skip_or_pad; end; orders(cur_rho).repeat_count = orders(cur_rho).repeat_count - 1; if orders(cur_rho).repeat_count > 0 then go to continue_this_rho; /* done with this rho, move left to preceding one */ cur_rho = cur_rho-1; if cur_rho ^= 0 then go to leave_old_rho; /* all done, move result down */ if operands(2).on_stack then value_stack_ptr = right_vb; else if operands(1).on_stack then value_stack_ptr = left_vb; else value_stack_ptr = orders_ptr; number_of_dimensions = rhorho; n_words = size (value_bead); if characters then n_words = n_words + size(character_string_overlay); else n_words = n_words + (1+size(numeric_data)); left_vb = apl_push_stack_ (n_words); /* result = old posn on stack, left = new posn on stack */ number_of_dimensions = rhorho; n_words = size (value_bead); /* move bead header with overlay */ left_vb -> Some_Words = result_vb -> Some_Words; left = addr(left_vb -> value_bead.rho(rhorho+1)); /* set up address of data */ if ^ characters then if substr(rel(left), 18, 1) then left = addrel(left, 1); left_vb -> value_bead.data_pointer = left; if characters then left -> character_string_overlay = result -> character_string_overlay; else left -> numeric_data = result -> numeric_data; operators_argument.result = left_vb; return; /**** come here to depart ****/ exit: operators_argument.result = result_vb; return; /**** errors *****/ rank_error_left: operators_argument.error_code = apl_error_table_$rank; go to signal_error; domain_error_left: operators_argument.error_code = apl_error_table_$domain; go to signal_error; length_error_left: operators_argument.error_code = apl_error_table_$length; go to signal_error; signal_error: operators_argument.where_error = operators_argument.where_error + 1; return; %include apl_push_stack_fcn; end;  apl_attach_streams_.pl1 08/04/87 1710.1r 08/04/87 1541.9 114309 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Commands and subroutines to attach & detach the APL I/O streams and Device Interface Module. R.S.Lamson, D.A.Moon, and P.Green, 1973 Modified 740511 by PG to correct handling of network terminals. Modified 750711 by PG to work with MCS. Modified 760209 by PG to add Correspondence 2741s. Modified 760730 by PG to add bit-paired APL/ASCII terminals (CDI 1030). Modified 770120 by PG to work in an absentee process. Modified 781208 by PG to use iox_$move_attach and friends (bug 218). Modified 790320 by PG to flush NET2741 (sugg 344), add TYPEPAIRED and BITPAIRED (bug 210). Modified 790326 by PG to fix 387 (didn't detach switches in absentee). Modified 790602 by PG to fix 401 (didn't recognize typepaired or bitpaired), and to do sugg 396 (recognize some TTF names, and be consistent with TTF). Modified 790910 by PG to add TELERAY11 and LA36 terminal types (sugg 386). Modified 790912 by PG to get TELERAY11 to switch in and out automatically like TEK4013. Modified 800129 by PG to add SARA, AJ510, and AJ830. Modified 800130 by PG to call apl_dim_select_table_. Modified 800227 by PG to setup apl_static_$user_tty in absentee. Modified 810125 by WMY to fix bug 479, the streams are attached incorrectly when running in foreground absentee. Modified 811208 by TO to get LA36 (ne cybernex_apl) to switch in and out Modified 820824 by AD to fix bug 484 (line length was obtained from modes string instead of by calling get_line_length_). */ /* format: style3 */ apl_start: procedure; call cu_$arg_count (argument_count); if argument_count ^= 0 then do; call cu_$arg_ptr (1, argument_ptr, argument_length, code); if code ^= 0 then do; argument_error: call com_err_ (code, "apl_start", "Usage: apl_start {-terminal_type name} where name = 1050, 2741, CORR2741, 1030, TEK4013, TEK4015, TN300, ARDS, ASCII, TTY33, TTY38, TYPEPAIRED, BITPAIRED, TELERAY11, LA36, SARA, AJ510, AJ830, AJ832."); return; end; if argument ^= "-terminal_type" & argument ^= "-ttp" then do; code = error_table_$badopt; go to argument_error; end; call cu_$arg_ptr (2, argument_ptr, argument_length, code); if code ^= 0 then do; code = error_table_$noarg; go to argument_error; end; user_terminal_type = argument; end; else user_terminal_type = ""; call apl_attach_streams_ (user_terminal_type, code); if code ^= 0 then call com_err_ (code, "apl_start", "^a", user_terminal_type); return; apl_attach_streams_: entry (a_terminal_type, a_code); a_code = 0; if apl_streams_attached then do; a_code = error_table_$ionmat; return; end; call user_info_$absentee_queue (abs_q); /* The abs_q must be greater than zero (zero means foreground) */ if abs_q >= 0 then do; absentee_process = "1"b; call iox_$attach_name ("apl_output_", apl_static_$apl_output, "syn_ user_output", codeptr (apl_attach_streams_), a_code); if a_code ^= 0 then return; call iox_$attach_name ("apl_input_", apl_static_$apl_input, "syn_ user_input", codeptr (apl_attach_streams_), a_code); apl_static_$user_tty = iox_$user_io; apl_streams_attached = "1"b; return; end; else absentee_process = "0"b; terminal_info.version = 1; call iox_$control (iox_$user_io, "terminal_info", addr (terminal_info), code); if code = 0 then do; terminal_type = terminal_info.term_type; if terminal_info.line_type = LINE_TELNET then network_terminal = "1"b; else network_terminal = "0"b; end; else do; terminal_type = "ASCII"; network_terminal = "0"b; end; if a_terminal_type ^= "" /* if caller gave us one, use it instead */ then do; terminal_type = translate (a_terminal_type, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); if terminal_type = "4013" /* convert old apl-only name to TTF name */ then terminal_type = "TEK4013"; end; call apl_dim_select_table_ (terminal_type, table_ptr, default_table_used); if default_table_used & a_terminal_type ^= "" /* subroutine couldn't understand name that user gave us */ then do; a_code = error_table_$no_term_type; return; end; call mask; /* Get the old modes so we can compute some apl modes from them. */ call iox_$modes (iox_$user_io, "", old_modes, status_code); if status_code ^= 0 then do; a_code = status_code; return; end; if index (old_modes, "^red") ^= 0 then new_modes = "^red"; else new_modes = "red"; if index (old_modes, "^tabs") ^= 0 | (terminal_type = "TEK4013") | (terminal_type = "TEK4015") /* SHOULD BE IN TABLE */ then new_modes = new_modes || ",^tabs"; else new_modes = new_modes || ",tabs"; i = get_line_length_$switch (iox_$user_io, status_code); if status_code = 0 then new_modes = new_modes || ",ll" || ltrim (char (i)); if network_terminal then do; initial_modes = "^esc,^erkl,^can"; final_modes = "esc,erkl,can"; end; else do; initial_modes = "rawi,rawo,^hndlquit"; final_modes = "^rawi,^rawo,hndlquit"; end; call iox_$find_iocb ("user_tty_", apl_static_$user_tty, status_code); if status_code ^= 0 then go to loss (7); call iox_$move_attach (iox_$user_io, apl_static_$user_tty, status_code); if status_code ^= 0 /* today is not our day... */ then go to loss (6); call iox_$modes (apl_static_$user_tty, initial_modes, "", status_code); if status_code ^= 0 then go to loss (5); /* the following statement is necessary because the ios_ writearound for iox_ does not follow the same search rules as the old ios_. taking the addr will cause the normal search rules to be followed. */ if addr (apl_dim_$apl_dim_module) = null then ; call ios_$attach ("user_i/o", "apl_dim_", "user_tty_", (new_modes), status); if status_code ^= 0 /* what!? probably no room for sdb... */ then go to loss (4); call iox_$attach_name ("apl_output_", apl_static_$apl_output, "syn_ user_output", codeptr (apl_attach_streams_), status_code); if status_code ^= 0 then go to loss (3); call iox_$attach_name ("apl_input_", apl_static_$apl_input, "syn_ user_input", codeptr (apl_attach_streams_), status_code); if status_code ^= 0 then go to loss (2); call ios_$order ("user_i/o", "set_table", table_ptr, status); if status_code ^= 0 /* aw, c'mon! We got this far and then lost? */ then go to loss (1); call ios_$order ("user_i/o", "read_back_input", null, ""b); apl_streams_attached = "1"b; /* this bit prevents us from trying to attach the streams more than once, in case of a recursive call. */ /* SHOULD BE IN TABLE */ if (terminal_type = "TEK4013") | (terminal_type = "TEK4015") | (terminal_type = "TELERAY11") then call iox_$put_chars (apl_static_$user_tty, addr (enter_4013_apl_mode), length (enter_4013_apl_mode), 0); else if (terminal_type = "AJ510") then call iox_$put_chars (apl_static_$user_tty, addr (enter_aj510_apl_mode), length (enter_aj510_apl_mode), 0); else if (terminal_type = "LA36") then call iox_$put_chars (apl_static_$user_tty, addr (enter_la36_apl_mode), length (enter_la36_apl_mode), 0); call unmask; return; loss (1): call iox_$detach_iocb (apl_static_$apl_input, 0); loss (2): call iox_$detach_iocb (apl_static_$apl_output, 0); loss (3): call ios_$detach ("user_i/o", "", "", ""b); loss (4): call iox_$modes (apl_static_$user_tty, final_modes, "", 0); loss (5): call iox_$move_attach (apl_static_$user_tty, iox_$user_io, 0); loss (6): loss (7): a_code = status_code; /* give caller prime reason why failed. */ return; apl_end: entry; call apl_detach_streams_ (code); if code ^= 0 then call com_err_ (code, "apl_end", "While trying to restore the I/O switches."); return; apl_detach_streams_: entry (a_code); a_code = 0; if ^apl_streams_attached then do; a_code = error_table_$ioname_not_active; return; end; if ^absentee_process then do; /* SHOULD BE IN TABLE */ if (terminal_type = "TEK4013") | (terminal_type = "TEK4015") | (terminal_type = "TELERAY11") then call iox_$put_chars (apl_static_$user_tty, addr (leave_4013_apl_mode), length (leave_4013_apl_mode), code); else if (terminal_type = "AJ510") then call iox_$put_chars (apl_static_$user_tty, addr (leave_aj510_apl_mode), length (leave_aj510_apl_mode), code); else if (terminal_type = "LA36") then call iox_$put_chars (apl_static_$user_tty, addr (leave_la36_apl_mode), length (leave_la36_apl_mode), code); call mask; call ios_$detach ("user_i/o", "", "", ""b); /* flush apl dim */ call iox_$move_attach (apl_static_$user_tty, iox_$user_io, code); if code ^= 0 then a_code = code; call iox_$modes (iox_$user_io, final_modes, "", code); if code ^= 0 then a_code = code; call unmask; end; call iox_$detach_iocb (apl_static_$apl_output, 0); call iox_$detach_iocb (apl_static_$apl_input, 0); apl_static_$apl_input = null; apl_static_$apl_output = null; apl_static_$user_tty = null; apl_streams_attached = "0"b; /* ready for a 2nd time... */ return; /* Internal procedures */ mask: unmask: procedure (); return; end /* mask */; /* parameters */ dcl ( a_terminal_type char (*), a_code fixed bin (35) ) parameter; /* entries */ declare apl_attach_streams_ entry (char (*), fixed bin (35)), apl_detach_streams_ entry (fixed bin (35)), apl_dim_$apl_dim_module entry (), apl_dim_select_table_ entry (char (*), ptr, bit (1) aligned), com_err_ entry options (variable), cu_$arg_count entry (fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin), ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned), ios_$detach entry (char (*), char (*), char (*), bit (72) aligned), ios_$order entry (char (*), char (*), pointer, bit (72) aligned), iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$detach_iocb entry (ptr, fixed bin (35)), iox_$find_iocb entry (char (*), ptr, fixed bin (35)), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)), iox_$move_attach entry (ptr, ptr, fixed bin (35)), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)), user_info_$absentee_queue entry (fixed bin); /* automatic */ declare 1 terminal_info aligned, 2 version fixed bin, /* ==1 */ 2 id char (4) unal, 2 term_type char (32) unal, 2 line_type fixed bin, 2 baud_rate fixed bin, 2 reserved (4) fixed bin; dcl abs_q fixed bin, argument_count fixed bin, argument_length fixed bin, argument_ptr pointer, default_table_used bit (1) aligned, network_terminal bit (1) aligned, user_terminal_type char (32), (i, number_of_digits) fixed bin, new_modes char (168) varying, status bit (72) aligned, table_ptr pointer, code fixed bin (35); /* based */ dcl argument char (argument_length) based (argument_ptr), status_code fixed bin (35) aligned based (addr (status)); /* UGH! */ /* builtins */ dcl (addr, codeptr, index, length, ltrim, null, substr, translate, verify) builtin; /* external static */ declare ( error_table_$badopt, error_table_$ioname_not_active, error_table_$ionmat, error_table_$no_term_type, error_table_$noarg ) fixed bin (35) external static; declare ( apl_static_$apl_input, apl_static_$apl_output, apl_static_$user_tty, iox_$user_io ) ptr external static; /* internal static */ declare ( absentee_process bit (1) aligned, apl_streams_attached bit (1) aligned initial ("0"b), terminal_type char (32) unal, old_modes char (256), (final_modes, initial_modes) char (32) ) internal static; /* internal static initial */ declare ( enter_4013_apl_mode char (2) init (""), /* ESC CTL-N */ leave_4013_apl_mode char (2) init (""), /* ESC CTL-O */ enter_aj510_apl_mode char (1) init (""), /* CTL-N */ leave_aj510_apl_mode char (1) init (""), /* CTL-O */ enter_la36_apl_mode char (1) init (""), /* CTL-O */ leave_la36_apl_mode char (1) init ("") /* CTL-N */ ) aligned internal static options (constant); /* include files */ %include line_types; end /* apl_attach_streams_ */;  apl_clear_workspace_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 44136 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_clear_workspace_: procedure (); /* * routine to initialize the APL workspace on a )CLEAR command or on entry to the APL subsystem. * * it assumes that the apl_ws_info structure and the value stack have already been created. * * * written 73.7.31 by DAM * modified 8/25/73 by DAM for version 3 workspace format * modified July 1974 by GGB to change names of some subroutines called and to call ios_ slightly * differently to get width * Modified 761005 by PG to use get_line_length_, and to initialize input prompts. Modified 790914 by PG to allocate output buffer. Modified 791013 by PG to initialize ws_info.tab_width. */ /* automatic */ declare 1 initial_latent_expression aligned, /* value bead for '', used to initialize QuadLX */ 2 type bit (18) unaligned, /* I can't use like value_bead because I'm programming in this */ 2 size bit (18) unaligned, /* crock language where automatic structures can't have */ 2 reference_count fixed bin (29), /* refer options in them. */ 2 total_data_elements fixed bin (21), 2 rhorho fixed bin, 2 data_pointer unaligned pointer, 2 rho (1) fixed bin (21); declare code fixed bin (35); /* builtins */ declare (addr, addrel, null, size, string) builtin; /* entries */ declare apl_clear_storage_ entry (), apl_copy_value_ entry (pointer unaligned, pointer unaligned), get_group_id_ entry () returns (char (32)), get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); /* external static */ declare ( apl_static_$apl_output ptr, apl_static_$immediate_input_prompt char (32) varying, sys_info$max_seg_size fixed bin (18) ) external static; /* program */ call apl_clear_storage_; /* clear the heap and reset the value stack */ ws_info.digits = 10; ws_info.width = get_line_length_$switch (apl_static_$apl_output, code); if code ^= 0 then do; ws_info.width = 132; /* make this default */ call iox_$modes (apl_static_$apl_output, "ll132", "", code); end; ws_info.index_origin = 1; ws_info.float_index_origin = 1; ws_info.random_link = 16807; /* 7**5, sounds like a good random link to use for now */ ws_info.fuzz = 1e-13; /* defined in APL to be 1e-13 */ ws_info.integer_fuzz = 1.110223e-16; /* 2**-53, sounds like a good integer fuzz */ ws_info.number_of_symbols = 0; ws_info.maximum_value_stack_size = sys_info$max_seg_size - 2; /* the -2 is for pl1_operators_ bugs I guess */ ws_info.last_error_code = 0; ws_info.lock = ""; ws_info.wsid = "clear ws"; ws_info.user_number = 100; /* default user number as in TSO-APL */ string (ws_info.interrupt_info) = ""b; ws_info.user_name = get_group_id_ (); ws_info.immediate_input_prompt = apl_static_$immediate_input_prompt; ws_info.evaluated_input_prompt = QQuad || QColon || QNewLine || (6)" "; ws_info.character_input_prompt = ""; call iox_$control (apl_static_$apl_output, "get_tab_width", addr (ws_info.tab_width), code); if code ^= 0 /* no apl dim */ then ws_info.tab_width = 10; /* default */ /* Allocate and initialize symbol table. */ ws_info.symbol_table_ptr = addrel (ws_info_ptr, size (ws_info)); symbol_table.table_size = initial_size; symbol_table.hash_bucket_ptr (*) = null; /* Allocate output buffer */ ws_info.output_buffer_ptr = addrel (ws_info.symbol_table_ptr, size (symbol_table)); ws_info.output_buffer_len = 900; /* must be < 1000 to avoid kludge in apl_dim_write_ */ /* ...so read_back_output will work */ ws_info.output_buffer_pos = 1; ws_info.output_buffer_ll = 0; /* Store pointer to first parse frame. */ ws_info.current_parse_frame_ptr = addrel (ws_info.output_buffer_ptr, size (output_buffer)); /* create '' as the initial latent expression */ string (initial_latent_expression.type) = character_value_type; initial_latent_expression.rhorho = 1; initial_latent_expression.total_data_elements = 0; initial_latent_expression.data_pointer = null; /* no one should ever reference through this */ initial_latent_expression.rho (1) = 0; call apl_copy_value_ (addr (initial_latent_expression), ws_info.latent_expression); return; /* include files */ %include apl_number_data; %include apl_bead_format; %include apl_symbol_table; %include apl_ws_info; %include apl_characters; end /* apl_clear_workspace_ */;  apl_comma_operators_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 200691 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_comma_operators_: procedure; /* * This module implements the following APL operators: * ravel ,A * scalar laminate 1,2 * catenate A,B * laminate A,[1.5]B * * written 73.7.08 by DAM * modified to take advantage of EIS, 73.7.31 by DAM * modified to fix a bug causing catenate of a scalar and a null * vector (either way) to fail due to setting of total_data_elements * field incorrectly, and to slightly decrease size of object code * by G. Gordon Benedict, June 15, 1974 * Modified 770307 by PG to fix bug 195 (+_1 bug in checking rank subscript for laminate). Modified 790305 by William M. York to fix part of bug 278 (some programs do not double-word align value beads). * */ dcl result_vb ptr, /* -> result value_bead on stack */ result ptr, /* -> data array of result value_bead */ rhorho fixed bin, /* rhorho of result */ kludge_rhorho fixed binary defined (rhorho), /* to get around name conflict in calculate_result_bead_laminate */ left ptr, /* -> data array of left operand value_bead */ right ptr, /* -> data array of right operand value_bead */ left_rr fixed bin, /* rhorho of left operand */ right_rr fixed bin, /* rhorho of right operand */ /* variables used to control scanning through the arguments in the inner loop */ (left_pos, right_pos) fixed bin(21), /* index in datum array of left or right operand */ (left_scalar, right_scalar) bit(1), /* "1"b if left (right) operand is a scalar */ outersize fixed bin(21), /* total number of result elements */ jointsize fixed bin(21), /* number of result elements between joints */ innersize fixed bin(21), /* number of result elements in dimensions to right (in rho vector) of the dimension in which the joints occur */ joint fixed bin(21), /* number of elements in a column before you get to the joint */ I fixed bin, /* dimension along which joining is to occur */ J fixed bin(21), /* = result.rho[I] */ characters bit(1), /* 1 => do in character mode, 0 => do in numeric mode */ resulting_type bit(18), /* type field for result, needed for null-vector hacks */ (i, j, n) fixed bin(21), /* for do loops, etc. */ (right_vb, left_vb) ptr; /* -> value_bead of left & right args irrespectively */ dcl left_size fixed bin(21), /* number of things taken at a time from left argument */ right_size fixed bin(21), /* number of things taken at a time from right argument */ result_pos fixed bin(21), /* base of column currently being generated in result */ left_numbers(left_size) float aligned based, /* because you can't use substr on arrays in PL/I */ right_numbers(right_size) float based aligned; dcl apl_number float; /* for size builtin */ dcl n_words fixed bin(18), /* for moving things around */ words (n_words) bit(36) aligned based, data_elements fixed bin(21) def(outersize); /* satisfy include file - allow use of size builtin */ declare (addr, addrel, fixed, rel, size, string, substr) builtin; dcl (left_char, right_char) char(1), (left_num, right_num) float; %include apl_number_data; %include apl_bead_format; %include apl_value_bead; %include apl_operators_argument; %include apl_ws_info; apl_catenate_: entry(operators_argument); call determine_conformability; /* check ranks, find which case, set up various parameters */ if left_scalar then if right_scalar then go to comma_two_scalars; else /* scalar,array */ call calculate_result_bead (right_vb); /*since right is array, calculate all result bead fields from right */ else if right_scalar then do; /* array,scalar */ call calculate_result_bead (left_vb); /* however now left is array */ joint = left_vb -> value_bead.rho (I) * joint; end; else /* array,array */ if left_rr = right_rr then do; /* same ranks is OK */ rhorho = left_rr; if rhorho < I then go to rank_subsc_error; do j = 1 by 1 while (j <= rhorho); if j ^= I then if left_vb->value_bead.rho(j) ^= right_vb->value_bead.rho(j) then go to length_error; end; J = left_vb->value_bead.rho(I) + right_vb->value_bead.rho(I); innersize = 1; do j = I by 1 while(j < rhorho); innersize = left_vb->value_bead.rho(j + 1) * innersize; end; joint = innersize*left_vb->value_bead.rho(I); outersize = left_vb->value_bead.total_data_elements + right_vb->value_bead.total_data_elements; /* allocate result and set rho vector */ call stack_allocate; do j = 1 by 1 while(j <= rhorho); result_vb->value_bead.rho(j) = left_vb->value_bead.rho(j); if j = I then result_vb->value_bead.rho(j) = result_vb->value_bead.rho(j) + right_vb->value_bead.rho(j); end; end; else if right_rr+1 = left_rr then do; /* right arg has one less rank is allowed too */ call calculate_result_bead_vector (left_vb, right_vb); /* left is 1st cause it has more dims */ joint = left_vb->value_bead.rho(I) * joint; end; else if left_rr+1 = right_rr then /* left arg with one less rank is also allowed */ call calculate_result_bead_vector (right_vb, left_vb); /* right has more than left */ else go to rank_error; /* but any other case is not allowed */ catenate_laminate_join: jointsize = J * innersize; left_pos, right_pos = 0; /* set up control variables for scanning through arguments */ left_size = joint; /* number of things at a time to take from left */ right_size = jointsize - left_size; /* number of things at a time to take from the right */ /** All stuff has been set up. Do the actual operation **/ do result_pos = 0 repeat (result_pos + jointsize) while(result_pos < outersize); /* part of column before a joint is moved in from left argument */ if ^left_scalar then do; /* use EIS to copy in from vector */ if characters then substr(result -> character_string_overlay, result_pos+1, left_size) = substr(left -> character_string_overlay, left_pos+1, left_size); else addr(result -> numeric_datum(result_pos)) -> left_numbers = addr(left -> numeric_datum(left_pos)) -> left_numbers; left_pos = left_pos + left_size; end; else /* assign scalar to vector row of result */ if characters then do n = 0 by 1 while (n < left_size); /* use copy builtin if and when it */ result -> character_datum(n+result_pos) = left -> character_datum(0); /* ever works. */ end; else do n = 0 by 1 while (n < left_size); /* use assignment of scalar to aggregate */ result -> numeric_datum(n+result_pos) = left -> numeric_datum(0); /* if and when it ever generates */ end; /* as good or better code than do-loop */ /* part of column after a joint is moved in from right argument */ if ^right_scalar then do; /* use EIS to copy in from vector */ if characters then substr(result -> character_string_overlay, result_pos+left_size+1, right_size) = substr(right -> character_string_overlay, right_pos+1, right_size); else addr(result -> numeric_datum(result_pos+left_size)) -> right_numbers = addr(right -> numeric_datum(right_pos)) -> right_numbers; right_pos = right_pos + right_size; end; else /* assign to scalar to a vector row of result */ if characters then do n = 0 by 1 while (n < right_size); /* use copy builtin if and when */ result -> character_datum(n+result_pos+left_size) = right -> character_datum(0); end; /* it ever works */ else do n = 0 by 1 while (n < right_size); /* use assignment of a scalar to an aggregate */ result -> numeric_datum(n+result_pos+left_size) = right -> numeric_datum(0); end; /* if and when it ever generates as good or better code than the do loop */ end; /* maybe copy result down */ if ^ operands(2).on_stack then if ^operands(1).on_stack then do; /* result is already at right place since nothing else on stack */ operators_argument.result = result_vb; return; end; else operators_argument.result = left_vb; /* only left on stack, over-write it */ else operators_argument.result = right_vb; /* right or both on stack, over-write right */ /* yes, copy result down */ number_of_dimensions = rhorho; /* for taking size, base of refer option */ n_words = size(value_bead); /* first copy bead header stuff + rho vector */ operators_argument.result -> words = result_vb -> words; /* adjust value_bead.data_pointer */ left, operators_argument.result -> value_bead.data_pointer = addr(operators_argument.result->value_bead.rho(rhorho+1)); if characters then n_words = size(character_string_overlay); else do; n_words = size(numeric_datum); if substr(rel(left), 18, 1) then do; left = addrel(left, 1); /* double-word align */ operators_argument.result -> value_bead.data_pointer = left; end; end; if n_words ^= 0 then /* avoid illegal_procedure faults from kludge EIS hardware */ left -> words = result -> words; /* move in the data */ value_stack_ptr = addrel(left, n_words); /* set ptr to first word above data */ return; comma_two_scalars: rhorho = 1; outersize = 2; if characters then do; left_char = left -> character_datum(0); right_char = right -> character_datum(0); call stack_allocate_0; result -> character_datum(0) = left_char; result -> character_datum(1) = right_char; end; else do; left_num = left -> numeric_datum(0); right_num = right -> numeric_datum(0); call stack_allocate_0; result -> numeric_datum(0) = left_num; result -> numeric_datum(1) = right_num; end; result_vb -> value_bead.rho(1) = 2; operators_argument.result = result_vb; return; /*** routines to make a bead on the value stack, given rhorho and outersize. returns result_vb, result. Sets value_bead.type, .rhorho, .data_pointer. Sets value_stack_ptr ***/ stack_allocate_0: proc; /* this entry flushes operands before allocating */ if operands(2).on_stack then value_stack_ptr = right_vb; else if operands(1).on_stack then value_stack_ptr = left_vb; stack_allocate: entry; /* this entry allocates on top of stack */ dcl words_needed_in_bead fixed bin(19), words_needed fixed bin(19), data_words_needed fixed bin(19); if characters then data_words_needed = size(character_string_overlay); else data_words_needed = size(numeric_datum); number_of_dimensions = rhorho; words_needed_in_bead = size(value_bead); words_needed = words_needed_in_bead + data_words_needed; if ^ characters then words_needed = words_needed + 1; /* double word alignment hack */ result_vb = apl_push_stack_ (words_needed); result = addrel(result_vb, words_needed_in_bead); /* -> data area */ string(result_vb -> value_bead.type) = resulting_type; if ^ characters then if substr(rel(result), 18, 1) then result = addrel(result, 1); /* double word align */ result_vb -> value_bead.reference_count = -1; result_vb -> value_bead.total_data_elements = outersize; result_vb -> value_bead.rhorho = rhorho; result_vb -> value_bead.data_pointer = result; %include apl_push_stack_fcn; end; /* This subroutine calculates information about the result bead from either the left or right bead (whichever one arg ptr points to) for the apl_catenate_ entry. */ calculate_result_bead: procedure (a_info_bead_ptr); declare a_info_bead_ptr pointer parameter; /* ptr to which bead is array */ declare info_bead_ptr pointer initial (a_info_bead_ptr); /* for efficiency */ kludge_rhorho = info_bead_ptr -> value_bead.rhorho; if I > kludge_rhorho then go to rank_subsc_error; J = info_bead_ptr -> value_bead.rho(I) + 1; innersize = 1; do i = I by 1 while (i < kludge_rhorho); innersize = info_bead_ptr -> value_bead.rho(i + 1) * innersize; end; outersize, /* init to product of all dims of greater rank than I */ joint = innersize; /* left member is a scalar, so only take 1 at a time from it */ /* Multiply outersize by all dimensions of lesser rank than I so that it will be product of all dimensions but that of I */ do i = 0 to I -2; outersize = info_bead_ptr -> value_bead.rho (i + 1) * outersize; end; outersize = outersize + info_bead_ptr -> value_bead.total_data_elements; /* allocate result and set rho vector */ call stack_allocate; do j = 1 by 1 while (j <= kludge_rhorho); result_vb->value_bead.rho(j) = info_bead_ptr -> value_bead.rho(j); if j = I then result_vb->value_bead.rho(j) = result_vb->value_bead.rho(j) + 1; end; end calculate_result_bead; /* This subroutine calculates data in the result bead for apl_catenate_ for vector arguments, when one vector has one less dimension than the other */ calculate_result_bead_vector: procedure (a_greater_ptr, a_less_ptr); declare (a_greater_ptr, /* ptr to value bead with greater rhorho */ a_less_ptr) ptr parameter; /* pointer to other one, dummy */ declare (greater_ptr initial (a_greater_ptr), /* is it really more efficient? */ less_ptr initial (a_less_ptr)) pointer automatic; kludge_rhorho = greater_ptr -> value_bead.rhorho; if kludge_rhorho < I then go to rank_subsc_error; do j = 1 by 1 while (j < I); /* check that rho vectors match */ if greater_ptr -> value_bead.rho(j) ^= less_ptr -> value_bead.rho(j) then go to length_error; end; do j = I+1 by 1 while(j <= kludge_rhorho); if greater_ptr -> value_bead.rho(j) ^= less_ptr -> value_bead.rho (j-1) then go to length_error; end; J = greater_ptr -> value_bead.rho(I)+1; innersize = 1; do j = I by 1 while(j < kludge_rhorho); innersize = greater_ptr -> value_bead.rho(j + 1) * innersize; end; joint = innersize; outersize = greater_ptr -> value_bead.total_data_elements + less_ptr -> value_bead.total_data_elements; /* allocate result and set rho vector */ call stack_allocate; do j = 1 by 1 while(j <= kludge_rhorho); result_vb->value_bead.rho(j) = greater_ptr -> value_bead.rho(j); if j = I then result_vb->value_bead.rho(j) = result_vb->value_bead.rho(j) + 1; end; end calculate_result_bead_vector; determine_conformability: proc; left_vb = operands(1).value; right_vb = operands(2).value; /* copy arg ptrs for efficiency (?) */ if left_vb->value_bead.data_type.character_value then if right_vb->value_bead.data_type.character_value then do; characters = "1"b; resulting_type = character_value_type; end; else call null_vector_hacks; else if left_vb->value_bead.data_type.numeric_value then if right_vb->value_bead.data_type.numeric_value then do; characters = "0"b; resulting_type = string(left_vb -> value_bead.type) & string(right_vb -> value_bead.type); end; else call null_vector_hacks; else go to domain_error; /* types conform, set up variables so that rank/shape checking can be done */ left = left_vb->value_bead.data_pointer; right = right_vb->value_bead.data_pointer; left_rr = left_vb->value_bead.rhorho; left_scalar = (left_rr = 0); /* comma only accepts true scalars as scalars */ right_rr = right_vb->value_bead.rhorho; right_scalar = (right_rr = 0); I = operators_argument.dimension; null_vector_hacks: proc; /* * this routine is called when there is a mismatch in types. * normally, this would be a domain error, but for compatibility with * some apparently undocumented features in APL/360 the following special * cases are recognized: * 1) both arguments are null * the type of the right-hand argument is used. * 2) one is null, but not both * the type of the non-null argument is used. * 3) otherwise * it is a domain error */ if left_vb -> value_bead.total_data_elements = 0 then if right_vb -> value_bead.total_data_elements = 0 then /* case 1 */ resulting_type = string(right_vb -> value_bead.type); else /* case 2, right is non-null */ resulting_type = string(right_vb -> value_bead.type); /* not optimized - clarity */ else if right_vb -> value_bead.total_data_elements = 0 then /* case 2, left is non-null */ resulting_type = string(left_vb -> value_bead.type); else go to domain_error; /* case 3, not allowed */ characters = (resulting_type = character_value_type); end null_vector_hacks; end determine_conformability; apl_ravel_: entry (operators_argument); right_vb = operands(2).value; resulting_type = string(right_vb -> value_bead.type); if ^operands (2).on_stack /* copy into stack */ then do; if right_vb -> value_bead.data_type.character_value then characters = "1"b; else if right_vb -> value_bead.data_type.numeric_value then characters = "0"b; else go to domain_error_right; rhorho = 1; outersize = right_vb -> value_bead.total_data_elements; left_vb = right_vb; /* hack type-field !! */ call stack_allocate; /* having set up the bead header, now copy the data values */ if outersize ^= 0 /* avoid IPR fault from EIS hardware */ then if characters then result -> character_string_overlay = right_vb -> value_bead.data_pointer -> character_string_overlay; else result -> numeric_datum (*) = right_vb -> value_bead.data_pointer -> numeric_datum (*); end; else if right_vb -> value_bead.rhorho = 0 /* special handling for scalar on stack, because */ then do; /* it cannot be done in place */ rhorho = 1; outersize = 1; if right_vb -> value_bead.data_type.character_value /* save value and type of scalar */ then do; characters = "1"b; right_char = right_vb -> value_bead.data_pointer -> character_datum(0); end; else do; characters = "0"b; right_num = right_vb -> value_bead.data_pointer -> numeric_datum(0); end; left_vb, value_stack_ptr = right_vb; /* get rid of the old value bead, and ... */ /* set left_vb to hack the type field */ call stack_allocate; /* get a new bead with room for rho vector */ if characters then result -> character_datum (0) = right_char; else result -> numeric_datum(0) = right_num; /* fill in data from saved scalar */ end; else result_vb = right_vb; /* a non-scalar on the stack may always be overlayed */ /* now just mung the rho vector */ operators_argument.result = result_vb; result_vb -> value_bead.rhorho = 1; result_vb -> value_bead.rho(1) = result_vb -> value_bead.total_data_elements; return; apl_laminate_: entry(operators_argument); call determine_conformability; /* check ranks, find which case, set up parameters */ if left_scalar then if right_scalar then go to comma_two_scalars; else /* scalar,array */ call calculate_result_bead_laminate (right_vb); /* because right is array it dominates */ else if right_scalar /* array,scalar */ then call calculate_result_bead_laminate (left_vb); /* left is array */ else if right_rr = left_rr /* arrays of the same rank */ then do; if I > right_rr then go to rank_subsc_error; rhorho = right_rr + 1; do j = 0 by 1 while (j < right_rr); /* make sure rho vectors are equal */ if left_vb->value_bead.rho(j + 1) ^= right_vb->value_bead.rho(j + 1) then go to length_error; end; outersize = 2 * left_vb->value_bead.total_data_elements; innersize = 1; do j = I by 1 while (j < left_rr); innersize = left_vb->value_bead.rho(j + 1) * innersize; end; joint = innersize; /* allocate and fill rho */ call stack_allocate; do j = 0 by 1 while (j < I); /* part of rho before joint */ result_vb->value_bead.rho(j + 1) = left_vb->value_bead.rho(j + 1); end; do j = I by 1 while (j < right_rr); /* part of rho after joint */ result_vb->value_bead.rho(j+2) = left_vb->value_bead.rho(j + 1); end; result_vb->value_bead.rho(I+1) = 2; /* part of rho for joint */ end; else go to rank_error; J = 2; go to catenate_laminate_join; /* Subroutine to calculate bead info and sizes, etc. for laminate when one operand is scalar and the other is vector */ calculate_result_bead_laminate: procedure (a_array_bead_ptr); declare a_array_bead_ptr pointer parameter; /* which bead is array */ declare array_bead_ptr pointer initial /* for efficiency */ (a_array_bead_ptr); if I > array_bead_ptr -> value_bead.rhorho then go to rank_subsc_error; kludge_rhorho = array_bead_ptr -> value_bead.rhorho + 1; outersize = 2 * array_bead_ptr -> value_bead.total_data_elements; innersize = 1; do j = I by 1 while (j < array_bead_ptr -> value_bead.rhorho); innersize = array_bead_ptr -> value_bead.rho(j + 1) * innersize; end; joint = innersize; /* since joining two things of equal size */ /* allocate and fill rho */ call stack_allocate; do j = 0 by 1 while ( j < kludge_rhorho); if j < I then result_vb->value_bead.rho(j + 1) = array_bead_ptr -> value_bead.rho(j + 1); else if j = I then result_vb->value_bead.rho(j + 1) = 2; /* the lamination dimension */ else result_vb->value_bead.rho(j + 1) = array_bead_ptr -> value_bead.rho(j); end; end calculate_result_bead_laminate; /*** errors ***/ dcl (apl_error_table_$operator_subscript_range, apl_error_table_$length, apl_error_table_$rank, apl_error_table_$domain) fixed bin(35) external; rank_subsc_error: operators_argument.error_code = apl_error_table_$operator_subscript_range; return; rank_error: operators_argument.error_code = apl_error_table_$rank; return; length_error: operators_argument.error_code = apl_error_table_$length; return; domain_error_right: operators_argument.where_error = operators_argument.where_error - 1; domain_error: operators_argument.error_code = apl_error_table_$domain; return; end /* apl_comma_operators */;  apl_command_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 210951 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3 */ apl_command_: proc (line, r_paren_pos, exit_flag); /* * this module processes commands for APL. * * written 7/25/73 by DAM * Modified 1/7/74 by PG to fix )WIDTH to tell dim. Modified 740405 by PG to fix )COPY, flush )MAIL Modified 741009 by PG to add )V1LIB, change )HELP for installation. Modified 741017 by PG to add )TABS. Modified 770112 by PG to add )V1DROP, delete )WORK, fix )HELP, and fix )TABS. Modified 770303 by PG to add )ERRS, delete )BRIEF and )LONG (bug 265), and fix locks (bug 276). Modified 780207 by PG to fix 309, add dummy )RESET, and do a little cleaning up of the source Modified 780211 by PG to add $from_editor entrypoint. Modified 780512 by William York to change calling sequences for the vars, fns, and grps commands. Modified 790213 by PG to fix 367 (copy command could not handle wsid's with locks). Modified 790720 by PG to fix 404 (the last change fixed locks for copy, but broke them for everything else!), and to switch to iox_. Modified 791219 by PG to add )VERSION and )SINL. Modified 800131 by PG to add )? Modified 811210 by TO to add )EFNS */ /* parameters */ declare line char (*) aligned parameter, /* the command string */ r_paren_pos fixed bin (21) parameter, /* index in line of the ")" that begins the command */ exit_flag fixed bin (35) parameter; /* return code to caller */ /* automatic */ declare amount_to_pass fixed bin (21), called_from_editor bit (1) aligned, cur_pos fixed bin (21), his_password char (8) aligned, list_count fixed bin, list_element (100) char (100), /* TEMPORARY KLUDGE - interface will probably be changed */ lock_len fixed bin (21), lock_ptr ptr, tok_len fixed bin (21), tok_type fixed bin, wsid_len fixed bin (21), wsid_ptr ptr, cmd4 char (4) aligned, cmd_number fixed bin, old_flag bit (1) aligned, on_off bit (1) aligned, letter char (1) aligned, command_line char (132), send_type bit (1) aligned, /* indicates whether command is MSG on|off or to be sent */ code fixed bin (35), 1 ready_mode aligned, 2 ready_state bit (1) unaligned, 2 pad bit (35) unaligned; declare ext_fcn_class_code fixed bin, old_tab_width fixed bin, tab_width fixed bin, apl_number float; /* based */ declare string_to_pass char (amount_to_pass) unaligned based (addr (line_array (cur_pos))), wsid_string char (wsid_len) unaligned based (wsid_ptr), lock_string char (lock_len) unaligned based (lock_ptr), line_array (length (line)) char (1) unaligned based (addr (line)); /* builtin */ declare (addr, float, hbound, lbound, length, min, substr) builtin; /* entries */ declare apl_flush_buffer_nl_ entry (), apl_print_string_ entry (char (*)), apl_read_password_ entry (char (8) aligned), apl_external_fcn_defn_ entry (char (*), fixed bin), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), convert_binary_integer_$decimal_string entry (fixed bin (35)) returns (char (13) varying), apl_error_$huh entry (fixed bin (35)), ioa_$ioa_switch entry options (variable), who entry options (variable), help entry options (variable), cu_$ready_proc entry (1 aligned, 2 bit (1) unaligned, 2 bit (35) unaligned), cu_$cp entry (pointer, fixed bin (21), fixed bin (35)), (apl_vars_command_, apl_fns_command_, apl_efns_command_, apl_grps_command_) entry (char (1) aligned, bit (1) aligned), apl_clear_workspace_ entry, (apl_si_command_, apl_siv_command_) entry, (apl_save_command_, apl_load_command_, apl_wsid_command_) entry (char (*), char (*), fixed bin (35)), apl_directory_commands_ entry (char (4) aligned, char (*)), (apl_copy_command_, apl_v1_copy_command_) entry (char (*), char (*), bit (1) aligned, char (*) dim (*), fixed bin, fixed bin (35)), apl_erase_command_ entry (fixed bin, dim (*) char (*)), apl_group_command_ entry (fixed bin, dim (*) char (*)), apl_grp_command_ entry (char (*)); /* external static */ declare ( apl_error_table_$return_from_apl, apl_error_table_$ws_cleared, apl_error_table_$ws_loaded ) fixed bin (35) external, apl_static_$apl_output ptr external static, apl_static_$version_number char (5) external static; /* internal static */ /* table of commands, used to dispatch through cmd (): tv */ declare cmd_table (0:48) char (8) aligned static init ("r", /* 0 */ "q", /* 1 */ "quit", /* 2 */ "e", /* 3 */ "errs", /* 4 */ "reset", /* 5 */ "debug", /* 6 */ "vars", /* 7 */ "grps", /* 8 */ "fns", /* 9 */ "digits", /* 10 */ "origin", /* 11 */ "width", /* 12 */ "clear", /* 13 */ "siv", /* 14 */ "si", /* 15 */ "save", /* 16 */ "load", /* 17 */ "wsid", /* 18 */ "check", /* 19 */ "help", /* 20 */ "huh", /* 21 */ "off", /* 22 */ "continue", /* 23 */ "exec", /* 24 */ "erase", /* 25 */ "copy", /* 26 */ "pcopy", /* 27 */ "group", /* 28 */ "grp", /* 29 */ "msg", /* 30 */ "lib", /* 31 */ "zfn", /* 32 */ "mfn", /* 33 */ "dfn", /* 34 */ "libd", /* 35 */ "drop", /* 36 */ "ports", /* 37 */ "meter", /* 38 */ "v1drop", /* 39 */ "symbols", /* 40 */ "v1copy", /* 41 */ "v1pcopy", /* 42 */ "v1lib", /* 43 */ "tabs", /* 44 */ "version", /* 45 */ "sinl", /* 46 */ "?", /* 47 */ "efns"); /* 48 */ declare command_OK_in_editor (0:48) bit (1) unaligned internal static initial ("1"b, /* 0 */ (2) (1)"0"b, /* 1-2 */ (2) (1)"1"b, /* 3-4 */ "0"b, /* 5 */ (7) (1)"1"b, /* 6-12 */ "0"b, /* 13 */ (2) (1)"1"b, /* 14-15 */ (2) (1)"0"b, /* 16-17 */ (4) (1)"1"b, /* 18-21 */ (2) (1)"0"b, /* 22-23 */ "1"b, /* 24 */ (2) (1)"0"b, /* 25-26 */ (14) (1)"1"b, /* 27-40 */ "0"b, /* 41 */ (7) (1)"1"b); /* 42-48 */ /* include files */ %include apl_characters; %include apl_scan_info; %include apl_ws_info; %include apl_number_data; /* program */ called_from_editor = "0"b; /* main entry */ go to join; apl_command_$from_editor: entry (line, r_paren_pos, exit_flag); called_from_editor = "1"b; join: exit_flag = 0; cur_pos = r_paren_pos + 1; call scan; /* We don't care about the token type */ cmd4 = substr (line, cur_pos, min (tok_len, 4)); /* expand or truncate to 4 chars for lookup */ do cmd_number = lbound (cmd_table, 1) to hbound (cmd_table, 1) while (cmd4 ^= substr (cmd_table (cmd_number), 1, 4)); end; if cmd_number <= hbound (cmd_table, 1) then if (tok_len > 4 & substr (line, cur_pos, tok_len) = cmd_table (cmd_number)) | (tok_len <= 4) then do; cur_pos = cur_pos + tok_len; /* skip over command name */ if called_from_editor & ^command_OK_in_editor (cmd_number) then do; call ioa_$ioa_switch (apl_static_$apl_output, "not while in editor"); return; end; go to cmd (cmd_number); end; incorrect_command: call ioa_$ioa_switch (apl_static_$apl_output, "incorrect command"); return; cmd (0): /* )R causes ready message */ ready_mode.ready_state = "1"b; call cu_$ready_proc (ready_mode); return; cmd (22): /* )OFF [HOLD] [: [SIGNOFF_LOCK]] */ call off_command_parse; cmd (1): /* )Q */ cmd (2): /* )QUIT */ exit_flag = apl_error_table_$return_from_apl; return; cmd (23): /* )CONTINUE [HOLD] [:SIGNOFF_LOCK] */ call off_command_parse; call apl_save_command_ ("continue", (ws_info.lock), code); if code = 0 then go to cmd (1); /* if saved successfully, do )Q */ ws_info.off_hold = "0"b; /* if error, clean up after ourselves */ ws_info.signoff_lock = ""; /* .. */ return; cmd (3): /* )E command_line */ cmd (24): /* )EXEC command_line */ if ws_info.restrict_exec_command then go to incorrect_command; substr (line, 1, cur_pos - 1) = ""; /* blank out beginning of line, before actual command */ /* (caveat vocator) */ ws_info.transparent_to_signals = "1"b; /* while out in Multics command system, turn off our */ call cu_$cp (addr (line), length (line), (0)); /* condition handler. The effect is intended to */ ws_info.transparent_to_signals = "0"b; /* be as if it was in a separate process */ return; cmd (45): /* )VERSION */ call scan; if tok_type ^= NO_TOKEN then go to incorrect_command; call ioa_$ioa_switch (apl_static_$apl_output, "is ^a", apl_static_$version_number); return; cmd (47): /* Query command (?) */ call scan; if tok_type ^= NO_TOKEN then go to incorrect_command; do cmd_number = lbound (cmd_table, 1) to hbound (cmd_table, 1); call apl_print_string_ ((cmd_table (cmd_number))); end; call apl_flush_buffer_nl_; return; cmd (37): /* )PORTS */ call who; return; cmd (30): /* )MSG */ if ws_info.restrict_msg_command then go to incorrect_command; call scan; send_type = "0"b; if tok_type = NO_TOKEN /* no argument */ then on_off = "1"b; else do; if tok_type = NAME_TOKEN then if substr (line, cur_pos, tok_len) = "on" then on_off = "1"b; else if substr (line, cur_pos, tok_len) = "off" then on_off = "0"b; else send_type = "1"b; if ^send_type then do; /* allow only one argument */ cur_pos = cur_pos + tok_len; call scan; if tok_type ^= NO_TOKEN then go to incorrect_command; end; end; if ^send_type then do; if on_off then command_line = "immediate_messages"; else command_line = "defer_messages"; end; else command_line = "send_message " || substr (line, cur_pos); call cu_$cp (addr (command_line), length (command_line), code); if code ^= 0 then go to incorrect_command; return; cmd (4): /* )ERRS */ call scan; if tok_type = NO_TOKEN then do; call ioa_$ioa_switch (apl_static_$apl_output, "is ^[long^;brief^]", ws_info.long_error_mode); return; end; else if tok_type ^= NAME_TOKEN then go to incorrect_command; old_flag = ws_info.long_error_mode; if substr (line, cur_pos, tok_len) = "brief" then on_off = "0"b; else if substr (line, cur_pos, tok_len) = "long" then on_off = "1"b; else go to incorrect_command; cur_pos = cur_pos + tok_len; call scan; if tok_type ^= NO_TOKEN then go to incorrect_command; call ioa_$ioa_switch (apl_static_$apl_output, "was ^[long^;brief^]", old_flag); ws_info.long_error_mode = on_off; return; cmd (6): /* )DEBUG */ if ws_info.restrict_debug_command then go to incorrect_command; call on_off_parse (ws_info.debug_mode); return; cmd (38): /* )METER */ call on_off_parse (ws_info.meter_mode); return; cmd (19): /* )CHECK */ call on_off_parse (ws_info.compatibility_check_mode); return; cmd (44): /* )TABS N_ */ call iox_$control (apl_static_$apl_output, "get_tab_width", addr (old_tab_width), code); /* get old width */ call scan; /* find argument */ if tok_type = NO_TOKEN then do; /* no arg given */ call ioa_$ioa_switch (apl_static_$apl_output, "is ^d", old_tab_width); return; end; else if tok_type ^= INTEGER_TOKEN then go to incorrect_command; tab_width = apl_number; /* remember new value */ call iox_$control (apl_static_$apl_output, "set_tab_width", addr (tab_width), code); if code ^= 0 then go to incorrect_command; /* DIM didn't like value... */ call ioa_$ioa_switch (apl_static_$apl_output, "was ^d", old_tab_width); return; /* commands for defining external functions */ cmd (32): /* )ZFN */ ext_fcn_class_code = 2; go to external_function_command; cmd (33): /* )MFN */ ext_fcn_class_code = 3; go to external_function_command; cmd (34): /* )DFN */ ext_fcn_class_code = 4; external_function_command: if ws_info.restrict_external_functions then go to incorrect_command; call scan; /* skip blanks before arg */ if tok_type = NO_TOKEN then go to incorrect_command; amount_to_pass = length (line) - cur_pos + 1 - 1; /* the +1-1 is to strip off newline. This subroutine does the real work */ call apl_external_fcn_defn_ (string_to_pass, ext_fcn_class_code); return; cmd (21): /* )HUH - reprint last error in long form */ if ws_info.last_error_code = 0 then call ioa_$ioa_switch (apl_static_$apl_output, "no previous error"); else call apl_error_$huh (ws_info.last_error_code); return; /* The following commands list the 3 flavors of workspace names in the same fashion. */ cmd (7): /* )VARS */ cmd (8): /* )GRPS */ cmd (9): /* )FNS */ cmd (48): /* )EFNS */ call scan; /* look for optional argument */ if tok_type = NO_TOKEN then letter = " "; else if tok_type = NAME_TOKEN then if tok_len = 1 then letter = substr (line, cur_pos, 1); else go to incorrect_command; else go to incorrect_command; if cmd_number = 7 then call apl_vars_command_ (letter, called_from_editor); else if cmd_number = 9 then call apl_fns_command_ (letter, called_from_editor); else if cmd_number = 48 then call apl_efns_command_ (letter, called_from_editor); else call apl_grps_command_ (letter, called_from_editor); return; /* The following commands, if given with no argument, print the appropriate value, else they attempt to change the ws parameter to that value */ cmd (10): /* )DIGITS */ call number_command (ws_info.digits, 1, 19); return; cmd (11): /* )ORIGIN */ call number_command (ws_info.index_origin, 0, 1); ws_info.float_index_origin = float (ws_info.index_origin); /* in case has changed, update for iota */ return; cmd (12): /* )WIDTH */ call number_command (ws_info.width, 30, 390); call iox_$modes (apl_static_$apl_output, "ll" || convert_binary_integer_$decimal_string ((ws_info.width)), "", code) ; return; cmd (40): /* )SYMBOLS */ call number_command (ws_info.number_of_symbols, 0, 0); return; /* The following commands all deal with the workspace itself in some way. */ cmd (5): /* )RESET */ call ioa_$ioa_switch (apl_static_$apl_output, "not implemented"); return; cmd (13): /* )CLEAR */ call scan; /* check for argument */ if tok_type = NO_TOKEN then do; /* normal clear with no argument */ call apl_clear_workspace_; call ioa_$ioa_switch (apl_static_$apl_output, "clear ws"); exit_flag = apl_error_table_$ws_cleared; return; end; else go to incorrect_command; cmd (14): /* )SIV */ cmd (46): /* )SINL */ call apl_siv_command_; return; cmd (15): /* )SI */ call apl_si_command_; return; cmd (16): /* )SAVE */ if ws_info.restrict_save then go to incorrect_command; call ws_command (apl_save_command_); return; cmd (17): /* )LOAD */ if ws_info.restrict_load then go to incorrect_command; call ws_command (apl_load_command_); if code = 0 then exit_flag = apl_error_table_$ws_loaded; return; cmd (18): /* )WSID */ call ws_command (apl_wsid_command_); return; /* The following commands are somewhat temporary, probably. They are an attempt to provide a reasonable user interface. */ cmd (20): /* )HELP command for getting help I guess */ tok_len = length (line) - 1; /* drop trailing NL */ do cur_pos = cur_pos to tok_len while (substr (line, cur_pos, 1) = " "); end; if cur_pos > tok_len /* nothing on line */ then call help ("apl_help_available"); else call help (substr (line, cur_pos, tok_len - cur_pos + 1)); return; cmd (31): /* )LIB */ cmd (35): /* )LIBD is parsed the same way */ cmd (43): /* )V1LIB */ call scan; /* find argument, if any */ if tok_type = NO_TOKEN then amount_to_pass = 0; /* no arg, pass null string */ else amount_to_pass = length (line) - cur_pos; /* pass rest of line, but not newline at end */ call apl_directory_commands_ (cmd4, string_to_pass); return; cmd (36): /* )DROP */ cmd (39): /* )V1DROP */ call ws_command (drop_command); return; cmd (26): /* )COPY */ call copy_command (apl_copy_command_, "0"b); return; cmd (27): /* )PCOPY */ call copy_command (apl_copy_command_, "1"b); return; cmd (41): /* )V1COPY */ call copy_command (apl_v1_copy_command_, "0"b); return; cmd (42): /* )V1PCOPY */ call copy_command (apl_v1_copy_command_, "1"b); return; cmd (25): /* )ERASE */ call compile_list; call apl_erase_command_ (list_count, list_element); return; cmd (28): /* )GROUP */ call compile_list; call apl_group_command_ (list_count, list_element); return; cmd (29): /* )GRP */ call compile_list; if list_count ^= 1 then go to incorrect_command; call apl_grp_command_ (list_element (1)); return; /* Internal procedures (in alphabetical order) */ compile_list: procedure; list_count = 0; list_loop: call scan; if tok_type = NO_TOKEN then return; if tok_type ^= NAME_TOKEN then go to incorrect_command; list_count = list_count + 1; list_element (list_count) = substr (line, cur_pos, tok_len); cur_pos = cur_pos + tok_len; go to list_loop; end compile_list; drop_command: proc (wsid, lock, code); declare wsid char (*) parameter, lock char (*) parameter, code fixed bin (35) parameter; if length (lock) ^= 0 then go to incorrect_command; /* no lock allowed */ code = 0; /* code is not really used */ call apl_directory_commands_ (cmd4, wsid); end; get_lock: proc; /* this proc is called when type-1 token seen, may be colon */ if substr (line, cur_pos, 1) ^= ":" then go to incorrect_command; cur_pos = cur_pos + 1; call scan; if tok_type = NO_TOKEN /* colon but no lock = blank lock */ then do; lock_ptr = addr (QSpace); lock_len = 1; return; end; else if tok_type = DELIMITER_TOKEN then do; if tok_len ^= 1 then go to incorrect_command; if substr (line, cur_pos, 1) ^= QQuadQuote then go to incorrect_command; cur_pos = cur_pos + 1; /* get line from user attempting to use print-suppress */ call apl_read_password_ (his_password); if his_password = "*" then do; lock_len = 1; lock_ptr = addr (QSpace); end; else do; lock_len = length (his_password); /* trailing spaces are OK */ lock_ptr = addr (his_password); end; end; else if tok_type ^= NAME_TOKEN then go to incorrect_command; else do; /* use just next token after colon as the lock */ lock_ptr = addr (line_array (cur_pos)); lock_len = tok_len; cur_pos = cur_pos + tok_len; end; call scan; /* check for unwated tokens after lock */ return; end get_lock; number_command: procedure (variable, minimum, maximum); declare (variable, minimum, maximum) fixed bin parameter, n fixed bin; call scan; if tok_type = NO_TOKEN /* no argument, tell what variable is */ then call ioa_$ioa_switch (apl_static_$apl_output, "is ^d", variable); else if minimum = maximum /* )SYMBOLS escape */ then go to incorrect_command; /* can't assign to this one... */ else if tok_type = INTEGER_TOKEN /* integer argument */ then do; n = apl_number; if n < minimum then go to incorrect_command; else if n > maximum then go to incorrect_command; call ioa_$ioa_switch (apl_static_$apl_output, "was ^d", variable); variable = n; end; else go to incorrect_command; /* name or floating point cruft */ end number_command; off_command_parse: procedure; call scan; if tok_type = NO_TOKEN then return; if tok_type = NAME_TOKEN then if substr (line, cur_pos, tok_len) = "hold" then do; ws_info.off_hold = "1"b; /* tell apl_subsystem_ to do an off hold */ cur_pos = cur_pos + tok_len; call scan; end; else go to incorrect_command; if tok_type = DELIMITER_TOKEN then do; call get_lock; if lock_len = 1 & lock_string = " " then ws_info.signoff_lock = "*"; /* blank lock */ else ws_info.signoff_lock = lock_string; call scan; end; if tok_type ^= NO_TOKEN then go to incorrect_command; return; end off_command_parse; on_off_parse: procedure (bv_flag); /* parameters */ declare bv_flag bit (1) unaligned; /* automatic */ declare new_flag bit (1) aligned; /* program */ call scan; if tok_type = NO_TOKEN then do; /* if no argument, print state */ call ioa_$ioa_switch (apl_static_$apl_output, "is ^[on^;off^]", bv_flag); return; end; else if tok_type ^= NAME_TOKEN then go to incorrect_command; if substr (line, cur_pos, tok_len) = "on" then new_flag = "1"b; else if substr (line, cur_pos, tok_len) = "off" then new_flag = "0"b; else go to incorrect_command; cur_pos = cur_pos + tok_len; call scan; if tok_type ^= NO_TOKEN then go to incorrect_command; /* allow only one argument */ call ioa_$ioa_switch (apl_static_$apl_output, "was ^[on^;off^]", bv_flag); bv_flag = new_flag; return; end on_off_parse; scan: procedure (); /* lazy programmers... */ call apl_scan_ (line, cur_pos, cur_pos, tok_len, tok_type, addr (apl_number)); end scan; ws_command: proc (command); copy = "0"b; go to it; copy_command: entry (command, protected); copy = "1"b; declare command entry options (variable), (copy, protected) bit (1) aligned; declare cur_state fixed bin, saw_number bit (1) aligned, last_in_wsid fixed bin (21), start_of_wsid fixed bin (21); /* internal static */ declare new_state (0:1, 0:5) fixed bin (8) unal internal static initial (3, 0, 1, 2, 2, 3, 3, 0, 3, 2, 2, 3); /* program */ it: lock_ptr = addr (wsid_ptr); /* avoid uninitialized ptr (to null string) */ lock_len = 0; /* if no lock specified, will use null string */ call scan; /* Check for optional wsid (and/or lock), and optional arguments for copy */ saw_number = "0"b; last_in_wsid, start_of_wsid = cur_pos; if tok_type = INTEGER_TOKEN then do; saw_number = "1"b; last_in_wsid, cur_pos = cur_pos + tok_len; call scan; end; cur_state = 0; begin: if (tok_type = DELIMITER_TOKEN) & (substr (line, cur_pos, 1) = ":") then tok_type = 5; /* special for colon */ cur_state = new_state (cur_state, tok_type); go to state (cur_state); state (0): /* delimiter seen */ if saw_number then if (substr (line, cur_pos, 1) = "<") | (substr (line, cur_pos, 1) = ">") then go to incorrect_command; /* can't mix lib number and pathname */ state (1): /* first name seen */ last_in_wsid, cur_pos = cur_pos + tok_len; call scan; go to begin; state (2): /* error - number seen */ go to incorrect_command; state (3): /* done */ if tok_type = 5 then call get_lock; wsid_len = last_in_wsid - start_of_wsid; wsid_ptr = addr (line_array (start_of_wsid)); if copy then do; call compile_list; call command (wsid_string, lock_string, protected, list_element, list_count, code); return; end; if tok_type ^= NO_TOKEN then go to incorrect_command; /* extraneous arguments */ call command (wsid_string, lock_string, code); end /* ws_command */; end /* apl_command_ */;  apl_compression_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 114831 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* This module implements the two APL mixed operators compression and expansion. Created by Richard S. Lamson on an unknown date Essentially completely recoded by G. Gordon Benedict on 11/17/73 to: fix bugs in stack allocation and copy up code fix a slight bug in algorithm make more efficient. Modified 770223 by PG to fix bug 192 (handling of 0\i0 and 1\i0). Modified 770224 by PG to fix unnumbered bug whereby operators_argument.result did not always get set if right arg was on stack. Also fixed operators to extend scalar arg on rhs. Modified 770228 by PG to fix bug 272 (1 0\4 fails...770224 change wasn't quite right), and bug 274 (operations on characters set value_stack_ptr one word too high). Modified 790308 by William M. York to double-word align all value beads. Modified 800226 by BIM and PG for bug 445 (0\'X' should be '/b'). Modified 800226 by PG to fix 454 (expand and compress failed if qCT=0). We should never have used qCT here, anyway, so I changed it to use the qIT (with the new algorithm, to avoid bug 358). */ /* format: style3 */ apl_compression_: procedure (operators_argument); internal_op_code = compression; go to joined_code; apl_expansion_: entry (operators_argument); internal_op_code = expansion; joined_code: integer_fuzz = ws_info.integer_fuzz; right_vb = operators_argument.operands (2).value; if right_vb -> value_bead.numeric_value then do; copy_zero = copy_zero_num (internal_op_code); copy_one = copy_one_num (internal_op_code); end; else if right_vb -> value_bead.character_value then do; copy_zero = copy_zero_char (internal_op_code); copy_one = copy_one_char (internal_op_code); end; else go to domain_error_right; if right_vb -> value_bead.rhorho = 0 then dimension, result_rhorho = 1; else do; result_rhorho = right_vb -> value_bead.rhorho; dimension = operators_argument.dimension; end; right_data_elements = right_vb -> value_bead.total_data_elements; if right_data_elements = 1 then do; dim_to_compress = right_data_elements; /* is 1 of course */ from_increment = 0; /* right is scalar so do not increment index to non-existent next element */ end; else do; dim_to_compress = right_vb -> value_bead.rho (dimension); if dimension > right_vb -> value_bead.rhorho then goto operator_subscript_range_error; from_increment = 1; /* next element of right will be 1 element ahead of last */ end; left_vb = operators_argument.operands (1).value; left_data_elements = left_vb -> value_bead.total_data_elements; left = left_vb -> value_bead.data_pointer; right = right_vb -> value_bead.data_pointer; skip, times = 1; do subscript = 1 by 1 while (subscript < dimension); times = right_vb -> value_bead.rho (subscript) * times; end; do subscript = dimension + 1 to right_vb -> value_bead.rhorho; skip = right_vb -> value_bead.rho (subscript) * skip; end; /* left arg is not null, check that it is numeric */ if left_data_elements ^= 0 then if ^left_vb -> value_bead.numeric_value then go to domain_error_left; if left_data_elements = 1 then if internal_op_code = compression then do; if abs (left_numeric_datum (0)) <= integer_fuzz then go to create_null_value; if abs (left_numeric_datum (0) - 1e0) <= integer_fuzz then go to return_right_argument; goto domain_error_left; end; else ; /* no special cases for expansion */ else if left_vb -> value_bead.rhorho ^= 1 then go to rank_error; ones_count = 0; if left_data_elements ^= 0 then if left_vb -> value_bead.zero_or_one_value then ones_count = fixed (sum (left_numeric_datum), 35); /* add up and convert to fixed */ else do this_subscript = 0 by 1 while (this_subscript < left_data_elements); value = floor (left_numeric_datum (this_subscript) + .5e0); if abs (value) > integer_fuzz /* not equal to zero */ then if abs (value - 1e0) <= integer_fuzz then ones_count = ones_count + 1; /* equal to one */ else go to domain_error_left; /* not equal to zero or one */ end; /* Calculate the length of the result */ if internal_op_code = compression then if (left_data_elements = dim_to_compress) | (right_data_elements = 1) then result_length = ones_count; else goto length_error; else if (ones_count = dim_to_compress) | (right_data_elements = 1) then result_length = left_data_elements; else go to incomplete_expansion; /* Handle special cases & optimizations. */ if /* tree */ result_length = dim_to_compress then if internal_op_code = compression then go to return_right_argument; /* compression won't shorten arg */ else if (right_data_elements = 1) & (ones_count = 0) then ; /* 0\ */ else go to return_right_argument; /* expansion won't lengthen arg */ if left_data_elements = 0 then go to create_null_value; call allocate_result; from_subscript, to_subscript = 0; do time = 0 by 1 while (time < times); /* this loop controls how often left array is looped thru */ do position = 0 by 1 while (position < left_data_elements); /* loop thru left arg */ if abs (left_numeric_datum (position)) <= integer_fuzz then copy_site = copy_zero; else copy_site = copy_one; do subscript = 0 by 1 while (subscript < skip); /* loop across dim to be reduced */ go to copy_site; copy_zero_char (0): result_value_char (to_subscript) = Blank; to_subscript = to_subscript + 1; go to exeunt; copy_zero_num (0): result_numeric_datum (to_subscript) = 0.0e0; to_subscript = to_subscript + 1; go to exeunt; copy_one_char (0): copy_one_char (1): result_value_char (to_subscript) = right_argument_char (from_subscript); to_subscript = to_subscript + 1; goto increment_from_subscript; copy_one_num (0): copy_one_num (1): result_numeric_datum (to_subscript) = right_numeric_datum (from_subscript); to_subscript = to_subscript + 1; copy_zero_char (1): copy_zero_num (1): increment_from_subscript: from_subscript = from_subscript + from_increment; exeunt: end; end; end; if ^operators_argument.operands (2).on_stack then do; /* right not on stack, see if can move to left */ if ^operators_argument.operands (1).on_stack then do; /* cannot, just return it whereever it is */ call fill_in_bead (); /* finalize bead contents */ return; end; final_result_vb = left_vb; end; else /* right is on stack */ final_result_vb = right_vb; if fixed (rel (final_result_vb), 18, 0) + total_words_wanted > ws_info.maximum_value_stack_size then return; /* copy-up wouldn't fit on stack... */ ws_info.pointers.value_stack_ptr = final_result_vb; /* put result here */ previous_result_array_pointer = result; /* save because allocate_again will smash */ call allocate_again (); /* allocate at this new spot */ call fill_in_bead (); /* fill in bead values */ if data_words_wanted = 0 then return; /* avoid IPR */ result -> word_copy_overlay = /* copy up stack */ previous_result_array_pointer -> word_copy_overlay; return; create_null_value: result_length = 0; goto return_same; return_right_argument: /* no change; left arg must be all 1s */ if operators_argument.operands (2).on_stack then do; /* how lucky -- just return it */ operators_argument.result = right_vb; data_elements = right_vb -> value_bead.total_data_elements; number_of_dimensions = right_vb -> value_bead.rhorho; total_words_wanted = size (value_bead) + size (numeric_datum) + 1; ws_info.value_stack_ptr = addrel (right_vb, total_words_wanted); /* protect result */ return; end; result_length = dim_to_compress; return_same: if operators_argument.operands (2).on_stack then ws_info.value_stack_ptr = right_vb; else if operators_argument.operands (1).on_stack then ws_info.value_stack_ptr = left_vb; call allocate_result (); call fill_in_bead (); result -> word_copy_overlay = /* copy entire right array onto stack */ right -> word_copy_overlay; return; rank_error: operators_argument.error_code = apl_error_table_$rank; return; incomplete_expansion: operators_argument.error_code = apl_error_table_$incomplete_expansion; return; length_error: operators_argument.error_code = apl_error_table_$length; return; domain_error_right: operators_argument.where_error = operators_argument.where_error - 2; domain_error_left: operators_argument.where_error = operators_argument.where_error + 1; operators_argument.error_code = apl_error_table_$domain; return; operator_subscript_range_error: operators_argument.error_code = apl_error_table_$operator_subscript_range; return; allocate_result: procedure (); data_elements = multiply (multiply (times, skip, 21, 0), result_length, 21, 0); number_of_dimensions = result_rhorho; bead_words_wanted = size (value_bead); /* words to be in result value bead */ if right_vb -> value_bead.numeric_value /* numbers we want */ then data_words_wanted = size (numeric_datum) + 1; else data_words_wanted = size (character_string_overlay); allocate_again: /* entry point for moving final result up stack */ entry (); /* bead_words_wanted and data_words_wanted have either been set by caller, or by falling through from allocate_result above. */ total_words_wanted = bead_words_wanted + data_words_wanted; result_vb = apl_push_stack_ (total_words_wanted); result = addrel (result_vb, bead_words_wanted); if right_vb -> value_bead.numeric_value then if substr (rel (result), 18, 1) then result = addrel (result, 1); operators_argument.result = result_vb; end allocate_result; fill_in_bead: procedure (); result_vb -> value_bead.data_pointer = result; string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type); result_vb -> value_bead.total_data_elements = data_elements; do subscript = 1 to right_vb -> value_bead.rhorho; result_vb -> value_bead.rho (subscript) = right_vb -> value_bead.rho (subscript); end; result_vb -> value_bead.rho (dimension) = result_length; result_vb -> value_bead.rhorho = result_rhorho; end fill_in_bead; %include apl_push_stack_fcn; /* automatic */ declare (dimension, dim_to_compress, internal_op_code, times, skip, ones_count, result_length, from_subscript, to_subscript, position, subscript, data_elements, time, this_subscript, left_data_elements, right_data_elements, result_rhorho) fixed binary (21); declare (total_words_wanted, bead_words_wanted, data_words_wanted, from_increment) fixed binary precision (19); declare integer_fuzz float, value float; declare (copy_site, copy_zero, copy_one) label local; declare (left_vb, left, right_vb, right, result_vb, result, previous_result_array_pointer, final_result_vb) pointer; /* based */ declare word_copy_overlay dimension (data_words_wanted) based fixed binary (35); /* for rapid data copying */ declare left_numeric_datum (0:left_data_elements - 1) float based (left), result_numeric_datum (0:data_elements - 1) float based (result), right_numeric_datum (0:right_data_elements - 1) float based (right); declare 1 right_argument_char_structure based (right) aligned, 2 right_argument_char character (1) unaligned dimension (0:right_data_elements - 1); declare 1 result_value_char_structure based (result) aligned, 2 result_value_char character (1) unaligned dimension (0:data_elements - 1); /* external static */ declare ( apl_error_table_$length, apl_error_table_$rank, apl_error_table_$domain, apl_error_table_$operator_subscript_range, apl_error_table_$incomplete_expansion ) fixed binary (35) external static; /* internal static */ declare ( compression initial (1), expansion initial (0) ) fixed binary internal static; declare Blank character (1) aligned internal static initial (" "); /* builtins */ declare (abs, addrel, fixed, floor, rel, size, multiply, sum, string, substr) builtin; /* include files */ %include apl_bead_format; %include apl_value_bead; %include apl_ws_info; %include apl_number_data; %include apl_operators_argument; end apl_compression_;  apl_create_save_frame_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 82026 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Program to push a "save" frame on the APL stack. Used by programs which must operate in the global environment. Richard S. Lamson, 1973. Modified by PG on 740315 to fix a bug which caused the save frame to overwrite the last word of the previous frame. Modified by PG on 740514 to check for running off the parse stack, and fix a serious reference count bug. Modified by G. Gordon Benedict in July, 1974 to add correct apl names to entry points Modified 761011 by PG for new parse_frame declaration. Modified 770204 by PG to get update entry to restore local meanings (apparently hasn't done so since 740514 change was made). Modified 790815 by PG to fix 413 (local meanings don't get restored by )LOAD...looks like this was broken by 770204 change...looks like there are 3 cases, not 2 as I had thought). */ apl_create_save_frame_: procedure; /* Push a save frame after the suspended frame that is on the top of the stack now. */ parse_frame_ptr = ws_info.current_parse_frame_ptr; number_of_ptrs = 1 + divide (addr (parse_frame.old_meaning_ptrs (1)) -> source_length + 3, 4, 21, 0); save_frame_pointer = addrel (parse_frame_ptr, size (parse_frame)); if fixed (rel (save_frame_pointer), 18) > max_parse_stack_depth then call apl_system_error_ (apl_error_table_$cant_push_save_frame); total_symbols = 0; /* Save a pointer to each symbol bead, a pointer to each meaning, and set g-m-p-p to null to indicate that the current meaning is assumed to be the global meaning. */ do bucket_number = 1 to symbol_table.table_size; do symbol_pointer = symbol_table.hash_bucket_ptr (bucket_number) repeat (symbol_pointer -> symbol_bead.hash_link_pointer) while (symbol_pointer ^= null); total_symbols = total_symbols + 1; save_frame.symbol_pointer (total_symbols) = symbol_pointer; call increment_reference_count (symbol_pointer); save_frame.saved_meaning_pointer (total_symbols) = symbol_pointer -> symbol_bead.meaning_pointer; call increment_reference_count (symbol_pointer -> symbol_bead.meaning_pointer); save_frame.global_meaning_pointer_pointer (total_symbols) = null; end; end; /* Now walk the stack and find the "globalest" meaning for each symbol. If the symbol was never localized, the current values are ok. If the symbol was only localized once, that localization has the correct old global meaning. Otherwise each additional localization replaces the current one, since we walk the stack backwards. */ do parse_frame_ptr = ws_info.current_parse_frame_ptr repeat (parse_frame_ptr -> parse_frame.last_parse_frame_ptr) while (parse_frame_ptr ^= null); if parse_frame_ptr -> parse_frame.parse_frame_type = function_frame_type then do; lexed_function_bead_pointer = parse_frame_ptr -> parse_frame.lexed_function_bead_ptr; do local = 1 to lexed_function_bead_pointer -> lexed_function_bead.number_of_localized_symbols; symbol_pointer = lexed_function_bead_pointer -> lexed_function_bead.localized_symbols (local); if symbol_pointer ^= null then if symbol_pointer -> general_bead.symbol /* filter localized system variables */ then do global = 1 to total_symbols; if symbol_pointer = save_frame.symbol_pointer (global) then do; call process_symbol; go to found_symbol; end; end; /* if it falls thru the do-loop, its an error; a localized symbol which has no correspondence in the symbol table, but who cares? */ found_symbol: end; end; else if parse_frame_ptr -> parse_frame.parse_frame_type = save_frame_type then call apl_system_error_ (apl_error_table_$random_system_error); end; save_frame.last_frame_pointer = ws_info.current_parse_frame_ptr; save_frame.saved_symbol_count = total_symbols; save_frame.frame_type = save_frame_type; ws_info.current_parse_frame_ptr = save_frame_pointer; return; process_symbol: procedure; /* Since the current meaning (symbol_bead.meaning_pointer) can point to the same bead as the old meaning ptr, we must be careful with the reference counts. We will increment the reference count first, then decrement it. Make the current meaning be the more global meaning. */ call increment_reference_count (parse_frame_ptr -> parse_frame.old_meaning_ptrs (local)); call decrement_reference_count (save_frame.symbol_pointer (global) -> symbol_bead.meaning_pointer); save_frame.symbol_pointer (global) -> symbol_bead.meaning_pointer = parse_frame_ptr -> parse_frame.old_meaning_ptrs (local); /* Remember where we got this pointer to the global meaning, so we can change it if destroy_save_frame_update_ is called. */ save_frame.global_meaning_pointer_pointer (global) = addr (parse_frame_ptr -> parse_frame.old_meaning_ptrs (local)); end process_symbol; /* Entry to restore meanings to old localized meanings. */ apl_destroy_save_frame_: entry; modification = "0"b; go to destroy; /* Entry to replace global meaning with present meaning, and then revert to old local meanings. */ apl_destroy_save_frame_update_: entry; modification = "1"b; destroy: save_frame_pointer = ws_info.current_parse_frame_ptr; if save_frame.frame_type ^= save_frame_type then return; do global = 1 to save_frame.saved_symbol_count; sp = save_frame.symbol_pointer (global); mp = save_frame.saved_meaning_pointer (global); gmpp = save_frame.global_meaning_pointer_pointer (global); /* If requested, make global meaning be present meaning. There are two ways to do this, depending on whether the symbol was localized or not. */ if modification & gmpp = null then do; /* Case 1: Set global meaning from present meaning. Symbol was never localized. Therefore present meaning is correct, and all we have to do is flush the saved old "local" meaning. There is purposefully no code in this then-clause; the cases seem clearer that way. */ end; else do; /* Present meaning is not correct */ if modification & gmpp ^= null then do; /* Case 2: Set global meaning from present meaning. Symbol was localized. Therefore we have to set the oldest parse_frame.old_meaning_ptr (point to by gmpp), and relocalize the symbol. */ tp = sp -> symbol_bead.meaning_pointer; call increment_reference_count (tp); call decrement_reference_count (gmpp -> based_meaning_pointer); gmpp -> based_meaning_pointer = tp; end; /* Case 2 (rest) and Case 3: Global meaning OK now. Restore local meaning as shown by save_frame. */ call increment_reference_count (mp); call decrement_reference_count (sp -> symbol_bead.meaning_pointer); sp -> symbol_bead.meaning_pointer = mp; end; /* Now throw away pointers in save frame */ call decrement_reference_count (mp); call decrement_reference_count (sp); end; ws_info.current_parse_frame_ptr = save_frame.last_frame_pointer; return; increment_reference_count: procedure (pointer); declare pointer pointer unaligned parameter; if pointer = null then return; pointer -> general_bead.reference_count = pointer -> general_bead.reference_count + 1; end increment_reference_count; decrement_reference_count: procedure (pointer); declare pointer pointer unaligned parameter; if pointer = null then return; pointer -> general_bead.reference_count = pointer -> general_bead.reference_count - 1; if pointer -> general_bead.reference_count <= 0 then call apl_free_bead_ (pointer); end decrement_reference_count; /* automatic */ declare (parse_frame_ptr, lexed_function_bead_pointer, symbol_pointer, mp, sp, gmpp, tp) pointer unaligned; declare ( bucket_number, local, global, total_symbols, pointers, source_length based ) fixed binary (24) aligned; declare modification bit (1) aligned; /* based */ declare based_meaning_pointer pointer unaligned based; /* builtins */ declare (addr, divide, fixed, null, rel, size) builtin; /* external static */ declare (apl_error_table_$cant_push_save_frame, apl_error_table_$random_system_error) fixed binary (35) aligned external static; /* entries */ declare apl_system_error_ entry (fixed binary (35)); declare apl_free_bead_ entry (pointer unaligned); /* include files */ %include apl_number_data; %include "apl_ws_info"; %include "apl_bead_format"; %include "apl_symbol_bead"; %include "apl_lexed_function_bead"; %include "apl_parse_frame"; %include "apl_save_frame"; %include "apl_symbol_table"; %include "apl_operator_bead"; end /* apl_create_save_frame_ */;  apl_create_workspace_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 19368 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_create_workspace_: procedure (); /* * this routine is called when apl is invoked to set up and clear the workspace * * written 73.7.31 by DAM * modified 8/25/73 by DAM for version 3 workspace format * modified 9/15/73 by DAM to remove apl_ws_ptr_ - thus exorcising the curse of compatibility * modified 12/06/73 by PG for apl_segment_manager_ * modified July 1974 by G. Gordon Benedict to remove superfluous declaration of unique_chars_ * and to change names of some subroutines called. * Modified 761006 by PG to cleanup some initialization of variables. Modified 781208 by PG to use clock builtin. */ /* automatic */ declare parse_stack_ptr ptr; /* builtin */ declare (clock, string) builtin; /* entries */ declare apl_segment_manager_$get entry () returns (pointer), hcs_$set_max_length_seg entry (pointer, fixed bin (18), fixed bin (35)), apl_initialize_storage_ entry, apl_clear_workspace_ entry; /* program */ parse_stack_ptr = apl_segment_manager_$get (); /* set a max length on this segment, which will contain the parse stack, to insure that when we have 256K segments an out-of-bounds fault will occur, rather than a wrap-around, in certain depth errors */ call hcs_$set_max_length_seg (parse_stack_ptr, 65536, (0)); apl_static_$ws_info_ptr.static_ws_info_ptr, ws_info_ptr = parse_stack_ptr; ws_info.time_invoked = clock (); ws_info.version_number = 3; string (ws_info.switches) = ""b; ws_info.signoff_lock = ""; ws_info.vcpu_time = 0; call apl_initialize_storage_ (); call apl_clear_workspace_ (); return; /* include files */ %include apl_ws_info; %include apl_number_data; end /* apl_create_workspace_ */;  apl_date_time_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 20187 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3 */ apl_date_time_: procedure (P_time) returns (char (17)); /* program to format date/time into APL/360 format. Written by PG on 740208 Modified 800116 by PG to use pictures, and put in colons (like VS APL) */ /* parameters */ declare P_time fixed binary (71) parameter; /* entries */ declare decode_clock_value_ entry (fixed bin (71), fixed bin (17), fixed bin (17), fixed bin (17), fixed bin (71), fixed bin (17), char (3) aligned); /* automatic */ declare (day_of_month, day_of_week, hour, minute, month, second, seconds_since_midnight, year) fixed bin (17), time_of_day fixed bin (71), time_zone char (3) aligned; declare 1 apl_time unaligned, 2 hour picture "99", 2 colon1 char (1), 2 minute picture "99", 2 colon2 char (1), 2 second picture "99", 2 space char (1), 2 month picture "99", 2 slash1 char (1), 2 day picture "99", 2 slash2 char (1), 2 year picture "99"; /* builtin */ declare (divide, float, max, string) builtin; /* APL time format: "HH:MM:SS MM/DD/YY" */ /* program */ call decode_clock_value_ (P_time, month, day_of_month, year, time_of_day, day_of_week, time_zone); string (apl_time) = " : : / /"; seconds_since_midnight = float (time_of_day, 63) / 1e6; /* convert microseconds to seconds */ hour = divide (seconds_since_midnight, 3600, 16, 0); minute = divide (seconds_since_midnight - 3600 * hour, 60, 16, 0); second = seconds_since_midnight - 3600 * hour - 60 * minute; apl_time.hour = hour; apl_time.minute = minute; apl_time.second = second; apl_time.month = month; apl_time.day = day_of_month; apl_time.year = max (year - 1900, 0); /* don't bomb if year is 0 */ return (string (apl_time)); end /* apl_date_time_ */;  apl_decode_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 83583 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_decode_: procedure (operators_argument); /* * this module implements the APL _| operator * * written 73.7.31 by DAM * Modified 740717 by PG for new value bead dcl & error marker. * Modified 760903 by PG to protect result on value stack. Modified 770927 by PG to fix bug 250 (scalar_|matrix failed because rhorho of result computed incorrectly). */ dcl left_vb pointer, /* -> value bead for left operand */ left pointer, /* -> value array of left operand */ right_vb pointer, /* -> value bead for right operand */ right pointer, /* -> value array of right operand */ result_vb pointer, /* -> value bead on stack in which result is constructed */ result pointer, /* -> value array on stack in which result is constructed */ data_elements fixed bin(21), /* number of elements in the result */ left_walk_pos fixed bin(21), /* position in walking from row to row of left operand */ left_walk_bump fixed bin(21), /* increment to left_walk_pos to get to next row */ right_walk_pos fixed bin(21), /* position in walking from column to column of right operand */ right_walk_size fixed bin(21), /* right_walk_pos is bumped by 1 until it reaches this value */ add_up float, /* temporary for adding up one element of the result */ left_pos fixed bin(21), /* position of current element in current row of left operand */ left_inc fixed bin(21), /* amount to bump left_pos to get to next element, same row */ right_pos fixed bin(21), /* position of current element in current column of right operand */ right_inc fixed bin(21), /* amount to bump right_pos by to get next element, same column */ add_up_length fixed bin(21), /* length of row/column which is added up */ result_pos fixed bin(21), /* position in result of element currently being computed */ factor float, /* current power of radix, used in adding_up loop */ add_up_count fixed bin(21), /* counter to count number of times around adding_up loop */ n_words fixed bin (19), /* number of words of stack space required to hold the result */ final_result_vb pointer, /* -> value bead where result is finally put on stack */ final_result pointer; /* -> array for ditto */ dcl (i, j) fixed bin; /* do-loop temporaries */ dcl (addr, addrel, size, rel, substr, string, max) builtin; %include apl_number_data; %include apl_operators_argument; %include apl_value_bead; %include apl_bead_format; %include apl_operator_bead; %include apl_ws_info; /* pick up pointers to arguments */ left_vb = operands(1).value; left = left_vb -> value_bead.data_pointer; if ^left_vb -> value_bead.numeric_value then go to domain_error_left; right_vb = operands(2).value; right = right_vb -> value_bead.data_pointer; if ^right_vb -> value_bead.numeric_value then go to domain_error_right; /* determine conformability and set up control variables according to which case */ if left_vb -> value_bead.total_data_elements = 1 then do; /* effective scalar */ left_walk_bump = 1; left_inc = 0; if right_vb -> value_bead.total_data_elements = 1 then do; /* effective scalar */ add_up_length = 1; right_inc = 0; right_walk_size = 1; end; else do; add_up_length = right_vb -> value_bead.rho(1); right_inc = 1; do i = 2 to right_vb -> value_bead.rhorho; right_inc = right_inc * right_vb -> value_bead.rho(i); end; right_walk_size = right_inc; end; end; else if right_vb -> value_bead.total_data_elements = 1 then do; right_inc = 0; right_walk_size = 1; left_walk_bump = left_vb -> value_bead.rho(left_vb -> value_bead.rhorho); add_up_length = left_walk_bump; left_inc = 1; end; else if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) = right_vb -> value_bead.rho(1) then do; left_walk_bump = left_vb -> value_bead.rho(left_vb -> value_bead.rhorho); left_inc = 1; right_inc = 1; do i = 2 to right_vb -> value_bead.rhorho; right_inc = right_inc * right_vb -> value_bead.rho(i); end; right_walk_size = right_inc; add_up_length = left_walk_bump; end; else if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) = 1 then do; right_inc = 1; do i = 2 to right_vb -> value_bead.rhorho; right_inc = right_inc * right_vb -> value_bead.rho(i); end; right_walk_size = right_inc; add_up_length = right_vb -> value_bead.rho(1); left_inc = 0; left_walk_bump = 1; end; else if right_vb -> value_bead.rho(1) = 1 then do; left_walk_bump = left_vb -> value_bead.rho(left_vb -> value_bead.rhorho); right_walk_size = right_vb -> value_bead.total_data_elements; left_inc = 1; right_inc = 0; add_up_length = left_walk_bump; end; else go to length_error; /* I guess */ /* compute size of result */ data_elements = 1; if left_vb -> value_bead.total_data_elements ^= 1 then do i = 1 by 1 while (i < left_vb -> value_bead.rhorho); data_elements = data_elements * left_vb -> value_bead.rho(i); end; if right_vb -> value_bead.total_data_elements ^= 1 then do i = 2 to right_vb -> value_bead.rhorho; data_elements = data_elements * right_vb -> value_bead.rho(i); end; /* push result onto stack */ number_of_dimensions = max (left_vb -> value_bead.rhorho - 1, 0) + max (right_vb -> value_bead.rhorho - 1, 0); n_words = size (value_bead) + size (numeric_datum) + 1; result_vb = apl_push_stack_ (n_words); string(result_vb -> value_bead.type) = string(left_vb -> value_bead.type) & string(right_vb -> value_bead.type) & integral_value_type; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result = addr(result_vb -> value_bead.rho(result_vb -> value_bead.rhorho+1)); if substr(rel(result), 18, 1) then result = addrel(result, 1); result_vb -> value_bead.data_pointer = result; /* construct rho of result as concatenation of rhos of operands */ do i = 1 by 1 while (i < left_vb -> value_bead.rhorho); result_vb -> value_bead.rho(i) = left_vb -> value_bead.rho(i); end; do j = i by 1 while (j <= result_vb -> value_bead.rhorho); result_vb -> value_bead.rho(j) = right_vb -> value_bead.rho(j-i+2); end; /* do it */ result_pos = 0; do left_walk_pos = 0 by left_walk_bump while(left_walk_pos < left_vb -> value_bead.total_data_elements); do right_walk_pos = 0 by 1 while (right_walk_pos < right_walk_size); add_up = 0; factor = 1; left_pos = left_walk_pos + add_up_length*left_inc; /* work from right to left */ right_pos = right_walk_pos + add_up_length*right_inc; /* .. */ do add_up_count = 0 by 1 while(add_up_count < add_up_length); right_pos = right_pos - right_inc; add_up = add_up + factor * right -> numeric_datum(right_pos); left_pos = left_pos - left_inc; factor = factor * left -> numeric_datum(left_pos); end; result -> numeric_datum(result_pos) = add_up; result_pos = result_pos + 1; end; end; if result_pos = 0 then result -> numeric_datum(0) = 0; /* special kludge for (iota 0) _| iota 0 */ /* copy result down on stack in the usual way */ if operands(2).on_stack then value_stack_ptr = right_vb; else if operands(1).on_stack then value_stack_ptr = left_vb; else do; /* result is already in right place */ operators_argument.result = result_vb; return; end; /* n_words is already set */ final_result_vb = apl_push_stack_ (n_words); string(final_result_vb -> value_bead.type) = string(result_vb -> value_bead.type); final_result_vb -> value_bead.total_data_elements = result_vb -> value_bead.total_data_elements; final_result_vb -> value_bead.rhorho = result_vb -> value_bead.rhorho; if result_vb -> value_bead.rhorho > 0 /* zero-length arrays are illegal in PL/I */ then final_result_vb -> value_bead.rho (*) = result_vb -> value_bead.rho (*); final_result = addr(final_result_vb -> value_bead.rho(final_result_vb -> value_bead.rhorho+1)); if substr(rel(final_result), 18, 1) then final_result = addrel(final_result, 1); final_result_vb -> value_bead.data_pointer = final_result; final_result -> numeric_datum(*) = result -> numeric_datum(*); operators_argument.result = final_result_vb; return; domain_error_right: operators_argument.where_error = operators_argument.where_error - 2; domain_error_left: operators_argument.where_error = operators_argument.where_error + 1; operators_argument.error_code = apl_error_table_$domain; return; length_error: operators_argument.error_code = apl_error_table_$length; return; dcl (apl_error_table_$domain, apl_error_table_$length) fixed bin(35) external; %include apl_push_stack_fcn; end /* apl_decode_ */ ;  apl_dim_.alm 11/29/83 1637.3r w 11/29/83 1346.2 11169 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " This is the outer module transfer vector for the apl_dim_ module. " Modified 790614 by PG to flush setsize and getsize entries. entry apl_dim_module apl_dim_module: tra *+1,6 tra apl_dim_util_$apl_dim_attach tra apl_dim_util_$apl_dim_detach tra apl_dim_read_$apl_dim_read_ tra apl_dim_write_$apl_dim_write_ tra apl_dim_util_$apl_dim_abort tra apl_dim_util_$apl_dim_order tra apl_dim_util_$apl_dim_resetread tra apl_dim_util_$apl_dim_resetwrite tra ios_$no_entry " setsize tra ios_$no_entry " getsize tra ios_$no_entry " setdelim tra ios_$no_entry " getdelim tra ios_$no_entry tra ios_$no_entry tra apl_dim_util_$apl_dim_changemode tra ios_$no_entry tra ios_$no_entry tra ios_$no_entry tra ios_$no_entry tra ios_$no_entry tra ios_$no_entry end  apl_dim_canonicalize_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 70452 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Input canonicalization program for APL Device Interface Module. Paul Green, July 1973 */ /* Modified 741018 by PG for variable tab width. */ /* Modified 780505 by William York to allow erasing of illegal characters. */ /* format: style3 */ apl_dim_canonicalize_: procedure (sdb_ptr, charp, lowi, n); dcl (col, ncol, sos, lowi, i, j, k, save, tempn) fixed bin (18); dcl pair_index fixed bin, compressing bit (1) aligned, pair char (2) aligned, move fixed bin (3), tchar bit (9), (charp, tempp) ptr; dcl 1 temp (n) aligned, /* temp array of chars and their columns */ 2 col unal fixed bin (17), /* column where char starts */ 2 erase bit (1) unaligned, /* if erase char */ 2 kill bit (1) unaligned, /* kill char switch */ 2 stop bit (1) unaligned, /* end-of-line switch */ 2 error bit (1) unaligned, /* character error here */ 2 pad bit (5) unaligned, 2 char bit (9) unaligned; dcl ccol fixed bin (17); dcl tempa (1) fixed bin based (tempp) aligned; /* overlay for temp, used in sort */ dcl 1 char based aligned, /* to reference input string */ 2 a (0:1) bit (9) unaligned; /* builtins */ dcl (addr, binary, divide, index, mod, null, substr, unspec) builtin; /* include files */ %include apl_dim_sdb; %include apl_dim_table; /* program */ compressing = compression_in_ptr ^= null; tempp = addr (temp); col = 1; /* first copy chars into stack array */ j = 1; /* computing column position */ do i = lowi to lowi + n - 1; tempa (j) = 0; tchar = charp -> char.a (i); /* copy char */ if tchar = "100011000"b /* if special erase */ then do; temp (j).char = "000100011"b; /* erase char */ temp (j).erase = "1"b; /* erase flag on */ end; else if tchar = "100011001"b /* if kill */ then do; temp (j).char = "001000000"b; /* store real kill char */ temp (j).kill = "1"b; /* set switch */ end; else if tchar = "100011010"b /* if character error */ then do; temp (j).char = "011000010"b; /* universal ignored, spacing char */ temp (j).error = "1"b; end; else do; temp (j).char = tchar; end; temp (j).col = col; /* store column where char starts */ move = binary (type (binary (temp (j).char, 9)).move, 3); /* get movement code */ if move = 0 /* +1 (normal) */ then do; col = col + 1; end; else if move = 3 /* tab */ then do; col = col + stream_data_block.tab_width - mod (col, stream_data_block.tab_width); end; else if move = 2 /* bs */ then do; j = j - 1; /* erase from temp array */ if col > 1 /* and backup col */ then col = col - 1; end; else if move = 4 /* cr */ then do; j = j - 1; /* don't keep it */ col = 1; end; else if move = 5 /* nl */ then if tchar = "011000000"b /* QLineFeed */ then temp (j).stop = "1"b; /* force end-of-line at this column */ else do; temp (j).col = col + 250; /* nl is like a big barrier */ col = col + 500; end; j = j + 1; end; tempn = j - 1; /* length of temp array */ do i = tempn by -1 to 2; /* sort */ if tempa (i) < tempa (i - 1) /* if inversion */ then do; save = tempa (i - 1); /* save char out of place */ do j = i to tempn while (tempa (j) < save); /* search for correct place */ tempa (j - 1) = tempa (j); /* sliding other chars */ end; tempa (j - 1) = save; /* place found, insert */ end; end; sos = 1; /* first character is significant */ tempa (tempn + 1) = 0; do i = 1 by 1 while (i <= tempn); /* process erase kill chars */ shortlp: if temp (i).char = "000100000"b /* if blank */ then if temp (i + 1).col = temp (i).col /* and at same col with next char */ then do; do k = i + 1 to tempn; /* delete blank */ tempa (k - 1) = tempa (k); end; tempn = tempn - 1; go to shortlp; end; if temp (i).erase /* only recognize this erase char */ then do; do k = i - 1 by -1 to sos while (temp (k).erase); /* find last existing graphic */ end; if k >= sos /* if something to erase */ then do; if type (binary (temp (k).char, 9)).white /* if erasing white space */ then do j = k by -1 to 1 while (type (binary (temp (j).char, 9)).white); tempa (j) = -1;/* turn the erase flag on */ end; else do; ccol = temp (k).col; do j = k by -1 to 1 while (temp (j).col = ccol); /* else erase all in col */ tempa (j) = -1; /* set the erase bit on */ end; end; end; else sos = i + 1; /* only suceding columns are significant */ end; else if temp (i).kill /* if kill char */ then do; if temp (i + 1).erase /* if next char is erase */ then if temp (i + 1).col = temp (i).col /* and at same col */ then go to loop; /* do not kill */ sos = i + 1; /* kill, first significant column is the next column */ end; else if temp (i).stop then do; tempn = i - 1; /* delete LineFeed and rest of line */ do k = i - 1 by -1 while (temp (k).col = temp (i).col); /* and everything in same col */ tempn = tempn - 1; end; end; loop: end; j = lowi; /* copy back into string, inserting bs */ col = 1; /* no initial bs */ do i = sos to tempn; if temp (i).erase then go to skip; ncol = temp (i).col; if ncol < col /* if backed up */ then do; if temp (i).char = temp (i - 1).char then go to skip; /* eliminate duplicate chars in same column */ if compressing then do; unspec (substr (pair, 1, 1)) = temp (i - 1).char; unspec (substr (pair, 2, 1)) = temp (i).char; pair_index = index (compression_string, pair); if 2 * divide (pair_index, 2, 17, 0) = pair_index /* if not found or bad match (even index) */ then if stream_data_block.character_error_index < 0 then do; if pair = "ot" & temp (i + 1).char = "001110101"b /* "u" */ & temp (i).col = temp (i + 1).col then stream_data_block.escape_out_seen = "1"b; else stream_data_block.character_error_index = j - 1 - lowi; /* j-1-lowi chars are good */ pair_index = 0; end; else pair_index = 0; else pair_index = divide (pair_index, 2, 17, 0) + 1; if pair_index ^= 0 then do; temp (i).char = output_character (pair_index); j = j - 1; /* wipe out previous char */ end; end; else do; charp -> char.a (j) = "000001000"b; /* insert backspace */ j = j + 1; end; end; if temp (i).error /* character error */ then if stream_data_block.character_error_index < 0 then stream_data_block.character_error_index = j - lowi; charp -> char.a (j) = temp (i).char; /* move char */ j = j + 1; col = ncol; /* remember col */ if type (binary (temp (i).char, 9)).move = "0"b /* if normal +1 char */ then col = col + 1; /* then move ahead 1 */ skip: end; n = j - lowi; /* return new n (might be less) */ return; end /* apl_dim_canonicalize_ */;  apl_dim_read_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 129447 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Read portion of the APL Device Interface Module. Stolen from the "code_converter" module (which was stolen from hardcore TTYDIM) by Paul Green, July, 1973. */ /* Modified 740530 by PG to add tabsin mode to control changing spaces to tabs on input */ /* Modified 741018 by PG for variable tab width. */ /* Modified 780503 by William York to allow erasing of illegal characters to work. */ /* Modified 781208 by PG to switch to clock builtin */ /* Modified 790614 by PG use iox_-style calls. */ /* Modified 790910 by PG to fix 295 (quit-editing w/o BS or CR left in LF) */ /* format: style3 */ apl_dim_read_: procedure (sdb_ptr, readp, offset, nelem, nelemt, bv_status); /* parameters */ dcl ( readp ptr, /* ptr to caller's buffer */ offset fixed bin, /* offset in caller's buffer */ nelem fixed bin (21), /* number of elements desired by caller */ nelemt fixed bin (21), /* number of elements actually transmitted */ bv_status bit (72) aligned /* I/O system status */ ) parameter; /* automatic */ dcl (col, number_of_spaces, old_read_back_state, normal_read_n_transmitted, line, toffset, act, move, c, i, ini, outi, outimax, sum, tpini) fixed bin (21), (outp, rbufp) ptr, temp_ptr ptr, inchar bit (9), shift bit (2), (oneshift, pass2, prefsw, target_eof) bit (1), real_time fixed bin (71); /* entries */ dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)), apl_dim_canonicalize_ entry (ptr, ptr, fixed bin (21), fixed bin (21)); /* based */ declare based_string char (nelemt) based; declare char_array (0:1044479) char (1) unaligned based; dcl 1 char based (rbufp) aligned, /* to ref strings */ 2 a (0:1) bit (9) unaligned; /* builtins */ declare (addr, binary, bit, clock, fixed, hbound, length, mod, null, substr) builtin; /* conditions */ declare apl_quit_ condition; /* named constants (internal static initial) */ declare character_error_message char (11) internal static options (constant) initial ("char error "); /* include files */ %include apl_dim_sdb; %include apl_dim_table; /* program */ begin: oneshift, pass2, prefsw, target_eof = "0"b; bv_status = ""b; if rawim then do; real_time = clock (); temp_ptr = addr (readp -> char_array (offset)); call iox_$get_line (stream_data_block.device_iocb_ptr, temp_ptr, nelem, nelemt, status_code); bv_status = status; keying_time = keying_time + clock () - real_time; return; end; ini = read_offset; outimax = offset + nelem; outp = readp; nelemt = 0; device_ptr = device_info_ptr; /* get pointer to device info table */ conversion_ptr = conv_tab_ptr; /* pointer to conversion tables */ rbufp = addr (canonicalization_buffer); if ini < 0 then do; call getmore; ini = 0; end; /* Now that the characters have been read, begin processing them. If no carriage return or backspace was typed, canonicalization is done by this program; otherwise all canonicalization is done by "apl_dim_canonicalize_". */ tpini = ini; toffset = offset; again: outi = toffset; shift = actshift; col = actcol; line = actline; character_error_index = -1; iloop: if outimax <= outi /* if no more space */ then go to rdone; /* quit right now */ if ini >= inimax then call getmore; if shift then substr (char.a (ini), 3, 1) = shift; /* if shifting console, add present shift state */ inchar = in (binary (char.a (ini), 9)); /* convert char to ascii */ ini = ini + 1; /* bump input index */ haveascii: if inchar & "100000000"b /* if special control char */ then do; i = binary (substr (inchar, 3, 7), 7); /* get action code */ if i = 0 then shift = "01"b; /* go to lower case */ else if i = 1 /* go to upper case */ then shift = "10"b; else if i = 2 /* one char shift */ then oneshift = "1"b; else if i = 3 /* pref */ then do; if ini >= inimax then call getmore; if shift then substr (char.a (ini), 3, 1) = shift; /* add shift bit */ inchar = char.a (ini) & "001111111"b; /* get raw code */ ini = ini + 1; prefsw = "1"b; /* search should look for prefix def. */ prefesc: do i = 0 to hbound (escape (*), 1); /* search prefix/escape table */ if inchar = escape (i).inchar /* if match */ then if escape (i).prefix = prefsw /* and right kind */ then do; inchar = escape (i).outchar; /* get results */ if escape (i).conceal /* if char is to be concealed */ then go to store; /* then don't look at it */ else go to haveascii; end; end; if prefsw /* if not found in table */ then go to iloop; /* ignore pref and char */ end; else if i = 5 /* character error */ then do; if pass2 /* if 2nd pass required */ then do; inchar = "100011010"b; /* tell 2nd pass to do it */ go to store; end; if character_error_index < 0 /* if no errors yet */ then character_error_index = outi - toffset; go to bad_char_exit; end; go to iloop; end; bad_char_exit: if inchar & "100000000"b then act = 0; else act = binary (type (binary (inchar, 9)).action, 4); /* if normal char */ if inchar & "100000000"b then move = 0; else move = binary (type (binary (inchar, 9)).move, 3); /* get action and movement code */ if (move = 2) | (move = 4) | (act = 5) /* bs, cr or quit-edit linefeed...second pass required */ then if ^pass2 /* if not already set */ then if conm /* and in canonical mode */ then do; pass2 = "1"b; ini = tpini; go to again; /* start conversion over */ end; go to new_col (move); /* switch on column move code */ new_col (0): col = col + 1; /* normal +1 movement */ go to end_col; new_col (1): go to end_col; /* no movement */ new_col (2): if col > 0 then col = col - 1; /* backspace */ go to end_col; new_col (3): /* tab */ if stream_data_block.tab_width < 2 /* turned off */ then number_of_spaces = 1; /* treat like SP */ else number_of_spaces = stream_data_block.tab_width - mod (col, stream_data_block.tab_width); col = col + number_of_spaces; if ^tabsin_mode then do; substr (outp -> based_string, outi + 1, number_of_spaces) = " "; outi = outi + number_of_spaces; go to iloop; end; go to end_col; new_col (4): col = 0; /* carriage return */ go to end_col; new_col (5): col = 0; line = line + 1; /* new line */ go to end_col; new_col (6): col = 0; line = 0; /* new page */ go to end_col; new_col (7): line = line + 10 - mod (line, 10); /* vertical tab */ end_col: if act = 0 /* normal */ then do; if oneshift /* if char to be shifted */ then do; substr (inchar, 3, 1) = ^substr (inchar, 3, 1); /* complement 100 bit */ oneshift = "0"b; end; store: outp -> char.a (outi) = inchar; /* store ascii char */ outi = outi + 1; go to iloop; end; else if act = 2 /* if erase char */ then do; if ^erklm /* if not in erase kill mode */ then go to store; /* then store erase char */ if pass2 /* if second pass required, don't erase now */ then do; inchar = "100011000"b; /* tell second pass to erase */ go to store; end; if outi > toffset /* if something to erase */ then do; if character_error_index = outi - toffset - 1 /* if erasing bad char */ then character_error_index = -1; outi = outi - 1; if type (binary (outp -> char.a (outi), 9)).white /* if prev char white */ then do outi = outi by -1 to offset + 1 while (type (binary (outp -> char.a (outi - 1), 9)).white); /* erase all white space */ end; end; end; else if act = 3 /* kill */ then do; if ^erklm /* if not in erase kill mode */ then go to store; /* then store kill char */ if pass2 /* if second pass required */ then do; inchar = "100011001"b; /* fake kill char */ go to store; end; outi = toffset; /* reset output string */ character_error_index = -1; /* reset any character errors */ end; else if act = 4 /* read delimiter */ then do; if conm then if type (binary (inchar, 9)).white /* if in canonical mode */ then do outi = outi by -1 to toffset + 1 while (type (binary (outp -> char.a (outi - 1), 9)).white); /* erase all white space */ end; outp -> char.a (outi) = inchar; /* store the new line */ outi = outi + 1; rdone: nelemt = outi - toffset; /* indicate length of returned string */ if pass2 /* if second pass required, do it */ then call apl_dim_canonicalize_ (sdb_ptr, outp, toffset, nelemt); nelemt = nelemt + toffset - offset; if ini < inimax then read_offset = ini; /* more characters to be processed */ else do; read_offset = -1; /* read-ahead buffer is empty */ if target_eof then do; status = ""b; status_bits.end_of_logical_data = "1"b; bv_status = status; /* tell caller about eof */ end; end; /* Copy unprocessed portion of canonicalization_buffer down to beginning. While this copy is proceeding, no QUITs may occur. */ if read_offset ^= -1 then do; inimax = inimax - read_offset; substr (canonicalization_buffer, 1, inimax) = substr (canonicalization_buffer, read_offset + 1, inimax); read_offset = 0; /* zero-origin */ canonicalization_index = inimax + 1; /* inimax is zero-origin, canon is 1-origin */ end; else canonicalization_index = 1; actshift = shift; actcol = col; actline = line; if stream_data_block.character_error_index >= 0 then do; if stream_data_block.escape_out_seen then do; stream_data_block.escape_out_seen = "0"b; stream_data_block.character_error_index = -1; signal apl_quit_; return; end; call iox_$control (stream_data_block.iocb_ptr, "resetread", null, status_code); call iox_$put_chars (stream_data_block.iocb_ptr, addr (character_error_message), length (character_error_message), status_code); old_read_back_state = stream_data_block.read_back; stream_data_block.read_back = read_back_output; if stream_data_block.character_error_index > 0 then call iox_$put_chars (stream_data_block.iocb_ptr, addr (outp -> char_array (toffset)), (stream_data_block.character_error_index), status_code); stream_data_block.character_error_index = -1; stream_data_block.read_back = old_read_back_state; go to begin; end; return; end; else if act = 1 /* esc char */ then do; if ^escm /* if not in escape mode, store char */ then go to store; c = 0; /* count for oct esc */ sum = 0; /* for oct to bin conversion */ escl: call skip_specials; if (inchar & "111111000"b) = "000110000"b /* if octal number */ then do; sum = sum * 8 + binary (inchar, 9) - 48; /* add into sum */ c = c + 1; if c < 3 /* if done */ then go to escl; shortn: inchar = bit (binary (sum, 9), 9); /* store converted number */ go to store; end; if c > 0 /* if started as octal, then quit */ then do; ini = ini - 1; /* fix to pickup non number again */ go to shortn; end; prefsw = "0"b; /* if not octal esc, lookup in table */ go to prefesc; end; else if act = 5 /* canonicalization break */ then do; outp -> char.a (outi) = inchar; /* store the break */ outi = outi + 1; if pass2 then do; nelemt = outi - toffset; call apl_dim_canonicalize_ (sdb_ptr, outp, toffset, nelemt); outi = toffset + nelemt; pass2 = "0"b; end; tpini = ini; toffset = outi; end; go to iloop; main_program_return: return; /* INTERNAL PROCEDURES */ getmore: proc; /* get more characters to read */ if target_eof then go to rdone; real_time = clock (); status = ""b; call iox_$get_line (stream_data_block.device_iocb_ptr, addr (normal_read_buffer), length (normal_read_buffer), normal_read_n_transmitted, status_code); keying_time = keying_time + clock () - real_time; if status_code ^= 0 then do; bv_status = status; go to main_program_return; end; if actshift then actshift = "01"b; /* all input begins in lower case; as does each line of output. (nl is in lower case!) */ /* if not in read_back_output or read_back_input mode, then column is ok. Otherwise we are guaranteed to be in column 0. */ if stream_data_block.read_back ^= read_back_input then actcol = 0; if normal_read_n_transmitted = 0 then do; target_eof = "1"b; go to rdone; end; if end_of_logical_data then target_eof = "1"b; status = ""b; if canonicalization_index <= 0 /* AAARRRGGGHHH!!! */ then canonicalization_index = 1; /* fix it quick... */ substr (canonicalization_buffer, canonicalization_index, normal_read_n_transmitted) = substr (normal_read_buffer, 1, normal_read_n_transmitted); canonicalization_index = canonicalization_index + normal_read_n_transmitted; inimax = canonicalization_index - 1; /* inimax is zero origin */ end getmore; skip_specials: proc; /* procedure to skip over "special" chars, setting shift bits */ loop: if ini >= inimax then call getmore; /* first get the characters */ if shift then substr (char.a (ini), 3, 1) = shift; /* set shift bit */ inchar = in (binary (char.a (ini), 9)); /* get char */ ini = ini + 1; if inchar & "100000000"b /* if special */ then do; i = binary (substr (inchar, 3, 7), 7); if i = 0 then shift = "01"b; /* go to lower case */ else if i = 1 then shift = "10"b; /* go to upper case */ go to loop; /* check next char */ end; return; /* with variables set */ end skip_specials; end /* apl_dim_read_ */;  apl_dim_select_table_.pl1 11/29/83 1637.3r w 11/29/83 1346.2 27243 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3 */ apl_dim_select_table_: procedure (P_terminal_type, P_table_ptr, P_default_table_used); /* parameters */ declare ( P_terminal_type char (*), P_table_ptr ptr, P_default_table_used bit (1) aligned ) parameter; /* automatic */ declare table_ptr ptr, terminal_type char (32); /* builtins */ declare addr builtin; /* external static */ declare ( apl_dim_tables_$apl_2741, apl_dim_tables_$apl_correspondence_2741, apl_dim_tables_$apl_1030, apl_dim_tables_$apl_4013, apl_dim_tables_$apl_teletype, apl_dim_tables_$apl_ascii, apl_dim_tables_$apl_tn300, apl_dim_tables_$apl_ascii_display, apl_dim_tables_$apl_typepaired, apl_dim_tables_$apl_bitpaired, apl_dim_tables_$apl_teleray11, apl_dim_tables_$apl_la36, apl_dim_tables_$apl_sara, apl_dim_tables_$apl_aj510, apl_dim_tables_$apl_aj830 ) external static; /* program */ terminal_type = P_terminal_type; P_default_table_used = "0"b; if terminal_type = "1050" | terminal_type = "2741" then table_ptr = addr (apl_dim_tables_$apl_2741); else if terminal_type = "TTY33" | terminal_type = "TTY37" | terminal_type = "TTY38" then table_ptr = addr (apl_dim_tables_$apl_teletype); else if terminal_type = "ARDS" then table_ptr = addr (apl_dim_tables_$apl_ascii_display); else if terminal_type = "TN300" then table_ptr = addr (apl_dim_tables_$apl_tn300); else if terminal_type = "TEK4013" | terminal_type = "TEK4015" then table_ptr = addr (apl_dim_tables_$apl_4013); else if terminal_type = "CORR2741" then table_ptr = addr (apl_dim_tables_$apl_correspondence_2741); else if terminal_type = "1030" then table_ptr = addr (apl_dim_tables_$apl_1030); else if terminal_type = "TYPEPAIRED" then table_ptr = addr (apl_dim_tables_$apl_typepaired); else if terminal_type = "BITPAIRED" then table_ptr = addr (apl_dim_tables_$apl_bitpaired); else if terminal_type = "ASCII" then table_ptr = addr (apl_dim_tables_$apl_ascii); else if terminal_type = "TELERAY11" then table_ptr = addr (apl_dim_tables_$apl_teleray11); else if terminal_type = "LA36" then table_ptr = addr (apl_dim_tables_$apl_la36); else if terminal_type = "SARA" then table_ptr = addr (apl_dim_tables_$apl_sara); else if terminal_type = "AJ510" then table_ptr = addr (apl_dim_tables_$apl_aj510); else if (terminal_type = "AJ830") | (terminal_type = "AJ832") then table_ptr = addr (apl_dim_tables_$apl_aj830); else do; P_default_table_used = "1"b; table_ptr = addr (apl_dim_tables_$apl_ascii); end; P_table_ptr = table_ptr; return; end apl_dim_select_table_;  apl_dim_tables_.alm 11/29/83 1637.3rew 11/29/83 1346.2 366336 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " Conversion table for APL/Multics to 2741/1050. " PG 8/14/73. " Modified 740319 by PG for network_ascii table and fix a couple of bugs " Modified 740322 by PG to fix bugs in 4013 table " Modified 740327 by PG to add network 2741 table " Modified 741015 by PG to get network 2741 table to work " Modified 741031 by PG to fix bugs in overstrike conversion table. " Modified 741118 by PG to fix length of ASCII compression table. " Modified 760206 by PG to add Correspondence 2741 table. " Modified 760730 by PG to finally add bit-paired APL/ASCII table (CDI 1030). " Modified 770406 by PG to change graphics for left tack,right tack,diamond,and braces on 2741s. " Modified 770415 by PG to add cent-sign " Modified 780317 by PG to fix 317 (letter H going to "140 instead of "150 on Corr 2741), " and convert to ALM. " Modified 790320 by PG to add CommaHyphen to all tables, to delete NET2741 table, " and to add typepaired and bitpaired tables. " Modified 790910 by PG to add Teleray11 type, add 1200 baud delay values, " and to flush delays for TEK4013 now that TYPEPAIRED exists. " Modified 800129 by PG to add SARA, AJ510, AJ830. " Modified 800130 by PG to correct quit-editing string for TELERAY11, " AJ510, AJ830, and LA36. " NOTE WELL: The macro expander of ALM screws up if unbalanced parenthesis appear " in the comment field of any line passed to it. The symptom is that the macro " does not get expanded. This is disasterous for the tables! Please be careful! " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " MACROS " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " maclist object macro dev_info zero &1,&2 "conversion table offset,sequence table offset zero &3,&4 "compression_in table offset,compression_out table offset &end macro dev_info1 "graphic,shifter,quit_editing_allowed,linefeed_char_code,escape_char_code. vfd 1/&1,1/&2,1/&3,15/0,o9/&4,o9/&5 "delay,upper case,lower case,escape char device. vfd o9/&6,o9/&7,o9/&8,o9/&9 &end macro dev_info2 vfd 18/&1,18/&2 "default page length,default line length. &end macro delay &R&(&=&x,1&[ vfd &;,&]o18/&i&) &end macro tab9 &R&(&=&x,1&[ vfd &;,&]o9/&i&) &end macro tab6 &R&(&=&x,1&[ vfd &;,&]6/&i&) &end " name apl_dim_tables_ segdef apl_1030 segdef apl_2741 segdef apl_4013 segdef apl_aj510 segdef apl_aj830 segdef apl_ascii segdef apl_ascii_display segdef apl_bitpaired segdef apl_correspondence_2741 segdef apl_la36 segdef apl_sara segdef apl_teleray11 segdef apl_teletype segdef apl_tn300 segdef apl_typepaired equ graphic,1 equ not_graphic,0 equ shift_needed,1 equ no_shift_needed,0 equ quit_editing_allowed,1 equ quit_editing_not_allowed,0 " " Conversion table for EBCD 2741s. " apl_2741: dev_info convert_2741,sequence_2741,compression_in,compression_out aci "2741",32 dev_info1 not_graphic,shift_needed,quit_editing_allowed, 056,245,075,034,037,240 dev_info2 0,120 " page length,line length delay 0,0,0,0,0,0, " 110 nl addend,nl multiplier,tab addend,tab multiplier,bs num pads,np num pads 1616,71,1253,71,0,0, " 134 and 150 0,0,0,0,0,0, " 300 0,0,0,0,0,0 " 1200 dec 7 tab9 056,075,034,044,035,056,037 " LF IDLE UPSHIFT OR-SIGN BS LF DOWNSHIFT even " code conversion tables " " flags bit(2), 00=none,01=upper case,10=lower case,11=special. " data bit(7) value if flags ^= special,else " 0=ignore,1=mark error,2=octal escape,3=conditional NL,4-7 unused, " (>7)=(data-8)th entry in sequence table convert_2741: tab9 602,602,602,602,602,602,015,610 " apl/ascii to 2741 tab9 035,057,455,602,602,602,611,612 tab9 602,602,602,602,602,016,602,602 tab9 602,602,602,602,602,602,602,602 tab9 000,613,602,602,614,602,602,221 tab9 265,264,271,401,466,201,467,442 tab9 424,440,420,460,410,450,430,470 tab9 404,444,267,266,260,250,270,205 tab9 602,615,616,617,620,621,622,623 tab9 624,625,626,627,630,631,632,633 tab9 634,635,636,637,640,641,642,643 tab9 644,645,646,465,242,464,602,233 tab9 602,443,423,463,413,453,433,473 tab9 407,447,441,421,461,411,451,431 tab9 471,405,445,422,462,412,452,432 tab9 472,406,446,647,211,650,262,600 tab9 210,230,204,244,224,203,253,206 tab9 212,231,222,213,207,241,261,263 tab9 223,251,246,272,252,651,652,653 tab9 654,655,656,657,660,661,662,663 tab9 664,665,666,667,670,240,232,247 tab9 245,403,243,220,273,402,202,671 tab9 672,673,674,675,676,677,700,701 tab9 702,703,704,601,705,706,707,710 tab9 711,603,712,713,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 " flag bit(1), 0=normal,1=special. " data bit(8) value if normal,else 0=goto lower case,1=goto upper case,2=one char shift,3=prefix char, " 4=ignore it,5=character error tab9 040,053,255,251,070,161,171,150 " 2741 to apl/ascii tab9 064,155,165,144,404,006,025,404 tab9 062,153,163,142,060,404,404,404 tab9 066,157,167,146,401,010,404,404 tab9 061,152,057,141,071,162,172,151 tab9 065,156,166,145,404,012,300,011 tab9 063,154,164,143,135,133,054,056 tab9 067,160,170,147,404,404,403,404 tab9 040,055,256,205,202,077,207,214 tab9 200,174,210,213,404,006,025,404 tab9 253,047,212,220,204,404,404,404 tab9 201,211,246,137,404,010,404,400 tab9 245,215,134,252,203,250,222,247 tab9 075,221,224,206,404,012,300,011 tab9 074,216,176,217,051,050,073,072 tab9 076,052,223,254,404,404,403,404 " code movement table. " white bit(1), " red bit(1), " action bit(4), 0=none,1=esc,2=erase,3=kill,4=delim,5=break " move bit(3) 0=+1,1=0,2=bs,3=tab,4=cr,5=nl,6=np,7=vt tab9 001,001,001,001,001,001,001,001 tab9 402,403,445,007,006,404,201,201 tab9 001,001,001,001,001,001,001,001 tab9 000,000,001,001,000,001,000,001 tab9 400,000,000,020,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 030,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,401 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,010,020,000 tab9 000,000,030,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 055,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 " device movement table. " move bit(6) 0=+1,1=0,2=bs,3=tab,4=cr,5=nl,6=pref,7=LC,8=UC,9=QC tab6 0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,1,1,1 tab6 0,0,0,0,8,2,1,7,0,0,0,0,0,0,0,0,0,0,0,0,1,5,1,3 tab6 0,0,0,0,0,0,0,0,0,0,0,0,9,1,6,1,0,0,0,0,0,0,0,0 tab6 0,0,0,0,1,1,1,1,0,0,0,0,0,1,1,1,0,0,0,0,8,2,1,7 tab6 0,0,0,0,0,0,0,0,0,0,0,0,1,5,1,3,0,0,0,0,0,0,0,0 tab6 0,0,0,0,9,1,6,1 " escape/prefix table " prefix bit(1), 0=escape char,1=prefix char " conceal bit(1), 0=normal,1=do not process for special meaning " unused bit(7), " inchar bit(9), char after escape or prefix " outchar bit(9) sequence is translated to this character dec 4 " === (5-1) tab9 600,023,017 " brs tab9 600,123,017 " BRS tab9 600,043,016 " rrs tab9 600,143,016 " RRS tab9 200,245,245 " esc esc (diaresis) " output sequence table. " dcl 1 sequence_entry, " 2 count unal fixed bin(8), " 2 string char(sequence_entry.count) unaligned sequence_2741: tab9 2,034,037 " Bel -> upshift,downshift tab9 2,076,043 " RRS -> prefix A. tab9 2,076,023 " BRS -> prefix B. tab9 3,221,035,467 " ! tab9 3,422,035,442 " $ tab9 3,443,035,233 " A_ tab9 3,423,035,233 " B_ tab9 3,463,035,233 " C_ tab9 3,413,035,233 " D_ tab9 3,453,035,233 " E_ tab9 3,433,035,233 " F_ tab9 3,473,035,233 " G_ tab9 3,407,035,233 " H_ tab9 3,447,035,233 " I_ tab9 3,441,035,233 " J_ tab9 3,421,035,233 " K_ tab9 3,461,035,233 " L_ tab9 3,411,035,233 " M_ tab9 3,451,035,233 " N_ tab9 3,431,035,233 " O_ tab9 3,471,035,233 " P_ tab9 3,405,035,233 " Q_ tab9 3,445,035,233 " R_ tab9 3,422,035,233 " S_ tab9 3,462,035,233 " T_ tab9 3,412,035,233 " U_ tab9 3,452,035,233 " V_ tab9 3,432,035,233 " W_ tab9 3,472,035,233 " X_ tab9 3,406,035,233 " Y_ tab9 3,446,035,233 " Z_ tab9 3,465,035,241 " { [(os)_o tab9 3,464,035,241 " } ](os)_o tab9 3,244,035,262 " nand tab9 3,224,035,262 " nor tab9 3,231,035,201 " reverse first tab9 3,442,035,201 " -/ tab9 3,273,035,262 " locked function tab9 3,231,035,271 " logarithm tab9 3,231,035,211 " O| tab9 3,231,035,242 " transpose tab9 3,231,035,442 " /O tab9 3,273,035,211 " grade down tab9 3,207,035,211 " grade up tab9 3,263,035,241 " lamp tab9 3,261,035,221 " quote quad tab9 3,251,035,223 " i beam tab9 3,242,035,201 " -\ tab9 3,261,035,203 " domino tab9 3,260,035,270 " <> diamond tab9 3,424,035,233 " 0_ tab9 3,440,035,233 " 1_ tab9 3,420,035,233 " 2_ tab9 3,460,035,233 " 3_ tab9 3,410,035,233 " 4_ tab9 3,450,035,233 " 5_ tab9 3,430,035,233 " 6_ tab9 3,470,035,233 " 7_ tab9 3,404,035,233 " 8_ tab9 3,444,035,233 " 9_ tab9 3,207,035,233 " underlined delta tab9 3,223,035,241 " hydrant tab9 3,251,035,241 " thorn tab9 3,265,035,201 " (- left tack THIS ) FOR BSG! tab9 3,264,035,201 " BSG ( LEFT PARN! )- right tack tab9 3,056,075,075 " line feed,delay,delay tab9 3,246,035,211 " c| tab9 3,466,035,201 " ,- compression_in: dec 178 " 178 characters in table tab9 047,056,057,163 " ! $ tab9 137,141,137,142 " A_ B_ tab9 137,143,137,144 " C_ D_ tab9 137,145,137,146 " _E F_ tab9 137,147,137,150 " G_ H_ tab9 137,151,137,152 " I_ J_ tab9 137,153,137,154 " K_ L_ tab9 137,155,137,156 " M_ N_ tab9 137,157,137,160 " O_ P_ tab9 137,161,137,162 " Q_ R_ tab9 137,163,137,164 " S_ T_ tab9 137,165,137,166 " U_ V_ tab9 137,167,137,170 " W_ X_ tab9 137,171,137,172 " Y_ Z_ tab9 176,203,176,204 " nor,nand tab9 055,211,055,057 " -O  -/ tab9 176,254,052,211 " locked function,logarithm tab9 174,211,134,211 " O| O\ tab9 057,211,174,254 " /O,grade down tab9 174,214,215,217 " grade up,lamp tab9 047,216,220,221 " quad quote,i beam tab9 055,134,205,216 " \-,domino tab9 060,137,061,137 " 0_ 1_ tab9 062,137,063,137 " 2_ 3_ tab9 064,137,065,137 " 4_ 5_ tab9 066,137,067,137 " 6_ 7_ tab9 070,137,071,137 " 8_ 9_ tab9 137,214,215,220 " underlined delta,hydrant tab9 133,215,135,215 " { } tab9 050,055,051,055 " (- )- tab9 074,076,215,221 " <> _f " these overstrikes are used to generate ASCII codes tab9 134,163,137,204 " & (S\),^ (underlined and-sign) tab9 047,253,057,205 " " (apostrophe/upper minus),% (divide/slash) " the following overstrikes are allowed by APL\360 tab9 055,255,054,072 " left arrow/minus,,: tab9 055,256,054,056 " right arrow/minus,., tab9 054,073,056,077 " , .? tab9 056,072,057,075 " .: =/ tab9 072,073,160,162 " : PR tab9 145,146,053,055 " EF +- tab9 055,205,057,202 " divide/-,/=/ tab9 075,202,151,164 " /== TI tab9 145,154,146,154 " LE LF tab9 157,161,047,072 " QO ': tab9 203,204,174,222 " v& (alternate for diamond) c| tab9 054,055 " ,- compression_out: dec 89 " 89 elements in table tab9 041,044,101,102 " ! $ A_ B_ tab9 103,104,105,106 tab9 107,110,111,112 tab9 113,114,115,116 tab9 117,120,121,122 tab9 123,124,125,126 tab9 127,130,131,132 " W_ X_ Y_ Z_ tab9 225,226,227,230 " v~ &~ -o  -/ tab9 231,232,233,234 tab9 235,236,237,240 tab9 241,242,243,244 tab9 260,261,262,263 " 0_ 1_ 2_ 3_ tab9 264,265,266,267 " 4_ 5_ 6_ 7_ tab9 270,271,272,274 " 8_ 9_ _d _e tab9 173,175,276,277 " { } (- )- tab9 257,275,046,136 " <> _f & ^ tab9 042,045,255,073 " " % -< tab9 256,054,073,077 " -> , ? tab9 072,202,073,162 " : /= R tab9 145,053,205,202 " E + -: /= tab9 202,164,145,145 " /= T E E tab9 161,041,257,302 " Q ! <> c| tab9 303 " ,- " " Conversion table for Correspondence 2741. " modes: ll125. " enter: null " leave: null apl_correspondence_2741: dev_info cor_2741,seq_cor_2741,compression_in,compression_out aci "CORR2741",32 dev_info1 not_graphic,shift_needed,quit_editing_allowed, 056,245,075,034,037,240 dev_info2 0,120 delay 0,0,0,0,0,0, 1616,71,1253,71,0,0, 0,0,0,0,0,0, 0,0,0,0,0,0 dec 7 tab9 056,075,034,064,035,056,037 " LF IDLE UPSHIFT OR-SIGN BS LF DOWNSHIFT even cor_2741: tab9 602,602,602,602,602,602,015,610 " APL/Multics to Correspondence 2741 tab9 035,057,055,602,602,602,611,612 tab9 602,602,602,602,602,016,602,602 tab9 602,602,602,602,602,602,602,602 tab9 000,613,602,602,614,602,602,212 tab9 253,211,213,467,473,267,421,407 tab9 444,440,420,460,404,410,430,450 tab9 470,464,221,273,360,210,250,233 tab9 602,615,616,617,620,621,622,623 tab9 624,625,626,627,630,631,632,633 tab9 634,635,636,637,640,641,642,643 tab9 644,645,646,453,207,411,602,263 tab9 602,471,466,472,452,412,463,443 tab9 446,431,403,432,406,441,422,405 tab9 413,433,451,445,402,462,461,465 tab9 442,447,424,647,241,650,202,600 tab9 204,230,270,264,244,223,212,247 tab9 262,205,245,252,246,203,206,272 tab9 266,222,224,242,261,651,652,653 tab9 654,655,656,657,660,661,662,663 tab9 664,665,666,667,670,240,265,231 tab9 251,423,271,220,243,401,201,671 tab9 672,673,674,675,676,677,700,701 tab9 702,703,704,600,705,706,707,710 tab9 711,603,712,713,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 040,255,164,152,064,157,154,057 " Corr 2741 to APL/Multics tab9 065,135,145,160,404,006,025,404 tab9 062,076,156,251,172,404,404,404 tab9 066,151,153,161,401,010,404,404 tab9 061,155,170,147,060,163,150,171 tab9 067,162,144,133,404,012,300,011 tab9 063,166,165,146,071,167,142,053 tab9 070,141,143,054,404,404,403,404 tab9 040,256,176,215,200,211,216,134 tab9 075,051,206,052,404,006,025,404 tab9 253,072,221,205,222,404,404,404 tab9 201,247,047,077,404,010,404,400 tab9 245,174,223,254,204,212,214,207 tab9 076,250,213,050,404,012,300,011 tab9 074,224,210,137,203,246,220,055 tab9 202,252,217,073,404,404,403,404 " code movement table tab9 001,001,001,001,001,001,001,001 tab9 402,403,445,007,006,404,201,201 tab9 001,001,001,001,001,001,001,001 tab9 000,000,001,001,000,001,000,001 tab9 400,000,000,020,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 030,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,401 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,010,020,000 tab9 000,000,030,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 055,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 " device movement table tab6 0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,1,1,1 tab6 0,0,0,0,8,2,1,7,0,0,0,0,0,0,0,0,0,0,0,0,1,5,1,3 tab6 0,0,0,0,0,0,0,0,0,0,0,0,9,1,6,1,0,0,0,0,0,0,0,0 tab6 0,0,0,0,1,1,1,1,0,0,0,0,0,1,1,1,0,0,0,0,8,2,1,7 tab6 0,0,0,0,0,0,0,0,0,0,0,0,1,5,1,3,0,0,0,0,0,0,0,0 tab6 0,0,0,0,9,1,6,1 " escape/prefix table dec 4 " === (5-1) tab9 600,023,017 " brs tab9 600,123,017 " BRS tab9 600,043,016 " rrs tab9 600,143,016 " RRS tab9 200,245,245 " esc esc (diaresis) " Corr 2741 output sequence table seq_cor_2741: tab9 2,034,037 " Bel -> upshift,downshift tab9 2,076,071 " RRS -> prefix A tab9 2,076,066 " BRS -> prefix B tab9 3,232,035,421 " ! tab9 3,445,035,407 " $ tab9 3,471,035,263 " A_ tab9 3,466,035,263 " B_ tab9 3,472,035,263 " C_ tab9 3,452,035,263 " D_ tab9 3,412,035,263 " E_ tab9 3,463,035,263 " F_ tab9 3,443,035,263 " G_ tab9 3,446,035,263 " H_ tab9 3,431,035,263 " I_ tab9 3,403,035,263 " J_ tab9 3,432,035,263 " K_ tab9 3,406,035,263 " L_ tab9 3,441,035,263 " M_ tab9 3,422,035,263 " N_ tab9 3,405,035,263 " O_ tab9 3,413,035,263 " P_ tab9 3,433,035,263 " Q_ tab9 3,451,035,263 " R_ tab9 3,445,035,263 " S_ tab9 3,402,035,263 " T_ tab9 3,462,035,263 " U_ tab9 3,461,035,263 " V_ tab9 3,465,035,263 " W_ tab9 3,442,035,263 " X_ tab9 3,447,035,263 " Y_ tab9 3,424,035,263 " Z_ tab9 3,453,035,203 " { [(os)_o tab9 3,411,035,203 " } ](os)_o tab9 3,264,035,202 " nor tab9 3,244,035,202 " nand tab9 3,205,035,267 " reverse first tab9 3,407,035,267 " -/ tab9 3,243,035,202 " locked function tab9 3,205,035,213 " logarithm tab9 3,205,035,241 " reverse tab9 3,205,035,207 " \o tab9 3,205,035,407 " /o tab9 3,243,035,241 " grade down tab9 3,346,035,241 " grade up tab9 3,272,035,203 " lamp tab9 3,206,035,232 " quad quote tab9 3,222,035,266 " i beam tab9 3,207,035,267 " -\ tab9 3,206,035,223 " domino tab9 3,360,035,250 " <> diamond tab9 3,444,035,263 " 0_ tab9 3,440,035,263 " 1_ tab9 3,420,035,263 " 2_ tab9 3,460,035,263 " 3_ tab9 3,404,035,263 " 4_ tab9 3,410,035,263 " 5_ tab9 3,430,035,263 " 6_ tab9 3,450,035,263 " 7_ tab9 3,470,035,263 " 8_ tab9 3,464,035,263 " 9_ tab9 3,246,035,263 " underlined delta tab9 3,266,035,203 " hydrant tab9 3,222,035,203 " thorn tab9 3,253,035,267 " (- left tack THIS ) FOR BSG! tab9 3,211,035,267 " BSG ( LEFT PARN! )- right tack tab9 3,056,075,075 " line feed,delay,delay tab9 3,224,035,241 " c| tab9 3,473,035,267 " ,- " " Conversion table for the Tektronix 4013 APL/ASCII/Graphics terminal. " modes: ll73,pl34,^tabs " enter: ESC SI " leave: ESC SO apl_4013: dev_info convert_4013,sequence_4013,compression_in,compression_out aci "TEK4013",32 dev_info1 graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,041 dev_info2 34,73 delay 0,0,0,0,0,23, 0,0,0,0,0,35, 0,0,0,0,0,73, 0,0,0,0,0,146 dec 4 tab9 012,050,010,012 " LF OR-SIGN BS LF even " APL/Multics to 4013 convert_4013: tab9 602,602,602,602,602,602,600,007 " ignore 006 for now tab9 010,011,702,602,703,015,602,602 tab9 602,602,602,602,602,600,602,602 " ignore 025 for now tab9 602,602,602,602,602,602,602,602 tab9 040,610,602,602,176,602,602,113 tab9 072,042,120,055,054,137,056,057 tab9 060,061,062,063,064,065,066,067 tab9 070,071,076,074,043,045,046,121 tab9 602,611,612,613,614,615,616,617 tab9 620,621,622,623,624,625,626,627 tab9 630,631,632,633,634,635,636,637 tab9 640,641,642,073,077,047,602,106 tab9 602,141,142,143,144,145,146,147 tab9 150,151,152,153,154,155,156,157 tab9 160,161,162,163,164,165,166,167 tab9 170,171,172,173,115,175,124,600 tab9 044,136,052,050,051,053,105,131 tab9 125,117,123,104,110,112,114,103 tab9 102,116,132,130,126,643,644,645 tab9 646,647,650,651,652,653,654,655 tab9 656,657,660,661,662,041,127,111 tab9 122,075,101,100,107,133,135,140 tab9 663,664,665,666,667,670,671,672 tab9 673,674,675,601,676,677,134,174 tab9 012,603,700,701,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 " 4013 to APL/Multics tab9 000,001,002,003,004,005,006,007 tab9 010,011,012,300,404,015,016,017 " 013 ==> 300,linefeed tab9 020,021,022,023,024,025,026,027 tab9 030,031,032,403,034,035,036,037 tab9 040,245,051,074,200,075,076,135 tab9 203,204,202,205,054,053,056,057 tab9 060,061,062,063,064,065,066,067 tab9 070,071,050,133,073,251,072,134 tab9 253,252,220,217,213,206,137,254 tab9 214,247,215,047,216,174,221,211 tab9 052,077,250,212,176,210,224,246 tab9 223,207,222,255,276,256,201,055 tab9 257,141,142,143,144,145,146,147 tab9 150,151,152,153,154,155,156,157 tab9 160,161,162,163,164,165,166,167 tab9 170,171,172,173,277,175,044,404 " code movement table for 4013 tab9 001,001,001,001,001,001,001,001 tab9 402,403,445,007,006,404,201,201 tab9 001,001,001,001,001,001,001,001 tab9 000,000,001,001,000,001,000,001 tab9 400,000,000,020,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 030,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,401 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,010,020,000 tab9 000,000,030,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 055,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 " device movement table for 4013 tab6 1,1,1,1,1,1,1,1,2,3,5,1,1,4,1,1,1,1,1,1,1,1,1,1 tab6 1,1,1,6,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,1 " escape/prefix table for 4013 dec 1 tab9 200,245,245 " esc esc (diaresis) " output sequence table for 4013 sequence_4013: tab9 3,113,010,056 " ! tab9 3,141,010,106 " A_ tab9 3,142,010,106 tab9 3,143,010,106 tab9 3,144,010,106 tab9 3,145,010,106 tab9 3,146,010,106 tab9 3,147,010,106 tab9 3,150,010,106 tab9 3,151,010,106 tab9 3,152,010,106 tab9 3,153,010,106 tab9 3,154,010,106 tab9 3,155,010,106 tab9 3,156,010,106 tab9 3,157,010,106 tab9 3,160,010,106 tab9 3,161,010,106 tab9 3,162,010,106 tab9 3,163,010,106 tab9 3,164,010,106 tab9 3,165,010,106 tab9 3,166,010,106 tab9 3,167,010,106 tab9 3,170,010,106 tab9 3,171,010,106 tab9 3,172,010,106 " Z_ tab9 3,050,010,124 " nor tab9 3,051,010,124 " nand tab9 3,117,010,137 " -O tab9 3,057,010,137 " -/ tab9 3,107,010,124 " locked fcn tab9 3,117,010,120 " *O tab9 3,117,010,115 " O| tab9 3,117,010,077 " O\ tab9 3,117,010,057 " /O tab9 3,107,010,115 " grade down tab9 3,110,010,115 " grade up tab9 3,103,010,112 " lamp tab9 3,114,010,113 " quad quote tab9 3,116,010,102 " ibeam tab9 3,077,010,137 " -\ tab9 3,114,010,053 " domino tab9 3,060,010,106 " 0_ tab9 3,061,010,106 tab9 3,062,010,106 tab9 3,063,010,106 tab9 3,064,010,106 tab9 3,065,010,106 tab9 3,066,010,106 tab9 3,067,010,106 tab9 3,070,010,106 tab9 3,071,010,106 " 9_ tab9 3,110,010,106 " underlined delta tab9 3,102,010,112 " hydrant tab9 3,116,010,112 " thorn tab9 3,132,010,115 " c| tab9 3,054,010,137 " ,- tab9 2,015,012 " CR LF tab9 33,033,014,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177 " (25) 177,ESC,FF " " Conversion table for an APL/ASCII bit-paired terminal,such as a CDI 1030. " modes: ll73,^tabs " enter: ? " leave: ? apl_1030: dev_info convert_1030,sequence_1030,compression_in,compression_out aci "1030",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,041 dev_info2 0,79 delay 0,0,0,0,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 0,0,0,0,0,146 dec 5 tab9 012,177,051,010,012 " LF DEL OR-SIGN BS LF even " APL/Multics to 1030 convert_1030: tab9 602,602,602,602,602,602,600,007 " ignore 006 for now tab9 010,011,702,602,703,015,602,602 tab9 602,602,602,602,602,600,602,602 " ignore 025 for now tab9 602,602,602,602,602,602,602,602 tab9 040,610,602,602,174,602,602,113 " SP ! " # $ % & ' tab9 053,052,120,055,054,075,056,057 " ( ) * + ,- . / tab9 060,061,062,063,064,065,066,067 tab9 070,071,076,074,043,045,047,121 " 8 9 : < = > ? tab9 602,611,612,613,614,615,616,617 tab9 620,621,622,623,624,625,626,627 tab9 630,631,632,633,634,635,636,637 tab9 640,641,642,073,077,072,602,106 " X_ Y_ Z_ [ \ ] ^ _ tab9 602,141,142,143,144,145,146,147 tab9 150,151,152,153,154,155,156,157 tab9 160,161,162,163,164,165,166,167 tab9 170,171,172,173,115,175,124,600 tab9 044,046,050,051,137,176,105,131 " <_ >_ =/ OR AND -: EPS UP tab9 125,117,123,104,110,112,114,103 tab9 102,116,132,130,126,643,644,645 tab9 646,647,650,651,652,653,654,655 tab9 656,657,660,661,662,041,127,111 tab9 122,136,101,042,107,100,140,134 tab9 663,664,665,666,667,670,671,672 tab9 673,674,675,601,676,677,133,163 tab9 012,603,700,701,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 " 1030 to APL/Multics tab9 000,001,002,003,004,005,006,007 tab9 010,011,012,300,404,015,016,017 " 013 ==> 300,linefeed tab9 020,021,022,023,024,025,026,027 tab9 030,031,032,403,034,035,036,037 tab9 040,245,253,074,200,075,201,076 tab9 202,203,051,050,054,053,056,057 tab9 060,061,062,063,064,065,066,067 tab9 070,071,135,133,073,055,072,134 tab9 255,252,220,217,213,206,137,254 tab9 214,247,215,047,216,174,221,211 tab9 052,077,250,212,176,210,224,246 tab9 223,207,222,276,257,174,251,204 tab9 256,141,142,143,144,145,146,147 tab9 150,151,152,153,154,155,156,157 tab9 160,161,162,163,164,165,166,167 tab9 170,171,172,277,044,175,205,404 " code movement table for 1030 tab9 001,001,001,001,001,001,001,001 tab9 402,403,445,007,006,404,201,201 tab9 001,001,001,001,001,001,001,001 tab9 000,000,001,001,000,001,000,001 tab9 400,000,000,020,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 030,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,401 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,010,020,000 tab9 000,000,030,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 055,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 " device movement table for 1030 tab6 1,1,1,1,1,1,1,1,2,3,5,1,1,4,1,1,1,1,1,1,1,1,1,1 tab6 1,1,1,6,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,1 " escape/prefix table for 1030 dec 1 tab9 200,245,245 " esc esc (diaresis) " output sequence table for 1030 sequence_1030: tab9 3,113,010,056 " ! tab9 3,141,010,106 " A_ tab9 3,142,010,106 tab9 3,143,010,106 tab9 3,144,010,106 tab9 3,145,010,106 tab9 3,146,010,106 tab9 3,147,010,106 tab9 3,150,010,106 tab9 3,151,010,106 tab9 3,152,010,106 tab9 3,153,010,106 tab9 3,154,010,106 tab9 3,155,010,106 tab9 3,156,010,106 tab9 3,157,010,106 tab9 3,160,010,106 tab9 3,161,010,106 tab9 3,162,010,106 tab9 3,163,010,106 tab9 3,164,010,106 tab9 3,165,010,106 tab9 3,166,010,106 tab9 3,167,010,106 tab9 3,170,010,106 tab9 3,171,010,106 tab9 3,172,010,106 " Z_ tab9 3,051,010,124 " nor tab9 3,124,010,137 " nand tab9 3,075,010,117 " -O tab9 3,057,010,075 " -/ tab9 3,107,010,124 " locked fcn tab9 3,117,010,120 " *O tab9 3,117,010,115 " O| tab9 3,117,010,077 " O\ tab9 3,117,010,057 " /O tab9 3,107,010,115 " grade down tab9 3,110,010,115 " grade up tab9 3,103,010,112 " lamp tab9 3,114,010,113 " quad quote tab9 3,116,010,102 " ibeam tab9 3,075,010,077 " -\ tab9 3,114,010,176 " domino tab9 3,060,010,106 " 0_ tab9 3,061,010,106 tab9 3,062,010,106 tab9 3,063,010,106 tab9 3,064,010,106 tab9 3,065,010,106 tab9 3,066,010,106 tab9 3,067,010,106 tab9 3,070,010,106 tab9 3,071,010,106 " 9_ tab9 3,110,010,106 " underlined delta tab9 3,102,010,112 " hydrant tab9 3,116,010,112 " thorn tab9 3,132,010,115 " c| tab9 3,054,010,075 " ,- tab9 2,015,012 " CR LF tab9 33,033,014,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177,177 " (25) 177,ESC,FF " " Code conversion table for ASCII devices " PG 1/4/74 apl_ascii: dev_info convert_ascii,sequence_ascii,ascii_compression_in,ascii_compression_out aci "ASCII",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,042 dev_info2 0,79 " page length,line length delay 0,0,0,0,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 0,0,0,0,0,146 dec 8 tab9 012,177,177,177,177,166,010,012 " LF PAD PAD PAD PAD OR-SIGN BS LF even " APL/Multics to ASCII devices convert_ascii: tab9 602,602,602,602,602,602,600,007 tab9 010,011,610,602,014,015,016,017 tab9 602,602,602,602,602,600,602,602 tab9 602,602,602,602,602,602,602,602 tab9 040,041,602,602,044,045,602,047 tab9 050,051,052,053,054,055,056,057 tab9 060,061,062,063,064,065,066,067 tab9 070,071,072,073,074,075,076,077 tab9 602,611,612,613,614,615,616,617 tab9 620,621,622,623,624,625,626,627 tab9 630,631,632,633,634,635,636,637 tab9 640,641,642,133,134,135,602,137 tab9 602,101,102,103,104,105,106,107 tab9 110,111,112,113,114,115,116,117 tab9 120,121,122,123,124,125,126,127 tab9 130,131,132,173,174,175,176,600 tab9 643,644,645,166,046,646,145,647 tab9 650,157,143,146,144,651,161,156 tab9 652,164,653,654,165,655,656,657 tab9 660,661,662,663,664,665,666,667 tab9 714,670,142,671,155,042,167,151 tab9 160,170,141,136,147,672,673,674 tab9 675,676,677,700,701,702,703,704 tab9 705,706,707,601,710,711,712,713 tab9 012,603,715,716,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 tab9 602,602,602,602,602,602,602,602 " ASCII devices to APL/Multics tab9 000,001,002,003,004,005,006,007 tab9 010,011,012,300,404,015,016,017 " 013 ==> 300,linefeed tab9 020,021,022,023,024,025,026,027 tab9 030,031,032,403,034,035,036,037 tab9 040,041,245,246,044,045,204,047 tab9 050,051,052,053,054,055,056,057 tab9 060,061,062,063,064,065,066,067 tab9 070,071,072,073,074,075,076,077 tab9 252,141,142,143,144,145,146,147 tab9 150,151,152,153,154,155,156,157 tab9 160,161,162,163,164,165,166,167 tab9 170,171,172,133,134,135,253,137 tab9 140,252,242,212,214,206,213,254 tab9 405,247,405,405,405,244,217,211 tab9 250,216,405,405,221,224,203,246 tab9 251,405,405,173,174,175,176,404 " code movement table for ASCII tab9 001,001,001,001,001,001,001,001 tab9 402,403,445,007,006,404,201,201 tab9 001,001,001,001,001,001,001,001 tab9 000,000,001,001,000,001,000,001 tab9 400,000,000,020,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 030,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,401 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,010,020,000 tab9 000,000,030,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 055,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 tab9 000,000,000,000,000,000,000,000 " device movement table for ASCII tab6 1,1,1,1,1,1,1,1,2,3,5,1,1,4,1,1,1,1,1,1,1,1,1,1 tab6 1,1,1,6,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 tab6 0,0,0,0,0,0,0,1 " escape/prefix table for ASCII dec 1 tab9 200,245,245 " esc esc (double quote) " output sequence table for ASCII sequence_ascii: tab9 2,015,012 " NL -> CR LF tab9 3,101,010,137 " A_ tab9 3,102,010,137 tab9 3,103,010,137 tab9 3,104,010,137 tab9 3,105,010,137 tab9 3,106,010,137 tab9 3,107,010,137 tab9 3,110,010,137 tab9 3,111,010,137 tab9 3,112,010,137 tab9 3,113,010,137 tab9 3,114,010,137 tab9 3,115,010,137 tab9 3,116,010,137 tab9 3,117,010,137 tab9 3,120,010,137 tab9 3,121,010,137 tab9 3,122,010,137 tab9 3,123,010,137 tab9 3,124,010,137 tab9 3,125,010,137 tab9 3,126,010,137 tab9 3,127,010,137 tab9 3,130,010,137 tab9 3,131,010,137 tab9 3,132,010,137 tab9 3,074,010,137 tab9 3,076,010,137 " >_ tab9 3,057,010,075 " /= tab9 3,055,010,072 " -: tab9 3,136,010,174 " ^| tab9 3,166,010,174 " v| tab9 3,137,010,157 " _o tab9 3,137,010,174 " _| tab9 3,050,010,137 " (_ THIS ) FOR BSG! tab9 3,051,010,137 " BSG ( LEFT PARN! )_ tab9 3,166,010,176 " v~ tab9 3,046,010,176 " &~ tab9 3,055,010,157 " -o tab9 3,055,010,057 " -/ tab9 3,147,010,176 " g~ tab9 3,052,010,157 " *o tab9 3,157,010,174 " o| tab9 3,134,010,157 " \o tab9 3,057,010,157 " /o tab9 3,147,010,174 " g| tab9 3,144,010,174 " d| tab9 3,047,010,161 " 'q tab9 3,055,010,134 " -\ tab9 3,055,010,074 " -< tab9 3,055,010,076 " -> tab9 3,074,010,076 " <> tab9 3,060,010,137 " 0_ tab9 3,061,010,137 " 1_ tab9 3,062,010,137 " 2_ tab9 3,063,010,137 " 3_ tab9 3,064,010,137 " 4_ tab9 3,065,010,137 " 5_ tab9 3,066,010,137 " 6_ tab9 3,067,010,137 " 7_ tab9 3,070,010,137 " 8_ tab9 3,071,010,137 " 9_ tab9 3,137,010,144 " _d tab9 3,137,010,145 " _e tab9 3,137,010,146 " _f tab9 3,050,010,055 " (- THIS ) FOR BSG! tab9 3,051,010,055 " BSG ( LEFT PARN! )- tab9 3,056,010,156 " .n tab9 3,143,010,174 " c| tab9 3,054,010,055 " ,- " compression table for ASCII ascii_compression_in: dec 140 " 140 characters in table tab9 137,141,137,142 " A_ B_ tab9 137,143,137,144 tab9 137,145,137,146 tab9 137,147,137,150 tab9 137,151,137,152 tab9 137,153,137,154 tab9 137,155,137,156 tab9 137,157,137,160 tab9 137,161,137,162 tab9 137,163,137,164 tab9 137,165,137,166 tab9 137,167,137,170 tab9 137,171,137,172 tab9 074,137,076,137 " <_ >_ tab9 057,075,055,072 " /= -: tab9 174,253,174,203 " ^| v| tab9 137,211,137,174 " _o _| tab9 050,137,051,137 " (_ )_ tab9 176,203,176,204 " v~ &~ tab9 055,211,055,057 " -o -/ tab9 176,254,052,211 " g~ *o tab9 174,211,134,211 " o| \o tab9 057,211,174,254 " /o g| tab9 174,214,047,216 " d| 'q tab9 055,134,055,074 " -\ <- tab9 055,076,074,076 " -> <> tab9 060,137,061,137 " 0_ 1_ tab9 062,137,063,137 " 2_ 3_ tab9 064,137,065,137 " 4_ 5_ tab9 066,137,067,137 " 6_ 7_ tab9 070,137,071,137 " 8_ 9_ tab9 137,214,137,206 " _d _e tab9 137,213,050,055 " _f (- THIS ) FOR BSG! tab9 051,055,056,217 " BSG ( LEFT PARN! )- .n tab9 174,212,054,055 " c| ,- ascii_compression_out: dec 70 " 70 elements in table tab9 101,102,103,104 tab9 105,106,107,110 tab9 111,112,113,114 tab9 115,116,117,120 tab9 121,122,123,124 tab9 125,126,127,130 tab9 131,132,200,201 tab9 202,205,207,210 tab9 215,220,222,223 tab9 225,226,227,230 tab9 231,232,233,234 tab9 235,236,237,241 tab9 243,255,256,257 tab9 260,261,262,263 tab9 264,265,266,267 tab9 270,271,272,274 tab9 275,276,277,240 tab9 302,303 " apl_ascii_display: dev_info convert_ascii,sequence_ascii,ascii_compression_in,ascii_compression_out aci "ARDS",32 dev_info1 graphic,no_shift_needed,quit_editing_not_allowed, 013,245,000,0,0,042 dev_info2 45,73 delay 0,0,0,0,0,0, 0,0,0,0,0,0, 0,0,0,0,0,0, 0,0,0,0,0,0 dec 0 tab9 0,0,0,0,0,0,0,0 " nothing apl_tn300: dev_info convert_ascii,sequence_ascii,ascii_compression_in,ascii_compression_out aci "TN300",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,042 dev_info2 0,118 delay 0,0,0,0,2,23, 2000,0,0,0,3,35, 6000,0,0,0,6,73, 24000,0,0,0,24,300 dec 8 tab9 012,177,177,177,177,166,010,012 " LF PAD PAD PAD PAD OR-SIGN BS LF apl_teletype: dev_info convert_ascii,sequence_ascii,ascii_compression_in,ascii_compression_out aci "TELETYPE",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,042 dev_info2 0,90 delay 0,15,632,232,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 0,0,0,0,0,146 dec 8 tab9 012,177,177,177,177,166,010,012 " LF PAD(4) OR-SIGN BS LF apl_typepaired: dev_info convert_4013,sequence_4013,compression_in,compression_out aci "TYPEPAIRED",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,041 dev_info2 0,79 delay 0,15,632,232,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 0,0,0,0,0,146 dec 8 tab9 012,177,177,177,177,050,010,012 " LF PAD(4) OR-SIGN BS LF apl_bitpaired: dev_info convert_1030,sequence_1030,compression_in,compression_out aci "BITPAIRED",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,041 dev_info2 0,79 delay 0,15,632,232,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 0,0,0,0,0,146 dec 8 tab9 012,177,177,177,177,051,010,012 "LF PAD(4) OR-SIGN BS LF apl_aj510: apl_teleray11: dev_info convert_4013,sequence_4013,compression_in,compression_out aci "TELERAY11",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,041 dev_info2 24,79 delay 0,0,0,0,0,23, 0,0,0,0,0,35, 0,0,0,0,0,73, 0,0,0,0,0,146 dec 4 tab9 012,050,010,012 " LF OR-SIGN BS LF apl_aj830: apl_la36: dev_info convert_4013,sequence_4013,compression_in,compression_out aci "LA36",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,041 dev_info2 0,79 delay 0,15,632,232,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 6000,0,0,0,0,146 dec 8 tab9 012,177,177,177,177,050,010,012 " LF (4) PAD OR-SIGN BS LF apl_sara: dev_info convert_ascii,sequence_ascii,ascii_compression_in,ascii_compression_out aci "SARA",32 dev_info1 not_graphic,no_shift_needed,quit_editing_allowed, 013,245,177,0,0,042 dev_info2 0,132 delay 0,15,632,232,0,23, 0,15,632,232,0,35, 6000,0,0,0,0,73, 12000,330,0,0,0,100 dec 8 tab9 012,177,177,177,177,166,010,012 " LF (4) PAD OR-SIGN BS LF end  apl_dim_util_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 152307 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Utility Module of the APL Device Interface Module. Paul Green, July 1973 Modified 740511 by PG to properly handle default line & page lengths. Modified 740530 by PG to add tabsin mode. Modified 741104 by PG to fix detach/reattach handling. Modified 750722 by PG to get baud rate properly under MCS. Modified 770406 by PG to have set_tab_width control tab mode, too. Modified 771003 by PG to have initialize_sdb clear status in all cases. Modified 790613 by PG to fix 402 (TTYDIM changes broke quit-editing). Modified 790910 by PG to record 1200 baud info, and to complete switch to iox_. Modified 800128 by Warren Johnson to allow graphic mode. Modified 800130 by PG to use 1200 baud delay values if actual baud > 1200, and to call apl_dim_select_table_. Modified 800226 by PG to implement ^ll mode. */ /* format: style3 */ apl_dim_attach: procedure (stream, my_name, att_stream, modes, bv_status, sdb_ptr); /* parameters */ dcl ( bv_status bit (72) aligned, /* status returned by call */ stream char (*), /* stream name */ my_name char (*), /* this dim's name */ att_stream char (*), /* stream to which it is attached */ modes char (*) ) parameter; /* i/o mode */ /* entries */ dcl apl_dim_select_table_ entry (char (*), ptr, bit (1) aligned), convert_binary_integer_$decimal_string entry (fixed bin) returns (char (12) varying), get_system_free_area_ entry () returns (ptr), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$find_iocb entry (char (*), ptr, fixed bin (35)), iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* external static */ dcl ( error_table_$ionmat, error_table_$action_not_performed, error_table_$bad_mode, error_table_$no_room_for_sdb ) external fixed bin (35) aligned static; /* builtin */ dcl (addr, addrel, binary, length, null, pointer, substr, unspec) builtin; /* automatic */ dcl i fixed bin, quit_read_n_transmitted fixed bin (21), char_1 char (1) aligned, bit_char bit (9) aligned, system_area_ptr ptr, quit_pending bit (1) aligned; /* internal static */ dcl working_table_ptr ptr internal static initial (null); /* internal static "constants" */ dcl new_line char (1) internal static options (constant) initial (" "); /* based */ dcl system_area area (65536) based (system_area_ptr); /* conditions */ dcl (apl_quit_, area, bad_area_format, quit) condition; /* include files */ %include apl_dim_sdb; %include apl_dim_table; /* program */ bv_status, status = ""b; if sdb_ptr ^= null /* multiple attachment */ then do; status_code = error_table_$ionmat; stream_detached = "1"b; bv_status = status; return; end; on area, bad_area_format go to cant_do_it; system_area_ptr = get_system_free_area_ (); allocate stream_data_block in (system_area) set (sdb_ptr); call iox_$find_iocb (stream, stream_data_block.iocb_ptr, status_code); call iox_$find_iocb ((stream_data_block.name), stream_data_block.device_iocb_ptr, status_code); call initialize_sdb (working_table_ptr); go to chmodes; /* set the modes */ cant_do_it: status_code = error_table_$no_room_for_sdb; stream_detached = "1"b; bv_status = status; return; apl_dim_order: entry (sdb_ptr, request, arg_ptr, bv_status); /* order requests are interpreted or passed on */ dcl request char (*), /* request */ arg_ptr ptr, /* ptr to table or to maximum length values */ fbin_arg based (arg_ptr) fixed bin (35); /* fixed point args to line_ */ /* and page_length calls */ dcl keying_time_param fixed bin (71) based (arg_ptr), device_type_param char (32) based (arg_ptr); declare 1 read_status_structure aligned, 2 event_channel fixed bin (71), 2 input_available bit (1); bv_status, status = ""b; device_ptr = stream_data_block.device_info_ptr; conversion_ptr = stream_data_block.conv_tab_ptr; if request = "process_quit" /* handle APL QUIT editing feature */ then do; /* To make this code immune to quits (in case the user manages to sneak in two quits in a big hurry), we'll set up a handler which just sets a flag. If the flag is on, we'll assume he didn't type anything first, and cause an APL interrupt when things have settled down. */ quit_pending = "0"b; on quit quit_pending = "1"b; call iox_$control (stream_data_block.device_iocb_ptr, "read_status", addr (read_status_structure), status_code); if status_code ^= 0 then quit_read_n_transmitted = 0; else if ^input_available /* No input waiting */ then quit_read_n_transmitted = 0; else do; call iox_$get_chars (stream_data_block.device_iocb_ptr, addr (quit_read_buffer), length (quit_read_buffer), quit_read_n_transmitted, status_code); end; /* do a reset-read just in case the line break (QUIT) looked like a character with bad parity. */ call iox_$control (stream_data_block.device_iocb_ptr, "resetread", null, status_code); /* If the user didn't type anything, or this console doesn't have LINE FEED, we treat the QUIT as an APL interrupt. Note that APL/360 allows a user to type 0 characters and still edit. What a crock! */ if quit_read_n_transmitted = 0 | ^quit_editing_allowed then do; call interrupt_action; return; end; /* check for unmodified 2741-type terminals. */ if quit_read_n_transmitted = 1 then do; char_1 = substr (quit_read_buffer, 1, 1); bit_char = unspec (char_1); if device_move (binary (bit_char, 9)) = "11"b3 /* 9 == Quit char (EOT) */ then do; call interrupt_action; return; end; end; /* we now know that this is an "editing quit" */ call iox_$put_chars (stream_data_block.device_iocb_ptr, addrel (addr (editing_prompt), 1), length (editing_prompt), status_code); call iox_$control (stream_data_block.device_iocb_ptr, "start", null, status_code); unspec (char_1) = linefeed_character_device; if canonicalization_index <= 0 /* AAARRRGGGHHH!!!!!! */ then canonicalization_index = 1; substr (canonicalization_buffer, canonicalization_index, quit_read_n_transmitted + 1) = substr (quit_read_buffer, 1, quit_read_n_transmitted) || char_1; /* Mark Quit with LineFeed */ canonicalization_index = canonicalization_index + quit_read_n_transmitted + 1; if quit_pending then call interrupt_action; return; /* Internal procedure which performs action upon receiving an APL interrupt signal */ interrupt_action: procedure; call resetwrite (); if hndlquit_mode then do; read_offset = -1; /* finish resetread on apl_input_ */ canonicalization_index = 1; /* .. (user_tty_ already reset) */ call iox_$put_chars (stream_data_block.iocb_ptr, addr (new_line), length (new_line), status_code); end; call iox_$control (stream_data_block.device_iocb_ptr, "start", null, status_code); signal apl_quit_; return; end interrupt_action; end; else if request = "set_table" /* set translation table pointer */ then call initialize_sdb (arg_ptr); else if request = "line_length" /* set maximum line length */ then do; if fbin_arg >= 3 then max_col = fbin_arg; /* copy argument into sdb */ end; else if request = "page_length" /* set maximum page length */ then do; if fbin_arg >= 2 then max_line = fbin_arg; end; else if request = "table_ptr" /* pointer to translation table currently in use */ then do; arg_ptr = device_info_ptr; end; else if request = "get_keying_time" then keying_time_param = stream_data_block.keying_time; else if request = "get_device_type" then device_type_param = device_info.device_name; else if request = "read_back_output" then do; if arg_ptr ^= null then device_type_param = read_back_names (stream_data_block.read_back); stream_data_block.read_back = read_back_output; end; else if request = "read_back_spaces" then do; if arg_ptr ^= null then device_type_param = read_back_names (stream_data_block.read_back); stream_data_block.read_back = read_back_spaces; end; else if request = "read_back_input" then do; if arg_ptr ^= null then device_type_param = read_back_names (stream_data_block.read_back); stream_data_block.read_back = read_back_input; end; else if request = "get_tab_width" then do; if arg_ptr ^= null then fbin_arg = stream_data_block.tab_width; end; else if request = "set_tab_width" then do; i = stream_data_block.tab_width; if arg_ptr ^= null then if fbin_arg >= 0 then do; if fbin_arg < 2 then stream_data_block.tabm = "0"b; /* turn tabs off */ else stream_data_block.tabm = "1"b; /* turn tabs on */ stream_data_block.tab_width = fbin_arg; fbin_arg = i; end; else status_code = error_table_$action_not_performed; else stream_data_block.tab_width = 10; end; else call iox_$control (stream_data_block.device_iocb_ptr, request, arg_ptr, status_code); /* pass on order call */ bv_status = status; return; initialize_sdb: procedure (bv_table_ptr); /* parameters */ declare bv_table_ptr ptr parameter; /* automatic */ declare table_ptr ptr; declare 1 terminal_info aligned, 2 version fixed bin, 2 id char (4) unal, 2 term_type char (32) unal, 2 line_type fixed bin, 2 baud_rate fixed bin, 2 reserved (4) fixed bin; /* program */ terminal_info.version = 1; call iox_$control (stream_data_block.device_iocb_ptr, "terminal_info", addr (terminal_info), status_code); if status_code = 0 then do; if terminal_info.baud_rate = 110 then stream_data_block.baud_rate = baud_rate_110; else if (terminal_info.baud_rate = 133) | (terminal_info.baud_rate = 150) then stream_data_block.baud_rate = baud_rate_150_or_134; else if terminal_info.baud_rate = 300 then stream_data_block.baud_rate = baud_rate_300; else if terminal_info.baud_rate >= 1200 then stream_data_block.baud_rate = baud_rate_1200; else stream_data_block.baud_rate = baud_rate_300; /* default */ end; else do; stream_data_block.baud_rate = baud_rate_300; terminal_info.term_type = "ASCII"; end; status = ""b; if bv_table_ptr = null then call apl_dim_select_table_ (terminal_info.term_type, table_ptr, ("0"b)); else table_ptr = bv_table_ptr; working_table_ptr, /* save away to detach/reattach will use same table */ device_info_ptr, device_ptr = table_ptr; if device_info.shift_needed then actshift = "01"b; /* initially lower case */ else actshift = "00"b; if max_col = -1 /* meaning it wasn't set by attach or changemode */ then max_col = device_info.default_line_length; if max_line = -1 then max_line = device_info.default_page_length; conv_tab_ptr, conversion_ptr = pointer (device_ptr, device_info.conversion_offset); sequence_table_ptr, sequence_ptr = pointer (device_ptr, device_info.sequence_offset); if device_info.compression_in_offset ^= ""b then do; compression_in_ptr = pointer (device_ptr, device_info.compression_in_offset); compression_out_ptr = pointer (device_ptr, device_info.compression_out_offset); end; stream_data_block.internal_type (*) = conversions.code_move (*); if conv_tab_ptr -> out (9) = "110000010"b then tabm = "0"b; return; end initialize_sdb; apl_dim_detach: entry (sdb_ptr, att_stream, disposal, bv_status); dcl disposal char (*); /* ignored */ bv_status, status = ""b; system_area_ptr = get_system_free_area_ (); free stream_data_block in (system_area); sdb_ptr = null (); stream_detached = "1"b; bv_status = status; return; apl_dim_abort: entry (sdb_ptr, oldstatus, bv_status); /* this is simply passed on to the attached stream */ dcl oldstatus bit (72); /* transaction to be deleted */ bv_status, status = ""b; call iox_$control (stream_data_block.device_iocb_ptr, "abort", null, status_code); bv_status = status; return; apl_dim_resetread: entry (sdb_ptr, bv_status); bv_status, status = ""b; read_offset = -1; canonicalization_index = 1; call iox_$control (stream_data_block.device_iocb_ptr, "resetread", null, status_code); bv_status = status; return; apl_dim_resetwrite: entry (sdb_ptr, bv_status); bv_status, status = ""b; call resetwrite (); bv_status = status; return; resetwrite: procedure; call iox_$control (stream_data_block.device_iocb_ptr, "resetwrite", null, status_code); return; end resetwrite; apl_dim_changemode: entry (sdb_ptr, modes, oldmodes, bv_status); dcl oldmodes char (*); dcl mode char (10) varying, onsw bit (1), (stoff, endoff, col_temp, term_code) fixed bin, oms char (128) varying; dcl cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin); bv_status, status = ""b; if tabm then oms = "tabs,"; else oms = "^tabs,"; if tabsin_mode then oms = oms || "tabsin,"; else oms = oms || "^tabsin,"; if hndlquit_mode then oms = oms || "hndlquit,"; else oms = oms || "^hndlquit,"; if conm then oms = oms || "can,"; else oms = oms || "^can,"; if escm then oms = oms || "esc,"; else oms = oms || "^esc,"; if rawim then oms = oms || "rawi,"; else oms = oms || "^rawi,"; if erklm then oms = oms || "erkl,"; else oms = oms || "^erkl,"; if red_mode then oms = oms || "red,"; else oms = oms || "^red,"; if graphic then oms = oms || "graphic,"; else oms = oms || "^graphic,"; if max_line > 0 then oms = oms || "pl" || convert_binary_integer_$decimal_string (max_line) || ","; else oms = oms || "^pl,"; if max_col > 0 then oms = oms || "ll" || convert_binary_integer_$decimal_string (max_col); else oms = oms || "^ll"; oldmodes = oms; chmodes: /* make any changes to the stream data block indicated by modes */ stoff = 1; do endoff = 1 to length (modes); if substr (modes, endoff, 1) = "," | substr (modes, endoff, 1) = "." then go to check_mode; if endoff = length (modes) then do; endoff = endoff + 1; /* allow setting of last mode if no "." at end of string */ check_mode: mode = substr (modes, stoff, endoff - stoff); stoff = endoff + 1; if substr (mode, 1, 1) = "^" then do; /* are you setting a mode on or off */ mode = substr (mode, 2); onsw = "0"b; end; else onsw = "1"b; if mode = "tabs" then tabm = onsw; /* and set the appropriate bit */ else if mode = "hndlquit" then hndlquit_mode = onsw; else if mode = "tabsin" then tabsin_mode = onsw; else if mode = "can" then conm = onsw; else if mode = "esc" then escm = onsw; else if mode = "rawi" then rawim = onsw; else if mode = "erkl" then erklm = onsw; else if mode = "red" then red_mode = onsw; else if mode = "graphic" then graphic = onsw; else if mode = "default" then do; erklm, conm, escm = "1"b; rawim = "0"b; end; else if mode = "ll" then if onsw then do; status_code = error_table_$bad_mode; bv_status = status; return; end; else stream_data_block.max_col = 0; else if substr (mode, 1, 2) = "ll" then do; col_temp = cv_dec_check_ (substr (mode, 3), term_code); if term_code ^= 0 | col_temp < 4 then do; status_code = error_table_$bad_mode; bv_status = status; return; end; call iox_$modes (stream_data_block.device_iocb_ptr, (mode), "", 0); max_col = col_temp; end; else if mode = "pl" then if onsw then do; status_code = error_table_$bad_mode; bv_status = status; return; end; else stream_data_block.max_line = 0; else if substr (mode, 1, 2) = "pl" then do; col_temp = cv_dec_check_ (substr (mode, 3), term_code); if term_code ^= 0 | col_temp < 2 | ^onsw then do; status_code = error_table_$bad_mode; bv_status = status; return; end; call iox_$modes (stream_data_block.device_iocb_ptr, (mode), "", 0); max_line = col_temp; end; else if mode ^= "" then status_code = error_table_$bad_mode; end; end; bv_status = status; return; end /* apl_dim_attach */;  apl_dim_write_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 154692 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Write portion of the APL Device Interface Module. Paul Green, July 1973 */ /* Modified 740328 by PG to add features for net2741 device type */ /* Modified 741101 by PG to emit final downshift upon write so [MqN] editing will work. */ /* Modified 750320 by PG to get above fix to work correctly! */ /* Modified 770407 by PG to get )TABS command to work properly (not all wired-in 10's had been parameterized!). */ /* Modified 790411 by PG to fix 381 (was not padding backspace chars) */ /* Modified 791017 by PG to "fix" bug 395 by moving write_buffer to the stack and enlarging it. Modified 791220 by PG to improve fix to 381 by padding only first BS char in a sequence, to speed up [MqN] style of editing on a TN300, and to fix bug 432 in which [MqN] editing failed with 4.00 editor because read_back_spaces returned wrong number of spaces (especially when tabs were present, but also at other times). This also fixes bug 410, where overstruck characters get converted to 3 spaces on input. Modified 800128 by Warren Johnson to handle graphic mode. Modified 800130 by PG to once and for all fix the **** fatal process error bug (443). Modified 800131 by PG to fix bug in graphic mode. Modified 800226 by PG to implement ^ll mode. Discovered Modified 831107 by M. Pandolf in writing CR when whitespace character is a CR instead of just setting column to 0 */ /* format: style3 */ apl_dim_write_: procedure (P_sdb_ptr, P_data_ptr, P_data_offset, P_data_length, P_n_elements_transmitted, P_status); /* parameters */ dcl (P_data_offset, P_data_length, P_n_elements_transmitted) fixed bin, P_sdb_ptr ptr, P_data_ptr ptr, P_status bit (72); /* automatic */ dcl data_ptr ptr, current_char char (1); dcl (n_delays, nl_addend, nl_multiplier, tab_addend, tab_multiplier) fixed bin (21); dcl (i, ini, wcol, seqi, ei, ereti, escape_index) fixed bin (21), (col, oldcol) fixed bin (9), initial_column fixed bin (9), /* column we are in before any output is done. */ (donesw, last_char_was_BS, whitesw) bit (1) aligned, (shift, mode) bit (2), (inchar, enchar, outchar, oldoutchar) bit (9), erets (0:4) fixed bin, error_mark_line char (150), (device_last_line_start, last_line_start, out_char) fixed bin, 1 write_struc aligned, 2 write_buffer dim (4096) bit (9) unal; /* based */ dcl based_string dim (0:1044479) char (1) based, data_string char (P_data_length) based (data_ptr), write_buffer_overlay char (4096) aligned based (addr (write_struc)); /* entries */ dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* builtins */ dcl (addr, addrel, binary, copy, divide, length, max, mod, substr, unspec) builtin; /* include files */ %include apl_dim_sdb; %include apl_dim_table; %include apl_characters; /* program */ /* copy input parameters */ sdb_ptr = P_sdb_ptr; data_ptr = addr (P_data_ptr -> based_string (P_data_offset)); /* initialize output parameters */ P_n_elements_transmitted = 0; P_status, status = ""b; /* get ptrs to conversion tables, and extract commonly used values */ device_ptr = device_info_ptr; conversion_ptr = conv_tab_ptr; nl_addend = device_info.pad_info (baud_rate).nl_addend; nl_multiplier = device_info.pad_info (baud_rate).nl_multiplier; tab_addend = device_info.pad_info (baud_rate).tab_addend; tab_multiplier = device_info.pad_info (baud_rate).tab_multiplier; initial_column, col = actcol; /* get current column */ shift = actshift; /* pick up shift */ if shift then shift = "11"b; /* undefined...will cause leading shift to be emitted */ ereti = 0; /* init stack index for enter */ whitesw = "0"b; /* currently not moving carriage */ last_char_was_BS = "0"b; /* was no last char, couldn't have been BS */ last_line_start, ini = 1; /* get starting offset */ donesw = "0"b; /* not done */ device_last_line_start, /* start of last output line... */ out_char = 1; /* where to store in output buffer */ /* **************************** READ A CHARACTER ********************* */ r (0): loop: if ini > length (data_string) then do; donesw = "1"b; goto asblack; /* done except for positioning carriage */ end; current_char = substr (data_string, ini, 1); /* get char to process */ unspec (inchar) = unspec (current_char); ini = ini + 1; /* get ready to get next char */ /* ***********************JUST KEEP TRACK OF CARRIAGE POSITION FOR WHITE CHARACTERS ***************************** */ if (inchar & "400"b3) /* if too big for table, assume black */ then go to asblack; if ^red_mode then if type (binary (inchar, 9)).red then if stream_data_block.graphic then go to asblack; /* keep in graphic mode */ else go to loop; /* otherwise discard it */ /* This red mode stuff may still not be right for graphic mode... */ if type (binary (inchar, 9)).white /* carriage movement */ then do; if whitesw = "0"b then do; wcol = col; /* this is first white after black so init wcol */ whitesw = "1"b; /* note we are in white mode */ end; i = binary (type (binary (inchar, 9)).move, 3); /* i is movement type */ if i = 0 then wcol = wcol + 1; /* blank */ else if i = 5 then do; /* nl */ whitesw = "0"b; /* treat it as black */ oldcol = col; /* save for delay comp */ outchar = out (10); /* output nl */ erets (0) = 1; goto enter; /* set up return and 'call' enter */ r (1): n_delays = divide (nl_addend + oldcol * nl_multiplier, 512, 17, 0); call enter_delays (n_delays); end; else if i = 3 /* tab */ then if stream_data_block.tab_width < 2 /* turned off */ then wcol = wcol + 1; else wcol = wcol + stream_data_block.tab_width - mod (wcol, stream_data_block.tab_width); else if i = 2 /* bs */ then if wcol > 0 /* and not at left margin */ then wcol = wcol - 1; /* then back up */ else ; /* else stay at margin */ else if i = 4 /* cr */ then if wcol = 0 then do; if out_char > length (write_buffer_overlay) then call flush_output_buffer; write_buffer (out_char) = "015"b3; out_char = out_char + 1; end; else wcol = 0; goto loop; end; else do; /* character is a printing character */ /* ****************************** POSITION CARRIAGE ************************* */ asblack: if whitesw then do; whitesw = "0"b; /* this is first black after white */ if max_col > 3 /* don't get stuck in a loop */ then do while (wcol > max_col); /* reduce below limit */ oldcol = col; outchar = out (10); erets (0) = 2; goto enter; /* output nl */ r (2): n_delays = divide (nl_addend + oldcol * nl_multiplier, 512, 17, 0); call enter_delays (n_delays); outchar = escape_character_device; /* output escape char */ erets (0) = 3; goto enter; r (3): outchar = out (99); /* output a 'c' */ erets (0) = 4; goto enter; r (4): wcol = wcol - max_col + col; /* set up target column */ end; if wcol < col /* backward motion required */ then do; if wcol = 0 /* if going to left margin */ then if out (13) ^= "602"b3 /* and cr available */ then do; /* use cr */ outchar = out (13); erets (0) = 9; go to enter; end; erets (0) = 5; /* not going to col 0 or no cr available */ do i = 1 to col - wcol; outchar = out (8); goto enter; r (5): end; end; else do; /* if in tab mode & worth using tab(s) */ if tabm & ((wcol - col) > 2) then do; if mod (col, tab_width) >= (tab_width - 2) /* if not enough spaces before tab */ then do; erets (0) = 6; /* blanks */ do i = 1 to tab_width - mod (col, tab_width); outchar = out (32); goto enter; r (6): end; end; erets (0) = 7; do i = 1 to divide (wcol, tab_width, 17, 0) - divide (col, tab_width, 17, 0); oldcol = col; outchar = out (9); /* tab char */ goto enter; r (7): n_delays = divide (tab_addend + (col - oldcol) * tab_multiplier, 512, 17, 0); call enter_delays (n_delays); end; end; if wcol > col /* if blanks needed */ then do; erets (0) = 8; do i = 1 to wcol - col; outchar = out (32); goto enter; r (8): end; end; end; end; r (9): if donesw then do; /* if really done */ /* **************** TRANSMIT CONTENTS OF THE CONVERSION BUFFER & RETURN **************** */ if shift & "10"b then do; /* if in upper case, emit final downshift */ if out_char > length (write_buffer_overlay) then call flush_output_buffer; write_buffer (out_char) = device_info.lower_case; out_char = out_char + 1; shift = "01"b; /* now in LC */ end; call flush_output_buffer; P_n_elements_transmitted = ini - 1; actcol = col; actshift = shift; /* save present shift state (not used, really) */ if stream_data_block.error_mark_column > 0 then do; i = stream_data_block.error_mark_column; stream_data_block.error_mark_column = 0; substr (error_mark_line, 1, i - 1) = ""; substr (error_mark_line, i, 2) = QAndSign || QNewLine; call iox_$put_chars (stream_data_block.iocb_ptr, addr (error_mark_line), i + 1, status_code); end; return; end; /* **************************** ENTER THE CHARACTER ************************* */ erets (0) = 0; /* place data char */ if inchar & "400"b3 /* if too big */ then outchar = "602"b3; /* make look like octal escape */ else outchar = out (binary (inchar, 9)); /* If we are in graphic output mode, and we are outputting an ASCII control character, and the tables say to discard (600) or escape (602) the character, then pass it on unmolested. The purpose of graphic output mode is to enable an APL program to do terminal control functions ("plot mode") itself. */ if stream_data_block.graphic then if binary (inchar, 9) < 32 /* no problem with these, just send 'em out */ then outchar = inchar; else if (outchar = "602"b3) | (outchar = "600"b3) then outchar = inchar; /* don't mess up these, either */ /* go to enter; */ end; enter: mode = outchar; /* get shift code */ enchar = outchar & "177"b3; if mode = "11"b /* special action */ then do; if enchar = "001"b3 /* if mark error */ then do; stream_data_block.error_mark_column = col + 1; end; else if enchar = "002"b3 /* if escape */ then do; ereti = ereti + 1; /* set up recursion */ erets (ereti) = 10; outchar = escape_character_device; /* escape char */ goto enter; r (10): erets (ereti) = 11; /* set up return */ do escape_index = 1 to 9 by 3;/* pick off 3-bit bytes */ outchar = out (binary (substr (inchar, escape_index, 3), 3) + 48); goto enter; r (11): end; ereti = ereti - 1; go to r (erets (ereti)); end; else if enchar = "003"b3 /* Conditional New Line */ then do; if col > 0 then do; ereti = ereti + 1; erets (ereti) = 16; outchar = out (10); /* nl */ go to enter; r (16): ereti = ereti - 1; end; else last_line_start = last_line_start + 1; /* case...skip over CNL */ go to r (erets (ereti)); end; seqi = binary (enchar, 9) - 8; /* else it is a character sequence */ if seqi >= 0 then do; ereti = ereti + 1; erets (ereti) = 12; /* save return */ sequence_ptr = addrel (sequence_table_ptr, seqi); /* pointer to given sequence */ do seqi = 1 to sequence.size; outchar = sequence.characters (seqi); goto enter; r (12): end; ereti = ereti - 1; end; go to r (erets (ereti)); end; ei = binary (conversions.device_move (binary (enchar, 9)), 6); /* update col */ go to new_col (ei); new_col (0): /* normal */ col = col + 1; go to end_col; new_col (2): /* backspace */ col = col - 1; go to end_col; new_col (3): /* tab */ if stream_data_block.tab_width < 2 then col = col + 1; else col = col + stream_data_block.tab_width - mod (col, stream_data_block.tab_width); if max_col > 0 then if col > max_col then if max_col < stream_data_block.tab_width/* hmm. shouldn't be permitted. */ then go to r (erets (ereti)); go to end_col; new_col (4): /* carriage return */ initial_column, col = 0; go to end_col; new_col (5): /* new line */ stream_data_block.canonicalization_index = 1; /* don't need this stuff anymore */ last_line_start = ini; device_last_line_start = out_char + 1; if mode & shift /* KLUDGE: tables make NL lower-case, skip shift char */ then device_last_line_start = device_last_line_start + 1; initial_column, col = 0; actline = actline + 1; go to end_col; new_col (6): /* prefix */ col = col - 1; /* prefix */ go to end_col; new_col (10): /* 2 character sequences at device */ col = col + 2; new_col (1): new_col (7): new_col (8): new_col (9): end_col: if max_col > 3 /* don't loop */ then if col > max_col /* check for end of carriage */ then if col > 3 /* don't loop */ then do; oldoutchar = outchar; outchar = out (10); /* nl */ ereti = ereti + 1; erets (ereti) = 13; goto enter; r (13): n_delays = divide (nl_addend + binary (max_col, 9) * nl_multiplier, 512, 17, 0); call enter_delays (n_delays); outchar = escape_character_device; /* output escape char */ erets (ereti) = 14; goto enter; r (14): outchar = out (99); /* output 'c' */ erets (ereti) = 15; goto enter; r (15): ereti = ereti - 1; /* setup return */ outchar = oldoutchar; /* put original character */ goto enter; end; if mode & shift /* if shift needed */ then do; if out_char > length (write_buffer_overlay) then call flush_output_buffer; if mode & "01"b /* if char must be upper case */ then write_buffer (out_char) = device_info.upper_case; else write_buffer (out_char) = device_info.lower_case; out_char = out_char + 1; shift = ^mode; end; if out_char > length (write_buffer_overlay) then call flush_output_buffer; write_buffer (out_char) = enchar; /* store actual character */ out_char = out_char + 1; if binary (conversions.device_move (binary (enchar, 7)), 6) = 2 /* BS */ then do; n_delays = device_info.pad_info (baud_rate).bs_n_pads; if n_delays > 0 then if ^last_char_was_BS /* only pad first BS in a sequence */ then call enter_delays (n_delays); last_char_was_BS = "1"b; end; else last_char_was_BS = "0"b; go to r (erets (ereti)); enter_delays: procedure (P_n_delays); /* parameters */ declare P_n_delays fixed bin (21); /* automatic */ declare padx fixed bin (21); /* program */ if out_char + P_n_delays > length (write_buffer_overlay) then call flush_output_buffer; do padx = 1 to P_n_delays; write_buffer (out_char) = delay_character; out_char = out_char + 1; end; end enter_delays; flush_output_buffer: procedure (); call iox_$put_chars (stream_data_block.device_iocb_ptr, addr (write_buffer), out_char - 1, status_code); /* If sdb.read_back = read_back_output, and output does not end in new-line, save the partial output line in the input buffer so that the input the user types will be read back in and re-canonicalized. If sdb.read_back = read_back_spaces, substitute spaces for the actual characters, at the rate of one space per column of output, no matter how many characters it took. Since spaces have been converted to tabs, and delay characters have been inserted, the number of characters output is not relevant. If sdb.read_back = read_back_input, skip this operation. */ if last_line_start < length (data_string) /* if output does not end in NL */ then if read_back ^= read_back_input then do; if read_back = read_back_output then do; i = (out_char - 1) - device_last_line_start + 1; substr (canonicalization_buffer, canonicalization_index, i) = substr (write_buffer_overlay, device_last_line_start, i); end; else do; /* read back spaces */ i = col - initial_column; if i > 0 then unspec (substr (canonicalization_buffer, canonicalization_index, i)) = copy (out (32), i); /* "i" spaces */ end; canonicalization_index = max (1, canonicalization_index + i); /* i can be negative */ end; device_last_line_start, out_char = 1; return; end flush_output_buffer; end /* apl_dim_write_ */;  apl_directory_commands_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 65196 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_directory_commands_: procedure (command_name, argument); /* * this module contains miscellaneous APL commands dealing with directories. * currently the ")LIB", ")LIBD", ")V1LIB", ")V1DROP", and ")DROP" commands are included. * written 73.9.15 by DAM * Modified 741009 by PG to use ioa_$ioa_stream, and add )V1LIB. * Modified 770113 by PG to add )V1DROP. Modified 781208 by PG to switch to clock builtin */ /* parameters */ dcl command_name char (4) aligned parameter, /* name of command to be executed */ argument char (*) parameter; /* the argument to the command (a wsid) */ /* automatic */ dcl wsid char (168), dname char (168), ename char (32), fcbp pointer, code fixed bin (35), date_time_used fixed bin (71), date_time_modified fixed bin (71), v1 bit (1) aligned; /* builtins */ dcl (addr, before, clock, fixed, null, unspec) builtin; /* entries */ dcl ioa_$ioa_stream entry options (variable), apl_print_string_ entry (char (*)), apl_print_newline_ entry, apl_flush_buffer_ entry, (apl_translate_pathname_, apl_translate_pathname_$allow_version_one) entry (char (*), char (*), char (*), pointer, fixed bin (35)), apl_date_time_ entry (fixed bin (71)) returns (char (17)), com_err_ entry options (variable), msf_manager_$close entry (pointer), delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)), get_wdir_ entry returns (char (168)aligned), hcs_$star_ entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35)), get_system_free_area_ entry returns (pointer), freen_ entry (pointer); /* required because hardcode won't say how many Names */ /* conditions */ dcl cleanup condition; /* external static */ dcl error_table_$nomatch fixed bin (35) external; /* internal static */ dcl apl_output_stream char (11) internal static initial ("apl_output_"); dcl suffix char (7) varying; dcl eptr pointer, nptr pointer, ecount fixed bin, e_x fixed bin, n_x fixed bin, nct fixed bin, Names (100 /* or so */ ) char (32) based (nptr), 1 Entries (ecount) based (eptr) aligned, 2 ( type bit (2), nnames bit (16), nindex bit (18)) unaligned; /* dispatch on command_name */ if command_name = "drop" then do; v1 = "0"b; go to drop; end; else if command_name = "v1dr" then do; v1 = "1"b; go to drop; end; else if command_name = "lib " then go to lib; else if command_name = "libd" then go to libd; else if command_name = "v1li" then go to v1lib; else return; /* random error, not too serious so just ignore */ drop: /* )DROP */ if argument ^= "" then wsid = argument; else wsid = ws_info.wsid; if wsid = "clear ws" then do; call ioa_$ioa_stream (apl_output_stream, "not dropped, this ws is clear ws"); return; end; if v1 then call apl_translate_pathname_$allow_version_one (wsid, dname, ename, fcbp, code); else call apl_translate_pathname_ (wsid, dname, ename, fcbp, code); if code ^= 0 then do; bad_code: call com_err_ (code, "apl", "^a>^a", dname, ename); /* tell loser that he lost */ return; end; call msf_manager_$close (fcbp); /* we didn't really want it opened anyway */ call delete_$path (dname, ename, "100111"b, "", code); if code ^= 0 then go to bad_code; call ioa_$ioa_stream (apl_output_stream, "^a", apl_date_time_ (clock ())); return; lib: libd: v1lib: /* commands to list directories - libd also gives dates */ if argument = "" then dname = get_wdir_ (); else do; call apl_translate_pathname_ (argument, dname, (""), fcbp, code); /* "" as ename says I want a directory */ if code ^= 0 then do; /* not there fail - fails later if there but not dir. */ ename = ""; /* get better looking error message (slightly) */ go to bad_code; end; end; if command_name ^= "v1li" then do; ename = "**.sv.apl"; suffix = ".sv.apl"; end; else do; ename = "*.apl"; suffix = ".apl"; end; nptr, eptr = null; on cleanup call cleanup_proc; call hcs_$star_ (dname, ename, 3, get_system_free_area_ (), ecount, eptr, nptr, code); if code = error_table_$nomatch then go to empty_directory; if code ^= 0 then go to bad_code; /* OK, produce the directory listing */ if command_name = "libd" then /* put headings if long listing */ call ioa_$ioa_stream (apl_output_stream, "^5xname^3-^4xdate used^-^4xdate saved^/"); do e_x = 1 by 1 while (e_x <= ecount); /* process each entry */ n_x = fixed (Entries (e_x).nindex, 18); /* index of first name for entry */ if command_name = "libd" then do; /* if long format, make line of listing */ ename = Names (n_x); call get_date_time_modified; call ioa_$ioa_stream (apl_output_stream, "^30a^20a^a", before (ename, suffix), apl_date_time_ (date_time_used), apl_date_time_ (date_time_modified)); do nct = fixed (Entries (e_x).nnames, 16) by -1 while (nct > 1); /* do auxiliary names */ n_x = n_x + 1; call ioa_$ioa_stream (apl_output_stream, "^a", before (Names (n_x), suffix)); end; end; else do; /* normal )LIB listing */ do nct = fixed (Entries (e_x).nnames,16) by -1 while (nct > 0); call apl_print_string_ (before (Names (n_x), suffix)); n_x = n_x + 1; end; end; end; /* Listing has been produced - clean up */ if command_name = "libd" then call ioa_$ioa_stream (apl_output_stream, ""); else do; call apl_print_newline_; call apl_flush_buffer_; end; call cleanup_proc; return; empty_directory: call ioa_$ioa_stream (apl_output_stream, "no workspaces"); return; cleanup_proc: procedure; if nptr ^= null then call freen_ (nptr); if eptr ^= null then call freen_ (eptr); end cleanup_proc; get_date_time_modified: procedure; /* sets date_time_modified to the dtm for dname>ename */ dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), pointer, pointer, fixed bin (35)), be_sure_to_chase_links fixed bin (1) static init (1), 1 branch_info aligned automatic structure, /* return data from status_ */ 2 ( type bit (2), nnames bit (16), nrp bit (18), dtm bit (36), dtu bit (36), mode bit (5), padding bit (13), records bit (18)) unaligned; call hcs_$status_ (dname, ename, be_sure_to_chase_links, addr (branch_info), null, code); if code ^= 0 then dtm, dtu = (36)"0"b; /* if no status permission on entry, return the year one */ code = 0; unspec (date_time_modified) = (20)"0"b || dtm || (16)"0"b; /* unpack kludgey file-system time */ unspec (date_time_used) = (20)"0"b || dtu || (16)"0"b; /* .. */ end get_date_time_modified; /* include files */ %include apl_ws_info; %include apl_number_data; end;  apl_domino_operator_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 130815 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_domino_operator_: procedure (operators_argument); /* * this routine performs the monadic and dyadic domino (matrix-invert, least squares). * * written 73.9.11 by DAM based on a procedure by Max Smith * completely rewritten 73.10.8 by DAM to use LU decomposition * Modified 741015 by PG to reduce precision of subscripts to get better code. * Modified 750326 by PG to fix bug 209 causing random WS FULL errors. * Modified 760903 by PG to fix bug 227 causing domino to return incorrect numbers. * Modified 760905 by PG to fix bug that caused dyadic usage to fail if the equations were permuted. * Modified 770303 by PG to fix bug 269 (inverting singular matrices w/o error msg) by adding * code to scan the diagonal of U looking for zeroes. Modified 771110 by PG to fix bug 293 by setting up our own underflow handler...since apl's seems to be broken. Modified 771130 by PG to remove our own underflow handler, now that apl's works again. Modified 771205 by PG to permute AtA completely before performing decomposition, thus fixing bug 294 causing Hilbert (and other ill-conditioned) matrices to fail. Modified 771221 by PG to increase precision of result when A is square by not multiplying through by At. Modified 790411 by William M. York to allocate temporaries on the APL value stack instead of the Multics stack, avoiding storage conditions. Modified 810125 by WMY to fix bug 481, the shape of the result is incorrect when the operand is on the stack. Modified 811211 by TO to correct pivoting algorithm. Modified 811211 by TO to correct stack allocation problem. */ /* description of the algorithm let A be the right operand, B be the left operand. If used monadically, B is identity matrix of appropriate size We solve T T (A A) X = A B for X. We check for singularity by enabling the overflow and zerodivide conditions, and by checking the diagonal of the decomposition of AtA. We do use "partial pivoting" and scaling. The algorithm has not been particularly optimized for speed. Much better code could be produced by zero-origin indexing. The major variables are: A right operand B left operand At A-transpose, isub defined on A. AtA the computed product of At and A AtB the computed product of At and B LU the L-U triangular decomposition of AtA,[1]AtB X the answer H first part of rho A, kept in times-reduced form U last element of rho A T last part of rho B, in times-reduced form. rho B is H|T. T may be empty Note this is a slight generalization of IBM's domino, in that arrays of equations may be solved. Note: The APL/SV extensions to accept vectors as column matrices, and scalars as 1x1 matrices, have been included. The reference for the algorithm implemented here is: "Applied Linear Algebra," Ben Noble, Prentice Hall, 1969. Pages 142ff describe the generalized inverse of a nonsquare matrix. Pages 216ff describe the LU decomposition algorithm used here. No library of books on computerized algorithms for matrix manipulation would be complete without: "Computer Solution of Linear Algebraic Systems," George Forsythe and Cleve B. Moler, Prentice Hall, 1967. This book has an excellent treatment of the computational problems that occur, such as round-off, finite precision, and treatment of nearly-singular matrices. */ /* automatic */ declare (H, T, U) fixed bin (17), /* maximum number of elements/dimension is 2**17 */ (rhoH, rhoT) fixed bin, rhoU fixed bin static init (1); dcl right_vb pointer, right pointer, left_vb pointer, left pointer, final_result_vb pointer, final_result pointer, end_of_operands pointer, saved_stack_ptr pointer; dcl i fixed bin (21), (colx, j, joinx, rowx) fixed bin (17), data_elements fixed bin (17), result_rhorho fixed bin, n_words fixed bin (19), monadic bit (1) aligned, (z, zz) float, pivot float, the_max float, pivot_row fixed bin (17), pivot_col fixed bin (17); dcl A dim (H, U) float based (right), B dim (H, T) float based (left), AtA dim (U, U) float based (AtA_ptr), AtB dim (U, T) float based (AtB_ptr), LU dim (U, U+T) float based (LU_ptr), X dim (U, T) float based (X_ptr), permute dim (U) fixed bin (17) based (permute_ptr), (AtA_ptr, AtB_ptr, LU_ptr, X_ptr, permute_ptr) pointer; /* external static */ dcl (apl_error_table_$domain, apl_error_table_$length, apl_error_table_$rank) fixed bin (35) external; /* builtins */ dcl (abs, addr, addrel, hbound, null, rel, size, string, substr) builtin; /* conditions */ dcl (overflow, zerodivide) condition; /* include files */ %include apl_number_data; %include apl_ws_info; %include apl_operators_argument; %include apl_bead_format; %include apl_value_bead; /* save stack height and pick up arguments. determine whether monadic or dyadic */ right_vb = operands (2).value; right = right_vb -> value_bead.data_pointer; left_vb = operands (1).value; if left_vb = null then monadic = "1"b; else do; monadic = "0"b; /* dyadic */ left = left_vb -> value_bead.data_pointer; end; if operands (2).on_stack then final_result_vb = right_vb; /* where to leave result value_bead */ else if ^monadic & operands (1).on_stack then final_result_vb = left_vb; else final_result_vb = value_stack_ptr; /* make checks for errors and compute the parameters H, T, and U from the arguments' rhos */ if ^ right_vb -> value_bead.data_type.numeric_value then go to domain_error_right; rhoH = right_vb -> value_bead.rhorho - 1; if rhoH < 0 then rhoH = 0; if right_vb -> value_bead.rhorho > 1 then U = right_vb -> value_bead.rho (rhoH+1); else if right_vb -> value_bead.rhorho = 1 then do; /* accept vector as column matrix */ U = right_vb -> value_bead.rho (1); H = 1; go to special_H; end; else do; /* accept scalar as 1x1 matrix */ U, H = 1; go to special_H; end; H = right_vb -> value_bead.rho (1); do i = 2 by 1 while (i <= rhoH); H = H * right_vb -> value_bead.rho (i); end; if H > 131072 then go to domain_error_right; if H < U then go to domain_error_right; special_H: if ^monadic then do; /* check left operand */ if ^ left_vb -> value_bead.data_type.numeric_value then go to domain_error_left; if left_vb -> value_bead.rhorho = 0 then do; /* APL/SV extension: accept scalar as 1-long vector here */ if H ^= 1 then go to length_error; rhoT = 1; T = 1; go to special_T; end; if left_vb -> value_bead.rhorho < rhoH then go to rank_error_left; do i = 1 by 1 while (i <= rhoH); if left_vb -> value_bead.rho (i) ^= right_vb -> value_bead.rho (i) then go to length_error; /* both rhos must start with H */ end; rhoT = 0; T = 1; do i = i by 1 while (i <= left_vb -> value_bead.rhorho); T = T * left_vb -> value_bead.rho (i); rhoT = rhoT + 1; end; /* picks up rest of rho of B in T */ special_T: end; if monadic then do; result_rhorho = right_vb -> value_bead.rhorho; /* normally rhoU + rhoH */ T = H; data_elements = U * H; end; else do; result_rhorho = rhoU + rhoT; if left_vb -> value_bead.rhorho = 0 then result_rhorho = result_rhorho - 1; /* fudge rank for scalar args */ if right_vb -> value_bead.rhorho = 0 then result_rhorho = result_rhorho - 1; /* .. */ data_elements = U * T; end; /* prepare space in stack for result. Don't write in it yet since may overlay operands */ end_of_operands = ws_info.value_stack_ptr; /* remember end of operand area */ ws_info.value_stack_ptr = final_result_vb; /* pop operands */ number_of_dimensions = result_rhorho; n_words = size (value_bead) + size (numeric_datum) + 1; final_result_vb = apl_push_stack_ (n_words); final_result = addr (final_result_vb -> value_bead.rho (result_rhorho+1)); if substr (rel (final_result), 18, 1) /* double word align these numbers */ then final_result = addrel (final_result, 1); /* begin block here to declare At, so it can be defined on A */ begin; dcl At dim (U, H) float defined (A (2sub, 1sub)); /* Allocate temporary storage for computations */ saved_stack_ptr = ws_info.value_stack_ptr; if rel (end_of_operands) > rel (ws_info.value_stack_ptr) then /* don't overlay operands */ ws_info.value_stack_ptr = end_of_operands; AtA_ptr = apl_push_stack_ (size (AtA)); AtB_ptr = apl_push_stack_ (size (AtB)); LU_ptr = apl_push_stack_ (size (LU)); X_ptr = apl_push_stack_ (size (X)); permute_ptr = apl_push_stack_ (size (permute)); /* set up condition handlers to detect singularity */ on overflow, zerodivide go to singularity; /* compute AtB, using identity for B if monadic */ if ^monadic then if H = U then do rowx = 1 to U; /* dyadic, square case. */ do colx = 1 to T; AtB (rowx, colx) = B (rowx, colx); end; end; else do rowx = 1 to U; /* dyadic, nonsquare case. */ do colx = 1 to T; z = 0.0e0; do joinx = 1 to H; z = z + At (rowx, joinx) * B (joinx, colx); end; AtB (rowx, colx) = z; end; end; else if H = U then do rowx = 1 to U; /* monadic, square case */ do colx = 1 to T; if rowx = colx then AtB (rowx, colx) = 1e0; else AtB (rowx, colx) = 0e0; end; end; else do rowx = 1 to U; /* monadic, nonsquare case */ do colx = 1 to T; AtB (rowx, colx) = At (rowx, colx); end; end; /* compute AtA */ if H = U then do rowx = 1 to U; /* square case */ do colx = 1 to U; AtA (rowx, colx) = A (rowx, colx); end; end; else do rowx = 1 to U; /* nonsquare case */ do colx = 1 to U; z = 0.0e0; do joinx = 1 to H; z = z + At (rowx, joinx) * A (joinx, colx); end; AtA (rowx, colx) = z; end; end; /* 1) Initialize permute vector, which controls re-ordering of equations (rows) of AtA and AtB. 2) Scale AtA and AtB so that the largest element in any row is of magnitude 1. */ do rowx = 1 to U; permute (rowx) = rowx; the_max = abs (AtA (rowx, 1)); do colx = 2 to U; z = abs (AtA (rowx, colx)); /* assign to temp only to get better code */ if z > the_max then the_max = z; end; do colx = 1 to T; z = abs (AtB (rowx, colx)); /* .. */ if z > the_max then the_max = z; end; AtA (rowx, *) = AtA (rowx, *) / the_max; AtB (rowx, *) = AtB (rowx, *) / the_max; end; do pivot_col = 1 to U; /* translform one row of AtA to LU */ do colx = 1 to U; z = AtA (permute (colx), pivot_col); do j = 1 by 1 while (j abs (pivot) then do; pivot = (LU (permute (j), pivot_col)); pivot_row = j; end; end; /* swap the indices */ i = permute (pivot_col); permute (pivot_col) = permute (pivot_row); permute (pivot_row) = i; /* check singular matrix */ /* If any of the diagonal elements of U are zero, AtA is singular. (The product of the diagonal elements of U is the determinant). */ if abs (pivot) < ws_info.integer_fuzz then go to domain_error_right; /* transform the pivot column to LU */ do j = pivot_col+1 by 1 while (j <= U); LU (permute (j), pivot_col) = LU (permute (j), pivot_col)/pivot; end; /* transform the pivot row of AtB to LU */ do colx = U+1 to hbound (LU, 2); z = AtB (permute (pivot_col), colx - U); do j = 1 by 1 while (j < pivot_col); z = z - LU (permute (j), colx) * LU (permute (pivot_col), j); end; LU (permute (pivot_col), colx) = z; end; end; do rowx = U by -1 to 1; /* compute answer by back substitution */ do colx = 1 to T; /* uses only the U portion of LU */ z = LU (permute (rowx), U+colx); do j = rowx+1 to U; z = z - LU (permute (rowx), j) * X (j, colx); end; X (rowx, colx) = z / LU (permute (rowx), rowx); end; end; /* iterative improvement */ /* TO BE SUPPLIED - requires proceduring of some of the above code. */ end; /* the begin block for At */ /* fill rho vector of the result. Careful inspection and consideration of all cases reveals that we will never over-write an operand's rho before we copy into result's rho! */ do i = result_rhorho by -1 to 2; if monadic then final_result_vb -> value_bead.rho (i) = right_vb -> value_bead.rho (i-1); else final_result_vb -> value_bead.rho (i) = left_vb -> value_bead.rho (rhoH+i-1); end; if result_rhorho >= 1 /* fudge for scalar arg */ then final_result_vb -> value_bead.rho (1) = U; string (final_result_vb -> value_bead.type) = numeric_value_type; final_result_vb -> value_bead.rhorho = result_rhorho; final_result_vb -> value_bead.total_data_elements = data_elements; final_result_vb -> value_bead.data_pointer = final_result; /* copy from automatic storage into APL stack (data_elements is still set) */ final_result -> numeric_datum (*) = addr (X) -> numeric_datum (*); operators_argument.result = final_result_vb; /* Free temporary storage. */ ws_info.value_stack_ptr = saved_stack_ptr; return; /* error exits */ domain_error_right: operators_argument.where_error = operators_argument.where_error - 2; domain_error_left: operators_argument.where_error = operators_argument.where_error + 1; singularity: operators_argument.error_code = apl_error_table_$domain; return; length_error: operators_argument.error_code = apl_error_table_$length; return; rank_error_left: operators_argument.where_error = operators_argument.where_error + 1; operators_argument.error_code = apl_error_table_$rank; return; %include apl_push_stack_fcn; end; /* apl_domino_operator_ */  apl_dyadic_bool_appendage_.alm 11/29/83 1637.3rew 11/29/83 1346.3 31230 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " apl_dyadic_bool_appendage_ -- fast boolean operations on boolean values " " Benson I. Margulies February 80. " name apl_dyadic_bool_appendage_ segdef and,or,eq,nand,nor,neq " " faster versions of dyadic and or nand nor equal(nxor) nequal(xor) " these all depend on the internal representation of floating point values " " " calling sequence: " declare apl_dyadic_bool_appendage_$XXX entry (ptr, ptr, ptr, fixed bin (21) aligned); " call apl_dyadic_bool_appendage_$XXX (lptr, rptr, rsptr, count); " " lptr first arg array " rptr second arg array " rsptr result array " count number of elements to process " " General strategy: for AND, OR, NAND, and NOR, we need never " load the arguments. we can set the indicators -- for OR, " if first is 1 then stop & store 1, else check second " for AND, if first is zero, store zero, else check second. " for eq / neq things are similar. bool fzero,400000 " top 18 bits of a floating-point zero. bool fone,002400 " top 18 bits of a floating-point one. " " SETUP. Subroutine to setup registers from arguments. " " Usage: " tsx3 setup " setup: lda pr0|8,* " count => a als 1 " (count) * 2 is offset of last value in vectors (points to second word) eax1 0,al " hide it in x1 for limit epp3 pr0|2,* " ptr to ptr to first argument epp3 pr3|0,* epp4 pr0|4,* " ptr to ptr to second argument epp4 pr4|0,* epp5 pr0|6,* " ptr to ptr to result epp5 pr5|0,* lda fzero,du " zero in a ldq fone,du " and one in q tra 0,x3 " back to where you left it " " AND. First zero stores zero. " and: tsx3 setup eax2 and_loop and_loop: szn pr3|-2,x1 " L=0? tmi return_zero " yes szn pr4|-2,x1 " R=0? tmi return_zero " yes tra return_one " neither " " NAND. First zero stores one. " nand: tsx3 setup eax2 nand_loop nand_loop: szn pr3|-2,x1 " L=0? tmi return_one " yes szn pr4|-2,x1 " R=0? tmi return_one " yes tra return_zero " neither " " OR. First one stores one. " or: tsx3 setup eax2 or_loop or_loop: szn pr3|-2,x1 " L=1? tpl return_one " yes szn pr4|-2,x1 " R=1? tpl return_one " yes tra return_zero " neither " " NOR. First one stores zero. " nor: tsx3 setup eax2 nor_loop nor_loop: szn pr3|-2,x1 " L=1? tpl return_zero " yes szn pr4|-2,x1 " R=1? tpl return_zero " yes tra return_one " neither " " EQUAL. " eq: tsx3 setup eax2 eq_loop eq_loop: szn pr3|-2,x1 " L=1? tpl try_one " yes try_zero: szn pr4|-2,x1 " (L=0), R=0? tmi return_one " yes tra return_zero " no try_one: szn pr4|-2,x1 " (L=1), R=1? tpl return_one " yes tra return_zero " no " " NOT EQUAL. " neq: tsx3 setup eax2 neq_loop neq_loop: szn pr3|-2,x1 " L=0? tmi try_one " yes tra try_zero " no " " BOTTOM OF LOOP. Store a zero or one, and go around again. " return_zero: sta pr5|-2,x1 " store the top half of a zero tra around return_one: stq pr5|-2,x1 " store the top half of a one around: stz pr5|-1,x1 " put out zero second word eax1 -2,x1 " bump to previous value. tpnz 0,x2 " go to appropriate loop short_return end  apl_dyadic_ibeam_.pl1 11/29/83 1637.3rew 11/29/83 1346.3 8307 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_dyadic_ibeam_: procedure (operators_argument); /* Dummy procedure to turn these unimplemented operators into errors */ /* PG 740625 */ /* Modified 781109 by PG to remove trap for format operators */ /* external static */ declare apl_error_table_$not_implemented fixed bin (35) external static; /* include files */ %include apl_operators_argument; /* program */ operators_argument.error_code = apl_error_table_$not_implemented; return; end;  apl_dyadic_iota_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 56637 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* This program implements the dyadic, mixed operators iota and epsilon. Written by R.S.Lamson, Summer, 1973. Modified by PG on 740909 for new value bead declaration, positioning error marker, and proper handling of the value stack and fuzz. Modified 780209 by PG to use apl_push_stack_ (bug 278). */ apl_dyadic_iota_: procedure (operators_argument); from_vb = operators_argument.operands (2).value; into_vb = operators_argument.operands (1).value; data_elements = from_vb -> value_bead.total_data_elements; if into_vb -> value_bead.rhorho ^= 1 then go to left_argument_not_vector; if operators_argument.operands (2).on_stack & from_vb -> value_bead.numeric_value then result_vb = from_vb; else call allocate_result; internal_op_code = internal_iota_code; match_site = iota_match_site; non_match_site = iota_non_match_site; go to joined_code; apl_dyadic_epsilon_: entry (operators_argument); from_vb = operators_argument.operands (1).value; into_vb = operators_argument.operands (2).value; data_elements = from_vb -> value_bead.total_data_elements; if operators_argument.operands (1).on_stack & from_vb -> value_bead.numeric_value then result_vb = from_vb; else call allocate_result; internal_op_code = internal_epsilon_code; match_site = epsilon_match_site; non_match_site = epsilon_non_match_site; joined_code: from = from_vb -> value_bead.data_pointer; into = into_vb -> value_bead.data_pointer; result = result_vb -> value_bead.data_pointer; if into_vb -> value_bead.total_data_elements = 0 then go to never_match; if from_vb -> value_bead.character_value then if into_vb -> value_bead.character_value then comparison_site = character_comparison_site; else go to never_match; else if from_vb -> value_bead.numeric_value then if into_vb -> value_bead.numeric_value then comparison_site = numeric_comparison_site; else go to never_match; else go to no_type_bits; do from_subscript = 0 by 1 while (from_subscript < from_vb -> value_bead.total_data_elements); do into_subscript = 0 by 1 while (into_subscript < into_vb -> value_bead.total_data_elements); go to comparison_site; character_comparison_site: if from -> character_datum (from_subscript) = into -> character_datum (into_subscript) then go to match_site; else go to next_comparison; numeric_comparison_site: if from -> numeric_datum (from_subscript) = into -> numeric_datum (into_subscript) then go to match_site; else if abs (from -> numeric_datum (from_subscript) - into -> numeric_datum (into_subscript)) < abs (ws_info.fuzz * (from -> numeric_datum (from_subscript) + into -> numeric_datum (into_subscript))) then go to match_site; next_comparison: end; go to non_match_site; iota_match_site: /* iota match */ iota_non_match_site: /* iota mismatch. happens to work because subscript is right coming out of loop and is more efficient than using value_bead.rho */ result -> numeric_datum (from_subscript) = float (into_subscript + ws_info.index_origin); go to next_element; epsilon_match_site: /* epsilon match */ result -> numeric_datum (from_subscript) = 1.0e0; go to next_element; epsilon_non_match_site: /* epsilon mismatch */ result -> numeric_datum (from_subscript) = 0.0e0; next_element: end; go to return_point; never_match: if internal_op_code = internal_iota_code then value = float (into_vb -> value_bead.total_data_elements + ws_info.index_origin); else value = 0.0e0; do from_subscript = 0 by 1 while (from_subscript < data_elements); result -> numeric_datum (from_subscript) = value; end; return_point: if internal_op_code = internal_iota_code then string (result_vb -> value_bead.type) = integral_value_type; else string (result_vb -> value_bead.type) = zero_or_one_value_type; operators_argument.result = result_vb; return; left_argument_not_vector: operators_argument.error_code = apl_error_table_$iota_argument_not_vector; operators_argument.where_error = operators_argument.where_error + 1; return; no_type_bits: operators_argument.error_code = apl_error_table_$no_type_bits; return; allocate_result: procedure(); number_of_dimensions = from_vb -> value_bead.rhorho; n_words = size (value_bead) + size (numeric_datum) + 1; result_vb = apl_push_stack_ (n_words); result_vb -> value_bead.total_data_elements = from_vb -> value_bead.total_data_elements; result_vb -> value_bead.rhorho = from_vb -> value_bead.rhorho; do from_subscript = 1 to from_vb -> value_bead.rhorho; result_vb -> value_bead.rho (from_subscript) = from_vb -> value_bead.rho (from_subscript); end; result_vb -> value_bead.data_pointer = addr (result_vb -> value_bead.rho (number_of_dimensions + 1)); if substr (rel (result_vb -> value_bead.data_pointer), 18, 1) then result_vb -> value_bead.data_pointer = addrel (result_vb -> value_bead.data_pointer, 1); end allocate_result; %include apl_push_stack_fcn; /* external static */ declare (apl_error_table_$iota_argument_not_vector, apl_error_table_$no_type_bits ) fixed binary (35) external static; /* automatic */ declare value float; declare (from_vb, into_vb, result_vb, from, into, result) pointer; declare (internal_op_code, data_elements, from_subscript, into_subscript) fixed binary (21); declare n_words fixed bin (19); declare (internal_iota_code initial (1), internal_epsilon_code initial (2)) fixed binary (21) internal static; declare (match_site, non_match_site, comparison_site) label local; /* builtin */ declare (abs, addr, addrel, fixed, float, mod, rel, size, string, substr) builtin; /* include files */ %include apl_number_data; %include apl_bead_format; %include apl_value_bead; %include apl_ws_info; %include apl_operators_argument; end apl_dyadic_iota_;  apl_editor_.pl1 11/29/83 1637.3rew 11/29/83 1346.3 655920 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* New version of the APL editor, written by William M. York, Summer 1979. */ /* Modified 791207 by wmy to fix bug 426 ([Nq0] editing doesn't work) and the following unreported bugs: 1) Hitting QUIT while in line-editing mode can leave you in read_back_output mode. 2) Attempting to edit a pendent function reports the error properly, but leaves you in the editor in an inconsistant state. 3) When the header is deleted [q] mis-numbers the lines. 4) [d0] will delete the header of a suspended function. 5) Function is renumbered after lex reports errors, but line number prompt is left as the old (sometimes no longer existing) line number. Modified 791217 by PG to fix bug whereby [Nq0] was rejected in a suspended function. Modified 800131 by PG to fix 442 (editor permitted user to add labels to a suspended fcn), and 435 (editor would not permit system variables in the header of a new fcn). Modified 800827 by WMY to add extensions to editor for context searching and substitution. Modified 810615 by WMY to add context_global_print and fix bugs */ apl_editor_: procedure (header_line, header_line_pos, code); dcl header_line char(*) parameter; dcl header_line_pos fixed bin(21) parameter; dcl code fixed bin(35) parameter; /* Automatic */ dcl input_buffer char(256); dcl input_line_length fixed bin(21); dcl character_pos fixed bin; dcl character char(1); dcl current_line_number fixed decimal (10, 5); dcl line_pos fixed bin; dcl (got_line, quit_force) bit(1) init ("0"b); dcl saved_search_string char(128) varying init(""); /* Internal Static */ dcl whitespace_NL_string char(3) internal static options (constant) init (" "); /* SPACE, TAB, NL */ /* Based */ dcl input_line char(input_line_length) based (addr (input_buffer)); /* External */ dcl (apl_error_table_$bad_function_header, apl_error_table_$extra_text) external fixed bin(35); dcl (cleanup, apl_quit_) condition; /* Entries */ dcl apl_create_save_frame_ entry (); dcl apl_segment_manager_$get entry () returns (pointer); dcl apl_command_$from_editor entry (char(*), fixed bin(21), fixed bin(35)); dcl (length, substr, verify) builtin; /* Include Files */ %include apl_number_data; %include apl_characters; %include apl_function_info; /* Program */ code = 0; function_info.first_unused_char_in_buffer = 1; function_info.locked_function = "0"b; function_info.suspended_function = "0"b; function_info.saved_stop_vector = null (); function_info.saved_trace_vector = null (); function_info.number_of_lines = 0; function_info.edit_buffer_ptr = apl_segment_manager_$get (); call apl_create_save_frame_; on cleanup call apl_editor_cleanup (function_info); character_pos = header_line_pos + 1; call open_function (header_line, character_pos, function_info); input_line_length = length (header_line) - character_pos + 1; input_line = substr (header_line, character_pos); character_pos = 1; current_line_number = function_info.line_info(function_info.number_of_lines).line_number + 1; /* All setup is done, we are ready to go */ on apl_quit_ goto internal_error_restart; do while ("1"b); got_line = "0"b; do while (^got_line); if character_pos > length (input_line) then do; /* This is the place where the error routine goes after reporting errors */ internal_error_restart: call prompt (current_line_number, function_info); call read_line (input_buffer, input_line_length); character_pos = 1; end; got_line = "1"b; line_pos = verify (substr (input_line, character_pos), whitespace_NL_string); if line_pos > 0 then character_pos = character_pos + line_pos - 1; else do; character_pos = length (input_line) + 1; got_line = "0"b; end; end; /* do while (^got_line) */ /* Could be del line, bracket line, APL command line, or new line of function. */ character = substr (input_line, character_pos, 1); if character = QDel | character = QDelTilde then do; if quit_force then call apl_editor_cleanup (function_info); if character = QDelTilde then function_info.locked_function = "1"b; else function_info.locked_function = "0"b; character_pos = character_pos + 1; if character_pos < length (input_line) then call error (apl_error_table_$extra_text, input_line, character_pos); call close_function (function_info, current_line_number, code); if code = 0 then call apl_editor_cleanup (function_info); else if code ^= apl_error_table_$bad_function_header then do; quit_force = "1"b; call error (0, "", 0); end; end; else do; quit_force = "0"b; if character = QLeftBracket then call process_bracket_contents (input_buffer, input_line_length, character_pos, current_line_number, function_info); else if character = QRightParen then do; call apl_command_$from_editor (input_line, (character_pos), code); character_pos = length (input_line) + 1; end; else if character = QPeriod then call context_editor (input_buffer, input_line_length, character_pos, current_line_number, function_info, saved_search_string); else do; call process_new_function_line (input_line, character_pos, current_line_number, function_info); current_line_number = increment_line_number (current_line_number); end; end; /* else do */ end; /* do forever */ apl_editor_return_point: return; open_function: procedure (header_line, character_pos, function_info); dcl header_line char(*) parameter; dcl character_pos fixed bin parameter; %include apl_function_info; /* Automatic */ dcl (header_start, header_length) fixed bin; dcl complicated_header bit(1); dcl last_frame_was_suspended bit(1); dcl function_bead_ptr pointer; dcl lexed_function_bead_ptr pointer; dcl parse_frame_ptr pointer; /* External */ dcl (apl_error_table_$complicated_header_line, apl_error_table_$non_function_edited, apl_error_table_$locked_function_edited, apl_error_table_$external_function_edited, apl_error_table_$pendent_function_edited) fixed bin(35) external; /* Entries */ dcl apl_get_symbol_ entry (char(*), pointer unaligned, fixed bin); /* Include Files */ %include apl_ws_info; %include apl_bead_format; %include apl_operator_bead; %include apl_symbol_bead; %include apl_function_bead; %include apl_lexed_function_bead; %include apl_parse_frame; /* Program */ call parse_header_line (header_line, character_pos, header_start, header_length, complicated_header, function_info); /* Lookup function name */ call apl_get_symbol_ ((function_info.name), function_info.symbol_ptr, (0)); /* If we just created the symbol_bead, hang on to it, otherwise decrement it. */ if function_info.symbol_ptr -> symbol_bead.reference_count > 1 then call decrement_reference_count (function_info.symbol_ptr); function_bead_ptr = function_info.symbol_ptr -> symbol_bead.meaning_pointer; if function_bead_ptr ^= null() then do; if complicated_header then call report_error (apl_error_table_$complicated_header_line, header_line, header_start); if ^(function_bead_ptr -> function_bead.function) then do; call report_error (apl_error_table_$non_function_edited, header_line, header_start); call apl_editor_cleanup (function_info); end; if function_bead_ptr -> function_bead.class = 1 then do; call report_error (apl_error_table_$locked_function_edited, header_line, header_start); call apl_editor_cleanup (function_info); end; else if function_bead_ptr -> function_bead.class ^= 0 then do; call report_error (apl_error_table_$external_function_edited, header_line, header_start); call apl_editor_cleanup (function_info); end; lexed_function_bead_ptr = function_bead_ptr -> function_bead.lexed_function_bead_pointer; if lexed_function_bead_ptr ^= null () then do parse_frame_ptr = ws_info.current_parse_frame_ptr repeat (parse_frame_ptr -> parse_frame.last_parse_frame_ptr) while (parse_frame_ptr ^= null()); if parse_frame.parse_frame_type = suspended_frame_type then last_frame_was_suspended = "1"b; else do; if parse_frame.parse_frame_type = function_frame_type then if parse_frame.lexed_function_bead_ptr = lexed_function_bead_ptr then if ^last_frame_was_suspended then do; /* Not allowed to edit pendent functions, punt */ call report_error (apl_error_table_$pendent_function_edited, header_line, header_start); call apl_editor_cleanup (function_info); end; else function_info.suspended_function = "1"b; last_frame_was_suspended = "0"b; end; /* else do */ end; /* do parse_frame_ptr */ call assign_line_numbers (function_info); end; /* if function_bead_ptr ^= null () */ else do; call make_new_function (function_info, substr (header_line, header_start, header_length)); call assign_line_numbers (function_info); end; return; end; /* open_function */ close_function: procedure (function_info, current_line_number, code); %include apl_function_info; dcl current_line_number fixed decimal(10, 5) parameter; dcl code fixed bin(35) parameter; /* Automatic */ dcl character_pos fixed bin; dcl line_count fixed bin; dcl reported_si_damage bit (1) aligned; dcl scratch_space_ptr pointer; dcl function_bead_ptr pointer unaligned; dcl lexed_function_bead_ptr pointer unaligned; dcl function_name char(32) varying; dcl parse_frame_ptr pointer; dcl data_elements fixed bin; dcl last_frame_was_suspended bit(1); dcl bad_header bit(1); dcl lex_errors_occurred bit(1) aligned; /* Static */ dcl unlocked_message char(28) static options (constant) init ("function has been unlocked. "); /* Based */ dcl edit_buffer char(4 * sys_info$max_seg_size) based (function_info.edit_buffer_ptr); /* External */ dcl sys_info$max_seg_size external fixed bin; dcl apl_static_$apl_output external pointer; dcl apl_error_table_$bad_function_header external fixed bin(35); dcl apl_error_table_$edited_pendent_fcn external fixed bin (35); dcl (size, substr, string, null, lbound, addrel, divide) builtin; /* Entries */ dcl apl_allocate_words_ entry (fixed bin(24), pointer unaligned); dcl apl_function_lex_ entry (char(*) aligned, ptr unaligned, bit(1) aligned, fixed bin(24), ptr); dcl apl_get_symbol_ entry (char(*), pointer unaligned, fixed bin); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* Include Files */ %include apl_ws_info; %include apl_bead_format; %include apl_operator_bead; %include apl_symbol_bead; %include apl_function_bead; %include apl_lexed_function_bead; %include apl_parse_frame; /* Program */ code = 0; data_elements = 0; do line_count = lbound (function_info.line_info, 1) to function_info.number_of_lines; data_elements = data_elements + function_info.line_info(line_count).line_length; end; call apl_allocate_words_ (size (function_bead), function_bead_ptr); string (function_bead_ptr -> function_bead.type) = function_type; function_bead_ptr -> function_bead.text_length = data_elements; character_pos = 1; do line_count = lbound (function_info.line_info, 1) to function_info.number_of_lines; substr (function_bead_ptr -> function_bead.text, character_pos, function_info.line_info(line_count).line_length) = substr (edit_buffer, function_info.line_info(line_count).line_start, function_info.line_info(line_count).line_length); character_pos = character_pos + function_info.line_info(line_count).line_length; end; scratch_space_ptr = addrel (function_info.edit_buffer_ptr, divide (function_info.first_unused_char_in_buffer + 3, 4, 17, 0)); call apl_function_lex_ (function_bead_ptr -> function_bead.text, lexed_function_bead_ptr, lex_errors_occurred, 0, scratch_space_ptr); function_bead_ptr -> function_bead.lexed_function_bead_pointer = lexed_function_bead_ptr; if lex_errors_occurred then do; code = -1; if function_info.locked_function then do; function_bead_ptr -> function_bead.class = 0; function_info.locked_function = "0"b; call iox_$put_chars (apl_static_$apl_output, addr (unlocked_message), length (unlocked_message), code); end; /* Find out if header is valid, and if so hack the meaning pointer to save the function definition. */ call parse_function_name_and_args (substr (edit_buffer, function_info.line_info(1).line_start, function_info.line_info(1).line_length), 1, (0), function_name, (""), (""), (""), ("0"b), ("0"b), bad_header); if bad_header then do; code = apl_error_table_$bad_function_header; return; end; call apl_get_symbol_ ((function_name), symbol_ptr, (0)); function_info.symbol_ptr = symbol_ptr; /* remember symbol ptr */ end; /* if lex_errors_occurred */ else symbol_ptr = lexed_function_bead_ptr -> lexed_function_bead.name; call decrement_reference_count (symbol_ptr -> symbol_bead.meaning_pointer); symbol_ptr -> symbol_bead.meaning_pointer = function_bead_ptr; function_bead_ptr -> function_bead.reference_count = 1; /* Renumber all the lines if there were errors */ if lex_errors_occurred then do; call assign_line_numbers (function_info); current_line_number = function_info.line_info(function_info.number_of_lines).line_number + 1; end; last_frame_was_suspended = "0"b; reported_si_damage = "0"b; /* See if the function we have just finished editing successfully is on the SI. We check now, as well as at the beginning, because the user could have renamed the function while editing it. */ if ^lex_errors_occurred then do parse_frame_ptr = ws_info.current_parse_frame_ptr repeat (parse_frame.last_parse_frame_ptr) while (parse_frame_ptr ^= null ()); if parse_frame.parse_frame_type = suspended_frame_type then last_frame_was_suspended = "1"b; else do; code = 0; if parse_frame.parse_frame_type = function_frame_type then if parse_frame.lexed_function_bead_ptr -> lexed_function_bead.name = symbol_ptr then if last_frame_was_suspended then do; /* We have found a suspended instance of this function. See if they match. We have prevented some kinds of errors by refusing to let the user edit the header, but by renaming the function, or by adding/deleting/reordering labels, he could still screw us. */ code = check_function_compatibility (parse_frame.lexed_function_bead_ptr, lexed_function_bead_ptr); if code = 0 then do; call decrement_reference_count (parse_frame.function_bead_ptr); call decrement_reference_count (parse_frame.lexed_function_bead_ptr); parse_frame.function_bead_ptr = function_bead_ptr; function_bead_ptr -> general_bead.reference_count = function_bead_ptr -> general_bead.reference_count + 1; parse_frame.lexed_function_bead_ptr = lexed_function_bead_ptr; lexed_function_bead_ptr -> general_bead.reference_count = lexed_function_bead_ptr -> general_bead.reference_count + 1; end; end; else code = apl_error_table_$edited_pendent_fcn; if code ^= 0 then do; if ^reported_si_damage then call report_error (code, "", 0); reported_si_damage = "1"b; end; last_frame_was_suspended = "0"b; end; end; if function_info.locked_function then do; function_bead_ptr -> function_bead.class = 1; function_bead_ptr -> function_bead.stop_control_pointer = null (); function_bead_ptr -> function_bead.trace_control_pointer = null (); end; else do; function_bead_ptr -> function_bead.class = 0; function_bead_ptr -> function_bead.stop_control_pointer = function_info.saved_stop_vector; if function_info.saved_stop_vector ^= null () then function_info.saved_stop_vector -> general_bead.reference_count = function_info.saved_stop_vector -> general_bead.reference_count + 1; function_bead_ptr -> function_bead.trace_control_pointer = function_info.saved_trace_vector; if function_info.saved_trace_vector ^= null () then function_info.saved_trace_vector -> general_bead.reference_count = function_info.saved_trace_vector -> general_bead.reference_count + 1; end; return; check_function_compatibility: procedure (P_old_lfbp, P_new_lfbp) returns (fixed bin (35)); /* parameters */ declare (P_old_lfbp, P_new_lfbp) ptr unal parameter; /* automatic */ declare indx fixed bin (17), new_labels_ptr ptr, new_lfbp ptr, old_labels_ptr ptr, old_lfbp ptr; /* external static */ declare (apl_error_table_$labels_differ, apl_error_table_$locals_differ, apl_error_table_$n_labels_differ, apl_error_table_$n_locals_differ) fixed bin (35) external static; /* program */ old_lfbp = P_old_lfbp; new_lfbp = P_new_lfbp; if (old_lfbp -> lexed_function_bead.number_of_labels = new_lfbp -> lexed_function_bead.number_of_labels) then if (old_lfbp -> lexed_function_bead.number_of_localized_symbols = new_lfbp -> lexed_function_bead.number_of_localized_symbols) then do; /* We know they have the same number of locals, see if the names match */ do indx = 1 to old_lfbp -> lexed_function_bead.number_of_localized_symbols - old_lfbp -> lexed_function_bead.number_of_labels; if old_lfbp -> lexed_function_bead.localized_symbols (indx) ^= new_lfbp -> lexed_function_bead.localized_symbols (indx) then return (apl_error_table_$locals_differ); end; /* We know they have the same number of labels. See if they are the same names, in the same order. */ old_labels_ptr = old_lfbp -> lexed_function_bead.label_values_ptr; new_labels_ptr = new_lfbp -> lexed_function_bead.label_values_ptr; do indx = 1 to old_lfbp -> lexed_function_bead.number_of_labels; if old_labels_ptr -> lexed_function_label_values (indx) ^= new_labels_ptr -> lexed_function_label_values (indx) then return (apl_error_table_$labels_differ); end; return (0); end; else return (apl_error_table_$n_locals_differ); return (apl_error_table_$n_labels_differ); end check_function_compatibility; end close_function; process_bracket_contents: procedure (input_buffer, input_line_length, character_pos, current_line_number, function_info); dcl input_buffer char(*) parameter; dcl input_line_length fixed bin(21); dcl character_pos fixed bin parameter; dcl current_line_number fixed decimal(10, 5) parameter; %include apl_function_info; /* Automatic */ dcl (state, last_state) fixed bin; dcl count fixed bin; dcl (token_type, token_start) fixed bin; dcl gotten_number fixed decimal (10,5); dcl (left_number, right_number) fixed decimal (10,5); /* Based */ dcl input_line char(input_line_length) based (addr (input_buffer)); /* External */ dcl (apl_error_table_$empty_editor_brackets, apl_error_table_$missing_quad_or_rb, apl_error_table_$missing_number_or_rb, apl_error_table_$missing_rb, apl_error_table_$missing_number, apl_error_table_$bad_token_in_brackets, apl_error_table_$suspended_header, apl_error_table_$extra_text) fixed bin(35) external; /* Internal Static */ /* States: LB = Left Bracket, N = Number, Quad and Delta are themselves */ dcl (LB init (0), LB_N init (1), LB_N_Quad init (2), LB_N_Quad_N init (3), LB_Quad init (4), LB_Quad_N init (5), LB_Delta init (6), LB_Delta_N init (7), Done init (8), Empty_Brackets init (9), Not_Quad_or_RB init (10), Not_N_or_RB init (11), Not_RB init (12), Not_N init (13)) fixed bin internal static options (constant); dcl first_time_in_process bit (1) aligned initial ("1"b) internal static; dcl state_table(0:7, 4) fixed bin internal static; dcl (Number_Token init (1), Quad_Token init (2), Delta_Token init (3), RB_Token init (4), Bad_Token init (5)) fixed bin internal static options (constant); /* Program */ if first_time_in_process then do; state_table(LB, Number_Token) = LB_N; state_table(LB, Quad_Token) = LB_Quad; state_table(LB, Delta_Token) = LB_Delta; state_table(LB, RB_Token) = Empty_Brackets; state_table(LB_N, Number_Token) = Not_Quad_or_RB; state_table(LB_N, Quad_Token) = LB_N_Quad; state_table(LB_N, Delta_Token) = Not_Quad_or_RB; state_table(LB_N, RB_Token) = Done; state_table(LB_N_Quad, Number_Token) = LB_N_Quad_N; state_table(LB_N_Quad, Quad_Token) = Not_N_or_RB; state_table(LB_N_Quad, Delta_Token) = Not_N_or_RB; state_table(LB_N_Quad, RB_Token) = Done; state_table(LB_N_Quad_N, Number_Token) = Not_RB; state_table(LB_N_Quad_N, Quad_Token) = Not_RB; state_table(LB_N_Quad_N, Delta_Token) = Not_RB; state_table(LB_N_Quad_N, RB_Token) = Done; state_table(LB_Quad, Number_Token) = LB_Quad_N; state_table(LB_Quad, Quad_Token) = Not_N_or_RB; state_table(LB_Quad, Delta_Token) = Not_N_or_RB; state_table(LB_Quad, RB_Token) = Done; state_table(LB_Quad_N, Number_Token) = Not_RB; state_table(LB_Quad_N, Quad_Token) = Not_RB; state_table(LB_Quad_N, Delta_Token) = Not_RB; state_table(LB_Quad_N, RB_Token) = Done; state_table(LB_Delta, Number_Token) = LB_Delta_N; state_table(LB_Delta, Quad_Token) = Not_N; state_table(LB_Delta, Delta_Token) = Not_N; state_table(LB_Delta, RB_Token) = Not_N; state_table(LB_Delta_N, Number_Token) = Not_RB; state_table(LB_Delta_N, Quad_Token) = Not_RB; state_table(LB_Delta_N, Delta_Token) = Not_RB; state_table(LB_Delta_N, RB_Token) = Done; first_time_in_process = "0"b; end; state = LB; character_pos = character_pos + 1; /* flush the LB */ process_another: last_state = state; call get_next_bracket_token (input_line, character_pos, token_type, token_start, gotten_number); if token_type = Bad_Token then call error (apl_error_table_$bad_token_in_brackets, input_line, token_start); state = state_table (last_state, token_type); go to new_state(state); new_state(1): /* LB_N */ /* If function is suspended, user is not allowed to edit header. Check for left number = 0, and barf. If in any future changes, a left number of 0 does not refer to line 0, this code will have to be changed. */ if gotten_number = 0 then if function_info.suspended_function then call error (apl_error_table_$suspended_header, input_line, token_start); left_number = gotten_number; go to process_another; new_state(7): /* LB_Delta_N */ /* Check for attempt to delete header of suspended function */ if gotten_number = 0 then if function_info.suspended_function then call error (apl_error_table_$suspended_header, input_line, token_start); new_state(3): /* LB_N_Quad_N */ new_state(5): /* LB_Quad_N */ right_number = gotten_number; go to process_another; new_state(2): /* LB_N_Quad */ new_state(4): /* LB_Quad */ new_state(6): /* LB_Delta */ go to process_another; new_state(8): /* Done */ go to perform_action(last_state); new_state(9): /* Empty_Brackets */ call error (apl_error_table_$empty_editor_brackets, input_line, token_start); new_state(10): /* Not_Quad_or_RB */ call error (apl_error_table_$missing_quad_or_rb, input_line, token_start); new_state(11): /* Not_N_or_RB */ call error (apl_error_table_$missing_number_or_rb, input_line, token_start); new_state(12): /* Not_RB */ call error (apl_error_table_$missing_rb, input_line, token_start); new_state(13): /* Not_N */ call error (apl_error_table_$missing_number, input_line, token_start); /* This is where the actual actions begin. The entire line has been parsed so that we know exactly what to do. */ perform_action(1): /* LB_N */ current_line_number = left_number; return; perform_action(2): /* LB_N_Quad */ call print_function_lines (left_number, 1, function_info); current_line_number = left_number; return; perform_action(3): /* LB_N_Quad_N */ if character_pos < length (input_line) then call error (apl_error_table_$extra_text, input_line, character_pos); call edit_one_line (input_buffer, input_line_length, character_pos, left_number, right_number, current_line_number, function_info); return; perform_action(4): /* LB_Quad */ call print_function_lines (0, 2, function_info); return; perform_action(5): /* LB_Quad_N */ call print_function_lines (right_number, 2, function_info); return; perform_action(7): /* LB_Delta_N */ do count = lbound (function_info.line_info, 1) to function_info.number_of_lines while (function_info.line_info(count).line_number < right_number); end; if count ^> function_info.number_of_lines then if function_info.line_info(count).line_number = right_number then do; do count = count to function_info.number_of_lines - 1; function_info.line_info(count) = function_info.line_info(count + 1); end; function_info.number_of_lines = function_info.number_of_lines - 1; end; current_line_number = right_number; return; get_next_bracket_token: procedure (input_line, character_pos, token_type, token_start, gotten_number); dcl input_line char(*) parameter; dcl character_pos fixed bin parameter; dcl token_type fixed bin parameter; dcl token_start fixed bin parameter; dcl gotten_number fixed decimal (10,5) parameter; /* Automatic */ dcl character char(1); dcl number_length fixed bin; dcl whitespace char(2) init (" "); /* space, tab */ dcl conversion condition; character_pos = character_pos + verify (substr (input_line, character_pos), whitespace) - 1; token_start = character_pos; character = substr (input_line, character_pos, 1); if index ("0123456789.", character) ^= 0 then do; number_length = verify (substr (input_line, character_pos), "0123456789.") - 1; on conversion goto got_bad_token; gotten_number = fixed (substr (input_line, character_pos, number_length), 10, 5); revert conversion; character_pos = character_pos + number_length; token_type = Number_Token; end; else do; if character = QQuad then token_type = Quad_Token; else if character = QDelta then token_type = Delta_Token; else if character = QRightBracket then token_type = RB_Token; else do; got_bad_token: token_type = Bad_Token; return; end; character_pos = character_pos + 1; end; end; /* get_next_bracket_token */ end; /* process_bracket_contents */ context_editor: procedure (input_buffer, input_line_length, character_pos, current_line_number, function_info, saved_search_string); dcl input_buffer char(*) parameter; dcl input_line_length fixed bin(21); dcl character_pos fixed bin parameter; dcl current_line_number fixed decimal(10, 5) parameter; %include apl_function_info; dcl saved_search_string char(128) varying parameter; /* Automatic */ dcl char char(1); /* Based */ dcl input_line char(input_line_length) based (addr (input_buffer)); /* External */ dcl apl_error_table_$bad_context_request external fixed bin(35); dcl apl_static_$apl_output external ptr; /* Entries */ dcl ioa_$ioa_switch entry() options(variable); /* Include */ %include apl_characters; character_pos = character_pos + 1; /* Line has at least a NL in it, so this substr won't fail */ char = substr (input_line, character_pos, 1); if char = QSlash then call context_search (input_line, character_pos, current_line_number, function_info, saved_search_string, "0"b); else if char = QLessThan /* reverse search */ then do; character_pos = character_pos + 1; char = substr (input_line, character_pos, 1); if char = QSlash then call context_search (input_line, character_pos, current_line_number, function_info, saved_search_string, "1"b); else call error (apl_error_table_$bad_context_request, input_line, character_pos); end; else if char = QLetterS then call context_substitute (input_line, character_pos, current_line_number, function_info, saved_search_string); else if char = QLetterG then call context_global_print (input_line, character_pos, function_info, saved_search_string); else call error (apl_error_table_$bad_context_request, input_line, character_pos); if character_pos < length (input_line) then do; call ioa_$ioa_switch (apl_static_$apl_output, "extra text follows context request"); call error (0, "", 0); end; return; context_search: procedure (input_line, character_pos, current_line_number, function_info, saved_search_string, reverse_search); dcl input_line char(*) parameter; dcl character_pos fixed bin parameter; dcl current_line_number fixed decimal(10, 5) parameter; %include apl_function_info; dcl saved_search_string char(128) varying parameter; dcl reverse_search bit(1) parameter; /* Automatic */ dcl search_string_start fixed bin; dcl search_string char (128) varying; dcl starting_line_idx fixed bin; dcl increment fixed bin; dcl end_of_first_half fixed bin; dcl start_of_second_half fixed bin; dcl idx fixed bin; dcl line_idx fixed bin; /* External */ dcl apl_static_$apl_output external ptr; dcl apl_error_table_$missing_slash external fixed bin(35); dcl sys_info$max_seg_size external fixed bin; /* Based */ dcl edit_buffer char(sys_info$max_seg_size * 4) based (function_info.edit_buffer_ptr); /* Entries */ dcl ioa_$ioa_switch entry options (variable); /* Program */ character_pos = character_pos + 1; /* skip "/" */ search_string_start = character_pos; /* Move forward to next "/" */ idx = index (substr (input_line, character_pos), QSlash); if idx = 0 then do; character_pos = input_line_length + 1; call error (apl_error_table_$missing_slash, input_line, character_pos); end; character_pos = character_pos + idx - 1; search_string = substr (input_line, search_string_start, character_pos - search_string_start); /* drop trailing "/" */ /* Hack empty search string to use previous */ if search_string = "" then search_string = saved_search_string; else saved_search_string = search_string; character_pos = character_pos + 1; /* move over slash */ /* Get index into function line array of current line */ call get_line_info_idx (current_line_number, starting_line_idx, function_info, code); /* If code is not zero, the current_line does not exist. If we are past the end of the lines array, start at the beginning. */ if code ^= 0 then if starting_line_idx > function_info.number_of_lines then starting_line_idx = lbound (function_info.line_info, 1); /* Loop through lines looking for match starting at the line after (or before) and wrapping around at the bottom (or top) of the function. Set up the proper loop variables. */ if reverse_search then do; increment = -1; end_of_first_half = 1; /* back to line 1 */ start_of_second_half = function_info.number_of_lines; end; else do; increment = 1; end_of_first_half = function_info.number_of_lines; start_of_second_half = 1; /* start again at top */ end; do line_idx = starting_line_idx + increment to end_of_first_half by increment, start_of_second_half to starting_line_idx by increment; /* Does current line match? */ idx = index (substr (edit_buffer, function_info.line_info(line_idx).line_start, function_info.line_info(line_idx).line_length), search_string); if idx ^= 0 then do; current_line_number = function_info.line_info(line_idx).line_number; call print_function_lines (current_line_number, 1, function_info); return; end; end; call ioa_$ioa_switch (apl_static_$apl_output, "search fails"); call error (0, "", 0); end; /* context_search */ context_substitute: procedure (input_line, character_pos, current_line_number, function_info, saved_search_string); dcl input_line char(*) parameter; dcl character_pos fixed bin parameter; dcl current_line_number fixed decimal(10, 5) parameter; %include apl_function_info; dcl saved_search_string char(128) varying parameter; /* Automatic */ dcl string_start fixed bin; dcl (string1, string2) char(128) varying; dcl idx fixed bin; dcl verify_substitute bit(1) init ("0"b); dcl show_substitute bit(1) init ("0"b); dcl line_idx fixed bin; dcl (old_start, old_length) fixed bin; dcl first_free_char fixed bin; dcl old_tail_length fixed bin; dcl answer_buffer char(5); dcl answer_length fixed bin(21); dcl prompt_string char(14) varying; /* Based */ dcl edit_buffer char(4 * sys_info$max_seg_size) based (function_info.edit_buffer_ptr); /* External */ dcl apl_error_table_$missing_slash external fixed bin(35); dcl apl_error_table_$bad_substitute external fixed bin(35); dcl apl_static_$apl_output external ptr; dcl sys_info$max_seg_size fixed bin(35) ext static; /* Entries */ dcl ioa_$ioa_switch entry() options(variable); /* Program */ character_pos = character_pos + 1; /* skip "s" */ if substr (input_line, character_pos, 1) ^= QSlash then call error (apl_error_table_$bad_substitute, input_line, character_pos); character_pos = character_pos + 1; /* skip slash */ string_start = character_pos; /* find first terminating slash */ idx = index (substr (input_line, character_pos), QSlash); if idx = 0 then do; character_pos = input_line_length + 1; call error (apl_error_table_$missing_slash, input_line, character_pos); end; character_pos = character_pos + idx - 1; string1 = substr (input_line, string_start, character_pos - string_start); /* If string1 is empty use previous string */ if string1 = "" then string1 = saved_search_string; else saved_search_string = string1; character_pos = character_pos + 1; /* skip past slash */ string_start = character_pos; idx = index (substr (input_line, character_pos), QSlash); if idx = 0 then do; character_pos = input_line_length + 1; call error (apl_error_table_$missing_slash, input_line, character_pos); end; character_pos = character_pos + idx - 1; string2 = substr (input_line, string_start, character_pos - string_start); character_pos = character_pos + 1; /* skip over "/" */ /* Check for verification request */ if length (input_line) >= character_pos then do; char = substr (input_line, character_pos, 1); if char = QQuestion then verify_substitute = "1"b; if char = QLetterP then show_substitute = "1"b; character_pos = character_pos + 1; end; /* look up line info index */ call get_line_info_idx (current_line_number, line_idx, function_info, code); if code ^= 0 then do; call ioa_$ioa_switch (apl_static_$apl_output, "substitute fails - line is empty"); call error (0, "", 0); end; old_start = function_info.line_info(line_idx).line_start; old_length = function_info.line_info(line_idx).line_length; idx = index (substr (edit_buffer, old_start, old_length), string1); if idx = 0 /* no string1 */ then do; call ioa_$ioa_switch (apl_static_$apl_output, "substitute fails - no match in line"); call error (0, "", 0); end; /* Build new line in edit_buffer. This should really be done by some managing routine. */ first_free_char = function_info.first_unused_char_in_buffer; /* first add part of line before string1 */ substr (edit_buffer, first_free_char, idx - 1) = substr (edit_buffer, old_start, idx - 1); first_free_char = first_free_char + idx - 1; /* now splice in string2 */ substr (edit_buffer, first_free_char, length (string2)) = string2; first_free_char = first_free_char + length (string2); /* now add end of old line */ old_tail_length = old_length - (idx + length (string1)) + 1; substr (edit_buffer, first_free_char, old_tail_length) = substr (edit_buffer, old_start + (idx + length (string1)) - 1, old_tail_length); first_free_char = first_free_char + old_tail_length; if verify_substitute then do; prompt_string = line_number_to_string (function_info.line_info(line_idx).line_number); call ioa_$ioa_switch (apl_static_$apl_output, "^va^a", length (prompt_string), prompt_string, substr (edit_buffer, function_info.first_unused_char_in_buffer, first_free_char - function_info.first_unused_char_in_buffer)); ask_if_substitute_is_ok: call ioa_$ioa_switch (apl_static_$apl_output, "ok? "); call read_line (answer_buffer, answer_length); answer_length = answer_length - 1; /* drop NL */ if substr (answer_buffer, 1, answer_length) = "no" then return; else if substr (answer_buffer, 1, answer_length) ^= "yes" then do; call ioa_$ioa_switch (apl_static_$apl_output, "please answer yes or no"); goto ask_if_substitute_is_ok; end; end; /* At this point we know that the substitution has passed verification (if any) and should actually be done. This is accomplished by changing the function_info entry for the line to point at the newly constructed line. */ function_info.line_info(line_idx).line_start = function_info.first_unused_char_in_buffer; function_info.line_info(line_idx).line_length = first_free_char - function_info.first_unused_char_in_buffer; function_info.first_unused_char_in_buffer = first_free_char; if show_substitute then call print_function_lines (function_info.line_info(line_idx).line_number, 1, function_info); return; end; /* context_substitute */ context_global_print: procedure (input_line, character_pos, function_info, saved_search_string); dcl input_line char(*) parameter; dcl character_pos fixed bin parameter; %include apl_function_info; dcl saved_search_string char(128) varying parameter; dcl string_start fixed bin; dcl idx fixed bin; dcl string char(128) varying; dcl first_idx fixed bin; dcl line_idx fixed bin; dcl line_start fixed bin; dcl line_length fixed bin; dcl edit_buffer char(4 * sys_info$max_seg_size) based (function_info.edit_buffer_ptr); dcl apl_error_table_$bad_global_print external fixed bin(35); dcl apl_error_table_$missing_slash external fixed bin(35); dcl sys_info$max_seg_size external fixed bin(35); character_pos = character_pos + 1; /* skip "g" */ if substr (input_line, character_pos, 1) ^= QSlash then call error (apl_error_table_$bad_global_print, input_line, character_pos); character_pos = character_pos + 1; /* skip slash */ string_start = character_pos; /* find first terminating slash */ idx = index (substr (input_line, character_pos), QSlash); if idx = 0 then do; character_pos = input_line_length + 1; call error (apl_error_table_$missing_slash, input_line, character_pos); end; character_pos = character_pos + idx - 1; string = substr (input_line, string_start, character_pos - string_start); /* If string is empty use previous string */ if string = "" then string = saved_search_string; else saved_search_string = string; character_pos = character_pos + 1; /* skip past slash */ first_idx = lbound (function_info.line_info, 1); do line_idx = first_idx to function_info.number_of_lines; line_start = function_info.line_info(line_idx).line_start; line_length = function_info.line_info(line_idx).line_length; idx = index (substr (edit_buffer, line_start, line_length), string); if idx ^= 0 then call print_function_lines (function_info.line_info(line_idx).line_number, 1, function_info); end; return; end; /* context_global_print */ end; /* context_editor */ process_new_function_line: procedure (initial_input_line, character_pos, current_line_number, function_info); dcl initial_input_line char(*) parameter; dcl character_pos fixed bin parameter; dcl current_line_number fixed decimal(10, 5) parameter; %include apl_function_info; /* Automatic */ dcl input_buffer char(256); dcl input_line_length fixed bin(21); dcl (line_pos, del_pos) fixed bin; dcl (in_quotes, was_in_quotes, got_line, replacing_old_line) bit(1); dcl (count, line_info_idx) fixed bin; /* Based */ dcl input_line char(input_line_length) based (addr (input_buffer)); dcl edit_buffer char(sys_info$max_seg_size * 4) based (function_info.edit_buffer_ptr); /* External */ dcl sys_info$max_seg_size external fixed bin; dcl apl_error_table_$mismatched_editor_quotes external fixed bin(35); dcl (length, substr, ltrim) builtin; /* Program */ call get_line_info_idx (current_line_number, line_info_idx, function_info, code); if code = 0 then replacing_old_line = "1"b; else do; replacing_old_line = "0"b; /* There is no existing line for current_line_number, but line_info_idx points to where it should be. If that place is in the middle of existing lines, lines have to be moved to make room */ if line_info_idx <= function_info.number_of_lines then do count = function_info.number_of_lines to line_info_idx by -1; function_info.line_info(count + 1) = function_info.line_info(count); end; /* no else clause, line_info_idx is after the last existing line, so we can just add the line (note that all of this code assumes that we never get more lines than the line_info array is long. this should be fixed.) */ end; /* else do */ input_buffer = substr (initial_input_line, character_pos); input_line_length = length (substr (initial_input_line, character_pos)); in_quotes = "0"b; was_in_quotes = "0"b; got_line = "0"b; do while (^got_line); del_pos = 0; do line_pos = 1 to length (input_line) - 1; character = substr (input_line, line_pos, 1); if character = QApostrophe then in_quotes = ^in_quotes; if character = QDel | character = QDelTilde then del_pos = line_pos; end; if ^was_in_quotes then function_info.line_info(line_info_idx).line_start = function_info.first_unused_char_in_buffer; if del_pos ^= 0 then do; if in_quotes then call error (apl_error_table_$mismatched_editor_quotes, input_line, line_pos); substr (edit_buffer, function_info.first_unused_char_in_buffer, del_pos) = substr (input_line, 1, del_pos - 1) || QNewLine; function_info.first_unused_char_in_buffer = function_info.first_unused_char_in_buffer + del_pos; got_line = "1"b; character_pos = character_pos + del_pos - 1; end; else do; if in_quotes then was_in_quotes = "1"b; else do; got_line = "1"b; character_pos = length (initial_input_line) + 1; end; substr (edit_buffer, function_info.first_unused_char_in_buffer, length (input_line)) = ltrim (input_line); function_info.first_unused_char_in_buffer = function_info.first_unused_char_in_buffer + length (ltrim (input_line)); if ^got_line then call read_line (input_buffer, input_line_length); end; end; function_info.line_info(line_info_idx).line_number = current_line_number; function_info.line_info(line_info_idx).line_length = function_info.first_unused_char_in_buffer - function_info.line_info(line_info_idx).line_start; if ^replacing_old_line then function_info.number_of_lines = function_info.number_of_lines + 1; return; end; /* process_new_function_line */ parse_header_line: procedure (line_to_parse, character_pos, header_start, header_length, complicated_header, function_info); dcl line_to_parse char(*) parameter; /* contains header line and maybe other stuff */ dcl character_pos fixed bin parameter; /* where we are in line */ dcl (header_start, header_length) fixed bin parameter;/* return info about actual header line */ dcl complicated_header bit(1) parameter; /* return: true if args or return var found */ %include apl_function_info; /* Automatic */ dcl (token_start, token_length) fixed bin; dcl (done, last_token_was_semicolon, ran_out_of_tokens, bad_header) bit(1); dcl code2 fixed bin(35); /* Based */ dcl character_array_kludge(length (line_to_parse)) char(1) based (addr (line_to_parse)); dcl token char(token_length) based (addr (character_array_kludge(token_start))); /* Program */ header_start = character_pos; call parse_function_name_and_args (line_to_parse, character_pos, header_start, function_info.name, function_info.args(0), function_info.args(1), function_info.args(2), complicated_header, ran_out_of_tokens, bad_header); if bad_header then call apl_editor_cleanup (function_info); header_length = character_pos - header_start; if ran_out_of_tokens then return; /* Now process local variables */ done = "0"b; do while (^done); call get_header_token (line_to_parse, character_pos, token_start, token_length, code2); /* "token" depends on vals of token_(start length) */ if code2 ^= 0 then done = "1"b; else if token = QLamp then do; character_pos = length (line_to_parse) + 1; done = "1"b; end; else if token = QSemiColon then last_token_was_semicolon = "1"b; else do; /* could be var or non-header stuff */ if ^last_token_was_semicolon then do; character_pos = token_start; done = "1"b; end; else do; /* we did see semi, this could be var name */ call validate_identifier (token, code2); if code2 ^= 0 then do; character_pos = token_start; /* back up over token */ done = "1"b; end; end; last_token_was_semicolon = "0"b; end; /* else do */ end; /* do while (^done)... */ header_length = character_pos - header_start; return; end; /* parse_header_line */ parse_function_name_and_args: procedure (line_to_parse, character_pos, header_start, function_name, right_arg, left_arg, return_arg, complicated_header, ran_out_of_tokens, bad_header); dcl line_to_parse char(*) parameter; dcl character_pos fixed bin parameter; dcl header_start fixed bin parameter; dcl (function_name, right_arg, left_arg, return_arg) char(*) varying parameter; dcl (complicated_header, ran_out_of_tokens, bad_header) bit(1) parameter; /* Automatic */ dcl (id_number, phony_number_of_ids, last_identifier) fixed bin; dcl (found_left_arrow, done) bit(1); dcl old_character_pos fixed bin; dcl (token_start, token_length) fixed bin; dcl code fixed bin(35); dcl 1 identifiers(4), 2 name char(256) varying init ((4)(1)""), 2 position fixed bin; /* Based */ dcl character_array_kludge(length (line_to_parse)) char(1) based (addr (line_to_parse)); dcl token char(token_length) based (addr (character_array_kludge(token_start))); /* External */ dcl (apl_error_table_$misplaced_left_arrow, apl_error_table_$missing_function_name) external fixed bin(35); /* Program */ function_name, right_arg, left_arg, return_arg = ""; complicated_header, ran_out_of_tokens, bad_header = "0"b; done, found_left_arrow = "0"b; do id_number = 1 to 4 while (^ran_out_of_tokens & ^done); old_character_pos = character_pos; call get_header_token (line_to_parse, character_pos, token_start, token_length, code); if code ^= 0 /* no more tokens */ then ran_out_of_tokens = "1"b; else if token = QLamp then do; character_pos = length (line_to_parse) + 1; ran_out_of_tokens = "1"b; end; else do; if token = QLeftArrow then do; /* Found a left arrow. First token must have been the return var. */ if id_number ^= 2 then do; call report_error (apl_error_table_$misplaced_left_arrow, line_to_parse, token_start); bad_header = "1"b; return; end; call get_header_token (line_to_parse, character_pos, token_start, token_length, code); if code ^= 0 then do; call report_error (apl_error_table_$missing_function_name, line_to_parse, character_pos); bad_header = "1"b; return; end; found_left_arrow = "1"b; end; /* if token = QLeftArrow */ call validate_identifier (token, code); if code = 0 then do; identifiers(id_number).name = token; identifiers(id_number).position = token_start; end; else do; character_pos = old_character_pos; done = "1"b; end; end; /* else do; if token = QLeftArrow... */ end; /* do id_number... */ if identifiers(1).name = "" then do; call report_error (apl_error_table_$missing_function_name, line_to_parse, token_start); bad_header = "1"b; return; end; header_start = identifiers(1).position; if ran_out_of_tokens | done then last_identifier = id_number - 2; else last_identifier = id_number - 1; if found_left_arrow then do; /* First identifier was the return var. */ return_arg = identifiers(1).name; complicated_header = "1"b; phony_number_of_ids = last_identifier - 1; /* subtract one for the return var */ end; else phony_number_of_ids = last_identifier; /* Step through and figure out which identifiers are which header components. */ if phony_number_of_ids = 3 /* left_arg function_name right_arg */ then do; function_name = identifiers(last_identifier - 1).name; right_arg = identifiers(last_identifier).name; left_arg = identifiers(last_identifier - 2).name; complicated_header = "1"b; end; else if phony_number_of_ids = 2 /* function_name right_arg */ then do; function_name = identifiers(last_identifier - 1).name; right_arg = identifiers(last_identifier).name; complicated_header = "1"b; end; else if phony_number_of_ids = 1 /* function_name */ then function_name = identifiers(last_identifier).name; return; end; /* parse_function_name_and_args */ get_header_token: procedure (line_to_parse, character_pos, token_start, token_length, code); dcl line_to_parse char(*) parameter; dcl character_pos fixed bin parameter; dcl (token_start, token_length) fixed bin parameter; dcl code fixed bin(35); /* Automatic */ dcl new_pos fixed bin; /* Static */ dcl whitespace_string char(2) static options (constant) init (" "); /* SPACE, TAB */ dcl good_chars_in_identifier char(76) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789°±²³´µ¶·¸¹ŒŽº_"); /* Last ones are QZero_ thru QNine_, QDelta, QQuad, QDelta_ and _ */ /* Program */ code = 0; if character_pos > length (line_to_parse) then do; code = -1; return; end; else if substr (line_to_parse, character_pos, 1) = QNewLine then do; character_pos = character_pos + 1; code = -1; return; end; new_pos = verify (substr (line_to_parse, character_pos), whitespace_string); if new_pos = 0 /* nothing but whitespace */ then do; character_pos = character_pos + length (line_to_parse) + 1; code = -1; return; end; else character_pos = character_pos + new_pos - 1; token_start = character_pos; if index (good_chars_in_identifier, substr (line_to_parse, character_pos, 1)) ^= 0 then do; /* first char looks like identifier. find whole thing */ new_pos = verify (substr (line_to_parse, character_pos), good_chars_in_identifier); if new_pos = 0 /* identifier last thing on line */ then character_pos = length (line_to_parse) + 1; else character_pos = character_pos + new_pos - 1; end; else character_pos = character_pos + 1; /* all other tokens are 1 char */ token_length = character_pos - token_start; return; end; /* get_header_token */ validate_identifier: procedure (token, code); dcl token char(*) parameter; dcl code fixed bin(35) parameter; /* Static */ dcl good_chars_in_identifier char(76) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789°±²³´µ¶·¸¹ŒŽº_"); /* Last ones are QZero_ thru QNine_, QDelta, QQuad, QDelta_ and _ */ /* Program */ code = 0; if verify (token, good_chars_in_identifier) ^= 0 then code = -1; return; end; /* validate_identifier */ make_new_function: procedure (function_info, header_line); %include apl_function_info; dcl header_line char(*) parameter; /* Automatic */ dcl data_elements fixed bin; dcl function_bead_ptr pointer unaligned; /* Entries */ dcl apl_allocate_words_ entry (fixed bin(24), pointer unaligned); dcl (length, null, size, string, substr) builtin; /* Include Files */ %include apl_bead_format; %include apl_operator_bead; %include apl_function_bead; %include apl_symbol_bead; /* Program */ data_elements = length (header_line); if substr (header_line, data_elements, 1) ^= QNewLine then data_elements = data_elements + 1; call apl_allocate_words_ (size (function_bead), function_bead_ptr); string (function_bead_ptr -> function_bead.type) = function_type; function_bead_ptr -> function_bead.lexed_function_bead_pointer = null (); function_bead_ptr -> function_bead.class = 0; function_bead_ptr -> function_bead.stop_control_pointer = null (); function_bead_ptr -> function_bead.trace_control_pointer = null (); function_bead_ptr -> function_bead.text_length = data_elements; /* If we reserved room for NL, add one now */ if data_elements > length (header_line) then function_bead_ptr -> function_bead.text = header_line || QNewLine; else function_bead_ptr -> function_bead.text = header_line; function_info.symbol_ptr -> symbol_bead.meaning_pointer = function_bead_ptr; return; end; /* make_new_function */ assign_line_numbers: procedure (function_info); %include apl_function_info; /* Automatic */ dcl function_bead_ptr pointer; dcl in_quotes bit(1); dcl (real_line_start, line_start) fixed bin; dcl (real_line_length, line_length) fixed bin; dcl line_pos fixed bin; dcl line_counter fixed bin; /* Based */ dcl edit_buffer char(4 * sys_info$max_seg_size) based (function_info.edit_buffer_ptr); /* External */ dcl sys_info$max_seg_size external fixed bin; dcl (apl_error_table_$mismatched_editor_quotes, apl_error_table_$not_end_with_newline) external fixed bin(35); /* Include files */ %include apl_bead_format; %include apl_symbol_bead; %include apl_function_bead; /* Program */ function_bead_ptr = function_info.symbol_ptr -> symbol_bead.meaning_pointer; in_quotes = "0"b; real_line_start, line_start = 1; real_line_length = 0; function_info.first_unused_char_in_buffer = 1; do line_counter = 1 by 1 while (real_line_start <= (function_bead_ptr -> function_bead.text_length)); line_length = index (substr (function_bead_ptr -> function_bead.text, line_start), QNewLine); if line_length = 0 then do; call report_error (apl_error_table_$not_end_with_newline, substr (function_bead_ptr -> function_bead.text, line_start), function_bead_ptr -> function_bead.text_length - line_start + 2); call apl_editor_cleanup (function_info); end; do line_pos = line_start to (line_start + line_length - 1); /* skip NL */ if substr (function_bead_ptr -> function_bead.text, line_pos, 1) = QApostrophe then in_quotes = ^in_quotes; else if ^in_quotes then if substr (function_bead_ptr -> function_bead.text, line_pos, 1) = QLamp then line_pos = line_start + line_length; /* stop loop */ end; real_line_length = real_line_length + line_length; if in_quotes then do; line_start = line_start + line_length; line_counter = line_counter - 1; end; else do; substr (edit_buffer, function_info.first_unused_char_in_buffer, real_line_length) = substr (function_bead_ptr -> function_bead.text, real_line_start, real_line_length); function_info.line_info(line_counter).line_number = line_counter - 1; function_info.line_info(line_counter).line_start = first_unused_char_in_buffer; function_info.line_info(line_counter).line_length = real_line_length; function_info.first_unused_char_in_buffer = function_info.first_unused_char_in_buffer + real_line_length; line_start, real_line_start = real_line_start + real_line_length; real_line_length = 0; end; end; /* do line_counter ... */ if in_quotes then call error (apl_error_table_$mismatched_editor_quotes, substr (function_bead_ptr -> function_bead.text, line_start), length (substr (function_bead_ptr -> function_bead.text, line_start)) + 1); function_info.number_of_lines = line_counter - 1; return; end; /* assign_line_numbers */ print_function_lines: procedure (first_line_number, print_type, function_info); dcl first_line_number fixed decimal(10, 5) parameter; dcl print_type fixed bin parameter; /* 1 = one line, 2 = specified line to end */ %include apl_function_info; /* Automatic */ dcl (first_array_idx, last_array_idx) fixed bin; dcl count fixed bin; dcl output_line char(256) varying; dcl code fixed bin(35); /* Based */ dcl edit_buffer char(4 * sys_info$max_seg_size) based (function_info.edit_buffer_ptr); /* External */ dcl apl_static_$apl_output external ptr; dcl sys_info$max_seg_size external fixed bin; dcl (length, substr, rtrim) builtin; /* Entries */ dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* Program */ do first_array_idx = lbound (function_info.line_info, 1) to function_info.number_of_lines while (function_info.line_info(first_array_idx).line_number < first_line_number); end; if first_array_idx > function_info.number_of_lines then return; if print_type = 1 then if function_info.line_info(first_array_idx).line_number ^= first_line_number then return; else last_array_idx = first_array_idx; if print_type = 2 then last_array_idx = function_info.number_of_lines; if first_line_number = 0 & print_type ^= 1 then do; output_line = " ¬ "; /* SP SP SP SP QDel SP */ /* Make sure that there is a line 0 */ if function_info.line_info(first_array_idx).line_number = 0 then do; output_line = output_line || substr (edit_buffer, function_info.line_info(1).line_start, function_info.line_info(1).line_length); first_array_idx = first_array_idx + 1; end; else output_line = output_line || QNewLine; call iox_$put_chars (apl_static_$apl_output, addrel (addr (output_line), 1), length (output_line), code); end; do count = first_array_idx to last_array_idx; if line_has_label (substr (edit_buffer, function_info.line_info(count).line_start, function_info.line_info(count).line_length)) then output_line = line_number_to_string_with_label (function_info.line_info(count).line_number); else output_line = line_number_to_string (function_info.line_info(count).line_number); output_line = output_line || substr (edit_buffer, function_info.line_info(count).line_start, function_info.line_info(count).line_length); call iox_$put_chars (apl_static_$apl_output, addrel (addr (output_line), 1), length (output_line), code); end; if print_type ^= 1 then do; output_line = " ¬ "; call iox_$put_chars (apl_static_$apl_output, addrel (addr (output_line), 1), length (output_line), code); end; return; end; /* print_function_lines */ edit_one_line: procedure (editor_input_buffer, editor_input_buffer_length, character_pos, left_number, right_number, current_line_number, function_info); dcl editor_input_buffer char(*) parameter; dcl editor_input_buffer_length fixed bin(21); dcl character_pos fixed bin parameter; dcl (left_number, right_number) fixed decimal(10, 5) parameter; dcl current_line_number fixed decimal (10, 5) parameter; %include apl_function_info; /* Automatic */ dcl (count, idx) fixed bin; dcl (original_line, input_line, output_line) char (256); dcl (original_line_length, input_line_length, output_line_length) fixed bin(21); dcl line_info_idx fixed bin; dcl prompt_string char(14) varying; dcl integer_part fixed decimal (5); dcl first_insertion fixed bin; dcl amount_to_insert fixed bin; dcl character char(1); dcl old_mode char(32); dcl code fixed bin(35); /* Static */ dcl NL char(1) static options (constant) init (" "); dcl insertion_chars char(36) static options (constant) init ("0123456789abcdefghijklmnopqrstuvwxyz"); dcl insertion_table(0:36) fixed bin static options (constant) init (-1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 100, 105, 110, 115, 120, 125, 130); /* Based */ dcl edit_buffer char(4 * sys_info$max_seg_size) based (function_info.edit_buffer_ptr); /* External */ dcl sys_info$max_seg_size external fixed bin; dcl apl_static_$apl_output external ptr; dcl (apl_error_table_$line_too_long_to_edit) external fixed bin(35); /* Entries */ dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl continue_to_signal_ entry (fixed bin(35)); dcl (substr, addr, copy, index, trunc, length) builtin; /* Include Files */ %include apl_ws_info; /* Program */ current_line_number = left_number; call get_line_info_idx (left_number, line_info_idx, function_info, code); if code ^= 0 /* no such line */ then return; prompt_string = line_number_to_string (current_line_number); original_line = prompt_string; original_line_length = length (prompt_string); count = function_info.line_info(line_info_idx).line_length; substr (original_line, original_line_length + 1, count) = substr (edit_buffer, function_info.line_info(line_info_idx).line_start, count); original_line_length = original_line_length + count; /* If there are any newlines other than the trailing one, barf */ idx = index (substr (original_line, 1, original_line_length - 1), NL); if idx ^= 0 then call error (apl_error_table_$line_too_long_to_edit, substr (original_line, 1, idx), idx); integer_part = trunc (right_number); if integer_part ^= right_number /* right is not integer */ then return; /* should probably error out */ if integer_part ^= 0 /* 0 is special case, skip all this code */ then do; call iox_$put_chars (apl_static_$apl_output, addr (original_line), original_line_length, code); output_line = ""; call iox_$put_chars (apl_static_$apl_output, addr (output_line), integer_part - 1, code); call read_line (input_line, input_line_length); substr (input_line, input_line_length) = ""; /* flush NL, add spaces */ output_line_length = 0; original_line_length = original_line_length - 1; /* flush NL */ first_insertion = 0; do count = 1 to original_line_length; character = substr (input_line, count, 1); if character ^= QSlash then do; amount_to_insert = insertion_table (index (insertion_chars, character)); /* lookup insertion value for char */ if amount_to_insert > 0 then do; if first_insertion < 1 then first_insertion = output_line_length + 1; output_line_length = output_line_length + amount_to_insert; /* insert the spaces */ end; substr (output_line, output_line_length + 1, 1) = substr (original_line, count, 1); output_line_length = output_line_length + 1; if output_line_length > ws_info.width then call error (apl_error_table_$line_too_long_to_edit, substr (output_line, 1, ws_info.width - 2), ws_info.width - 1); end; /* if character ^= QSlash */ /* There is no else clause, as slash is supposed to delete a char. If we do nothing, the char will not get copied */ end; /* do count ... */ if first_insertion < 1 then first_insertion = output_line_length + 1; if first_insertion < output_line_length then do; substr (output_line, output_line_length + 1, output_line_length - first_insertion + 1) = copy (QBackSpace, output_line_length - first_insertion + 1); output_line_length = output_line_length + (output_line_length - first_insertion + 1); end; end; /* if integer_part ^= 0 */ else do; output_line = original_line; output_line_length = original_line_length - 1; end; old_mode = ""; on apl_quit_ begin; call reset_read_back_output_mode (old_mode); call continue_to_signal_ (code); end; call set_read_back_output_mode (old_mode); call iox_$put_chars (apl_static_$apl_output, addr (output_line), output_line_length, code); call read_line (input_line, input_line_length); call reset_read_back_output_mode (old_mode); revert apl_quit_; editor_input_buffer = substr (input_line, 1, input_line_length); editor_input_buffer_length = input_line_length; character_pos = 1; return; /* let main command loop deal with it */ end; /* edit_one_line */ increment_line_number: procedure (line_number) returns (fixed decimal(10, 5)); dcl line_number fixed decimal(10, 5) parameter; /* Automatic */ dcl incremented_line_number fixed decimal(10, 5); dcl line_number_pic picture "99999v.99999"; dcl power fixed bin; dcl (length, rtrim, after, fixed) builtin; /* Program */ line_number_pic = current_line_number; power = length (rtrim (after (line_number_pic, "."), "0")); incremented_line_number = fixed (line_number + 10 ** (-power), 10, 5); return (incremented_line_number); end; /* increment_line_number */ line_number_to_string: procedure (line_number) returns (char(14) varying); dcl line_number fixed decimal(10, 5) parameter; /* Automatic */ dcl line_number_pic picture "zzzz9v.99999"; dcl return_string char(14) varying; dcl number_of_spaces fixed bin; dcl (length, ltrim, rtrim, copy) builtin; /* Program */ number_of_spaces = 6; goto lnts_join; line_number_to_string_with_label: entry (line_number) returns (char(14) varying); number_of_spaces = 5; lnts_join: line_number_pic = line_number; return_string = "["; return_string = return_string || ltrim (line_number_pic); return_string = rtrim (rtrim (return_string, "0"), "."); if length (return_string) = 1 then return_string = return_string || "0"; return_string = return_string || "] "; if length (return_string) < number_of_spaces then return_string = return_string || copy (" ", number_of_spaces - length (return_string)); return (return_string); end; /* line_number_to_string */ line_has_label: procedure (line) returns (bit(1)); dcl line char(*) parameter; dcl current_pos fixed bin; dcl (token_start, token_length) fixed bin; current_pos = 1; call get_header_token (line, current_pos, token_start, token_length, code); if code ^= 0 then return ("0"b); if substr (line, token_start + token_length, 1) = QColon then return ("1"b); else return ("0"b); end; /* line_has_label */ prompt: procedure (current_line_number, function_info); dcl current_line_number fixed decimal(10, 5) parameter; %include apl_function_info; /* Automatic */ dcl line_number_pic picture "99999v.99999"; dcl prompt_string char(14) varying; /* External */ dcl apl_static_$apl_output ptr external; /* Entries */ dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl (length, addr, addrel, rtrim) builtin; /* Program */ prompt_string = line_number_to_string (current_line_number); call iox_$put_chars (apl_static_$apl_output, addrel (addr (prompt_string), 1), length (prompt_string), code); return; end; /* prompt */ read_line: procedure (input_buffer, input_line_length); dcl input_buffer char(*) parameter; dcl input_line_length fixed bin(21) parameter; /* Automatic */ dcl got_line bit(1); dcl have_reattached_user_input bit(1); dcl code fixed bin(35); /* External */ dcl (error_table_$short_record, error_table_$end_of_info) fixed bin(35) external; dcl apl_error_table_$cant_read_input fixed bin(35) external; dcl apl_static_$apl_input pointer external; /* Entries */ dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl apl_system_error_ entry (fixed bin(35)); /* Program */ have_reattached_user_input = "0"b; got_line = "0"b; do while (^got_line); call iox_$get_line (apl_static_$apl_input, addr (input_buffer), length (input_buffer), input_line_length, code); if code = 0 then got_line = "1"b; else if code = error_table_$short_record then do; input_line_length = input_line_length + 1; substr (input_buffer, input_line_length, 1) = QNewLine; got_line = "1"b; end; else if code = error_table_$end_of_info then do; if have_reattached_user_input then call apl_system_error_ (apl_error_table_$cant_read_input); call reattach_user_input; have_reattached_user_input = "1"b; end; else call apl_system_error_ (apl_error_table_$cant_read_input); end; return; /* Small procedure to attach user_input back to user_i/o. Handles case where user_input is presently attached via syn_, and case where user_input is attached via regular IO module. */ reattach_user_input: procedure; dcl code fixed bin(35); /* External */ dcl iox_$user_input pointer external; dcl error_table_$not_closed fixed bin(35) external; /* Entries */ dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$attach_ptr entry (ptr, char(*), ptr, fixed bin (35)); /* Program */ call iox_$detach_iocb (iox_$user_input, code); if code = error_table_$not_closed then do; /* means was vfile_ or something */ call iox_$close (iox_$user_input, code); call iox_$detach_iocb (iox_$user_input, code); end; call iox_$attach_ptr (iox_$user_input, "syn_ user_i/o", null (), code); end; /* reattach_user_input */ end; /* read_line */ set_read_back_output_mode: procedure (old_mode); dcl old_mode char(*) parameter; /* Automatic */ dcl code fixed bin(35); /* External */ dcl apl_static_$apl_input external ptr; /* Entries */ dcl ipc_$mask_ev_calls entry (fixed bin(35)); dcl ipc_$unmask_ev_calls entry (fixed bin(35)); dcl iox_$control entry (ptr, char(*), ptr, fixed bin (35)); /* Program */ call ipc_$mask_ev_calls (code); call iox_$control (apl_static_$apl_input, "read_back_output", addr (old_mode), code); if code ^= 0 then call error (code, "", 0); return; reset_read_back_output_mode: entry (old_mode); /* Check to see if there is anythingg to reset */ if old_mode = "" then return; call iox_$control (apl_static_$apl_input, old_mode, (null ()), code); call ipc_$unmask_ev_calls (code); old_mode = ""; return; end; /* set_read_back_output_mode */ decrement_reference_count: procedure (bead_ptr); dcl bead_ptr pointer unaligned parameter; /* Entries */ dcl apl_free_bead_ entry (pointer unaligned); /* Include Files */ %include apl_bead_format; /* Program */ if bead_ptr = null() then return; bead_ptr -> general_bead.reference_count = bead_ptr -> general_bead.reference_count - 1; if bead_ptr -> general_bead.reference_count < 1 then do; call apl_free_bead_ (bead_ptr); bead_ptr = null(); end; return; end; /* decrement_reference_count */ get_line_info_idx: procedure (line_number, line_info_idx, function_info, code); dcl line_number fixed decimal(10, 5) parameter; dcl line_info_idx fixed bin parameter; %include apl_function_info; dcl code fixed bin(35) parameter; /* Program */ code = 0; do line_info_idx = 1 to function_info.number_of_lines while (function_info.line_info(line_info_idx).line_number < line_number); end; if line_info_idx > function_info.number_of_lines then do; code = -1; return; end; if function_info.line_info(line_info_idx).line_number ^= line_number then code = -1; return; end; /* get_line_info_idx */ error: procedure (code, source, position); dcl code fixed bin(35) parameter; dcl source char(*) parameter; dcl position fixed bin parameter; /* Automatic */ dcl fatal bit(1); /* Entries */ dcl apl_error_ entry (fixed bin(35), bit(36) aligned, fixed bin, char(*), ptr unaligned, fixed bin); /* Program */ fatal = "1"b; go to error_join; report_error: entry (code, source, position); fatal = "0"b; error_join: if code ^= 0 then call apl_error_ (code, "0"b, position, source, null (), 0); if fatal then goto internal_error_restart; else return; end; /* error, report_error */ apl_editor_cleanup: procedure (function_info); %include apl_function_info; /* Entries */ dcl apl_segment_manager_$free entry (ptr); dcl apl_destroy_save_frame_update_ entry (); /* Program */ call apl_segment_manager_$free (function_info.edit_buffer_ptr); call apl_destroy_save_frame_update_; goto apl_editor_return_point; end; /* apl_editor_cleanup */ end; /* apl_editor_ */  apl_encode_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 72837 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_encode_: proc(operators_argument); /* * this procedure implements the APL T operator * * written 1 August 1973 by DAM * Fixed 740827 by PG to set value_stack_ptr to protect result! Modified 770413 by PG to fix bug 208 (infinite loop when given null vectors). Modified 770414 by PG to fix bug 280 (was walking thru rows on left instead of columns). */ /* automatic */ dcl left_vb pointer, /* the usual pointer variables */ left pointer, right_vb pointer, right pointer, result_vb pointer, result pointer, final_result_vb pointer, final_result pointer, left_data_elements fixed bin (21), /* elements in left opnd */ right_data_elements fixed bin (21), /* elements in right opnd */ data_elements fixed bin (21), /* number of elements in the result */ rhorho fixed bin, /* number of dimensions of the result */ n_words fixed bin (19), /* number of words in the result value bead */ i fixed bin, /* do-loop var. */ j fixed bin, /* .. */ plane_base fixed bin (21), /* offset of current plane in left opnd */ last_column_on_this_plane fixed bin (21), column_base fixed bin (21), /* offset of first element in current column */ col_pos fixed bin (21), /* position in current column */ right_pos fixed bin(21), /* position of current number to be encoded, in right operand */ interval_between_columns fixed bin (21), interval_between_columns_minus_1 fixed bin (21), highest_column_element fixed bin (21), rho_subscript fixed bin (21), interval_between_elements fixed bin (21), column_length fixed bin (21), accum float, /* portion of number not yet encoded (quotient after each step) */ divisor float, /* copy of number from left operand */ quotient float, /* quotient result of APL div-mod operation */ residue float; /* remainder result of .. .. .. */ /* builtins */ dcl (abs, addr, addrel, rel, max, substr, string, size) builtin; /* external static */ dcl (apl_error_table_$domain, apl_error_table_$compatibility_error) fixed bin(35) external; %include apl_number_data; %include apl_ws_info; %include apl_operators_argument; %include apl_operator_bead; %include apl_value_bead; %include apl_bead_format; /* pick up arguments, make sure they are numbers */ left_vb = operands(1).value; left_data_elements = left_vb -> value_bead.total_data_elements; left = left_vb -> value_bead.data_pointer; if (left_data_elements ^= 0) & ^left_vb -> value_bead.numeric_value then go to domain_error_left; right_vb = operands(2).value; right_data_elements = right_vb -> value_bead.total_data_elements; right = right_vb -> value_bead.data_pointer; if (right_data_elements ^= 0) & ^right_vb -> value_bead.numeric_value then go to domain_error_right; /* determine length of columns of radices (and of result digits) */ if left_vb -> value_bead.rhorho = 0 /* a scalar */ then column_length = 1; else column_length = max (1, left_vb -> value_bead.rho (1)); /* compute size of result (product of sizes of operands) and allocate it */ data_elements = left_vb -> value_bead.total_data_elements * right_vb -> value_bead.total_data_elements; number_of_dimensions, rhorho = left_vb -> value_bead.rhorho + right_vb -> value_bead.rhorho; n_words = size (value_bead) + size (numeric_datum) + 1; result_vb = apl_push_stack_ (n_words); string(result_vb -> value_bead.type) = integral_value_type; /* will be changed to numeric if necessary */ result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = rhorho; result = addrel (result_vb, size (value_bead)); if substr (rel (result), 18, 1) then result = addrel (result, 1); result_vb -> value_bead.data_pointer = result; /* rho of result is concatenation of rhos of operands */ do i = 1 by 1 while (i <= left_vb -> value_bead.rhorho); result_vb -> value_bead.rho(i) = left_vb -> value_bead.rho(i); end; do j = i by 1 while (j <= rhorho); result_vb -> value_bead.rho(j) = right_vb -> value_bead.rho(j-i+1); end; interval_between_elements = 1; do rho_subscript = 2 to left_vb -> value_bead.rhorho; interval_between_elements = interval_between_elements * left_vb -> value_bead.rho (rho_subscript); end; interval_between_columns = interval_between_elements * column_length; interval_between_columns_minus_1 = interval_between_columns - interval_between_elements; /* walk through columns of left arg, elements of right arg, and elements of left column */ do plane_base = 0 repeat (plane_base + interval_between_columns) while (plane_base < left_data_elements); last_column_on_this_plane = plane_base + interval_between_elements; do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); highest_column_element = column_base + interval_between_columns_minus_1; do right_pos = 0 by 1 while (right_pos < right_data_elements); accum = right -> numeric_datum (right_pos); do col_pos = highest_column_element repeat (col_pos - interval_between_elements) while (col_pos >= column_base); divisor = left -> numeric_datum (col_pos); if divisor <= ws_info.fuzz /* if divisor is fuzz-less-or-equal to zero */ then if ws_info.compatibility_check_mode then go to compatibility_error_left; /* old APL acted differently with neg or zero left */ if abs (divisor) > ws_info.fuzz /* if divisor is not fuzz-equal to zero */ then do; quotient = apl_floor_ (accum / divisor); residue = accum - divisor*quotient; end; else do; /* renege on integer type */ string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type); residue = accum; quotient = 0; end; result -> numeric_datum (col_pos * right_data_elements + right_pos) = residue; accum = quotient; end; end; end; end; /* now put result in proper place */ if operators_argument.operands (2).on_stack then ws_info.value_stack_ptr = right_vb; else if operators_argument.operands (1).on_stack then ws_info.value_stack_ptr = left_vb; else do; operators_argument.result = result_vb; return; end; final_result_vb = apl_push_stack_ (n_words); string(final_result_vb -> value_bead.type) = string(result_vb -> value_bead.type); final_result_vb -> value_bead.rhorho = result_vb -> value_bead.rhorho; final_result_vb -> value_bead.total_data_elements = data_elements; do i = 1 to rhorho; /* use do loop because for bad code for assigning value_bead.rho(*) */ final_result_vb -> value_bead.rho(i) = result_vb -> value_bead.rho(i); end; final_result = addr(final_result_vb -> value_bead.rho(rhorho+1)); if substr(rel(final_result), 18, 1) then final_result = addrel(final_result, 1); final_result_vb -> data_pointer = final_result; final_result -> numeric_datum (*) = result -> numeric_datum (*); operators_argument.result = final_result_vb; return; compatibility_error_left: /* if ws_info .compatibility_check_mode was on and a element of left arg was neg or zero */ operators_argument.where_error = operators_argument.where_error + 1; operators_argument.error_code = apl_error_table_$compatibility_error; return; domain_error_left: operators_argument.where_error = operators_argument.where_error + 1; go to domain_error; domain_error_right: operators_argument.where_error = operators_argument.where_error - 1; domain_error: operators_argument.error_code = apl_error_table_$domain; return; %include apl_push_stack_fcn; %include apl_floor_fcn; end /* apl_encode_ */;  apl_erase_command_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 39537 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3 */ apl_erase_command_: proc (nargs, arglist); /* * this routine executes the )ERASE apl command * written 73.9.06 by DAM * Modified 740131 by PG to check for SI DAMAGE Modified 800116 by PG to stop calling apl_system_error_ for SI DAMAGE report because it unwinds & leaves the save frame on the SI, leading to system errors later on. */ /* parameters */ dcl nargs fixed bin parameter, arglist dim (*) char (*) parameter; /* automatic */ declare argno fixed bin, code fixed bin (35), not_erased_msg char (150) varying aligned, symb ptr unaligned; /* builtins */ declare (addr, addrel, length, maxlength, null, rtrim) builtin; /* entries */ dcl apl_create_save_frame_ entry, apl_destroy_save_frame_update_ entry, apl_get_symbol_ entry (char (*), unaligned pointer, fixed bin), apl_free_bead_ entry (unaligned pointer), apl_pendant_function_check_ entry (unaligned pointer) returns (bit (1) aligned), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* external static */ declare apl_static_$apl_output ptr external static; /* internal static */ declare NL char (1) init (" ") internal static; /* include files */ %include apl_bead_format; %include apl_group_bead; %include apl_symbol_bead; %include apl_ws_info; /* program */ not_erased_msg = ""; call apl_create_save_frame_; /* operate on global meanings */ do argno = 1 to nargs; /* process each argument, left to right */ call apl_get_symbol_ (rtrim (arglist (argno)), symb, (0)); call expunge (symb); call wash (symb); end; call apl_destroy_save_frame_update_; if length (not_erased_msg) > 0 then do; not_erased_msg = not_erased_msg || NL; call iox_$put_chars (apl_static_$apl_output, addrel (addr (not_erased_msg), 1), length (not_erased_msg), code); end; return; wash: proc (abp); dcl abp unaligned pointer parameter, bp unaligned pointer automatic; bp = abp; bp -> general_bead.reference_count = bp -> general_bead.reference_count - 1; if bp -> general_bead.reference_count <= 0 then call apl_free_bead_ (bp); end; expunge: proc (abp); dcl memx fixed bin, abp unaligned pointer parameter, bp unaligned pointer automatic; bp = abp; if bp -> symbol_bead.meaning_pointer = null then do; call not_erased (bp -> symbol_bead.name); return; end; if bp -> symbol_bead.meaning_pointer -> general_bead.type.group then do memx = 1 to bp -> symbol_bead.meaning_pointer -> group_bead.number_of_members; /* erase the members of a group */ call expunge (bp -> symbol_bead.meaning_pointer -> group_bead.member (memx)); end; if bp -> symbol_bead.meaning_pointer -> general_bead.function then if apl_pendant_function_check_ (bp -> symbol_bead.meaning_pointer) then do; call not_erased (bp -> symbol_bead.name); return; end; call wash (bp -> symbol_bead.meaning_pointer); bp -> symbol_bead.meaning_pointer = null; return; not_erased: procedure (P_name); /* parameters */ declare P_name char (*) parameter; /* program */ if length (not_erased_msg) = 0 then not_erased_msg = "not erased: "; /* Is there room to fit the text on the current output line, and is there room to fit the text in the output buffer? Note that the NL doesn't count in the first test, but does count in the second. */ if (length (not_erased_msg) + length (P_name) + 1 > ws_info.width) | (length (not_erased_msg) + length (P_name) + 1 >= maxlength (not_erased_msg)) then do; not_erased_msg = not_erased_msg || NL; call iox_$put_chars (apl_static_$apl_output, addrel (addr (not_erased_msg), 1), length (not_erased_msg), code); not_erased_msg = ""; end; not_erased_msg = not_erased_msg || " "; not_erased_msg = not_erased_msg || P_name; return; end /* not_erased */; end /* expunge */; end /* apl_erase_command_ */;  apl_error_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 71244 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_error_: proc(code, a_options, a_marker_pos, source_line, function_name_ptr_structure, line_number); /* * this module prints error messages for apl. * any fancy error recovery to be done must be done by the caller. * * written 73.7.07 by DAM * modified 73.8.20 by DAM for new dim * Modified 740131 by PG for compatibility error * Modified 750630 by PG to make SYSTEM ERRORS always long Modified 780211 by PG to add RESULT SIZE ERROR. Modified 780914 by PG to move mapping table to apl_error_table_ */ /* parameters */ dcl code fixed bin(35), /* status code, usually from apl_error_table_ */ a_options bit(36) aligned parameter, a_marker_pos fixed bin, /* position in source_line of character to be marked */ source_line char(*), /* line to print (or null string to suppress) */ 1 function_name_ptr_structure aligned structure parameter, 2 function_name_ptr ptr unaligned, /* -> symbol bead of function name to put in front of source_line (null ptr to suppress) */ line_number fixed bin; /* line number to put in brackets after function_name */ /* automatic */ dcl short_error_msg char(8) aligned, brief_msg char (20), error_table_code_option bit(36) aligned init("01"b), /* mask for option that code is from system error_table_, msg is to be put in somewhat different format */ long_error_msg char(100) aligned, long_error_mode bit (1) aligned, options bit(36) aligned, /* options bits */ marker_pos fixed bin, /* copy argument since is input argument and will modify */ i fixed bin; dcl 1 buffer_structure aligned, 2 buffer char(200) varying, /* message constructed here, length must be multiple of 4 */ 2 too_long char(4); /* if buffer fills up, put "...NL" here to tell loser */ /* conditions */ dcl apl_system_error_ condition; /* also the name of one entry to this procedure */ /* entries */ dcl convert_status_code_ entry(fixed bin(35), char(8) aligned, char(100) aligned), ios_$order entry (char (*), char (*), ptr, bit (72) aligned), cu_$cl entry, ioa_$rsnpnnl entry options(variable), ios_$write entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72)aligned), ios_write_length fixed bin; dcl ioa_$ioa_stream entry options(variable); dcl ios_$resetread entry(char(*), bit(72) aligned); /* external static */ dcl 1 apl_error_table_$mapping_table (100 /* phony */) aligned external static, 2 short_msg char (8), 2 brief_msg char (24); dcl apl_error_table_$n_map_entries fixed bin external static; /* internal static */ dcl apl_output_stream char(32) static init("apl_output_"), apl_input_stream char(32) static init("apl_input_"), SystemErrorEntry bit(36) aligned static init("000000000000000000000000000000000001"b), /* (35 0's and a 1) */ HuhEntry bit(36) aligned static init("000000000000000000000000000000000010"b); /* builtins */ dcl (null, substr, length, lbound, hbound) builtin; /* include files */ %include apl_bead_format; %include apl_symbol_bead; %include apl_number_data; %include apl_ws_info; %include apl_characters; /* program */ options = a_options; /* copy parameter since to other entry it is not a parameter */ if a_marker_pos <= 0 then marker_pos = 1; else if a_marker_pos > length (source_line) then marker_pos = length (source_line) + 1; else marker_pos = a_marker_pos; join: if ws_info_ptr ^= null /* watch out! */ then ws_info.last_error_code = code; call convert_status_code_(code, short_error_msg, long_error_msg); /* do conversion of short msg to brief msg */ do i = 1 to apl_error_table_$n_map_entries; if apl_error_table_$mapping_table (i).short_msg = short_error_msg then do; brief_msg = apl_error_table_$mapping_table (i).brief_msg; go to exitloop; end; end; brief_msg = short_error_msg; /* Oh, well. Don't translate */ exitloop: call ios_$order (apl_output_stream, "printer_on", null, (""b)); /* turn on printer in case it is off */ if options & HuhEntry /* )HUH - reprint error message */ then do; if substr(long_error_msg, 1, 4) = (4) " " then call ioa_$ioa_stream(apl_output_stream, "^a^a", (QConditionalNewLine), brief_msg); else call ioa_$ioa_stream(apl_output_stream, "^a^a - ^a", (QConditionalNewLine), brief_msg, long_error_msg); return; end; if ws_info_ptr = null /* don't fault if it is */ then long_error_mode = "1"b; else long_error_mode = ws_info.long_error_mode; if short_error_msg = "system" then long_error_mode = "1"b; /* SYSTEM ERRORS are always long */ /* put out first line of message */ if options & error_table_code_option then call ioa_$ioa_stream(apl_output_stream, "command error: ^a", long_error_msg); else if substr(long_error_msg, 1, 4) = (4)" " /* can't print long msg if there isn't one */ then go to short_form; else if long_error_mode then call ioa_$ioa_stream(apl_output_stream, "^a^a - ^a", (QConditionalNewLine), brief_msg, long_error_msg); else short_form: call ioa_$ioa_stream (apl_output_stream, "^a^a", (QConditionalNewLine), brief_msg); if options & SystemErrorEntry then go to finish; /* now put out second line (user source with mark) unless suppressed */ if source_line = "" then go to finish; if function_name_ptr = null /* error in evaluated input */ then do; buffer = ""; /* no longer put in 6 spaces, come from dim */ if marker_pos-1 ^= 0 /* EIS kludge */ then buffer = buffer || substr(source_line, 1, marker_pos-1); buffer = buffer || QMarkError; /* put in char to tell dim to put caret under next char */ if length(source_line) - marker_pos + 1 ^= 0 /* EIS kludge */ then buffer = buffer || substr(source_line, marker_pos); end; else do; /* error in body of a function */ call ioa_$rsnpnnl("^a[^d]^x", buffer, (0), function_name_ptr -> symbol_bead.name, line_number); if length(buffer) < 6 then buffer = buffer || " "; if marker_pos-1 ^= 0 /* EIS kludge */ then buffer = buffer || substr(source_line, 1, marker_pos-1); buffer = buffer || QMarkError; if length(source_line) - marker_pos + 1 ^= 0 /* EIS kludge */ then buffer = buffer || substr(source_line, marker_pos); end; /* take care of possibility of buffer overflow */ if length(buffer) = 200 /* the length it was declared with above */ then do; too_long = "... "; ios_write_length = length (buffer) + length (too_long); end; else do; buffer = buffer || (QConditionalNewLine); /* will put NewLine if line doesn't end in one */ ios_write_length = length(buffer); end; call ios_$write(apl_output_stream, addr(buffer), 4 /* varying-string hack */ , ios_write_length, (0), (""b)); finish: call ios_$resetread(apl_input_stream, (""b)); /* flush input since was an error */ if ws_info_ptr ^= null /* don't fault */ then if ws_info.debug_mode then if short_error_msg = "system" then do; call ioa_$ioa_stream(apl_output_stream, "debug mode -- coming up to command level"); call cu_$cl; end; if options & SystemErrorEntry then signal apl_system_error_; /* this will never return */ return; apl_system_error_: entry (code); /* less parameters for system errors */ options = SystemErrorEntry; go to join; apl_error_$huh: entry (code); /* for )HUH command; reprint an error in long form */ options = HuhEntry; go to join; end /* apl_error_ */;  apl_error_table_.alm 11/05/86 1621.0r w 11/04/86 1038.9 140229 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " apl_error_table_.alm " initially typed in 7/7/73 by DAM " this error table has all the APL error messages " Modified by PG on 740516 to add cant_push_save_frame " Modified 740625 by PG to add not_implemented " Modified 740830 by PG to add ws_full_no_quota and bad_print_value. " Modified 740909 by PG to add exec_restricted " Modified 770106 by PG to add line_number_missing, and delete header_cannot_be_deleted " Modified 770224 by PG to add incomplete_expansion " Modified 771121 by PG to conv to ALM, add unknown_system_var, and various parse system errs " Modified 780211 by PG to changed some WS FULLs to RESULT SIZE ERRORs. " Modified 780227 by PG to add bead_already_free " Modified 780504 by PG to add misplaced_diamond " Modified 780505 by PG to stop listing bleeping object code " Modified 780707 by William York to add file errors " Modified 780901 by PG to add more codes for apl_load_command_. " Modified 780909 by PG to add underscore_cant_begin_id. " Modified 780914 by PG to put mapping_table here. " Modified 780920 by PG to add mixed_diamonds_and_semicolons. " Modified 780927 by PG to add cant_read_input " Modified 781220 by PG to change several errors to NONCE ERRORs, and add some new ones. " Modified 790327 by PG to add display_disabled. " Modified 790625 by PG to add result_size " Modified 790912 by PG to add function " Modified 800819 by WMY to add rqo_on_file " Modified 800821 by WMY to add bad_context_request " Modified 810618 by WMY to add context editor errors missing_slash, " bad_substitute, and bad_global_print. " maclist off macro maclist &end include et_macros et apl_error_table_ " LEX ERRORS ec duplicate_label,syntax, (label appears on more than one line) ec ill_inner_prod,syntax, (malformed inner product) ec ill_outer_prod,syntax, (malformed outer product) ec ill_reduction,syntax, (reduction is not allowed with this function) ec ill_scan,syntax, (scan is not allowed with this function) ec lex_screwed_up,system, (internal error in the lex) ec misplaced_diamond,syntax, (misplaced diamond) ec misplaced_right_arrow,syntax, (misplaced right arrow) ec misplaced_semicolon,syntax, (misplaced semicolon) ec mixed_diamonds_and_semicolons,syntax, (line cannot contain both diamonds and semicolons) ec not_end_with_newline,system, " used by parse as well. (text ends without a newline) ec random_char,syntax, (this character may only appear in a quoted string) ec too_many_statements,nonce, (only 100 statements per line) ec underscore_cant_begin_id,syntax, (an underscore cannot begin an identifier) ec excess_right_parens,syntax, (excess right parenthesis) ec mismatched_parens,syntax, (mismatched parentheses) ec ill_opr_brackets,syntax, (brackets are not allowed with this function) ec misplaced_brackets,syntax, (misplaced brackets) ec excess_right_brackets,syntax, (excess right bracket) ec not_end_with_value,syntax, (you need a value here) ec ill_small_circle,syntax, (apparent outer product does not contain a period) ec unknown_system_name,syntax, (unknown system variable or function) ec ws_full_in_lex,nonce, (function is too big) ec constant_mism,syntax, (adjacent constants must be both numeric or both character) ec ill_paren_level,syntax, (unmatched left parenthesis or bracket) ec not_allowed_inner_prod,syntax, (inner product is not allowed with this function) ec not_allowed_outer_prod,syntax, (outer product is not allowed with this function) ec more_than_one_line,system, (text contains more than one line) ec extra_decimal_point,syntax, (extra decimal point in number) ec badass,syntax, (malformed assignment) ec lone_upper_minus,syntax, (upper minus must be followed by a number) ec lone_period,syntax, (a number may not consist of only a decimal point) ec excess_label,syntax, (only one label per line is allowed) ec random_char_in_hdr,defn, (this character cannot appear in a function header line) ec need_name,defn, (you need a name here) ec only_1_return_value,defn, (only one return-value symbol may appear) ec need_semicolon,defn, (a semicolon must precede the list of local variables) ec too_short_execute,syntax, (incomplete expression) ec (mism_quotes,u_mism_ur_quotes),syntax, (mismatched character string quotes) ec more_than_one_line_execute,syntax, (the string to be executed is not a single expression) ec bad_subsc_assign_sys_var,nonce, (subscripted assignment to this system variable is not allowed) ec cant_be_localized,defn, (name of system-variable being localized is misspelled) " PRIMITIVE OR EXTERNAL FUNCTION ERRORS ec compatibility_error,compat, (this operator has been changed) ec display_disabled,context, (this operator requires debug mode) ec domain,domain, () ec exec_restricted,context, (Multics commands are restricted) ec fixedoverflow,nonce, (fixedoverflow condition) ec function,function, (in external function) ec incomplete_expansion,length, (number of ones is not equal to length of expansion coordinate) ec index,index, (bad subscript) ec invalid_circular_fcn,domain, (invalid left argument to circle) ec iota_argument_not_vector,rank, (dyadic iota requires vector left argument) ec length,length, () ec no_identity,domain, (this operator has no identity element) ec not_implemented,context, (this operator is not supported by this implementation) ec not_within_int_fuzz,domain, (value not integral) ec operator_subscript_range,rank, (subscript on function is out of range) ec overflow,nonce, (exponent overflow) ec random_system_error,system, (save output and contact maintenance personnel) ec rank,rank, () ec system,system, () ec zerodivide,domain, (attempt to divide by zero) " EDITOR ERRORS ec bad_substitute_syntax,defn, (incorrect syntax in substitute request) ec edited_pendent_fcn,si-damn, (did not change pendent copy of function) ec extra_text,defun, (extraneous characters after end of line) ec line_too_long_to_edit,nonce, (line too long to edit) ec labels_differ,si-damn, (did not change suspended copy of function; labels differ) ec locals_differ,si-damn, (did not change suspended copy of function; local variables differ) ec n_labels_differ,si-damn, (did not change suspended copy of function; number of labels differ) ec n_locals_differ,si-damn, (did not change suspended copy of function; number of local variables differ) ec substitute_failed,defn, (substitution failed) ec mismatched_editor_quotes,system, (mismatched editor quotes) ec empty_editor_brackets,defn, (no line number or quad present in brackets) ec missing_quad_or_rb,defn, (expected quad or right bracket missing) ec missing_number_or_rb,defn, (expected number or right bracket missing) ec missing_rb,defn, (expected right bracket missing) ec missing_number,defn, (expected line number missing) ec bad_token_in_brackets,defn, (this character may not appear within editor brackets) ec misplaced_left_arrow,defn, (found left arrow where not expected) ec missing_function_name,defn, (function name expected in this position) ec pendent_function_edited,defn, " IBM and v1apl spell it pend_ent (a pendent function may not be edited) ec suspended_header,defn, (you may not edit the header of a suspended function) ec only_integer_after_quad,defn, (only an integer may appear after an editing quad) ec line_number_missing,defn, (no line number specified) ec complicated_header_line,defn, (header line for pre-existing function may contain only function name) ec non_function_edited,defn, (attempt to edit a variable or group symbol) ec locked_function_edited,defn, (attempt to edit a locked function) ec external_function_edited,defn, (attempt to edit an external function) ec variable_name_required,defn, (a variable name is required in this position) ec unmatched_editor_brackets,defn, (a right bracket is required in this position) ec bad_editor_bracket_syntax,defn, (a right bracket or quad is required in this position) ec del_in_wrong_place,defn, (a del may only appear at the end of a definition line) ec too_many_editor_digits,defn, (a line number may contain only five digits to the right of the decimal point) ec bad_function_header,defn, (invalid header must be corrected before exiting editor) ec bad_context_request,syntax, (invalid context editing request) ec missing_slash,syntax, (search/substitute strings must be delimited by slashes) ec bad_substitute,syntax, (invalid substitute request) ec bad_global_print,syntax, (invalid global print request) " COMMAND ERRORS ec cant_autoload,command, (unable to autoload ws.) ec cant_save_ws,system, (unable to save ws.) ec cant_load_ws,system, (unable to load saved ws due to internal format error.) ec pendent_function_copied,si-damn, (attempt to copy into a pendent function.) ec (pendent_function_erased,pendant_object_erased),si-damn, (attempt to erase a pendent function.) ec ws_dir_restricted,restrict, (ws directory restricted to working dir.) ec ws_locked,command, (ws locked.) ec ws_wrong_version,command, (ws version incorrect.) " STORAGE MANAGER ERRORS ec attempt_to_free_not_temp,system, (attempt to free a temporary segment which is not a temporary segment) ec bead_already_free,system, (attempt to free a bead that is already free) ec no_type_bits,system, (value has no type bits) ec tables_inconsistent,system, (internal error in storage manager) ec hash_table_full,ws-full, (storage manager hash table is full) ec bead_not_known_to_apl,system, (attempt to free bead in segment not known to apl) ec cant_create_seg,system, (no access to create segments in specified directory) ec cant_truncate_seg,system, (a freed temporary segment cannot be truncated) ec invalid_free_bead,system, (attempt to free a bead with non-zero reference count) ec non_existent_stack,system, (the value stack has gotten into a segment that was not assigned to it) ec uninterned_symbol,system, (symbol bead not in hash table) ec temp_seg_already_exists,system, (there exist other apl_seg_NNN temps not created by segment manager) ec (wsfull_alloc_too_big,result_size),res-size, (object would be larger than a segment) ec wsfull_no_stack_segs,ws-full, (no more room for value stack) ec wsfull_on_stack,res-size, (temporary object would be larger than a segment) ec wsfull_out_of_maps,ws-full, (segment-map tables exhausted) ec wsfull_out_of_segs,ws-full, (segment tables exhausted) " SYSTEM VARIABLES ERRORS ec bad_assign_to_system_var,domain, (attempt to assign an improper value to a system variable) ec no_sv,syntax, (shared variables are not supported by this implementation) ec unknown_system_var,system, (unknown system variable) " PARSE ERRORS ec assign_to_value,usage, (assignment to non-variable) ec assign_to_label,usage, (attempt to redefine the value of a label) ec bad_assignment,usage, (invalid assignment) ec bad_evaluated_input,usage, (evaluated-input does not accept lists) ec bad_execute,execute, (the argument is not a single expression) ec cant_get_stop_trace,usage, (cannot get stop/trace control) ec (cant_push_save_frame,depth),depth, (depth of function calls is too great) ec cant_read_input,system, (unable to read from apl_input_) ec context,context, (there is probably a missing function here) ec done_line_system_error,system, (bad frame type after finishing current line) ec execute,execute, (attempt to execute a malformed string) ec improper_dyadic_usage,usage, (this function may not be used dyadically) ec improper_monadic_usage,usage, (this function may not be used monadically) ec improper_niladic_usage,usage, (this function may not be used niladically) ec interrupt,intr, () ec locked_function_error,domain, (error occurred within locked function) ec pull_assign_system_error,system, (assignment to non-symbol) ec pull_system_error,system, (invalid lexeme or invalid meaning for name) ec report_error_system_error,system, (bad frame type while reporting another error) ec super_dirty_stop,system, (operation not complete) ec too_much_input,nonce, (input line is too long) ec value,value, () ec ws_full_no_quota,ws-full, (record quota overflow) " SUBSYSTEM ERRORS ec system_error,system, () " SUBSYSTEM AND COMMAND STATUS CODES ec return_from_apl,system, (status code apl_error_table_$return_from_apl) ec ws_loaded,system, (status code apl_error_table_$ws_loaded) ec ws_cleared,system, (status code apl_error_table_$ws_cleared) ec off_hold,system, (status code apl_error_table_$off_hold) " FILE SYSTEM ERRORS ec rqo_on_file,ws-full, " ws full (file space exhausted) ec file_already_tied,ftied, " file tied (file already tied) ec tie_num_in_use,tiedup, " file tie error (tie num already in use) ec bad_tie_num,tiedup, " file tie error (number not tied to a file) ec bad_component_num,badcomp, " file index error (component number out of range) ec not_enough_components,badcomp, " file index error (file has fewer components than specified) ec bad_apl_file,badfile, " bad file format (bad file format) ec old_file_header,oldfile, " old file version (old file version) ec file_already_exists,fnameerr, " file name error (file name duplication) ec no_such_file,fnameerr, " file name error (file not found) ec bad_file_name,fnameerr, " file name error (invalid file name) ec bad_fname_match,fnameerr, " file name error (file name given does not match tied file name) ec too_many_files,ftoomany, " file tie quota used up (maximum number of files exceeded) ec no_write_permission,fmoderr, " file access error (user has no write access to file) ec no_access_to_file,fmoderr, " file access error (user has no access to file) ec bad_access_modes,badmatrx, (invalid access modes supplied) ec bad_access_matrix,badmatrx, (badly formed access matrix) " " Table used to map short names to long names. " macro map aci "&1",8 aci "&2",24 set num_maps,num_maps+1 &end " set num_maps,0 "initialize var to count number of map entries " segdef mapping_table mapping_table: map (domain),(domain error) map (defn),(defn error) map (index),(index error) map (length),(length error) map (rank),(rank error) map (syntax),(syntax error) map (value),(value error) map (depth),(depth error) map (system),(system error) map (ws-full),(ws full) map (si-damn),(si damage) map (intr),(interrupt) map (usage),(usage error) map (context),(context error) map (execute),(¼ error) "that's a \274 there..._e. map (compat),(compatibility error) map (res-size),(result size error) map (nonce),(nonce error) map (command),(command error) map (function),(function error) map (ftied),(file tied) map (tiedup),(file tie error) map (badcomp),(file index error) map (badfile),(bad file format) map (oldfile),(old file version) map (fnameerr),(file name error) map (ftoomany),(file tie quota used up) map (fmoderr),(file access error) map (badmatrx),(bad access matrix) segdef n_map_entries n_map_entries: zero 0,num_maps end  apl_external_fcn_defn_.pl1 11/29/83 1637.3r w 11/29/83 1346.3 82413 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_external_fcn_defn_: proc(a_a_path, a_class); /* * this routine defines an external function for APL * it is called by the )ZFN, )MFN, and )DFN commands. * written 73.09.05 by DAM Modified 811210 by TO to add apl_search_paths for local functions. */ dcl a_a_path char(*) parameter, /* pathname of external function */ a_class fixed bin parameter, /* class code to put in function bead */ a_path char(length(a_a_path)) aligned init(a_a_path) automatic; /* must copy argument because apl_create_save_frame_ clobbers the portion of the stack used as a command buffer, which is where a_a_path is */ if ^init_flg then call init; esw = 0; sbp = null; call apl_create_save_frame_; /* now running in the global environment */ if index(a_path, " ") ^= 0 then do; /* 2 arguments, first is apl name */ call apl_scan_(a_path, 1, apl_name_pos, apl_name_len, tok_type, null); if tok_type ^= 2 then go to incorrect_command; if apl_name_pos+apl_name_len ^= index(a_path, " ") then go to incorrect_command; call apl_get_symbol_(substr(a_path, apl_name_pos, apl_name_len), sbp, (0)); call apl_scan_(a_path, apl_name_pos+apl_name_len, cx, (0), tok_type, null); if tok_type = 0 then go to incorrect_command; /* trailing spaces?? */ end; else cx = 1; /* now process pathname/refname argument */ not_refname = "0"b; cx0 = cx; do cx = cx by 1 to length(a_path); if substr(a_path, cx, 1) = "<" then not_refname = "1"b; else if substr(a_path, cx, 1) = ">" then not_refname = "1"b; else if substr(a_path, cx, 1) = " " then go to incorrect_command; end; if not_refname then do; /* pathname */ call expand_path_(addr(a_path_pn_part), length(a_path)+1-cx0, addr(dn), addr(en), code); if code ^= 0 then go to coderr; call seperate_en; call hcs_$initiate(dn, seg_name, seg_name, 0, 0, segptr, code); if segptr = null then go to coderr; if code = error_table_$namedup then go to coderr; /* should be possible to get around this somehow if there was a decent interface to the linker */ end; else do; /* refname */ en = substr(a_path, cx0); call seperate_en; end; join: if ^not_refname then do; call hcs_$fs_get_seg_ptr (seg_name, segptr, code); if segptr ^= null () then goto make_ptr; /* initiated already */ call search_paths_$find_dir ("apl", null (), seg_name, ref_dir_name, dn, code); if code ^= 0 then goto make_ptr; call hcs_$initiate (dn, seg_name, seg_name, 0, 0, segptr, code); if segptr = null () then goto coderr; if code = error_table_$namedup then goto coderr; end; make_ptr: call hcs_$make_ptr(addr (apl$), seg_name, entry_name, entry_ptr, code); if entry_ptr = null then go to coderr; call hcs_$fs_get_mode(entry_ptr, mode, code); if code ^= 0 then go to coderr; if (bit(fixed(mode, 4), 4) & "0100"b) = "0000"b then go to moderr; if esw ^= 0 then go to got_entry_ptr; /* if necessary, pick up sbp which points at symbol bead */ if cx0 = 1 then call apl_get_symbol_(decat(en, " ", "100"b), sbp, (0)); /* compute function_bead.text as reference name or full path name */ if not_refname then do; call expand_path_(addr(a_path_pn_part), length(a_path)+1-cx0, addr(dn), null, code); if code ^= 0 then go to coderr; /* !! should never happen !! */ end; else dn = a_path_pn_part; data_elements = length(decat(dn, " ", "100"b)); /* don't store trailing blanks */ /* do not allow if name already has a global meaning */ if sbp -> symbol_bead.meaning_pointer ^= null then go to incorrect_command; /* now create the function bead */ call apl_allocate_words_(size(function_bead), fbp); string(fbp -> function_bead.type) = function_type; fbp -> function_bead.lexed_function_bead_pointer = entry_ptr; fbp -> function_bead.class = a_class; fbp -> function_bead.stop_control_pointer, fbp -> function_bead.trace_control_pointer = null; fbp -> function_bead.text_length = data_elements; fbp -> function_bead.text = substr(dn, 1, data_elements); /* now hook onto the meaning of the symbol which names the function */ sbp -> symbol_bead.meaning_pointer = fbp; call wash_sbp; call apl_destroy_save_frame_update_; return; moderr: code = error_table_$moderr; coderr: call com_err_(code, myname(esw), substr(a_path, cx0)); call wash_sbp; if esw = 0 then call apl_destroy_save_frame_; return; incorrect_command: call wash_sbp; if esw ^= 0 then do; /* should never happen */ code = error_table_$badpath; go to coderr; end; call ioa_$ioa_stream (apl_output_stream, "^Rincorrect command^B"); call apl_destroy_save_frame_; return; wash_sbp: proc; if sbp = null then return; sbp -> symbol_bead.reference_count = sbp -> symbol_bead.reference_count - 1; if sbp -> symbol_bead.reference_count <= 0 then call apl_free_bead_(sbp); end; seperate_en: proc; if index(en, "$") = 0 then seg_name, entry_name = en; else do; seg_name = decat(en, "$", "100"b); entry_name = decat(en, "$", "001"b); end; end; init: proc; call hcs_$fs_get_path_name (addr (apl$), dn, ix, en, code); if code = 0 then ref_dir_name = dn; init_flg = "1"b; return; end; apl_external_fcn_addr_: entry(a_a_path, return_pointer_alignment_structure); /* * this entry, given function_bead.text for an external function, returns its entry-point pointer */ if ^init_flg then call init; esw = 1; sbp = null; cx0 = 1; /* in case error */ /* two possibilities - absolute pathname or refname */ if substr(a_path, 1, 1) = ">" then do; /* full pathname */ not_refname = "1"b; call expand_path_(addr(a_path), length(a_path), addr(dn), addr(en), code); if code ^= 0 then go to coderr; /* !! */ call seperate_en; call hcs_$initiate(dn, seg_name, seg_name, 0, 0, segptr, code); if segptr = null then go to coderr; if code = error_table_$namedup then go to coderr; end; else do; /* reference name */ not_refname = "0"b; en = a_path; call seperate_en; end; go to join; got_entry_ptr: return_pointer = entry_ptr; return; dcl 1 return_pointer_alignment_structure aligned structure parameter, 2 return_pointer unaligned pointer; dcl apl_name_pos fixed bin(21), apl_name_len fixed bin(21), tok_type fixed bin, sbp unaligned pointer, /* -> symbol bead */ fbp unaligned pointer, /* -> function bead */ ix fixed bin, cx fixed bin(21), /* current character index */ cx0 fixed bin(21), /* character index of start of pathname or refname */ not_refname bit(1), dn char(168), en char(32), seg_name char(32), entry_name char(32), segptr pointer, entry_ptr pointer, code fixed bin(35), esw fixed bin, mode fixed bin(5), data_elements fixed bin(21); /* based */ dcl 1 a_path_expand_path_hack_overlay based(addr(a_path)), 2 first_part char(cx0-1), 2 a_path_pn_part char(length(a_path)-cx0+1); dcl apl_create_save_frame_ entry, apl_destroy_save_frame_ entry, apl_destroy_save_frame_update_ entry, apl_scan_ entry(char(*) aligned, fixed bin(21), fixed bin(21), fixed bin(21), fixed bin, unaligned pointer), apl_get_symbol_ entry(char(*), unaligned pointer, fixed bin), apl_free_bead_ entry(unaligned pointer), apl_allocate_words_ entry(fixed bin(18), unaligned pointer); dcl expand_path_ entry(pointer, fixed bin, pointer, pointer, fixed bin(35)), hcs_$initiate entry(char(*), char(*), char(*), fixed bin(1), fixed bin(2), pointer, fixed bin(35)), hcs_$make_ptr entry(pointer, char(*), char(*), pointer, fixed bin(35)), hcs_$fs_get_mode entry(pointer, fixed bin(5), fixed bin(35)), hcs_$fs_get_path_name entry (pointer, char (*), fixed bin, char (*), fixed bin (35)), hcs_$fs_get_seg_ptr entry (char (*), pointer, fixed bin (35)), search_paths_$find_dir entry (char (*), pointer, char (*), char (*), char (*), fixed bin (35)), com_err_ entry options(variable), ioa_$ioa_stream entry options(variable); /* external static */ declare apl$ external static; dcl (error_table_$moderr, error_table_$namedup, error_table_$badpath, error_table_$no_search_list) fixed bin(35) external; dcl init_flg bit (1) aligned int static init ("0"b); dcl ref_dir_name char (168) int static init (""); dcl myname(0:1) char(32) static init("apl_external_fcn_defn_", "apl_external_fcn_addr_"); dcl apl_output_stream char (11) static initial ("apl_output_"); dcl (addr, bit, fixed, length, substr, index, null, size, string, decat) builtin; /* include files */ %include apl_bead_format; %include apl_function_bead; %include apl_symbol_bead; end;  apl_file_system_.pl1 11/29/83 1637.3rew 11/29/83 1346.4 599436 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_file_system_: procedure (operators_argument); /* Procedure to manage APL component files. Written 2/79 by William M. York. Modified 790212 by WMY to add entrypoints for untying and unlocking all tied files, and to check for code = 0 before calling file_error. Modified 790213 by WMY to implement qFLIB. Modified 790225 by WMY to make qFLIB free up allocated storage. Modified 790225 by WMY to fix bug 397 (value_stack_ptr gets assigned from an uninitialized variable). Modified 800814 by WMY fix bug 470 (attemtping to open or create a file when quota is exhausted leaves the switch attached). Modified 820120 by WMY to fix a problem for Renault in which qFHOLD returns a not_a_valid_iocb or no_iocb error code. */ /* Automatic storage */ dcl share bit (1) aligned; /* open file for sharing */ dcl create_if_not_found bit(1) aligned; /* create new files? */ dcl untie_error bit(1) aligned; dcl flim_not_fsize bit(1) aligned; /* for common code */ dcl fsetacl_not_faddacl bit(1) aligned; /* for common code */ dcl switched_one bit(1) aligned; /* for sorting */ dcl (left_vb, right_vb) ptr; /* ptrs to arg beads */ dcl (left, right) ptr; /* ptrs to arg values */ dcl result_vb ptr unaligned; /* to APL bead */ dcl bead_size fixed bin(21); /* size of APL value */ dcl size_read fixed bin(21); /* size of record read */ dcl data_ptr ptr; /* ptr to data elements */ dcl tie_num fixed; /* current tie num */ dcl iocb_ptr ptr; /* current file ptr */ dcl tied_array_idx fixed bin; /* where to put info */ dcl data_elements fixed bin; /* number of values in right arg */ dcl component_number fixed bin; dcl component_key picture "99999999999"; /* for conversion to string */ dcl start_component fixed bin; /* first component done */ dcl end_component fixed bin; /* last one done */ dcl drop_number fixed bin; /* number of components to drop */ dcl file_pathname char(168); /* file name stuff */ dcl (file_dname, new_dname) char(168); dcl (file_ename, new_ename) char(32); dcl user_name char(22); /* for keeping record of */ dcl user_project char(9); /* who wrote what */ dcl (count, idx) fixed bin; /* random counters */ dcl increment fixed bin; /* do loop step */ dcl temp_string char(20) varying; /* scratch string */ dcl info_ptr ptr; /* for vfile_status_ */ dcl lock_info bit(2) aligned; /* for set_file_lock */ dcl lock bit(2) init ("10"b); /* lock file, inhibit writes only */ dcl unlock bit(2) init ("00"b); /* unlock file */ dcl current_file_locked bit(1) init ("0"b); /* indicator of locking */ dcl system_area area (261120) based (area_ptr); /* for acl structure */ dcl area_ptr pointer; /* for acl hacking */ dcl acl_ptr pointer; dcl acl_count fixed bin; dcl mode_string char(4); /* ACL modes; "rew", etc */ dcl fcb_ptr pointer; /* for msf_manager_ */ dcl (code, code2) fixed bin(35); /* status code */ dcl 1 index_info based (info_ptr) like indx_info; dcl 1 segment_acl (acl_count) aligned based (acl_ptr), 2 access_name char(32), 2 modes bit(36), 2 zero_pad bit(36), 2 status_code fixed bin(35); dcl 1 delete_acl (acl_count) aligned based (acl_ptr), 2 access_name char(32), 2 status_code fixed bin(35); dcl uid bit(36); /* segment unique id */ /* These arrays must be the same dimension as tied_files */ dcl file_uids (100) bit(36); /* for locking order */ dcl array_idxs (100) fixed bin; /* for keeping array idxs */ /* Header information at the beginning of each file. */ dcl 1 file_header, /* info at head of file */ 2 version fixed bin, 2 first_component fixed bin, 2 last_component fixed bin; dcl file_header_version fixed bin init (1); dcl file_header_size fixed bin (21); dcl file_header_key char(256) varying init ("APL_file_header"); /* Header information for each component. */ dcl 1 component_header, 2 size fixed bin, 2 user_id char(32), 2 user_number fixed bin, 2 time fixed bin(71); dcl component_header_size fixed bin(21); /* Internal static */ dcl 1 apl_file_system_static static, 2 number_of_files_tied fixed bin init (0), 2 first_file_open bit(1) aligned init ("1"b), 2 group_id char(32), 2 tied_files (100), 3 iocb_ptr pointer init ((100) null()), 3 tie_number fixed bin, 3 file_name char(168), 3 shared bit(1), 3 locked bit(1), 3 read_only bit(1), 3 first_component fixed, 3 last_component fixed; /* External static */ dcl apl_static_$apl_output ptr static external; /* Entries */ dcl vfile_status_ entry (char(*), char(*), ptr, fixed bin(35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); dcl msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin(35)); dcl msf_manager_$acl_replace entry (ptr, ptr, fixed bin, bit(1), fixed bin(35)); dcl msf_manager_$acl_add entry (ptr, ptr, fixed bin, fixed bin(35)); dcl msf_manager_$acl_delete entry (ptr, ptr, fixed bin, fixed bin(35)); dcl msf_manager_$close entry (ptr); dcl apl_translate_pathname_$file_system_pathname entry (char(*), char(*), char(*), ptr, fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)); dcl unique_chars_ entry (bit(*)) returns (char(15)); dcl user_info_$whoami entry (char(*), char(*), char(*)); dcl cv_userid_ entry (char(*)) returns (char(32)); dcl get_system_free_area_ entry returns (ptr); dcl ioa_$ioa_switch entry options (variable); /* I/O manipulation routines */ dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); dcl iox_$close entry (ptr, fixed bin(35)); dcl iox_$detach_iocb entry (ptr, fixed bin(35)); dcl iox_$seek_key entry (ptr, char(256) varying, fixed bin(21), fixed bin(35)); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl iox_$rewrite_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl iox_$delete_record entry (ptr, fixed bin(35)); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); /* Builtins */ dcl (null, addr, addrel, rtrim, substr, index, length, size, hbound, lbound, dimension, clock, abs, binary, codeptr, currentsize, divide, fixed, floor, ltrim, rel, string, sum, verify) builtin; /* Error codes */ dcl (error_table_$noentry, error_table_$nomatch, error_table_$file_busy, error_table_$lock_not_locked, error_table_$locked_by_this_process, error_table_$moderr, error_table_$no_info, error_table_$no_operation, error_table_$no_record) fixed bin(35) external; dcl (apl_error_table_$domain, apl_error_table_$not_within_int_fuzz, apl_error_table_$rank, apl_error_table_$length, apl_error_table_$file_already_tied, apl_error_table_$file_already_exists, apl_error_table_$no_write_permission, apl_error_table_$no_access_to_file, apl_error_table_$tie_num_in_use, apl_error_table_$no_such_file, apl_error_table_$bad_tie_num, apl_error_table_$bad_file_name, apl_error_table_$bad_fname_match, apl_error_table_$bad_component_num, apl_error_table_$not_enough_components, apl_error_table_$bad_apl_file, apl_error_table_$old_file_header, apl_error_table_$bad_access_matrix, apl_error_table_$bad_access_modes, apl_error_table_$too_many_files) fixed bin(35) external; /* Include files */ %include vfs_info; %include branch_status; %include star_structures; %include iox_modes; %include apl_number_data; %include apl_ws_info; %include apl_bead_format; %include apl_value_bead; %include apl_operators_argument; /* All calls to file system functions are made through the main procedure, apl_file_system_. The following transfer vector picks the appropriate entry and starts it off. */ /* Pop argument(s) off stack */ if operators_argument.operands(2).on_stack then ws_info.value_stack_ptr = operators_argument.operands(2).value; else if operators_argument.operands(1).on_stack then ws_info.value_stack_ptr = operators_argument.operands(1).value; goto file_operation(operators_argument.op1); niladic_functions: entry (operators_argument); goto file_operation(operators_argument.op1); /* The three entries following all deal with file opening. They merely set some state bits, then call open_file which does all the real work. */ file_operation(75): /* qFCREATE */ share = "0"b; /* exclusive open */ create_if_not_found = "1"b; /* create a new file */ goto decode_args; file_operation(92): /* qFTIE */ share = "0"b; create_if_not_found = "0"b; goto decode_args; file_operation(91): /* qFSTIE */ share = "1"b; create_if_not_found = "0"b; goto decode_args; decode_args: call decode_file_id; call decode_right_arg (1, 1); /* If the maximum number of files are already tied, complain. */ if number_of_files_tied >= dimension (tied_files, 1) then call file_error (apl_error_table_$too_many_files); call open_file (share, create_if_not_found); operators_argument.result = null(); error_return: /* All errors return through here. */ return; /* FUNTIE unties (i.e. closes and detaches) all APL files given in its right argument, updating the file header information if necessary. */ file_operation(121): /* qFUNTIE */ call decode_right_arg (0, -1); /* allow infinite number */ /* Check each tie number for validity and untie them. */ call check_integers (right_vb, code); if code ^= 0 then call file_error (code); untie_error = "0"b; do count = 0 to (right_vb -> value_bead.total_data_elements - 1); tie_num = integerize (right -> numeric_datum (count)); tied_array_idx = get_tie_index (tie_num, code); if code = 0 then call untie_file (tied_array_idx, code); /* If that number is not tied, go to next. Any other error is fatal. */ else if code = apl_error_table_$bad_tie_num then untie_error = "1"b; else call file_error (code); end; /* do for all tie nums */ if untie_error then call file_error (apl_error_table_$bad_tie_num); operators_argument.result = null; return; /* FERASE unties and deletes a file. */ file_operation(78): /* qFERASE */ call decode_file_id; call decode_right_arg (1, 1); /* Find the array index of the specified file. */ tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Get the full pathnames of both the specified file and the file tied to the specified tie number. */ call expand_pathname_ (file_pathname, new_dname, new_ename, code); if code ^= 0 then call file_error (code); call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); if code ^= 0 then call file_error (code); /* Get unique ids of the file specified by name and the file tied to the specified number. */ call hcs_$status_long (new_dname, new_ename, 1, addr (branch_status), null (), code); if code ^= 0 then call file_error (code); uid = branch_status.unique_id; call hcs_$status_long (file_dname, file_ename, 1, addr (branch_status), null (), code); if code ^= 0 then call file_error (code); if branch_status.unique_id ^= uid then call file_error (apl_error_table_$bad_fname_match); call untie_file (tied_array_idx, code); call delete_$path (file_dname, file_ename, "000100"b, "apl", code); if code ^= 0 then call file_error (code); operators_argument.result = null(); return; /* from ferase */ /* FRENAME changes the filename of a tied APL file. */ file_operation(87): /* qFRENAME */ call decode_file_id; call decode_right_arg (1, 1); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Get the full pathnames of both the given filename and the filename of the file tied to the given number. */ call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); if code ^= 0 then call file_error (code); call expand_pathname_ (file_pathname, new_dname, new_ename, code); if code ^= 0 then call file_error (code); /* If the names are not the same, rename the file (hcs_$chname_file complains if the names are identical). */ if new_ename ^= file_ename then do; call hcs_$chname_file (file_dname, file_ename, file_ename, new_ename, code); if code ^= 0 then call file_error (code); tied_files(tied_array_idx).file_name = file_pathname; end; operators_argument.result = null (); return; /* from frename */ /* FAPPEND writes the given APL value to the logical end of the APL file. */ file_operation(74): /* qFAPPEND */ call decode_right_arg (1, 1); left_vb = operators_argument(1).value; tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); iocb_ptr = tied_files(tied_array_idx).iocb_ptr; /* if file is sharable, read header from file */ if tied_files(tied_array_idx).shared then do; file_header_size = size (file_header) * 4; call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); if code ^= 0 then call file_error (code); /* Prevent interference from other users of the shared file */ call lock_file (tied_array_idx, lock); call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); if code ^= 0 then call file_error (code); component_number = file_header.last_component + 1; end; else component_number = tied_files(tied_array_idx).last_component + 1; component_key = component_number; /* convert to string */ call iox_$seek_key (iocb_ptr, (component_key), size_read, code); /* Component must not already be there. */ if code ^= error_table_$no_record then call file_error (apl_error_table_$bad_apl_file); if operators_argument(1).on_stack then bead_size = compute_length (left_vb); else bead_size = binary (left_vb -> value_bead.size) * 4; /* Write the bead out wholesale. The one pointer in it (value_bead.data_pointer) will br reconstructed by FREAD */ call iox_$write_record (iocb_ptr, left_vb, bead_size, code); if code ^= 0 then call file_error (code); /* Update component header */ /* Get info to write to component header... */ component_header.user_id = group_id; component_header.user_number = ws_info.user_number; component_header.time = clock (); component_header.size = bead_size; component_header_size = size (component_header) * 4; /* ...and write it out */ call iox_$seek_key (iocb_ptr, component_key || "info", size_read, code); if code = error_table_$no_record then call iox_$write_record (iocb_ptr, addr (component_header), component_header_size, code); else call iox_$rewrite_record (iocb_ptr, addr (component_header), component_header_size, code); if code ^= 0 then call file_error (code); /* Update file header information, either in the file or in the array */ if tied_files(tied_array_idx).shared then do; file_header_size = size (file_header) * 4; file_header.version = file_header_version; file_header.last_component = component_number; if file_header.first_component = 0 then file_header.first_component = component_number; call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); if code ^= 0 then call file_error (code); call iox_$rewrite_record (iocb_ptr, addr (file_header), file_header_size, code); if code ^= 0 then call file_error (code); /* Unlock the file. */ call lock_file (tied_array_idx, unlock); end; else do; tied_files(tied_array_idx).last_component = component_number; if tied_files(tied_array_idx).first_component = 0 then tied_files(tied_array_idx).first_component = component_number; end; operators_argument.result = null(); return; /* from fappend */ /* FREPLACE replaces the value of a given APL file component with a new value. */ file_operation(88): /* qFREPLACE */ /* Get tie number and component number. */ call decode_right_arg (2, 2); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Check range of component number if possible. */ if ^(tied_files(tied_array_idx).shared) then if (component_number < tied_files(tied_array_idx).first_component) | (component_number > tied_files(tied_array_idx).last_component) then call file_error (apl_error_table_$bad_component_num); /* Get pointer to APL value. */ left_vb = operators_argument(1).value; iocb_ptr = tied_files(tied_array_idx).iocb_ptr; component_key = component_number; /* Seek component with given number. If it does not exist, the component number is out of range. */ call iox_$seek_key (iocb_ptr, (component_key), size_read, code); if code = error_table_$no_record then call file_error (apl_error_table_$bad_component_num); else if code ^= 0 then call file_error (code); /* Compute total size of the bead. */ if operators_argument(1).on_stack then bead_size = compute_length (left_vb); else bead_size = binary (left_vb -> value_bead.size) * 4; /* Write the new value. */ if tied_files(tied_array_idx).shared then call lock_file (tied_array_idx, lock); call iox_$rewrite_record (iocb_ptr, left_vb, bead_size, code); if code ^= 0 then call file_error (code); /* Update the component header. */ /* Get info to write to component header... */ component_header.user_id = group_id; component_header.user_number = ws_info.user_number; component_header.time = clock (); component_header.size = bead_size; component_header_size = size (component_header) * 4; /* ...and write it out */ call iox_$seek_key (iocb_ptr, component_key || "info", size_read, code); if code ^= 0 then call file_error (code); call iox_$rewrite_record (iocb_ptr, addr (component_header), component_header_size, code); if code ^= 0 then call file_error (code); /* As we are replacing a component the total number of components remains the same, and we don't have to update the file header. */ if tied_files(tied_array_idx).shared then call lock_file (tied_array_idx, unlock); operators_argument.result = null(); return; /* from freplace */ /* FDROP deletes components from either end of an APL file. */ file_operation(77): /* qFDROP */ call decode_right_arg (2, 2); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); iocb_ptr = tied_files(tied_array_idx).iocb_ptr; /* If file is opened for sharing, we must read header info from file header. */ if tied_files(tied_array_idx).shared then do; call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); if code ^= 0 then call file_error (code); file_header_size = size (file_header) * 4; call lock_file (tied_array_idx, lock); call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); if code ^= 0 then call file_error (code); start_component = file_header.first_component; end_component = file_header.last_component; end; else do; start_component = tied_files(tied_array_idx).first_component; end_component = tied_files(tied_array_idx).last_component; end; /* Check to see that there are as many components to drop as specified. */ if drop_number > (end_component - start_component + 1) then call file_error (apl_error_table_$not_enough_components); /* If drop_number is positve, drop components from the low numbered end of the file. Update static file information now so that even if something goes wrong, the file will look like the components were dropped. */ if drop_number > 0 then do; end_component = (start_component + drop_number - 1); increment = 1; tied_files(tied_array_idx).first_component = end_component + 1; end; else do; start_component = end_component; /* start from high end */ end_component = (start_component + drop_number + 1); increment = -1; tied_files(tied_array_idx).last_component = end_component - 1; end; /* Check to see if any components remain. If not, reset the static information to the same state as for an empty file. It is not certain that this is done in the APL*PLUS file system, but it seems reasonable. */ if tied_files(tied_array_idx).first_component > tied_files(tied_array_idx).last_component then do; tied_files(tied_array_idx).first_component = 0; tied_files(tied_array_idx).last_component = 0; end; /* Update the shared file information. If this is done here, the components will appear to be gone even if something goes wrong below. */ if tied_files(tied_array_idx).shared then do; file_header.first_component = tied_files(tied_array_idx).first_component; file_header.last_component = tied_files(tied_array_idx).last_component; call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); if code ^= 0 then call file_error (code); call iox_$rewrite_record (iocb_ptr, addr (file_header), file_header_size, code); if code ^= 0 then call file_error (code); call lock_file (tied_array_idx, unlock); end; /* Do the real work. */ do component_number = start_component to end_component by increment; component_key = component_number; call iox_$seek_key (iocb_ptr, (component_key), size_read, code); if code ^= 0 then call file_error (code); call iox_$delete_record (iocb_ptr, code); if code ^= 0 then call file_error (code); end; operators_argument.result = null(); return; /* from fdrop */ /* FREAD reads an APL value from an APL file and returns it. */ file_operation(86): /* qFREAD */ /* Get tie number and component number */ call decode_right_arg (2, 2); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Check component number for proper range of values if info is available */ if ^(tied_files(tied_array_idx).shared) then if (component_number > tied_files(tied_array_idx).last_component) | (component_number < tied_files(tied_array_idx).first_component) then call file_error (apl_error_table_$bad_component_num); iocb_ptr = tied_files(tied_array_idx).iocb_ptr; component_key = component_number; /* Find file component with designated key. If none exists, component number must have been out of range. */ call iox_$seek_key (iocb_ptr, (component_key), size_read, code); if code = error_table_$no_record then call file_error (apl_error_table_$bad_component_num); else if code ^= 0 then call file_error (code); bead_size = divide ((size_read + 3), 4, 21, 0); /* convert bytes to words */ /* Get storage to hold value bead... */ result_vb = apl_push_stack_ ((bead_size)); /* ...and read file component into it. */ call iox_$read_record (iocb_ptr, (result_vb), size_read, size_read, code); if code ^= 0 then call file_error (code); /* Find pointer to actual data. It starts after the last element of value_bead.rho. */ data_ptr = addrel (addr (result_vb -> value_bead.rho (result_vb -> value_bead.rhorho)), 1); /* If data is numeric, it is guarenteed to be even word aligned. Adjust the pointer accordingly. */ if result_vb -> value_bead.numeric_value then if substr (rel (data_ptr), 18, 1) /* even or odd word? */ then data_ptr = addrel (data_ptr, 1); /* Assign value into bead header... */ result_vb -> value_bead.data_pointer = data_ptr; /* ...and return value bead. */ operators_argument.result = result_vb; return; /* from fread */ /* FRDCI returns information about a given component in an APL file. */ file_operation(85): /* qFRDCI */ call decode_right_arg (2, 2); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Check component number for proper range of values if info is available */ if ^tied_files(tied_array_idx).shared then if (component_number > tied_files(tied_array_idx).last_component) | (component_number < tied_files(tied_array_idx).first_component) then call file_error (apl_error_table_$bad_component_num); iocb_ptr = tied_files(tied_array_idx).iocb_ptr; component_key = component_number; /* Find file component with designated key. If none exists, component number must have been out of range. */ call iox_$seek_key (iocb_ptr, component_key || "info", size_read, code); if code = error_table_$no_record then call file_error (apl_error_table_$bad_component_num); else if code ^= 0 then call file_error (code); component_header_size = size (component_header) * 4; call iox_$read_record (iocb_ptr, addr (component_header), component_header_size, size_read, code); if code ^= 0 then call file_error (code); /* Set global infomation on bead size, to be used to calculate how much storage to ask for. */ data_elements = 3; number_of_dimensions = 1; bead_size = size (value_bead) + size (numeric_datum) + 1; /* Get storage for bead. */ result_vb = apl_push_stack_ ((bead_size)); /* Fix up bead. */ string (result_vb -> value_bead.type) = integral_value_type; /* from incl file */ result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result_vb -> value_bead.rho(1) = data_elements; result = addrel (result_vb, size (value_bead)); /* even word align data */ if substr (rel (result), 18, 1) then result = addrel (result, 1); result_vb -> value_bead.data_pointer = result; result -> numeric_datum(0) = component_header.size; result -> numeric_datum(1) = component_header.user_number; result -> numeric_datum(2) = component_header.time; operators_argument.result = result_vb; return; /* from frdci */ /* FNUMS returns the tie numbers of all tied files. */ file_operation(84): /* qFNUMS */ /* We don't need to call decode_right_arg as this is a niladic function, and is guaranteed to have no args (by APL) */ /* Set global data used to compute length of bead. */ data_elements = number_of_files_tied; number_of_dimensions = 1; bead_size = size (value_bead) + size (numeric_datum) + 1; result_vb = apl_push_stack_ ((bead_size)); string (result_vb -> value_bead.type) = integral_value_type; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result_vb -> value_bead.rho(1) = data_elements; /* Find pointer to data. */ result = addrel (result_vb, size (value_bead)); /* Even word align the data pointer. */ if substr (rel (result), 18, 1) then result = addrel (result, 1); result_vb -> value_bead.data_pointer = result; /* Fill in result bead with tie numbers of tied files. */ idx = 0; do count = lbound (tied_files, 1) to hbound (tied_files, 1); if tied_files(count).iocb_ptr ^= null () then do; result -> numeric_datum(idx) = tied_files(count).tie_number; idx = idx + 1; end; end; operators_argument.result = result_vb; return; /* from fnums */ /* FNAMES returns the names of the currently tied files in a character matrix. */ file_operation(83): /* qFNAMES */ /* We don't need to call decode_right_arg because we are guaranteed to have no arguments. */ /* Set global data used for bead size computation. */ data_elements = number_of_files_tied * 168; /* max length of one pathname */ number_of_dimensions = 2; bead_size = size (value_bead) + size (character_data_structure); result_vb = apl_push_stack_ ((bead_size)); /* allocate storage */ string (result_vb -> value_bead.type) = character_value_type; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result_vb -> value_bead.rho(1) = number_of_files_tied; result_vb -> value_bead.rho(2) = 168; /* Find pointer to data in bead */ result = addrel (result_vb, size (value_bead)); result_vb -> value_bead.data_pointer = result; /* Fill in result bead with file pathnames. */ idx = 0; do count = lbound (tied_files, 1) to hbound (tied_files, 1); if tied_files(count).iocb_ptr ^= null () then do; substr (result -> character_string_overlay, (idx * 168 + 1), 168) = tied_files(count).file_name; idx = idx + 1; end; end; operators_argument.result = result_vb; return; /* from fnames */ /* FLIB returns a character matrix of all of the files on the working dir */ file_operation(80): /* qFLIB */ right_vb = operators_argument.operands(2).value; data_elements = right_vb -> value_bead.total_data_elements; file_pathname = right_vb -> value_bead.data_pointer -> character_string_overlay; /* Ask apl_translate_pathname_ for a directory (signified by passing it a null string ename). */ call apl_translate_pathname_$file_system_pathname (file_pathname, file_dname, (""), null (), code); if code ^= 0 then call file_error (code); file_ename = "**.cf.apl"; area_ptr = get_system_free_area_ (); call hcs_$star_ (file_dname, file_ename, 3, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code = 0 then data_elements = star_entry_count * 32; else if code = error_table_$nomatch then data_elements = 0; else call file_error (code); number_of_dimensions = 2; bead_size = size (value_bead) + size (character_data_structure); result_vb = apl_push_stack_ ((bead_size)); string (result_vb -> value_bead.type) = character_value_type; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result_vb -> value_bead.rho(1) = star_entry_count; result_vb -> value_bead.rho(2) = 32; /* Find pointer to data in bead */ result = addrel (result_vb, size (value_bead)); result_vb -> value_bead.data_pointer = result; do count = 1 to star_entry_count; /* star_entry_count will be 0 for no matches. */ substr (result -> character_string_overlay, (count - 1) * 32 + 1, 32) = star_names(star_entries(count).nindex); end; /* If no matches were found, ptr's are null */ if star_names_ptr ^= null() then free star_names in (system_area); if star_entry_ptr ^= null() then free star_entries in (system_area); operators_argument.result = result_vb; return; /* from flib */ /* FLISTACL returns a character matrix of the Access Control List for the msf containing the APL file. */ file_operation(82): /* qFLISTACL */ call decode_right_arg (1, 1); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); iocb_ptr = tied_files(tied_array_idx).iocb_ptr; /* Get pointer to area in which to write data. */ area_ptr = get_system_free_area_ (); /* Get ACL */ call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); if code ^= 0 then call file_error (code); call msf_manager_$open (file_dname, file_ename, fcb_ptr, code); if code ^= 0 then call file_error (code); call msf_manager_$acl_list (fcb_ptr, area_ptr, acl_ptr, null(), acl_count, code); if code ^= 0 then call file_error (code); call msf_manager_$close (fcb_ptr); /* Set global data used to compute bead length. */ data_elements = 36 * acl_count; number_of_dimensions = 2; bead_size = size (value_bead) + size (character_data_structure); result_vb = apl_push_stack_ ((bead_size)); string (result_vb -> value_bead.type) = character_value_type; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result_vb -> value_bead.rho(1) = acl_count; result_vb -> value_bead.rho(2) = 36; /* Find pointer to data in bead */ result = addrel (result_vb, size (value_bead)); result_vb -> value_bead.data_pointer = result; do count = 1 to acl_count; substr (result -> character_string_overlay, (((count - 1) * 36) + 5), 32) = segment_acl(count).access_name; if substr (segment_acl(count).modes, 1, 1) then substr (mode_string, 1, 1) = "r"; else substr (mode_string, 1, 1) = " "; if substr (segment_acl(count).modes, 2, 1) then substr (mode_string, 2, 1) = "e"; else substr (mode_string, 2, 1) = " "; if substr (segment_acl(count).modes, 3, 1) then substr (mode_string, 3, 2) = "w "; else substr (mode_string, 3, 2) = " "; substr (result -> character_string_overlay, (((count - 1) * 36) + 1), 4) = mode_string; end; free segment_acl in (system_area); operators_argument.result = result_vb; return; /* from flistacl */ /* FSETACL sets the Access Control List for an APL file. */ file_operation(89): /* qFSETACL */ fsetacl_not_faddacl = "1"b; goto common_acl_hacker; /* FADDACL adds acl entries to the APL file acl. */ file_operation(73): /* qFADDACL */ fsetacl_not_faddacl = "0"b; goto common_acl_hacker; common_acl_hacker: call decode_right_arg (1, 1); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Decode the left argument */ left_vb = operators_argument.operands(1).value; /* Validate the character matrix */ if ^left_vb -> general_bead.value then call file_error (apl_error_table_$domain); if ^left_vb -> value_bead.character_value /* Must be characters */ then call file_error (apl_error_table_$domain); /* Check for correct dimensionality. Must be vector or 2-dimensional array. */ if (left_vb -> value_bead.rhorho > 2 | left_vb -> value_bead.rhorho < 1) then call file_error (apl_error_table_$rank); /* If value is a matrix, it must be n by 36 */ if left_vb -> value_bead.rhorho = 2 then if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) ^= 36 then call file_error (apl_error_table_$length); else; /* If it is a vector, it must have at least 5 elements ("rew *") */ else if left_vb -> value_bead.total_data_elements < 5 then call file_error (apl_error_table_$length); left = left_vb -> value_bead.data_pointer; /* Get space to put acl structure in. */ area_ptr = get_system_free_area_ (); if left_vb -> value_bead.rhorho = 1 then acl_count = 1; else acl_count = left_vb -> value_bead.rho(1); allocate segment_acl in (system_area); data_elements = left_vb -> value_bead.total_data_elements; /* Fill in acl structure. */ code = 0; do count = 1 to acl_count; if substr (left -> character_string_overlay, 4, 1) ^= " " /* space */ then do; code = apl_error_table_$bad_access_matrix; goto bad_matrix_syntax_exit; end; /* The following statement is designed to allow the user to not bother to pad to 36 characters if his entry is a vector. Basically it uses rho(rhorho) of the value, which is rho(1) for a vector and rho(2) for a matrix, to compute the length of the current row of the value. The rho(2) of the matrix will always be 36 (see code above), the rho(1) of the vector will be the actual length of the vector. The substring of the line from the 5th char for length_of_line - 4 chars is the user id. cv_userid_ converts this into the canonical form. */ segment_acl(count).access_name = cv_userid_ (ltrim (substr (left -> character_string_overlay, ((count - 1) * 36) + 5, left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) - 4))); mode_string = substr (left -> character_string_overlay, ((count - 1) * 36) + 1, 3); if verify (mode_string, "rew ") ^= 0 then do; code = apl_error_table_$bad_access_modes; goto bad_matrix_syntax_exit; end; substr (segment_acl(count).modes, 1, 1) = (index (mode_string, "r") > 0); substr (segment_acl(count).modes, 2, 1) = (index (mode_string, "e") > 0); substr (segment_acl(count).modes, 3, 1) = (index (mode_string, "w") > 0); end; /* Get the APL file pathname, then do the actual ACL rearranging. */ call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename,code); if code ^= 0 then call file_error (code); call msf_manager_$open (file_dname, file_ename, fcb_ptr, code); if code ^= 0 then call file_error (code); if fsetacl_not_faddacl then call msf_manager_$acl_replace (fcb_ptr, acl_ptr, acl_count, "0"b, code); else call msf_manager_$acl_add (fcb_ptr, acl_ptr, acl_count, code); call msf_manager_$close (fcb_ptr); bad_matrix_syntax_exit: if code ^= 0 then call file_error (code); free segment_acl in (system_area); operators_argument.result = null(); return; /* from fsetacl or faddacl */ /* FDELETEACL removes the specified access names from the ACL list for an APL file. */ file_operation(76): /* qFDELETEACL */ call decode_right_arg (1, 1); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); /* Decode the left argument */ left_vb = operators_argument.operands(1).value; /* Validate the character matrix */ if ^left_vb -> general_bead.value then call file_error (apl_error_table_$domain); if ^left_vb -> value_bead.character_value /* Must be characters */ then call file_error (apl_error_table_$domain); /* Check for correct dimensionality. Must be vector or 2-dimensional array. */ if (left_vb -> value_bead.rhorho > 2 | left_vb -> value_bead.rhorho < 1) then call file_error (apl_error_table_$rank); /* Character matrix must be n by 32 */ if left_vb -> value_bead.rhorho = 2 then if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) ^= 32 then call file_error (apl_error_table_$length); else; /* If it is a vector, it must have at least 1 element. */ else if left_vb -> value_bead.total_data_elements < 1 then call file_error (apl_error_table_$length); left = left_vb -> value_bead.data_pointer; /* Get space to put acl structure in. */ area_ptr = get_system_free_area_ (); if left_vb -> value_bead.rhorho = 1 then acl_count = 1; else acl_count = left_vb -> value_bead.rho(1); allocate delete_acl in (system_area); /* Fill in acl structure. */ do count = 1 to acl_count; /* For an explanation of the following statement, see the similar code in fsetacl. */ delete_acl(count).access_name = cv_userid_ (substr (left -> character_string_overlay, ((count - 1) * 32) + 1, left_vb -> value_bead.rho(left_vb -> value_bead.rhorho))); end; /* Get the APL file pathname, then do the actual ACL rearranging. */ call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); if code ^= 0 then call file_error (code); call msf_manager_$open (file_dname, file_ename, fcb_ptr, code); if code ^= 0 then call file_error (code); call msf_manager_$acl_delete (fcb_ptr, acl_ptr, acl_count, code); if code ^= 0 then call file_error (code); call msf_manager_$close (fcb_ptr); free delete_acl in (system_area); operators_argument.result = null(); return; /* from fdeleteacl */ /* FLIM returns the number of the first component and 1 greater than the number of the last component. */ file_operation(81): /* qFLIM */ flim_not_fsize = "1"b; goto flim_fsize_common; /* FSIZE returns the same information as FLIM, plus the storage used and storage reservation of the file */ file_operation(90): /* qFSIZE */ flim_not_fsize = "0"b; goto flim_fsize_common; flim_fsize_common: call decode_right_arg (1, 1); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); iocb_ptr = tied_files(tied_array_idx).iocb_ptr; /* Set global data used to compute bead length. */ if flim_not_fsize then do; data_elements = 2; number_of_dimensions = 1; end; else do; data_elements = 4; number_of_dimensions = 1; end; bead_size = size (value_bead) + size (numeric_datum) + 1; result_vb = apl_push_stack_ ((bead_size)); string (result_vb -> value_bead.type) = integral_value_type; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.rhorho = number_of_dimensions; result_vb -> value_bead.rho(1) = data_elements; /* Find pointer to data. */ result = addrel (result_vb, size (value_bead)); /* Even word align the data pointer. */ if substr (rel (result), 18, 1) then result = addrel (result, 1); result_vb -> value_bead.data_pointer = result; /* Fill in the result bead with the first and last component numbers of the file. */ if tied_files(tied_array_idx).shared then do; call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); if code ^= 0 then call file_error (code); file_header_size = size (file_header) * 4; call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); if code ^= 0 then call file_error (code); result -> numeric_datum(0) = file_header.first_component; result -> numeric_datum(1) = file_header.last_component + 1; end; else do; result -> numeric_datum(0) = tied_files(tied_array_idx).first_component; result -> numeric_datum(1) = tied_files(tied_array_idx).last_component + 1; end; /* Fill in storage used and storage reservation. */ if ^flim_not_fsize then do; call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); if code ^= 0 then call file_error (code); area_ptr = get_system_free_area_ (); allocate index_info in (system_area); index_info.info_version = 1; call vfile_status_ (file_dname, file_ename, info_ptr, code); if code ^= 0 then call file_error (code); result -> numeric_datum(2) = index_info.record_bytes; result -> numeric_datum(3) = TheBiggestNumberWeveGot; free index_info in (system_area); end; operators_argument.result = result_vb; return; /* from flim */ /* FHOLD locks all of the files specified by the user in the right argument after unlocking all of the files the user currently has locked. */ file_operation(79): /* qFHOLD */ /* Allow as many tie nums as the maximum tieable. */ call decode_right_arg (0, hbound (tied_files, 1)); call check_integers (right_vb, code); if code ^= 0 then call file_error (code); /* Unlock all currently locked files. */ do count = lbound (tied_files, 1) to hbound (tied_files, 1); if tied_files(count).iocb_ptr ^= null () then call lock_file (count, unlock); end; /* Check to see that all specified files are tied, and get their UID's to determine locking order. */ do count = 0 to (right_vb -> value_bead.total_data_elements - 1); tie_num = integerize (right -> numeric_datum (count)); tied_array_idx = get_tie_index (tie_num, code); if code ^= 0 then call file_error (code); call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); if code ^= 0 then call file_error (code); call hcs_$status_long (file_dname, file_ename, 1, addr (branch_status), null (), code); if code ^= 0 then call file_error (code); file_uids(count + 1) = branch_status.unique_id; array_idxs(count + 1) = tied_array_idx; end; /* Sort the files by unique id. This ensures that every process using shared files will lock them in the same order, thus preventing deadlocks. */ do count = (right_vb -> value_bead.total_data_elements - 1) to 1 by -1; switched_one = "0"b; do idx = 1 to count; /* If the current entry is greater than the next, switch them, and switch the corresponding array indecies. */ if file_uids(idx) > file_uids(idx + 1) then do; uid = file_uids(idx); file_uids(idx) = file_uids(idx + 1); file_uids(idx + 1) = uid; tied_array_idx = array_idxs(idx); array_idxs(idx) = array_idxs(idx + 1); array_idxs(idx + 1) = tied_array_idx; switched_one = "1"b; /* note that switching was done */ end; end; /* If no entries were exchanged this pass, everything is in order. */ if ^switched_one then goto exit_early; end; exit_early: /* Do the actual file locking. If somebody else has one of the files locked, we will sleep until we can lock it (see attachment and opening modes in open_file). All the preceding UID hair is to ensure that no deadly embraces can occur (everybody locks them in the same order). */ do count = 1 to (right_vb -> value_bead.total_data_elements); call lock_file (array_idxs(count), lock); end; operators_argument.result = null(); return; /* from fhold */ /* open_file is the routine that does all the real work of attaching and opening files. */ open_file: procedure (share, create_if_not_found); dcl (share, create_if_not_found) bit(1) aligned parameter; dcl attach_desc char(256) varying; /* attach description */ dcl record_quota_overflow condition; dcl any_other condition; dcl apl_error_table_$rqo_on_file fixed bin(35) external; /* Take advantage of the fact that this code MUST be executed before any other file system functions can run. */ if first_file_open then do; call user_info_$whoami (user_name, user_project, ("")); group_id = rtrim (user_name) || "." || user_project; first_file_open = "0"b; end; /* See if the specified tie number is already tied to a file, and if so, complain. */ tied_array_idx = get_tie_index (tie_num, code); if code = 0 then call file_error (apl_error_table_$tie_num_in_use); /* Find a free array slot. */ tied_array_idx = get_free_index (tie_num, code); if code ^= 0 then call file_error (code); /* Build the attach description based on previously gathered information. */ attach_desc = "vfile_ " || file_pathname; /* Check to see if file already exists when creating. */ if create_if_not_found then do; call hcs_$status_minf (file_dname, file_ename, 1, (0), (0), code); if code = 0 /* status_minf found the file */ then call file_error (apl_error_table_$file_already_exists); if code ^= error_table_$noentry /* if it was not there, it's OK */ then call file_error (code); end; /* Otherwise, make sure it will not be created. */ else attach_desc = attach_desc || " -old"; /* If the file is to be opened in shared mode, set the wait time for a locked file to -1, forever. This means that any attempt to operate on a file locked by another APL user will wait until the other user unlocks the file, then proceed. */ if share then attach_desc = attach_desc || " -share -1"; else attach_desc = attach_desc || " -exclusive"; /* File information is kept in an internal static array, indexed by tie number. The "shared" bit is the definitive test for determining whether or not file header information may be kept in the static storage or must be written to the file header. */ tied_files(tied_array_idx).shared = share; /* set up any_other handler to catch vfile_ complaints when quota is exhausted. It sometimes gets null pointer faults */ on any_other begin; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); call file_error (apl_error_table_$rqo_on_file); end; /* Attach the APL file. */ call iox_$attach_name (unique_chars_ (""b), iocb_ptr, (attach_desc), codeptr(apl_file_system_), code); if code ^= 0 then call file_error (code); /* All APL value files are indexed files, and are opened in the same way */ call iox_$open (iocb_ptr, Keyed_sequential_update, "0"b, code); if code = error_table_$moderr then do; call iox_$detach_iocb (iocb_ptr, code); /* Since the open failed due to insufficient access, we are going to try to open for read only. This code first takes out the attach description information pertaining to sharable openings, then tries again. */ if share then temp_string = "-share -1"; else temp_string = "-exclusive"; idx = index (attach_desc, temp_string); /* if idx = 0 we are in trouble */ attach_desc = substr (attach_desc, 1, idx - 1) || substr (attach_desc, idx + length (temp_string)); call iox_$attach_name (unique_chars_ (""b), iocb_ptr, (attach_desc), codeptr(apl_file_system_), code); if code ^= 0 then call file_error (code); call iox_$open (iocb_ptr, Keyed_sequential_input, "0"b, code); if code ^= 0 then call iox_$detach_iocb (iocb_ptr, code2); if code = error_table_$moderr then call file_error (apl_error_table_$no_access_to_file); /* Remember that this is a read only file. */ tied_files(tied_array_idx).read_only = "1"b; end; else tied_files(tied_array_idx).read_only = "0"b; if code ^= 0 then call iox_$detach_iocb (iocb_ptr, code2); if code ^= 0 then call file_error (code); /* Find the file header record. If it isn't there, assume this is the first write to this file and continue. */ call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); /* If there is no such record, this is a new file. Use write_record to write header info... */ if code = error_table_$no_record then do; file_header_size = size (file_header) * 4; file_header.version = file_header_version; file_header.first_component = 0; file_header.last_component = 0; call iox_$write_record (iocb_ptr, addr (file_header), file_header_size, code); if code ^= 0 then call file_error (code); if ^share then do; tied_files(tied_array_idx).first_component = 0; tied_files(tied_array_idx).last_component = 0; end; end; /* ...otherwise read the existing header info */ else do; if code ^= 0 then call file_error (code); file_header_size = size (file_header) * 4; call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); if code ^= 0 then call file_error (code); if file_header.version ^= file_header_version then call file_error (apl_error_table_$old_file_header); /* If file is exclusively tied, header info may be kept in static storage */ if ^share then do; tied_files(tied_array_idx).first_component = file_header.first_component; tied_files(tied_array_idx).last_component = file_header.last_component; end; end; revert any_other; /* Set up static data array entry for this file. */ tied_files(tied_array_idx).iocb_ptr = iocb_ptr; tied_files(tied_array_idx).tie_number = tie_num; tied_files(tied_array_idx).file_name = file_pathname; tied_files(tied_array_idx).locked = "0"b; number_of_files_tied = number_of_files_tied + 1; return; end; /* open_file */ /* untie_all_files is intended to be called by APL to untie all of the user's files. This is done when he quits APL. */ untie_all_files: entry; dcl found_one bit(1); found_one = "0"b; do count = lbound (tied_files, 1) to hbound (tied_files, 1); if tied_files(count).iocb_ptr ^= null() then do; call untie_file (count, code); found_one = "1"b; end; end; if found_one then call ioa_$ioa_switch (apl_static_$apl_output, "files untied - some files automatically untied"); return; /* untie_file closes and detaches a file given its tied_files array index, updating the tied file database if necessary. If the specified array index does not refer to a file, untie_file returns. */ untie_file: procedure (tied_array_idx, code); dcl tied_array_idx fixed bin parameter; dcl code fixed bin(35) parameter; dcl iocb_ptr pointer; code = 0; if tied_files(tied_array_idx).iocb_ptr = null() then return; iocb_ptr = tied_files(tied_array_idx).iocb_ptr; /* If the file is exclusively tied, update the header in the file. */ if (^tied_files(tied_array_idx).shared & ^tied_files(tied_array_idx).read_only) then do; file_header_size = size (file_header) * 4; file_header.version = file_header_version; file_header.first_component = tied_files(tied_array_idx).first_component; file_header.last_component = tied_files(tied_array_idx).last_component; call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); if code ^= 0 then return; call iox_$rewrite_record (iocb_ptr, addr (file_header), file_header_size, code); if code ^= 0 then return; end; /* if not shared */ tied_files(tied_array_idx).iocb_ptr = null(); number_of_files_tied = number_of_files_tied - 1; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); end; /* untie_file */ /* decode_file_id parses a filename of an APL file. It also sets the global variables "left_vb" (a pointer to the left value bead), "left" (a pointer to the data in the left vb), "file_dname", "file_ename", and "file_pathname". */ decode_file_id: procedure; /* automatic */ dcl file_id char (168); dcl (libx, strx) fixed bin; /* program */ left_vb = operators_argument.operands (1).value; if ^left_vb -> general_bead.value then call file_error (apl_error_table_$domain); if ^left_vb -> value_bead.character_value then call file_error (apl_error_table_$domain); if (left_vb -> value_bead.total_data_elements = 0) then call file_error (apl_error_table_$length); if (left_vb -> value_bead.rhorho > 1) & (left_vb -> value_bead.total_data_elements ^= 1) then call file_error (apl_error_table_$rank); /* data_elements is a global variable used in based dcls (see declarations of character_datum and character_string_overlay for a better understanding of this code). Set here for length computations. */ data_elements = left_vb -> value_bead.total_data_elements; left = left_vb -> value_bead.data_pointer; /* Strip leading spaces. */ do strx = lbound (left -> character_datum, 1) to hbound (left -> character_datum, 1) while (left -> character_datum (strx) = " "); end; /* If strx is off the end of the array, no non-white characters were found. Report an error. */ if strx > hbound (left -> character_datum, 1) then call file_error (apl_error_table_$bad_file_name); libx = strx; /* index of first non-blank */ /* Does file-id include a library number? */ if index ("0123456789", left -> character_datum (strx)) ^= 0 then do; do strx = strx + 1 to hbound (left -> character_datum, 1) while (left -> character_datum (strx) >= "0" & left -> character_datum (strx) <= "9"); end; /* Skip blanks */ do strx = strx to hbound (left -> character_datum, 1) while (left -> character_datum (strx) = " "); end; /* If strx is off the end of the array, no file name was found after the library number. */ if strx > hbound (left -> character_datum, 1) then call file_error (apl_error_table_$bad_file_name); end; /* Scan file name */ do strx = strx to hbound (left -> character_datum, 1) while (left -> character_datum (strx) ^= " "); end; /* Skip trailing blanks. */ do idx = strx to hbound (left -> character_datum, 1) while (left -> character_datum (idx) = " "); end; /* If idx is not one greater than the length of the string, there is cruft after the file name (possibly a "storage reservation", a number accepted by other APL file systems, but meaningless in Multics APL. */ if idx <= hbound (left -> character_datum, 1) then call file_error (apl_error_table_$bad_file_name); /* strx is now one greater than the last char in the file name. Note that the apparent off-by-one error in using libx + 1 instead of libx is due to the fact the the array character_datum is dimensioned to be 0:data_elements-1 (zero-origin) while the string character_string_overlay is char (data_elements), (one-origin). */ file_id = substr (left -> character_string_overlay, libx + 1, strx - libx); call apl_translate_pathname_$file_system_pathname (file_id, file_dname, file_ename, null, code); file_pathname = rtrim (file_dname) || ">" || file_ename; return; end; /* decode_file_id */ /* decode_right_arg checks to make sure the right number of elements were supplied in the right hand vector. The global variables "tie_num", "component_number", and "drop_number" are set to the 1st, 2nd and 2nd elements of the argument vector. The global variables "right_vb" (a pointer to the right value bead) and "right" (pointer to the actual data in the right vb) are also set. */ decode_right_arg: procedure (min_arg_len, max_arg_len); /* parameters */ dcl (min_arg_len, max_arg_len) fixed bin parameter; /* program */ right_vb = operators_argument.operands(2).value; if ^right_vb -> general_bead.value /* must be a value bead */ then call file_error (apl_error_table_$domain); if ^right_vb -> value_bead.numeric_value /* must be numeric */ then call file_error (apl_error_table_$domain); /* Set global variable used for based objects reference below */ data_elements = right_vb -> value_bead.total_data_elements; /* If we have more than 1 dimension, there better be only one element in the matrix. */ if (right_vb -> value_bead.rhorho > 1) & (data_elements ^= 1) then call file_error (apl_error_table_$rank); /* Check range for length. -1 signifies no limit on values */ if (data_elements < min_arg_len) | ((max_arg_len ^= -1) & (data_elements > max_arg_len)) then call file_error (apl_error_table_$length); right = right_vb -> value_bead.data_pointer; /* If we don't have "real" integers, check for fuzz tolerance. */ if right_vb -> value_bead.integral_value then do; tie_num = fixed (right -> numeric_datum (0)); if data_elements > 1 then do; component_number = fixed (right -> numeric_datum (1)); drop_number = fixed (right -> numeric_datum(1)); end; end; else do; tie_num = integerize (right -> numeric_datum(0)); if data_elements > 1 then do; component_number = integerize (right -> numeric_datum(1)); drop_number = integerize (right -> numeric_datum(1)); end; end; return; end; /* decode_right_arg */ /* integerize converts a floating number to a fixed one if it is within integer fuzz of an integer. If not, an error is reported. */ integerize: procedure (number) returns (fixed bin); dcl number float aligned parameter; /* Check for tolerance outside of integer fuzz range. */ if abs (floor (number + 0.5) - number) < ws_info.integer_fuzz then return (fixed (floor (number + 0.5))); else call file_error (apl_error_table_$not_within_int_fuzz); end; /* integerp */ /* check_integers makes sure that all of the numbers in a numeric value_bead are within integer fuzz of an integer. If they are not, a status code is returned. It is the caller's responsibility to act upon the error. */ check_integers: procedure (bead_ptr, code); dcl bead_ptr ptr parameter; dcl code fixed bin(35); dcl count fixed bin; dcl data_ptr ptr; dcl data_elements fixed bin; code = 0; data_ptr = bead_ptr -> value_bead.data_pointer; data_elements = bead_ptr -> value_bead.total_data_elements; do count = 0 to hbound (data_ptr -> numeric_datum, 1); if abs (floor (data_ptr -> numeric_datum(count) + 0.5) - data_ptr -> numeric_datum(count)) >= integer_fuzz then do; code = apl_error_table_$not_within_int_fuzz; return; end; end; end; /* check_integers */ /* unlock_all_files unlocks all of the currently locked files. It is used by APL each time "desk calcualtor" level is reached. */ unlock_all_files: entry; do count = lbound (tied_files, 1) to hbound (tied_files, 1); if tied_files(count).iocb_ptr ^= null() then call lock_file (count, unlock); end; return; /* lock_file locks or unlocks a file given its tied_files array index, updating the static information. */ lock_file: procedure (tied_array_idx, mode); dcl tied_array_idx fixed bin parameter; dcl mode bit(2) parameter; if tied_files(tied_array_idx).iocb_ptr = null() then return; /* Indicate that some locking action has occurred in this call to the file system. This allows file_error to win. First mode bit is "1"b for lock, "0"b for unlock. */ current_file_locked = substr (mode, 1, 1); /* If state is already right, punt. */ if tied_files(tied_array_idx).locked = current_file_locked then return; /* Set info to reflect given locking state. */ tied_files(tied_array_idx).locked = current_file_locked; lock_info = mode; call iox_$control (tied_files(tied_array_idx).iocb_ptr, "set_file_lock", addr (lock_info), code); if (code ^= 0) & (code ^= error_table_$lock_not_locked) & (code ^= error_table_$locked_by_this_process) then call file_error (code); return; end; /* lock_file */ /* file_error takes care of reporting all errors pertaining to the file system. Some standard error codes are converted wholesale to file system errors. */ file_error: procedure (status_code); dcl status_code fixed bin(35) parameter; if status_code = 0 /* nothing to report */ then return; operators_argument.error_code = status_code; /* file_busy means somebody already has the file exclusively tied. */ if status_code = error_table_$file_busy then operators_argument.error_code = apl_error_table_$file_already_tied; /* These codes just get APL flavoring. */ if status_code = error_table_$noentry then operators_argument.error_code = apl_error_table_$no_such_file; if status_code = error_table_$moderr then operators_argument.error_code = apl_error_table_$no_write_permission; if status_code = error_table_$no_info then operators_argument.error_code = apl_error_table_$no_access_to_file; if status_code = error_table_$no_operation then operators_argument.error_code = apl_error_table_$no_write_permission; if current_file_locked then call lock_file (tied_array_idx, unlock); goto error_return; end; /* file_error */ /* get_tie_index and get_free_index manage the array containing information about tied files. */ get_tie_index: procedure (tie_num, code) returns (fixed bin); dcl tie_num fixed bin parameter; dcl code fixed bin(35) parameter; dcl count fixed bin; /* get_tie_index finds the array index of an already tied file. If the given tie number is not tied to a file, an error is reported. */ code = 0; /* Find the array slot holding the info on the specified tie num. Checking for non-null iocb_ptr is the definitive test of whether or not a slot contains info about a currently tied file. Tie numbers between 1 and 20 (inclusive) are optimized on the grounds that users use them most often. */ if (tie_num < 21) & (tie_num > 0) & (tied_files(tie_num).iocb_ptr ^= null()) /* test for tiedness */ then return (tie_num); else do count = 21 to hbound (tied_files, 1); if (tied_files(count).tie_number = tie_num) /* find matching tie num */ & (tied_files(count).iocb_ptr ^= null()) /* and check for tiedness */ then return (count); end; code = apl_error_table_$bad_tie_num; return (-1); end; /* get_tie_index */ get_free_index: procedure (tie_num, code) returns (fixed bin); dcl tie_num fixed bin parameter; dcl code fixed bin(35) parameter; dcl count fixed bin; /* get_free_index finds a free array entry to use for a newly tied file. */ code = 0; /* Find the array slot not currently holding info about a file. Checking for non-null iocb_ptr is the definitive test of whether or not a slot is in use. Tie numbers between 1 and 20 (inclusive) are optimized on the grounds that users use them most often. */ if (tie_num < 21) & (tie_num > 0) then if tied_files(tie_num).iocb_ptr = null() then return (tie_num); else do; code = apl_error_table_$tie_num_in_use; return (-1); end; else do count = 21 to hbound (tied_files, 1); if tied_files(count).iocb_ptr = null() then return (count); end; code = apl_error_table_$too_many_files; return (-1); end; /* get_free_index */ /* compute_length calculates the size of an APL value bead. */ compute_length: procedure (value_bead_ptr) returns (fixed bin (21)); /* parameter */ declare value_bead_ptr ptr parameter; /* automatic */ declare data_size fixed bin (19), temp_vb ptr; /* program */ temp_vb = value_bead_ptr; /* set global information used to compute length */ data_elements = temp_vb -> value_bead.total_data_elements; if temp_vb -> value_bead.numeric_value then data_size = size (numeric_datum) + 1; else data_size = size (character_string_overlay); return (4 * (currentsize (temp_vb -> value_bead) + data_size)); end /* compute_length */; /* apl_push_stack_ is a utility program to allocate space on the APL stack. */ %include apl_push_stack_fcn; end; /* apl_file_system */  apl_fns_command_.pl1 11/29/83 1637.3r w 11/29/83 1346.4 48033 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modification History - 811210. Modified 811210 by TO to add )EFNS command. */ apl_fns_command_: procedure (a_initial_letter, frame_already_saved); type_string = function_type; go to list_command_common; apl_efns_command_: entry (a_initial_letter, frame_already_saved); type_string = function_type; efns_flag = "1"b; go to list_command_common; apl_vars_command_: entry (a_initial_letter, frame_already_saved); type_string = value_type; go to list_command_common; apl_grps_command_: entry (a_initial_letter, frame_already_saved); type_string = group_type; list_command_common: initial_letter = a_initial_letter; if ^frame_already_saved then do; on cleanup call apl_destroy_save_frame_; call apl_create_save_frame_; end; save_frame_pointer = ws_info.current_parse_frame_ptr; total_symbols = save_frame_pointer -> save_frame.saved_symbol_count; printed_count = 0; do symbol_number = 1 to total_symbols - 1; if save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.meaning_pointer ^= null then do; do other_symbol_number = symbol_number + 1 to total_symbols; if save_frame_pointer -> save_frame.symbol_pointer (other_symbol_number) -> symbol_bead.meaning_pointer ^= null then do; if save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.name > save_frame_pointer -> save_frame.symbol_pointer (other_symbol_number) -> symbol_bead.name then do; temporary = save_frame_pointer -> save_frame.symbol_pointer (symbol_number); save_frame_pointer -> save_frame.symbol_pointer (symbol_number) = save_frame_pointer -> save_frame.symbol_pointer (other_symbol_number); save_frame_pointer -> save_frame.symbol_pointer (other_symbol_number) = temporary; temporary = save_frame_pointer -> save_frame.saved_meaning_pointer (symbol_number); save_frame_pointer -> save_frame.saved_meaning_pointer (symbol_number) = save_frame_pointer -> save_frame.saved_meaning_pointer (other_symbol_number); save_frame_pointer -> save_frame.saved_meaning_pointer (other_symbol_number) = temporary; end; end; end; end; end; do symbol_number = 1 to total_symbols; if save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.meaning_pointer ^= null then if string (save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.meaning_pointer -> general_bead.type) & type_string then if substr (save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.name, 1, 1) >= initial_letter then if ^efns_flag then do; call apl_print_string_ (save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.name); printed_count = printed_count + 1; end; else do; class = save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.meaning_pointer -> function_bead.class; if class = 2 | class = 3 | class = 4 then do; call ioa_$ioa_stream (apl_output_stream, ")^[zfn^;mfn^;dfn^] ^a ^- ^a", class - 1, save_frame_pointer -> save_frame.symbol_pointer (symbol_number) -> symbol_bead.name, save_frame.symbol_pointer (symbol_number) -> symbol_bead.meaning_pointer -> function_bead.text); printed_count = printed_count + 1; end; end; end; if ^efns_flag then do; if printed_count > 0 then call apl_print_newline_; call apl_flush_buffer_; end; else if printed_count > 0 then call ioa_$ioa_stream (apl_output_stream, ""); if ^frame_already_saved then call apl_destroy_save_frame_; declare temporary pointer unaligned; declare (symbol_number, other_symbol_number, total_symbols, printed_count ) fixed binary (29); declare cleanup condition; declare apl_print_string_ entry (character (*)); declare (apl_create_save_frame_, apl_destroy_save_frame_, apl_print_newline_, apl_flush_buffer_ ) entry (); declare ioa_$ioa_stream entry options (variable); declare a_initial_letter character (1); declare frame_already_saved bit (1) aligned; declare initial_letter character (1) aligned; declare type_string bit (18) aligned; declare class fixed bin; declare efns_flag bit (1) aligned init ("0"b); declare apl_output_stream char (11) int static init ("apl_output_"); declare (null, string, substr ) builtin; %include apl_number_data; %include "apl_ws_info"; %include "apl_bead_format"; %include "apl_save_frame"; %include "apl_symbol_bead"; %include "apl_function_bead"; end apl_fns_command_;  apl_format_util_.alm 11/29/83 1637.3rew 11/29/83 1346.4 66303 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " Written 781114 by PG " Modified 781206 by PG to fix 361 (round_fixed computed temp length wrong) " Modified 790305 by PG to fix 369 (round_fixed had test reversed in 0_or_1 case) " Modified 790319 by PG to fix 378 (round_fixed lost negative sign in 0_or_1 case) " Modified 791127 by PG to add split entry. " Modified 810125 by WMY to fix bug 453b, the sign is occasionally dropped in " the split entrypoint. " name apl_format_util_ segdef round segdef round_fixed segdef split " " Usage: " declare apl_format_util_$round entry (float dec (19), fixed bin, char (21)); " " call apl_format_util_$round (value, n_digits, buffer); " " We assume that 0 < n_digits < 20 " " Subroutine to implement a useful round builtin, since the " PL/I round builtin only takes constant arguments to tell it " how many digits to keep! " equ P_value,2 equ P_digits,4 equ P_buffer,6 " " We round to a specified number of decimal digits. This case is easy; " we just assign to a float decimal temp that has as many digits as we " wish to keep. The hardware performs the rounding during assignment. " round: epp1 pr0|P_value,* get ptr to value to round ldq pr0|P_digits,* get number of digits adq 2,dl account for sign and exponent epp2 pr0|P_buffer,* get ptr to temporary space mvn (pr),(pr,rl),round move rounded into buffer desc9fl pr1|0,21 source desc9fl pr2|0,ql target mvn (pr,rl),(pr) move back into input arg desc9fl pr2|0,ql source desc9fl pr1|0,21 target short_return " " Usage: " declare apl_format_util_$round_fixed entry (float dec (19), " fixed bin, char (21)); " " call apl_format_util_$round_fixed (value, n_digits, buffer); " " We round to a specified number of decimal places. This is accomplished " by computing the precision of an intermediate floating decimal temp, " and assigning to it, thus rounding to that number of digits. " The precision of the temp has enough digits to hold the integral part of the " result, as well as the correct number of fractional digits. " " The length of the temporary is: " #integral_digits + #decimal_places + 2 " " = (19 - #leading_zeros + exponent) + #decimal_places + 2 " " = -#leading_zeros + 21 + exponent + #decimal_places " round_fixed: epp1 pr0|P_value,* get ptr to value to round epp2 pr0|P_buffer,* get ptr to temporary space eax7 20 byte offset of exponent mlr (pr,x7),(pr) extract exponent desc9a pr1|0,1 source desc9a pr2|0,1 target lda pr2|0 get exponent als 1 shift sign into place ars 28 extend sign, shift number down sta pr2|0 save exponent tct (pr) count leading zeros desc9a pr1|0(1),19 in decimal value arg zero_table table is here arg pr2|1 flag || count goes here ttn all_zero value is 0e0 lda pr2|1 get flag & count word ana =o000077777777 keep count only sta pr2|1 put it back for later neg 0 form -count ada 21,dl form -count + 21 ada pr2|0 form -count + 21 + exponent ada pr0|P_digits,* form -count + 21 + exponent + decimal_places cmpa 21,dl prec(temp) >= prec(input)? tmi 2,ic no " all_zero: short_return yes...nothing to do cmpa 2,dl prec(temp) <= 2? tmi return_zero <2 ... no digits left tze return_0_or_1 =2 ... one (new) digit left mvn (pr),(pr,rl),round move rounded into buffer desc9fl pr1|0,21 source desc9fl pr2|0,al target mvn (pr,rl),(pr),round move rounded into input desc9fl pr2|0,al source desc9fl pr1|0,21 target short_return " return_zero: mvn (),(pr) store zero desc9ls fixed_zero,2 source desc9fl pr1|0,21 target short_return " fixed_zero: aci "+0" " " In this case, we are rounding away all of the digits in the original value. " For example, if the value was .555, we are rounding to an integer, and the " result is 1.0. The intermediate length in this case is 2...no digits at " all. Thus, we cannot just assign to the intermediate temp. " We end up converting a number of the form: " s000...0DDD...D x 10 ** exp " to: " s000...1000...0 x 10 ** exp " which normalizes to: " s000..........1 x 10 ** (exp + length (DDD...D)) " " thus, new_exp = old_exp + (19 - #leading_zeros) " return_0_or_1: lxl7 pr2|1 get number of leading zeros cmpc (pr,x7),(),fill(065) is the leading digit less than 5? desc9a pr1|0(1),1 the digit desc9a 0,0 a "5" tnc return_zero yes...return zero mlr (pr),(pr),fill(061) move sign and "1" into temp desc9a pr1|0,1 source desc9a pr2|2,2 target lda pr2|0 get exponent ada 19,dl form exp + 19 sba pr2|1 form exp + 19 - #zeros als 28 fixup sign arl 1+18 byte-align, move to byte 3. stba pr2|2,10 store exponent mvn (pr),(pr) move into parameter desc9fl pr2|2,3 source desc9fl pr1|0,21 target short_return " zero_tab: vfd 9/0,9/1,9/2,9/3 TCT table to skip 060's. vfd 9/4,9/5,9/6,9/7 vfd 9/8,9/9,9/0,9/0 " equ zero_table,zero_tab-12 since only 060-071 can ever appear " we don't need full table. " " Usage: " declare apl_format_util_$split entry (float dec (19), fixed dec (19), fixed bin, " char (21)); " " call apl_format_util_$split (decimal_value, integer_value, exponent, round_buffer); " " We take a floating-point, decimal value and split it into two parts: an integer decimal " value that contains the digits, and an integer binary value that contains the adjusted " exponent (adjusted so that it is the true exponent for scientific form). " " equ P_value,2 equ P_integer_value,4 equ P_exponent,6 equ P_buffer4,8 " split: epp1 pr0|P_value,* get ptr to value to split epp4 pr0|P_integer_value,* get ptr to output value epp2 pr0|P_exponent,* get ptr to exponent value epp3 pr0|P_buffer4,* get ptr to buffer in arg 4 eax7 20 byte offset of exponent mlr (pr,x7),(pr) extract exponent desc9a pr1|0,1 source desc9a pr3|0,1 target lda pr3|0 get exponent als 1 shift sign into place ars 28 extend sign, shift number down sta pr3|0 save exponent tct (pr) count leading zeroes desc9a pr1|0(1),19 in decimal value arg zero_table table is here arg pr3|1 flag || count goes here lda 0,dl get ready for zero case ttn split.all_zero value is 0e0 lda pr3|1 get flag & count word ana =o000077777777 keep count only sta pr3|1 save count of leading zeros lda pr3|0 compute true exponent ada 18,dl .. sba pr3|1 = exp + 18 - n_leading_zeros " split.all_zero: sta pr2|0 save in exponent " Now take the digits out of the floating-point decimal number, and slide " them left so that the first non-zero digit of the source becomes the very first digit " of the integer. " mvn (),(pr) initialize target desc9ls fixed_zero,2 source desc9ls pr4|0,20 target lda 19,dl compute # significant digits sba pr3|1 = 19 - n_leading_zeros ldq pr3|1 offset of first digit is just n_leading_zeros mlr (pr,rl,ql),(pr,rl) move digits into position desc9a pr1|0(1),al source (step over sign) desc9a pr4|0(1),al target (step over sign) mlr (pr),(pr) transfer sign from source to target desc9a pr1|0,1 desc9a pr4|0,1 short_return " end  apl_get_symbol_.pl1 11/29/83 1637.3r w 11/29/83 1346.4 28359 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* This program, given the name of a symbol, searches the hash table of symbols for it. If it is found, a pointer to that symbol's symbol_bead is returned, along with the hash index used to find it. If it is not found, a symbol bead for it is created and it is entered into the hash table. Either way you win. (Speaking of gratuitous side-effects...) Written on an unknown date by an unknown person, probably DAM This comment inserted, and name apl_get_symbol_ added by G. Gordon Benedict in July 1974 */ apl_get_symbol_: get_apl_symbol_: proc(symbol_name, return_ptr, hash_index); dcl symbol_name char(*), /* name of symbol to get bead for. No trailing spaces */ 1 return_ptr aligned structure, 2 return_pointer pointer unaligned, /* (Output) -> symbol bead */ hash_index fixed bin; /* (Output) index in hash table of symbol bead, used by free_apl_bead_ to recompute hash index */ dcl temp_ptr ptr unaligned; dcl i fixed bin, apl_allocate_words_ entry(fixed bin(20), pointer unaligned), (length, fixed, unspec, string, substr, mod, null, size, divide) builtin; %include apl_number_data; %include apl_ws_info; %include apl_symbol_table; %include apl_bead_format; %include apl_symbol_bead; /*** 1 - compute hash code for symbol_name ***/ hash_index = 0; do i = 1 to length(symbol_name); hash_index = hash_index + fixed(unspec(substr(symbol_name, i, 1)), 9); /* initial kludgey hash function */ end; hash_index = mod(hash_index, symbol_table.table_size) + 1; /*** 2 - see if symbol is already in hash table ***/ do temp_ptr = hash_bucket_ptr(hash_index) repeat(temp_ptr -> symbol_bead.hash_link_pointer) while(temp_ptr ^= null); if temp_ptr -> symbol_bead.name = symbol_name then go to found_it; end; /*** 3 - not there - so make one and thread it in ***/ call apl_allocate_words_(size(symbol_bead) + divide(length(symbol_name)+3, 4, 17, 0), temp_ptr); string(temp_ptr -> general_bead.type) = symbol_type; temp_ptr -> general_bead.reference_count = 0; /* hash links don't count */ temp_ptr -> symbol_bead.meaning_pointer = null; /* initiall undefined */ temp_ptr -> symbol_bead.name_length = length(symbol_name); temp_ptr -> symbol_bead.name = symbol_name; temp_ptr -> symbol_bead.hash_link_pointer = hash_bucket_ptr(hash_index); /* thread it in */ hash_bucket_ptr(hash_index) = temp_ptr; ws_info.number_of_symbols = ws_info.number_of_symbols + 1; /* some of rsl's things use this */ found_it: temp_ptr -> symbol_bead.reference_count = temp_ptr -> symbol_bead.reference_count + 1; /* going to give away ptr to it */ return_pointer = temp_ptr; return; end apl_get_symbol_;  apl_grade_down_.pl1 11/29/83 1637.3r w 11/29/83 1346.4 143766 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* This module implements the APL grade-up and grade-down operators. Each column is sorted in the sense that indices that would sort that column were they used as subscripts are returned. The result is thus an array of integers which conforms with the operand. The Singleton sort algorithm is used. (CACM 12, #3, March 1969, p185-187) Created Oct 3, 1973 by G. Gordon Benedict Modified December 19, 1973 by PG to really use the Singleton sort. Modified December 30, 1973 by PG to be able to sort maximum-sized value. Modified 760922 by PG to split apl_grade_up_ from apl_grade_down_. Modified 780209 by PG to use apl_push_stack_ (bug 278) */ apl_grade_down_: procedure (operators_argument); /* implements grade down */ declare numeric_datum_or1 float dimension (data_elements) based;/* for efficiently getting "size" */ declare (apl_error_table_$rank, apl_error_table_$domain) static external fixed binary (35); /* naughty */ declare (operand_vb, /* pointer to value bead of operand (argument) */ operand_array, /* pointer to operand array */ result_vb, /* result value bead ptr */ result_array, /* pointer to result array */ data_pointer, /* return argument of push_value_stack */ index_base) pointer; /* pointer to base of indices for this column */ declare (rhorho, /* number of dimensions in operand and result */ data_elements, /* no of numbers in operand and result */ dimension, /* the dimension along which to perform the grade */ rho_sub_dimension, /* the length of that dimension */ interval_between_elements, /* no of elements inbetween each element of a column */ plane_base, /* subscript which indicates the base of a plane */ column_base, /* subscript which indicates the base of a column */ column_skip_interval, /* interval between base of columns */ rho_subscript, /* random subscript */ last_column_on_this_plane, /* offset to last column before plane_base must be changed */ first, /* used in actual sort. lowest element in a partition */ swap_temp, /* used for swapping index entries */ last, /* highest element in a partition */ median, /* index of middle datum */ low, /* moves up from first, looking for elements > median_value */ high, /* moves down from last, looking for elements < median_value */ median_index, /* temporary used to hold indices (median) in loops */ depth) /* depth in recursion (partition count) */ fixed binary; declare swap_em /* flag used to eliminate goto's in comparison code */ bit (1) aligned; declare bubble_is_ok initial (13) /* how short a vector must be to bubble sort it */ fixed binary internal static; declare total_words_needed /* words to allocate for allocate subroutine */ fixed bin (19); declare 1 stack (0 : 18) aligned, /* holds bounds of partitions as we "recurse" */ 2 first fixed binary, /* lower bound */ 2 last fixed binary; /* upper bound */ declare (float_index, /* used in converting from indices values to APL subscripts */ index_origin, /* a copy of ws_info.float_index_origin for efficiency */ median_value) float; /* a guess of mean value of array */ declare (addr, addrel, divide, fixed, float, hbound, rel, size, string, substr) builtin; declare indices (0 : rho_sub_dimension - 1) fixed binary based (index_base); /* these are permuted rather than actual argument array; they tell where that element would be */ declare rho_copy_overlay (rhorho) fixed binary (34) based; /* used for copying rho vectors quickly */ declare apl_get_next_value_stack_seg_ entry (fixed binary (18)); /* subroutine to allocate new value stack */ /* include files */ %include apl_number_data; %include apl_operators_argument; %include apl_bead_format; %include apl_value_bead; %include apl_ws_info; /* Look at arguments, check rank, get storage, etc. */ operand_vb = operators_argument.operands (2).value; if ^ operand_vb -> value_bead.header.type.data_type.numeric_value then goto domain_error; data_elements = operand_vb -> value_bead.total_data_elements; /* no. of entries in array */ operand_array = operand_vb -> value_bead.data_pointer; /* ptr to the array */ dimension = operators_argument.dimension; /* dimension along which to sort */ rhorho = operand_vb -> value_bead.rhorho; /* extract dimensionality */ if rhorho = 0 then goto rank_error; /* cannot be scalar */ if rhorho < dimension then goto rank_error; /* Calculate interval between elements and interval between column bases */ interval_between_elements = 1; do rho_subscript = dimension by 1 while (rho_subscript < rhorho); interval_between_elements = interval_between_elements * operand_vb -> value_bead.rho (rho_subscript + 1); end; rho_sub_dimension = operand_vb -> value_bead.rho (dimension); column_skip_interval = rho_sub_dimension * interval_between_elements; /* column base separation */ /* A temporary operand of indices are needed. If the operand is on the stack the final result can be stored there column by column as it is generated (since a column once referenced is never referenced again). Therefore only the table of indices will be allocated, which has one element for each element in a column to reduce. If operand is not on the stack, then a result bead, a result array, and a table of indices will be allocated */ index_origin = ws_info.float_index_origin; if operators_argument.operands (2).on_stack /* overlay operand with result */ then do; operators_argument.result, /* result will be returned in same place as operand */ result_vb = operand_vb; result_array = operand_array; /* store result over operand */ end; else do; /* not on stack. Must allocate new bead, new array, and indices */ number_of_dimensions = rhorho; total_words_needed = size (value_bead) + size (numeric_datum_or1) + 1; operators_argument.result, result_vb = apl_push_stack_ (total_words_needed); /* set result pointers to allocated area */ result_array = addr (result_vb -> value_bead.rho (rhorho + 1)); if substr (rel (result_array), 18, 1) /* if odd data boundary */ then result_array = addrel (result_array, 1); result_vb -> value_bead.rhorho = rhorho; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.data_pointer = result_array; if rhorho > 0 /* copy rho vector */ then addr (result_vb -> value_bead.rho) -> rho_copy_overlay = addr (operand_vb -> value_bead.rho) -> rho_copy_overlay; end; total_words_needed = rho_sub_dimension; /* allocate indices. Must do it separately so that we can sort maximum-sized value, which will need a whole value stack for operand, in that case this temporary will go in a new segment. */ index_base = apl_push_stack_ (total_words_needed); string (result_vb -> value_bead.header.type) = /* subscripts are always integers */ integral_value_type; /* If operand is scalar just return the index origin */ if data_elements = 1 /* effective scalar */ then do; result_array -> numeric_datum (0) = index_origin; return; end; /* Main loop. The two outer loops find the offset of the base of the column to sort */ do plane_base = 0 repeat (plane_base + column_skip_interval) while (plane_base < data_elements); last_column_on_this_plane = plane_base + interval_between_elements; /* offset to last column, plus 1 */ do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); /* Into the indices insert index values which point to the elements in the operand array that are in this column. */ indices (0) = column_base; /* point to first data element in column to sort */ do rho_subscript = 1 by 1 while (rho_subscript < rho_sub_dimension); indices (rho_subscript) = indices (rho_subscript - 1) + interval_between_elements; end; /* This loop actually sorts the column contained in the indices vector. Note that the data is never moved, only the subscripts. */ first = 0; /* lowest subscript into indices starts out at bottom */ last = rho_sub_dimension - 1; /* Believe me, this is last one */ depth = -1; /* no recursion yet */ repeat_sort: /* comes back here to process each partition */ if last - first <= bubble_is_ok then if first ^= 0 | last <= 0 /* true unless this is first partition, and it has */ then do; /* some elements. We can't bubble that one case */ call bubble_sort (); go to pop_stack; end; low = first; median = divide (first + last, 2, 18, 0); high = last; /* first step is to sort the first, median, and last values of the data such that first <= median <= last. This causes the upward and downward scans to be "data limited" so that they are guaranteed not to run off the end of the array. Grade up & grade down are not totally symmetrical, since equal elements always have their indices in ascending order. */ swap_em = "0"b; if operand_array -> numeric_datum (indices (first)) < operand_array -> numeric_datum (indices (median)) then swap_em = "1"b; else if operand_array -> numeric_datum (indices (first)) = operand_array -> numeric_datum (indices (median)) then if indices (first) > indices (median) then swap_em = "1"b; if swap_em then do; swap_temp = indices (median); indices (median) = indices (first); indices (first) = swap_temp; swap_em = "0"b; end; if operand_array -> numeric_datum (indices (last)) > operand_array -> numeric_datum (indices (median)) then swap_em = "1"b; else if operand_array -> numeric_datum (indices (last)) = operand_array -> numeric_datum (indices (median)) then if indices (last) < indices (median) then swap_em = "1"b; if swap_em then do; swap_temp = indices (median); indices (median) = indices (last); indices (last) = swap_temp; swap_em = "0"b; if operand_array -> numeric_datum (indices (first)) < operand_array -> numeric_datum (indices (median)) then swap_em = "1"b; else if operand_array -> numeric_datum (indices (first)) = operand_array -> numeric_datum (indices (median)) then if indices (first) > indices (median) then swap_em = "1"b; if swap_em then do; swap_temp = indices (median); indices (median) = indices (first); indices (first) = swap_temp; end; end; /* Now we can actually select the value which will be used to partition the data into two sublists. The "low" sublist will be all values, starting from the lower end of the array, which are less than the median value. The "high" sublist will be all values, starting from the upper end of the array, which are greater than the median value. */ median_index = indices (median); median_value = operand_array -> numeric_datum (median_index); grade_repeat: do high = high - 1 by -1 while (operand_array -> numeric_datum (indices (high)) < median_value); end; if operand_array -> numeric_datum (indices (high)) = median_value then if indices (high) > median_index then go to grade_repeat; grade_repeat_up: do low = low + 1 by 1 while (operand_array -> numeric_datum (indices (low)) > median_value); end; if operand_array -> numeric_datum (indices (low)) = median_value then if indices (low) < median_index then go to grade_repeat_up; if low <= high then do; swap_temp = indices (high); indices (high) = indices (low); indices (low) = swap_temp; go to grade_repeat; end; /* recursion occurs here in sense that the file is partitioned and the partition indices are stacked */ /* This algorithm can sort up to ^1+2*K+1 elements, according to Knuth and Singleton (In PL/I notation, (2**(k+1))-1), where K = dimension (stack, 1). Since the largest APL value must fit in one 256K segment (2*18 words), K = 17 is sufficient. */ /* The reason we can sort so many items, in place, with so little storage, is that Singleton's algorithm saves the larger of the two sublists, and then recurses on the smaller list. Should it do it in the other order, no stack less in size than the original list would be good enough (more or less). By saving the larger list, the worst case for recursion is when the smaller list is consistently just less than 1/2 of the combined sizes. The reader will quickly note that this implies that the size of the stack need only be logarithmically as large as the number of items to be sorted. */ depth = depth + 1; /* push a new frame */ if (high - first) > (last - low) then do; stack (depth).first = first; /* lower sublist is bigger */ stack (depth).last = high; first = low; /* so sort the upper one */ end; else do; stack (depth).first = low; /* upper sublist is bigger */ stack (depth).last = last; last = high; /* so sort the lower one */ end; go to repeat_sort; pop_stack: /* sort partition whose bounds are now stacked at end */ if depth >= 0 /* not done with this column, nor is stack all popped */ then do; first = stack (depth).first; /* extract bounds of this partition */ last = stack (depth).last; depth = depth - 1; /* reduce "stack pointer" to previous frame */ go to repeat_sort; /* sort previous partition */ end; /* Now have produced a permutation vector for an entire column. Convert this vector into a vector of subscripts and store it into the result array. This is done by having a subscript increment from the index origin, each time storing it into an element of the result vector specified by the corresponding element of the indices */ swap_temp = column_base; do rho_subscript = 0 by 1 while (rho_subscript < rho_sub_dimension); /* thru whole index vector */ result_array -> numeric_datum (swap_temp) = float (divide (indices (rho_subscript) - column_base, interval_between_elements, 17, 0)) + index_origin; swap_temp = swap_temp + interval_between_elements; /* next subscript */ end; end; end; ws_info.value_stack_ptr = index_base; /* pop index array */ return; /* Various types of errors */ rank_error: operators_argument.error_code = apl_error_table_$rank; operators_argument.where_error = operators_argument.where_error - 1; /* right operand */ return; domain_error: operators_argument.error_code = apl_error_table_$domain; operators_argument.where_error = operators_argument.where_error - 1; /* right operand */ return; /* Internal procedure to perform a data-limited bubble sort on the vector from "first" to "last". */ bubble_sort: procedure (); do first = first + 1 to last; median_index = indices (first); median_value = operand_array -> numeric_datum (median_index); low = first; bubble_repeat: do low = low - 1 by -1 while (operand_array -> numeric_datum (indices (low)) < median_value); indices (low + 1) = indices (low); end; if operand_array -> numeric_datum (indices (low)) = median_value then if indices (low) > median_index then do; indices (low + 1) = indices (low); go to bubble_repeat; end; indices (low + 1) = median_index; end; return; end bubble_sort; %include apl_push_stack_fcn; end /* apl_grade_down_ */;  apl_grade_up_.pl1 11/29/83 1637.3r w 11/29/83 1346.4 143712 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* This module implements the APL grade-up and grade-down operators. Each column is sorted in the sense that indices that would sort that column were they used as subscripts are returned. The result is thus an array of integers which conforms with the operand. The Singleton sort algorithm is used. (CACM 12, #3, March 1969, p185-187) Created Oct 3, 1973 by G. Gordon Benedict Modified December 19, 1973 by PG to really use the Singleton sort. Modified December 30, 1973 by PG to be able to sort maximum-sized value. Modified 760922 by PG to split apl_grade_up_ from apl_grade_down_. Modified 780209 by PG to use apl_push_stack_ (bug 278) */ apl_grade_up_: procedure (operators_argument); /* implements grade up */ declare numeric_datum_or1 float dimension (data_elements) based;/* for efficiently getting "size" */ declare (apl_error_table_$rank, apl_error_table_$domain) static external fixed binary (35); /* naughty */ declare (operand_vb, /* pointer to value bead of operand (argument) */ operand_array, /* pointer to operand array */ result_vb, /* result value bead ptr */ result_array, /* pointer to result array */ data_pointer, /* return argument of push_value_stack */ index_base) pointer; /* pointer to base of indices for this column */ declare (rhorho, /* number of dimensions in operand and result */ data_elements, /* no of numbers in operand and result */ dimension, /* the dimension along which to perform the grade */ rho_sub_dimension, /* the length of that dimension */ interval_between_elements, /* no of elements inbetween each element of a column */ plane_base, /* subscript which indicates the base of a plane */ column_base, /* subscript which indicates the base of a column */ column_skip_interval, /* interval between base of columns */ rho_subscript, /* random subscript */ last_column_on_this_plane, /* offset to last column before plane_base must be changed */ first, /* used in actual sort. lowest element in a partition */ swap_temp, /* used for swapping index entries */ last, /* highest element in a partition */ median, /* index of middle datum */ low, /* moves up from first, looking for elements > median_value */ high, /* moves down from last, looking for elements < median_value */ median_index, /* temporary used to hold indices (median) in loops */ depth) /* depth in recursion (partition count) */ fixed binary; declare swap_em /* flag used to eliminate goto's in comparison code */ bit (1) aligned; declare bubble_is_ok initial (13) /* how short a vector must be to bubble sort it */ fixed binary internal static; declare total_words_needed /* words to allocate for allocate subroutine */ fixed bin (19); declare 1 stack (0 : 18) aligned, /* holds bounds of partitions as we "recurse" */ 2 first fixed binary, /* lower bound */ 2 last fixed binary; /* upper bound */ declare (float_index, /* used in converting from indices values to APL subscripts */ index_origin, /* a copy of ws_info.float_index_origin for efficiency */ median_value) float; /* a guess of mean value of array */ declare (addr, addrel, divide, fixed, float, hbound, rel, size, string, substr) builtin; declare indices (0 : rho_sub_dimension - 1) fixed binary based (index_base); /* these are permuted rather than actual argument array; they tell where that element would be */ declare rho_copy_overlay (rhorho) fixed binary (34) based; /* used for copying rho vectors quickly */ declare apl_get_next_value_stack_seg_ entry (fixed binary (18)); /* subroutine to allocate new value stack */ /* include files */ %include apl_number_data; %include apl_operators_argument; %include apl_bead_format; %include apl_value_bead; %include apl_ws_info; /* Look at arguments, check rank, get storage, etc. */ operand_vb = operators_argument.operands (2).value; if ^ operand_vb -> value_bead.header.type.data_type.numeric_value then goto domain_error; data_elements = operand_vb -> value_bead.total_data_elements; /* no. of entries in array */ operand_array = operand_vb -> value_bead.data_pointer; /* ptr to the array */ dimension = operators_argument.dimension; /* dimension along which to sort */ rhorho = operand_vb -> value_bead.rhorho; /* extract dimensionality */ if rhorho = 0 then goto rank_error; /* cannot be scalar */ if rhorho < dimension then goto rank_error; /* Calculate interval between elements and interval between column bases */ interval_between_elements = 1; do rho_subscript = dimension by 1 while (rho_subscript < rhorho); interval_between_elements = interval_between_elements * operand_vb -> value_bead.rho (rho_subscript + 1); end; rho_sub_dimension = operand_vb -> value_bead.rho (dimension); column_skip_interval = rho_sub_dimension * interval_between_elements; /* column base separation */ /* A temporary operand of indices are needed. If the operand is on the stack the final result can be stored there column by column as it is generated (since a column once referenced is never referenced again). Therefore only the table of indices will be allocated, which has one element for each element in a column to reduce. If operand is not on the stack, then a result bead, a result array, and a table of indices will be allocated */ index_origin = ws_info.float_index_origin; if operators_argument.operands (2).on_stack /* overlay operand with result */ then do; operators_argument.result, /* result will be returned in same place as operand */ result_vb = operand_vb; result_array = operand_array; /* store result over operand */ end; else do; /* not on stack. Must allocate new bead, new array, and indices */ number_of_dimensions = rhorho; total_words_needed = size (value_bead) + size (numeric_datum_or1) + 1; operators_argument.result, result_vb = apl_push_stack_ (total_words_needed); /* set result pointers to allocated area */ result_array = addr (result_vb -> value_bead.rho (rhorho + 1)); if substr (rel (result_array), 18, 1) /* if odd data boundary */ then result_array = addrel (result_array, 1); result_vb -> value_bead.rhorho = rhorho; result_vb -> value_bead.total_data_elements = data_elements; result_vb -> value_bead.data_pointer = result_array; if rhorho > 0 /* copy rho vector */ then addr (result_vb -> value_bead.rho) -> rho_copy_overlay = addr (operand_vb -> value_bead.rho) -> rho_copy_overlay; end; total_words_needed = rho_sub_dimension; /* allocate indices. Must do it separately so that we can sort maximum-sized value, which will need a whole value stack for operand, in that case this temporary will go in a new segment. */ index_base = apl_push_stack_ (total_words_needed); string (result_vb -> value_bead.header.type) = /* subscripts are always integers */ integral_value_type; /* If operand is scalar just return the index origin */ if data_elements = 1 /* effective scalar */ then do; result_array -> numeric_datum (0) = index_origin; return; end; /* Main loop. The two outer loops find the offset of the base of the column to sort */ do plane_base = 0 repeat (plane_base + column_skip_interval) while (plane_base < data_elements); last_column_on_this_plane = plane_base + interval_between_elements; /* offset to last column, plus 1 */ do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); /* Into the indices insert index values which point to the elements in the operand array that are in this column. */ indices (0) = column_base; /* point to first data element in column to sort */ do rho_subscript = 1 by 1 while (rho_subscript < rho_sub_dimension); indices (rho_subscript) = indices (rho_subscript - 1) + interval_between_elements; end; /* This loop actually sorts the column contained in the indices vector. Note that the data is never moved, only the subscripts. */ first = 0; /* lowest subscript into indices starts out at bottom */ last = rho_sub_dimension - 1; /* Believe me, this is last one */ depth = -1; /* no recursion yet */ repeat_sort: /* comes back here to process each partition */ if last - first <= bubble_is_ok then if first ^= 0 | last <= 0 /* true unless this is first partition, and it has */ then do; /* some elements. We can't bubble that one case */ call bubble_sort (); go to pop_stack; end; low = first; median = divide (first + last, 2, 18, 0); high = last; /* first step is to sort the first, median, and last values of the data such that first <= median <= last. This causes the upward and downward scans to be "data limited" so that they are guaranteed not to run off the end of the array. Grade up & grade down are not totally symmetrical, since equal elements always have their indices in ascending order. */ swap_em = "0"b; if operand_array -> numeric_datum (indices (first)) > operand_array -> numeric_datum (indices (median)) then swap_em = "1"b; else if operand_array -> numeric_datum (indices (first)) = operand_array -> numeric_datum (indices (median)) then if indices (first) > indices (median) then swap_em = "1"b; if swap_em then do; swap_temp = indices (median); indices (median) = indices (first); indices (first) = swap_temp; swap_em = "0"b; end; if operand_array -> numeric_datum (indices (last)) < operand_array -> numeric_datum (indices (median)) then swap_em = "1"b; else if operand_array -> numeric_datum (indices (last)) = operand_array -> numeric_datum (indices (median)) then if indices (last) < indices (median) then swap_em = "1"b; if swap_em then do; swap_temp = indices (median); indices (median) = indices (last); indices (last) = swap_temp; swap_em = "0"b; if operand_array -> numeric_datum (indices (first)) > operand_array -> numeric_datum (indices (median)) then swap_em = "1"b; else if operand_array -> numeric_datum (indices (first)) = operand_array -> numeric_datum (indices (median)) then if indices (first) > indices (median) then swap_em = "1"b; if swap_em then do; swap_temp = indices (median); indices (median) = indices (first); indices (first) = swap_temp; end; end; /* Now we can actually select the value which will be used to partition the data into two sublists. The "low" sublist will be all values, starting from the lower end of the array, which are less than the median value. The "high" sublist will be all values, starting from the upper end of the array, which are greater than the median value. */ median_index = indices (median); median_value = operand_array -> numeric_datum (median_index); grade_repeat: do high = high - 1 by -1 while (operand_array -> numeric_datum (indices (high)) > median_value); end; if operand_array -> numeric_datum (indices (high)) = median_value then if indices (high) > median_index then go to grade_repeat; grade_repeat_up: do low = low + 1 by 1 while (operand_array -> numeric_datum (indices (low)) < median_value); end; if operand_array -> numeric_datum (indices (low)) = median_value then if indices (low) < median_index then go to grade_repeat_up; if low <= high then do; swap_temp = indices (high); indices (high) = indices (low); indices (low) = swap_temp; go to grade_repeat; end; /* recursion occurs here in sense that the file is partitioned and the partition indices are stacked */ /* This algorithm can sort up to ^1+2*K+1 elements, according to Knuth and Singleton (In PL/I notation, (2**(k+1))-1), where K = dimension (stack, 1). Since the largest APL value must fit in one 256K segment (2*18 words), K = 17 is sufficient. */ /* The reason we can sort so many items, in place, with so little storage, is that Singleton's algorithm saves the larger of the two sublists, and then recurses on the smaller list. Should it do it in the other order, no stack less in size than the original list would be good enough (more or less). By saving the larger list, the worst case for recursion is when the smaller list is consistently just less than 1/2 of the combined sizes. The reader will quickly note that this implies that the size of the stack need only be logarithmically as large as the number of items to be sorted. */ depth = depth + 1; /* push a new frame */ if (high - first) > (last - low) then do; stack (depth).first = first; /* lower sublist is bigger */ stack (depth).last = high; first = low; /* so sort the upper one */ end; else do; stack (depth).first = low; /* upper sublist is bigger */ stack (depth).last = last; last = high; /* so sort the lower one */ end; go to repeat_sort; pop_stack: /* sort partition whose bounds are now stacked at end */ if depth >= 0 /* not done with this column, nor is stack all popped */ then do; first = stack (depth).first; /* extract bounds of this partition */ last = stack (depth).last; depth = depth - 1; /* reduce "stack pointer" to previous frame */ go to repeat_sort; /* sort previous partition */ end; /* Now have produced a permutation vector for an entire column. Convert this vector into a vector of subscripts and store it into the result array. This is done by having a subscript increment from the index origin, each time storing it into an element of the result vector specified by the corresponding element of the indices */ swap_temp = column_base; do rho_subscript = 0 by 1 while (rho_subscript < rho_sub_dimension); /* thru whole index vector */ result_array -> numeric_datum (swap_temp) = float (divide (indices (rho_subscript) - column_base, interval_between_elements, 17, 0)) + index_origin; swap_temp = swap_temp + interval_between_elements; /* next subscript */ end; end; end; ws_info.value_stack_ptr = index_base; /* pop index array */ return; /* Various types of errors */ rank_error: operators_argument.error_code = apl_error_table_$rank; operators_argument.where_error = operators_argument.where_error - 1; /* right operand */ return; domain_error: operators_argument.error_code = apl_error_table_$domain; operators_argument.where_error = operators_argument.where_error - 1; /* right operand */ return; /* Internal procedure to perform a data-limited bubble sort on the vector from "first" to "last". */ bubble_sort: procedure (); do first = first + 1 to last; median_index = indices (first); median_value = operand_array -> numeric_datum (median_index); low = first; bubble_repeat: do low = low - 1 by -1 while (operand_array -> numeric_datum (indices (low)) > median_value); indices (low + 1) = indices (low); end; if operand_array -> numeric_datum (indices (low)) = median_value then if indices (low) > median_index then do; indices (low + 1) = indices (low); go to bubble_repeat; end; indices (low + 1) = median_index; end; return; end bubble_sort; %include apl_push_stack_fcn; end /* apl_grade_up_ */;  apl_group_command_.pl1 11/29/83 1637.3r w 11/29/83 1346.4 58536 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_group_command_: procedure (nargs, arglist); /* * apl command to create, append, or disband a group * * written 73.9.06 by DAM Modified 800819 by WMY to fix bug 468 ()GROUP X F F gives a system error (attempt to free bead with non-zero ref count)) */ dcl nargs fixed bin parameter, arglist dim (*) char (*) parameter; call apl_create_save_frame_; /* use global meanings */ call apl_get_symbol_ (before (arglist (1), " "), group_symbol, (0)); if nargs = 1 then do; /* disband group */ if group_symbol -> symbol_bead.meaning_pointer = null then go to cant_disband; else if group_symbol -> symbol_bead.meaning_pointer -> general_bead.type.group then ; else go to cant_disband; call wash (group_symbol -> symbol_bead.meaning_pointer); group_symbol -> symbol_bead.meaning_pointer = null; end; else do; /* create or append to existing group */ /* Check to see if group of this name already exists */ if group_symbol -> symbol_bead.meaning_pointer ^= null then if group_symbol -> symbol_bead.meaning_pointer -> general_bead.type.group then do argno = 2 by 1 while (argno <= nargs); /* group already exists, check to see if we are appending or replacing the group */ call apl_get_symbol_ (before (arglist (argno), " "), symb, (0)); if symb = group_symbol then go to append_to_group; else call wash (symb); end; /* create group bead */ if group_symbol -> symbol_bead.meaning_pointer ^= null then if group_symbol -> symbol_bead.meaning_pointer -> general_bead.type.group then call wash (group_symbol -> symbol_bead.meaning_pointer); else go to name_dup; /* have already flushed old value, if any */ call apl_allocate_words_ (size (group_bead) + nargs - 1, gbp); string (gbp -> general_bead.type) = group_type; gbp -> group_bead.number_of_members = nargs - 1; /* Add new symbols to group bead. */ do argno = 2 by 1 while (argno <= nargs); call apl_get_symbol_ (before (arglist (argno), " "), symb, (0)); /* Check for duplicate entries in symbol list */ do dupx = 1 to argno - 2; if gbp -> group_bead.member (dupx) = symb then go to mem_dup_create; end; /* Add this symbol to group bead */ gbp -> group_bead.member (argno - 1) = symb; end; /* Attach group bead to symbol */ group_symbol -> symbol_bead.meaning_pointer = gbp; end; /* create or append to group */ finish: call wash (group_symbol); call apl_destroy_save_frame_update_; return; append_to_group: group_symbol -> symbol_bead.reference_count = group_symbol -> symbol_bead.reference_count - 1; /* adjust for goto out of do loop */ /* name of group is in members list, append */ n_mem = group_symbol -> symbol_bead.meaning_pointer -> group_bead.number_of_members + nargs - 2; call apl_allocate_words_ (size (group_bead) + n_mem, gbp); /* make new, larger group bead */ string (gbp -> general_bead.type) = group_type; gbp -> group_bead.number_of_members = n_mem; /* copy old members */ do memx = 1 by 1 while (memx <= group_symbol -> symbol_bead.meaning_pointer -> group_bead.number_of_members); gbp -> group_bead.member (memx) = group_symbol -> symbol_bead.meaning_pointer -> group_bead.member (memx); end; /* add new members */ do argx = 2 by 1 while (argx <= nargs); if argx ^= argno then do; /* append member (skipping over the group's own name) */ call apl_get_symbol_ (before (arglist (argx), " "), symb, (0)); do dupx = 1 by 1 while (dupx < memx); /* look for duplications */ if gbp -> group_bead.member (dupx) = symb then go to mem_dup_append; end; gbp -> group_bead.member (memx) = symb; memx = memx + 1; end; end; /* flush old bead - do not decrement reference counts of old members since copied over */ call apl_free_words_ (fixed (group_symbol -> symbol_bead.meaning_pointer -> general_bead.size, 18), group_symbol -> symbol_bead.meaning_pointer); group_symbol -> symbol_bead.meaning_pointer = gbp; go to finish; wash: proc (bp); dcl bp unaligned pointer; dcl p unaligned pointer; p = bp; if p = null then return; p -> general_bead.reference_count = p -> general_bead.reference_count - 1; if p -> general_bead.reference_count <= 0 then call apl_free_bead_ (p); end; /* error exits */ mem_dup_create: gbp -> group_bead.number_of_members = argno - 2; go to mem_dup; mem_dup_append: gbp -> group_bead.number_of_members = memx - 1; mem_dup: call ioa_$ioa_stream (apl_output_stream, "^Rincorrect command - group member ^a appears twice^B", symb -> symbol_bead.name); call wash (gbp); /* flush space for group bead, fix up reference counts on members */ go to finish; cant_disband: call ioa_$ioa_stream (apl_output_stream, "^Rcan't disband - ^a is not a group^B", group_symbol -> symbol_bead.name); go to finish; name_dup: call ioa_$ioa_stream (apl_output_stream, "^Rnot grouped, name in use^B"); go to finish; dcl group_symbol unaligned pointer, argno fixed bin, symb unaligned pointer, gbp unaligned pointer, ioa_$ioa_stream entry options (variable), n_mem fixed bin, memx fixed bin, dupx fixed bin, argx fixed bin; declare apl_output_stream char (11) static initial ("apl_output_"); dcl (null, string, addr, fixed, size, before) builtin; dcl apl_create_save_frame_ entry, apl_destroy_save_frame_update_ entry, apl_get_symbol_ entry (char (*), unaligned pointer, fixed bin), apl_allocate_words_ entry (fixed bin (18), unaligned pointer), apl_free_words_ entry (fixed bin (18), unaligned pointer), apl_free_bead_ entry (unaligned pointer); /* include files */ %include apl_bead_format; %include apl_group_bead; %include apl_symbol_bead; end;  apl_grp_command_.pl1 11/29/83 1637.3r w 11/29/83 1346.4 17541 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ apl_grp_command_: procedure (group_name); /* * command to list the members of a group * written 73.9.06 by DAM */ dcl group_name char(*) parameter; call apl_create_save_frame_; /* use global meanings */ call apl_get_symbol_(before(group_name, " "), sbp, (0)); if sbp -> symbol_bead.meaning_pointer = null then go to no_good; if ^ sbp -> symbol_bead.meaning_pointer -> general_bead.type.group then go to no_good; do n = 1 by 1 while(n <= sbp -> symbol_bead.meaning_pointer -> group_bead.number_of_members); call apl_print_string_(sbp -> symbol_bead.meaning_pointer -> group_bead.member(n) -> symbol_bead.name); end; call apl_print_newline_; call apl_flush_buffer_; wash_ret: sbp -> symbol_bead.reference_count = sbp -> symbol_bead.reference_count - 1; if sbp -> symbol_bead.reference_count <= 0 then call apl_free_bead_(sbp); call apl_destroy_save_frame_; return; no_good: call ioa_$ioa_stream ("apl_output_", "^Rincorrect command^B"); go to wash_ret; dcl sbp unaligned pointer, n fixed bin; dcl apl_get_symbol_ entry(char(*), unaligned pointer, fixed bin), apl_print_string_ entry (char (*)), apl_print_newline_ entry, apl_flush_buffer_ entry, apl_create_save_frame_ entry, apl_destroy_save_frame_ entry, apl_free_bead_ entry (unaligned pointer); dcl ioa_$ioa_stream entry options(variable); dcl (null, before) builtin; %include apl_bead_format; %include apl_symbol_bead; %include apl_group_bead; end;  apl_iota_appendage_.alm 11/29/83 1637.3r w 11/29/83 1346.5 27432 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " Subroutine called by apl to do a fast iota. " "Calling sequence: " " call apl_iota_appendage_ (index_origin, increment, no_of_elements, ptr_to_result_array); " " declare apl_iota_appendage_ entry (float, float, fixed bin, ptr); " " Modified 2 January 1974 by PG to construct backwards iota for big dealer. " Modified 740829 by PG to treat index register 3 as an unsigned word offset, thus fixing a bug " in which i65536 gave an overflow fault, and i70000 did only last 4 elements! " "Calling sequence for backwards iota: " " call apl_iota_appendage_ (index_origin, - step, - no_of_elements, ptr_to_result_array) " name apl_iota_appendage_ segdef apl_iota_appendage_ equ index_origin,2 equ step,4 equ no_of_elements,6 equ result_ptr,8 apl_iota_appendage_: eppbp ap|result_ptr,* get ptr to result array eppbp bp|0,* ldq ap|no_of_elements,* number of elements to process tze return_iota no elements to process, return null vector tpl normal_iota ascending iota. lls 36 prepare for negate. neg 0 make number_of_elements positive als 1 convert to word count eax2 0,al put offset to last word in x2. dfld ap|index_origin,* index_origin will be assigned to last element. eppbb ap|step,* get pointer to step (presumed to be negative). tra join_iota and begin. normal_iota: qls 1 convert to word count eax2 0,ql put offset to last word in x2 qrl 1 convert back to element number lda 0,dl prepart for conversion to float lde =71b25,du load e with right magic number fad =0.0,du convert to float eppbb ap|step,* get ptr to step between elements fsb =1.0,du must subtract 1 because want number assigned to last element dfmp bb|0 multiply by step dfad ap|index_origin,* add index origin join_iota: eax3 0,x2 get number of groups of 4 in result anx3 =o777770,du get rid of those over mod 4 boundary tze do_few less than 4 elements to process anx2 7,du epplb bp|0,x2 many_iota_loop: dfst lb|-2,x3 store into an element dfsb bb|0 reduce by step quantity dfst lb|-4,x3 store into an element dfsb bb|0 reduce by step quantity dfst lb|-6,x3 store into an element dfsb bb|0 reduce by step quantity dfst lb|-8,x3 store into an element dfsb bb|0 reduce by step quantity sblx3 8,du reduce by the 4 elements processed this iteration (unsigned offset!) tnz many_iota_loop go do 4 more (again, unsigned! (tpnz was wrong!)) do_few: "less than 4 left to do cmpx2 0,du and out the mod 4 ones tze return_iota none left to do few_iota_loop: dfst bp|-2,x2 dfsb bb|0 sbx2 2,du tpnz few_iota_loop return_iota: short_return end  apl_lex_.pl1 11/29/83 1637.3r w 11/29/83 1346.6 699579 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3 */ apl_lex_: procedure; /* * apl_lex_ * * This module converts a character string into a lexed_function bead. * It is called after a function is edited, by the QuadFX function, by the execute operator, * and when a function is called that had not yet been lexed after a )LOAD. * * apl_lex_ is the first pass of the APL parser. It does a left to right scan * and produces a lexed_function bead which includes an array of packed pointers * called lexemes. Each lexeme points to a value bead, a symbol bead, or an operator bead. * The second pass of the parser is a right to left scan of the lexemes done at run time * * Entries: * apl_line_lex_ processes a line of evaluated input * apl_function_lex_ processes the definition of a function, including the header line * apl_scan_ gets next token in a character string - for editor and apl_command_ * apl_execute_lex_ same as apl_line_lex_ except errors work differently. Used by the execute operator * canonicalize_apl_line_ canonicalizes spacing and number format in apl lines - used by editor, etc. */ /* * written 6/20/73 by D A Moon * debugged by DAM at various times during 7/73 * apl_scan_ added 7/25/73 by DAM * facilities for the execute operator added 8/7/73 by DAM * modified 8/20/73 by DAM for bug fixing and localization of system variables * Modified 740131 by PG for better error message for misused -> * Modified 740320 by PG to use PL/I EIS conversion routines * Modified July 1974 to fix illegal machine op on outer product with left bracket by G. Gordon Benedict * Modified 741009 by PG to make unbalanced quotes error msg work. * Modified 770106 by PG to add apl_editor_scan_ and fix unbalanced parens to work (bug 193). Modified 780310 by PG to fix bug 314 (not checking for duplicate labels). Modified 780403 by PG to fix bug 318 (fix to 314 broke code to re-lex functions for error position). Modified 780504 by PG to add diamond processing Modified 780613 by PG to fix bug 323 (lex looped if given stmts (between diamonds) of zero length.) Modified 780909 by PG to fix bug 326 (F-<.IQ 1 caused lex to loop & fault), and to diagnose identifiers beginning with an underscore. Modified 780920 by PG to permit -> after semicolons, and to diagnose mixed diamonds and semicolons. Modified 781107 by PG to add argument list processing. Modified 790327 by WMY to fix bug 388, result of lexing a function with no body. A null lexed_function_bead_ptr was returned, now a lexed_funciton_bead with no statements is returned. Modified 800129 by PG to implement localized system variables. Modified 811211 by H. Hoover (UofC) to add qCALL system function. */ /* declarations */ dcl line_type bit (2) aligned, Diamond_type bit (2) aligned int static init ("01"b), Semicolon_type bit (2) aligned int static init ("10"b); dcl stmt_length_map (100) fixed bin; dcl stmt_number fixed bin; dcl (first_lexeme, line_len, lx, output_index) fixed bin; dcl done bit (1) aligned; dcl parse_frame_ptr ptr; dcl esw fixed bin, /* entry switch */ apl_line_lex_ fixed bin static init (1), /* values for esw */ apl_function_lex_ fixed bin static init (2), /* .. */ apl_scan_ fixed bin static init (0), /* .. */ apl_execute_lex_ fixed bin static init (3), /* .. */ /* canonicalize_apl_line_ fixed bin static init(4), unused for now */ next_lexeme fixed bin, /* type of the next lexeme to be emitted */ lexeme ptr unaligned, /* next lexeme to be emitted */ last_lexeme fixed bin, /* type of the last lexeme that was emitted */ /* type codes which may be the value of next_lexeme, last_lexeme */ BeginOfLine fixed bin static init (1), /* no last lexeme, new line has been started */ OperatorLexeme fixed bin static init (2), ValueLexeme fixed bin static init (4), /* a parenthesized expression */ OpenParenLexeme fixed bin static init (5), /* left paren or left bracket */ ConstantLexeme fixed bin static init (6), /* a numeric or character constant. Has not yet been emitted, but is sitting in stack_value_ptr -> value_bead */ NameLexeme fixed bin static init (7), /* a symbol (name, identifier) */ /* may also be SemiColon */ error_suppress bit (1), /* "1"b to suppress error messages - used by apl_execute_lex_ */ char_index fixed bin (20), /* 0-origin index in the variable text, which is input string */ line_no fixed bin, /* current statement number */ line_index fixed bin (20), /* value of char_index at start of this line */ space_left_in_stack fixed bin, /* number of words left in value stack, if counts down to 0 may have to switch segments */ value_stack_popper ptr, /* saved value of ws_info.value_stack_ptr upon entry */ value_stack_space ptr, /* -> stuff we have pushed onto value stack. may be different from value_stack_popper if we have switched stack segs */ lexeme_index fixed bin, /* index in temp_lexeme_array of next lexeme to be emitted */ 1 lexeme_array_alignment_structure aligned based (value_stack_space), 2 emission_array (lexeme_index), /* array of emissions */ 3 temp_lexeme_array pointer unaligned, /* lexeme */ 3 source_pos fixed bin, /* value of char_index afterfirst char of token was read */ temp_lexeme_size fixed bin static init (2), /* size(emission_array(1)) is not allowed and does not work */ char_count fixed bin; /* when this counts up to 0, the end of the string 'text' has been reached */ /* parenthesis stuff */ dcl paren_level fixed bin, /* index into paren_stack, 0 if top level */ 1 paren_stack_structure (1000 /* or so */) aligned based (paren_stack_ptr), 2 paren_stack fixed bin, /* type of paen - codes dcl'ed below */ 2 paren_loc fixed bin (21), /* value of char_index at left paren */ paren_stack_ptr pointer, /* at begin of line, set above statement_map */ P_S_Parens fixed bin static init (1), /* paren_stack: () */ P_S_Brackets fixed bin static init (2), /* paren_stack: [] */ P_S_Opr_Brackets fixed bin static init (3), /* paren_stack: [] after operator */ P_S_qCALL_Parens fixed bin static init (4); /* paren_stack: () after qCALL system function */ dcl code fixed bin (35), /* status code used to generate error messages */ n fixed bin, /* temp */ begin_subscript_calc fixed bin, /* index in temp_lexeme_array of thing getting subscripted-assigned */ chr fixed bin (9), /* APL character code for current character */ temp_ptr ptr unaligned, template_ptr ptr unaligned, /* for making lexed function bead */ hack_ptr pointer aligned, /* see assign: */ NL character static init (" "), ( function_being_lexed, /* -> symbol bead for function name from header line, or null */ left_arg_symbol, /* -> symbol bead for what it says */ right_arg_symbol, /* .. */ return_value_symbol ) /* .. */ pointer unaligned initial (null), name_index fixed bin, /* 0-origin index in the following */ 1 name_buffer_array_alignment_structure based (name_buffer_ptr) aligned, /* buffer for building up names of symbols */ 2 name_buffer_array (0:(1000) /* or so */) fixed bin (8) unaligned, /* overlay on character string */ 1 name_buffer_alignme_structure aligned based (name_buffer_ptr), 2 name_buffer char (name_index) unaligned, name_buffer_ptr pointer; /* resides in parse stack above paren_stack */ /* stuff for number conversion */ dcl apl_number_for_size float; /* used only with the size builtin */ dcl apl_number float bin (63), number_buffer float decimal (34), 1 overlay_on_number_buffer based (addr (number_buffer)) aligned, 2 sign char (1) unaligned, /* ascii code "+" or "-" */ 2 digit (0:33) fixed bin (8) unaligned, /* ascii code from chr for "0" - "9" */ 2 must_be_zero bit (1) unaligned, 2 exponent fixed bin (7) unaligned, (expona, exponb) fixed bin, magic_rounding_constant float decimal (32) static initial (1.0000000000000000000542101080243e0), decimal_zero float dec (34) aligned static init (0e0), /* has to be named constant due to PL/I compiler bug */ negative_exponent bit (1), stack_value_ptr ptr; /* -> value bead sitting in stack above lexeme_array */ /* statement & label map */ dcl 1 statement_map (1:1000 /* or so */) aligned based (statement_map_ptr), /* in parse stack */ 2 lexeme_index fixed bin, /* index in lexeme_array of last lexeme for line */ 2 label pointer unaligned, /* null or -> symbol bead for label on this line (only 1 label per line!) */ statement_map_ptr pointer; /* localized symbols table */ dcl 1 MY aligned based (parse_stack_space), 2 localized_symbols (number_of_localized_symbols) pointer unaligned; dcl (number_of_localized_symbols, number_of_labels) fixed bin; /* form of data in parse stack is: localized_symbols array statement_map paren_stack */ /* builtins */ dcl (abs, addr, addrel, binary, bit, decimal, fixed, hbound, index, lbound, length, mod, null, rel, size, string, substr, unspec) builtin; /* more misc dcl */ dcl fatal bit (1), ll fixed bin, i fixed bin, apl_error_ entry (fixed bin (35), bit (36) aligned, fixed bin, char (*), pointer unaligned, fixed bin), apl_get_symbol_ entry (char (*), pointer unaligned, fixed bin), apl_allocate_words_ entry (fixed bin (18), pointer unaligned), apl_free_bead_ entry (pointer unaligned), /* only call this if reference count has decremented to zero */ apl_copy_value_ entry (pointer unaligned, pointer unaligned); /* external static */ dcl ( apl_error_table_$mixed_diamonds_and_semicolons, apl_error_table_$underscore_cant_begin_id, apl_error_table_$too_short_execute, apl_error_table_$too_many_statements, apl_error_table_$duplicate_label, apl_error_table_$more_than_one_line_execute, apl_error_table_$u_mism_ur_quotes, apl_error_table_$bad_subsc_assign_sys_var, apl_error_table_$extra_decimal_point, apl_error_table_$cant_be_localized, apl_error_table_$random_char, apl_error_table_$ill_scan, apl_error_table_$ill_reduction, apl_error_table_$lex_screwed_up, apl_error_table_$not_end_with_newline, apl_error_table_$ill_outer_prod, apl_error_table_$ill_inner_prod, apl_error_table_$misplaced_diamond, apl_error_table_$misplaced_semicolon, apl_error_table_$excess_right_parens, apl_error_table_$mismatched_parens, apl_error_table_$ill_opr_brackets, apl_error_table_$misplaced_brackets, apl_error_table_$excess_right_brackets, apl_error_table_$not_end_with_value, apl_error_table_$ill_small_circle, apl_error_table_$unknown_system_name, apl_error_table_$ws_full_in_lex, apl_error_table_$constant_mism, apl_error_table_$mism_quotes, apl_error_table_$ill_paren_level, apl_error_table_$not_allowed_inner_prod, apl_error_table_$not_allowed_outer_prod, apl_error_table_$more_than_one_line, apl_error_table_$badass, apl_error_table_$lone_upper_minus, apl_error_table_$lone_period, apl_error_table_$excess_label, apl_error_table_$random_char_in_hdr, apl_error_table_$need_name, apl_error_table_$only_1_return_value, apl_error_table_$need_semicolon, apl_error_table_$misplaced_right_arrow ) fixed bin (35) external; /* include files */ %include apl_number_data; %include apl_bead_format; %include apl_value_bead; %include apl_operator_bead; %include apl_character_codes; %include apl_lex_pseudo_chars; %include apl_ws_info; %include apl_operator_table_; %include apl_lex_tables_; %include apl_lexed_function_bead; %include apl_parse_frame; /**** entry point to lex a line of evaluated input ****/ apl_line_lex_: entry (text, lex_return_pointer, errors_occurred, a_bad_lexeme_index, parse_stack_space); dcl text char (*) aligned parameter, /* string to be lexically analyzed */ lex_return_pointer pointer unaligned, /* this return argument usually -> lexed_function bead, but in the case of lexing for errors, -> error_mark_structure */ errors_occurred bit (1) aligned parameter, /* return argument - "1"b if lex has printed 1 or more error msgs */ a_bad_lexeme_index fixed bin parameter, /* 0 for normal lexing, > 0 implies this is index of lexeme at which error ocurred, so source is to be marked (lexing for errors) */ 1 error_mark_structure aligned based (parse_stack_space), 2 error_line_number fixed bin, 2 error_line_index fixed bin (21), /* pl1 (1-origin) index of start of line in error */ 2 error_index_within_line fixed bin, /* pl1 (1-origin) index of character within line to be marked */ 2 length_of_line fixed bin, /* number of characters in erroneous line, including newline at end */ parse_stack_space pointer aligned parameter; /* -> space I can use on parse stack */ /* apl_line_lex_ begin executable code */ error_suppress = "0"b; esw = apl_line_lex_; go to line_execute_lex_join; apl_execute_lex_: entry (text, lex_return_pointer, errors_occurred, a_bad_lexeme_index, parse_stack_space); esw = apl_execute_lex_; error_suppress = ^ws_info.long_error_mode; /* suppress syntax errors unless long mode */ line_execute_lex_join: errors_occurred = "0"b; last_lexeme = BeginOfLine; /* don't get the idea that this statement is superfluous */ char_index = 0; lexeme_index = 1; line_no = 0; call setup_value_stack; number_of_localized_symbols = 0; number_of_labels = 0; statement_map_ptr = parse_stack_space; /* no local symbols table */ char_count = -length (text) - 1; go to start_line; process_newline: snail (10): if paren_level ^= 0 then go to barf_at_ill_paren_level; /* make some error checks */ if last_lexeme = OperatorLexeme then do; /***** write around pl1 compiler bug in packed to unpacked pointer comparison ****/ temp_ptr = addr (operator_bead_table (op_index (RightArrow))); if lexeme = temp_ptr then ; /* special case, allow RightArrow alone on a line */ else go to barf_at_not_end_with_value; end; else if last_lexeme = ConstantLexeme then call convert_constant; statement_map (line_no).lexeme_index = lexeme_index - 1; /* If we are lexing for errors, see if we have found the erroneous line. */ if a_bad_lexeme_index ^= 0 then if a_bad_lexeme_index < lexeme_index then do; error_mark_structure.error_line_number = line_no; error_mark_structure.error_line_index = line_index + 1; /* Correct the lexeme index to account for any diamond reordering present */ lx = a_bad_lexeme_index; if line_no > 1 then first_lexeme = statement_map (line_no - 1).lexeme_index; else first_lexeme = 0; lx = lx - first_lexeme; do stmt_number = stmt_number by -1 to 1 while (lx > stmt_length_map (stmt_number)); lx = lx - stmt_length_map (stmt_number); end; stmt_number = stmt_number - 1; /* we have found the right statement...skip it */ do stmt_number = stmt_number by -1 to 1; lx = lx + stmt_length_map (stmt_number); end; error_mark_structure.error_index_within_line = source_pos (lx + first_lexeme) - line_index; error_mark_structure.length_of_line = char_index - line_index; lex_return_pointer = addr (error_mark_structure); return; end; start_line: line_type = "00"b; stmt_number = 1; stmt_length_map (1) = 0; line_no = line_no + 1; paren_level = 0; line_index = char_index; /* save start of line */ lexeme = addr (operator_bead_table (op_index (NewLine))); /* put out a beginning of line lexeme */ next_lexeme = BeginOfLine; statement_map (line_no).label = null; /* assume line will be unlabeled */ paren_stack_ptr = addr (statement_map (line_no + 1)); /* put paren stack above statement map */ go to hrund_emit; start_new_lexeme: snail (11): char_count = char_count + 1; if char_count = 0 then if esw = apl_execute_lex_ then go to process_newline; /* forge a newline at end of execute string */ else go to end_of_text; /* but for any other entry, this is the end */ else if char_count > 0 then go to end_of_text; /* newline has already been forged, so now text ends */ chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to snail (char_type (chr)); /* snail(0) = barf_at_random_char snail(1) = start_name snail(2) = " snail(3) = " snail(5) = start_number snail(6) = start_negative_number snail(9) = skip_over_comment snail(10) = process_newline snail(11) = start_new_lexeme skip over blanks snail(12) = process_char_constant snail(13) = barf_at_random_char snail(14) = hrund_emit_operator snail(22) = assign the remaining snails follow */ snail (4): /* QuadQuote */ next_lexeme = NameLexeme; /* sort of a name */ go to get_hrund_emit; snail (8): /* scan & reduction - or maybe expand & compress */ if last_lexeme ^= OperatorLexeme then go to hrund_emit_operator; if ^(lexeme -> operator_bead.allow_reduction) then go to barf_at_ill_reduction; if chr = Slash then lexeme = addr (lexeme -> scalar_op.slash_operator_bead); else if chr = BackSlash then lexeme = addr (lexeme -> scalar_op.backslash_operator_bead); else if chr = SlashHyphen then lexeme = addr (lexeme -> scalar_op.slash_hyphen_operator_bead); else if chr = BackSlashHyphen then lexeme = addr (lexeme -> scalar_op.backslash_hyphen_operator_bead); else go to ulose; /* tables screwed up */ go to hrund_replace; snail (15): /* generate a branch from RightArrow */ if (last_lexeme ^= BeginOfLine) & (last_lexeme ^= Diamond) & (last_lexeme ^= SemiColon) then go to misplaced_right_arrow; else go to hrund_emit_operator; snail (16): /* process SmallCircle, which may only be used to introduce an outer product */ skip_blanks_for_SmallCircle: char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if char_type (chr) = 11 then go to skip_blanks_for_SmallCircle; /* allow blanks */ if char_type (chr) ^= 7 then go to barf_at_ill_small_circle; /* must be period */ /* do outer product - chr = "." */ doprod (11): /* outer product */ char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to doprod (char_type (chr)); doprod (14): /* got operator to take outer product of */ lexeme = addr (operator_bead_table (op_index (chr))); if ^(lexeme -> operator_bead.allow_product) then go to barf_at_not_allowed_outer_prod; lexeme = addr (lexeme -> scalar_op.outer_product_operator_bead); next_lexeme = OperatorLexeme; go to hrund_emit; doprod (0): doprod (1): doprod (2): doprod (3): doprod (4): doprod (5): doprod (6): doprod (7): doprod (8): doprod (9): doprod (10): doprod (12): doprod (13): doprod (15): doprod (16): doprod (17): doprod (18): doprod (19): doprod (20): doprod (21): doprod (22): doprod (23): code = apl_error_table_$ill_outer_prod; go to error; snail (7): /* process dot (except outer-product dot) */ /* operator followed by dot -- might be inner product, but could be start of a number. Have to look ahead a little */ if char_count < -1 then if char_type (fixed (unspec (substr (text, char_index + 1, 1)), 9)) = 5 then go to start_number_with_decimal_point; else if last_lexeme ^= OperatorLexeme then go to barf_at_lone_period; else if last_lexeme ^= OperatorLexeme then go to barf_at_lone_period; if ^(lexeme -> operator_bead.allow_product) then do; /* left opeator does not permit inner product. */ /* back up and mark it. */ do while (char_index > line_index); /* don't overdo things... */ char_count = char_count - 1; char_index = char_index - 1; chr = binary (unspec (substr (text, char_index, 1)), 9); if char_type (chr) ^= 11 /* blanks */ then go to barf_at_not_allowed_inner_prod; end; go to barf_at_not_allowed_inner_prod; /* should not get here */ end; skip_blanks_for_inner_prod: char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if char_type (chr) = 11 then go to skip_blanks_for_inner_prod; if char_type (chr) ^= 14 then go to barf_at_ill_inner_prod; /* definitely an inner product, chr = right operator */ temp_ptr = addr (operator_bead_table (op_index (chr))); /* lexeme -> left opr, temp_ptr -> right opr */ if ^(temp_ptr -> operator_bead.allow_product) then go to barf_at_not_allowed_inner_prod; /* inner product is OK. Dig up the correct inner-product bead */ lexeme = addr (inner_product_table (fixed (lexeme -> operator_bead.op1, 17), fixed (temp_ptr -> operator_bead.op1, 17))) ; go to hrund_replace; /* write over the lexeme of the left operator */ snail (17): /* semicolon */ if paren_level = 0 /* top level? */ then do; if line_type = Diamond_type then do; code = apl_error_table_$mixed_diamonds_and_semicolons; go to error; end; line_type = Semicolon_type; end; else do; /* within some sort of brackets or parens */ if paren_stack (paren_level) = P_S_Opr_Brackets then go to barf_at_misplaced_semicolon; if paren_stack (paren_level) = P_S_Parens /* Argument List */ then do; next_lexeme = OperatorLexeme; lexeme = addr (operator_bead_table (op_index (SemiColonCons))); go to hrund_emit; end; if paren_stack (paren_level) = P_S_qCALL_Parens /* qCALL argument List */ then do; next_lexeme = OperatorLexeme; lexeme = addr (operator_bead_table (op_index (QuadCALLSemicolon))); go to hrund_emit; end; end; next_lexeme = SemiColon; /* Mixed Output */ go to get_hrund_emit; snail (23): /* diamond */ if paren_level ^= 0 then go to barf_at_misplaced_diamond; if line_type = Semicolon_type then do; code = apl_error_table_$mixed_diamonds_and_semicolons; go to error; end; line_type = Diamond_type; stmt_number = stmt_number + 1; if stmt_number > hbound (stmt_length_map, 1) then do; code = apl_error_table_$too_many_statements; go to error; end; stmt_length_map (stmt_number) = 0; next_lexeme = Diamond; go to get_hrund_emit; snail (18): /* left parenthesis */ paren_level = paren_level + 1; paren_stack (paren_level) = P_S_Parens; paren_loc (paren_level) = char_index; next_lexeme = OpenParenLexeme; if last_lexeme = NameLexeme then if temp_lexeme_array (lexeme_index - 1) = addr (operator_bead_table (op_index (QuadCALL))) then paren_stack (paren_level) = P_S_qCALL_Parens; go to get_hrund_emit; snail (20): /* right parenthesis */ if paren_level = 0 then go to barf_at_excess_right_parens; if paren_stack (paren_level) ^= P_S_Parens & paren_stack (paren_level) ^= P_S_qCALL_Parens then go to barf_at_mismatched_parens; if last_lexeme = OperatorLexeme then go to barf_at_not_end_with_value; if last_lexeme = OpenParenLexeme then go to barf_at_not_end_with_value; paren_level = paren_level - 1; next_lexeme = ValueLexeme; go to get_hrund_emit; snail (19): /* left bracket */ if last_lexeme = OperatorLexeme then if lexeme -> operator_bead.allow_brackets then do; /* brackets after mixed operator */ paren_level = paren_level + 1; paren_stack (paren_level) = P_S_Opr_Brackets; paren_loc (paren_level) = char_index; last_lexeme = OpenParenLexeme; temp_lexeme_array (lexeme_index - 1) = addr (lexeme -> mixed_op.brackets_operator_bead); go to get_hrund_emit; /* left opr bracket same as left bracket */ end; else go to barf_at_ill_opr_brackets; /* brackets after operator, but operator doesn't want them */ else if last_lexeme = BeginOfLine then go to barf_at_brackets_beginning; else if last_lexeme = OpenParenLexeme then go to barf_at_brackets_beginning; else if last_lexeme = SemiColon then go to barf_at_brackets_beginning; else if last_lexeme = Diamond then go to barf_at_brackets_beginning; /* a valid use of brackets for subscripting */ paren_level = paren_level + 1; paren_stack (paren_level) = P_S_Brackets; paren_loc (paren_level) = char_index; next_lexeme = OpenParenLexeme; go to get_hrund_emit; snail (21): /* right bracket */ if paren_level = 0 then go to barf_at_excess_right_brackets; if paren_stack (paren_level) ^= P_S_Brackets then if paren_stack (paren_level) ^= P_S_Opr_Brackets then go to barf_at_mismatched_parens; else do; /* opr brackets */ next_lexeme = OperatorLexeme; lexeme = addr (operator_bead_table (op_index (RightOprBracket))); /* funny bracket for rank spec. */ if last_lexeme = OpenParenLexeme then go to barf_at_not_end_with_value; /* empty brackets not allowed */ else if last_lexeme = OperatorLexeme then go to barf_at_not_end_with_value; end; else do; /* regular brackets */ next_lexeme = ValueLexeme; lexeme = addr (operator_bead_table (op_index (RightBracket))); if last_lexeme = OperatorLexeme then go to barf_at_not_end_with_value; end; paren_level = paren_level - 1; go to hrund_emit; /*** routines for emitting lexemes ***/ hrund_replace: /* write new OperatorLexeme over old, last_lexeme need not be changed. For inner product, etc. */ temp_lexeme_array (lexeme_index - 1) = lexeme; go to start_new_lexeme; hrund_emit_operator: snail (14): next_lexeme = OperatorLexeme; get_hrund_emit: lexeme = addr (operator_bead_table (op_index (chr))); hrund_emit: /* emit lexeme, set last_lexeme, and re-enter main loop on next character */ call emission; go to start_new_lexeme; emission: proc; if last_lexeme = ConstantLexeme then call convert_constant; /* get constant off stack and into value bead, emit ptr to value bead. This makes room avail to emit next ptr */ space_left_in_stack = space_left_in_stack - temp_lexeme_size; if space_left_in_stack < 0 then go to value_stack_exceeded; temp_lexeme_array (lexeme_index) = lexeme; source_pos (lexeme_index) = char_index; /* assume was one-character token */ if char_count >= 0 then source_pos (lexeme_index) = source_pos (lexeme_index) + 1; /* adjust for forged newline, which didn't bump char_index. Happens mainly in names */ lexeme_index = lexeme_index + 1; stmt_length_map (stmt_number) = stmt_length_map (stmt_number) + 1; last_lexeme = next_lexeme; end emission; convert_constant: proc; if stack_value_ptr -> value_bead.total_data_elements = 1 then /* scalar */ stack_value_ptr -> value_bead.rhorho = 0; else stack_value_ptr -> value_bead.rho (1) = stack_value_ptr -> value_bead.total_data_elements; if a_bad_lexeme_index ^= 0 then temp_ptr = null; else call apl_copy_value_ ((stack_value_ptr), temp_ptr); /* take value bead off stack, put in heap */ /* now emit temp_ptr. already know about lexeme_index, space_left_in_stack, etc. */ temp_lexeme_array (lexeme_index - 1) = temp_ptr; last_lexeme = ValueLexeme; space_left_in_stack = maximum_value_stack_size - fixed (rel (value_stack_space), 18) - lexeme_index * temp_lexeme_size; end convert_constant; /*** name lexer ***/ snail (1): /* alphabetic, underscore, delta, and underscored versions of these */ if chr = UnderLine then do; code = apl_error_table_$underscore_cant_begin_id; go to error; end; snail (2): /* E */ snail (3): /* Quad */ name_buffer_ptr = addr (paren_stack (paren_level + 1)); /* put name buffer at top of parse stack */ name_index = 0; /* start at beginning of name buffer */ nm (1): /* letter, etc. */ nm (2): /* E */ nm (5): /* digit */ /* legal name constituents come here */ name_buffer_array (name_index) = chr; /* drop character into name */ name_index = name_index + 1; char_count = char_count + 1; if char_count >= 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; /* line, function is system error */ case (3): chr = NewLine; /* execute is similar except don't adjust char_count */ end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; go to nm (char_type (chr)); nm (0): nm (3): nm (4): nm (6): nm (7): nm (8): nm (9): nm (10): nm (11): nm (12): nm (13): nm (14): nm (15): nm (16): nm (17): nm (18): nm (19): nm (20): nm (21): nm (22): nm (23): /* break character found. Name has ended. Make a lexeme for it */ if name_buffer_array (0) = Quad then if name_index = 1 then lexeme = addr (operator_bead_table (op_index (Quad))); else do; /* system name */ do n = lbound (system_names, 1) to hbound (system_names, 1); if system_names (n) = name_buffer then do; lexeme = addr (operator_bead_table (op_index (n))); go to emit_name; end; end; go to barf_at_unknown_system_name; /* not in table */ end; else if name_index > 2 /* stop/trace control */ then if name_buffer_array (1) = Delta then if name_buffer_array (0) = LetterT then go to trace_control; else if name_buffer_array (0) = LetterS then go to stop_control; else go to pl1_loss; else go to pl1_loss; else pl1_loss: /* because & loses in if */ do; /* not a special name, look up in symbol table and check for label */ if a_bad_lexeme_index ^= 0 then lexeme = null; else call apl_get_symbol_ (name_buffer, lexeme, (0)); if esw = apl_function_lex_ then if chr = Colon then if last_lexeme = BeginOfLine then do; /* process label */ if statement_map (line_no).label ^= null then go to barf_at_excess_label; if lexeme ^= null /* protect loop if we are just re-lexing for errors */ then do n = 1 to line_no - 1; if statement_map (n).label = lexeme then go to duplicate_label; end; statement_map (line_no).label = lexeme; /* store ptr to symbol bead in stmt map */ number_of_labels = number_of_labels + 1; go to start_new_lexeme; end; end; emit_name: /* emit name lexeme then look at chr again */ next_lexeme = NameLexeme; call emission; source_pos (lexeme_index - 1) = source_pos (lexeme_index - 1) - name_index; /* -> beginning of name */ go to snail (char_type (chr)); stop_control: call s_t_emit_name; lexeme = addr (operator_bead_table (op_index (SDelta))); go to emit_name; /* put out funny lexeme which looks like system-variable */ trace_control: call s_t_emit_name; lexeme = addr (operator_bead_table (op_index (TDelta))); go to emit_name; /* put out funny lexeme which looks like a system variable */ s_t_emit_name: proc; if a_bad_lexeme_index ^= 0 then lexeme = null; else call apl_get_symbol_ (substr (name_buffer, 3), lexeme, (0)); /* get ptr to symbol bead for fcn */ next_lexeme = NameLexeme; /* first put out name of function, then SD or TD lexeme */ call emission; source_pos (lexeme_index - 1) = source_pos (lexeme_index - 1) - name_index; /* -> beginning of name */ end s_t_emit_name; /*** character constants ***/ snail (12): if last_lexeme ^= ConstantLexeme then do; /* start a value bead in the stack */ source_pos (lexeme_index) = char_index; lexeme_index = lexeme_index + 1; /* as if we has emitted the constant-lexeme already */ stmt_length_map (stmt_number) = stmt_length_map (stmt_number) + 1; stack_value_ptr = addr (temp_lexeme_array (lexeme_index)); last_lexeme = ConstantLexeme; number_of_dimensions = 1; space_left_in_stack = space_left_in_stack - size (value_bead); /* = size of empty value bead with one rho vector entry */ if space_left_in_stack < 0 then go to value_stack_exceeded; string (stack_value_ptr -> value_bead.type) = character_value_type; /* don't worry about size field - never looked at since in stack */ stack_value_ptr -> value_bead.reference_count = -1; stack_value_ptr -> value_bead.total_data_elements = 0; /* start out as '', the null string */ stack_value_ptr -> value_bead.rhorho = 1; /* .. */ /* don't worry about rho(1), will be set by convert_constant */ /* also convert_constant will take care of the scalar case */ stack_value_ptr -> value_bead.data_pointer = addr (stack_value_ptr -> value_bead.rho (2)); /* first free loc */ n = -1; /* set up byte ctr to append new word */ end; else if stack_value_ptr -> value_bead.data_type.character_value then /* OK to append to prev string */ n = -1 - mod (stack_value_ptr -> value_bead.total_data_elements, 4); /* mod 4 char ctr, -4 to -1 */ else go to barf_at_constant_mism; /* not OK to append to prev # */ /* now append characters of quoted string to stack_value_ptr -> value_bead */ char_constant_loop: char_count = char_count + 1; if char_count = 0 then go to unexpected_eot_char_constant; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if chr = Apostrophe then do; /* may be end of string or insertion of quote into string */ char_count = char_count + 1; if char_count = 0 then if esw = apl_execute_lex_ then do; chr = NewLine; go to process_newline; end; else go to unexpected_eot_char_constant; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if chr ^= Apostrophe then go to snail (char_type (chr)); /* end of string */ end; /* two quotes, fall through to put one into string */ /* drop chr into string */ n = n + 1; if n = 0 then do; n = -4; /* append new word to value bead */ space_left_in_stack = space_left_in_stack - 1; if space_left_in_stack < 0 then go to value_stack_exceeded; end; unspec (stack_value_ptr -> value_bead.data_pointer -> character_datum (stack_value_ptr -> value_bead.total_data_elements)) = bit (fixed (chr, 9), 9); stack_value_ptr -> value_bead.total_data_elements = stack_value_ptr -> value_bead.total_data_elements + 1; go to char_constant_loop; /*** numeric constant processing ***/ start_negative_number: snail (6): number_buffer = decimal_zero; /* zero out digit(0:33), must_be_zero */ sign = "-"; char_count = char_count + 1; if char_count = 0 then go to barf_at_lone_upper_minus; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if char_type (chr) = 5 then go to number_proc; else if chr = Period then go to dec_point_join; else go to barf_at_lone_upper_minus; start_number: snail (5): number_buffer = decimal_zero; number_proc: if esw ^= apl_scan_ then call numsetup; expona = -(1 + hbound (digit, 1) + 1); /* digit counter and exponent offset */ if chr ^= Zero then go to numip (5); /* gobble leading zeroes */ numiplz: char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; if chr = Zero then go to numiplz; else if chr = Period then do; if esw ^= apl_scan_ then string (stack_value_ptr -> value_bead.type) = string (stack_value_ptr -> value_bead.type) & not_integer_mask; else token_type = 4; exponb = expona; go to numfplz; end; else go to numip (char_type (chr)); /* not leading-char, process it */ numip (5): /* add another digit to integer part */ digit (expona + 1 + hbound (digit, 1) + 1) = chr; expona = expona + 1; if expona = 0 then go to eat_up_long_number_ip; char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; go to numip (char_type (chr)); numip (7): /* decimal point ends integer part, begins fraction part */ if esw ^= apl_scan_ then string (stack_value_ptr -> value_bead.type) = string (stack_value_ptr -> value_bead.type) & not_integer_mask; /* decimal point means not an integer (not always, e.g. 1.0, but assume always anyway) */ else token_type = 4; exponb = expona; go to numfp_join; numfp (5): /* add another digit to fraction part */ digit (exponb + 1 + hbound (digit, 1) + 1) = chr; exponb = exponb + 1; if exponb = 0 then go to eat_up_long_number_fp; numfp_join: char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; go to numfp (char_type (chr)); numip (2): numfp (2): numhp1 (2): numhp2 (2): /* E seen - begin exponent */ if esw ^= apl_scan_ then string (stack_value_ptr -> value_bead.type) = string (stack_value_ptr -> value_bead.type) & not_integer_mask; else token_type = 4; /* if there is an exponent, decide that it is not an integer */ exponb = 0; /* expona = number of digits of integer part - (1+hbound(digit,1)+1) */ /* exponb gets exponent */ negative_exponent = "0"b; /* assume no upper minus after E */ char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; if chr = UpperMinus then negative_exponent = "1"b; else go to numep (char_type (chr)); numep_getc: char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; go to numep (char_type (chr)); numep (5): /* add digit to exponent */ exponb = exponb * 10 + chr - Zero; go to numep_getc; numep (0): numep (1): numep (2): numep (3): numep (4): numep (6): numep (8): numep (9): numep (10): numep (11): numep (12): numep (13): numep (14): numep (15): numep (16): numep (17): numep (18): numep (19): numep (20): numep (21): numep (22): numep (23): /* finish exponent (break chr seen) */ if negative_exponent then exponb = -exponb; expona = expona + exponb; /* set expona as if 0's given instead of E, fall through */ numip (0): numip (1): numip (3): numip (4): numip (6): numip (8): numip (9): numip (10): numip (11): numip (12): numip (13): numip (14): numip (15): numip (16): numip (17): numip (18): numip (19): numip (20): numip (21): numip (22): numip (23): numfp (0): numfp (1): numfp (3): numfp (4): numfp (6): numfp (8): numfp (9): numfp (10): numfp (11): numfp (12): numfp (13): numfp (14): numfp (15): numfp (16): numfp (17): numfp (18): numfp (19): numfp (20): numfp (21): numfp (22): numfp (23): numhp1 (0): numhp1 (1): numhp1 (3): numhp1 (4): numhp1 (6): numhp1 (8): numhp1 (9): numhp1 (10): numhp1 (11): numhp1 (12): numhp1 (13): numhp1 (14): numhp1 (15): numhp1 (16): numhp1 (17): numhp1 (18): numhp1 (19): numhp1 (20): numhp1 (21): numhp1 (22): numhp1 (23): numhp2 (0): numhp2 (1): numhp2 (3): numhp2 (4): numhp2 (6): numhp2 (8): numhp2 (9): numhp2 (10): numhp2 (11): numhp2 (12): numhp2 (13): numhp2 (14): numhp2 (15): numhp2 (16): numhp2 (17): numhp2 (18): numhp2 (19): numhp2 (20): numhp2 (21): numhp2 (22): numhp2 (23): number_finish: /* finish number (break chr seen) */ /* put in expona as the exponent */ expona = expona + 1; /* fudge,fudge, wonderful fudge from fudgetown! */ if expona > 127 then go to substitute_infinity; /* next statement would raise size condition */ if expona < -127 then go to substitute_zero; /* ... */ exponent = expona; /* pack exponent into decimal number */ if abs (number_buffer) > decimal (TheBiggestNumberWeveGot) then go to substitute_infinity; else if abs (number_buffer) < decimal (TheSmallestNumberWeveGot) then go to substitute_zero; /* OK, number_buffer may now be assigned to numeric_datum without raising any conditions or otherwise losing */ apl_number = binary (number_buffer * magic_rounding_constant, 63); num_spit_out: if esw = apl_scan_ then go to end_number_scan; space_left_in_stack = space_left_in_stack - size (apl_number_for_size); if space_left_in_stack < 0 then go to value_stack_exceeded; stack_value_ptr -> value_bead.data_pointer -> numeric_datum (stack_value_ptr -> value_bead.total_data_elements) = apl_number; if stack_value_ptr -> value_bead.data_type.zero_or_one_value then /* some possibility that might be 0 or 1 */ if apl_number ^= 0.0e0 then if apl_number ^= 1.0e0 then /* so see whether or not it really is */ stack_value_ptr -> value_bead.data_type.zero_or_one_value = "0"b; stack_value_ptr -> value_bead.total_data_elements = stack_value_ptr -> value_bead.total_data_elements + 1; go to snail (char_type (chr)); /* number has been emitted, look at break chr again */ start_number_with_decimal_point: number_buffer = decimal_zero; dec_point_join: expona, exponb = -(1 + hbound (digit, 1) + 1); if esw ^= apl_scan_ then do; call numsetup; string (stack_value_ptr -> value_bead.type) = string (stack_value_ptr -> value_bead.type) & not_integer_mask; end; else token_type = 4; numfplz: /* skip over leading zeroes in fraction part */ char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; end; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; if chr ^= Zero then go to numfp (char_type (chr)); expona = expona - 1; /* adjust for zero being thrown away */ go to numfplz; /* come here when numeric underflow */ substitute_zero: apl_number = 0.0e0; go to num_spit_out; /* come here when numeric overflow */ substitute_infinity: if sign = "-" then apl_number = -TheBiggestNumberWeveGot; else apl_number = TheBiggestNumberWeveGot; go to num_spit_out; /* come here if two decimal points in a number */ numep (7): numfp (7): numhp2 (7): if esw = apl_scan_ then go to end_number_scan; code = apl_error_table_$extra_decimal_point; go to error; /* come here to eat up extra digits if the loser types more than 60 or so */ numhp1 (5): expona = expona + 1; /* these digits are still to the left of a decimal point */ eat_up_long_number_ip: char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; go to number_finish; end; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to numhp1 (char_type (chr)); eat_up_long_number_fp: numhp2 (5): numhp1 (7): /* eat digits to right of decimal point */ char_count = char_count + 1; if char_count = 0 then begin; go to case (esw); case (1): case (2): go to unexpected_end_of_text; case (0): case (3): chr = NewLine; go to number_finish; end; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to numhp2 (char_type (chr)); numsetup: proc; if last_lexeme ^= ConstantLexeme then do; /* make value bead, as with char constant */ source_pos (lexeme_index) = char_index; /* as if we had already emitted the constant-lexeme */ lexeme_index = lexeme_index + 1; stmt_length_map (stmt_number) = stmt_length_map (stmt_number) + 1; stack_value_ptr = addr (temp_lexeme_array (lexeme_index)); last_lexeme = ConstantLexeme; number_of_dimensions = 1; if space_left_in_stack < size (value_bead) + 1 then go to value_stack_exceeded; string (stack_value_ptr -> value_bead.type) = zero_or_one_value_type; /* some bits may get cleared later */ /* don't worry about fields not assigned here, see char const comments */ stack_value_ptr -> value_bead.reference_count = -1; stack_value_ptr -> value_bead.total_data_elements = 0; stack_value_ptr -> value_bead.rhorho = 1; /* set data_pointer to next double word. */ temp_ptr = addr (stack_value_ptr -> value_bead.rho (2)); /* next available word. */ if substr (rel (temp_ptr), 18, 1) /* if on an odd word boundary */ then temp_ptr = addrel (temp_ptr, 1); /* then make it even */ stack_value_ptr -> value_bead.data_pointer = temp_ptr; space_left_in_stack = maximum_value_stack_size - fixed (rel (stack_value_ptr -> value_bead.data_pointer), 18); end; else if stack_value_ptr -> value_bead.data_type.numeric_value then ; /* OK to append to prev number */ else go to barf_at_constant_mism; /* not OK to append to prev string */ end numsetup; /*** routine called to get at least half a segment of value stack space. anyone who tries to lex a function bigger than this is crazy! ***/ setup_value_stack: proc; dcl apl_get_next_value_stack_seg_ entry (fixed bin (21)); value_stack_popper = ws_info.value_stack_ptr; /* so can restore ws_info.value_stack_ptr on return */ space_left_in_stack = maximum_value_stack_size - fixed (rel (value_stack_popper), 18); if space_left_in_stack < 32768 then do; /* this seg is too small, get another one */ call apl_get_next_value_stack_seg_ (32768); value_stack_space = ws_info.value_stack_ptr; space_left_in_stack = maximum_value_stack_size - fixed (rel (value_stack_space), 18); end; else value_stack_space = value_stack_popper; /* if keeping same seg */ end setup_value_stack; snail (9): /* skip over comment */ call for_illumination_only; go to process_newline; /*** hirsute apl assignment operator gets all kinds of help from this phase of parse so runtime parser will not have to do as much work ***/ snail (22): if last_lexeme = NameLexeme then if lexeme = null then go to hrund_emit_operator; /* if lexing for errors, will be null ptr */ else if lexeme -> general_bead.type.symbol then go to hrund_emit_operator; /* assignment to user variable, easy - just emit -<- lexeme */ else if lexeme -> general_bead.type.operator then do; /* assignment to system variable */ if lexeme -> operator_bead.ignores_assignment then lexeme = addr (operator_bead_table (op_index (AssignIgnore))); else if lexeme -> operator_bead.special_assignment then lexeme = addr (lexeme -> system_var_op.assignment_to); else go to ulose; last_lexeme = OperatorLexeme; go to hrund_replace; end; else go to ulose; else if last_lexeme = ValueLexeme /***** then if lexeme = addr(operator_bead_table(op_index(RightBracket))) then do; *****/ then do; /**** this kludge is due to bad code by PL/I for pointer compare packed ****/ hack_ptr = lexeme; if hack_ptr = addr (operator_bead_table (op_index (RightBracket))) then do; /* subscripted assignment - first step is to find the left end of the subscript calculation */ /***** the following code has been hacked up because of bad code generated by the PL/I compiler for comparing a packed pointer with the addr of something *****/ n = 0; do begin_subscript_calc = lexeme_index - 1 by -1; /* look back */ hack_ptr = temp_lexeme_array (begin_subscript_calc); /* copy to avoid ptr compare bug and also because optimizer did not optimize repeated references */ if hack_ptr = addr (operator_bead_table (op_index (RightBracket))) then n = n + 1; else if hack_ptr = addr (operator_bead_table (op_index (RightOprBracket))) then n = n + 1; else if hack_ptr = addr (operator_bead_table (op_index (RightParen))) then n = n + 1; else if hack_ptr = addr (operator_bead_table (op_index (LeftParen))) then n = n - 1; else if hack_ptr = addr (operator_bead_table (op_index (LeftBracket))) then n = n - 1; if n = 0 then go to exitloop_for_subscript_calc; end; exitloop_for_subscript_calc: /* begin_subscript_calc -> "[" lexeme */ begin_subscript_calc = begin_subscript_calc - 1; /* lexeme being subscripted */ lexeme = temp_lexeme_array (begin_subscript_calc); if lexeme = null then go to subscripted_assign_user_var; /* bug when lexing for errors */ if lexeme -> general_bead.type.operator then if lexeme -> operator_bead.allow_subscripted_assignment then temp_lexeme_array (begin_subscript_calc) = addr (lexeme -> system_var_op.subscripted_assignment_to); else if lexeme -> operator_bead.ignores_assignment then temp_lexeme_array (begin_subscript_calc) = addr (operator_bead_table (op_index (AssignIgnore))); else do; char_index = source_pos (begin_subscript_calc); /* get marker at right place */ go to barf_at_bad_subscripted_assignment_to_system_variable; end; else if lexeme -> general_bead.type.symbol then do; /* subscripted assignment to user variable */ subscripted_assign_user_var: /* move subscript to right of the assignment lexeme. */ space_left_in_stack = space_left_in_stack - temp_lexeme_size; if space_left_in_stack < 0 then go to value_stack_exceeded; begin_subscript_calc = begin_subscript_calc + 1; /* -> leftmost thing to be moved to right */ do i = lexeme_index by -1 while (i ^= begin_subscript_calc); /* Move Right to Left loop */ emission_array (i) = emission_array (i - 1); end; temp_lexeme_array (begin_subscript_calc) = addr (operator_bead_table (op_index (AssignSub))); /* insert subscripted assignment operator to the left of the brakcet subscript calculation */ source_pos (begin_subscript_calc) = char_index; lexeme_index = lexeme_index + 1; /* one more lexeme has been emitted here */ stmt_length_map (stmt_number) = stmt_length_map (stmt_number) + 1; end; else go to barf_at_badass; end; /* end of subscripted-assignment do */ else go to barf_at_badass; end; /****** end of hack_ptr do, due to PL/I compiler bug ******/ else go to barf_at_badass; /* assignment preceded by some random lexeme */ temp_lexeme_array (lexeme_index - 1) = addr (operator_bead_table (op_index (RightOprBracket))); last_lexeme = OperatorLexeme; /* assignment looks to right like monadic operator, with rank qualifier */ go to start_new_lexeme; /*** all has been lexed, make a lexed_function_bead ***/ end_of_text: if esw ^= apl_execute_lex_ then if char_index ^= line_index then go to barf_at_not_end_with_newline; /** if errors occurred, don't make a lexed_function_bead since our caller won't look at it anyway **/ if errors_occurred then go to die_die_die; lexeme_index = lexeme_index - 1; /* flush extra begin-line lexeme */ if esw = apl_line_lex_ then if line_no ^= 2 then go to barf_at_more_than_one_line; else ; else if esw = apl_execute_lex_ then if line_no ^= 2 then go to barf_at_more_than_one_line_execute; /* allocate lexed_function_bead */ if a_bad_lexeme_index ^= 0 then go to ulose; /* shouldn't get here! ought to have encountered the bad lexeme by now */ call apl_allocate_words_ (size (lexed_function_bead) + number_of_localized_symbols + 3 + 2 * number_of_labels + lexeme_index + line_no - 1 - 1, lex_return_pointer); string (lex_return_pointer -> lexed_function_bead.type) = lexed_function_type; lex_return_pointer -> lexed_function_bead.name = function_being_lexed; lex_return_pointer -> lexed_function_bead.number_of_statements = line_no - 1; lex_return_pointer -> lexed_function_bead.number_of_localized_symbols = number_of_localized_symbols + number_of_labels + 3; lex_return_pointer -> lexed_function_bead.number_of_labels = number_of_labels; lex_return_pointer -> lexed_function_bead.label_values_ptr = addr (lex_return_pointer -> lexed_function_bead.label_values); lex_return_pointer -> lexed_function_bead.statement_map_ptr = addr (lex_return_pointer -> lexed_function_bead.statement_map); lex_return_pointer -> lexed_function_bead.lexeme_array_ptr = addr (lex_return_pointer -> lexed_function_bead.lexeme_array); lex_return_pointer -> lexed_function_bead.localized_symbols (ReturnSymbol) = return_value_symbol; lex_return_pointer -> lexed_function_bead.localized_symbols (LeftArgSymbol) = left_arg_symbol; lex_return_pointer -> lexed_function_bead.localized_symbols (RightArgSymbol) = right_arg_symbol; do n = 1 by 1 while (n <= number_of_localized_symbols); lex_return_pointer -> lexed_function_bead.localized_symbols (n + 3) = MY.localized_symbols (n); end; if number_of_labels ^= 0 then do; /* set up label_values */ template_ptr = addr (number_buffer); /* initialize label template outside the loop, except the actual value, stored in apl_number */ string (template_ptr -> value_bead.type) = label_type; template_ptr -> value_bead.total_data_elements = 1; template_ptr -> value_bead.rhorho = 0; template_ptr -> value_bead.data_pointer = addr (apl_number); n = number_of_localized_symbols + 3; do i = 1 by 1 while (i < line_no); /* scan statement map for labels */ if statement_map (i).label ^= null then do; /* aha! a label */ n = n + 1; lex_return_pointer -> lexed_function_bead.localized_symbols (n) = statement_map (i).label; apl_number = i; /* convert line number label is on to APL number */ call apl_copy_value_ (template_ptr, lex_return_pointer -> lexed_function_bead.label_values_ptr -> lexed_function_label_values (n - number_of_localized_symbols - 3)); end; end; if n ^= lex_return_pointer -> lexed_function_bead.number_of_localized_symbols then /* whoops */ go to ulose; end; /*** end of if number_of_labels ^= 0 then do ***/ /* set up statement map */ statement_count = line_no - 1; /* set up dimension of lexed_function_statement_map */ do n = 1 by 1 while (n < line_no); lex_return_pointer -> lexed_function_bead.statement_map_ptr -> lexed_function_statement_map (n) = statement_map (n).lexeme_index; end; /* now set up the actual lexeme array */ first_lexeme = 1; do i = 1 by 1 while (i < line_no); /* step thru each line */ output_index = statement_map (i).lexeme_index; /* new line begins same place as old */ line_len = output_index - first_lexeme + 1; /* Each line begins with a BOL. It doesn't get moved. It will have the same position in the output (lexemes are conserved). */ first_lexeme = first_lexeme + 1; /* don't copy BOL */ do while (first_lexeme <= statement_map (i).lexeme_index); n = 0; done = "0"b; do lx = first_lexeme to statement_map (i).lexeme_index while (^done); if temp_lexeme_array (lx) -> general_bead.type.operator then if temp_lexeme_array (lx) -> operator_bead.type_code = diamond_type then done = "1"b; else n = n + 1; else n = n + 1; end; /* At this point n is the number of lexemes before the diamond, if any */ do lx = n - 1 to 0 by -1; /* copy lexemes backwards */ lex_return_pointer -> lexed_function_bead.lexeme_array_ptr -> lexed_function_lexeme_array (output_index) = temp_lexeme_array (first_lexeme + lx); output_index = output_index - 1; end; /* If there is a diamond, copy it */ first_lexeme = first_lexeme + n; if first_lexeme <= statement_map (i).lexeme_index then do; lex_return_pointer -> lexed_function_bead.lexeme_array_ptr -> lexed_function_lexeme_array (output_index) = temp_lexeme_array (first_lexeme); output_index = output_index - 1; first_lexeme = first_lexeme + 1; end; end; lex_return_pointer -> lexed_function_bead.lexeme_array_ptr -> lexed_function_lexeme_array (output_index) = temp_lexeme_array (output_index); end; ws_info.value_stack_ptr = value_stack_popper; /* pop our temporary storage off the value stack */ /*** set up bits_for_parse field ***/ unspec (lex_return_pointer -> lexed_function_bead.bits_for_parse) = ""b; lex_return_pointer -> lexed_function_bead.bits_for_parse.function = "1"b; lex_return_pointer -> lexed_function_bead.bits_for_parse.op1 = 99; if right_arg_symbol ^= null then if left_arg_symbol ^= null then lex_return_pointer -> lexed_function_bead.bits_for_parse.dyadic = "1"b; else lex_return_pointer -> lexed_function_bead.bits_for_parse.monadic = "1"b; return; /* done!! */ /*** here are some error routines ***/ misplaced_right_arrow: code = apl_error_table_$misplaced_right_arrow; go to error; snail (0): snail (13): code = apl_error_table_$random_char; go to error; barf_at_ill_reduction: if chr ^= Slash & chr ^= SlashHyphen then code = apl_error_table_$ill_scan; else code = apl_error_table_$ill_reduction; go to error; ulose: code = apl_error_table_$lex_screwed_up; go to fatal_error; barf_at_not_end_with_newline: unexpected_end_of_text: if esw = apl_execute_lex_ then do; code = apl_error_table_$too_short_execute; go to error; end; code = apl_error_table_$not_end_with_newline; go to fatal_error; barf_at_ill_inner_prod: code = apl_error_table_$ill_inner_prod; go to error; barf_at_misplaced_diamond: code = apl_error_table_$misplaced_diamond; go to error; barf_at_misplaced_semicolon: code = apl_error_table_$misplaced_semicolon; go to error; barf_at_excess_right_parens: code = apl_error_table_$excess_right_parens; go to error; barf_at_mismatched_parens: code = apl_error_table_$mismatched_parens; go to error; barf_at_ill_opr_brackets: code = apl_error_table_$ill_opr_brackets; go to error; barf_at_brackets_beginning: code = apl_error_table_$misplaced_brackets; go to error; barf_at_excess_right_brackets: code = apl_error_table_$excess_right_brackets; go to error; barf_at_not_end_with_value: code = apl_error_table_$not_end_with_value; go to error; barf_at_ill_small_circle: code = apl_error_table_$ill_small_circle; go to error; barf_at_unknown_system_name: code = apl_error_table_$unknown_system_name; go to err_back_over_name; value_stack_exceeded: code = apl_error_table_$ws_full_in_lex; go to fatal_error; barf_at_constant_mism: code = apl_error_table_$constant_mism; go to error; unexpected_eot_char_constant: begin; go to case (esw); case (2): if error_suppress then go to case (3); /* entry was apl_function_lex_no_messages_, diff. error */ code = apl_error_table_$mism_quotes; go to fatal_error; case (1): case (3): /* is user error rather than system error */ code = apl_error_table_$u_mism_ur_quotes; go to error; end; barf_at_ill_paren_level: char_count = char_count - (char_index - paren_loc (1)); char_index = paren_loc (1); /* location of left-most unbalanced paren */ code = apl_error_table_$ill_paren_level; go to error; barf_at_not_allowed_inner_prod: code = apl_error_table_$not_allowed_inner_prod; go to error; barf_at_not_allowed_outer_prod: code = apl_error_table_$not_allowed_outer_prod; go to error; barf_at_more_than_one_line: code = apl_error_table_$more_than_one_line; go to fatal_error; barf_at_more_than_one_line_execute: code = apl_error_table_$more_than_one_line_execute; go to error; barf_at_badass: code = apl_error_table_$badass; go to error; barf_at_bad_subscripted_assignment_to_system_variable: code = apl_error_table_$bad_subsc_assign_sys_var; go to error; barf_at_lone_upper_minus: if esw = apl_scan_ then go to scan0 (0); code = apl_error_table_$lone_upper_minus; go to error; barf_at_bad_localization: code = apl_error_table_$cant_be_localized; go to fatal_error; barf_at_lone_period: code = apl_error_table_$lone_period; go to error; barf_at_excess_label: code = apl_error_table_$excess_label; go to error; duplicate_label: code = apl_error_table_$duplicate_label; go to error; /*** routines transferred to by the above barfs ***/ err_back_over_name: /* back up to beginning of identifier */ do while ("1"b); char_count = char_count - 1; char_index = char_index - 1; if char_index = 0 then go to err_hack; /* reached begin of text */ n = char_type (fixed (unspec (substr (text, char_index - 1 + 1, 1)))); if n ^= 1 then if n ^= 2 then if n ^= 3 then if n ^= 5 then go to err_hack; /* found break char preceding name */ end; /* keep looping */ err_hack: /* exitloop for the preceding loop */ char_count = char_count + 1; char_index = char_index + 1; /* as if the chr to be marked had just been read */ /* fall into error */ error: /* barf and go on to the next line looking for more errors */ fatal = "0"b; if error_suppress then go to die_die_die; /* if not allowed to print messages, just go tell caller. don't even bother to check for any more errors */ go to handle_lex_error; fatal_error: /* error from which lex cannot recover */ fatal = "1"b; handle_lex_error: /* find length of the current line */ begin; go to case (esw); case (1): case (2): ll = index (substr (text, char_index - 1 + 1), NL) - 1; if ll < 0 then ll = length (substr (text, char_index - 1 + 1)); ll = ll + char_index - line_index /* +1-1*/; go to endcase; case (3): ll = -char_count - 1 + char_index - line_index; if char_count >= 0 then ll = ll + 1; /* reached end of execute, forged NewLine was not counted in char_index */ endcase: end; call apl_error_ (code, ""b, char_index - line_index /* +1-1 */, substr (text, line_index + 1, ll), /* the losing line */ function_being_lexed, line_no); if fatal then do; /* crap out of lex */ die_die_die: errors_occurred = "1"b; /* tell our caller that we have printed some error messages */ call cleanup; lex_return_pointer = null; if esw = apl_function_lex_ then if error_suppress then if error_line_number_arg = 0 then error_line_number_arg = line_no; return; end; errors_occurred = "1"b; /* tell our caller that we have printed some error messages */ /* nonfatal error, advance to next line and continue lexing */ char_count = char_count + ll - char_index + line_index; char_index = line_index + ll; go to start_line; /*** get rid of all the beads we generated ***/ cleanup: proc; do i = lbound (MY.localized_symbols, 1) by 1 while (i <= hbound (MY.localized_symbols, 1)); call wash (MY.localized_symbols (i)); end; if last_lexeme = ConstantLexeme then n = hbound (temp_lexeme_array, 1) - 1; /* last lexeme has not yet been stored into */ else n = hbound (temp_lexeme_array, 1); do i = lbound (temp_lexeme_array, 1) by 1 while (i < n); /* yes, < not <= ! */ call wash (temp_lexeme_array (i)); end; call wash (function_being_lexed); call wash (left_arg_symbol); call wash (right_arg_symbol); call wash (return_value_symbol); ws_info.value_stack_ptr = value_stack_popper; return; wash: procedure (temp_ptr); /* parameters */ dcl temp_ptr ptr unal parameter; /* program */ if temp_ptr ^= null then if ^temp_ptr -> general_bead.type.operator then do; temp_ptr -> general_bead.reference_count = temp_ptr -> general_bead.reference_count - 1; if temp_ptr -> general_bead.reference_count < 1 then call apl_free_bead_ (temp_ptr); end; end wash; end cleanup; /*** special entry point used by QuadFX ***/ apl_function_lex_no_messages_: entry (text, lex_return_pointer, errors_occurred, a_bad_lexeme_index, parse_stack_space, error_line_number_arg); dcl error_line_number_arg fixed bin; /* returns number of the argument that lost */ error_line_number_arg = 0; /* initialize */ error_suppress = "1"b; go to join_with_apl_function_lex_; /*** this entry is for lexing a function. It knows about header lines, labels, etc. ***/ apl_function_lex_: entry (text, lex_return_pointer, errors_occurred, a_bad_lexeme_index, parse_stack_space); error_suppress = "0"b; join_with_apl_function_lex_: esw = apl_function_lex_; char_count = -length (text) - 1; errors_occurred = "0"b; last_lexeme = BeginOfLine; char_index = 0; lexeme_index = 1; line_no = 0; /* in case of error in header line */ line_index = 0; /* in case of error in header line */ call setup_value_stack; number_of_labels = 0; char_count = -length (text) - 1; /*** process header line, producing localized_symbols table, and setting the automatic variables function_being_lexed, left_arg_symbol, right_arg_symbol, return_value_symbol ***/ number_of_localized_symbols = 0; lexeme = null; return_value_symbol = null; /* assume none will show up */ hdr1_loop: hdr1 (11): /* to ignore blanks at begin of header line */ char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to hdr1 (char_type (chr)); hdr1 (0): hdr1 (3): hdr1 (4): hdr1 (5): hdr1 (6): hdr1 (7): hdr1 (8): hdr1 (12): hdr1 (13): hdr1 (14): hdr1 (15): hdr1 (16): hdr1 (18): hdr1 (19): hdr1 (20): hdr1 (21): hdr1 (23): hdr2 (0): hdr2 (3): hdr2 (4): hdr2 (5): hdr2 (6): hdr2 (7): hdr2 (8): hdr2 (12): hdr2 (13): hdr2 (14): hdr2 (15): hdr2 (16): hdr2 (18): hdr2 (19): hdr2 (20): hdr2 (21): hdr2 (23): hdr3 (0): hdr3 (3): hdr3 (4): hdr3 (5): hdr3 (6): hdr3 (7): hdr3 (8): hdr3 (12): hdr3 (13): hdr3 (14): hdr3 (15): hdr3 (16): hdr3 (18): hdr3 (19): hdr3 (20): hdr3 (21): hdr3 (22): hdr3 (23): hdr4 (0): hdr4 (3): hdr4 (4): hdr4 (5): hdr4 (6): hdr4 (7): hdr4 (8): hdr4 (12): hdr4 (13): hdr4 (14): hdr4 (15): hdr4 (16): hdr4 (18): hdr4 (19): hdr4 (20): hdr4 (21): hdr4 (22): hdr4 (23): hdr5 (0): hdr5 (4): hdr5 (5): hdr5 (6): hdr5 (7): hdr5 (8): hdr5 (12): hdr5 (13): hdr5 (14): hdr5 (15): hdr5 (16): hdr5 (18): hdr5 (19): hdr5 (20): hdr5 (21): hdr5 (22): hdr5 (23): /* moby dispatch table */ code = apl_error_table_$random_char_in_hdr; go to fatal_error; hdr1 (17): hdr1 (22): /* semicolon, left arrow */ code = apl_error_table_$need_name; go to fatal_error; hdr1 (9): /* lamp - just as a hack allow comments and blank lines before the header */ call for_illumination_only; hdr1 (10): /* NewLine */ go to hdr1_loop; hdr1 (1): hdr1 (2): /* begin of name - parse it and stick it in lexeme - may be return_value or fcn_name */ call parse_name_in_header_line; go to hdr2 (char_type (chr)); /* look at chr that ended name */ /* HEADER 2 LOOP BEGINS HERE */ hdr2 (11): char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to hdr2 (char_type (chr)); hdr2 (9): /* lamp - skip comment and trun into semicolon */ call for_illumination_only; hdr2 (10): /* newline - there was nothing on the header line but the name of the function */ hdr2 (17): /* semicolon - similar except local vars to be done */ function_being_lexed = lexeme; left_arg_symbol, right_arg_symbol = null; go to look_for_local_var_dcls; /* which will check whether chr = NewLine or SemiColon */ hdr2 (22): /* LeftArrow - lexeme is symbol whose value is value of fcn */ if return_value_symbol = null then return_value_symbol = lexeme; else do; code = apl_error_table_$only_1_return_value; go to fatal_error; end; go to hdr1_loop; /* and go on in same state (just about) */ hdr2 (1): hdr2 (2): /* another symbol follows. There are two cases: 1) one more symbol follows. It is right_arg_symbol and this one is fcn name 2) two more symbols follow. This one is left_arg_symbol and they are right_arg_symbol and fcn_name */ temp_ptr = lexeme; /* hold this one in my hand until I know which case holds */ call parse_name_in_header_line; go to hdr3 (char_type (chr)); /** now search for the break character of this name **/ /* HEADER 3 LOOP BEGINS HERE */ hdr3 (11): char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to hdr3 (char_type (chr)); hdr3 (9): /* lamp - end it all. skip over comment and fall into newline case */ call for_illumination_only; hdr3 (10): /* newline - temp_ptr = fcn name and lexeme = right arg symbol */ hdr3 (17): /* semicolon which is similar to newline */ function_being_lexed = temp_ptr; right_arg_symbol = lexeme; left_arg_symbol = null; go to look_for_local_var_dcls; /* which checks for semicolon or newline */ hdr3 (1): hdr3 (2): /* case 2 - another name follows. deposit the first two and then pick up the third one */ left_arg_symbol = temp_ptr; function_being_lexed = lexeme; call parse_name_in_header_line; go to hdr4 (char_type (chr)); /* HEADER 4 LOOP BEGINS HERE */ hdr4 (11): /* and scan up to following newline or semicolon */ char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to hdr4 (char_type (chr)); hdr4 (1): hdr4 (2): /* still another name? that's no good */ code = apl_error_table_$need_semicolon; go to fatal_error; hdr4 (9): /* lamp - skip over comment and trun into newline */ call for_illumination_only; hdr4 (10): /* new line - store final arg symbol */ hdr4 (17): /* semicolon is sort of like newline */ right_arg_symbol = lexeme; go to look_for_local_var_dcls; /* HEADER 5 LOOP BEGINS HERE */ hdr5 (11): hdr5 (17): /* skip extraneous blanks and semicolons */ char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; look_for_local_var_dcls: /* enter here with chr = SemiColon or NewLine */ go to hdr5 (char_type (chr)); hdr5 (9): /* lamp - skip over comment and turn into NewLine */ call for_illumination_only; hdr5 (10): /* newline - this ends the header line */ statement_map_ptr = addr (MY.localized_symbols (number_of_localized_symbols + 1)); go to start_line; /* this is probably the right place to join with the apl_line_lex_ code */ hdr5 (1): hdr5 (2): hdr5 (3): /* seen the beginning of a name - this is a localized variable */ call parse_name_in_header_line; number_of_localized_symbols = number_of_localized_symbols + 1; MY.localized_symbols (number_of_localized_symbols) = lexeme; nugatory_system_variable_localization: /* abnormal exit from call to parse_name_in_header_line */ go to hdr5 (char_type (chr)); /*** routine to gobble up a name in the header line. Similar to the one for names everwhere else ***/ parse_name_in_header_line: proc; name_buffer_ptr = addr (MY.localized_symbols (number_of_localized_symbols + 1)); /* first free loc on parse stack */ name_index = 0; hnm (1): hnm (2): hnm (5): name_buffer_array (name_index) = chr; name_index = name_index + 1; char_count = char_count + 1; if char_count = 0 then go to unexpected_end_of_text; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; go to hnm (char_type (chr)); hnm (0): hnm (3): hnm (4): hnm (6): hnm (7): hnm (8): hnm (9): hnm (10): hnm (11): hnm (12): hnm (13): hnm (14): hnm (15): hnm (16): hnm (17): hnm (18): hnm (19): hnm (20): hnm (21): hnm (22): hnm (23): /* char found that's not allowed in name. name has ended. our caller will figure out what to do with chr */ if name_buffer_array (0) = Quad then do; /* localization of system variable is only case that can come here */ do n = lbound (system_names, 1) to hbound (system_names, 1); if system_names (n) = name_buffer then do; if ^operator_bead_table (op_index (n)).system_variable then go to barf_at_bad_localization; /** localizing system variable, put pointer to operator bead **/ if operator_bead_table (op_index (n)).ignores_assignment then go to nugatory_system_variable_localization; /* take abnormal exit if trivial */ lexeme = addr (operator_bead_table (op_index (n))); return; end; end; go to barf_at_bad_localization; end; else if a_bad_lexeme_index ^= 0 then lexeme = null; else call apl_get_symbol_ (name_buffer, lexeme, (0)); /* don't worry about quad names, stop-trace control, etc. */ return; end parse_name_in_header_line; /*** lamp munger ***/ for_illumination_only: proc; /* this proc changes Lamp into NewLine */ do while (chr ^= NewLine); char_count = char_count + 1; if char_count = 0 then if esw = apl_execute_lex_ then chr = NewLine; else go to unexpected_end_of_text; else do; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; end; end; end for_illumination_only; dcl data_elements fixed bin static init (0); /* just to satisfy GGB's include file */ /***** simple lexer for use of outside world *****/ apl_scan_: entry (text, initial_scan_pos, scan_pos, scan_length, token_type, scan_number_ptr_structure); /* dcl text char(*) aligned; */ dcl initial_scan_pos fixed bin (21), /* (Input) where to start looking at text */ scan_pos fixed bin (21), /* (Output) index of first char of token */ scan_length fixed bin (21), /* (Output) number of characters in token */ token_type fixed bin, /* (Output) 0=no token found, 1=random char, 2= name, 3 = positive integer, 4 = some random number */ 1 scan_number_ptr_structure aligned, /* (Input) null or pointer to place to put number if token_type>=3 */ 2 scan_number_ptr pointer unaligned; dcl editor_scan bit (1) aligned; editor_scan = "0"b; go to scan_begin; apl_editor_scan_: entry (text, initial_scan_pos, scan_pos, scan_length, token_type, scan_number_ptr_structure); editor_scan = "1"b; scan_begin: esw = apl_scan_; char_index = initial_scan_pos - 1; char_count = -length (text) - 2 + initial_scan_pos; token_type = 0; scan_length = 0; /* assuming will find no token */ /* skip leading blanks */ scan0 (11): scan0 (10): char_count = char_count + 1; if char_count = 0 then go to scan_end; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if editor_scan & chr = Delta then i = 14; /* Make Delta a token by itself */ else i = char_type (chr); /* Normal case (Delta is an alphabetic */ go to scan0 (i); scan0 (1): scan0 (2): /* scan a name */ token_type = 2; scan_pos = char_index; scanm (1): scanm (2): scanm (5): char_count = char_count + 1; if char_count = 0 then do; scan_length = char_index - scan_pos + 1; return; end; chr = fixed (unspec (substr (text, char_index + 1, 1)), 9); char_index = char_index + 1; if editor_scan & chr = Delta then i = 14; /* Make Delta a token by itself */ else i = char_type (chr); /* Normal case (Delta is an alphabetic */ go to scanm (i); scanm (0): scanm (3): scanm (4): scanm (6): scanm (7): scanm (8): scanm (9): scanm (10): scanm (11): scanm (12): scanm (13): scanm (14): scanm (15): scanm (16): scanm (17): scanm (18): scanm (19): scanm (20): scanm (21): scanm (22): scanm (23): scan_length = char_index - scan_pos; return; /* number scanning */ scan0 (5): token_type = 3; scan_pos = char_index; go to start_number; scan0 (6): token_type = 4; scan_pos = char_index; go to start_negative_number; scan0 (7): token_type = 4; scan_pos = char_index; go to start_number_with_decimal_point; end_number_scan: /* return here when done with number */ if scan_number_ptr ^= null then scan_number_ptr -> numeric_datum (0) = apl_number; scan_length = char_index - scan_pos; if char_count >= 0 then scan_length = scan_length + 1; /* char_index was not bumped for the pseudo NewLine supplied at end of text */ return; /* come here when random character is encountered while scanning */ scan0 (3): scan0 (0): scan0 (4): scan0 (8): scan0 (9): scan0 (12): scan0 (13): scan0 (14): scan0 (15): scan0 (16): scan0 (17): scan0 (18): scan0 (19): scan0 (20): scan0 (21): scan0 (22): scan0 (23): token_type = 1; scan_length = 1; /* random char is token by itself */ scan_pos = char_index; return; /* come here when end of text is reached by scan */ scan_end: if token_type >= 3 then go to end_number_scan; scan_pos = char_index; return; /* rest has already been set up (for no token) */ /**** put apl_canonicalize_line_ here sometime when I feel like writing it ****/ end /* apl_lex_ */;  apl_load_command_.pl1 11/29/83 1637.3r w 11/29/83 1346.6 252909 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Procedure to )LOAD an APL workspace. Richard S. Lamson, August 1973. Artificial respiration and external heart massage applied 10/9/73, by PG Modified for Version 3 workspaces by PG, 12/4/73 Modified 740430 by PG for )COPY and )PCOPY Modified 740621 by PG to fix loading of boolean values and alignment of numeric values Modified 741010 by PG to check for zero-length refer, to check for copying into pendent function, to fix "not copied" msg, and to use new names. Modified 741119 by PG to fix )COPY to push a save frame first. Modified 750723 by PG to not load width, check for non-symbol beads in load_symbol, and enable loading of localized variables. Modified 761011 by PG to use new parse_frame declaration, and be able to load both version 3 and version 4 (new saved_pf declaration) workspaces. Modified 780523 by William York to let apl_storage_manager_ handle storage allocation by itself, with no unnecessary help from the load command. Modified 780901 by PG to fix 329 (apl refuses to enter apl if continue workspace is locked!). Modified 781220 by PG to fix 330 (load and copy didn't terminate segments), and 226 (poor error msgs). Modified 790131 by PG to fix 351 (copy didn't ignore symbols with no meaning, thus clobbering existing symbols). Modified 790814 by PG to fix 412 (load didn't set function_bead.lexed_function_bead_ptr for functions on the SI, and load_bead didn't update loaded_bead_table for anything!) modified 811210 by TO to use APL search paths. */ apl_load_command_: procedure (bv_wsid, bv_lock, bv_code); /* program */ autoload = "0"b; go to join; apl_load_command_$autoload: entry (bv_wsid, bv_lock, bv_code); autoload = "1"b; join: fcbp = null; loaded_bead_table_pointer = null; on cleanup call clean_up; /* give back our temp seg. */ call initialize_load_command (bv_code); if bv_code ^= 0 then do; if ^(autoload & bv_wsid = "continue" & bv_code = error_table_$noentry) then do; call convert_status_code_ (bv_code, short_msg, long_msg); call ioa_$ioa_switch (apl_static_$apl_output, "apl: ^a ^a^[>^]^a", long_msg, dname, (dname ^= ">" & ename ^= ""), ename); end; if autoload then bv_code = apl_error_table_$cant_autoload; call clean_up; return; end; /* The following values are session parameters, not workspace parameters, and hence do not get cleared or loaded: tabs, width, check mode, error mode, and everything in ws_info.switches. */ call apl_clear_workspace_; ws_info.digits = saved_ws_info.digits; ws_info.index_origin = saved_ws_info.index_origin; ws_info.random_link = saved_ws_info.random_link; ws_info.fuzz = saved_ws_info.fuzz; ws_info.float_index_origin = saved_ws_info.float_index_origin; ws_info.integer_fuzz = saved_ws_info.integer_fuzz; ws_info.lock = saved_ws_info.lock; ws_info.wsid = bv_wsid; saved_symbol_count = saved_ws_info.number_of_symbols; do symbol_number = 1 to saved_symbol_count; call load_symbol (symbol_number); end; do symbol_number = 1 to saved_symbol_count; loaded_bead_pointer (symbol_number) -> symbol_bead.meaning_pointer = load_bead (loaded_bead_pointer (symbol_number) -> symbol_bead.meaning_pointer -> saved_sb.meaning_pointer) ; end; /* meaning_pointer points to saved copy of symbol_bead (set by load_symbol) */ ws_info.latent_expression = load_bead (saved_ws_info.latent_expression); parse_frame_ptr = ws_info.current_parse_frame_ptr; previous_frame_pointer = null; do saved_frame_pointer = un_pseudo_pointer (saved_ws_info.current_parse_frame_ptr) repeat (un_pseudo_pointer (saved_pf.last_parse_frame_ptr)) while (saved_frame_pointer ^= null); parse_frame.last_parse_frame_ptr = previous_frame_pointer; parse_frame.parse_frame_type, frame_type = saved_pf.parse_frame_type; go to load_frame (frame_type); load_frame (5): /* SAVE FRAME */ parse_frame_ptr -> save_frame.saved_symbol_count, symbol_count = saved_sf.saved_symbol_count; do symbol_number = 1 to symbol_count; parse_frame_ptr -> save_frame.symbol_pointer (symbol_number) = load_bead (saved_sf.symbol_pointer (symbol_number)); parse_frame_ptr -> save_frame.saved_meaning_pointer (symbol_number) = load_bead (saved_sf.saved_meaning_pointer (symbol_number)); parse_frame_ptr -> save_frame.global_meaning_pointer_pointer (symbol_number) = null; end; previous_frame_pointer = parse_frame_ptr; parse_frame_ptr = addr (parse_frame_ptr -> save_frame.symbol_pointer (symbol_count + 1)); go to next_frame; load_frame (1): /* SUSPENDED FRAME */ load_frame (3): /* EVALUATED FRAME */ if saved_ws_info.save_version = 3 then do; source_length, addr (parse_frame.old_meaning_ptrs (1)) -> suspended_source_length = addr (v3_saved_pf.old_meaning_ptrs (1)) -> suspended_source_length; addr (parse_frame.old_meaning_ptrs (2)) -> suspended_source = addr (v3_saved_pf.old_meaning_ptrs (2)) -> suspended_source; end; else do; /* v4 */ source_length, addr (parse_frame.old_meaning_ptrs (1)) -> suspended_source_length = addr (saved_pf.old_meaning_ptrs (1)) -> suspended_source_length; addr (parse_frame.old_meaning_ptrs (2)) -> suspended_source = addr (saved_pf.old_meaning_ptrs (2)) -> suspended_source; end; number_of_ptrs = divide (source_length + 3, 4, 21, 0) + 1; /* Top frame source is of form ")save xxx", or some sort of function call, in the case where the workspace has been saved during quad-input, or after an error. */ if saved_pf.re_lex_source = "0"b then do; parse_frame.lexed_function_bead_ptr = null; parse_frame.function_bead_ptr = null; go to copy_other_stuff; end; call apl_line_lex_ (addr (parse_frame.old_meaning_ptrs (2)) -> suspended_source, parse_frame.lexed_function_bead_ptr, errors_occurred, 0, (temporary_bead_pointer)); if errors_occurred then go to fatal_error; go to copy_other_stuff; load_frame (2): /* FUNCTION FRAME */ parse_frame.function_bead_ptr = load_bead (saved_pf.function_bead_ptr); call apl_function_lex_ (parse_frame.function_bead_ptr -> function_bead.text, bead_pointer, errors_occurred, 0, (temporary_bead_pointer)); if errors_occurred then go to fatal_error; parse_frame.lexed_function_bead_ptr = bead_pointer; parse_frame.function_bead_ptr -> function_bead.lexed_function_bead_pointer = bead_pointer; bead_pointer -> lexed_function_bead.reference_count = bead_pointer -> lexed_function_bead.reference_count + 1; number_of_ptrs = parse_frame.lexed_function_bead_ptr -> lexed_function_bead.number_of_localized_symbols; do symbol_number = 1 to number_of_ptrs; /* load old meanings of localized symbols */ if saved_ws_info.save_version = 3 then temp_symbol = v3_saved_pf.old_meaning_ptrs (symbol_number); else temp_symbol = saved_pf.old_meaning_ptrs (symbol_number); parse_frame.old_meaning_ptrs (symbol_number) = load_bead (temp_symbol); end; go to copy_other_stuff; load_frame (4): /* EXECUTE FRAME */ /*** reductions_pointer = ????? */ bead_pointer = reduction_stack (parseme_count - 2).semantics; data_elements = bead_pointer -> value_bead.total_data_elements; call apl_execute_lex_ (bead_pointer -> value_bead.data_pointer -> character_string_overlay, parse_frame.lexed_function_bead_ptr, errors_occurred, 0, (temporary_bead_pointer)); if errors_occurred then go to fatal_error; number_of_ptrs = 0; copy_other_stuff: reductions_pointer = addrel (parse_frame_ptr, size (parse_frame)); if saved_ws_info.save_version = 3 then saved_reductions_pointer = addr (v3_saved_pf.old_meaning_ptrs (number_of_ptrs + 1)); else saved_reductions_pointer = addr (saved_pf.old_meaning_ptrs (number_of_ptrs + 1)); parse_frame.reduction_stack_ptr = reductions_pointer; parseme_count, parse_frame.current_parseme = saved_pf.current_parseme; parse_frame.current_lexeme = saved_pf.current_lexeme; parse_frame.current_line_number = saved_pf.current_line_number; if saved_pf.return_point = 0 /* gone...but equivalent to another point */ then parse_frame.return_point = 8; else parse_frame.return_point = saved_pf.return_point; parse_frame.put_result = saved_pf.put_result; parse_frame.print_final_value = saved_pf.print_final_value; parse_frame.initial_value_stack_ptr = ws_info.value_stack_ptr; parse_frame.number_of_ptrs = number_of_ptrs; do reduction_number = 1 to parseme_count; reduction_stack.type (reduction_number), reduction_type = saved_rs (reduction_number).type; unspec (reduction_stack (reduction_number).bits) = unspec (saved_rs (reduction_number).bits); load_this_one = "0"b; if reduction_type = op_type then if reduction_stack (reduction_number).function | reduction_stack (reduction_number).has_list then load_this_one = "1"b; else if reduction_stack (reduction_number).semantics_valid then reduction_stack_for_op (reduction_number).semantics = saved_rs_for_op (reduction_number).semantics; else ; else load_this_one = "1"b; if load_this_one then do; if reduction_stack (reduction_number).semantics_valid then if reduction_stack (reduction_number).semantics_on_stack then reduction_stack (reduction_number).semantics = load_bead_on_stack (saved_rs (reduction_number).semantics); else reduction_stack (reduction_number).semantics = load_bead (saved_rs (reduction_number).semantics); end; reduction_stack (reduction_number).lexeme = saved_rs (reduction_number).lexeme; end; previous_frame_pointer = parse_frame_ptr; parse_frame_ptr = addr (reduction_stack (parseme_count + 1)); next_frame: end; ws_info.current_parse_frame_ptr = previous_frame_pointer; call apl_destroy_save_frame_; call clean_up; non_local_return: return; fatal_error: call clean_up; call apl_system_error_ (apl_error_table_$cant_load_ws); return; apl_copy_command_: entry (bv_wsid, bv_lock, bv_protected, bv_names, bv_number_of_names, bv_code); /* parameters */ declare ( bv_protected bit (1) aligned, bv_number_of_names fixed bin, bv_names char (*) dim (*) ) parameter; /* program */ not_found = ""; not_copied = ""; fcbp = null; loaded_bead_table_pointer = null; autoload = "0"b; on cleanup call clean_up; call initialize_load_command (bv_code); if bv_code ^= 0 then do; call convert_status_code_ (bv_code, short_msg, long_msg); call ioa_$ioa_switch (apl_static_$apl_output, "apl: ^a ^a^[>^]^a", long_msg, dname, (dname ^= ">" & ename ^= ""), ename); call clean_up; return; end; call apl_create_save_frame_ (); saved_symbol_count = saved_ws_info.number_of_symbols; if bv_number_of_names = 0 then do; /* copy all names */ do symbol_index = 1 to saved_symbol_count; symbol_pointer = un_pseudo_pointer (bead_description_table (symbol_index).bead_pointer); if symbol_pointer -> saved_general_bead.type.symbol then if symbol_pointer -> saved_sb.meaning_pointer ^= 0 /* ignore if no meaning */ then call copy (symbol_pointer); end; end; else do; /* selected copy */ do copy_index = 1 to bv_number_of_names; found = "0"b; do symbol_index = 1 to saved_symbol_count while (^found); symbol_pointer = un_pseudo_pointer (bead_description_table (symbol_index).bead_pointer); if symbol_pointer -> saved_general_bead.type.symbol then if symbol_pointer -> saved_sb.meaning_pointer ^= 0 /* ignore if no meaning */ then if bv_names (copy_index) = symbol_pointer -> saved_sb.name then do; call copy (symbol_pointer); found = "1"b; end; end; if ^found then call not_found_ (before (bv_names (copy_index), " ")); end; end; if length (not_found) ^= 0 then do; not_found = not_found || nl; call iox_$put_chars (apl_static_$apl_output, addrel (addr (not_found), 1), length (not_found), code); end; if length (not_copied) ^= 0 then do; not_copied = not_copied || nl; call iox_$put_chars (apl_static_$apl_output, addrel (addr (not_copied), 1), length (not_copied), code); end; call apl_destroy_save_frame_update_; call clean_up; return; initialize_load_command: procedure (bv_code); /* parameters */ dcl bv_code fixed bin (35) parameter; /* program */ call apl_translate_pathname_$use_search_paths (bv_wsid, dname, ename, fcbp, bv_code); if bv_code ^= 0 then do; dname = bv_wsid; /* setup for error msg printer. */ ename = ""; return; end; if ws_info.restrict_load_directory then if dname ^= get_wdir_ () then do; bv_code = apl_error_table_$ws_dir_restricted; return; end; call msf_manager_$get_ptr (fcbp, 0, "0"b, ws_segment (0), (0), bv_code); if ws_segment (0) = null then return; saved_ws_info_pointer = ws_segment (0); do component = 1 to saved_ws_info.highest_segment; call msf_manager_$get_ptr (fcbp, component, "0"b, ws_segment (component), (0), bv_code); if ws_segment (component) = null then return; end; if saved_ws_info.save_version < 3 | saved_ws_info.save_version > 4 then do; bv_code = apl_error_table_$ws_wrong_version; return; end; if saved_ws_info.lock ^= bv_lock then do; bv_code = apl_error_table_$ws_locked; return; end; call ioa_$ioa_switch (apl_static_$apl_output, "saved ^a", apl_date_time_ (saved_ws_info.time_saved)); bead_description_pointer = un_pseudo_pointer (saved_ws_info.bead_table_pointer); loaded_bead_table_pointer = apl_segment_manager_$get (); temporary_bead_pointer = addrel (loaded_bead_table_pointer, saved_ws_info.total_beads); bv_code = 0; do bead_number = 1 to saved_ws_info.total_beads; loaded_bead_pointer (bead_number) = null; end; return; end /* initialize_load_command */; clean_up: procedure; if loaded_bead_table_pointer ^= null then do; call apl_segment_manager_$free (loaded_bead_table_pointer); loaded_bead_table_pointer = null; end; if fcbp ^= null then do; call msf_manager_$close (fcbp); fcbp = null; end; return; end clean_up; not_copied_: procedure (name); /* parameters */ declare name char (*) parameter; /* program */ if length (not_copied) = 0 then not_copied = "not copied: "; if length (not_copied) + length (name) + 1 > ws_info.width then do; not_copied = not_copied || nl; call iox_$put_chars (apl_static_$apl_output, addrel (addr (not_copied), 1), length (not_copied), code); not_copied = "not copied: "; end; not_copied = not_copied || " "; not_copied = not_copied || name; return; end not_copied_; not_found_: procedure (name); /* parameters */ declare name char (*) parameter; /* program */ if length (not_found) = 0 then not_found = "not found: "; if length (not_found) + length (name) + 1 > ws_info.width then do; not_found = not_found || nl; call iox_$put_chars (apl_static_$apl_output, addrel (addr (not_found), 1), length (not_found), code); not_found = "not found: "; end; not_found = not_found || " "; not_found = not_found || name; return; end not_found_; copy: procedure (bv_symbol_pointer); /* parameters */ declare bv_symbol_pointer pointer unaligned parameter; /* automatic */ declare symbol_pointer pointer unaligned; /* program */ call apl_get_symbol_ (bv_symbol_pointer -> saved_sb.name, symbol_pointer, (0)); if symbol_pointer -> symbol_bead.meaning_pointer ^= null then do; if bv_protected then do; call not_copied_ (bv_symbol_pointer -> saved_sb.name); return; end; if symbol_pointer -> symbol_bead.meaning_pointer -> general_bead.function then if apl_pendant_function_check_ (symbol_pointer -> symbol_bead.meaning_pointer) then do; call not_copied_ (bv_symbol_pointer -> saved_sb.name); call apl_system_error_ (apl_error_table_$pendent_function_copied); end; call wash (symbol_pointer -> symbol_bead.meaning_pointer); end; symbol_pointer -> symbol_bead.meaning_pointer = copy_bead (bv_symbol_pointer -> saved_sb.meaning_pointer); /* Don't flush this symbol if this reference created it; otherwise be transparent & restore ref. ct. */ if symbol_pointer -> general_bead.reference_count > 1 then call wash (symbol_pointer); return; end copy; wash: procedure (bv_bead_pointer); /* parameters */ declare bv_bead_pointer pointer unaligned parameter; /* automatic */ declare bead_pointer pointer unaligned; /* program */ bead_pointer = bv_bead_pointer; bead_pointer -> general_bead.reference_count = bead_pointer -> general_bead.reference_count - 1; if bead_pointer -> general_bead.reference_count < 1 then call apl_free_bead_ (bead_pointer); return; end wash; un_pseudo_pointer: procedure (bv_bead_pointer) returns (pointer unaligned); bead_pointer = bv_bead_pointer; if bead_pointer = null then return (null); else return (addrel (ws_segment (fixed (baseno (bead_pointer), 18)), rel (bead_pointer))); declare (bv_bead_pointer, bead_pointer) pointer unaligned; end un_pseudo_pointer; load_symbol: procedure (bv_bead_number); bead_number = bv_bead_number; if bead_number = 0 then return; if loaded_bead_pointer (bead_number) ^= null then do; loaded_bead_pointer (bead_number) -> general_bead.reference_count = loaded_bead_pointer (bead_number) -> general_bead.reference_count + 1; return; end; saved_bead_pointer = un_pseudo_pointer (bead_description_table (bead_number).bead_pointer); if ^saved_bead_pointer -> saved_general_bead.symbol then do; call apl_system_error_ (apl_error_table_$cant_load_ws); go to non_local_return; end; call apl_get_symbol_ (saved_bead_pointer -> saved_sb.name, bead_pointer, (0)); bead_pointer -> symbol_bead.meaning_pointer = saved_bead_pointer; loaded_bead_pointer (bead_number) = bead_pointer; return; declare (bead_pointer, saved_bead_pointer) pointer unaligned; declare (bv_bead_number, bead_number) fixed binary (21); end load_symbol; copy_bead: load_bead: procedure (bv_bead_number) returns (pointer unaligned); /* parameters */ declare bv_bead_number fixed bin (21); /* automatic */ declare loading_on_stack bit (1) aligned; declare bead_pointer ptr unaligned; declare (saved_data_pointer, into_pointer, sb) ptr; declare bead_number fixed bin (21), (symbol_number, member_number) fixed bin, datum_number fixed bin (24); /* program */ loading_on_stack = "0"b; go to common; load_bead_on_stack: entry (bv_bead_number) returns (pointer unaligned); loading_on_stack = "1"b; common: bead_number = bv_bead_number; if bead_number <= 0 /* <0 means system error, actually. */ then return (null); if loaded_bead_pointer (bead_number) ^= null then do; loaded_bead_pointer (bead_number) -> general_bead.reference_count = loaded_bead_pointer (bead_number) -> general_bead.reference_count + 1; return (loaded_bead_pointer (bead_number)); end; sb = un_pseudo_pointer (bead_description_table (bead_number).bead_pointer); go to copy_in_bead (index (string (sb -> saved_general_bead.type), "1"b)); copy_in_bead (5): /* GROUP BEAD */ call allocate; bead_pointer -> group_bead.number_of_members = sb -> saved_gb.number_of_members; do symbol_number = 1 to bead_pointer -> group_bead.number_of_members; bead_pointer -> group_bead.member (symbol_number) = load_bead (sb -> saved_gb.member (symbol_number)); end; go to end_case; copy_in_bead (2): /* SYMBOL BEAD */ call load_symbol (bead_number); loaded_bead_pointer (bead_number) -> symbol_bead.meaning_pointer = load_bead (loaded_bead_pointer (bead_number) -> symbol_bead.meaning_pointer -> saved_sb.meaning_pointer); return (loaded_bead_pointer (bead_number)); copy_in_bead (4): /* FUNCTION BEAD */ call allocate; bead_pointer -> function_bead.class = sb -> saved_fb.class; bead_pointer -> function_bead.text_length = sb -> saved_fb.text_length; bead_pointer -> function_bead.stop_control_pointer = load_bead (sb -> saved_fb.stop_control_pointer); bead_pointer -> function_bead.trace_control_pointer = load_bead (sb -> saved_fb.trace_control_pointer); bead_pointer -> function_bead.text = sb -> saved_fb.text; bead_pointer -> function_bead.lexed_function_bead_pointer = null; go to end_case; copy_in_bead (9): /* LIST BEAD */ call stack_allocate; bead_pointer -> list_bead.number_of_members = sb -> saved_lb.number_of_members; do member_number = 1 to bead_pointer -> list_bead.number_of_members; unspec (bead_pointer -> list_bead.bits (member_number)) = unspec (sb -> saved_lb.bits (member_number)); if bead_pointer -> list_bead.bits (member_number).semantics_on_stack then bead_pointer -> list_bead.member_ptr (member_number) = load_bead_on_stack (sb -> saved_lb.member_ptr (member_number)); else bead_pointer -> list_bead.member_ptr (member_number) = load_bead (sb -> saved_lb.member_ptr (member_number)); end; go to end_case; copy_in_bead (3): /* VALUE BEADS */ call allocate; number_of_dimensions, bead_pointer -> value_bead.rhorho = sb -> saved_value_bead.rhorho; if bead_pointer -> value_bead.rhorho > 0 then bead_pointer -> value_bead.rho (*) = sb -> saved_value_bead.rho (*); data_elements, bead_pointer -> value_bead.total_data_elements = sb -> saved_value_bead.total_data_elements; into_pointer = addrel (bead_pointer, size (value_bead)); if bead_pointer -> value_bead.numeric_value then if substr (rel (into_pointer), 18, 1) then into_pointer = addrel (into_pointer, 1); bead_pointer -> value_bead.data_pointer = into_pointer; saved_data_pointer = pointer (sb, rel (sb -> saved_value_bead.data_pointer)); if bead_pointer -> value_bead.character_value then into_pointer -> character_string_overlay = saved_data_pointer -> character_string_overlay; else if string (bead_pointer -> value_bead.type) = zero_or_one_value_type then do; do datum_number = 0 by 1 while (datum_number < data_elements); if substr (saved_data_pointer -> saved_boolean_datum, datum_number + 1, 1) = "1"b then into_pointer -> numeric_datum (datum_number) = 1e0; else into_pointer -> numeric_datum (datum_number) = 0e0; end; end; else into_pointer -> numeric_datum (*) = saved_data_pointer -> numeric_datum (*); end_case: loaded_bead_pointer (bead_number) = bead_pointer; return (bead_pointer); copy_in_bead (0): copy_in_bead (1): copy_in_bead (6): copy_in_bead (7): copy_in_bead (8): copy_in_bead (10): copy_in_bead (11): copy_in_bead (12): copy_in_bead (13): copy_in_bead (14): copy_in_bead (15): copy_in_bead (16): copy_in_bead (17): copy_in_bead (18): call apl_system_error_ (apl_error_table_$cant_load_ws); go to non_local_return; /* pseudo-function used by load_bead to allocate space for each bead in either the stack or heap. */ allocate: procedure; declare allocate_on_stack bit (1) aligned; allocate_on_stack = loading_on_stack; go to common; stack_allocate: entry; allocate_on_stack = "1"b; common: n_words = fixed (sb -> saved_general_bead.size, 18, 0); /* the size was normalized to eleminate any padding words for value beads...add 1 back so we can safely double-word align the numbers. */ if sb -> saved_general_bead.value then n_words = n_words + 1; if allocate_on_stack then bead_pointer = apl_push_stack_ (n_words); else call apl_allocate_words_ (n_words, bead_pointer); string (bead_pointer -> general_bead.type) = string (sb -> saved_general_bead.type); bead_pointer -> general_bead.reference_count = 1; return; %include apl_push_stack_fcn; end allocate; end load_bead; /* builtins */ declare (addr, addrel, baseno, before, divide, fixed, index, length, null, pointer, substr, rel, size, string, unspec) builtin; /* entries */ declare apl_date_time_ entry (fixed bin (71)) returns (char (17)); declare apl_pendant_function_check_ entry (ptr unal) returns (bit (1) aligned); declare apl_system_error_ entry (fixed bin (35)); declare apl_allocate_words_ entry (fixed bin (19), pointer unaligned); declare apl_get_symbol_ entry (char (*), pointer unaligned, fixed bin); declare apl_create_save_frame_ entry (); declare (apl_destroy_save_frame_, apl_destroy_save_frame_update_) entry (); declare apl_free_bead_ entry (pointer unaligned); declare apl_translate_pathname_$use_search_paths entry (char (*), char (*), char (*), pointer, fixed bin (35)); declare apl_segment_manager_$get entry () returns (pointer); declare apl_segment_manager_$free entry (pointer); declare (apl_line_lex_, apl_function_lex_, apl_execute_lex_) entry (char (*) aligned, pointer unaligned, bit (1) aligned, fixed bin, pointer); declare apl_clear_workspace_ entry (); declare convert_status_code_ entry (fixed bin (35), char (8), char (100)); declare get_wdir_ entry () returns (char (168) aligned); declare ioa_$ioa_switch entry options (variable); declare iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); declare msf_manager_$close entry (ptr); declare msf_manager_$get_ptr entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)); /* conditions */ declare cleanup condition; /* automatic */ declare autoload bit (1) aligned; declare code fixed bin (35); declare dname char (168), ename char (32); declare long_msg char (100), short_msg char (8); declare (not_found, not_copied) char (150) aligned varying; declare (errors_occurred, found, load_this_one) bit (1) aligned; declare ( temporary_bead_pointer unaligned, loaded_bead_table_pointer ) pointer; declare ws_segment dimension (0:63) pointer aligned; declare (previous_frame_pointer, parse_frame_ptr, bead_pointer, symbol_pointer) pointer unaligned; declare fcbp pointer; declare (saved_symbol_count, frame_type, symbol_count, source_length, symbol_index, copy_index, data_elements, parseme_count, reduction_number, reduction_type, component) fixed bin; declare n_words fixed bin (19); declare (bead_number, symbol_number, temp_symbol) fixed bin (21); /* internal static initial */ declare nl char (1) aligned internal static initial (" "); /* based */ declare loaded_bead_pointer dimension (1) pointer unaligned based (loaded_bead_table_pointer); declare suspended_source_length fixed binary (29) aligned based; declare suspended_source character (source_length) based aligned; /* parameters */ declare (bv_wsid, bv_lock) char (*) unaligned; declare bv_code fixed bin (35); /* external static */ declare (apl_error_table_$cant_autoload, apl_error_table_$cant_load_ws, apl_error_table_$pendent_function_copied, apl_error_table_$ws_dir_restricted, apl_error_table_$ws_locked, apl_error_table_$ws_wrong_version, error_table_$noentry) fixed bin (35) external static; declare apl_static_$apl_output ptr external static; /* include files */ %include apl_number_data; %include apl_ws_info; %include apl_bead_format; %include apl_operator_bead; %include apl_symbol_bead; %include apl_value_bead; %include apl_list_bead; %include apl_function_bead; %include apl_lexed_function_bead; %include apl_group_bead; %include apl_parse_frame; %include apl_save_frame; %include apl_saved_ws; end /* apl_load_command_ */; */ ----------------------------------------------------------- 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 */