apl_zcode_to_ascii_.alm 08/12/81 2123.1r 08/08/81 1559.8 42210 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** "ALM subroutine to convert from 9 bit EBCDIC ZCODE to 9 bit Multics APL ASCII "Input bytes must be valid EBCDIC characters in the range "00 <_ hexadecimal_value <_ FF, or 000 <_ octal_value <_ 377. " "ARG 1: source string - data to be converted "ARG 2: target string - converted data " "PL/I Usage: " "dcl apl_zcode_to_ascii_ entry (char (*), char (*)); " call apl_zcode_to_ascii_ (input_string, output_string); " "Note: the EBCDIC to ASCII mapping used is defined in the text " of this procedure. It is available to the user program " through the following declaration. " "dcl apl_zcode_to_ascii_$za_table char (256) external static; " "The table consists of 256 ASCII characters which correspond to "the 256 EBCDIC characters. As only 128 of the EBCDIC characters "have ASCII mappings, the other 128 are mapped into the ASCII SUB "character, octal 032. (The EBCDIC SUB character is also mapped "into octal 032. " " 0) Created (as ebcdic_to_ascii_) by Ross E. Klinger, 02/14/74 " 1) Modified (as ebcdic_to_ascii) by R.E. Klinger, 03/13/75 " 2) Rewritten to be apl_zcode_to_ascii_ by Paul Green, 7/30/76 name apl_zcode_to_ascii_ segdef apl_zcode_to_ascii_ segdef za_table apl_zcode_to_ascii_: epp1 ap|2,* address of source string to pr1 epp3 ap|4,* address of target string to pr3 ldx3 0,du set x3 not to skip parent pointer if none lxl2 ap|0 load argument list code value canx2 =o000004,du check for code 4 - no parent pointer tnz *+2 transfer if no parent pointer ldx3 2,du parent pointer - set x3 to skip it lda ap|6,x3* load source string descriptor ldq ap|8,x3* load target string descriptor ana mask drop all but string size bits anq mask ditto mvt (pr,rl),(pr,rl),fill(230) translate ebcdic to ascii desc9a pr1|0,al source string desc9a pr3|0,ql target string arg za_table short_return "exit mask: oct 000077777777 even " ASCII OUTPUT ASCII GRAPHIC EBCDIC INPUT za_table: oct 000001002003 NUL SOH STX ETX 00-03 oct 032011032072 - HT - FAKECOLON 04-07 oct 056032032013 FAKEPERIOD - - VT 08-0B oct 014015133135 FF CR [ ] 0C-0F oct 050051073057 ( ) SEMICOLON / 10-13 oct 134255256032 \ -< -> - 14-17 oct 032245053055 - DIAR + - 18-1B oct 251205052212 x -: * c 1C-1F oct 213174204203 f | & v 20-23 oct 074200075201 < <_ = >_ 24-27 oct 076202252206 > /= a e 28-2B oct 247250246054 i p w , 2C-2F oct 041233220221 ! o| _| t 30-33 oct 211077176207 o ? ~ ^| 34-37 oct 210222223217 v| (_ )_ n 38-3B oct 224137234242 u _ \o b 3C-3F oct 215216241232 _o q 'q *o 40-43 oct 226225240237 &~ v~ .n d| 44-47 oct 236227230243 g| -o -/ -\ 48-4B oct 244275274046 m _f _e "046 4C-4F oct 100043044032 @ # $ - 50-53 oct 777776141142 Td Sd A B 54-57 oct 143144145146 C D E F 58-5B oct 147150151152 G H I J 5C-5F oct 153154155156 K L M N 60-63 oct 157160161162 O P Q R 64-67 oct 163164165166 S T U V 68-6B oct 167170171172 W X Y Z 6C-6F oct 214101102103 d A_ B_ C_ 70-73 oct 104105106107 D_ E_ F_ G_ 74-77 oct 110111112113 H_ I_ J_ K_ 78-7B oct 114115116117 L_ M_ N_ O_ 7C-7F oct 120121122123 P_ Q_ R_ S_ 80-83 oct 124125126127 T_ U_ V_ W_ 84-87 oct 130131132272 W_ Y_ Z_ _d 88-8B oct 060061062063 0 1 2 3 8C-8F oct 064065066067 4 5 6 7 90-93 oct 070071056253 8 9 . ^ 94-97 oct 040047072254 SP ' : g 98-9B oct 012775010300 NL EOB BS LF 9C-9F oct 231032032032 g~ - - - A0-A3 oct 032032032032 - - - - A4-A7 oct 032032136042 - - "136 "042 A8-AB oct 045032032032 % - - - AC-AF oct 032032032032 - - - - B0-B3 oct 032032032302 - - - c| B4-B7 oct 032032032032 - - - - B8-BB " END OF ZCODES. oct 032135032032 -,],-,- BC-F oct 173101102103 {,A,B,C C0-3 oct 104105106107 D,E,F,G C4-7 oct 110111032032 H,I,-,- C8-B oct 032032032032 -,-,-,- CC-F oct 175112113114 },J,K,L D0-3 oct 115116117120 M,N,O,P D4-7 oct 121122032032 Q,R,-,- D8-B oct 032032032032 -,-,-,- DC-F oct 134032123124 \,-,S,T E0-3 oct 125126127130 U,V,W,X E4-7 oct 131132032032 Y,Z,-,- E8-B oct 032032032032 -,-,-,- EC-F oct 060061062063 0,1,2,3 F0-3 oct 064065066067 4,5,6,7 F4-7 oct 070071032032 8,9,-,- F8-B oct 032032032032 -,-,-,- FC-F end  convert_tsoapl_ws.pl1 09/24/84 1339.5rew 09/24/84 1247.5 227160 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3 */ convert_tsoapl_ws: ctw: procedure; /* Written by Bernard Greenberg, from display_aplsv_ws.pl1, 10/77 */ /* Modified 771121 by PG to cleanup error handling and aborting. */ /* Modified 771207 by PG to convert library_number and man_number */ /* Modified 771209 by PG to make vput quick */ /* Modified 771212 by PG to fix bug that was reversing vectors in functions, and speed up function converter by processing only lines backwards, not the whole function. */ /* Modified 771230 by PG to fix bug in which we forgot to use cv_fb17 on a 360 number. */ /* Modified 771230 by PG to fix bug in fix of 771212...integers and floats were getting reversed. */ /* Modified 781005 by PG to fix bug 347 in declaration of function line offsets, and to fix bug 346 whereby symbol_bead for groups never pointed to the group_bead! Modified 800212 by PG to fix 450 (unknown symbol types got counted in num_symbols, but not converted). Modified 800227 by PG to add -relock_functions control argument. Modified 840907 by C Spitzer. correct length of format string passed to dump_segment_ */ /* Ideas: 1. All error messages should include name of ws. 2. Option to suppress "too small/too large" msg. 3. "Too small/too large" msg should give context (var name or fcn line number). */ /* automatic */ dcl arg_len fixed bin (21), arg_number fixed bin, arg_ptr ptr, bitcount fixed bin (24), code fixed bin (35), curr_component fixed bin, curr_seglen fixed bin (18), dname char (168), ename char (32), ename1 char (32), ename2 char (32), fcbp ptr, idx fixed bin, inpath_arg_len fixed bin (21), inpath_arg_ptr ptr, num_symbols fixed bin, number_of_ptrs fixed bin, outpath_arg_len fixed bin (21), outpath_arg_ptr ptr, pathx fixed bin, q (3) ptr init ((3) null ()), qr13stk fixed bin, qsymbot fixed bin, relock_functions bit (1) aligned, saved_bead_table_ptr ptr, segptrs (0:15) ptr, s360_trtblptr ptr, suspbarf bit (1) aligned, sx fixed bin, symbolx fixed bin, symtab_len fixed bin, ten_digits picture "(9)z9", this_rho fixed bin, type bit (9) aligned; /* internal static */ dcl MaxSegSize fixed binary (21) internal static initial (65535); /* used to be in apl_number_data.incl.pl1 */ /* based */ dcl arg_string char (arg_len) based (arg_ptr), inpath char (inpath_arg_len) based (inpath_arg_ptr), outpath char (outpath_arg_len) based (outpath_arg_ptr), s360_trtbl (0:99999) fixed bin (21) based (s360_trtblptr), saved_bead_table (saved_bead_count) ptr unal based (saved_bead_table_ptr); /* builtins */ dcl (abs, addr, addrel, baseno, baseptr, bin, binary, bit, copy, divide, fixed, length, ltrim, maxlength, mod, null, ptr, rel, size, string, substr, unspec) builtin; /* conditions */ dcl cleanup condition; /* entries */ dcl com_err_ entry options (variable), (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)), convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)), apl_zcode_to_ascii_ entry (char (*), char (*)), dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)), expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)), get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)), ioa_ entry options (variable), ioa_$nnl entry options (variable), ioa_$rsnnl entry options (variable), msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)), msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)), msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)), msf_manager_$close entry (ptr); /* external static */ dcl ( error_table_$badopt fixed bin (35), error_table_$too_many_args fixed bin (35), iox_$user_output ptr ) external static; /* internal static */ dcl myname char (17) internal static initial ("convert_tsoapl_ws") options (constant); dcl EQUALS char (1) unal internal static initial ("=") options (constant); dcl NL char (1) varying internal static options (constant) init (" "); /* include files */ %include apl_number_data; %include tsoapl_dcls; /* program */ pathx = 0; outpath_arg_ptr = addr (EQUALS); outpath_arg_len = length (EQUALS); relock_functions = "0"b; arg_number = 1; call cu_$arg_ptr (arg_number, arg_ptr, arg_len, code); do while (code = 0); if substr (arg_string, 1, 1) ^= "-" then do; go to pathcase (pathx); pathcase (0): inpath_arg_ptr = arg_ptr; inpath_arg_len = arg_len; pathx = pathx + 1; go to end_pathcase; pathcase (1): outpath_arg_ptr = arg_ptr; outpath_arg_len = arg_len; pathx = pathx + 1; go to end_pathcase; pathcase (2): call com_err_ (error_table_$too_many_args, myname, "Maximum of 2 pathnames permitted."); go to usage; end_pathcase: end; else if arg_string = "-relock_functions" | arg_string = "-relock_function" then relock_functions = "1"b; else if arg_string = "-unlock_functions" | arg_string = "-unlock_function" then relock_functions = "0"b; else do; call com_err_ (error_table_$badopt, myname, "^a", arg_string); return; end; arg_number = arg_number + 1; call cu_$arg_ptr (arg_number, arg_ptr, arg_len, code); end; if pathx = 0 then do; usage: call com_err_ (code, myname, "Usage: ^a inpath {outpath} {-relock_functions|-unlock_functions}", myname); return; end; call expand_pathname_$add_suffix (inpath, "sv.tsoapl", dname, ename, code); if code ^= 0 then do; call com_err_ (code, myname, "^a", inpath); return; end; call hcs_$initiate_count (dname, ename, "", bitcount, 0, aplsv_ws_ptr, code); if aplsv_ws_ptr = null then do; call com_err_ (code, myname, "^a>^a", dname, ename); return; end; call expand_pathname_$add_suffix (outpath, "sv.apl", dname, ename1, code); if code ^= 0 then do; call com_err_ (code, myname, outpath); go to termin_finale; end; call get_equal_name_ ((ename), ename1, ename2, code); if code ^= 0 then do; call com_err_ (code, myname, arg_string); go to termin_finale; end; call msf_manager_$open (dname, ename2, fcbp, code); if fcbp = null then do; call com_err_ (code, myname, "^a>^a", dname, ename2); go to termin_finale; end; saved_bead_pointer = null (); curr_component = -1; curr_seglen = MaxSegSize + 2; saved_ws_info_pointer = allocate (size (saved_ws_info)); /* Get ball rolling */ /* Get 360 symbol table parameters */ qr13stk = cvb36f32 (aplsv_ws.qr13stk) / 4; qsymbot = cvb36f32 (aplsv_ws.qsymbot) / 4; aplsv_symtab_ptr = byteptr (aplsv_ws.qsymbot); symtab_len = (qr13stk - qsymbot) / size (symtbe); /* Allocate bead translation table */ on cleanup call release_temp_segments_ (myname, q, (0)); call get_temp_segments_ (myname, q, (0)); saved_bead_table_ptr = q (1); /* Set up 360 translate table */ s360_trtblptr = q (2); /* Count number of good symbols & allocate saved bead table */ suspbarf = "0"b; num_symbols = 0; do sx = 1 to symtab_len; type = aplsv_symtab (sx).type; if type ^= UNUSED_TYPE then if (type = VARIABLE_TYPE) | (type = FUNCTION_TYPE) | (type = FUNCTIONZ_TYPE) | (type = GROUP_TYPE) then num_symbols = num_symbols + 1; else if (type = SYSTEM_VAR_TYPE) | (type = SYSTEM_FCN_TYPE) then ; else if (type = SUSP_TEMPVAR_TYPE) then do; if ^suspbarf then call ioa_ ("^a: Warning: suspended functions and values of ^a not being restored.", myname, ename); suspbarf = "1"b; end; else call report_bad_symbol (addr (aplsv_symtab (sx))); end; symbolx = 0; saved_bead_count = num_symbols; /* Process good symbols */ do sx = 1 to symtab_len; type = aplsv_symtab (sx).type; if type ^= UNUSED_TYPE then if (type = VARIABLE_TYPE) | (type = FUNCTION_TYPE) | (type = FUNCTIONZ_TYPE) | (type = GROUP_TYPE) then call process_symbol (sx); end; /* Set up the parse frame and null latent expresson */ number_of_ptrs = 0; saved_frame_pointer = allocate (size (saved_pf)); saved_pf.current_line_number = 1; saved_pf.parse_frame_type = 1; /* SUSPENDED FRAME */ saved_pf.last_parse_frame_ptr = null; saved_ws_info.current_parse_frame_ptr = vp_ptr (saved_frame_pointer); number_of_dimensions = 1; saved_bead_pointer = allocate (size (saved_value_bead)); saved_ws_info.latent_expression = beadno (vp_ptr (saved_bead_pointer)); string (saved_value_bead.type) = character_value_type; saved_value_bead.size = bit (fixed (size (value_bead), 18), 18); saved_value_bead.total_data_elements = 0; saved_value_bead.rhorho = 1; saved_value_bead.data_pointer = null; saved_value_bead.rho (1) = 0; /* Allocate the master bead table */ bead_description_pointer = allocate (size (bead_description_table)); saved_ws_info.bead_table_pointer = vp_ptr (bead_description_pointer); bead_description_table.bead_pointer (*) = saved_bead_table (*); /* Fill in the workspace header. */ saved_ws_info.save_version = 4; saved_ws_info.lock = ""; saved_ws_info.highest_segment = curr_component; saved_ws_info.total_beads = saved_bead_count; saved_ws_info.number_of_symbols = num_symbols; saved_ws_info.integer_fuzz = 1.110223e-16; /* Multics default */ saved_ws_info.fuzz = 1e-13; ten_digits = cvb36f32 (aplsv_ws.library_number); saved_ws_info.wsid = ltrim (ten_digits) || " " || cv_ascii (substr (aplsv_ws.wsname.chars, 1, aplsv_ws.wsname.len)); saved_ws_info.float_index_origin = bin (aplsv_ws.index_origin, 17); saved_ws_info.random_link = cvb36f32 (aplsv_ws.seed); call convert_date_to_binary_ (cv_ascii (aplsv_ws.date_saved) || " 00:00", saved_ws_info.time_saved, (0)); saved_ws_info.time_saved = saved_ws_info.time_saved + fixed (1e6 * cvb36f32 (aplsv_ws.time_saved) / 3e2, 71); saved_ws_info.index_origin = bin (aplsv_ws.index_origin, 17); saved_ws_info.digits = cvb36f32 (aplsv_ws.digits); saved_ws_info.width = bin (cv_b18 (aplsv_ws.printing_width), 16); saved_ws_info.user_number = cvb36f32 (aplsv_ws.man_number); ten_digits = saved_ws_info.user_number; saved_ws_info.user_name = "TSO user " || ltrim (ten_digits); /* All done, close the workspace and quit */ call msf_manager_$adjust (fcbp, curr_component, curr_seglen * 36, "111"b, code); if code = 0 then call msf_manager_$close (fcbp); else call com_err_ (code, myname, "Problem in closing msf"); call release_temp_segments_ (myname, q, (0)); termin_finale: call hcs_$terminate_noname (aplsv_ws_ptr, code); return; abort: call release_temp_segments_ (myname, q, (0)); call hcs_$terminate_noname (aplsv_ws_ptr, code); call msf_manager_$close (fcbp); call delete_$path (dname, ename2, "100101"b, myname, code); return; process_symbol: procedure (bv_symdex); /* parameters */ dcl bv_symdex fixed bin; /* automatic */ dcl bit72 bit (72) aligned; dcl code bit (9); dcl cx fixed bin; dcl data_ptr ptr; dcl dtype fixed bin; dcl elmtct fixed bin; dcl f17un fixed bin (17) unaligned; dcl float_temp char (100) varying; dcl floatbin63 float bin (63); dcl fx35 fixed bin (35); dcl (j, k) fixed bin; dcl line char (3000) varying; dcl mulsym_ptr ptr; dcl nlines fixed bin; dcl space_state bit (1); dcl sx fixed bin; dcl ten_digits picture "(9)z9"; dcl varsymptr ptr; dcl vtemp char (1000) varying; /* based */ dcl based_elmtct_charcons char (elmtct) based (addr (fun_code.code (cx))); dcl cxa (0:99999) bit (36) aligned based (aplsv_ws_ptr); dcl funexp char (262143) based (q (3)) varying; /* program */ sx = bv_symdex; symtbep = addr (aplsv_symtab (sx)); mulsym_ptr = intern_360_sym (symtbep); aplsv_value_ptr = byteptr ("000"b3 || symtbe.value_offset); if symtbe.type = VARIABLE_TYPE then do; if symtbe.value_offset = "000000"b3 then return; /* intern did all work */ number_of_dimensions = cv_fb17 (aplsv_value.rhorho_x4) / 4; array_ptr = addr (aplsv_value.rho (number_of_dimensions + 1)); saved_bead_pointer = allocate (size (saved_value_bead)); mulsym_ptr -> saved_sb.meaning_pointer = beadno (vp_ptr (saved_bead_pointer)); saved_value_bead.rhorho = number_of_dimensions; data_elements = 1; do idx = 1 to number_of_dimensions; this_rho = binary (pack (aplsv_value.rho (idx))); saved_value_bead.rho (idx) = this_rho; data_elements = data_elements * this_rho; end; saved_value_bead.total_data_elements = data_elements; dtype = binary (aplsv_value.type, 9); (subrg): go to data_type (dtype); data_type (1): data_ptr = allocate (size (saved_boolean_datum)); do j = 1 to data_elements / 8; substr (data_ptr -> saved_boolean_datum, j * 8 - 7, 8) = bit_array.data (j); end; j = mod (data_elements, 8); if j ^= 0 then substr (data_ptr -> saved_boolean_datum, data_elements - j + 1) = bit_array.tail; saved_general_bead.size = bit (fixed (size (saved_boolean_datum), 18), 18); string (saved_general_bead.type) = zero_or_one_value_type; go to end_data_type; data_type (2): curr_seglen = curr_seglen + mod (curr_seglen, 2); data_ptr = allocate (size (numeric_datum)); string (saved_general_bead.type) = integral_value_type; saved_general_bead.size = bit (fixed (size (numeric_datum) + 1, 18), 18); do idx = 1 to data_elements; data_ptr -> numeric_datum (idx - 1) = binary (pack (fixed_array (idx))); end; go to end_data_type; data_type (3): curr_seglen = curr_seglen + mod (curr_seglen, 2); data_ptr = allocate (size (numeric_datum)); string (saved_general_bead.type) = numeric_value_type; saved_general_bead.size = bit (fixed (size (numeric_datum) + 1, 18), 18); do idx = 1 to data_elements; data_ptr -> numeric_datum (idx - 1) = cv_float (float_array (idx)); end; go to end_data_type; data_type (4): data_ptr = allocate (size (character_data_structure)); data_ptr -> character_string_overlay = cv_ascii (char_array); saved_general_bead.size = bit (fixed (size (character_string_overlay), 18), 18); string (saved_general_bead.type) = character_value_type; end_data_type: saved_general_bead.size = bit (fixed (size (value_bead) + fixed (saved_general_bead.size, 18), 18), 18); saved_value_bead.data_pointer = vp_ptr (data_ptr); end; else if symtbe.type = FUNCTION_TYPE | symtbe.type = FUNCTIONZ_TYPE then do; aplsv_function_ptr = aplsv_value_ptr; nlines = cv_fb17 (aplsv_function.nlines); funexp = ""; do idx = 0 to nlines - 1; /* the lines are built top-down, but each line is built right-to-left */ line = NL; if idx = 0 then code_ptr = byteptr ("000"b3 || aplsv_function.header_offset); else code_ptr = byteptr ("000"b3 || aplsv_function.line (idx).offset); code_len = cv_fb17 (fun_code.size); space_state = "0"b; /* Assume operator */ do cx = code_len to 1 by -1; code = fun_code.code (cx); if substr (code, 9, 1) = "1"b /* short syllable */ then do; if code = "003"b3 then ; /* unl sta */ else if code = "005"b3 then ; /* labeled sta */ else if code = CECONST | code = CBCONST | code = CICONST | code = CFCONST | code = CCCONST then do; if code = CCCONST then space_state = "0"b; else do; if space_state then call vput (" "); space_state = "1"b; end; elmtct = fixed (get_packs (2), 18); if code = CCCONST then do; /* chars */ cx = cx - elmtct; if fun_code.code (cx - 1) = "46"b4 || "1"b /* lamp/comment */ then vtemp = cv_ascii (based_elmtct_charcons); else vtemp = requote (cv_ascii (based_elmtct_charcons)); call vput (vtemp); end; else if code = CICONST then do; /* INTEGER */ vtemp = ""; do j = 1 to elmtct; fx35 = cvf32 (get_packs (4)); ten_digits = abs (fx35); if fx35 >= 0 then vtemp = ltrim (ten_digits); else do; vtemp = QUpperMinus; vtemp = vtemp || ltrim (ten_digits); end; if j ^= 1 then vtemp = vtemp || " "; call vput (vtemp); end; end; else if code = CBCONST then do; /* BOOLEAN */ j = cx - divide (elmtct + 7, 8, 17, 0); vtemp = ""; do k = 1 to elmtct; if mod (k, 8) = 1 then do; code = fun_code.code (j); j = j + 1; end; if k ^= 1 then vtemp = vtemp || " "; if substr (code, 2, 1) = "0"b then vtemp = vtemp || "0"; else vtemp = vtemp || "1"; code = substr (copy (code, 1), 2); end; call vput (vtemp); cx = cx - divide (elmtct + 7, 8, 17, 0); end; else if code = CFCONST | code = CECONST then do; /* FLOAT */ if code = CECONST then call com_err_ (0, myname, "ECONST encountered. Please call Bernard Greenberg, 617-492-9300" ); vtemp = ""; do j = 1 to elmtct; bit72 = get_packs (8); floatbin63 = cv_floatx (bit72); call ioa_$rsnnl ("^[^e^;^f^]", float_temp, 0, code = CECONST, abs (floatbin63)); if floatbin63 >= 0e0 then vtemp = float_temp; else do; vtemp = QUpperMinus; vtemp = vtemp || float_temp; end; if j ^= 1 then vtemp = vtemp || " "; call vput (vtemp); end; end; end; else if code = "007"b3 then ; /* dummy */ else do; /* zcode operator */ call vput (cv_asciich (substr (code, 1, 8))); space_state = "0"b; end; end; else if code = "000"b3 & fun_code.code (cx - 1) = "000"b3 then cx = cx - 1; else do; /* long syllable */ if space_state = "1"b then call vput (" "); unspec (f17un) = "11"b || substr (fun_code.code (cx - 1), 2) || substr (code, 2); cx = cx - 1; vtemp = get_symname (addr (cxa (qr13stk + f17un))); call vput (vtemp); space_state = "1"b; /* name/num */ end; end; funexp = funexp || line; end; data_elements = length (funexp); saved_bead_pointer = allocate (size (saved_fb)); mulsym_ptr -> saved_sb.meaning_pointer = beadno (vp_ptr (saved_bead_pointer)); string (saved_general_bead.type) = function_type; saved_general_bead.size = bit (fixed (size (function_bead), 18), 18); if relock_functions & (symtbe.type = FUNCTIONZ_TYPE) then saved_fb.class = 1; /* locked */ else saved_fb.class = 0; /* unlocked */ saved_fb.text_length = data_elements; saved_fb.text = funexp; end; else if symtbe.type = GROUP_TYPE then do; aplsv_group_ptr = aplsv_value_ptr; total_members = cv_fb17 (aplsv_group.count); saved_bead_pointer = allocate (size (saved_gb)); mulsym_ptr -> saved_sb.meaning_pointer = beadno (vp_ptr (saved_bead_pointer)); saved_general_bead.size = bit (fixed (size (group_bead) + total_members, 18), 18); /* UGH KLUDGE THANK LAMSON */ string (saved_general_bead.type) = group_type; saved_gb.number_of_members = total_members; do idx = 1 to total_members; varsymptr = byteptr (aplsv_group.symbp (idx)); mulsym_ptr = intern_360_sym (varsymptr); saved_gb.member (idx) = s360_trtbl (fixed (rel (varsymptr), 18)); end; end; return; /* Internal procedures for process_symbol */ vput: procedure (cs); /* parameters */ dcl cs char (*) varying; /* program */ if length (line) + length (cs) > maxlength (line) then do; call ioa_ ("^a: Buffer size exceeded.", myname); return; end; line = cs || line; end vput; get_packs: proc (n) returns (bit (*)); dcl n fixed bin; dcl btemp bit (100) varying; dcl j fixed bin; btemp = ""b; do j = cx - n to cx - 1 by 1; btemp = btemp || substr (fun_code.code (j), 2, 8); end; cx = cx - n; return (btemp); end get_packs; end process_symbol; allocate: proc (sz) returns (ptr); /* Master allocator */ dcl sz fixed bin; if curr_seglen + sz > MaxSegSize + 1 then do; curr_component = curr_component + 1; call msf_manager_$get_ptr (fcbp, curr_component, "1"b, segptrs (curr_component), (0), code); if segptrs (curr_component) = null then do; call com_err_ (code, myname, "Getting comp. #^d of msf.", curr_component); go to abort; end; call hcs_$truncate_seg (segptrs (curr_component), 0, code); if code ^= 0 then do; call com_err_ (code, myname, "Truncating new ws seg #^d.", curr_component); go to abort; end; curr_seglen = 0; end; curr_seglen = curr_seglen + sz; return (ptr (segptrs (curr_component), curr_seglen - sz)); end; vp_ptr: proc (pt) returns (ptr); /* cv ptr in CURRENT SEGMENT to virtual */ dcl pt ptr; return (ptr (baseptr (curr_component), rel (pt))); end; uvp_ptr: proc (pt) returns (ptr); /* Unvirtualize ptr */ dcl pt ptr; return (ptr (segptrs (binary (baseno (pt), 15)), rel (pt))); end; beadno: proc (vp) returns (fixed bin (21)); /* ASSIGN bead number */ dcl vp ptr; saved_bead_count = saved_bead_count + 1; saved_bead_table (saved_bead_count) = vp; return (saved_bead_count); beadno$symbol: entry (vp) returns (fixed bin (21)); symbolx = symbolx + 1; saved_bead_table (symbolx) = vp; return (symbolx); end; get_symname: proc (a_pt) returns (char (*)); dcl (pt, a_pt) ptr; pt = a_pt; if pt -> symtbe.size >= 4 then pt = addrel (byteptr ("000"b3 || pt -> symtbe.name_or_offset), 1); return (cv_ascii (pt -> symbol_struc.name)); end; requote: proc (instring) returns (char (*)); /* How difficult is PL/I for character string manipulation */ /* B. Greenberg 5/31/77 */ dcl instring char (*); dcl outstringl fixed bin (21); dcl QUOTE char (1) static init ("'") options (constant); dcl QUOTEQUOTE char (2) static init ("''") options (constant); dcl outstring char (2 * length (instring) + 2); dcl (i, j) fixed bin (21); dcl (index, length, substr) builtin; outstringl = 1; substr (outstring, 1, 1) = QUOTE; i = 1; nextj: j = index (substr (instring, i), QUOTE); if j = 0 then do; substr (outstring, outstringl + 1, length (instring) - i + 1) = substr (instring, i); outstringl = outstringl + length (instring) - i + 2; substr (outstring, outstringl, 1) = QUOTE; return (substr (outstring, 1, outstringl)); end; substr (outstring, outstringl + 1, j - 1) = substr (instring, i, j - 1); outstringl = outstringl + j; substr (outstring, outstringl, 2) = QUOTEQUOTE; outstringl = outstringl + 1; i = i + j; go to nextj; end; cv_asciich: proc (zc) returns (char (1) varying); dcl zc bit (8); dcl asc char (1); unspec (asc) = "0"b || zc; call apl_zcode_to_ascii_ ((asc), asc); return (asc); end; report_bad_symbol: procedure (P_symtabe_ptr); /* parameters */ declare P_symtabe_ptr ptr parameter; /* automatic */ declare symtabe_ptr ptr; /* program */ symtabe_ptr = P_symtabe_ptr; call ioa_ ("^a: Unknown symbol type ^2.4b hex for ""^a"".", substr (symtabe_ptr -> symtbe.type, 2), get_symname (symtabe_ptr)); call dumphex (symtabe_ptr, size (symtbe)); return; end report_bad_symbol; dumphex: proc (p, n); dcl p ptr, n fixed bin; call ioa_$nnl ("^p:", p); call dump_segment_ (iox_$user_output, p, 0, 0, n, "000001000010"b /*"0102"b3 */); end; intern_360_sym: proc (s360sp) returns (ptr); dcl s360relo fixed bin (18); dcl savep ptr init (saved_bead_pointer); dcl s360sp ptr; s360relo = fixed (rel (s360sp), 18); if s360_trtbl (s360relo) = 0 then do; symbol_name_length = s360sp -> symtbe.size; saved_bead_pointer = allocate (size (saved_sb)); saved_sb.name_length = symbol_name_length; saved_sb.name = get_symname (s360sp); string (saved_general_bead.type) = symbol_type; saved_general_bead.size = bit (fixed (size (symbol_bead), 18), 18); s360_trtbl (s360relo) = beadno$symbol (vp_ptr (addr (saved_sb))); end; saved_bead_pointer = savep; return (uvp_ptr ((saved_bead_table (s360_trtbl (s360relo))))); end; /* include files */ %include apl_symbol_bead; %include apl_value_bead; %include apl_function_bead; %include apl_saved_ws; %include apl_bead_format; %include apl_operator_bead; %include apl_group_bead; %include apl_characters; end;  display_tsoapl_ws.pl1 09/24/84 1339.5rew 09/24/84 1247.6 129195 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ display_tsoapl_ws: dtw: procedure; /* Started by Paul Green */ /* Brought to fruition by Bernard Greenberg, 10/77, features galore. */ /* Modified 771208 by PG to display library_number and man_number */ /* Modified 781005 by PG to fix bug 347 in declaration of function line offsets */ /* Modified 840907 by C Spitzer. correct length of format string passed to dump_segment_ */ /* automatic */ dcl arg_len fixed bin (21), aoutsw ptr, arg_ptr ptr, bitcount fixed bin (24), code fixed bin (35), dname char (168), ename char (32), idx fixed bin, long_option bit (1) aligned, rhorho fixed bin, this_rho fixed bin, qr13stk fixed bin, qsymbot fixed bin, symtab_len fixed bin, dtype fixed bin, sx fixed bin, temp_time fixed bin (71), temp_timec char (24); /* based */ dcl arg_string char (arg_len) based (arg_ptr); /* builtins */ dcl (addr, addrel, bin, binary, copy, divide, fixed, maxlength, mod, null, size, substr, translate, unspec) builtin; /* entries */ dcl com_err_ entry options (variable), convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)), date_time_ entry (fixed bin (71), char (*)), apl_zcode_to_ascii_ entry (char (*), char (*)), dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), ioa_ entry options (variable), ioa_$ioa_switch entry options (variable), ioa_$ioa_switch_nnl entry options (variable), ioa_$nnl entry options (variable), ioa_$rsnnl entry options (variable), iox_$look_iocb entry (char (*), ptr, fixed bin (35)); /* external static */ dcl iox_$user_output ptr ext; dcl error_table_$badopt fixed bin (35) ext; /* internal static */ dcl my_name char (17) internal static initial ("display_tsoapl_ws"); /* include files */ %include apl_characters; %include apl_number_data; %include tsoapl_dcls; /* program */ call iox_$look_iocb ("aplout", aoutsw, code); if code ^= 0 then aoutsw = iox_$user_output; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "Usage: display_tsoapl_ws path"); return; end; call expand_pathname_$add_suffix (arg_string, "sv.tsoapl", dname, ename, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; call hcs_$initiate_count (dname, ename, "", bitcount, 0, aplsv_ws_ptr, code); if aplsv_ws_ptr = null then do; call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; qr13stk = cvb36f32 (aplsv_ws.qr13stk)/4; qsymbot = divide (binary (pack (aplsv_ws.qsymbot)), 4, 20, 0); call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code = 0 then if arg_string = "-lg" | arg_string = "-long" then long_option = "1"b; else do; call com_err_ (error_table_$badopt, my_name, arg_string); go to finale; end; else long_option = "0"b; if long_option then do; call ioa_ ("name:^-^d ^a", cvb36f32 (aplsv_ws.library_number), cv_ascii (substr (aplsv_ws.wsname.chars, 1, aplsv_ws.wsname.len))); call convert_date_to_binary_ (cv_ascii (aplsv_ws.date_saved) || " 00:00", temp_time, code); temp_time = temp_time + fixed (1e6 * cvb36f32 (aplsv_ws.time_saved)/3e2, 71); call date_time_ (temp_time, temp_timec); call ioa_ ("saved:^-^a", temp_timec); call ioa_ ("saved by:^-^d", cvb36f32 (aplsv_ws.man_number)); call ioa_ ("fuzz:^-^w", aplsv_ws.fuzz); call ioa_ ("index origin:^-^d", cvb36f32 (aplsv_ws.index_origin)); call ioa_ ("seed:^-^d", cvb36f32 (aplsv_ws.seed)); call ioa_ ("digits:^-^d", cvb36f32 (aplsv_ws.digits)); call ioa_ ("width:^-^d", bin (cv_b18 (aplsv_ws.printing_width), 16)); call ioa_ (""); call ioa_ ("qsymbot:^-^w", qsymbot); call ioa_ ("qr13stk:^-^w", qr13stk); call ioa_ ("mx:^-^w", divide (cvb36f32 (aplsv_ws.mx), 4, 20, 0)); call ioa_ ("svi:^-^w", divide (cvb36f32 (aplsv_ws.svi), 4, 20, 0)); call ioa_ (""); end; aplsv_symtab_ptr = byteptr (aplsv_ws.qsymbot); symtab_len = (qr13stk - qsymbot)/size (symtbe); do sx = 1 to symtab_len; if aplsv_symtab (sx).type ^= UNUSED_TYPE then call process_symbol (sx); end; finale: call hcs_$terminate_noname (aplsv_ws_ptr, code); return; process_symbol: procedure (bv_symdex); /* parameters */ dcl bv_symdex fixed bin; /* automatic */ dcl nlabels_w_nargs fixed bin; dcl nlines fixed bin; dcl sx fixed bin; dcl code bit (9); dcl cx fixed bin; dcl space_state bit (1); dcl f17un fixed bin (17) unaligned; dcl bit72 bit (72) aligned; dcl elmtct fixed bin; dcl (i, j, k) fixed bin; dcl fx35 fixed bin (35); dcl varsymptr ptr; dcl funexp char (5000) varying; dcl vtemp char (100) varying; /* based */ dcl based_elmtct_charcons char (elmtct) based (addr (fun_code.code (cx))); dcl cxa (0:99999) bit (36) aligned based (aplsv_ws_ptr); /* program */ sx = bv_symdex; symtbep = addr (aplsv_symtab (sx)); if symtbe.value_offset = ""b /* ignore names with no value */ then return; aplsv_value_ptr = byteptr ("000"b3 || symtbe.value_offset); if symtbe.type = VARIABLE_TYPE then do; rhorho = divide (cv_fb17 (aplsv_value.rhorho_x4), 4, 21, 0); array_ptr = addr (aplsv_value.rho (rhorho + 1)); data_elements = 1; do idx = 1 to rhorho; this_rho = cvb36f32 (aplsv_value.rho (idx)); data_elements = data_elements * this_rho; end; funexp = get_symname (symtbep) || cv_asciich ("15"b4); /* <- */ do idx = 1 to rhorho; if idx ^= 1 then funexp = funexp || " "; call ioa_$rsnnl ("^d", vtemp, 0, cvb36f32 (aplsv_value.rho (idx))); funexp = funexp || vtemp; end; call ioa_$ioa_switch_nnl (aoutsw, "^a ^[^a ^;^s^]", funexp, rhorho ^= 0, cv_asciich ("2D"b4)); /* rho */ dtype = binary (aplsv_value.type, 9); if dtype < 1 | dtype > 4 then do; call ioa_$nnl ("Bad data type: ^d: ", dtype); call dumphex (aplsv_value_ptr, 16); go to badsym; end; go to data_type (dtype); data_type (1): do j = 1 to data_elements/8; do k = 1 to 8; call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^b", ^(j = 1 & k = 1), substr (bit_array.data (j), k, 1)); end; end; do k = 1 to mod (data_elements, 8); call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^b", ^(k = 1 & data_elements < 8), substr (bit_array.tail, k, 1)); end; go to end_data_type; data_type (2): do idx = 1 to data_elements; call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^d", idx ^= 1, binary (pack (fixed_array (idx)))); end; go to end_data_type; data_type (3): do idx = 1 to data_elements; call ioa_$ioa_switch_nnl (aoutsw, "^[ ^]^e", idx ^= 1, cv_float (float_array (idx))); end; go to end_data_type; data_type (4): call ioa_$ioa_switch_nnl (aoutsw, "^a^/", requote (cv_ascii (char_array))); end_data_type: call ioa_$ioa_switch_nnl (aoutsw, "^/"); end; else if symtbe.type = FUNCTION_TYPE | symtbe.type = FUNCTIONZ_TYPE then do; aplsv_function_ptr = aplsv_value_ptr; nlines = cv_fb17 (aplsv_function.nlines); nlabels_w_nargs = cv_fb17 (aplsv_function.nlabels_w_nargs); do idx = 0 to nlines - 1; funexp = ""; /* Init varying output */ if idx = 0 then code_ptr = byteptr ("000"b3 || aplsv_function.header_offset); else code_ptr = byteptr ("000"b3 || aplsv_function.line (idx).offset); code_len = cv_fb17 (fun_code.size); if idx = 0 then call ioa_$ioa_switch_nnl (aoutsw, "^p^-", addr (fun_code.size)); else call ioa_$ioa_switch_nnl (aoutsw, "^p^-[^2d] ", addr (fun_code.size), idx); space_state = "0"b; /* Assume operator */ do cx = code_len to 1 by -1; code = fun_code.code (cx); if substr (code, 9, 1) = "1"b /* short syllable */ then do; if code = "003"b3 then; /* unl sta */ else if code = "005"b3 then; /* labeled sta */ else if code = CECONST | code = CBCONST | code = CICONST | code = CFCONST | code = CCCONST then do; if code = CCCONST then space_state = "0"b; else do; if space_state then call vput (" "); space_state = "1"b; end; elmtct = fixed (get_packs (2), 18); if code = CCCONST then do; /* chars */ cx = cx - elmtct; if fun_code.code (cx - 1) = "46"b4 || "1"b /* lamp/comment */ then call vput (cv_ascii (based_elmtct_charcons)); else call vput (requote (cv_ascii (based_elmtct_charcons))); end; else if code = CICONST then do; /* integer, fullword */ do j = 1 to elmtct; fx35 = cvf32 (get_packs (4)); call ioa_$rsnnl ("^d^[ ^]", vtemp, 0, fx35, j ^= 1); vtemp = translate (vtemp, QUpperMinus, "-"); call vput ((vtemp)); end; end; else if code = CBCONST then do; /* BOOLEAN */ j = cx - divide (elmtct+ 7, 8, 17, 0); vtemp = ""; do k = 1 to elmtct; if mod (k, 8) = 1 then do; code = fun_code.code (j); j = j + 1; end; if k ^= 1 then vtemp = vtemp || " "; if substr (code, 2, 1) = "0"b then vtemp = vtemp || "0"; else vtemp = vtemp || "1"; code = substr (copy (code, 1), 2); end; call vput ((vtemp)); cx = cx - divide (elmtct + 7, 8, 17, 0); end; else if code = CFCONST | code = CECONST then do; do j = 1 to elmtct; bit72 = get_packs (8); call ioa_$rsnnl ("^[^e^;^f^]^[ ^]", vtemp, 0, code = CECONST, cv_floatx (bit72), j ^= 1); vtemp = translate (vtemp, QUpperMinus, "-"); call vput ((vtemp)); end; end; end; else if code = "007"b3 then; /* dummy */ else do; /* zcode operator */ call vput (cv_asciich (substr (code, 1, 8))); space_state = "0"b; end; end; else if code = "000"b3 & fun_code.code (cx - 1) = "000"b3 then cx = cx - 1; else do; /* long syllable */ if space_state = "1"b then call vput (" "); unspec (f17un) = "11"b || substr (fun_code.code (cx - 1), 2) || substr (code, 2); cx = cx - 1; call vput (get_symname (addr (cxa (qr13stk + f17un)))); space_state = "1"b; /* name/num */ end; end; if idx = 0 then do; call vput (cv_asciich ("9B"b4) || " "); /* del */ end; if length (funexp) = maxlength (funexp) then call ioa_$ioa_switch (aoutsw, "Function too big to convert. Max is ^d chars", maxlength (funexp)); call ioa_$ioa_switch_nnl (aoutsw, "^a^/", funexp); end; call ioa_$ioa_switch_nnl (aoutsw, "^-^a^/", cv_asciich ("9B"b4)); end; else if symtbe.type = GROUP_TYPE then do; call ioa_$ioa_switch_nnl (aoutsw, "^5x)group ^a", get_symname (symtbep)); aplsv_group_ptr = aplsv_value_ptr; do i = 1 to cv_fb17 (aplsv_group.count); varsymptr = byteptr (aplsv_group.symbp (i)); call ioa_$ioa_switch_nnl (aoutsw, " ^a", get_symname (varsymptr)); end; call ioa_$ioa_switch_nnl (aoutsw, "^/"); end; else if symtbe.type = SYSTEM_VAR_TYPE then; else if symtbe.type = SYSTEM_FCN_TYPE then; else do; call ioa_$nnl ("Unknown symbol type: ^2.4b. ", substr (symtbe.type, 2)); badsym: call ioa_ ("Losing symbol is ""^a""", get_symname (symtbep)); call dumphex (addr (symtbe), size (symtbe)); end; return; vput: proc (cs); dcl cs char (*); funexp = cs || copy (funexp, 1); end vput; get_packs: proc (n) returns (bit (*)); dcl n fixed bin; dcl btemp bit (100) varying; dcl j fixed bin; btemp = ""b; do j = cx - n to cx - 1 by 1; btemp = btemp || substr (fun_code.code (j), 2, 8); end; cx = cx - n; return (btemp); end get_packs; end process_symbol; get_symname: proc (a_pt) returns (char (*)); dcl (pt, a_pt) ptr; pt = a_pt; if pt -> symtbe.size >= 4 then pt = addrel (byteptr ("000"b3 || pt -> symtbe.name_or_offset), 1); return (cv_ascii (pt -> symbol_struc.name)); end; requote: proc (instring) returns (char (*)); /* How difficult is PL/I for character string manipulation */ /* B. Greenberg 5/31/77 */ dcl instring char (*); dcl outstringl fixed bin (21); dcl QUOTE char (1) static init ("'") options (constant); dcl QUOTEQUOTE char (2) static init ("''") options (constant); dcl outstring char (2 * length (instring) + 2); dcl (i, j) fixed bin (21); dcl (index, length, substr) builtin; outstringl = 1; substr (outstring, 1, 1) = QUOTE; i = 1; nextj: j = index (substr (instring, i), QUOTE); if j = 0 then do; substr (outstring, outstringl + 1, length (instring) - i + 1) = substr (instring, i); outstringl = outstringl + length (instring) - i + 2; substr (outstring, outstringl, 1) = QUOTE; return (substr (outstring, 1, outstringl)); end; substr (outstring, outstringl + 1, j - 1) = substr (instring, i, j - 1); outstringl = outstringl + j; substr (outstring, outstringl, 2) = QUOTEQUOTE; outstringl = outstringl + 1; i = i + j; go to nextj; end; cv_asciich: proc (zc) returns (char (1)); dcl zc bit (8); dcl asc char (1); unspec (asc) = "0"b || zc; call apl_zcode_to_ascii_ ((asc), asc); return (asc); end; dumphex: proc (p, n); dcl p ptr, n fixed bin; call ioa_$nnl ("^p:", p); call dump_segment_ (iox_$user_output, p, 0, 0, n, "000001000010"b /* "0102"b3 */); end; end;  read_tsoapl_tape.pl1 08/12/81 2123.1r 08/08/81 1600.1 119565 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* READ_TSOAPL_TAPE - Program to read in an IBM tape created by APLUTIL (at MIT) or APL/DOS. These tapes have a 144 byte workspace header record, followed by as many 10000 byte records as necessary to hold the workspace. To increase the maximum tape record size, change the variable TPMXL and the -bk argument in the attach description. */ read_tsoapl_tape: rtt: procedure; /* Written by Paul Green */ /* Changed for tape_nstd_, name args by B. Greenberg 10/77 */ /* Modified 771122 by PG to use correct maximum tape record length (10000 bytes). */ /* Modified 771201 by PG to set remaining_bytes to maximum before every workspace. */ /* Modified 771208 by PG to put library_number in workspace name. */ /* Modified 780811 by PG to permit density to be specified. */ /* automatic */ dcl arg_count fixed bin, argno fixed bin, arg_len fixed bin (21), arg_ptr ptr, attach_desc char (128) varying, bitcount fixed bin (24), buff_offset fixed bin (21), buff_ptr ptr, bytes_read fixed bin (21), bytes_to_read fixed bin (21), code fixed bin (35), density char (4) varying, dname char (168), ename char (32), end_of_tape bit (1) aligned, file_found (10) bit (1) aligned, fileno fixed bin, filenames (10) char (15), i fixed bin, listopt bit (1) init ("0"b), input_iocb_ptr ptr, n_words fixed bin (18), nfiles fixed bin, record_length fixed bin (21), record_number fixed bin, remaining_bytes fixed bin (21), tapename char (16) varying, ws_number fixed bin, ws_ptr ptr; /* based */ dcl arg_string char (arg_len) based (arg_ptr), buffer (0:1044479) char (1) based (buff_ptr); /* builtins */ dcl (addr, binary, divide, hbound, ltrim, min, null, rtrim, substr, translate) builtin; /* conditions */ dcl cleanup condition; /* entries */ dcl com_err_ entry options (variable), apl_zcode_to_ascii_ entry (char (*), char (*)), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin), cu_$arg_count entry (fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), get_wdir_ entry () returns (char (168)), ioa_ entry options (variable), hcs_$delentry_seg entry (ptr, fixed bin (35)), hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)), iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)), iox_$close entry (ptr, fixed bin (35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$detach_iocb entry (ptr, fixed bin (35)), iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); /* external static */ dcl (error_table_$badopt, error_table_$tape_error, error_table_$too_many_files, error_table_$noarg, error_table_$long_record, error_table_$end_of_info) fixed bin (35) external static; /* internal static */ dcl my_name char (16) aligned internal static initial ("read_tsoapl_tape") options (constant); dcl TPMXL fixed bin init (10000) static options (constant); /* include files */ %include apl_characters; %include iox_modes; /* program */ input_iocb_ptr = null; ws_ptr = null; dname = get_wdir_ (); attach_desc = ""; fileno = 0; nfiles = 0; file_found (*) = "0"b; tapename = ""; density = "1600"; /* default value */ call cu_$arg_count (arg_count); if arg_count = 0 then do; call com_err_ (0, my_name, "Usage: ^a tapename [filenames]", my_name); return; end; do argno = 1 to arg_count; call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if arg_string = "-atd" | arg_string = "-attach_description" then do; argno = argno + 1; call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "Attach description expected."); return; end; attach_desc = arg_string; end; else if arg_string = "-list" | arg_string = "-ls" then listopt = "1"b; /* busted else if arg_string = "-number" | arg_string = "-nb" then do; argno = argno + 1; call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "File number expected."); return; end; fileno = cv_dec_check_ (arg_string, code); if code ^= 0 then do; call com_err_ (0, my_name, "Bad numeric arg: ^a", arg_string); return; end; end; */ else if arg_string = "-den" | arg_string = "-density" then do; argno = argno + 1; call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "Density value of 200, 556, 800, or 1600 expected."); return; end; if arg_string ^= "200" & arg_string ^= "556" & arg_string ^= "800" & arg_string ^= "1600" then do; call com_err_ (0, my_name, "Invalid density ^a. Permissible values are 200, 556, 800, or 1600.", arg_string); return; end; density = arg_string; end; else if substr (arg_string, 1, 1) = "-" then do; call com_err_ (error_table_$badopt, my_name, "^a", arg_string); return; end; else do; if argno = 1 then tapename = arg_string; else do; if nfiles >= hbound (filenames, 1) then do; call com_err_ (error_table_$too_many_files, my_name, "Max is ^d workspaces.", hbound (filenames, 1)); return; end; nfiles = nfiles + 1; filenames (nfiles) = arg_string; end; end; end; if attach_desc = "" & tapename = "" then do; call com_err_ (error_table_$noarg, my_name, "Neither attach desc nor tape name given."); return; end; if attach_desc = "" then attach_desc = "tape_nstd_ " || tapename || " -bk 10000"; /* 10000 is biggest tape record. */ on cleanup call clean_up; call iox_$attach_ioname ("apl_tape_input_", input_iocb_ptr, (attach_desc), code); if code ^= 0 then do; call com_err_ (code, my_name, "Trying to attach I/O switch."); return; end; call iox_$open (input_iocb_ptr, Sequential_input, "0"b, code); if code ^= 0 then do; call com_err_ (code, my_name, "Trying to open I/O switch for sequential input."); call clean_up; return; end; call iox_$control (input_iocb_ptr, "d" || density, null (), code); if code ^= 0 then do; call com_err_ (code, my_name, "Trying to set density to ^a bpi.", density); call clean_up; return; end; call iox_$control (input_iocb_ptr, "nine", null(), code); if code ^= 0 then do; call com_err_ (code, my_name, "Trying to set nine mode."); call clean_up; return; end; call ioa_ ("Begin processing of ^a at ^a bpi.", tapename, density); call skip_file; record_number = 0; ws_number = 0; end_of_tape = "0"b; do while (^end_of_tape); call do_workspace; if fileno > 0 then end_of_tape = "1"b; end; do i = 1 to nfiles; if ^file_found (i) then call com_err_ (0, my_name, "File ^a not found.", filenames (i)); end; call clean_up; return; abort: call ioa_ ("Tape reading aborted at record ^d.", record_number); return_from_main: call clean_up; return; do_workspace: procedure; /* automatic */ declare new_ename char (32), this_file_name char (32), this_library_number fixed bin, ten_digits picture "(9)z9"; /* based */ dcl 1 ws_header aligned based (ws_ptr), 2 pad1 (32) bit (36), 2 qr13stk bit (36), 2 qsymbot bit (36), 2 mx bit (36), 2 svi bit (36), 2 pad2 (21) bit (36), 2 library_number bit (36), 2 name, 3 len fixed bin (8) unal, 3 chars char (11) unal; /* program */ ws_ptr, buff_ptr = get_ws_seg (); call iox_$read_record (input_iocb_ptr, buff_ptr, min (remaining_bytes, TPMXL), record_length, code); if code ^= 0 then if code = error_table_$end_of_info then do; end_of_tape = "1"b; return; end; else do; call com_err_ (code, my_name, "While reading workspace header."); go to abort; end; record_number = record_number + 1; if record_length ^= 144 then do; call ioa_ ("Tape not in expected format: first record of workspace not 144 bytes long."); go to abort; end; bytes_read = record_length; buff_offset = record_length; bytes_to_read = binary (pack (ws_header.mx)); remaining_bytes = remaining_bytes - record_length; call fill_buffer; bytes_read = 0; buff_offset = binary (pack (ws_header.svi)); bytes_to_read = binary (pack (ws_header.qr13stk), 22) - binary (pack (ws_header.svi), 22) + 1000; call fill_buffer; bitcount = (buff_offset + bytes_read) * 9; n_words = divide (bitcount + 35, 36, 24, 0); call apl_zcode_to_ascii_ (substr (ws_header.name.chars, 1, ws_header.name.len), this_file_name); this_file_name = translate (this_file_name, "dD", QDelta || QDelta_); this_library_number = binary (pack (ws_header.library_number)); if substr (this_file_name, 1, 11) = "PLDIRECTORY" then return; /* ignore useless APLDIRECTORY */ ws_number = ws_number + 1; if nfiles > 0 then do; do i = 1 to nfiles; if this_file_name = filenames (i) then do; call list_file; file_found (i) = "1"b; go to yes_save_this_file; end; end; return; end; call list_file; yes_save_this_file: if listopt then return; ten_digits = this_library_number; new_ename = rtrim (this_file_name) || ".lib" || ltrim (ten_digits) || ".sv.tsoapl"; call hcs_$chname_seg (ws_ptr, ename, new_ename, code); if code ^= 0 then call com_err_ (code, my_name, "Cannot rename ^a>^a to ^a", dname, ename, new_ename); call hcs_$truncate_seg (ws_ptr, n_words, code); if code ^= 0 then call com_err_ (code, my_name, "Unable to truncate ^a>^a to ^d words.", dname, ename, n_words); call hcs_$set_bc_seg (ws_ptr, bitcount, code); if code ^= 0 then call com_err_ (code, my_name, "Unable to set bitcount of ^a>^a to ^d.", dname, ename, bitcount); call hcs_$terminate_noname (ws_ptr, code); buff_ptr, ws_ptr = null (); return; list_file: procedure; call ioa_ ("^3d ^7d ^a", ws_number, this_library_number, this_file_name); end list_file; end do_workspace; fill_buffer: procedure; buff_ptr = addr (ws_ptr -> buffer (buff_offset)); do while (bytes_read < bytes_to_read); call iox_$read_record (input_iocb_ptr, buff_ptr, min (remaining_bytes, TPMXL), record_length, code); if code ^= 0 then do; call com_err_ (code, my_name, "While reading record ^d.", record_number + 1); if code ^= error_table_$tape_error then go to abort; end; record_number = record_number + 1; /* Successfully read another record! */ bytes_read = bytes_read + record_length; buff_ptr = addr (buffer (record_length)); /* step over this record */ remaining_bytes = remaining_bytes - record_length; end; return; end fill_buffer; get_ws_seg: procedure returns (ptr); dcl get_wdir_ entry () returns (char (168)); dcl unique_chars_ entry (bit (*)) returns (char (15)); if ws_ptr = null then do; dname = get_wdir_ (); ename = unique_chars_ ("0"b); call hcs_$make_seg (dname, ename, "", 1010b, ws_ptr, code); if ws_ptr = null then do; call com_err_ (code, my_name, "Cannot create ^a>^a", dname, ename); go to return_from_main; end; end; call hcs_$truncate_seg (ws_ptr, 0, code); if code ^= 0 then do; call com_err_ (code, my_name, "Unable to zero-truncate ^a>^a", dname, ename); go to return_from_main; end; remaining_bytes = 1044480; return (ws_ptr); end get_ws_seg; pack: procedure (aplsv_word) returns (bit (36) aligned); /* parameters */ dcl aplsv_word bit (36) aligned; /* automatic */ dcl word bit (36) aligned; /* program */ word = ""b; substr (word, 5, 8) = substr (aplsv_word, 2, 8); substr (word, 13, 8) = substr (aplsv_word, 11, 8); substr (word, 21, 8) = substr (aplsv_word, 20, 8); substr (word, 29, 8) = substr (aplsv_word, 29, 8); return (word); end pack; clean_up: procedure; if ws_ptr ^= null then do; call hcs_$delentry_seg (ws_ptr, code); ws_ptr = null; end; call iox_$close (input_iocb_ptr, code); call iox_$detach_iocb (input_iocb_ptr, code); end; skip_file: proc; dcl tbuf char (4) aligned; code = error_table_$end_of_info - 1; do while (code ^= error_table_$end_of_info); call iox_$read_record (input_iocb_ptr, addr (tbuf), 4, (0), code); if code ^= 0 & code ^= error_table_$end_of_info & code ^= error_table_$long_record then do; call com_err_ (code, my_name, "Error during file spacing."); go to return_from_main; end; end; end skip_file; 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