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