



		    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\<SCALAR> */
		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;
						/* <NL><CNL> 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<colx & j<pivot_col);
		     z = z-LU (permute (colx), j)*LU (permute (j), pivot_col);
		end;
		LU (permute (colx), pivot_col) = z;
	     end;

/*  search for the next pivot  */

	     pivot = LU (permute (pivot_col), pivot_col);
	     pivot_row = pivot_col;
	     do j = pivot_col+1 by 1 while (j <= U);
		if abs (LU (permute (j), pivot_col)) > 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

*/
