



		    apl_coded_.pl1                  11/29/83  1645.8r w 11/29/83  1645.8      178857



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
apl_coded_: procedure (operators_argument);

/* Adapted from apl_coded_file_routines_ by Mike Bonham, 80-02-15 */
/* Modified 81-12-21 by H. Hoover to tidy up. */
/* Modified 83-11-21 by A. Dewar to change handling of long_record error, */
/*     to continue untie loop until entire vector tried, */
/*     to use pathname_$component_check to construct absolute pathnames. */

/* external static */

dcl  apl_error_table_$domain fixed bin (35) ext,
     apl_error_table_$length fixed bin (35) ext,
     apl_error_table_$rank fixed bin (35) ext,
     apl_error_table_$system_error fixed bin (35) ext,
     error_table_$end_of_info fixed bin (35) ext,
     error_table_$long_record fixed bin (35) ext,
     error_table_$noentry fixed bin (35) ext,
     error_table_$short_record fixed bin (35) ext;

/* entries */

dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
     ioa_ entry options (variable),
     iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)),
     iox_$close entry (ptr, fixed bin (35)),
     iox_$detach_iocb entry (ptr, fixed bin (35)),
     iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
     iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)),
     iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)),
     pathname_$component_check entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     unique_chars_ entry (bit (*)) returns (char (15));

/* builtins */

dcl  addrel builtin,
     ceil builtin,
     hbound builtin,
     lbound builtin,
     ltrim builtin,
     null builtin,
     rel builtin,
     rtrim builtin,
     size builtin,
     string builtin,
     substr builtin;

/* internal static */

dcl 1 tcb (100) aligned internal static,
    2 iocb_ptr ptr init ((100) null),
    2 switch char (15) unaligned,
    2 eof bit (1) init ((100) (1)"0"b);

dcl  max_line_length fixed bin internal static options (constant) init (256),
     time_iofns_invoked fixed bin (71) internal static init (0);

/* automatic */

dcl  attach_desc char (256),
     b_ptr ptr,
     buf_line_ptr ptr,
     code fixed bin (35),
     data_elements fixed bin (21),
     file_dname char (168),
     file_ename char (32),
     file_pathname char (168),
     file_tie_error_occurred bit (1),
     left ptr,
     left_vb ptr,
     lines_read fixed bin,
     longest fixed bin,
     message char (100) aligned,
     n_read fixed bin (21),
     n_words fixed bin (19),
     no_of_lines fixed bin,
     pos_request_type fixed bin,
     pos_skip_count fixed bin (21),
     record_length fixed bin (21),
     result ptr,
     result_vb ptr,
     right ptr,
     right_vb ptr,
     subscript fixed bin (21),
     tcbx fixed bin,
     tie_num fixed bin;

/* based */

dcl  buffer (no_of_lines) char (max_line_length) based (b_ptr) init ((no_of_lines) (1)" "),
     minimum_buffer (lines_read) char (longest) based;

/* 'file_name' CREATE file_number */

create:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;
	call decode_file_id;
	call decode_tie_num;

	call hcs_$status_minf (file_dname, file_ename, 1, (0), (0), code);
	if code ^= error_table_$noentry		/* If file already exists... */
	then goto file_name_error;

	if operators_argument.operands (2).on_stack	/* Pop input args, if necessary */
	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 open_file;
	return;

/* R -< EOF file-number-vector

   Returns bit_vector of 'end-of-file status' for all files specified */

eof:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	right_vb = operators_argument.operands (2).value;

	if ^right_vb -> general_bead.value
	then go to domain_error_right;

	if ^right_vb -> value_bead.numeric_value
	then go to domain_error_right;

	if (right_vb -> value_bead.total_data_elements > 1) & (right_vb -> value_bead.rhorho ^= 1)
	then go to rank_error_right;

/* Temporarily insist that args must be integers */

	if ^right_vb -> value_bead.integral_value
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;

	data_elements = right_vb -> value_bead.total_data_elements;
	if operators_argument.on_stack (2)
	then do;					/*  Overlay result on right arg.  */
	     result_vb = right_vb;
	     string (result_vb -> value_bead.type) = zero_or_one_value_type;
	     result = right;
	end;
	else do;					/*  Allocate result of same shape as right arg.  */
	     number_of_dimensions = 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) = zero_or_one_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;
	     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;
	end;

	do subscript = 0 by 1 while (subscript < right_vb -> value_bead.total_data_elements);
	     tie_num = right -> numeric_datum (subscript);

	     if tcb.iocb_ptr (tie_num) ^= null
	     then
		if tcb.eof (tie_num)
		then result -> numeric_datum (subscript) = 1;
		else result -> numeric_datum (subscript) = 0;
	     else goto file_tie_error;
	end;

	operators_argument.result = result_vb;
	return;

/* R -< NUMS

   Returns a numeric vector holding the file numbers of all tied files.
*/

nums:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	data_elements = 0;				/* Count number of open files */
	do tcbx = lbound (tcb, 1) to hbound (tcb, 1);
	     if tcb.iocb_ptr (tcbx) ^= null
	     then data_elements = data_elements + 1;
	end;

	number_of_dimensions = 1;			/* Get size of result bead */
	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; /* Fill in result bead */
	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));
	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);

	result_vb -> value_bead.data_pointer = result;

	subscript = -1;				/* Fill in vector of file numbers */
	do tcbx = lbound (tcb, 1) to hbound (tcb, 1);
	     if tcb.iocb_ptr (tcbx) ^= null
	     then do;
		subscript = subscript + 1;
		result -> numeric_datum (subscript) = tcbx;
	     end;
	end;

	operators_argument.result = result_vb;
	return;

/* position-code [,skip-count] POSITION file-number */

position:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	call decode_tie_num;
	if tcb.iocb_ptr (tie_num) = null
	then goto file_not_tied;
	left_vb = operators_argument (1).value;
	if ^left_vb -> general_bead.value then goto domain_error_left;
	if ^left_vb -> value_bead.integral_value then goto domain_error_left;
	data_elements = left_vb -> value_bead.total_data_elements;
	if data_elements < 1 | data_elements > 2
	then goto length_error_left;

	left = left_vb -> value_bead.data_pointer;
	pos_request_type = left -> numeric_datum (0);
	if data_elements < 2
	then pos_skip_count = 1;
	else pos_skip_count = left -> numeric_datum (1);

	if operators_argument (2).on_stack then ws_info.value_stack_ptr = right_vb;
	else if operators_argument (1).on_stack then ws_info.value_stack_ptr = left_vb;

	if (pos_request_type < -1) | (pos_request_type > 3) then goto domain_error_left;
	call iox_$position (tcb.iocb_ptr (tie_num), pos_request_type, pos_skip_count, code);
	if code = 0
	then if pos_request_type = 1
	     then tcb.eof (tie_num) = "1"b;
	     else tcb.eof (tie_num) = "0"b;
	else if code = error_table_$end_of_info
	then if pos_skip_count > 0
	     then tcb.eof (tie_num) = "1"b;
	     else tcb.eof (tie_num) = "0"b;
	else goto position_out_of_bounds;
	operators_argument.result = null;
	return;

/* R <- no_of_lines READ file_number */

read:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	call decode_tie_num;
	if tcb.iocb_ptr (tie_num) = null then goto file_not_tied;
	left_vb = operators_argument (1).value;
	if left_vb = null then no_of_lines = 1;
	else do;
	     if ^left_vb -> general_bead.value then goto domain_error_left;
	     if ^left_vb -> value_bead.integral_value then goto domain_error_left;
	     if left_vb -> value_bead.total_data_elements ^= 1 then goto length_error_left;
	     left = left_vb -> value_bead.data_pointer;
	     no_of_lines = left -> numeric_datum (0);
	     if no_of_lines < 1 then goto domain_error_left;
	end;
	if operators_argument (2).on_stack then ws_info.value_stack_ptr = right_vb;
	else if operators_argument (1).on_stack then ws_info.value_stack_ptr = left_vb;

	allocate buffer set (b_ptr);
	tcb.eof (tie_num) = "0"b;
	lines_read = 0;
	longest = 0;
	do subscript = 1 to no_of_lines while (^tcb.eof (tie_num));
	     buf_line_ptr = addrel (b_ptr, lines_read * ceil (max_line_length/4.0));
	     call iox_$get_line (tcb.iocb_ptr (tie_num), buf_line_ptr, (max_line_length), n_read, code);
	     if code = error_table_$long_record
	     then go to cant_read_record;
	     else if (code = error_table_$end_of_info)| (code = error_table_$short_record)
	     then tcb.eof (tie_num) = "1"b;
	     else if code = 0 then do;
		substr (buffer (lines_read + 1), n_read, 1) = " ";
		n_read = n_read -1;
	     end;
	     if n_read > longest then longest = n_read;
	     lines_read = lines_read + 1;
	end;

	if (lines_read = 1) & (longest = 0) then lines_read = 0;

/* allocate char_matrix bead with minimum dimension */
	if lines_read <= 1
	then number_of_dimensions = 1;
	else number_of_dimensions = 2;
	data_elements = lines_read * longest;
	n_words = size (value_bead) + ceil (data_elements / 4.0);
	result_vb = apl_push_stack_ (n_words);
	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) = lines_read;
	result_vb -> value_bead.rho (number_of_dimensions) = longest;
	result = addrel (result_vb, size (value_bead));
	result_vb -> value_bead.data_pointer = result;

	if longest > 0 then
	     do subscript = 1 to lines_read;
	     result -> minimum_buffer (subscript) = buffer (subscript);
	end;

	free buffer;
	operators_argument.result = result_vb;
	return;

/* REWIND file-number-vector

   Rewinds all files specified in the vector argument. */

rewind:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	right_vb = operators_argument.operands (2).value;

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;

	if ^right_vb -> general_bead.value
	then go to domain_error_right;

	if ^right_vb -> value_bead.numeric_value
	then go to domain_error_right;

	if (right_vb -> value_bead.total_data_elements > 1) & (right_vb -> value_bead.rhorho ^= 1)
	then go to rank_error_right;

/* Temporarily insist that args must be integers */

	if ^right_vb -> value_bead.integral_value
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;

	do subscript = 0 by 1 while (subscript < right_vb -> value_bead.total_data_elements);
	     tie_num = right -> numeric_datum (subscript);

	     if tcb.iocb_ptr (tie_num) ^= null
	     then do;
		call iox_$position (tcb.iocb_ptr (tie_num), -1, 0, code);
		tcb.eof (tie_num) = "0"b;
	     end;
	     else goto file_tie_error;
	end;

	operators_argument.result = null;
	return;

/* 'file_name' TIE file_number */

tie:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	call decode_file_id;
	call decode_tie_num;

	if operators_argument.operands (2).on_stack	/* Pop input args, if necessary */
	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 open_file;
	return;

/* UNTIE file-number-vector

   Unties all files specified in the vector argument. */

untie:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	right_vb = operators_argument.operands (2).value;

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;

	if ^right_vb -> general_bead.value
	then go to domain_error_right;

	if ^right_vb -> value_bead.numeric_value
	then go to domain_error_right;

	if (right_vb -> value_bead.total_data_elements > 1) & (right_vb -> value_bead.rhorho ^= 1)
	then go to rank_error_right;

/* Temporarily insist that args must be integers */

	if ^right_vb -> value_bead.integral_value
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;

	file_tie_error_occurred = "0"b;

	do subscript = 0 by 1 while (subscript < right_vb -> value_bead.total_data_elements);
	     tie_num = right -> numeric_datum (subscript);

	     if tcb.iocb_ptr (tie_num) ^= null
	     then do;
		call iox_$close (tcb.iocb_ptr (tie_num), code);
		call iox_$detach_iocb (tcb.iocb_ptr (tie_num), code);
		tcb.iocb_ptr (tie_num) = null;
	     end;
	     else file_tie_error_occurred = "1"b;
	end;

	if file_tie_error_occurred
	then go to file_tie_error;

	operators_argument.result = null;
	return;


/* 'char_string' WRITE file_number */

write:	entry (operators_argument);
	if time_iofns_invoked < ws_info.time_invoked then do;
	     call close_files;
	     time_iofns_invoked = ws_info.time_invoked;
	end;

	call decode_tie_num;

	if tcb.iocb_ptr (tie_num) = null
	then go to file_not_tied;


	left_vb = operators_argument (1).value;
	if ^left_vb -> value_bead.character_value then goto domain_error_left;

	if (left_vb -> value_bead.rhorho > 1) & (left_vb -> value_bead.total_data_elements > 1)
	then goto rank_error_left;

	if operators_argument (2).on_stack
	then ws_info.value_stack_ptr = right_vb;	/* pop arg off stack */
	else if operators_argument.operands (1).on_stack
	then ws_info.value_stack_ptr = left_vb;

	record_length = left_vb -> value_bead.total_data_elements;

	left = left_vb -> value_bead.data_pointer;
	call iox_$put_chars (tcb.iocb_ptr (tie_num), left, record_length, code);
	if code ^= 0 then goto cant_write_record;

	operators_argument.result = null;
	return;

already_tied:
	call ioa_ ("file ^d already tied", tie_num);
	go to system_error;

cant_attach:
	call expand_code;
	call ioa_ ("cant attach file: ^a", message);
	go to system_error;

cant_open:
	call expand_code;
	call ioa_ ("cant open file: ^a", message);
	go to system_error;

cant_read_record:
	call expand_code;
	call ioa_ ("cant read record: ^a", message);
	go to system_error;

cant_write_record:
	call expand_code;
	call ioa_ ("cant write record: ^a", message);

file_name_error:
	call ioa_ ("file name error");
	go to system_error;

file_not_tied:
	call ioa_ ("file ^d not tied", tie_num);
	go to system_error;

file_tie_error:
	call ioa_ ("file tie error");
	go to system_error;

position_out_of_bounds:
	call ioa_ ("position out of bounds.");
	goto system_error;





domain_error_left:
domain_error_right:
	operators_argument.error_code = apl_error_table_$domain;
	return;

length_error_left:
length_error_right:
	operators_argument.error_code = apl_error_table_$length;
	return;

rank_error_left:
rank_error_right:
	operators_argument.error_code = apl_error_table_$rank;
	return;

system_error:
	operators_argument.error_code = apl_error_table_$system_error;
	return;
%include apl_push_stack_fcn;
close_files: proc;
	     do subscript = 1 to 100;
		tcb.eof (subscript) = "0"b;
		tcb.switch (subscript) = "";
		if tcb.iocb_ptr (subscript) ^= null () then do;
		     call iox_$close (tcb.iocb_ptr (subscript), code);
		     call iox_$detach_iocb (tcb.iocb_ptr (subscript), code);
		     tcb.iocb_ptr (subscript) = null ();
		end;
	     end;
	end close_files;
decode_file_id: procedure;

	     left_vb = operators_argument.operands (1).value;

	     if ^left_vb -> general_bead.value
	     then go to domain_error_left;

	     if ^left_vb -> value_bead.character_value
	     then go to domain_error_left;

	     data_elements = left_vb -> value_bead.total_data_elements;
	     if data_elements < 1
	     then go to length_error_left;

	     if data_elements > 1 & left_vb -> value_bead.rhorho ^= 1
	     then go to rank_error_left;

	     left = left_vb -> value_bead.data_pointer;

	     call expand_pathname_ (ltrim (left -> character_string_overlay), file_dname, file_ename, code);
	     if code ^= 0
	     then goto file_name_error;
	     return;

	end decode_file_id;
decode_tie_num: procedure;

	     right_vb = operators_argument.operands (2).value;

	     if ^right_vb -> general_bead.value
	     then go to domain_error_right;

	     if ^right_vb -> value_bead.integral_value	/* TEMP...insist on integers */
	     then go to domain_error_right;

	     data_elements = right_vb -> value_bead.total_data_elements;

	     if (right_vb -> value_bead.rhorho > 1) & (data_elements ^= 1)
	     then go to rank_error_right;

	     if data_elements ^= 1
	     then go to length_error_right;

	     right = right_vb -> value_bead.data_pointer;

	     tie_num = right -> numeric_datum (0);

	     if (tie_num < lbound (tcb.iocb_ptr, 1)) | (tie_num > hbound (tcb.iocb_ptr, 1))
	     then go to file_tie_error;

	end decode_tie_num;

expand_code: procedure;

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);

	     call convert_status_code_ (code, "", message);
	     return;

	end expand_code;
open_file: procedure;

	     if tcb.iocb_ptr (tie_num) ^= null
	     then go to already_tied;

	     call pathname_$component_check (file_dname, file_ename, "", file_pathname, code);
	     if code ^= 0
	     then go to cant_attach;
	     attach_desc = "vfile_ " || rtrim (file_pathname) || " -extend";
	     tcb.switch (tie_num) = unique_chars_ (""b);

	     call iox_$attach_name (tcb.switch (tie_num), tcb.iocb_ptr (tie_num), attach_desc, null, code);
	     if code ^= 0
	     then go to cant_attach;

	     call iox_$open (tcb.iocb_ptr (tie_num), 3, "0"b, code);
	     if code ^= 0
	     then go to cant_open;

	     call iox_$position (tcb.iocb_ptr (tie_num), -1, 0, code);
	     tcb.eof (tie_num) = "0"b;

	     operators_argument.result = null;
	     return;

	end open_file;

%include apl_bead_format;
%include apl_number_data;
%include apl_operators_argument;
%include apl_value_bead;
%include apl_ws_info;
%include iox_modes;
     end apl_coded_;




		    apl_erf_.pl1                    11/29/83  1639.3rew 11/29/83  1549.4       30627



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

/* APL External Function to implement the PL/I 'erf' builtin for APL */
/* Written October 15, 1975 by Paul Green */
/* Modified 780927 by PG to fix bug 335 (type field of result not being setup properly).
	Also switched to apl_push_stack_ subroutine. */

/* format: style3 */
apl_erf_:
     procedure (operators_argument);

/* automatic */

declare	n_words		fixed bin (19),		/* number of words to allocate on value stack */
	result		ptr,			/* pointer to result data array */
	result_vb		ptr,			/* pointer to result value bead */
	right		ptr,			/* pointer to right data array */
	right_vb		ptr;			/* pointer to right value bead */

/* builtins */

declare	(addrel, erf, size, string, substr, rel)
			builtin;

/* include files */

%include apl_external_function;
%page;
/* program */

/* Usage in APL:
	)MFN ERF APL_ERF_
	RESULT -< ERF V		*/

	right_vb = operators_argument.operands (2).value; /* Get ptr to right argument */
	if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_right;

	if ^right_vb -> value_bead.numeric_value	/* Make sure argument is numeric */
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = right_vb -> value_bead.total_data_elements;

	if operators_argument.operands (2).on_stack
	then do;

/* overwrite operand with result */

		result_vb = right_vb;
		result = right;
	     end;
	else do;

/* Right operand isn't on stack...can't overlay...build new result bead. */

/* Calculate size of result bead. Note that result data array */
/* must be double-word aligned. */

		number_of_dimensions = right_vb -> value_bead.rhorho;
		n_words = size (value_bead) + size (numeric_datum) + 1;

/* Allocate space on the value stack for the result bead. */

		result_vb = apl_push_stack_ (n_words);

/* Set pointer to data array.  Double-word align it. */

		result = addrel (result_vb, size (value_bead));

		if substr (rel (result), 18, 1)
		then result = addrel (result, 1);

/* Initialize new value bead. */

		result_vb -> value_bead.total_data_elements = data_elements;
		result_vb -> value_bead.rhorho = number_of_dimensions;
		result_vb -> value_bead.data_pointer = result;

		if number_of_dimensions > 0		/* Zero-length arrays are invalid in PL/I, so check first */
		then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*);
	     end;

/* Give result bead the correct data type */

	string (result_vb -> value_bead.type) = numeric_value_type;

/* The result value bead is all set up.  Perform the operation */

	result -> numeric_datum (*) = erf (right -> numeric_datum (*));

	operators_argument.result = result_vb;
	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
						/* Mark right operand */
	operators_argument.error_code = apl_error_table_$domain;
	return;
%page;
%include apl_push_stack_fcn;
     end /* apl_erf_ */;




		    apl_get_list_nums_.pl1          11/29/83  1639.3r w 11/29/83  1549.4       57222



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

/* APL External Function to read a segment full of numbers that are in
   character form suitable for list-directed input. The numbers are converted
   to float bin (63) and returned as a vector.

   Written 790318 by PG (from apl_pickup_float_bin_2_).
   Modified 790622 by PG to fix 406 (did not check for reading > 130560 elements)
	Future enhancements: (1) when the lineno builtin is changed
	to work for stream input files, have the error messages from
	this program include the line number of the input file, (2) get
	a maximum-sized vector from APL at the beginning (get a whole
	value stack, in other words), rather than using a temp seg.
	This will use 255K less in the pdir, in the limiting case.
*/

apl_get_list_nums_:
     procedure (operators_argument);

/* automatic */

declare	code		fixed bin (35),		/* Multics status code */
	dname		char (168),		/* directory name for segment */
	ename		char (32),		/* entry name of segment */
	file_title	char (200) varying,		/* title of input file */
	n_words		fixed bin (19),		/* number of words to allocate on value stack */
	n_values		fixed bin,		/* number of values read */
	result		ptr,			/* pointer to result data array */
	result_vb		ptr,			/* pointer to result value bead */
	right		ptr,			/* pointer to right data array */
	right_vb		ptr,			/* pointer to right value bead */
	seg_ptr		ptr,			/* ptr to temp segment */
	temp_numeric_datum	float;			/* temporary apl value */

/* based */

declare	right_arg_string	char (data_elements) based (right);

/* builtins */

declare	(addrel, divide, null, onsource, rtrim, size, string, substr, rel)
			builtin;

/* conditins */

declare	(cleanup, conversion, endfile, transmit, undefinedfile)
			condition;

/* entries */

declare	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35)),
	get_temp_segment_	entry (char (*), ptr, fixed bin (35)),
	ioa_		entry options (variable),
	pl1_io_$error_code	entry (file) returns (fixed bin (35)),
	release_temp_segment_
			entry (char (*), ptr, fixed bin (35));

/* files */

declare	apl_get_list_nums	file;

/* include files */

%include apl_external_function;

/* program */

/* Usage in APL:
		)MFN GET_LIST_NUMS APL_GET_LIST_NUMS_
		R -< GET_LIST_NUMS 'PATH'		*/

	right_vb = operators_argument.operands (2).value; /* Get ptr to right argument */
	if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_right;

	if ^right_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = right_vb -> value_bead.total_data_elements;

/* Pop right arg off value stack, if necessary. */

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;

	call expand_pathname_ (right_arg_string, dname, ename, code);
	if code ^= 0
	then go to set_code;

/* Get a temp segment to hold the numbers in until we know how many there are. */

	seg_ptr = null;
	on cleanup
	     call clean_up;

	call get_temp_segment_ ("apl_get_list_nums_", seg_ptr, code);
	if code ^= 0
	then go to set_code;

/* Open the file and setup handlers for various errors that can happen. */

	file_title = "vfile_ " || rtrim (dname) || ">" || rtrim (ename) || " -extend";

	on undefinedfile (apl_get_list_nums)
	     go to cant_open;
	open file (apl_get_list_nums) title (file_title) stream input;

	on endfile (apl_get_list_nums)
	     go to end_of_file;
	on transmit (apl_get_list_nums)
	     go to transmit_trouble;
	on conversion
	     begin;
		call ioa_ ("apl_get_list_nums_: value ^d (^a) non-numeric. 0 assumed.", n_values, onsource ());
		onsource = "0";
	     end;

/* Everything is set up. Read data until eof. */

	get file (apl_get_list_nums) list ((seg_ptr -> numeric_datum (n_values - 1) do n_values = 1 to 130560 by 1));

/* If we get here, we have read as many values as will fit in one segment.
   It is just possible that this coincides with the end-of-file on
   the input file. If so, there is no error. */

	get file (apl_get_list_nums) list (temp_numeric_datum);

/* No end-of-file. Tell user it is just too big. */

	code = apl_error_table_$result_size;
	go to set_code;

/* put result on value stack */
/* Calculate size of result bead. Note that result data array */
/* must be double-word aligned. */

end_of_file:
	number_of_dimensions = 1;			/* We will return a vector */
	data_elements = n_values - 1;
	n_words = size (value_bead) + size (numeric_datum) + 1;

	result_vb = apl_push_stack_ (n_words);

/* Set pointer to data array.  Double-word align it. */

	result = addrel (result_vb, size (value_bead));

	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);

/* Initialize new value bead. */

	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_vb -> value_bead.data_pointer = result;

/* Give result bead the correct type */

	string (result_vb -> value_bead.type) = numeric_value_type;

/* The result value bead is all set up.  Copy the data into the apl workspace */

	result -> numeric_datum (*) = seg_ptr -> numeric_datum (*);

	call clean_up;

	operators_argument.result = result_vb;
	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
						/* Mark right operand */
	operators_argument.error_code = apl_error_table_$domain;
	return;

set_code:
	operators_argument.error_code = code;
	return;

cant_open:
transmit_trouble:
	operators_argument.error_code = pl1_io_$error_code (apl_get_list_nums);
	call clean_up;
	return;

/* Internal procedures */

clean_up:
     procedure;

	close file (apl_get_list_nums);
	call release_temp_segment_ ("apl_get_list_nums_", seg_ptr, code);

     end clean_up;

%include apl_push_stack_fcn;
     end;




		    apl_graphics_.pl1               11/29/83  1639.3rew 11/29/83  1549.4       74160



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

/* format: style3 */
apl_graphics_:
     proc;

/* An interface to the Multics Graphics System for APL */

/* Written April 1975 by Joseph W. Dehn III
   Modified 800122 by PG to bring up to current APL standards
   Modified 810717 by WMY to fix a bug in return_node which returned
	a pointer to the data instead of to the value bead.
*/

/* automatic */

declare	node		fixed bin (18),
	(x, y, z)		float bin,
	code		fixed bin (35),
	data_elements	fixed bin (21),
	ialign		fixed bin,
	left		ptr,
	left_vb		ptr,
	mode_value	fixed bin,
	n_words		fixed bin (19),
	result_vb		ptr,
	result_data	ptr,
	right		ptr,
	right_vb		ptr;

/* builtins */

declare	(addr, addrel, dim, length, null, rel, size, string, substr)
			builtin;

/* based */

declare	based_string	char (right_vb -> value_bead.total_data_elements) based (right_vb -> value_bead.data_pointer);

/* external static */

declare	(
	apl_error_table_$domain,
	apl_error_table_$length,
	apl_error_table_$rank
	)		fixed bin (35) external;

/* apl include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_bead_format;
%include apl_operators_argument;
%include apl_value_bead;

/* graphics include files */

%include gm_entry_dcls;
%include gc_entry_dcls;
%include go_entry_dcls;
%include graphic_etypes;

/* program */

gfsetposition:
     entry (operators_argument);

	call create_position (Setposition);

gfsetpoint:
     entry (operators_argument);

	call create_position (Setpoint);

gfpoint:
     entry (operators_argument);

	call create_position (Point);

gfshift:
     entry (operators_argument);

	call create_position (Shift);

gfvector:
     entry (operators_argument);

	call create_position (Vector);

gflinetype:
     entry (operators_argument);

	call create_mode (Linetype);

gfintensity:
     entry (operators_argument);

	call create_mode (Intensity);

gfblinking:
     entry (operators_argument);

	call create_mode (Blinking);

gfsensitivity:
     entry (operators_argument);

	call create_mode (Sensitivity);

gfscale:
     entry (operators_argument);

	call three_float;
	node = graphic_manipulator_$create_scale (x, y, z, code);
	go to return_node;

gfrotate:
     entry (operators_argument);

	call three_float;
	node = graphic_manipulator_$create_rotation (x, y, z, code);
	go to return_node;

gflist:
     entry (operators_argument);

	call create_structure (graphic_manipulator_$create_list);

gfarray:
     entry (operators_argument);

	call create_structure (graphic_manipulator_$create_array);

gfinit:
     entry (operators_argument);

	call gm_$init (code);
	go to return_nothing;

gferase:
     entry (operators_argument);

	call graphic_operator_$erase (code);
	go to return_nothing;

gfdisplay:
     entry (operators_argument);

	call one_node;
	call graphic_compiler_$display (node, code);
	go to return_nothing;

gfdisplayappend:
     entry (operators_argument);

	call one_node;
	call graphic_compiler_$display_append (node, code);
	go to return_nothing;

/* This is the only dyadic entry */

gftext:
     entry (operators_argument);

	left_vb = operators_argument.operands (1).value;

	if ^left_vb -> value_bead.value
	then go to domain_error_left;

	if ^left_vb -> value_bead.numeric_value
	then go to domain_error_left;

	right_vb = operators_argument.operands (2).value;

	if ^right_vb -> value_bead.value
	then go to domain_error_right;

	if ^right_vb -> value_bead.character_value
	then go to domain_error_right;

	if left_vb -> value_bead.total_data_elements > 1
	then if left_vb -> value_bead.rhorho > 1
	     then go to rank_error_left;
	     else go to length_error_left;

	ialign = left_vb -> value_bead.data_pointer -> numeric_datum (0);
	node = graphic_manipulator_$create_text (ialign, length (based_string), based_string, code);
	go to return_node;

/* ********** Action Routines ********** */

return_node:
	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;

	number_of_dimensions = 0;
	data_elements = 1;
	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;
	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.rhorho = number_of_dimensions;
	result_data = addrel (result_vb, size (value_bead));
	if substr (rel (result_data), 18, 1)
	then result_data = addrel (result_data, 1);

	result_vb -> value_bead.data_pointer = result_data;
	result_data -> numeric_datum (0) = node;

	operators_argument.result = result_vb;

return_nothing:
	if code ^= 0
	then operators_argument.error_code = code;

	return;

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$domain;
	return;

length_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

length_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$length;
	return;

rank_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

rank_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$rank;
	return;

/* INTERNAL PROCEDURES */

create_position:
     proc (itype);

dcl	itype		fixed bin;

	call three_float;
	node = graphic_manipulator_$create_position (itype, x, y, z, code);
	go to return_node;
     end;

create_mode:
     proc (itype);

dcl	itype		fixed bin;
dcl	mode_value	fixed bin;

	call validate_right;

	if (right_vb -> value_bead.total_data_elements > 1)
	then if right_vb -> value_bead.rhorho > 1
	     then go to rank_error_right;
	     else go to length_error_right;

	mode_value = right -> numeric_datum (0);
	node = graphic_manipulator_$create_mode (itype, mode_value, code);
	go to return_node;
     end;

three_float:
     proc;

	call validate_right;

	if right_vb -> value_bead.rhorho ^= 1
	then go to rank_error_right;

	if (right_vb -> value_bead.total_data_elements < 2) | (right_vb -> value_bead.total_data_elements > 3)
	then go to length_error_right;

	if right_vb -> value_bead.total_data_elements = 3
	then z = right -> numeric_datum (2);
	else z = 0e0;

	x = right -> numeric_datum (0);
	y = right -> numeric_datum (1);
	return;
     end;

one_node:
     proc;

	call validate_right;

	if right_vb -> value_bead.total_data_elements > 1
	then if right_vb -> value_bead.rhorho > 1
	     then go to rank_error_right;
	     else go to length_error_right;

	node = right -> numeric_datum (0);
	return;
     end;

create_structure:
     proc (structure_maker);

dcl	structure_maker	entry (dimension (*) fixed bin (18), fixed bin, fixed bin (35))
			returns (fixed bin (18)) variable;

	call validate_right;

	if right_vb -> value_bead.rhorho ^= 1
	then go to rank_error_right;

	data_elements = right_vb -> value_bead.rho (1);

	begin;

dcl	node_array	fixed bin (18) dim (data_elements);

	     node_array (*) = right -> numeric_datum (*); /* copy the floats to temp array */
	     node = structure_maker (node_array, (data_elements), code);
	end;

	go to return_node;

     end create_structure;

validate_right:
     proc;

	right_vb = operators_argument.operands (2).value;

	if ^right_vb -> value_bead.value
	then go to domain_error_right;

	if ^right_vb -> value_bead.numeric_value
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;
	return;

     end validate_right;

%include apl_push_stack_fcn;
     end apl_graphics_;




		    apl_ioa_.pl1                    11/29/83  1639.3r w 11/29/83  1549.4       73989



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

/* APL_IOA_ - APL Interface to Multics ioa_ subroutine.

   Written, coded, and debugged January 17, 1976 by Paul Green (200 lines in one day...!)
   Modified 760118 by PG to pass numeric vectors as arrays, and character vectors as strings.
   Modified 781115 by PG to pop list beads properly.
*/

apl_ioa_:
     procedure (operators_argument);

/* parameters */

/* see include file apl_operators_argument */

/* automatic */

dcl (add_nl, pad_arg, print_arg, list_given) bit (1) aligned,
    (left, left_vb, lowest_vb, result, result_vb, right_vb) ptr,
    (data_elements, left_data_elements, return_len) fixed bin (21),
    (i, na, nd, n_values, number_of_args) fixed bin,
     code fixed bin (35),
     n_words fixed bin (19),
     return_string char (256);

dcl 1 arglist aligned,
    2 n_args fixed bin (17) unal,
    2 flag bit (18) unal init ("000000000000000100"b),
    2 n_desc fixed bin (17) unal,
    2 pad bit (18) unal,
    2 ptr (100) ptr;

dcl 1 desclist aligned,
    2 desc (100),
      3 type bit (8) unal,
      3 n_dims bit (4) unal,
      3 size fixed bin (23) unal;

/* based */

dcl  result_string char (return_len) based;

/* builtin */

dcl (addr, addrel, null, size, string, translate, unspec) builtin;

/* entries */

dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned),
     iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* external static */

dcl ((apl_error_table_$domain,
     apl_error_table_$rank) fixed bin (35),
     iox_$user_output ptr
    ) external static;

/* internal static */

dcl (character_descriptor init ("10101010"b),
     float_bin_2_descriptor init ("10001000"b)
    ) bit (18) internal static options (constant);

/* include files */

%include apl_number_data;
%include apl_characters;
%include apl_operators_argument;
%include apl_bead_format;
%include apl_operator_bead;
%include apl_list_bead;
%include apl_value_bead;
%include apl_ws_info;

/* program */

	print_arg = "1"b;
	pad_arg = "0"b;
	add_nl = "1"b;
	go to begin;

apl_ioa_$rs:
	entry (operators_argument);

	print_arg = "0"b;
	pad_arg = "0"b;
	add_nl = "1"b;
	go to begin;

apl_ioa_$rsnnl:
	entry (operators_argument);

	print_arg = "0"b;
	pad_arg = "0"b;
	add_nl = "0"b;
	go to begin;

apl_ioa_$nnl:
	entry (operators_argument);

	print_arg = "1"b;
	pad_arg = "0"b;
	add_nl = "0"b;
	go to begin;

begin:
	right_vb = operators_argument (2).value;

	if right_vb -> general_bead.value
	then do;
		list_given = "0"b;
		n_values = 1;
	     end;
	else if right_vb -> general_bead.list_value
	     then do;
		     list_given = "1"b;
		     n_values = right_vb -> list_bead.number_of_members;
		end;
	     else go to domain_error_right;

	left_vb = operators_argument (1).value;

	if ^left_vb -> general_bead.value
	then go to domain_error_left;

	if ^left_vb -> value_bead.character_value
	then go to domain_error_left;

	if (left_vb -> value_bead.total_data_elements > 1) & (left_vb -> value_bead.rhorho ^= 1)
	then go to rank_error_left;

	left = left_vb -> value_bead.data_pointer;
	data_elements, left_data_elements = left_vb -> value_bead.total_data_elements;

	number_of_args = 1 + n_values;		/* 1 for control string, N for values */

	/* Translate UpperMinus to Circumflex in the control string...give apl user a break. */

	n_words  = size (character_string_overlay);
	result_vb = apl_push_stack_ (n_words);

	result_vb -> character_string_overlay = translate (left -> character_string_overlay, "^", QUpperMinus);
	arglist.ptr (1) = result_vb;

	if ^list_given
	then arglist.ptr (2) = right_vb -> value_bead.data_pointer;
	else do i = 1 to n_values;
		arglist.ptr (1+i) = right_vb -> list_bead.member_ptr (i) -> value_bead.data_pointer;
	     end;

	desclist.desc (1).type = character_descriptor;
	desclist.desc (1).n_dims = "0000"b;
	desclist.desc (1).size = left_data_elements;

	nd = 1;					/* this is the index of the current descriptor */
	na = number_of_args + 1;			/* index of current ptr */
	arglist.ptr (na) = addr (desclist.desc (1));	/* store ptr to descriptor for ctl string */

	if ^list_given
	then do;
		if right_vb -> value_bead.numeric_value
		then call generate_numeric_descriptor (right_vb);
		else do;
			na = na + 1;
			nd = nd + 1;
			arglist.ptr (na) = addr (desclist.desc (nd));
			desclist.desc (nd).type = character_descriptor;
			desclist.desc (nd).n_dims = "0000"b;
			desclist.desc (nd).size = right_vb -> value_bead.total_data_elements;
		     end;
	     end;
	else do i = 1 to n_values;
		if right_vb -> list_bead.member_ptr (i) -> value_bead.numeric_value
		then call generate_numeric_descriptor ((right_vb -> list_bead.member_ptr (i)));
		else do;
			na = na + 1;
			nd = nd + 1;
			arglist.ptr (na) = addr (desclist.desc (nd));
			desclist.desc (nd).type = character_descriptor;
			desclist.desc (nd).n_dims = "0000"b;
			desclist.desc (nd).size = right_vb -> list_bead.member_ptr (i) -> value_bead.total_data_elements;
		     end;
	     end;

	arglist.n_args = number_of_args * 2;		/* Multics convention...! */
	arglist.n_desc = number_of_args * 2;
	call ioa_$general_rs (addr (arglist), 1, 2, return_string, return_len, pad_arg, add_nl);

	if operators_argument.operands (2).on_stack	/* Pop args off stack */
	then if list_given
	     then do;

/* The list_bead is always higher than the value_beads it points to. Its members were
   evaluated in right-to-left (n_members to 1 by -1) order, so that members with higher
   subscripts are lower on the value stack. */

		     lowest_vb = right_vb;		/* initially, this is lowest guy on stack */
		     do i = 1 to n_values;
			if right_vb -> list_bead.bits (i).semantics_on_stack
			then lowest_vb = right_vb -> list_bead.member_ptr (i);
		     end;
		     ws_info.value_stack_ptr = lowest_vb;
		end;
	     else ws_info.value_stack_ptr = right_vb;
	else if operators_argument.operands (1).on_stack
	     then ws_info.value_stack_ptr = left_vb;

	if print_arg
	then do;
		call iox_$put_chars (iox_$user_output, addr (return_string), return_len, code);
		operators_argument.result = null;
	     end;
	else do;
		data_elements = return_len;
		number_of_dimensions = 1;
		n_words = size (value_bead) + size (character_string_overlay);
		result_vb = apl_push_stack_ (n_words);

		string (result_vb -> value_bead.type) = character_value_type;
		result_vb -> value_bead.total_data_elements = data_elements;
		result_vb -> value_bead.rhorho = 1;
		result_vb -> value_bead.rho (1) = data_elements;
		result = addrel (result_vb, size (value_bead));
		result_vb -> value_bead.data_pointer = result;

		result -> result_string = return_string;
		operators_argument.result = result_vb;
	     end;
	return;

domain_error_left:
domain_error_right:
	operators_argument.error_code = apl_error_table_$domain;
	return;

rank_error_left:
	operators_argument.error_code = apl_error_table_$rank;
	return;

generate_numeric_descriptor:
     procedure (bv_vb_ptr);

/* parameters */

dcl  bv_vb_ptr ptr parameter;

/* program */

	na = na + 1;				/* step to next arg ptr */
	nd = nd + 1;				/* step to next descriptor */
	arglist.ptr (na) = addr (desclist.desc (nd));
	desclist.desc (nd).type = float_bin_2_descriptor;
	desclist.desc (nd).n_dims = "0001"b;	/* numbers are always arrays... */
	desclist.desc (nd).size = 63;		/* precision is 63 */
	nd = nd + 1;
	unspec (desclist.desc (nd)) = ""b;
	desclist.desc (nd).size = 1;		/* LB is always 1 */
	nd = nd + 1;
	unspec (desclist.desc (nd)) = ""b;
	desclist.desc (nd).size = bv_vb_ptr -> value_bead.total_data_elements;	/* UB is TDE */
	nd = nd + 1;
	unspec (desclist.desc (nd)) = ""b;
	desclist.desc (nd).size = 2;		/* MULT is 2 words */
	return;

     end generate_numeric_descriptor;

%include apl_push_stack_fcn;
     end /* apl_ioa_ */;




		    apl_iox_.pl1                    11/29/83  1639.3rew 11/29/83  1558.0      108144



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* APL External Functions to access the full (ycch) panoply
   of  iox stream files
*/

/* stolen from apl_read_segment_ 1/28/80 BIM */

/* **************************************************************
   *   for the first implementation, we support the following:   *
   *   attach_name				       *
   *   open					       *
   *   get_chars					       *
   *   get_line					       *
   *   put_chars					       *
   *   close					       *
   *   detach_iocb				       *
   *   						       *
   *   packed pointers are left around in fixed bin (35)'s       *
   ************************************************************** */


/* *******************************************************************
   *   APL Definitions and calling sequences:			  *
   *   attach_name					  *
   *   )DFN IOX_ATTACH_NAME APL_IOX_$ATTACH_NAME		  *
   *   IOCB<-Switch_name IOX_ATTACH_NAME Attach_description	  *
   *   							  *
   *   open						  *
   *   )DFN IOX_OPEN APL_IOX_$OPEN				  *
   *   OpenMode IOX_OPEN IOCB (character name of it, long or short)	  *
   *   							  *
   *   get_chars						  *
   *   )DFN IOX_GET_CHARS APL_IOX_$GET_CHARS			  *
   *   RESULT<-HowMany IOX_GET_CHARS IOCB			  *
   *   							  *
   *   get_line						  *
   *   )MFN IOX_GET_LINE APL_IOX_$GET_LINE			  *
   *   RESULT<-IOX_GET_LINE IOCB				  *
   *   							  *
   *   close						  *
   *   )MFN IOX_CLOSE APL_IOX_$CLOSE				  *
   *   IOX_CLOSE IOCB					  *
   *   							  *
   *   detach_iocb					  *
   *   )MFN IOX_DETACH_IOCB APL_IOX_$DETACH_IOCB		  *
   ******************************************************************* */

apl_iox_$attach_name:
     procedure (operators_argument);

/* automatic */

declare  code fixed bin (35),				/* Multics status code */
         attach_description char (512),
         i fixed bin,
         get_line_flag bit (1),
         max_size fixed bin (21),
         ql fixed bin (21),
         integer fixed bin (35),
         n_words fixed bin (19),			/* number of words to allocate on value stack */
         found_mode bit (1),
         iox_mode char (24),
         switch_name char (32),
         iocbp ptr, packed_iocbp ptr unal,
         result ptr,				/* pointer to result data array */
         result_vb ptr,				/* pointer to result value bead */
         right ptr,					/* pointer to right data array */
         right_vb ptr,				/* pointer to right value bead */
         left ptr,
         left_vb ptr;
						/* based */

declare  right_arg_string char (data_elements) based (right);
declare  right_arg_integer fixed bin (35) based (right);
declare  left_arg_string char (data_elements) based (left);
declare  float_overlay float bin (63) based aligned;
declare  line_buffer char (ql) based (apl_iox_temp_seg_ptr_);

/* builtins */

declare (addrel, divide, null, size, string) builtin;

/* entries */

dcl  get_entry entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable;
dcl (get_temp_segment_, release_temp_segment_) entry (char (*), pointer, fixed bin (35));

/* external */
dcl  apl_iox_temp_seg_ptr_ ext static ptr init (null());
dcl  sys_info$max_seg_size fixed bin (19) external static;
/* errors */

dcl  error_table_$end_of_info fixed bin (35) ext static;
						/* include files */

%include iox_dcls;
%include iox_modes;
%include apl_external_function;

/* program -- attach_name entrypoint */

	right_vb = operators_argument.operands (2).value; /* Get ptr to right argument */
	if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_right;

	if ^right_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = right_vb -> value_bead.total_data_elements;

	attach_description = right_arg_string;

	left_vb = operators_argument.operands (1).value;	/* Get ptr to left argument */
	if ^left_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_left;

	if ^left_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_left;

	left = left_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = left_vb -> value_bead.total_data_elements;
	if data_elements > 32 then goto length_error_left;
	switch_name = left_arg_string;

	call POP_ARGS;

	call iox_$attach_name (switch_name, iocbp, attach_description, null (), code);
	if code ^= 0 then goto set_code;
	call get_temp_segment_ ("apl_iox_", apl_iox_temp_seg_ptr_, code);
	packed_iocbp = iocbp;
	unspec (integer) = unspec (packed_iocbp);

/* put result on value stack */
/* Calculate size of result bead. Note that result data array */
/* must be double-word aligned. */

	number_of_dimensions = 0;			/* for attach we return scalar */
	data_elements = 1;
	n_words = size (float_overlay);
	call ALLOCATE_RESULT ("1"b);

/* Give result bead the correct type */

	string (result_vb -> value_bead.type) = integral_value_type;

/* The result value bead is all set up.  Perform the operation */

	result -> float_overlay = integer;

	operators_argument.result = result_vb;
	return;

rank_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;
rank_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$rank;
	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1; /* Mark right operand */
	operators_argument.error_code = apl_error_table_$domain;
	return;

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 1; /* Mark right operand */
	operators_argument.error_code = apl_error_table_$domain;
	return;

length_error_left:
	operators_argument.where_error = operators_argument.where_error + 1; /* Mark right operand */
	operators_argument.error_code = apl_error_table_$length;
	return;

set_code:
	operators_argument.error_code = code;
	return;

open:	entry (operators_argument);

	call PICKUP_IOCB;				/* right arg is IOCBP */
	left_vb = operators_argument.operands (1).value;	/* Get ptr to left argument */
	if ^left_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_left;

	if ^left_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_left;

	left = left_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = left_vb -> value_bead.total_data_elements;
	if data_elements > 24 then goto length_error_left;
	iox_mode = left_arg_string;

	call POP_ARGS;

	found_mode = ""b;
	do i = 1 to 13 while (^found_mode);
	     if iox_modes (i) = iox_mode | short_iox_modes (i) = iox_mode then found_mode = "1"b;
	end;
	if ^found_mode then goto domain_error_left;
	call iox_$open (iocbp, i - 1, ""b, code);
	if code ^= 0 then goto set_code;
	return;					/* no value to return on open */

get_line:	entry (operators_argument);

	get_line_flag = "1"b;
	max_size = sys_info$max_seg_size * 4; /* can't get bigger */
	get_entry =iox_$get_line;
	goto GET_COMMON;

get_chars:
	entry (operators_argument);

	get_line_flag = ""b;
	get_entry = iox_$get_chars;
	left_vb = operators_argument.operands (1).value;	/* Get ptr to left argument */
	if ^left_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_left;
	if ^left_vb -> value_bead.integral_value /*cant read 1/2 char */
	then go to domain_error_left;

	left = left_vb -> value_bead.data_pointer;
	if left_vb -> value_bead.rhorho > 0 then goto rank_error_left;
	data_elements = left_vb -> value_bead.total_data_elements;
	max_size = left -> numeric_datum (0);
	
GET_COMMON:
	call PICKUP_IOCB;
	call POP_ARGS;
	call get_entry (iocbp, apl_iox_temp_seg_ptr_, max_size, ql, code);

    /******************************************************
     *   this should take long record into account, but   *
     *   i dont see how we could get more thana segment   *
     *   of line...				        *
     ******************************************************/

	if code ^= 0 & code ^= error_table_$end_of_info then goto set_code;
	if code = error_table_$end_of_info then do;
	     number_of_dimensions = 2;		/* indicate eof */
	     data_elements = 0;
	     n_words = 0;
	     call ALLOCATE_RESULT (""b);
	     result_vb -> value_bead.rho (*) = 0;
	     string (result_vb -> value_bead.type) = character_value_type;
	     operators_argument.result = result_vb;
	     return;
	end;
	else do;					/* normal return, return the line */
	     if get_line_flag then do; /* clean up after things */
		ql = ql - 1; /* dont return the NL */
		ql = length (rtrim (line_buffer, ""));
	     end;
	     
	     number_of_dimensions = 1;
	     data_elements = ql;
	     n_words = size (character_string_overlay);
	     call ALLOCATE_RESULT (""b);
	     result_vb -> value_bead.rho (1) = ql;
	     string (result_vb -> value_bead.type) = character_value_type;
	     result -> character_string_overlay = substr (line_buffer, 1, ql);
	     operators_argument.result = result_vb;
	     return;
	end;

put_chars:
	entry (operators_argument);

	call PICKUP_IOCB;

	left_vb = operators_argument.operands  (1).value;

	if ^left_vb -> value_bead.value
	then go to domain_error_left;

	if ^left_vb -> value_bead.character_value
	then go to domain_error_left;

	data_elements = left_vb -> value_bead.total_data_elements;
	left = left_vb -> value_bead.data_pointer;

	call POP_ARGS;

	if data_elements = 0
	then return;

	call iox_$put_chars (iocbp, left, data_elements, code);

/* No result */

	operators_argument.error_code = code;
	return;

close:	entry (operators_argument);

	call PICKUP_IOCB;
	call POP_ARGS;
	call iox_$close (iocbp, code);
	if code ^= 0 then goto set_code;
	return;

detach_iocb: entry (operators_argument);

	call PICKUP_IOCB;
	call POP_ARGS;
	call iox_$detach_iocb (iocbp, code);
	if code ^= 0 then goto set_code;
	if apl_iox_temp_seg_ptr_ ^= null() then
	     call release_temp_segment_ ("apl_iox_", apl_iox_temp_seg_ptr_,
	     code);
	return;

/* Internal procedures */

ALLOCATE_RESULT:
	proc (maligned);


dcl  maligned bit (1);

	     n_words = n_words + size (value_bead) + 1;
	     result_vb = apl_push_stack_ (n_words);

/* Set pointer to data array. */

	     result = addrel (result_vb, size (value_bead));
	     if maligned then
		if substr (rel (result), 18, 1) then
		     result = addrel (result, 1);

/* Initialize new value bead. */

	     result_vb -> value_bead.total_data_elements = data_elements;
	     result_vb -> value_bead.rhorho = number_of_dimensions;
	     result_vb -> value_bead.data_pointer = result;

	end;

PICKUP_IOCB: proc;
	     right_vb = operators_argument.operands (2).value; /* Get ptr to right argument */
	     if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	     then go to domain_error_right;

	     if ^right_vb -> value_bead.integral_value
	     then go to domain_error_right;

	     right = right_vb -> value_bead.data_pointer; /* Point to data array */
	     if right_vb -> rhorho ^= 0 then goto rank_error_right;

	     data_elements = right_vb -> value_bead.total_data_elements;

	     integer = right -> float_overlay;		/* integer */
	     unspec (packed_iocbp) = unspec (integer);	/* ppointer */
	     iocbp = packed_iocbp;			/* whew -- back to pointer */

	     return;
	end;


POP_ARGS: proc;


/* Pop args off value stack, if necessary. */

	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;
	return;
	end;

%include apl_push_stack_fcn;
     end;




		    apl_pickup_float_bin_2_.pl1     11/29/83  1639.3r w 11/29/83  1549.5       38790



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

/* APL External Function to pickup a segment full of double-floating numbers. */
/* This segment must have the bitcount correctly set. */
/* Written February 10, 1977 by Paul Green */
/* Modified 790215 by PG to set result type correctly, and to use apl_push_stack_. */

apl_pickup_float_bin_2_:
	procedure (operators_argument);

/* automatic */

declare	bitcount fixed bin (24),	/* bitcount of segment named by right argument */
	code fixed bin (35),	/* Multics status code */
	dname char (168),		/* directory name for segment */
	ename char (32),		/* entry name of segment */
	n_words fixed bin (19),	/* number of words to allocate on value stack */
	result ptr,		/* pointer to result data array */
	result_vb ptr,		/* pointer to result value bead */
	right ptr,		/* pointer to right data array */
	right_vb ptr,		/* pointer to right value bead */
	seg_ptr ptr;		/* ptr to segment named by right argument */

/* based */

declare	right_arg_string char (data_elements) based (right);

/* builtins */

declare	(addrel, divide, null, size, string, substr, rel) builtin;

/* entries */

declare	expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin, ptr, fixed bin (35)),
	hcs_$terminate_noname entry (ptr, fixed bin (35));

/* include files */

%include apl_external_function;

/* program */

	/* Usage in APL:
		)MFN PICKUP APL_PICKUP_
		RESULT -< PICKUP 'PATH'		*/

	right_vb = operators_argument.operands (2).value;	/* Get ptr to right argument */
	if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_right;

	if ^right_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = right_vb -> value_bead.total_data_elements;

	/* Pop right arg off value stack, if necessary. */

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;

	call expand_pathname_ (right_arg_string, dname, ename, code);
	if code ^= 0
	then go to set_code;

	call hcs_$initiate_count (dname, ename, "", bitcount, 1, seg_ptr, code);
	if seg_ptr = null
	then go to set_code;

	/* put result on value stack */
	/* Calculate size of result bead. Note that result data array */
	/* must be double-word aligned. */

	number_of_dimensions = 1;			/* We will return a vector */
	data_elements = divide (bitcount, 72, 24, 0);	/* Length of vector is number of double floating point numbers in segment. */
	n_words = size (value_bead) + size (numeric_datum) + 1;

	result_vb = apl_push_stack_ (n_words);

	/* Set pointer to data array.  Double-word align it. */

	result = addrel (result_vb, size (value_bead));

	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);

	/* Initialize new value bead. */

	string (result_vb -> value_bead.bead_type) = 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;
	result_vb -> value_bead.data_pointer = result;

	/* Give result bead the correct type */

	string (result_vb -> value_bead.type) = numeric_value_type;

	/* The result value bead is all set up.  Perform the operation */

	result -> numeric_datum (*) = seg_ptr -> numeric_datum (*);

	/* Terminate the segment */

	call hcs_$terminate_noname (seg_ptr, code);

	operators_argument.result = result_vb;
	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;	/* Mark right operand */
	operators_argument.error_code = apl_error_table_$domain;
	return;

set_code:
	operators_argument.error_code = code;
	return;

/* Internal procedures */

%include apl_push_stack_fcn;
     end;




		    apl_raw_output_.pl1             11/29/83  1639.3r w 11/29/83  1549.5       19656



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

/* APL External Function to write characters to a terminal (or absout) without having them
   translated by the APL DIM.

   Written 800227 by PG
*/

/* format: style3 */
apl_raw_output_:
     procedure (operators_argument);

/* automatic */

declare	code		fixed bin (35),		/* Multics status code */
	right		ptr,			/* pointer to right data array */
	right_vb		ptr;			/* pointer to right value bead */

/* based */

declare	right_arg_string	char (data_elements) based (right);

/* builtins */

declare	null		builtin;

/* entries */

declare	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* external static */

declare	apl_static_$user_tty
			ptr external static;

/* include files */

%include apl_external_function;

/* program */

/* Usage in APL:
		)MFN RAW_OUTPUT APL_RAW_OUTPUT_
		RAW_OUTPUT 'ANYTHING'		*/

	right_vb = operators_argument.operands (2).value; /* Get ptr to right argument */
	if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_right;

	if ^right_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = right_vb -> value_bead.total_data_elements;

/* Pop right arg off value stack, if necessary. */

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;

	call iox_$put_chars (apl_static_$user_tty, right, data_elements, code);
	operators_argument.result = null;
	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$domain;
	return;

     end apl_raw_output_;




		    apl_read_segment_.pl1           11/29/83  1639.3r w 11/29/83  1549.5       37206



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

/* APL External Function to read a segment as a character string. */
/* This segment must have the bitcount correctly set. */
/* Written 790215 by PG (from apl_pickup_float_bin_2_). */

apl_read_segment_:
	procedure (operators_argument);

/* automatic */

declare	bitcount fixed bin (24),	/* bitcount of segment named by right argument */
	code fixed bin (35),	/* Multics status code */
	dname char (168),		/* directory name for segment */
	ename char (32),		/* entry name of segment */
	n_words fixed bin (19),	/* number of words to allocate on value stack */
	result ptr,		/* pointer to result data array */
	result_vb ptr,		/* pointer to result value bead */
	right ptr,		/* pointer to right data array */
	right_vb ptr,		/* pointer to right value bead */
	seg_ptr ptr;		/* ptr to segment named by right argument */

/* based */

declare	right_arg_string char (data_elements) based (right);

/* builtins */

declare	(addrel, divide, null, size, string) builtin;

/* entries */

declare	expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin, ptr, fixed bin (35)),
	hcs_$terminate_noname entry (ptr, fixed bin (35));

/* include files */

%include apl_external_function;

/* program */

	/* Usage in APL:
		)MFN READ_SEGMENT APL_READ_SEGMENT_
		RESULT -< READ_SEGMENT 'PATH'		*/

	right_vb = operators_argument.operands (2).value;	/* Get ptr to right argument */
	if ^right_vb -> value_bead.value		/* Make sure argument is a value bead */
	then go to domain_error_right;

	if ^right_vb -> value_bead.character_value	/* Make sure argument is character */
	then go to domain_error_right;

	right = right_vb -> value_bead.data_pointer;	/* Point to data array */
	data_elements = right_vb -> value_bead.total_data_elements;

	/* Pop right arg off value stack, if necessary. */

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;

	call expand_pathname_ (right_arg_string, dname, ename, code);
	if code ^= 0
	then go to set_code;

	call hcs_$initiate_count (dname, ename, "", bitcount, 1, seg_ptr, code);
	if seg_ptr = null
	then go to set_code;

	/* put result on value stack */
	/* Calculate size of result bead. Note that result data array */
	/* must be double-word aligned. */

	number_of_dimensions = 1;			/* We will return a vector */
	data_elements = divide (bitcount + 8, 9, 24, 0);	/* Length of vector is number of bytes in segment. */
	n_words = size (value_bead) + size (character_string_overlay);

	result_vb = apl_push_stack_ (n_words);

	/* Set pointer to data array. */

	result = addrel (result_vb, size (value_bead));

	/* Initialize new value bead. */

	string (result_vb -> value_bead.bead_type) = 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;
	result_vb -> value_bead.data_pointer = result;

	/* Give result bead the correct type */

	string (result_vb -> value_bead.type) = character_value_type;

	/* The result value bead is all set up.  Perform the operation */

	result -> character_string_overlay = seg_ptr -> character_string_overlay;

	/* Terminate the segment */

	call hcs_$terminate_noname (seg_ptr, code);

	operators_argument.result = result_vb;
	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;	/* Mark right operand */
	operators_argument.error_code = apl_error_table_$domain;
	return;

set_code:
	operators_argument.error_code = code;
	return;

/* Internal procedures */

%include apl_push_stack_fcn;
     end;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
