assign_type_d.pl1 10/03/83 1722.3rew 10/03/83 1005.3 12258 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ assign_type_d: proc(descriptor_bit,psp,picture_ptr,assign_type,scale_prec) options(support); dcl descriptor_bit bit(36) aligned, (picture_ptr,psp) ptr; dcl assign_type fixed bin(17), scale_prec fixed bin(35), 1 fo based(addr(scale_prec)) aligned, 2 scale fixed bin(17) unal, 2 prec fixed bin(17) unal; dcl (addr,addrel,fixed,unspec) builtin; dcl assign_type_p ext entry(ptr,fixed bin(17),fixed bin(35)); %include descriptor; %include pl1_stack_frame; %include plio2_ps; if descriptor_bit="0"b then do; picture_ptr = psp->ps.stack_frame_p; picture_ptr = picture_ptr->pl1_stack_frame.text_base_ptr; picture_ptr = addrel(picture_ptr,psp->ps.top_half); call assign_type_p(picture_ptr,assign_type,scale_prec); return; end; unspec(desc_) = descriptor_bit; assign_type = type_*2 + fixed(pack_,17,0); fo.scale = scale_; fo.prec = precision_; end assign_type_d;  assign_type_p.pl1 10/03/83 1722.3rew 10/03/83 1005.3 9342 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ assign_type_p: proc(p,assign_type,scale_prec) options(support); dcl p ptr; dcl assign_type fixed bin(17), scale_prec fixed bin(35), 1 fo based(addr(scale_prec)) aligned, 2 scale fixed bin(17) unal, 2 prec fixed bin(17) unal; dcl addr builtin; %include desc_types; %include picture_desc_; %include picture_image; assign_type = type(p->picture_image.type); fo.scale = p->picture_image.scale - p->picture_image.scalefactor; if assign_type=char_desc*2 then fo.prec = p->picture_image.varlength; else fo.prec = p->picture_image.prec; end assign_type_p;  decode_oldesc_.pl1 10/03/83 1722.3rew 10/03/83 1005.3 11817 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ decode_oldesc_: proc(old) returns(bit(36)aligned) options(support); dcl old bit(36) aligned; dcl 1 old_descriptor aligned, 2 old_type fixed bin(14) unal, 2 old_junk bit(3) unal, 2 old_decimal bit(1) unal, 2 old_scale fixed bin(7) unal, 2 old_precision fixed bin(8) unal; dcl (divide,unspec) builtin; %include desc_types; %include descriptor; unspec(old_descriptor) = old; unspec(desc_) = (36) "0"b; scale_ = old_scale; precision_ = old_precision; if old_decimal then do; type_ = D_fixed_real_desc + divide(old_type-1,2,17,0); goto ret; end; if old_type<=entry_desc then do; type_ = old_type; goto ret; end; if old_type>=518 & old_type<=522 then do; type_ = old_type-500; if type_=v_bit_desc | type_=char_desc then type_ = 41-type_; goto ret; end; ret: return(unspec(desc_)); end decode_oldesc_;  display_pl1io_error.pl1 10/03/83 1722.3rew 10/03/83 1005.3 71820 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ display_pl1io_error: dpe: procedure (); /* Modified 770829 by PG for read/write to stream files */ /* automatic */ dcl bad_job bit (36); dcl (psp, fsbp) ptr; dcl (i, j) fixed bin (15); dcl vs char (128) varying; dcl attribute_conflict bit (1) aligned; dcl bad_code bit (1) aligned; dcl pseudo_file bit (1) aligned; dcl file_name_string char (40) varying; /* builtins */ dcl (null, substr, length, string) builtin; /* entries */ dcl ioa_ entry external options (variable); dcl ioa_$nnl entry external options (variable); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); /* internal static */ dcl test_conflicts (20) bit (20) internal static init ( /* . zzvopiousnrsdixxskne */ /* . ooeprnuptoeeinxxtemn */ /* . ttreiptdrkcqrtxxvylv */ /* . snnupamerueexxaes */ /* . 2 tttt ydecr ldt */ "00000001001110001100"b, /* data */ "00000001001110001100"b, /* edit */ "00000001001110001100"b, /* list */ "00000011001111001100"b, /* get */ "00000101001110001100"b, /* put */ "00000101001110001100"b, /* page */ "00000001001110001100"b, /* line */ "00000001001110001100"b, /* skip */ "00001010000001000000"b, /* read */ "00000100000000000000"b, /* write */ "00001110100001000000"b, /* rewrite */ "00001110100001000000"b, /* delete */ "00001101100001000000"b, /* locate */ "00001000110001000000"b, /* key */ "00001010110011000000"b, /* keyto */ "00001100110001000000"b, /* keyfrom */ "00001010100001000000"b, /* set */ "00001010000001000000"b, /* into */ "00001010100011000000"b, /* ignore */ "00000100000000000000"b); /* from */ dcl switch_word (36) char (15) varying static internal init ("zot1 ", "zot2 ", "version2 ", "open ", "print ", "input ", "output ", "update ", "stream ", "notkeyed ", "record ", "sequential ", "direct ", "interactive ", "not_used_pos15 ", "not_used_pos16 ", "stringvalue ", "keyed ", "namelist ", "environment ", "end_of_file ", "transmit_error ", "buffer_in_use ", "copy ", "detach ", "te_hold ", "prelim_eof ", "internal ", "threaded ", "fsb_in_use ", "not_used_pos31 ", "emptyline ", "iox_close ", "not_used_pos34 ", "not_used_pos35 ", "not_used_pos36 "); dcl nono_word (18) char (12) varying static internal init ("lock ", "unlock ", "read ", "write ", "rewrite ", "delete ", "locate ", "key ", "keyto ", "keyfrom ", "set ", "into ", "ignore ", "from ", "nofrom ", "nokey ", "nokeyfrom ", "nolock"); dcl bad_job_word (20) char (12) varying static internal init ( "data ", "edit ", "list ", "get ", "put ", "page ", "line ", "skip ", "read ", "write ", "rewrite ", "delete ", "locate ", "key ", "keyto ", "keyfrom ", "set ", "into ", "ignore ", "from "); dcl switch_nonos (5:18) bit (14) internal static init ( /* . piousnrsdixxsk */ /* . rnuptoeeinxxte */ /* . iptdrkcqrtxxvy */ /* . nupamerueexxae */ /* . tttt ydecr ld */ ""b, /* print */ "1"b, /* input */ "01"b, /* output */ "011"b, /* update */ "0001"b, /* stream */ "00000"b, /* notkeyed */ "100010"b, /* record */ "0000100"b, /* sequential */ "00001101"b, /* direct */ "010100101"b, /* interactive */ "0000000000"b, /* notused */ "00000000000"b, /* notused */ "000010000100"b, /* stringvalue */ "0000110001000"b); /* keyed */ /* include files */ %include plio2_fsb; %include plio2_ps; /* program */ fsbp = plio2_data_$badfsbp; bad_job = plio2_data_$badjob; if fsbp = null then do; call ioa_ ("^/There was no error raised during PL/I i/o in this process."); return; end; pseudo_file = substr (bad_job, 2, 1); /* string option bit */ if pseudo_file then file_name_string = "^/Error on string option pseudo-file "; else file_name_string = "^/Error on file ^a"; call ioa_$nnl (file_name_string, fsb.filename); bad_job = substr (bad_job, 4, 8)||substr (bad_job, 16, 12)|| (16)"0"b; if fsb.lnzc > 0 & ^fsb.switch.stream then call show_code; /* stream errors are not generally associated with a system error */ else call ioa_ (""); /* because ioa_$nnl was used, we need a trailing new_line */ call show_fsb; if plio2_data_$undef_file_sw then do; attribute_conflict = "0"b; call ioa_$nnl ("Error in opening or closing ^a", fsb.filename); call show_badfile; if ^attribute_conflict then do; bad_code = "0"b; if fsb.switch.stream then call show_code; if ^bad_code then call ioa_ (""); /* insert the final trailing new-line */ end; end; else do; call show_job; call show_conflicts; end; return; show_fsb: proc; if fsb.filename ^= """get_string_option""" & fsb.filename ^= """put_string_option""" then call ioa_ ("Title: ^a", fsb.path_name); vs = "Attributes: "; call print_attributes ((string (fsb.switch))); if substr (fsb.declared_attributes (1), 4, 33) then if ^pseudo_file /* fake fsb's do not have a valid decl_attrs field */ then do; vs = "Permanent attributes: "; call print_attributes (fsb.declared_attributes (1)); end; return; end show_fsb; show_job: proc; if bad_job = "0"b then call ioa_ ("No i/o job found."); else do; vs = "Last i/o operation attempted: "; do i = 1 to 20; if substr (string (bad_job), i, 1) then vs = vs||bad_job_word (i); if length (vs)>65 then call print_vs; end; if length (vs) ^= 0 then call print_vs; end; return; end show_job; print_vs: proc; call ioa_ ("^a", vs); vs = ""; end print_vs; print_attributes: proc (bit_str); dcl bit_str bit (36) aligned; do i = 4 to 14, 16 to 20, 24, 28; if substr (string (bit_str), i, 1) then vs = vs||switch_word (i); if length (vs)>65 then call print_vs; end; if length (vs) ^= 0 then call print_vs; end print_attributes; show_code: proc; dcl c1 char (8) aligned; dcl c2 char (100) aligned; dcl c3 char (100) varying; call convert_status_code_ ((fsb.lnzc), c1, c2); c3 = c2; if length (c3)>0 then do; call ioa_ (", status code: ^a", c3); bad_code = "1"b; end; end show_code; show_conflicts: proc; do i = 1 to 20; if substr (bad_job, i, 1) then do; if string (fsb.switch)&test_conflicts (i) then do; vs = "Attempted """||bad_job_word (i)||""" operation conflicts with"; call print_vs; do j = 1 to 20; if substr (string (fsb.switch), j, 1)&substr (test_conflicts (i), j, 1) then do; vs = " file """||switch_word (j)||""" attribute."; j = 20; end; end; end; if vs ^= "" then call print_vs; end; end; end show_conflicts; show_badfile: proc; do i = 5 to 18; if substr (string (fsb.switch), i, 1) then do j = 5 to 18; if substr (switch_nonos (i), j-4, 1) & substr (string (fsb.switch), j, 1) then do; if ^attribute_conflict then call ioa_ (""); /* give trailing NL to last line */ call ioa_ ("The ^a attribute conflicts with the ^a attribute.", switch_word (i), switch_word (j)); attribute_conflict = "1"b; end; end; end; return; end show_badfile; end /* display_pl1io_error */;  pl1_io_.pl1 10/03/83 1722.3rew 10/03/83 1005.3 11619 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ pl1_io_: proc; return; /* pl1_io_: user-accessible interfaces to get PL/I I/O data */ /* Bernard Greenberg 12/20/76 */ dcl 1 file_variable aligned based, /* Declaration of any PL/I File Value */ 2 fab_ptr ptr, /* Pointer to File Attribute Block (FAB) */ 2 fsb_ptr ptr; /* Pointer to File State Block (FSB */ dcl a_file file variable; /* Argument File */ dcl 1 a_file_value like file_variable aligned based (addr (a_file)); /* Redeclaration of parameter. */ get_iocb_ptr: entry (a_file) returns (ptr); /* Return pointer to IOCB */ return (a_file_value.fsb_ptr -> fsb.iocb_p); error_code: entry (a_file) returns (fixed bin (35)); /* Return last non-zero error code. */ return (a_file_value.fsb_ptr -> fsb.lnzc); dcl fsbp ptr; /* Satisfy include file */ %include plio2_fsb; end;  plio2_data_.alm 10/03/83 1722.3rew 10/03/83 1005.3 13626 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " " plio2_data_ " " static stuff to be bound into PLIO2 " P.A.Belmont " 12-17-70 " updated 7-27-72 " " name plio2_data_ " segdef pspstat,fsbpstat,fabpstat,fab2pstat,pliostringfsbp segdef bs,ht,nl,cr,np segdef max_page_size segdef badfsbp segdef badjob segdef user_debug_plio_sw,spds,undef_file_sw segdef interconv_debug_sw,finalconv_debug_sw segdef pliostatswitch,ermsgsw,realsignalsw segdef get_data_debug_sw,put_data_debug_sw,real_signal_debug_sw " use linkc join /link/linkc " " even pspstat: its -1,1 fsbpstat: its -1,1 fabpstat: its -1,1 badfsbp: its -1,1 fab2pstat: its -1,1 pliostringfsbp: its -1,1 user_debug_plio_sw: dec 0 undef_file_sw: dec 0 badjob: dec 0 spds: dec 0 interconv_debug_sw: dec 0 finalconv_debug_sw: dec 0 pliostatswitch: dec 0 ermsgsw: dec 0 get_data_debug_sw: dec 0 put_data_debug_sw: dec 0 real_signal_debug_sw: dec 0 realsignalsw: dec 1 max_page_size: dec 34000000000 bs: oct 010000000000 ht: oct 011000000000 nl: oct 012000000000 cr: oct 015000000000 np: oct 014000000000 " " " end  plio2_debug_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 9909 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_debug_:proc options(support); % include plio2_ps; % include plio2_fsb; dcl (null, string) builtin; dcl (fsbp,psp,jobp) ptr; /* */ renew_cur:entry; jobp=plio2_data_$fsbpstat; goto work; renew: entry(sn,of); dcl (sn,of) char(*); dcl octptr entry(char(*),char(*)) returns(ptr); jobp=octptr(sn,of); goto work; work: /* closes and unthreads the JOB file */ fsbp=plio2_data_fsb_thread_; do while(fsbp^=null); if fsb.fsb_thread=jobp then do; fsb.fsb_thread=fsb.fsb_thread->fsb.fsb_thread; jobp->fsb.fsb_thread=null; string(jobp->fsb.switch)="0"b; return; end; fsbp=fsb.fsb_thread; end; return; end;  plio2_dnd_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 38619 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified: 05/01/78 by PCK to implement unsigned binary Modified: 9 August 1978 by PCK to fix 1768 Modified: 25 Apr 1979 by PCK to implement 4-bit decimal */ dnd:proc(d,p,code) options(support); dcl d bit(36) aligned, p ptr, code fixed bin(15); /* d is descriptor, p points at D_structure (see below), and code=1 for failure */ /* updated 5-4-71 */ dcl 1 D aligned based(q), /* this is the D_STRUCTURE ! ! ! */ 2 type5 aligned, 3 ( cr,bd,ff,ls,pack) char(1) unaligned, 2 ( precx, scalex, bit_lengthx, typex ) fixed bin(15); dcl ( prec, scale, bit_length,type ) fixed bin(15); dcl q ptr; dcl (addr, string, substr) builtin; dcl WS fixed bin(15); dcl fixed builtin; % include plio2_descriptor_forms; %include std_descriptor_types; /* START */ WS=0; common: q=p; desc_ptr=addr(d); code=0; if nd_first then do; type=fixed(nd_type,6,0); if type=0 then go to bad_type; if type > cplx_flt_dec_9bit_dtype & type < real_fix_dec_9bit_ls_overp_dtype then /* if not an arithmetic data type then */ do; if WS=0 then go to bad_type; if type < bit_dtype | type > varying_char_dtype then go to bad_type; /* if not a string data type then */ addr(D.type5)->based_char5=string_types(type - bit_dtype + 1); D.precx=fixed(substr(desc_ptr->based_bits,13,24),24,0); go to string_exit; end; if type <= cplx_flt_dec_9bit_dtype then addr(D.type5)->based_char5=types_table(type)||" "; else if type<=real_fix_bin_2_uns_dtype then addr(D.type5)->based_char5=types_table(type - real_fix_bin_1_uns_dtype + real_fix_bin_1_dtype) || " "; else addr(D.type5)->based_char5=types_table(type - real_fix_dec_4bit_bytealigned_ls_dtype + real_fix_dec_9bit_ls_dtype) || " "; prec=fixed(nd_prec,12,0); scale=fixed(nd_scale,12,0); if scale>100000000000b then scale=scale - 1000000000000b; if nd_pack then D.type5.pack="p"; if D.type5.bd="d" then do; if D.type5.ff="l" then bit_length=prec+2; else bit_length=prec+1; if type <= cplx_flt_dec_9bit_dtype then bit_length=bit_length*9; /* chars are 9 bits */ else bit_length=(bit_length+mod(bit_length,2))*4.5; /* 2 digits per character */ end; else do; if nd_pack then do; if D.type5.ff="l" then bit_length=prec+9; else if type <= real_fix_bin_2_dtype then bit_length = prec + 1; else bit_length = prec; end; else go to unpacked_binary; end; end; else do; type=fixed(od_type,15,0); if type=0 then do; /* descriptor="0"b is the signal for a pictured item */ string (D.type5) = "p "; return; end; if type>8 then do; if WS=0 then go to bad_type; if type>522|type<519 then go to bad_type; addr(D.type5)->based_char5=string_types(type-514); D.precx=fixed(substr(desc_ptr->based_bits,19,18),18,0); string_exit: if D.bd="b" then D.bit_lengthx=D.precx; else D.bit_lengthx=9*D.precx; return; end; prec=fixed(od_prec,9,0); scale=fixed(od_scale,8,0); if scale>10000000b then scale=scale-100000000b; addr(D.type5)->based_char5=types_table(type)||" "; unpacked_binary: if D.type5.ls="l" then bit_length=72; else bit_length=36; end; if prec>63 then do; if D.type5.bd="d" then goto bad_prec; if D.type5.ff="l" then goto bad_prec; if prec>71 then goto bad_prec; end; D.precx=prec; if scale>127 then goto bad_scale; if scale<-128 then goto bad_scale; D.scalex=scale; D.typex=type; D.bit_lengthx=bit_length; return; bad_prec: bad_scale: bad_type: code=1; return; with_strings:entry(d,p,code); WS=1; go to common; dcl string_types(8) char(4) static internal init( "sb n", /* 514 */ "sbvn", /* 520 */ "sc n", /* 524 */ "scvn", /* 530 */ "sb o", /* 01007 */ "sc o", /* 01010 */ "sbvo", /* 01011 */ "scvo" /* 01012 */ ); end;  plio2_dump_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 84762 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified 9 October 1980 by M. N. Davidoff to fix 1978 (doesn't compile because nono_word had wrong number of initial list elements). */ /* format: style3 */ plio2_dump_: procedure; /* parameters */ dcl OF char (*); dcl SN char (*); /* automatic */ dcl fsbp ptr; dcl i fixed bin; dcl psp ptr; /* based */ dcl fsb_buffer char (fsb.bsize) based (fsb.bptr); /* builtin */ dcl (hbound, length, low, max, maxlength, min, null, string, substr) builtin; /* entry */ dcl ioa_$ioa_switch entry options (variable); dcl octptr entry (char (*), char (*)) returns (ptr); /* internal static */ dcl switch_word (36) char (16) varying static internal options (constant) init ("zot(1)", "zot(2)", "version_2", "open", "print", "input", "output", "update", "stream", "notkeyed", "record", "sequential", "direct", "interactive", "not_used_1", "not_used_2", "stringvalue", "keyed", "namelist", "implementation", "not_used_4", "transmit_error", "buffer_in_use", "copy", "detach", "te_hold", "not_used_5", "internal", "threaded", "fsb_in_use", "console", "emptyline", "iox_close", "xxx4", "xxx5", "xxx6"); dcl nono_word (18) char (12) varying static internal options (constant) init ("bit_string", "not_used_3", "read", "write", "rewrite", "delete", "locate", "key", "keyto", "keyfrom", "set", "into", "ignore", "from", "nofrom", "nokey", "nokeyfrom", "nolock"); dcl job_word (36) char (16) varying static internal options (constant) init ("explicit_file", "string", "varying_string", "data", "edit", "list", "get", "put", "page", "line", "skip", "copy", "p1p2", "bit_string", "char_string", "read", "write", "rewrite", "delete", "locate", "key", "keyto", "keyfrom", "set", "into", "ignore", "from", "version(1)", "version(2)", "version(3)", "version(4)", "version(5)", "version(6)", "not_byte_buffer", "pad1", "packed_ptr"); dcl ps_switch_word (4) char (16) varying internal static options (constant) initial ("first_field", "file", "transmit_error", "semi_sep"); /* external static */ dcl iox_$error_output ptr external static; %include plio2_fsb; %include plio2_fsbr; %include plio2_ps; %include plio2_psr; /* program */ setfsbp: entry (SN, OF); plio2_data_$fsbpstat = octptr (SN, OF); return; setpsp: entry (SN, OF); plio2_data_$pspstat = octptr (SN, OF); return; filelist: entry; call ioa_$ioa_switch (iox_$error_output, "List of files open or opened:"); do fsbp = plio2_data_fsb_thread_ repeat fsbp -> fsb.fsb_thread while (fsbp ^= null); call ioa_$ioa_switch (iox_$error_output, "fspb: ^p, filename: ^a^[, open pathname: ^a^;^s^]", fsbp, fsb.filename, fsb.switch.open, fsb.path_name); end; call ioa_$ioa_switch (iox_$error_output, ""); return; dgfsb: entry (SN, OF); fsbp = octptr (SN, OF); goto dfsbcommon; dcfsb: entry; fsbp = plio2_data_$fsbpstat; dfsbcommon: call ioa_$ioa_switch (iox_$error_output, "fsbp: ^p", fsbp); if fsbp = null then return; call ioa_$ioa_switch (iox_$error_output, "filename: ^a", validate ((fsb.filename))); call ioa_$ioa_switch (iox_$error_output, "title: ^a", validate (fsb.title)); if fsb.filename ^= """get_string_option""" & fsb.filename ^= """put_string_option""" then call ioa_$ioa_switch (iox_$error_output, "pathname: ^a", validate (fsb.path_name)); call print_switches ("attributes", string (fsb.switch), switch_word); call ioa_$ioa_switch (iox_$error_output, "bsize: ^d, thread: ^p, DA: ^w", fsb.bsize, fsb.fsb_thread, fsb.declared_attributes (1)); if fsb.switch.record then do; call print_switches ("forbidden operations", string (fsb.nono), nono_word); call ioa_$ioa_switch (iox_$error_output, "^[^[Current record exists.^;Current record deleted.^]^;^sNo current record.^]", fsbr.recio.rec_exists, fsbr.recio.rec_valid); if fsbr.recio.buffer_used then call ioa_$ioa_switch (iox_$error_output, "buffer_used"); if fsbr.switch.keyed then call ioa_$ioa_switch (iox_$error_output, "key_saved: ""^v^a""", length (fsbr.key_saved), fsbr.key_saved); if fsbr.inbuf_sw.exists then do; call ioa_$ioa_switch (iox_$error_output, "inbuf_exists^[ free^]^[ in_use^]", fsbr.inbuf_sw.free, fsbr.inbuf_sw.use); call ioa_$ioa_switch (iox_$error_output, "max: ^d, cur: ^d, ptr: ^p", fsbr.inbuf_maxlen, fsbr.inbuf_curlen, fsbr.inbuf_ptr); end; else call ioa_$ioa_switch (iox_$error_output, "no inbuf"); if fsbr.outbuf_sw.exists then do; call ioa_$ioa_switch (iox_$error_output, "outbuf_exists^[ free^]^[ in_use^]", fsbr.outbuf_sw.free, fsbr.outbuf_sw.use); call ioa_$ioa_switch (iox_$error_output, "max: ^d, cur: ^d, ptr: ^p", fsbr.outbuf_maxlen, fsbr.outbuf_curlen, fsbr.outbuf_ptr); if fsbr.outbuf_sw.use & fsbr.switch.keyed then call ioa_$ioa_switch (iox_$error_output, "outbuf_key: ""^v^a""", length (fsbr.outbuf_key), fsbr.outbuf_key); end; else call ioa_$ioa_switch (iox_$error_output, "no outbuf"); end; else do; call ioa_$ioa_switch (iox_$error_output, "lsep: ^d, blc: ^d, bnc: ^d", fsb.lsep, fsb.blc, fsb.bnc); call ioa_$ioa_switch (iox_$error_output, "bptr: ^p, kol: ^d", fsb.bptr, fsb.kol); if fsb.switch.stream then call ioa_$ioa_switch (iox_$error_output, "limit: ^d", fsb.limit); if fsb.switch.output then call ioa_$ioa_switch (iox_$error_output, "lsize: ^d", fsb.lsize); if fsb.switch.print then call ioa_$ioa_switch (iox_$error_output, "lineno: ^d, pageno: ^d, psize: ^d", fsb.lineno, fsb.pageno, fsb.psize); i = min (max (fsb.blc, fsb.bnc - 1), 20); if i > 0 then call ioa_$ioa_switch (iox_$error_output, "buffer: ""^v^a""", i, substr (fsb_buffer, 1, i)); end; call ioa_$ioa_switch (iox_$error_output, ""); return; dgps: entry (SN, OF); psp = octptr (SN, OF); goto pscommon; dcps: entry; psp = plio2_data_$pspstat; pscommon: call ioa_$ioa_switch (iox_$error_output, "psp: ^p", psp); if psp = null then return; if ps.job.read | ps.job.write | ps.job.rewrite | ps.job.delete | ps.job.locate then do; call print_switches ("job", string (ps.job), job_word); call ioa_$ioa_switch (iox_$error_output, "keytemp: ^a", validate_vs (psr.keytemp)); call ioa_$ioa_switch (iox_$error_output, "var_p: ^p, set_p_p: ^p, source_p: ^p", psr.variable_p, psr.set_p_p, psr.source_p); call ioa_$ioa_switch (iox_$error_output, "number: ^d, variable_bitlen: ^d", psr.number, psr.variable_bitlen); call ioa_$ioa_switch (iox_$error_output, "file_p: ^p, fsbp: ^p, auxp: ^p, fabp: ^p, fab2p: ^p", psr.file_p, psr.fsbp, psr.auxp, psr.fabp, psr.fab2p); end; else do; call ioa_$ioa_switch (iox_$error_output, "sfp: ^p, STTp: ^p, STBp: ^p", ps.stack_frame_p, ps.ST_top_p, ps.ST_block_p); call ioa_$ioa_switch (iox_$error_output, "format_area_p: ^p, ss_list_p: ^p", ps.format_area_p, ps.ss_list_p); call ioa_$ioa_switch (iox_$error_output, "source_p: ^p, special_list_p: ^p, copy_file_p: ^p", ps.source_p, ps.special_list_p, ps.copy_file_p); call print_switches ("job", string (ps.job), job_word); call ioa_$ioa_switch (iox_$error_output, "number: ^d", ps.number); call ioa_$ioa_switch (iox_$error_output, "value_p: ^p, descriptor: ^w, length: ^d, offset: ^w", ps.value_p, ps.descriptor, ps.length, ps.offset); call ioa_$ioa_switch (iox_$error_output, "prep: ^d, new_format: ^d", ps.prep, ps.new_format); call print_switches ("ps.switch", substr (string (ps.switch), 1, hbound (ps_switch_word, 1)), ps_switch_word); call ioa_$ioa_switch (iox_$error_output, "file_p: ^p, fsbp: ^p, auxp: ^p", ps.file_p, ps.fsbp, ps.auxp); call ioa_$ioa_switch (iox_$error_output, "fabp: ^p, fab2p: ^p", ps.fabp, ps.fab2p); call ioa_$ioa_switch (iox_$error_output, "vp: ^p, descr: ^w, start_copy: ^d", ps.vp, ps.descr, ps.start_copy); end; call ioa_$ioa_switch (iox_$error_output, ""); return; print_switches: procedure (title, bits, names); dcl title char (*); dcl bits bit (*); dcl names (*) char (*) varying; dcl i fixed bin; dcl line char (72) varying; if bits = ""b then return; line = title || ":"; do i = 1 to length (bits); if substr (bits, i, 1) then if length (line) + 1 + length (names (i)) <= maxlength (line) then line = line || " " || names (i); else do; call ioa_$ioa_switch (iox_$error_output, "^a", line); line = (5)" " || names (i); end; end; call ioa_$ioa_switch (iox_$error_output, "^a", line); end print_switches; validate: procedure (str) returns (char (256) varying); dcl str char (*); if str = low (length (str)) then return ("Unset string."); else return (str); end validate; validate_vs: procedure (arg_str) returns (char (256) varying); dcl arg_str char (*) varying; if length (arg_str) > maxlength (arg_str) then return ("Unset string."); else return (arg_str); end validate_vs; end plio2_dump_;  plio2_fl_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 89604 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_fl_: fl_: fl:format_list:proc options(support); /* updated 73-11-8: picture formats added */ /* D E B U G I N F O (plio2_$)dcfi will turn on or turn off display mode (plio2_$)dcfi25 will display the next 25 formats obtained. */ % include plio_format_codes; %include picture_image; dcl 1 fb aligned based(fbxp), 2 bits, 3 code bit(9) unaligned, 3 nval bit(9) unaligned, 3 offset bit(18) unaligned, 2 rep fixed bin(35), 2 val(3) fixed bin(35); dcl 1 fx aligned based(flxp), 2 fe(3) , /* cur, two more for the complex case */ 3 type fixed bin(15), 3 nval fixed bin(15), 3 val(3) fixed bin(15), 2 cur_rep fixed bin(15), /* octal offset 17 */ 2 cur_sfp ptr, /* octal offset 20,21 */ 2 cur_fep ptr, 2 first_open_paren_sw bit(18), 2 stk_index fixed bin(15), 2 frame(10), /* push down for "(" in a format list */ 3 sf1p ptr, 3 sf2p ptr, 3 fe1p ptr, 3 fe2p ptr, 3 rep fixed bin(15), 3 type fixed bin(15); /* facts about the form of FORMAT LISTSs in object programs are given herein in passim */ dcl (pspp,fbxp,psp,flxp,blp,block_sym_tab_p,qq) ptr; dcl (indexlimit,irep,ival,realstype) fixed bin(35); dcl stu_$decode_runtime_value ext entry(fixed bin(35),ptr,ptr,ptr,ptr,ptr,fixed bin(35)) returns(fixed bin(35)); dcl stu_$remote_format ext entry(fixed bin(35),ptr,ptr,label) returns(fixed bin(35)); dcl flabel label; dcl icode fixed bin(35); dcl i fixed bin(15); dcl erno fixed bin(15); dcl bl(2) ptr based(blp); dcl based_int fixed bin (35) based; dcl ( addr,addrel,fixed,null,baseptr,baseno,rel,substr ) builtin; dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl (ioa_,ioa_$nnl) entry ext options(variable); dcl format_letters char(44) aligned static int init (" r c f e b a xskip colpageline"); dcl (dcfi_sw,dcfi_ct) fixed bin(15) static internal init(0); dcl node(5) based(p) fixed bin(15); dcl p ptr; dcl c4 char(4) aligned; % include plio2_ps; /* */ reset_:entry(pspp); psp=pspp; flxp=ps.format_area_p; ps.new_format=0; /* fx.fe(1) is the structure passed to get edit and put edit which contains the current fully evaluated format item. In the case of the complex format, if fe(1).nval=1 then fe(2) gives both real formats; if fe(1).nval=2 then fe(2) and fe(3) give the two real formats. */ fx.stk_index=1; fx.cur_rep=0; fx.cur_fep=ps.special_list_p; if fx.cur_fep->based_int^=0 then goto err196; /* Note: the compiled format list begins with a word of ZEROs to distinguish a format_label from any other label on the basis of the material pointed to by it. */ fx.frame(1).sf1p,fx.frame(1).fe1p=null; fx.frame(1).sf2p=ps.stack_frame_p; fx.frame(1).fe2p=addrel(ps.special_list_p,1); /* since first word is zeros */ return; /* GET GET */ get_next_:entry(pspp); /* gets next format item and leaves it, fully evaluated, in fe(1). REP factors are evaluated before any of the rest of the format item is examined. PARAMs are evaluated before EACH use of the item. */ psp=pspp; block_sym_tab_p=null; /* used in call to decode value, should be pointer to the ST for the block of the (remote) format. detail a little unsettled now, so I'll use NULL */ flxp=ps.format_area_p; if ps.p1p2 then indexlimit =6; else /* ordinary PL2 case */ indexlimit=10; /* */ test_rep: if fx.cur_rep>0 then do; fx.cur_rep=fx.cur_rep-1; if fx.fe(1).type=c_format then do; fx.fe(2).val(1)=0; /* compiler bug made fx.fe(2).val(*)=0 very costly */ fx.fe(2).val(2)=0; fx.fe(2).val(3)=0; fx.fe(3).val(1)=0; fx.fe(3).val(2)=0; fx.fe(3).val(3)=0; if fx.fe(1).nval <1 then goto err194; fbxp=addrel(fx.cur_fep,fx.fe(1).val(1)); if fx.fe(2).type = picture_format then call decode_picture_format(2); else do i=1 to fx.fe(2).nval; ival=fbxp->fb.val(i); if ival<0 then do; ival=stu_$decode_runtime_value (ival,block_sym_tab_p,fx.cur_sfp,null,null,null,icode); if icode^=0 then goto err195; end; fx.fe(2).val(i)=ival; end; if fx.fe(1).nval<2 then do; fx.fe(3).val(1)=fx.fe(2).val(1); fx.fe(3).val(2)=fx.fe(2).val(2); fx.fe(3).val(3)=fx.fe(2).val(3); end; else do; fbxp=addrel(fx.cur_fep,fixed(fx.fe(1).val(2),18)); if fx.fe(3).type = picture_format then call decode_picture_format(3); else do i=1 to fx.fe(3).nval; ival=fbxp->fb.val(i); if ival<0 then do; ival=stu_$decode_runtime_value (ival,block_sym_tab_p,fx.cur_sfp,null,null,null,icode); if icode^=0 then goto err195; end; fx.fe(3).val(i)=ival; end; end; end; else do; /* non COMPLEX case */ fbxp=fx.cur_fep; fx.fe(1).val(1)=0; fx.fe(1).val(2)=0; fx.fe(1).val(3)=0; if fx.fe(1).type = picture_format then call decode_picture_format(1); else do i=1 to fx.fe(1).nval; ival=fbxp->fb.val(i); if ival<0 then do; ival=stu_$decode_runtime_value (ival,block_sym_tab_p,fx.cur_sfp,null,null,null,icode); if icode^=0 then goto err195; end; fx.fe(1).val(i)=ival; end; end; go to get_fb_exit; end; decode_picture_format: proc(number); dcl number fixed bin(15), p ptr; p = addrel(fbxp,fb.val(1)); fx.fe(number).nval = 3; fx.fe(number).val(1) = p->picture_image.varlength; fx.fe(number).val(2) = fixed(baseno(p),18); fx.fe(number).val(3) = fixed(rel(p),18); end decode_picture_format; test_next: tb18=fx.cur_fep->fb.bits.offset; dcl tb18 bit(18); if tb18="0"b then go to test_fx_stack; fx.cur_fep=addrel(fx.cur_fep,tb18); set_rep: irep=fx.cur_fep->fb.rep; if irep<0 then do; irep=stu_$decode_runtime_value(irep,block_sym_tab_p,fx.cur_sfp,null,null,null,icode); if icode^=0 then goto err195; end; fx.cur_rep=irep; fx.fe(1).type=fixed(fx.cur_fep->fb.bits.code,9); fx.fe(1).nval=fixed(fx.cur_fep->fb.bits.nval,9); if fx.fe(1).type> c_format then go to test_rep; /* non special */ if fx.cur_rep<1 then go to test_next; /* for n>0 nC or n( or nR */ if fx.fe(1).type= c_format then do; c_formatx: fx.fe(1).val(*)=fx.cur_fep->fb.val(*); if fx.fe(1).nval<1 then goto err194; fbxp=addrel(fx.cur_fep,fx.cur_fep->fb.val(1)); fx.fe(2).type,realstype=fixed(fbxp->fb.bits.code,9); /* if realstype^=f_format then if realstype^=e_format then if realstype^=picture_format then goto err194; */ fx.fe(2).nval=fixed(fbxp->fb.bits.nval,9); if fx.fe(1).nval<2 then do; fx.fe(3).type=fx.fe(2).type; fx.fe(3).nval=fx.fe(2).nval; end; else do; fbxp=addrel(fx.cur_fep,fx.cur_fep->fb.val(2)); fx.fe(3).type,realstype=fixed(fbxp->fb.bits.code,9); /* if realstype^=f_format then if realstype^=e_format then if realstype^=picture_format then goto err194; */ fx.fe(3).nval=fixed(fbxp->fb.bits.nval,9); end; go to test_rep; end; open_paren: fx.stk_index=fx.stk_index+1; if fx.stk_index>indexlimit then goto err197; fx.frame(fx.stk_index).sf1p=fx.cur_sfp; fx.frame(fx.stk_index).fe1p=fx.cur_fep; fx.frame(fx.stk_index).rep=fx.cur_rep; if fx.fe(1).type= r_format then do; r_formatx: icode=stu_$remote_format(fx.cur_fep->fb.val(1), fx.cur_sfp,null,flabel); if icode^=0 then goto err195; blp=addr(flabel); fx.frame(fx.stk_index).sf2p=bl(2); /* assumes LABEL=(format-list-p,stack-frame-p) */ if bl(1)->based_int^=0 then goto err196; fx.frame(fx.stk_index).fe2p=addrel(bl(1),1); end; else do; fx.frame(fx.stk_index).sf2p=fx.cur_sfp; fx.frame(fx.stk_index).fe2p=addrel(fx.cur_fep,fixed(fx.cur_fep->fb.val(1),18)); end; test_fx_stack: if fx.stk_index=1 then go to inner_cycle; if fx.frame(fx.stk_index).rep>0 then do; fx.frame(fx.stk_index).rep=fx.frame(fx.stk_index).rep -1; go to inner_cycle; end; fx.cur_sfp=fx.frame(fx.stk_index).sf1p; fx.cur_fep=fx.frame(fx.stk_index).fe1p; fx.stk_index=fx.stk_index-1; go to test_next; inner_cycle: fx.cur_sfp=fx.frame(fx.stk_index).sf2p; fx.cur_fep=fx.frame(fx.stk_index).fe2p; go to set_rep; err194: /* bad_complex_pair */ erno=194; go to error_exit; err195: /* decode error */ erno=195; goto error_exit; err196: /* first-word-of-format-not-zero */ erno=196; goto error_exit; err197: /* exceeds the depth of the format STACK */ erno=197; goto error_exit; error_exit: call plio2_signal_$s_r_(psp,"ERROR","format_list_processor",erno); get_fb_exit: if dcfi_sw=1 then do; dcfi_ct=dcfi_ct - 1; if dcfi_ct=0 then dcfi_sw=0; p=addr(fx.fe(1)); if node(1)=3 then goto disp_c; call disp_f; goto disp_ret; disp_c: call ioa_$nnl("complex("); p=addrel(p,5); call disp_f; call ioa_$nnl(","); p=addrel(p,5); call disp_f; call ioa_$nnl(")"); disp_ret: call ioa_(""); end; return; /* return from disp OR from normal get_next_ */ disp_f:proc; if node(1)=13 then do; qq=addrel(baseptr(node(4)),node(5)); call ioa_$nnl("p ""^a""",qq->picture_image.chars); end; else do; c4=substr(format_letters,node(1)*4-7,4); if node(2)=3 then call ioa_$nnl("^a(^d,^d,^d)", c4,node(3),node(4),node(5)); if node(2)=2 then call ioa_$nnl("^a(^d,^d)", c4,node(3),node(4)); if node(2)=1 then call ioa_$nnl("^a(^d)", c4,node(3)); if node(2)=0 then call ioa_$nnl("^a", c4); end; end disp_f; dcfi:entry; dcfi_sw=1-dcfi_sw; return; dcfi25:entry; dcfi_sw=1; dcfi_ct=25; return; end plio2_fl_;  plio2_gdt_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 53910 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_gdt_: get_data_temp_:proc(pspp) options(support); /* Modified: 4 April 1978 by RAB to more properly determine time to call stu_$get_implicit_qualifier */ dcl (pspp,psp) ptr; dcl ( oklist_p, val_p, sym_p, new_sp , ldip,new_block_p, p) ptr; dcl (text_p, link_p, ref_p) ptr init(null); dcl ( i, n, isteps, icode, nsubs ) fixed bin; dcl isize fixed bin(35); dcl bbit36 bit(36) based; dcl (addr, addrel, bit, binary, fixed, null, rel, substr) builtin; dcl based_bit36 bit (36) aligned based; dcl new_ST_sw bit(1) aligned; dcl stu_$find_runtime_symbol ext entry(ptr,char(*) aligned, ptr , fixed bin) returns(ptr); dcl stu_$get_runtime_address ext entry(ptr,ptr,ptr,ptr,ptr,ptr,ptr) returns (ptr); dcl stu_$decode_runtime_value ext entry (fixed bin(35),ptr,ptr,ptr,ptr,ptr,fixed bin) returns(fixed bin(35)); dcl stu_$get_implicit_qualifier ext entry (ptr,ptr,ptr,ptr,ptr) returns(ptr); dcl plio2_sym_to_desc ext entry(ptr,ptr,ptr,ptr) returns(bit(36)aligned); dcl 1 val_struct based, 2 flag bit(2) unal, 2 type bit(4) unal, 2 rest bit(30) unal; dcl 1 oklist aligned based(oklist_p), 2 okln fixed bin(15), 2 offset(128) bit(18) unaligned; dcl oklistlength fixed bin(17); dcl delta bit(18); dcl sym_q ptr; dcl erno fixed bin(35); dcl 1 ldi aligned based(ldip), 2 l fixed bin(15), 2 chars char(256) aligned, 2 name_l fixed bin(15), 2 (isub,sub(128)) fixed bin(15); dcl ( jsub,jlower,jupper ) fixed bin(35); %include pl1_stack_frame; % include symbol_node; % include runtime_symbol; % include plio2_ps; /* */ /* NOTE WELL on SymTab: I use the old symtab whenever it seems to agree with the new. */ start: psp=pspp; ldip=ps.auxp; sym_p=stu_$find_runtime_symbol(ps.ST_block_p,substr(ldi.chars,1,ldi.name_l),new_block_p,isteps); if sym_p=null then goto err72; if isteps<0 then goto err72; /* isteps is now used to report errors; -5 means a partial name which is ambiguous (sym_p is NOT null in this case) -1 means a null block ptr -2,-3 mean th name is too long or has too many parts -4 means the symbol has been searched for but not found */ if sym_p->runtime_symbol.flag then new_ST_sw = "1"b; else new_ST_sw = "0"b; oklist_p=ps.special_list_p; oklistlength=oklist.okln; if ps.job.p1p2 then oklistlength=oklistlength+oklistlength; /* since, in version one, oklist is stored one per word */ if oklistlength>0 then do; sym_q=sym_p; okloop: delta=bit(fixed(binary(rel(sym_q),18,0)-binary(rel(ps.ST_top_p),18,0),18,0),18); do i=1 to oklistlength; if delta=oklist.offset(i) then go to ok_exit; end; if fixed(sym_q->symbol_node.level,6)<2 then goto err73; /* SAME */ sym_q=addrel(sym_q,sym_q->symbol_node.father); /* SAME */ go to okloop; ok_exit: end; nsubs=fixed(sym_p->symbol_node.ndims,6); /* SAME */ if nsubs^=ldi.isub then goto err74; new_sp=ps.stack_frame_p; do i=1 to isteps; new_sp=new_sp->pl1_stack_frame.display_ptr; /* Here's an OPERATING SYSTEM interface for you. son's SF points to parent's SF in this fashion in MULTICS */ end; /* check subscript ranges */ do i=1 to nsubs; jsub=ldi.sub(i); if new_ST_sw then do; jlower=sym_p->runtime_symbol.bounds(i).lower; jupper=sym_p->runtime_symbol.bounds(i).upper; end; else do; jlower=sym_p->symbol_node.bounds(i).lower; jupper=sym_p->symbol_node.bounds(i).upper; end; icode=0; if jlower<0 then do; if ref_p = null & sym_p -> runtime_symbol.class = "0011"b then ref_p = stu_$get_implicit_qualifier(new_block_p,sym_p,new_sp,link_p,text_p); else; jlower=stu_$decode_runtime_value((jlower),new_block_p,new_sp,null,null,ref_p,icode); end; if icode^=0 then goto err76; if jupper<0 then do; if ref_p = null & sym_p -> runtime_symbol.class = "0011"b then ref_p = stu_$get_implicit_qualifier(new_block_p,sym_p,new_sp,link_p,text_p); else; jupper=stu_$decode_runtime_value((jupper),new_block_p,new_sp,null,null,ref_p,icode); end; if icode^=0 then goto err76; if jsubjupper then goto err77; end; /* end of do-loop on all subscripts */ val_p=stu_$get_runtime_address(new_block_p,sym_p,new_sp,null,null,null,addr(ldi.sub(1))); if val_p=null then goto err75; if sym_p->runtime_symbol.type="111111"b then do; ps.top_half = bit(fixed(sym_p->runtime_symbol.size,18),18); ps.descr = "0"b; end; else ps.descr=plio2_sym_to_desc(sym_p,null,psp,new_sp); ps.vp=val_p; if substr(ps.descr,1, 7)="1010100"b then goto varstrret; if substr(ps.descr,1, 7)="1010110"b then goto varstrret; /* if substr(ps.descr,1,15)="000001000001001"b then goto varstrret; if substr(ps.descr,1,15)="000001000001010"b then goto varstrret; */ return; varstrret: ps.vp=addrel(ps.vp,1); /* PLIO2 needs to have the pointer "as an argument" */ return; err72: erno=72; goto error_exit; err73: erno=73; goto error_exit; err74: erno=74; goto error_exit; err75: erno=75; goto error_exit; err76: erno=76; goto error_exit; err77: erno=77; goto error_exit; error_exit: addr(ps.descr)->based_bit36=addr(erno)->based_bit36; /* returns erno to which 63 will be added: 72 135 identifier not found in S.T. 73 136 identifier not found in (or under) data list of get-data statement 74 137 number of subscripts in identifier not equal number specified in S.T. 75 138 error return from stu_$get_runtime_address 76 139 error return from stu_$decode_runtime_value 77 140 subscript range error, info from S.T. */ ps.vp=null; return; end plio2_gdt_;  plio2_get_util_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 118476 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_get_util_:proc options(support); /* updated 73-12-6 */ /* 76-09-08: changed to use iox_$get_line call forwarder */ /* 73-12-6: updated to replace ios_ with iox_ */ /* 73-10-25: changed to comply with BASIS. Check how our guesses are when BASIS/1-12 comes out. */ /* 9-13-72: AG94 redefines the scanning for list and data-directed fields. We implement these changes here. */ /* 7-26-71: brought SKIP and COLUMN into the fold by adding them to the table-driven department. made eob = blc for a one-level rather than a two-level scanning strategy. */ /* 5-20-71: fixed get_prep to call get_value_data when appropriate. there will thus only have to be the one call to terminate. */ /* 5-18-71: fixed get_edit so that it does not count or transmit NL characters. */ /* This is the only procedure in the stream-directed input package which actually touches the input stream itself, hence does actual reads. */ dcl (addr, addrel, divide, index, mod, null, string, substr) builtin; dcl based_int fixed bin (35) based; dcl p_vector (100) ptr based; dcl ( off_end_sw init(0),return_sw ,i,erno,gcn,gsn, lout,gsi,count ) fixed bin(15); dcl (psp,pspp,fsbp) ptr; dcl condition char(10) init("ERROR"); dcl ermsg char(9) init("plio2_get_util_"); dcl ( ctl_char$np,ctl_char$nl,ctl_char$ht ) char(1) aligned external static; dcl x char(1) aligned; dcl 1 fakeinteger aligned based(addr(xint)), 2 xx char(3) unaligned, 2 intchar char(1) unaligned; dcl xint fixed bin(15) init(0); dcl ( iaction,iactstate,istate,itype,last_space) fixed bin(15); dcl 1 getfab2 aligned internal static, 2 gfs bit(36) init("001001001"b), 2 gfn char(32) init(""), 2 ( gfbs,gfls,gfps) fixed bin(15) init(0); dcl 1 gu_data aligned based(ps.auxp), 2 ii fixed bin(15), 2 char256al char(256) aligned, 2 first_non_space fixed bin(15); dcl plio2_get_util_$get_prep_ ext entry(ptr); dcl iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl plio2_open_$open_implicit_ ext entry(ptr); dcl put_copy_ ext entry(ptr,fixed bin(21)); dcl plio2_gvd_ ext entry(ptr); dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl ioa_ ext entry options(variable); dcl iocb_p ptr; dcl iocb_status fixed bin(35); dcl error_table_$short_record fixed bin(35) external; dcl error_table_$long_record fixed bin(35) external; % include plio2_fsb; % include plio2_ps; % include iocb; /* GET FIELD and SPACING ENTRIES */ get_field_data_:entry(pspp); /* will signal EOF unless field of length >0 of the form: []...[] {;|=} is scanned. MAY RETURN SHORT FIELD: {;|=} leading s are NOT returned no characters are returned. For the sake of "onfield" included s are left, so a field of the form: "a(3, 5). b(88 , 99 ) =" is possible. */ istate=2; field_prep: psp=pspp; fsbp=ps.fsbp; lout=0; go to get_next_char; get_field_edit_:entry(pspp); return_sw=1; edit_set_up: psp=pspp; istate=1; count=ii; if count>256 then goto err149; go to field_prep; get_field_list_:entry(pspp); /* will signal EOF or ERROR. lout=0 returned to indicate []... {EOF | ,} leading s are required for "onfield", so all s except s (which are removed) are left in place. Thus, for example, a character representation may not contain a (usefully, anyhow), for a will not be returned. Sets first_non_space for ease of scanning. */ istate=4; last_space=0; go to field_prep; get_x_format_:entry(pspp); return_sw=0; go to edit_set_up; get_skip_:entry(pspp); psp=pspp; gsn=ii; gsi=2; /* return*/ fsbp=ps.fsbp; go to do_skip; get_column_:entry(pspp); psp=pspp; gcn=ii-1; /* we shall skip to and over the column preceding the named column so that the NEXT get will be from the numbered column */ if gcn<0 then gcn=0; fsbp=ps.fsbp; go to do_column; /* ******************************** */ return_field: ii=lout; first_non_space=last_space+1; check_transmission_error: if fsb.switch.transmit_error then go to set_trans_error; if fsb.switch.te_hold then do; fsb.switch.te_hold="0"b; set_trans_error: ps.switch.transmit_error="1"b; end; place(2): gc_exit: return; /* plio2_get_util_ character class table */ dcl gu_cc(0:61) fixed bin(3) internal static init( (9)0, /* 000 ... 010 */ 3,4, /* TAB,NL */ 0,4,(19)0, /* 013, NP, 015 ... 037 */ 2,0,7, /* BLANK, 041, QUOTE */ (9)0, /* 043 ... 053 */ 1, /* COMMA */ (14)0, /* 055 ... 072 */ 5,0,6); /* SEMI, 074 , EQUAL */ /* ACTIONS and STATES - look O.K. 12-21-70 */ dcl gu_matrix(9,0:8) fixed bin(9) static internal init( /* STATE OTHER COMMA BLANK TAB NPNL SEMI EQUAL QUOTE OFFEND */ /* 0 1 2 3 4 5 6 7 8 */ /* 1-edit */ 61, 61, 61, 61, 11, 61, 61, 61, 51, /* 2-data prep */ 23, 12, 12, 12, 12, 32, 32, 23, 52, /* 3-data loop */ 23, 23, 23, 23, 13, 33, 33, 23, 53, /* 4-list prep */ 29, 44, 24, 24, 14, 74, 29, 25, 54, /* 5-list odd quote*/ 25, 25, 25, 25, 25, 25, 25, 26, 55, /* 6-list even quote */29, 76, 76, 76, 76, 76, 29, 25, 76, /* 7-skip */ (8)87,57, /* 8-column */ (8)98,58, /* 9-unquoted */ 29, 76, 76, 76, 76, 76, 29, 29, 79); /* (action code, next state code ) */ /* actions: 1-get 2-move 3-move,exit 4-list's comma 5-off the end 6-count for edit 7-eo_list 8-skip 9-column */ action(3): /* returns terminating EQ or SEMI that character must be re-scanned and then removed in the calling program */ lout=lout+1; if lout<257 then substr(char256al,lout,1)=x; go to return_field; action(4): /* list-prep sees []...{EOF|,} */ lout=0; if fsb.lsep=1 | ^ps.job.list then goto return_field; /* this is a second comma */ fsb.lsep=1; /* this is a first comma - mark it */ go to get_next_char; /* lout=0 insures that the comma will not be passed since there is nothing to move, "get next character" */ action(5): /* off-end may be either ENDFILE or ERROR depending on file/string and on stoppage DURING meaningful scan or before (or after) meaningful scan. BASIS is unclear about purposes, but generally says that EOF or EOS before the s have been scanned leads to EOF, but in the midst of a scan leads to ERROR. */ if istate=2 then condition="ENDFILE"; if istate=4 then if lout=0 then condition="ENDFILE"; else goto action(4); if istate=1 then if lout=0 then condition="ENDFILE"; goto err162; action(6): /* count for edit and get_x_format_ */ lout=lout+1; if return_sw^=0 then substr(char256al,lout,1)=x; if lout=count then go to check_transmission_error; go to action(1); action(7): /* we seem to have found an */ if itype=8 /* off-end */ then goto return_field; if x=";" then if ps.job.list then do; istate=9; goto action(2); end; else if istate=4 then lout=0; fsb.lsep=index(", "||" ;",x); if x=";" then ps.switch.semi_sep="1"b; go to return_field; /* */ err149: /* will not extract field of length over 256 */ erno=149; goto sandr; err162: /* string of string-option too short */ if ^ps.job.string then goto err163; erno=162; goto sandr; err163: /* EOF while scanning */ erno=163; goto signal_endfile; /* err164: /* EOF already encountered erno=164; goto signal_endfile; */ err165: /* get requires input,stream */ erno=165; goto sandr; err166: /* target of COLUMN lies inside a TAB */ erno=166; goto sandr; signal_endfile: condition="endfile"; goto sandr; sandr: if ps.job.string then condition="ERROR"; call plio2_signal_$s_r_(psp,condition,ermsg,erno); /* signals and causes abnormal return */ /* */ move: action(2): /* is never made part of the string to be returned */ if x=ctl_char$nl then goto get_next_char; lout=lout+1; if istate=4 then last_space=lout; if lout>256 then go to return_field; substr(char256al,lout,1)=x; get_next_char: action(1): if bnc>blc then do; get_replenish: bnc=1; /* we will attempt to fill up the buffer and we start at position 1 */ if ps.job.copy then do; call put_copy_(psp,fsb.blc); ps.start_copy=1; end; if ps.job.string then goto string_is_empty; if fsb.switch.not_used_4 then goto file_at_eof; /* OLD EOF FLAG */ if fsb.switch.transmit_error then do; fsb.switch.transmit_error="0"b; fsb.switch.te_hold="1"b; end; iocb_p=fsb.iocb_p; call iox_$get_line(iocb_p,fsb.bptr,fsb.bsize,fsb.blc,iocb_status); if iocb_status ^=0 then do; if iocb_status=error_table_$long_record then; else if iocb_status=error_table_$short_record then; else fsb.transmit_error = "1"b; end; if fsb.blc^=0 then go to buffer_replenished; file_at_eof: fsb.switch.not_used_4="1"b; /* EOF ACTION */ string_is_empty: off_end_sw=1; buffer_replenished: if off_end_sw^=0 then do; itype=8; go to re_act; end; end; x=substr(xbuf,bnc,1); bnc=bnc+1; if x=ctl_char$nl then /* new line character . . . */ do; kol=0; go to get_itype; end; if x=ctl_char$ht then /* horizontal tab character */ do; kol=10+10*(divide(kol,10,15,0)); go to get_itype; end; if x=ctl_char$np then goto get_itype; /* new page character */ kol=kol+1; get_itype: intchar=x; if xint>61 then itype=0; /* other */ else itype=gu_cc(xint); re_act: iactstate=gu_matrix(istate,itype); iaction=divide(iactstate,10,15,0); istate=mod(iactstate,10); go to action(iaction); /* */ /* CODE for SKIP and COLUMN */ do_column: if kol=gcn then go to gc_exit; if kol > gcn then do; gsi=4; gsn=1; go to do_skip; /* try to find column in next line */ place(4): go to do_column; end; istate=8; go to get_next_char; action(9): if kol=0 then go to gc_exit; if kol=gcn then go to gc_exit; if kol gcn : a tab has carried us over the desired column */ goto err166; do_skip: istate=7; if fsb.lsep=4 /* NL */ then gsn=gsn-1; do i= 1 to gsn; go to get_next_char; action(8): if x=ctl_char$nl then go to dse; /* kol=0 doesn't work now that there is NP */ go to get_next_char; dse: end; if gsi=6 then goto return_from_prep_skip; go to place(gsi); /* TERMINATE and PREP for GET */ get_terminate_:entry(pspp); psp=pspp; if ps.prep^=0 then call plio2_get_util_$get_prep_(psp); /* Due to a change in pl1_operator_'s entry stream_prep, the prep work will be done prior to the first transmission or terminate call. */ fsbp=ps.fsbp; if ps.job.copy then call put_copy_(psp,fsb.bnc-1); if ^ps.job.list then fsb.lsep=1; /* so that following comma will be 2nd comma */ return; get_prep_:entry(pspp); plio2_data_$pspstat, psp=pspp; ps.prep=0; string(ps.switch)="0"b; /* STRING OPTION */ if ps.job.string then do; plio2_data_$pliostringfsbp, plio2_data_$fsbpstat, ps.fsbp, fsbp= ps.source_p; /* for STRING OPTION source_p points to the fake FSB and fake FSB's bptr is addr(string). length(string) is in ps.number */ bnc=1; kol=0; if ps.varying_string then i=addrel(bptr,-1)->based_int; else i=ps.number; bsize,blc=i; fsb.title,fsb.filename="""get_string_option"""; /* for string option, fsb.buffer, fsb.path_name, fsb.declared_attributes(2) must not be used - fake_fsb is too short */ string(fsb.switch)="001101001"b; ps.file_p=null; go to prep_exit; end; /* FILE OPTION - EXPLICIT OR IMPLICIT */ if ps.job.explicit_file then ps.file_p=ps.source_p; else do; call ioa_("error in get prep: no explicit file"); ps.file_p=addr_sysin(); ps.job.explicit_file="1"b; end; ps.fsbp,fsbp,plio2_data_$fsbpstat=ps.file_p->p_vector(2); if fsb.switch.open then go to open1; plio2_data_$fab2pstat,ps.fab2p=addr(getfab2); call plio2_open_$open_implicit_(psp); open1: /* if fsb.switch.eof then goto err164; */ if fsb.switch.input="0"b|fsb.switch.stream="0"b then goto err165; prep_exit: if ps.job.copy then do; ps.start_copy=bnc; call put_copy_(psp,-1); /* SIGNAL to OPEN the COPY-FILE */ end; if ps.job.skip then do; gsi=6; /* and then return */ gsn=ps.number; go to do_skip; return_from_prep_skip: place(6): end; if ps.job.data then call plio2_gvd_(psp); return; addr_sysin:proc returns(ptr); dcl sysin file input stream; return(addr(sysin)); end addr_sysin; end plio2_get_util_;  plio2_gvd_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 61740 %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_gvd_: gvd_:gvd: get_value_data_:proc(pspp) options(support); /* updated 9-13-72 */ /* 9-13-72: conforming to AG94 */ dcl ( erno init(999), ignore,tsub,num_sw,sign, bnc,blc,oi,ns_len,vs_len,first_non_space) fixed bin(15); dcl ( pspp,psp,bp) ptr; dcl 1 ldi aligned, 2 l fixed bin(15), 2 chars char(256) aligned, 2( name_l,isub,sub(128)) fixed bin(15); dcl condition_name char(5); dcl value_saved char(256) aligned; dcl name_saved char(256) aligned; /* needed since ldi.chars is overwritten in the call to get_field_list. */ dcl based_int fixed bin (35) based; dcl 1 fakeint aligned based(addr(xint)), 2 aaa char(3) unaligned, 2 xchar char(1) unaligned; dcl xint init(0) fixed bin(15); dcl x char(1) aligned; dcl (iaction,istate,itype,iactstate,strlen) fixed bin(15); dcl fake_arg bit(1) unaligned based; dcl plio2_gdt_$get_data_temp_ ext entry(ptr); dcl plio2_get_util_$get_field_data_ ext entry(ptr); dcl plio2_get_util_$get_field_list_ ext entry(ptr); dcl plio2_get_util_$get_prep_ ext entry(ptr); dcl plio2_get_util_$get_terminate_ ext entry(ptr); dcl plio2_ldi_ ext entry(ptr); dcl plio2_signal_$s_l_ ext entry(ptr,char(*),char(*),fixed bin(15),char(*),fixed bin(15),fixed bin(15),fixed bin(15)); dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl ( addr,divide,min,mod,null,substr ) builtin; % include plio2_ps; /* CODE STARTS */ psp=pspp; ps.auxp=addr(ldi); /* there is no need to call GET_PREP for GVD is called from GET_PREP after prep work is done */ ps.switch.semi_sep="0"b; loop: if ps.switch.semi_sep then go to exit; call plio2_get_util_$get_field_data_(psp); if ldi.l>256 then goto err143; name_saved=ldi.chars; ns_len=ldi.l; if substr(ldi.chars,ldi.l,1)=";" then goto exit; if ldi.l=0 then goto loop; get_datum: call plio2_get_util_$get_field_list_(psp); if ldi.l=0 then goto loop; value_saved=ldi.chars; vs_len=ldi.l; first_non_space=ldi.name_l; if substr(value_saved,first_non_space,1)=";" then goto exit; ldi.chars=name_saved; ldi.l=ns_len; goto id_parse; OK: call plio2_gdt_$get_data_temp_(psp); if ps.vp=null then do; addr(erno)->based_int=addr(ps.descr)->based_int; erno=erno+63; /* yields 135-140: see plio2_gdt_ */ go to NG_1; end; ldi.l,vs_len=vs_len+1-first_non_space; ldi.chars=substr(value_saved,first_non_space,vs_len); call plio2_ldi_(psp); go to loop; /* */ NG: erno=istate+125; /* (...) appears illegally in datum identifier: 126:misc 127:numeric 128:sign 129:comma 130:equal 131:parens 132:dollar-or-_ 133:dot 134:alphabetic */ NG_1: vs_len=min(vs_len,256-ns_len); name_saved=substr(name_saved,1,ns_len) ||substr(value_saved,1,vs_len); ns_len=ns_len+vs_len; if ps.job.string then condition_name="ERROR"; else condition_name="NAME"; call plio2_signal_$s_l_(psp,condition_name,"get_data",erno, substr(name_saved,1,ns_len),1,ns_len,0); do; ps.switch.transmit_error="0"b; goto loop; end; goto loop; err123: /* problem in scan of datum identifier */ erno=123; goto sandr; err124: erno=124; goto sandr; /* more than 128 subscripts */ err143: /* identifier longer than 256 */ erno=143; goto sandr; sandr: call plio2_signal_$s_r_(psp,"ERROR","get_data",erno); exit: /* there is no need to call GET_TERMINATE for GVD is called from GET_PREP from GET_TERMINATE itself ! ! */ return; /* */ dcl data_char_class(0:127) fixed bin(9) internal static init( (9)10, /* 000...010 */ (2)11, /* TAB,NL */ (3)11, /* VTAB, NPAGE, CRETURN */ (18)10, /* 016 ... 037 */ 11, /* BLANK */ 10, /* 041 */ 10, /* QUOTE */ 10, /* 043 */ 1, /* DOLLAR */ (3)10, /* 045 ... 047 */ 6,7, /* OPEN_PAR, CLOSE_PAR */ 10, /* 052 */ 4,5,4,9, /* PLUS, COMMA, MINUS, DOT */ 10, /* 057 */ (2)3, /* ZERO, ONE */ (8)3, /* TWO, THREE, . . . NINE */ 10, /* 072 */ 10, /* SEMI */ 10, /* 074 */ 8, /* EQUAL */ (3)10, /* 076 ... 080 */ (26)2, /* CAPS */ (4)10, /* 133 ... 136 */ 1, /* UNDERSCORE */ 10, /* 140 */ (26)2, /* LOWER CASE */ (5)10 /* 173 ... 177 */ ); /* dollar,underscore 1 letters 2 numerals 3 plus/minus 4 comma 5 open paren 6 close paren 7 equal sign 8 dot 9 junk 10 ignorable 11 */ /* field has NOT had leading and intervening blank, tab, newpage, and newline characters removed by get_util_$get_field_data_. field terminates with the first equalsign or semicolon after the first character */ dcl data_mat(5,10) fixed bin(9) static internal init( /* STATE $_ ALPH NUM SIGN CMMA OPEN CLOZ EQU DOT JUNK*/ /* 1-prep */ 37, 12, 32, 33, 34, 36, 36, 35, 38, 31, /* 2-name */ 12, 12, 12, 33, 34, 23, 36, 00, 11, 31, /* 3- presubscr */ 37, 39, 64, 64, 34, 36, 36, 35, 38, 31, /* 4-subscr */ 37, 39, 74, 33, 83, 36, 85, 35, 38, 31, /* 5- endlist */ 37, 39, 32, 33, 34, 36, 36, 00, 11, 31); /* ( ACTION , new STATE ) actions: 0 OK 1 move 2 get 3 NG 6 set sign for ss 7 set ss digit 8 store ss */ /* */ id_parse: istate=1; bnc=1; blc=ldi.l; ldi.isub=0; oi=0; go to action(2); action(0): ldi.name_l=oi; /* index of last character of name */ go to OK; action(1): /* ldi.chars already contains the identifier ("as.you.like.it(1,2,-3)=") left adjusted. */ oi=oi+1; substr(ldi.chars,oi,1)=x; action(2): GET: if bnc>blc then goto err123; x=substr(ldi.chars,bnc,1); bnc=bnc+1; xchar=x; if xint>127 then do; itype=10; go to re_act; end; itype=data_char_class(xint); if itype=11 then goto GET; /* ignore blanks and so on. */ re_act: iactstate=data_mat(istate,itype); istate=mod(iactstate,10); iaction=divide(iactstate,10,15,0); transfer: go to action(iaction); action(3): go to NG; action(6): if x="-" then sign=1; else sign=0; tsub=0; if itype=4 then do; /* sign */ num_sw=0; goto GET; end; num_sw=1; /* a number has appeared in the current subscript */ action(7): num_sw=1; tsub=10*tsub+xint -48; go to GET; action(8): if num_sw=0 then do; /* bad subscript consisting of a sign only */ istate=itype-1; goto NG; end; if sign=1 then tsub=-tsub; isub=isub+1; if isub>128 then goto err124; ldi.sub(ldi.isub)=tsub; go to GET; end plio2_gvd_;  plio2_gvl_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 192105 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_gvl_: get_value_list_: procedure (p_ps_ptr) options (support); /* Modified: 18 July 1978 by R. A. Barnes to make gvl more quit-start proof if blocked */ /* Modified: 4 April 1978 by Peter C. Krupp to implement radix-n bit strings for get list */ /* Modified: 20 December 1977 by Richard A. Barnes to fix 1695 (get string) */ /* Rewritten Spring 1977 by R.Schoeman as part of the quick stream_io package. Recoded 770612 by PG to maintain fsb.kol accurately, and to use algorithms similar to EIS lex. package. This procedure is called once for each item in a data list in a get list statement. It is called at runtime by pl1_operators_ through the entrypoint get_value_list_. Section 12.14 (GET statement) of AG94 describes in detail the language-defined actions which are performed by this program. */ /* parameters */ declare p_ps_ptr ptr parameter; /* ptr to PS */ /* automatic */ declare BIT_STRING bit (1) aligned, bit256 bit (256) varying aligned, break fixed bin (21), code fixed bin (35), convert_index fixed bin (15), erno fixed bin (15), /* oncode number */ error_string char (1000) varying, /* used when raising conversion */ first_bit fixed bin (15), first_char fixed bin (21), in_ptr ptr, iocbp ptr, left fixed bin (21), onchar_index fixed bin (15), pic_buf char(64), pic_ptr ptr, psp ptr, RADIX_FACTOR fixed bin(15), rn_digit char(1) aligned, rn_value fixed bin(15), scan_index fixed bin (21), scan_start fixed bin (21), targ_ptr ptr, token_length fixed bin (21), token_start fixed bin (21), token_string char (257) varying; /* based */ declare buffer_array (1044480) char (1) unaligned based (fsb.bptr); /* builtins */ declare (addr, addrel, binary, bit, divide, index, length, reverse, search, substr, verify, unspec) builtin; /* conditions */ declare conversion condition; /* entries */ declare iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), plio2_get_util_$get_prep_ entry (ptr), plio2_signal_$conversion_error_ entry (ptr, char (*), fixed bin (15), ptr, fixed bin (15), fixed bin (15), fixed bin (15)), plio2_signal_$s_ entry (ptr, char (*), char (*), fixed bin (15)), plio2_signal_$s_r_ entry (ptr, char (*), char (*), fixed bin (15)), plio2_resig_ entry (ptr), put_copy_ entry (ptr, fixed bin (21)); /* external static */ dcl (error_table_$short_record, error_table_$long_record, error_table_$end_of_info) external static fixed bin (35); /* internal static */ declare ( HT char (1) aligned initial (" "), NL char (1) aligned initial (" "), QUOTE char (1) aligned initial (""""), HT_NL_quote char (3) aligned initial (" """), HT_NL_SP_comma char (4) aligned initial (" ,") ) internal static; declare max_io_string_length internal static options(constant) initial(256); /* include files */ %include plio2_ps; %include plio2_fsb; %include pl1_stack_frame; %include desc_dcls; %include desc_types; %include descriptor; %include picture_desc_; %include picture_image; %include picture_util; %include radix_factor_constants; /* program */ psp = p_ps_ptr; if ps.prep ^= 0 then call plio2_get_util_$get_prep_ (psp); iocbp = ps.fsbp -> fsb.iocb_p; BIT_STRING = "0"b; RADIX_FACTOR = 0; on conversion call plio2_resig_ (psp); init_scan: left = fsb.blc - fsb.bnc + 1; first_char = verify (substr (xbuf, fsb.bnc, left), " "); if first_char = 0 then do; /* rest of string was blanks */ call refill_buffer_ldi; if code ^= 0 then go to raise_eof; go to init_scan; end; fsb.kol = fsb.kol + first_char - 1; fsb.bnc = fsb.bnc + first_char - 1; /* step over blanks */ if substr (xbuf, fsb.bnc, 1) = NL then do; fsb.kol = 0; /* reset current column */ fsb.bnc = fsb.bnc + 1; /* step over newline */ go to init_scan; end; if substr (xbuf, fsb.bnc, 1) = HT then do; fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); fsb.bnc = fsb.bnc + 1; /* step over HT */ go to init_scan; end; if substr (xbuf, fsb.bnc, 1) = "," then do; fsb.kol = fsb.kol + 1; fsb.bnc = fsb.bnc + 1; /* step over comma */ if fsb.lsep = 2 then do; /* last separator was not a comma... */ fsb.lsep = 1; /* let this comma pass by */ goto init_scan; end; /* last separator was a comma...this comma means */ return; /* two commas in a row...input item is unchanged */ end; else if substr (xbuf, fsb.bnc, 1) = QUOTE /* current char is a quote? */ then do; /* yes...scan a quoted string */ scan_start = fsb.bnc + 1; /* start copying after quote */ token_start = scan_start; token_length = 0; rescan: scan_index = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_quote); if scan_index = 0 then do; /* eof while looking for closing quote */ if token_start = 0 /* copy has begun */ then token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1); else do; token_string = substr (xbuf, token_start, fsb.blc - token_start + 1); token_start = 0; end; call refill_buffer_ldi; if code ^= 0 then go to err163; /* error -- end of file */ scan_start = 1; go to rescan; end; fsb.kol = fsb.kol + scan_index - 1; /* update kol but not scan_start just yet */ if substr (xbuf, scan_start + scan_index - 1, 1) = NL then do; /* AG94 says ignore newlines inside quoted strings when in list-directed input. So we do. Ugh. */ fsb.kol = 0; if token_start > 0 /* if not copied yet, copy now */ then do; token_string = substr (xbuf, token_start, token_length); token_start = 0; end; token_string = token_string || substr (xbuf, scan_start, scan_index - 1); scan_start = scan_start + scan_index; go to rescan; end; else if substr (xbuf, scan_start + scan_index - 1, 1) = HT then do; fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); if token_start = 0 then token_string = token_string || substr (xbuf, scan_start, scan_index); else token_length = token_length + scan_index; scan_start = scan_start + scan_index; go to rescan; end; /* Found a matching quote. Ignore it. */ if token_start = 0 then token_string = token_string || substr (xbuf, scan_start, scan_index - 1); else token_length = token_length + scan_index - 1; scan_start = scan_start + scan_index; fsb.kol = fsb.kol + 1; /* step over quote */ /* Now look for a quote immediately following, which means we have two quotes in a row. */ /* First make sure we are not at the end of the buffer */ if scan_start > fsb.blc then do; if token_start > 0 /* if not copied yet, copy now */ then do; token_string = substr (xbuf, token_start, token_length); token_start = 0; end; call refill_buffer_ldi; if code ^= 0 then goto finish; /* eof encountered */ scan_start = 1; end; if substr (xbuf, scan_start, 1) = QUOTE then do; if token_start > 0 /* if not copied yet, copy now */ then do; token_string = substr (xbuf, token_start, token_length); token_start = 0; end; token_string = token_string || QUOTE; fsb.kol = fsb.kol + 1; scan_start = scan_start + 1; go to rescan; end; /* We have now parsed the quoted section of the string...scan until the next space or comma and include those characters, too. */ find_break: break = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_SP_comma); if break = 0 then do; /* eof while looking for delimiters */ if token_start > 0 /* if not copied yet, do it now */ then do; token_string = substr (xbuf, token_start, fsb.blc - token_start + 1); token_start = 0; end; else token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1); call refill_buffer_ldi; if code ^= 0 then goto finish; /* AG94 says this is a legal termination, not an error */ scan_start = 1; goto find_break; end; fsb.kol = fsb.kol + break - 1; if substr (xbuf, scan_start + break - 1, 1) = HT then fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); else if substr (xbuf, scan_start + break - 1, 1) = NL then fsb.kol = 0; /* determine whether we have a bit string */ if break = 2 /* exactly one char after trailing quote */ then if substr (xbuf, scan_start, 1) = "b" /* and that char is "b" */ then do; RADIX_FACTOR = 1; BIT_STRING = "1"b; end; /* determine whether we have a radix-n (n=2,4,8,16) bit string */ if break = 3 /* exactly two characters after the trailing quote */ then do; RADIX_FACTOR = index ("1234", substr (xbuf, scan_start + 1, 1)); if substr (xbuf, scan_start, 1) = "b" & RADIX_FACTOR ^= 0 then BIT_STRING = "1"b; end; fsb.bnc = scan_start + break; /* step over scanned chars and over delim */ if break > 1 /* if trailing stuff after closing quote... */ then do; if token_start > 0 /* ...and not yet copied */ then do; /* ...copy it now. */ token_string = substr (xbuf, token_start, token_length); token_start = 0; end; /* At this point, token_string contains the (unquoted) portion of the input item that was originally quoted, and substr (xbuf, scan_start, break - 1) contains the portion of the input item that appeared after the quoted part and before the delimiter. */ if ^BIT_STRING then do; /* unknown text immediately follow closing quote of a character string */ erno = 167; call conversion_error; end; end; end; /* end quoted string section */ else do; /* scan an unquoted input item */ scan_start = fsb.bnc; token_start = scan_start; /* token starts at first char */ token_length = 0; find_break_nq: scan_index = search (substr (xbuf, scan_start, fsb.blc - scan_start + 1), HT_NL_SP_comma); if scan_index = 0 then do; if token_start > 0 /* if not copied, copy & concatenate */ then do; token_string = substr (xbuf, token_start, fsb.blc - token_start + 1); token_start = 0; end; else token_string = token_string || substr (xbuf, scan_start, fsb.blc - scan_start + 1); call refill_buffer_ldi; if code ^= 0 then go to finish; /* not an error -- normal termination */ scan_start = 1; go to find_break_nq; end; fsb.kol = fsb.kol + scan_index - 1; /* update kol but not scan_start yet */ if substr (xbuf, scan_start + scan_index - 1, 1) = HT then fsb.kol = fsb.kol + 10 - divide (fsb.kol, 10, 21, 0); else if substr (xbuf, scan_start + scan_index - 1, 1) = NL then fsb.kol = 0; if token_start > 0 then token_length = token_length + scan_index - 1; else token_string = token_string || substr (xbuf, scan_start, scan_index - 1); fsb.bnc = scan_start + scan_index; /* step over scanned chars & delim */ end; if substr (xbuf, fsb.bnc - 1, 1) = "," /* item terminated by comma? */ then fsb.lsep = 1; /* yes...next comma means null item */ else fsb.lsep = 2; /* no....next comma is ignored */ /* We have now parsed the input item....convert it to the type of the target */ finish: if token_start > 0 /* token has not been copied */ then do; intype = char_desc * 2; in_ptr = addr (buffer_array (token_start)); /* use substraddr when available! */ inscale_prec = token_length; if token_length > max_io_string_length then go to err172; end; else if BIT_STRING then do; if length (token_string) > max_io_string_length then go to err172; if RADIX_FACTOR = 1 /* radix-2 bit string - no radix conversion necessary */ then do; bit256 = bit (token_string); intype = v_bit_desc * 2; in_ptr = addr (bit256); inscale_prec = length (bit256); end; else do; /* radix-4, 8, or 16 bit string - radix conversion necessary */ if length (token_string) * RADIX_FACTOR > max_io_string_length then go to err171; if RADIX_FACTOR = 4 /* radix-16 bit string - are hexadecimal digits upper or lower case */ then if search (token_string, capital_hex) > 0 then substr (digits (4), 11, 6) = capital_hex; else substr (digits (4), 11, 6) = lower_case_hex; bit256 = ""b; do convert_index=1 to length(token_string); /* convert from radix-n to radix-2 */ rn_digit = substr (token_string, convert_index, 1); rn_value = index (digits (RADIX_FACTOR), rn_digit); if rn_value = 0 then do; onchar_index = convert_index; erno = 168; error_string = token_string; call conversion_error_for_RADIX_N; go to finish; /* retry conversion with value returned from on unit */ end; first_bit = RADIX_FACTOR * (rn_value - 1) + 1; bit256 = bit256 || substr (expand_bits (RADIX_FACTOR), first_bit, RADIX_FACTOR); end; intype = v_bit_desc * 2; in_ptr = addr (bit256); inscale_prec = length (bit256); end; end; else do; intype = v_char_desc * 2; in_ptr = addr (token_string); inscale_prec = length (token_string); if length (token_string) > max_io_string_length then go to err172; end; ps.vp = ps.value_p; ps.descr = ps.descriptor; if ps.descr = "0"b then do; pic_ptr = psp -> ps.stack_frame_p -> pl1_stack_frame.text_base_ptr; pic_ptr = addrel (pic_ptr, psp -> ps.top_half); /* The following block of code should be similiar to or identical with the int. subroutine "set_pic_args" in plio2_qge. */ outtype = type (pic_ptr -> picture_image.type); outfo.outscale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor; if outtype = char_desc * 2 then outfo.outprec = pic_ptr -> picture_image.varlength; else outfo.outprec = pic_ptr -> picture_image.prec; /* end of "set_pic_args" */ call assign_ (addr (pic_buf), outtype, outscale_prec, in_ptr, intype, inscale_prec); call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1, addr (pic_buf) -> char1); end; else do; unspec (desc_) = unspec (ps.descr); outtype = desc_.type_ * 2 + binary (desc_.pack_, 1); if outtype = v_char_desc * 2 | outtype = v_bit_desc * 2 then targ_ptr = addrel (ps.value_p, -1); else targ_ptr = ps.value_p; outfo.outscale = desc_.scale_; outfo.outprec = desc_.precision_; call assign_ (targ_ptr, outtype, outscale_prec, in_ptr, intype, inscale_prec); end; no_assign: /* target of go to in conversion_error - transfer here when input item is to be left unchanged */ return; raise_eof: if ^ ps.string then do; call plio2_signal_$s_r_ (psp, "endfile", "quick_get_list", 163); return; end; err163: if ps.string then erno = 162; /* the string supplied with string option */ /* has insufficient data for this get statement. */ else erno = 163; /* end_of_file encountered while executing get statement. */ go to any_err; err171: erno=171; /* radix-factor bit string has a expanded length that exceeds 256 bits */ go to any_err; err172: erno=172; /* string whose length exceeds 256 not handled by plio2_ */ any_err: call plio2_signal_$s_r_ (psp, "ERROR", "quick_get_list", erno); return; /* The following procedure refills the buffer and returns with code = 0 if all went well, otherwise either raises an error itself or returns with a non-zero value of code, depending on AG-94's defined action. */ refill_buffer_ldi: procedure; if ps.copy then do; call put_copy_ (psp, fsb.blc); ps.start_copy = 1; end; if ps.string then do; code = error_table_$end_of_info; return; end; fsb.blc = 0; /* protects us somewhat from quit-start */ fsb.bnc = 1; /* .. */ if fsb.console then call iox_$get_line (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code); else call iox_$get_chars (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code); fsb.bnc = 1; if code ^= 0 then if (code = error_table_$short_record) | (code = error_table_$long_record) then code = 0; else if code ^= error_table_$end_of_info then do; call plio2_signal_$s_ (psp, "TRANSMIT", "quick_get_list", 153); return; end; return; end /* refill_buffer_ldi */; /* The following procedure processes conversion errors encountered during The execution of get list statements. It also validates the corrected onsource string and raises the conversion condition again if necessary. */ conversion_error: procedure; /* AG94 (and ANSI) says raise conversion here. But since we have not been saving the original input string (in the interests of speed), we have to reconstruct it. Ugh. */ error_string = QUOTE; do scan_index = 1 to length (token_string); if substr (token_string, scan_index, 1) = QUOTE then error_string = error_string || QUOTE; error_string = error_string || substr (token_string, scan_index, 1); end; error_string = error_string || QUOTE; error_string = error_string || substr (xbuf, scan_start, break - 1); if substr (xbuf, scan_start, 1) = "b" /* "..."b... ??? */ then break = break - 1; /* set onchar to char after b */ onchar_index = length (error_string) - break + 2; conversion_error_for_RADIX_N: entry; raise_conversion: call plio2_signal_$conversion_error_ (psp, "quick_get_list", erno, addrel (addr (error_string), 1), 1, length (error_string), onchar_index); if erno = 168 then do; /* radix conversion error occurred - go back */ token_string = error_string; return; end; /* Now check the returned onsource of validity. */ if substr (error_string, 1, 1) = QUOTE then do; error_string = rtrim (error_string); /* ignore white space to the right fo quoted string */ if substr (error_string, length (error_string) - 1, 2) = """b" then do; BIT_STRING = "1"b; RADIX_FACTOR = 1; token_string = substr (error_string, 2, length (error_string) - 3); end; else if substr (error_string, length (error_string), 1) = QUOTE then do; BIT_STRING = "0"b; token_string = ""; do scan_index = 2 to length (error_string) - 1; if substr (error_string, scan_index, 1) = QUOTE then do; scan_index = scan_index + 1; if substr (error_string, scan_index, 1) ^= QUOTE then do; onchar_index = scan_index; go to raise_conversion; end; end; token_string = token_string || substr ( error_string, scan_index, 1); end; if token_string = "" then go to no_assign; /* null item...no assign */ end; else if substr (error_string, length (error_string) - 2, 2) = """b" then do; RADIX_FACTOR = index ("1234", substr (error_string, length (error_string), 1)); if RADIX_FACTOR ^= 0 then do; BIT_STRING = "1"b; token_string = substr (error_string, 2, length (error_string) - 4); end; else do; onchar_index = length (error_string); go to raise_conversion; end; end; else do; onchar_index = length (error_string) - index (reverse (error_string), QUOTE) + 2; if onchar_index < length (error_string) then if substr (error_string, onchar_index, 1) = "b" then do; onchar_index = onchar_index + 1; if onchar_index < length (error_string) then if index ("1234", substr (error_string, onchar_index, 1)) ^= 0 then onchar_index = onchar_index + 1; end; go to raise_conversion; end; end; else if error_string = "" then do; onchar_index = 1; go to raise_conversion; /* onsource cannot be blanks */ end; else do; /* onsource OK */ BIT_STRING = "0"b; token_string = error_string; end; end /* conversion_error */; end /* plio2_gvl_ */;  plio2_ldi_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 38187 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_ldi_:proc(pspp) options(support); /* updated 5-5-71 */ /* updated 10-73 for a) new conversion routines b) new BASIS/1-10 inspired converting rules */ dcl based_chars char (1044480) based; dcl ( oncharind,oci,bnc,blc,istore,istate,erno,i,fnb,sn) fixed bin(15); dcl (sp,bp,psp,pspp,picture_p) ptr; dcl temp_answer bit(2304) aligned; dcl output256 char(256) aligned based(addr(temp_answer)); dcl bit256varying bit(256) aligned varying; dcl x char(1) aligned; dcl buffer char(64) aligned; dcl 1 ldi aligned based, 2 l fixed bin(15), 2 char256 char(256) aligned; dcl QUOTE char(1) aligned static internal init(""""); dcl char_vector(1000) unaligned based; dcl (addr,addrel,bit,fixed,substr,unspec,length,verify) builtin; dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl plio2_signal_$conversion_error_ ext entry(ptr,char(*),fixed bin(15),ptr,fixed bin(15),fixed bin(15),fixed bin(15)); dcl plio2_resig_ ext entry(ptr); dcl conversion condition; %include desc_dcls; %include desc_types; %include descriptor; %include picture_util; % include plio2_ps; /* A character string, S, is given which is not of zero length. It has neither leading nor trailing blanks or other spaces. (get_util_ returns the string ldi.chars _w_i_t_h leading s but gvd and gvl remove them before calling ldi.) Case 1. S::= {"xxx"}... remove outside quotes, doubled inside quotes to yield SS assign SS to target, leaving "assign" to raise CONVERSION. Case 2. S::= {"xxx"}...b remove outside quotes and final b and doubled inside quotes to obtain SS assign SS to bit256varying to obtain a bit string B of effective length L ("assign" may raise CONVERSION) assign B-L to target. Case 3. S::= something else. assign S to target, leaving "assign" to raise CONVERSION. C A U T I O N This is a very new idea, obtained from BASIS/1-10 with a lot of SALT. Examine BASIS/1-11 and BASIS/1-12 carefully for conformance. Also note that a lot of error-numbers are no longer used (here at least), since CONVERSION will now be raised by "assign" in ALL cases. P. A. Belmont 10-13-73 */ psp=pspp; istore=0; blc=ps.auxp->ldi.l; if blc > 256 then call plio2_signal_$s_(psp,"ERROR","ldi",242); bp=addr(ps.auxp->ldi.char256); on conversion call plio2_resig_(psp); x=substr(bp->based_chars,1,1); if x=QUOTE then go to is_quoted; output_original_CS: sp=bp; sn=blc; intype=char_desc*2; output: call assign_type_d(ps.descr,psp,picture_p,outtype,outscale_prec); if ps.descr="0"b then do; call assign_(addr(buffer),outtype,outscale_prec,sp,intype,(sn)); call pack_picture_(ps.vp->char1,picture_p->char1,addr(buffer)->char1); end; else do; unspec(desc_) = ps.descr; if type_=v_bit_desc | type_=v_char_desc then ps.vp = addrel(ps.vp,-1); call assign_(ps.vp,outtype,outscale_prec,sp,intype,(sn)); end; if ps.switch.transmit_error then do; ps.switch.transmit_error="0"b; call plio2_signal_$s_(psp,"TRANSMIT","ldi",153); end; return; is_quoted: istate=1; bnc=2; get_x: if bnc>blc then do; if istate=1 then goto output_original_CS; found_CS: intype = char_desc*2; sn = istore; sp=addr(output256); go to output; end; x=substr(bp->based_chars,bnc,1); bnc=bnc+1; go to action(istate); action(1): if x=QUOTE then do; istate=2; go to get_x; end; store_char: istore=istore+1; substr(output256,istore,1)=x; go to get_x; action(2): if x=QUOTE then do; istate=1; go to store_char; end; if x^="b" then goto output_original_CS; bit256varying=bit(substr(output256,1,istore)); sn=length(bit256varying); /* if CONVERSION is signalled, length may no longer be = istore */ sp=addr(bit256varying); intype=v_bit_desc*2; goto output; end;  plio2_ldo_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 48915 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified: 05/01/78 by PCK to implement unsigned binary */ plio2_ldo_:proc(pspp) options(support); put_value_list_:entry(pspp); dcl (pspp,psp,picture_p) ptr; dcl based_bit36 bit (36) aligned based; dcl based_chars char (1044480) based; dcl p_vector (100) ptr based; dcl based_bits bit(1000) unal based; dcl (code,erno,n_out,i ) fixed bin(15); dcl output char(516) unaligned; dcl v_output char(516) varying; dcl (addr,addrel,fixed,length,substr,unspec) builtin; dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15)); dcl plio2_put_util_$put_prep_ ext entry(ptr); dcl dnd$with_strings ext entry(bit(36) aligned,ptr,fixed bin(15)); dcl plio2_resig_ ext entry(ptr); dcl conversion condition; dcl based_VL fixed bin(35) based; dcl x char(1) aligned; dcl 1 descriptive aligned, 2 type5 aligned, 3 (cr,bd,ff,ls,pack) char(1) unal, 2 ( prec,scale,bit_length,type) fixed bin(15); %include desc_dcls; %include desc_types; %include descriptor; %include picture_image; %include picture_types; %include picture_util; % include plio2_fsb; % include plio2_ps; /* START */ psp=pspp; if ps.prep^=0 then call plio2_put_util_$put_prep_(psp); ps.vp=ps.value_p; ps.descr=ps.descriptor; go to common; err232: /* bad descriptor of output item */ erno=232; goto sandr; string_too_big: err242: /* strings of length >256 not handled */ erno=242; goto sandr; sandr: call plio2_signal_$s_(psp,"ERROR","LDO",erno); return; ldo_for_data:entry(pspp); psp=pspp; /* desc & ptr have already been moved to ps.vp,ps.descr and put_prep_ has already been called */ common: on conversion call plio2_resig_(psp); i=0; substr(addr(i)->based_bit36,30,7)=substr(ps.descr,1,7); if i<77 then goto standard_types; /* arithmetic data types 1-12 */ if i<83 then goto non_standard_types; /* address, area, structure data types 13-18 */ if i<87 then goto standard_types; /* string data types 19-22 */ if i=87 then goto non_standard_types; /* file data type 23 */ /* unsigned binary and packed decimal data types 33-46 */ standard_types: call dnd$with_strings(ps.descr,addr(descriptive),code); if code=1 then goto err232; if type5.cr="s" then go to is_string; call assign_type_d(ps.descr,psp,picture_p,intype,inscale_prec); if ps.descr="0"b then do; intype = char_desc*2; if picture_p->picture_image.type = cplx_fixed_picture | picture_p->picture_image.type = cplx_float_picture then inscale_prec = picture_p->picture_image.varlength * 2; /* a cplx pic's varlength is len of real part only */ else inscale_prec = picture_p->picture_image.varlength; end; call assign_(addr(v_output),v_char_desc*2,516,ps.vp,intype,inscale_prec); n_out = length(v_output); output = v_output; publish: /* put_field will put on the terminal blank or, if it is the last data directed, the semi in due course as " x=5 " OR " x=5;" */ call plio2_put_util_$put_field_(psp,addr(output),n_out); return; is_string: if type5.ff="v" /* varying */ then descriptive.prec=addrel(ps.vp,-1)->based_VL; if descriptive.prec > 256 then goto string_too_big; if type5.bd="b" then go to bits; if ps.fsbp->fsb.switch.print then if ps.job.list then do; n_out=descriptive.prec; substr(output,1,n_out)=substr(ps.vp->based_chars,1,n_out); go to publish; end; substr(output,1,1)=""""; n_out=2; do i=1 to descriptive.prec; x=substr(ps.vp->based_chars,i,1); if x="""" then do; substr(output,n_out,1)=""""; n_out=n_out+1; end; substr(output,n_out,1)=x; n_out=n_out+1; end; substr(output,n_out,1)=""""; go to publish; bits: substr(output,1,1)=""""; do i=1 to descriptive.prec; if substr(ps.vp->based_bits,i,1) then x="1"; else x="0"; substr(output,i+1,1)=x; end; n_out=descriptive.prec+3; substr(output,n_out-1,2)="""b"; go to publish; /* */ dcl packed bit(1) aligned; dcl b36 bit(36) aligned; dcl pt ptr; dcl based_ptr ptr based; dcl based_packed_ptr ptr unaligned based; dcl title5 char(5) aligned; dcl title7 char(7) aligned; dcl ioa_$rsnnl entry options(variable); non_standard_types: packed=substr(ps.descr,8,1); goto nst(i); nst(77): if packed then pt=ps.vp->based_packed_ptr; else pt=ps.vp->based_ptr; title7="pointer"; single_ptr: call ioa_$rsnnl("^a(^p)",output,n_out,title7,pt); goto publish; nst(78): if packed then b36=substr(ps.vp->based_bits,1,36); else b36=ps.vp->based_bit36; call ioa_$rsnnl("offset(^w)",output,n_out,b36); goto publish; nst(79): title5="label"; goto double_ptr; nst(80): title5="entry"; goto double_ptr; nst(87): title5="file "; goto double_ptr; double_ptr: call ioa_$rsnnl("^a(^p,^p)",output,n_out,title5,ps.vp->p_vector(1),ps.vp->p_vector(2)); goto publish; nst(82): title7="area at"; goto single_ptr; nst(81): substr(output,1,9)="structure"; n_out=9; goto publish; end plio2_ldo_;  plio2_octptr_.pl1 10/03/83 1722.3rew 10/03/83 1005.4 9288 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_octptr_:proc options(support); octptr:entry(s,o) returns(ptr); dcl (s,o) char(*); dcl op ptr; dcl (substr,addr,null,index,length) builtin; dcl (si,oi,i,ti) fixed bin(17); dcl 1 ptrform aligned based(addr(op)), 2 filler(4) fixed bin(17) unaligned; op=null; si,oi=0; do i=1 to length(s); ti=index("01234567",substr(s,i,1)); if ti=0 then goto badptr; si=si*8+ti-1; end; do i=1 to length(o); ti=index("01234567",substr(o,i,1)); if ti=0 then goto badptr; oi=oi*8+ti-1; end; filler(1)=si; filler(3)=oi; badptr: return(op); end plio2_octptr_;  plio2_open_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 188415 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_open_: proc options (support); /* Modified 790710 by PCK to fix bug 1845 */ /* Modified 790327 by RAB to use stackframeptr builtin */ /* Modified 780706 by PG to fix close_in_this_static to unthread multiple fsb's properly */ /* Modified 780309 by PG to fix 1706 (sysprint didn't get print attribute if opened explicitly) */ /* Modified 78.01.31 by RAB for close_in_this_static */ /* Modified 77.09.19 by RAB to fix 1674 in which get_chars was attempted for I/O modules that didn't support it */ /* Modified 770823 by PG to permit read & write statements on stream files */ /* 77-03-04: changed to support quick pl1 io by adding the "console" bit to the fsb */ /* 76-09-08: changed to use iox_$foo call forwarder */ /* 76-03-12: changed to get right referencing_dir for search rules in call to iox_$attach */ /* 75-05-27: changed to fix bug 1363 */ /* 74-12-17: modified for bit_string in job_bits,lock checking removed */ /* 74-12-2: modified for env(stringvalue) */ /* 74.09.12: fixed for add_finish_handler */ /* 73-12-3: updated for new io (iox). */ /* parameters */ dcl (pspp ptr, xname char (*) ) parameter; /* based */ dcl bch168 char (168) aligned based; dcl based_label label based; dcl 1 fab aligned based, 2 switch bit (36) aligned, 2 name char (32) aligned, 2 (line_size, page_size, buffer_size) fixed bin (17), 2 ch168p ptr; /* builtins */ dcl (addr, baseno, bit, fixed, min, null, rel, stackframeptr, string, substr) builtin; /* entries */ dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl ioa_ options (variable); dcl plio2_recio_$recio_close_ ext entry (ptr); dcl plio2_signal_$s_ ext entry (ptr, char (*), char (*), fixed bin (15)); dcl plio2_signal_$s_r_ ext entry (ptr, char (*), char (*), fixed bin (15)); dcl com_err_ entry options (variable); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl add_epilogue_handler_ entry (entry, fixed bin (35)); dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl unique_bits_ entry returns (bit (70)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$err_no_operation entry; /* external static */ dcl plio2_data_$max_page_size fixed bin (35) external; /* internal static */ dcl begining_of_file fixed bin int static options(constant) initial(-1); dcl debug_sw fixed bin (15) static internal init (0); /* automatic */ dcl evx entry variable; dcl code fixed bin (35); dcl (psp, fsbp, fabp, fab2p) ptr; dcl (i, iroute, erno) fixed bin (15); dcl title_option bit (1) aligned; dcl lnzc_set bit (1) aligned init ("0"b); dcl condition char (13) init ("ERROR"); dcl fab2px ptr; dcl (default_ps, default_ls) fixed bin (35); dcl (A18, B18) bit (18) aligned; dcl nono_18 bit (18) aligned; dcl iocb_name char (32); dcl iocb_status fixed bin (35) init (0); dcl iocb_p ptr; dcl iocb_title char (200); dcl iocb_attach_type fixed bin; dcl 1 temp_file aligned like file_value; dcl 1 temp_ps aligned like ps; dcl fabprime bit (36) aligned; /* include files */ %include stack_frame; %include pl1_file_value; %include plio2_fsb; %include plio2_fsbr; %include plio2_ps; %include iocb; /* program */ /* OPEN ENTRIES */ open_implicit_: entry (pspp); psp = pspp; fsbp = ps.fsbp; fab2p = ps.fab2p; iroute = 4; go to open_question; open_explicit_: entry (pspp); iroute = 1; plio2_data_$pspstat, psp = pspp; plio2_data_$fsbpstat, ps.fsbp, fsbp = ps.source_p -> file_value.fsb_ptr; plio2_data_$fab2pstat, ps.fab2p, fab2p = ps.special_list_p; ps.file_p = ps.source_p; addr (ps.ab_return) -> based_label = EXIT; open_question: if fsb.switch.open then go to check; /* thread on first opening and at the same time store the declared attributes and filename in the FSB. To get new declared attributes (for debugging) RENEW by unthreading, zeroing FSB-attributes */ if fsb.switch.threaded then fsb.declared_attributes (1) = fsb.declared_attributes (1) | ps.source_p -> file_value.fab_ptr -> fab.switch; else do; fsb.fsb_thread = plio2_data_fsb_thread_; if fsb.fsb_thread = null then do; evx = close_all_; call add_epilogue_handler_ (evx, code); if code ^= 0 then call com_err_ (code, "plio2_$open", "Unable to add epilogue handler."); end; fabp = ps.source_p -> file_value.fab_ptr; fsb.declared_attributes (1) = fabp -> fab.switch; fsb.filename = fabp -> fab.name; /* avoid a LOOP in the THREAD as surely as easily possible by setting the "threaded" bit here. */ plio2_data_fsb_thread_ = fsbp; fsb.switch.threaded = "1"b; end; title_option = "0"b; /* but we will look to see if there is one */ if fab2p -> fab.name ^= "" then do; title_option = "1"b; fsb.title = fab2p -> fab.name; end; else fsb.title = fsb.filename; if iroute = 4 then goto no_title168; /* no title with implicit opening */ if substr (fab2p -> fab.switch, 3, 1) = "0"b then goto no_title168; /* compiled with version 1 of PL1 */ if fab2p -> fab.buffer_size = -111111111111011101b then goto no_title168; /* corrects for bug in early version 2 PL1 compilers */ if fab2p -> fab.ch168p = null then goto no_title168; /* no title option */ fsb.path_name = fab2p -> fab.ch168p -> bch168; /* title168 is correctly present - use it */ title_option = "1"b; goto title_is_set; no_title168: if ^title_option then fsb.path_name = "vfile_ " || fsb.filename; else fsb.path_name = fsb.title; title_is_set: if substr (fsb.declared_attributes (1), 28, 1) /* internal */ then fsb.title = unique_chars_ (unique_bits_ ()); else fsb.title = fsb.filename; iocb_name = fsb.title; /* COMMENT ON ALL OF THESE NAMES: at this point we have: fsb.filename = declared file name fsb.title = (a) fsb.filename if external = (b) uniquename if internal and is to be used as iocb_name (for find_iocb) fsb.path_name= (a) "vfile_ "||fsb.filename if no title option = (b) TITLE if title option is specified and is to be used as iocb_title (for iox_$attach_iocb) later, for the canonical sysin and sysprint, fsb.path_name will be changed to "syn_ user_input" or "syn_ user_output". */ if iroute = 1 then fab2px = fab2p; /* explicit open - use all attributes */ else do; fabprime = fab2p -> fab.switch; fab2px = addr (fabprime); if substr (fsb.declared_attributes (1), 8, 1) /* update */ then if substr (string (ps.job), 16, 2) /* read,write */ then substr (fabprime, 6, 3) = "000"b; /* in,out,up */ end; string (fsb.switch) = (fsb.declared_attributes (1)| fab2px -> fab.switch|"000000000000000000000000000010010000"b) &"111111111111111111110001000111110111"b; /* zero out: eof,prelim_eof,transmit_error,detach,iox_close,te_hold,buffer_in_use */ /* set to one: threaded,emptyline */ /* TABLES for IMPLICATIONS,DEFAULTS,CONFLICTS, "NONOS" */ dcl 1 open_bits (27) aligned static internal, 2 ( b18 init ( /* [1-15] IMPLICATIONS */ "1"b, "01"b, "1010000000"b, "0001"b, "1000100000"b, "0"b, "000100111011011"b, "0000000100010"b, "000000001"b, "0000000001"b, "00000000001"b, "000000000001"b, "0000000000001"b, "00000000100001"b, "000000000000001"b, /* [16-20] DEFAULTS */ "0111"b, /* 16 - input, output, update */ "0000101"b, /* 17 - stream, record */ "000010011"b, /* 18 - stream(!?), sequential, direct */ "0000000000011"b, /* 19 - not_used_2, stringvalue */ "00000100000001"b, /* 20 - notkeyed, keyed */ /* [21-27] NONOs */ "01"b, /* 21 - input */ "001"b, /* 22 - output */ "000000001"b, /* 23 - interactive */ "000001"b, /* 24 - notkeyed */ "000000000001"b, /* 25 - not_used_2 */ "00000000000001"b, /* 26 - keyed */ "00001"b), /* 27 - stream */ c18 init ( /* [1-6] [7-15] CONFLICTS */ "011"b, "0101"b, "0011"b, "0000101"b, "000000011"b, (10) (1)"0"b, /* [16-20] DEFAULTS */ "01"b, /* 16 - input */ "00001"b, /* 17 - stream */ "00000001"b, /* 18 - sequential */ "00000000001"b, /* 19 - not_used_1 */ "000001"b, /* 20 - notkeyed */ /* [21-27] NONOs */ "0001111"b, /* 21 - write, rewrite, delete, locate */ "001011"b, /* 22 - read, rewrite, delete */ "00000000000010011"b, /* 23 - ignore, nokey, nokeyfrom */ "0000000111"b, /* 24 - key, keyto, keyfrom */ "000000000010001"b, /* 25 - set, nofrom */ "00000000000000001"b, /* 26 - nokeyfrom */ "0000111"b) /* 27 - rewrite, delete, locate */ ) bit (18) unaligned; A18 = substr (string (fsb.switch), 5, 15); /* NOTE: begins on bit number 5 */ B18 = "0"b; /* Open step 2. Supply implied attributes */ do i = 1 to 15; if A18 & open_bits.b18 (i) then substr (B18, i, 1) = "1"b; end; /* Open step 3. Supply default attributes */ do i = 16 to 20; if (B18 & open_bits.b18 (i)) = "0"b then B18 = (B18 | open_bits.c18 (i)); end; /* Open step 4. Supply print attribute. */ if (fsb.filename = "sysprint") & substr (B18, 5, 1) /* stream */ & substr (B18, 3, 1) /* output */ & ^fsb.switch.internal then substr (B18, 1, 1) = "1"b; /* PRINT */ /* Open step 5. Check for a consistent file description. */ do i = 1 to 5; if (B18 & open_bits.c18 (i)) = open_bits.c18 (i) then do; erno = 109+i; /* 110: input and output conflict 111: input and update conflict 112: output and update conflict 113: record and stream conflict 114: sequential and direct conflict 115: forwards and backwards conflict - NOT USED ANY MORE */ go to check; end; end; if ((B18 & "0000001001"b) = "0000001001"b) /* record and interactive */ | ((B18 & "0100000001"b) = "0100000001"b) /* input and interactive */ | ((B18 & "000010000000100"b) = "000010000000100"b) /* stream and stringvalue */ then do; erno = 108; /* file cannot be opened: interactive may apply to stream output only, stringvalue may apply to record i/o only */ goto check; end; nono_18 = "0"b; do i = 21 to 27; if (B18 & open_bits.b18 (i)) then nono_18 = (nono_18 | open_bits.c18 (i)); end; if ((B18 & "000101"b) = "000101"b) then nono_18 = (nono_18 | "0001001"b); /* notkeyed and update --> no write or locate */ substr (string (fsb.switch), 5, 15) = substr (B18, 1, 15); substr (string (fsb.nono), 1, 18) = substr (nono_18, 1, 18); if fsb.filename = "sysprint" then if fsb.switch.print then if ^title_option then if ^fsb.switch.internal then fsb.path_name = "syn_ user_output"; if fsb.filename = "sysin" then if fsb.switch.input then if fsb.switch.stream then if ^title_option then if ^fsb.switch.internal then fsb.path_name = "syn_ user_input"; call iox_$find_iocb (iocb_name, iocb_p, iocb_status); if iocb_status ^= 0 then do; erno = 104; /* call to iox_$find_iocb fails */ goto attach_fails; end; fsb.iocb_p = iocb_p; if iocb_p -> iocb.attach_descrip_ptr = null then do; iocb_title = fsb.path_name; do sp = stackframeptr() repeat (sp -> stack_frame.prev_sp) while (sp -> stack_frame_flags.support); end; call iox_$attach_ptr (iocb_p, iocb_title, sp -> stack_frame.entry_ptr, iocb_status); if iocb_status ^= 0 then do; erno = 105; /* call to attach_iocb fails */ goto attach_fails; end; else fsb.switch.detach = "1"b; end; if iocb_p -> iocb.open_descrip_ptr = null then do; if fsb.switch.input then iocb_attach_type = 1; else if fsb.switch.output then iocb_attach_type = 2; else iocb_attach_type = 3; if fsb.switch.record then if fsb.switch.direct then iocb_attach_type = iocb_attach_type+10; else if fsb.switch.keyed then iocb_attach_type = iocb_attach_type+7; else iocb_attach_type = iocb_attach_type+3; if iocb_attach_type = 6 then iocb_attach_type = 7; /* iox_ has 4 io types: in,out,up, and in-out */ call iox_$open (iocb_p, iocb_attach_type, "0"b, iocb_status); if iocb_status ^= 0 then do; erno = 106; /* call to iocb.open fails */ goto attach_fails; end; fsb.switch.iox_close = "1"b; goto is_iox_opened; end; /* Here we may test compatibility for data-sets already opened. Not implemented 73-12-3 */ /* AG94 requires that files with the input stream or record sequential (input | update) attributes be positioned to the beginning of the file. If iox_$open has been called this was already done, otherwise iox_$position must be called. */ if (fsb.stream & fsb.input) | (fsb.record & fsb.sequential & (fsb.input | fsb.update)) then call iox_$position (iocb_p, begining_of_file, 0, iocb_status); is_iox_opened: if fsb.switch.record then do; string (fsbr.recio) = "000"b; string (fsbr.inbuf_sw) = "0"b; string (fsbr.outbuf_sw) = "0"b; fsbr.lnzc = 0; fsbr.outbuf_key = ""; fsbr.key_saved = ""; end; else do; i = get_line_length_$switch (iocb_p, iocb_status); if iocb_status = 0 then do; default_ls = i; default_ps = plio2_data_$max_page_size; fsb.console = "1"b; /* if there was a meaningful line len, we will want to use get_line, not get_chars */ end; else do; default_ls = 132; default_ps = 60; if iocb_p -> iocb.get_chars = iox_$err_no_operation then fsb.console = "1"b; /* use get_line for input */ else fsb.console = "0"b; /* use get_chars for input */ end; if fab2p -> fab.line_size>0 then fsb.lsize = fab2p -> fab.line_size; else fsb.lsize = default_ls; if fsb.switch.print then do; if fab2p -> fab.page_size>0 then fsb.psize = fab2p -> fab.page_size; else fsb.psize = default_ps; end; else fsb.psize = 0; /* 0 for 'not a print file' */ /* AG94 specifies that if a linesize is given then the file _m_u_s_t have the output attribute; and that if a pagesize is given then it _m_u_s_t have the print attribute. The punishment is unspecified and none is supplied here. */ fsb.blc, fsb.kol = 0; fsb.lineno, fsb.pageno, fsb.bnc = 1; if fsb.print then fsb.lsep = 4; /* set up for initial PAGE option */ else fsb.lsep = 1; /* set up for GET LIST initial comma */ fsb.bptr = addr (fsb.buffer); fsb.bsize = 848; if fsb.stream then if fsb.output then fsb.limit = min (fsb.bsize, fsb.lsize); end; /* C A U T I O N : check this value against fsb.incl.pl1 at fsb.buffer. Size is in bytes. */ fsb.switch.open = "1"b; goto check; attach_fails: if debug_sw = 1 then call ioa_ ("iocb_status=^d", iocb_status); fsb.lnzc = iocb_status; lnzc_set = "1"b; check: if ^fsb.switch.open then do; if fsb.switch.iox_close then call iox_$close (iocb_p, iocb_status); if iocb_status ^= 0 then do; fsb.lnzc = iocb_status; lnzc_set = "1"b; end; if fsb.switch.detach then call iox_$detach_iocb (iocb_p, iocb_status); if iocb_status ^= 0 then do; fsb.lnzc = iocb_status; lnzc_set = "1"b; end; if ^lnzc_set then fsb.lnzc = 0; call plio2_signal_$s_ (psp, "UNDEFINEDFILE", "plio2_open_", erno); end; if iroute = 1 then return; if ^fsb.switch.open then do; condition = "ERROR"; erno = 102; /* file not open after return from handler of undefinedfile */ call plio2_signal_$s_r_ (psp, condition, "plio2_open_", erno); end; return; debug_open: entry; debug_sw = 1-debug_sw; return; clear_sysprint_: entry; call hcs_$make_ptr (null, "stat_", "sysprint.fsb", fsbp, code); if fsbp = null then return; if fsb.switch.open then if ^fsb.switch.internal then if fsb.switch.stream then if fsb.switch.output then do; fsb.bnc = 1; fsb.lineno = 1; fsb.pageno = 1; fsb.kol = 0; return; end; return; set_pageno: entry (isfile, page_num); dcl isfile (2) ptr; dcl page_num fixed bin (15); dcl pnln fixed bin (15); pnln = 1; goto pnlnjoin; get_pageno: entry (isfile) returns (fixed bin (15)); pnln = 2; goto pnlnjoin; get_lineno: entry (isfile) returns (fixed bin (15)); pnln = 3; pnlnjoin: fsbp = isfile (2); if ^fsb.switch.open then do; erno = 141; get_lineno_sig: call plio2_signal_$s_ (null, "ERROR", "get_lineno", erno); if pnln = 1 then return; else return (0); end; if ^fsb.switch.print then do; erno = 142; goto get_lineno_sig; end; if pnln = 1 then do; fsb.pageno = page_num; return; end; if pnln = 2 then return (fsb.pageno); else return (fsb.lineno); /* CLOSE ENTRIES */ close_: entry (pspp); psp = pspp; plio2_data_$pspstat = psp; fsbp = ps.source_p -> file_value.fsb_ptr; iroute = 10; go to close10; closebyname_: close_by_name_: entry (xname); dcl msg_sw bit (1) ; dcl found_name bit (1); msg_sw = "0"b; by_name_join: found_name = "0"b; psp = null; dcl name32 char (32) aligned; name32 = xname; iroute = 12; fsbp = plio2_data_fsb_thread_; do while (fsbp ^= null); if name32 = fsb.filename then do; go to close10; by_name_rejoin: found_name = "1"b; end; fsbp = fsb.fsb_thread; end; if found_name then return; if ^msg_sw then call ioa_ ("filename ^a not found", xname); else by_name_code = /* error_table_$no_file */ 1 ; return; close_by_name_sys_: entry (xname, by_name_code); dcl by_name_code fixed bin (35); by_name_code = 0; msg_sw = "1"b; go to by_name_join; closeall_: closeall: close_all: close_all_: entry; psp = null; iroute = 11; fsbp = plio2_data_fsb_thread_; do while (fsbp ^= null); close10: plio2_data_$fsbpstat = fsbp; if fsb.switch.open then do; if fsb.switch.record then do; temp_file.fab_ptr = null; temp_file.fsb_ptr = fsbp; temp_ps.source_p = addr (temp_file); call plio2_recio_$recio_close_ (addr (temp_ps)); end; iocb_p = fsb.iocb_p; if fsb.switch.iox_close then call iox_$close (iocb_p, iocb_status); if iocb_status ^= 0 then do; fsb.lnzc = iocb_status; lnzc_set = "1"b; end; if fsb.switch.detach then call iox_$detach_iocb (iocb_p, iocb_status); if iocb_status ^= 0 then do; fsb.lnzc = iocb_status; lnzc_set = "1"b; end; fsb.switch.open = "0"b; end; if iroute = 10 then return; if iroute = 12 then go to by_name_rejoin; fsbp = fsb.fsb_thread; end; return; listfiles: entry (); fsbp = plio2_data_fsb_thread_; call ioa_ ("thread:^p", fsbp); do while (fsbp ^= null); call ioa_ (" fsbp=^p,name=^a", fsbp, fsbp -> fsb.filename); fsbp = fsbp -> fsb.fsb_thread; end; EXIT: return; get_fsb_thread: entry (pspp); pspp = plio2_data_fsb_thread_; return; set_fsb_thread: entry (pspp); plio2_data_fsb_thread_ = pspp; return; /* This procedure closes and unthreads all fsb's contained in a specified static section. */ close_in_this_static: entry (start_thread, static_ptr, static_len); dcl start_thread ptr, /* start of fsb thread (Input/Output) */ static_ptr ptr, /* start of static section (Input) */ static_len fixed bin (18); /* length of static section in words (Input) */ dcl (static_seg_no, static_start, static_end) bit (18) aligned; dcl last ptr; static_seg_no = baseno (static_ptr); static_start = rel (static_ptr); static_end = bit (fixed (fixed (static_start, 18) + static_len, 18), 18); psp = null; last = null; do fsbp = start_thread repeat fsbp -> fsb.fsb_thread while (fsbp ^= null); if baseno (fsbp) = static_seg_no & rel (fsbp) >= static_start & rel (fsbp) < static_end then do; if fsbp -> fsb.switch.open then do; temp_file.fab_ptr = null; temp_file.fsb_ptr = fsbp; temp_ps.source_p = addr (temp_file); call close_ (addr (temp_ps)); end; if last ^= null then last -> fsb.fsb_thread = fsbp -> fsb.fsb_thread; else start_thread = fsbp -> fsb.fsb_thread; end; else last = fsbp; end; return; end /* plio2_open_ */;  plio2_pdt_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 46809 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_pdt_: put_value_data_:proc(pspp) options(support); % include plio2_ident; /* updated 10-14-71 */ go to start; dcl (pspp,psp,sslp ) ptr; dcl (offset,i,ii) fixed bin(15); dcl idesc bit(36); dcl (addr,addrel,bit,divide,fixed,null,substr) builtin; dcl plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15)); dcl plio2_put_util_$put_prep_ ext entry(ptr); dcl plio2_ldo_$ldo_for_data ext entry(ptr); dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(17)); dcl plio2_sym_to_desc ext entry(ptr,ptr,ptr,ptr) returns(bit(36) aligned); % include plio2_ps; /* */ % include runtime_symbol; dcl identifier_string char(256) aligned; dcl char_buf char(1000) unaligned based; dcl name_string char(512) varying; dcl ssl(100) fixed bin(15) based; dcl jtype fixed bin(12); dcl isize fixed bin(35); dcl ( dfxb15 init("100000100000000000000000000000001111"b), dfxd63 init("100100100000000000000000000000111111"b) ) bit(36) static internal; dcl subscr_dec char(64) aligned; dcl icode fixed bin(15); dcl (last_node_p,l1_p,name_p,stack_frame(17) based,sym_p,sym_q,new_sp) ptr; dcl stu_$decode_value ext entry(fixed bin(35),ptr,ptr,fixed bin(15)) returns( fixed bin(35)); dcl subscr fixed bin(15); dcl subscr_string char(32) aligned; dcl subscr_chl fixed bin(15); dcl bbit36 bit(36) based; dcl bbit9 bit(9) based; dcl fixed9 fixed bin(9); dcl isl fixed bin(15); /* identifier string length */ dcl carry fixed bin(15); dcl dgt(0:9) char(1) static internal init("0","1","2","3","4","5","6","7","8","9"); /* */ start: psp=pspp; ps.switch.semi_sep="0"b; if ps.prep^=0 then call plio2_put_util_$put_prep_(psp); last_node_p, sym_p=addrel(ps.ST_top_p,ps.offset); /* given addr(symbol_node) obtain a descriptor taking care of the two contingencies: first, that it may be either an old or a new ST. second, that it may be an element or an array node. */ /* get the level one ST_node_pointer */ sym_q=sym_p; loop_struct: if fixed(sym_q->runtime_symbol.level,6)<2 then go to level_1_node; sym_q=addrel(sym_q,sym_q->runtime_symbol.father); go to loop_struct; level_1_node: l1_p=sym_q; if sym_p->runtime_symbol.type="111111"b then do; idesc = "0"b; ps.top_half = bit(fixed(sym_p->runtime_symbol.size,18),18); end; else idesc=plio2_sym_to_desc(sym_p,l1_p,psp,null); /* the null stack frame ptr will be replaced by s_to_d using information in PS */ /* */ /* make name */ isl=0; name_string=""; sym_p=last_node_p; /* start from level_N_name */ name_loop: name_p=addrel(sym_p,sym_p->runtime_symbol.name); fixed9=fixed(name_p->bbit9,9); name_string=substr(name_p->char_buf,2,fixed9)||"."||name_string; isl=fixed9+isl+1; if isl>255 then goto err244; if sym_p=l1_p then go to end_name_loop; /* end at the level one node */ /* if fixed(sym_p->runtime_symbol.level,6)<2 then go to end_name_loop; */ sym_p=addrel(sym_p,sym_p->runtime_symbol.father); go to name_loop; end_name_loop: sslp=ps.ss_list_p; if sslp->ssl(1)>0 then do; substr(name_string,isl,1)="("; do i=2 to sslp->ssl(1)+1; subscr=sslp->ssl(i); if subscr<0 then do; subscr=-subscr; isl=isl+1; name_string=name_string||"-"; end; if subscr=0 then do; name_string=name_string||"0,"; isl=isl+2; end; else do; do ii=64 to 1 by -1; carry=divide(subscr,10,35,0); substr(subscr_dec,ii,1)=dgt(subscr-10*carry); if carry=0 then go to signif; subscr=carry; end; signif: name_string=name_string||substr(subscr_dec,ii,65-ii)||","; isl=isl+66-ii; end; if isl>255 then goto err244; end; substr(name_string,isl,1)=")"; /* replaces the final comma with the close_paren */ end; /* end of subscript pack */ else isl=isl-1; /* kill the final DOT: a.b.c. -> a.b.c */ publish_name: identifier_string=substr(name_string,1,isl)||"="; isl=isl+1; call plio2_put_util_$put_field_(psp,addr(identifier_string),isl); ps.descr=idesc; ps.vp=ps.value_p; call plio2_ldo_$ldo_for_data(psp); return; err244: call plio2_signal_$s_(psp,"ERROR","put data",244); /* err244: Identifier longer than 255 not handled by this implementation */ isl=255; goto publish_name; end plio2_pdt_;  plio2_put_util_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 152514 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_put_util_:proc options(support); /* updated 73-12-6 */ /* 770526 to fix 1626 by RAB */ /* 76-09-08: changed to use iox_$put_chars call forwarder */ /* 73-12-6: changed over for iox_ */ /* 73-10-30: fixed for new splitting rules and an entry for clearing output buffers introduced. */ /* 9-27-72: finished internal-proceduring; added */ /* 9-7-72: began internal-proceduring it and fixed bug in put_normal_char */ /* 1-28-72: pageno stuff added */ /*1-21-72: There should no longer be non-explicit files */ /* 8-2-71: slight fix to handling of SKIP by put_prep */ /* plio2_put_util_$ contains the entries: put_prep_(psp) put_terminate_(psp) put_copy_(psp,n) put_page_(psp) put_skip_(psp,n) put_line_(psp,n) put_column_(psp,n) put_field_(psp,csp,csl) and, internally, the PUT_PUBLISH code which includes the code for the host interface procedure WRITE_HOST. This is the only procedure in the stream-directed output package which actually touches the output stream, that is, actually writes. */ /* automatic */ dcl (pspp,psp,sptr,fsbp,fieldp,fieldpp) ptr; dcl (erno,nn,skip_count,target_line,fieldl,fieldll,/*col_no,*/blanks_out,blanks_left) fixed bin(15); dcl (pfstart,kkolx,sl,si,sll,shortline,/*iskip,*/testkol) fixed bin(15); dcl (x,y) char(1) aligned; /* based */ dcl based_int fixed bin (35) based; dcl p_vector (100) ptr based; /* builtins */ dcl (addr, addrel, divide, min, mod, null, substr, string) builtin; /* internal static */ dcl NL char(1) aligned static internal init(" "); dcl TAB char(1) aligned static internal init(" "); dcl BL char(1) aligned static internal init(" "); dcl SEMI char(1) aligned static internal init(";"); dcl new_line_line char(100) aligned static internal init((100)" "); dcl blank_line char(100) aligned static internal init(" "); dcl 1 putfab2 aligned static internal, 2 pfs bit(36) aligned init("001000101"b), 2 pfn char(32) aligned init(" "), 2 (pfbs,pfls,pfps) fixed bin(35) init(0); dcl ybuf char(1000) aligned based(sptr); dcl ioa_ ext entry options(variable); dcl put_data_block_all_ entry (ptr); dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl plio2_open_$open_implicit_ ext entry(ptr); dcl ctl_char$cr char(1) ext; dcl ctl_char$np char(1) ext; dcl iocb_p ptr; dcl iocb_status fixed bin(35); dcl plio2_data_$max_page_size fixed bin(35) external; /* include files */ %include plio2_fsb; %include plio2_ps; /* program */ /* PREP */ put_prep_:entry(pspp); psp=pspp; call put_prep; return; put_prep:proc; /* By a revision of pl1_operators_'s entry stream_prep, put_prep_ will be called before any call to put_terminate_ or the transmission entries. Thus there is less need to keep the historical test of the prep_sw and call to put_prep_ in these routines. The reason for putting back the "prep_call" which was so carefully removed in the original design is to assure that the output file is open BEFORE the first element for transmission is evaluated. */ plio2_data_$pspstat=psp; ps.prep=0; string(ps.switch)="0"b; if ps.job.string then do; /* STRING OPTION */ plio2_data_$pliostringfsbp, plio2_data_$fsbpstat, ps.fsbp, fsbp=ps.source_p; bnc=1; blc,kol=0; bsize=ps.number; lsize=ps.number+10000; fsb.limit=fsb.bsize; fsb.title,fsb.filename="""put_string_option"""; /* for string option, fsb.buffer, fsb.path_name, fsb.declared_attributes(2) must not be used - fske_fsb is too short */ string(fsb.switch)="001100101"b; /* v2pl1,open,stream,output */ /* fsb.bptr has already been set to addr(string) by the calling program */ ps.file_p=null; goto exit_put_prep; end; /* FILE or SYSPRINT */ if ps.job.explicit_file then ps.file_p=ps.source_p; else do; call ioa_ ("error in put_util: no explicit file"); ps.file_p=addr_sysprint(); ps.job.explicit_file="1"b; end; ps.fsbp,fsbp,plio2_data_$fsbpstat=ps.file_p->p_vector(2); if fsb.switch.open then go to open1; /* IMPLICIT OPEN */ plio2_data_$fabpstat,ps.fabp=ps.file_p->p_vector(1); plio2_data_$fab2pstat,ps.fab2p=addr(putfab2); call plio2_open_$open_implicit_(psp); open1: if fsb.switch.output="0"b|fsb.switch.stream="0"b then go to err221; if ps.job.skip then do; skip_count=ps.number; call put_skip; end; else do; if ps.job.page then call put_page; if ps.job.line then do; target_line=ps.number; call put_line; end; end; exit_put_prep: ps.switch.first_field="1"b; ps.switch.semi_sep="1"b; return; end put_prep; /* TERMINATE */ put_terminate_:entry(pspp); psp=pspp; if ps.prep^=0 then call put_prep; /* see NOTE at "put_prep" */ fsbp=ps.fsbp; ps.switch.first_field="0"b; if ps.job.data then do; if ps.switch.semi_sep then do; ps.switch.first_field="1"b; call put_data_block_all_(psp); ps.switch.first_field="0"b; end; if bnc=1 then do; y=SEMI; call put_normal_char; end; else substr(xbuf,bnc-1,1)=";"; end; if ps.job.string then do; if ps.job.varying_string then addrel(bptr,-1)->based_int=bnc-1; else do; if bnc>bsize then return; substr(xbuf,bnc,bsize+1-bnc)=" "; end; return; end; if fsbp->fsb.switch.interactive then do; skip_count=1; call put_skip; end; call put_publish; return; clear_output_buffer:entry(pspp); psp=pspp; if ps.job.string then return; fsbp=ps.fsbp; if ^fsb.switch.open then return; if ^fsb.switch.output then return; if ^fsb.switch.stream then return; fsb.bnc=1; fsb.lineno=1; fsb.kol=0; fsb.switch.emptyline="0"b; return; put_publish_:entry(pspp); psp=pspp; fsbp=ps.fsbp; call put_publish; return; put_field_:entry(pspp,fieldpp,fieldll); psp=pspp; fsbp=ps.fsbp; if ps.job.edit then do; call put_field; return; end; if ps.switch.first_field then do; if kol=0 then go to post_tab; if fsb.switch.print then do; testkol=10 + 10*divide(kol-1,10,35,0); if testkol=kol then goto post_tab; kol=testkol; if kollsize then go to pf1; kol=kkolx; /* ASSUMES that field consists of single column characters only !!!!!!!!!!!!!! */ go to pf22; pf2: kol=fieldl; /* kol must have been =0 */ pf22: sl=fieldl; /* "put" remainder of string in one piece */ si=pfstart; call insert_string; return; pf1: if ps.job.edit then go to pf3; pf4: if kol^=0 then call put_new_line; if emptyline then call put_new_line; if fieldl<=lsize then go to pf2; shortline=lsize; go to pf33; pf3: shortline=lsize-kol; pf33: sl=shortline; si=pfstart; call insert_string; /* kol=lsize but see below that kol becomes 0 */ fieldl=fieldl-shortline; pfstart=pfstart+shortline; call put_new_line; /* kol becomes 0 */ goto try_this_line; end put_field; put_normal_char:proc; /* The "put_field" for a single character. */ if kol=lsize then call put_new_line; kol=kol+1; x=y; call insert_char; end put_normal_char; put_skip_fast:proc; /* sets kol=0,emptyline,lineno */ /* doesn't care about psize !!! */ if skip_count > 1 then go to psf98; x=NL; call insert_char; goto exit_psf; psf98: sptr=addr(new_line_line); si=1; psf99: if skip_count>100 then go to psf100; sl=skip_count; call insert_string; fsb.limit = min(bsize,lsize+bnc-1); goto exit_psf; psf100: sl=100; call insert_string; skip_count=skip_count-100; lineno=lineno+100; go to psf99; exit_psf: kol=0; emptyline="0"b; lineno=lineno+skip_count; end put_skip_fast; /* */ insert_char:proc; /* doesn't care about lsize or psize */ if bnc>bsize then call put_publish; substr(xbuf,bnc,1)=x; if x=NL | x=ctl_char$cr | x=ctl_char$np then fsb.limit = min(bsize,lsize+bnc); bnc=bnc+1; return; end insert_char; insert_string:proc; /* doesn't care about psize or lsize */ insert_string_1: if sl<1 then return; if sl < bsize-bnc+2 then do; substr(xbuf,bnc,sl)=substr(ybuf,si,sl); bnc=bnc+sl; return; end; sll=bsize+1-bnc; substr(xbuf,bnc,sll)=substr(ybuf,si,sll); bnc=bsize+1; call put_publish; sl=sl-sll; si=si+sll; go to insert_string_1; end insert_string; put_publish:proc; if ps.job.string then goto err220; iocb_p=fsb.iocb_p; if bnc>1 then do; call iox_$put_chars(iocb_p,bptr,bnc-1,iocb_status); if iocb_status ^=0 then fsb.switch.transmit_error="1"b; bnc=1; /* buffer has been cleared */ fsb.limit=min(bsize,lsize-kol); if fsb.switch.transmit_error then call plio2_signal_$s_(psp,"TRANSMIT", "put_util",222); fsb.switch.transmit_error="0"b; end; return; end put_publish; addr_sysprint:proc returns(ptr); dcl sysprint file print stream output; return(addr(sysprint)); end addr_sysprint; /* */ /*put_column_:entry(pspp,nn); */ /* psp=pspp; */ /* fsbp=ps.fsbp; */ /* col_no=nn; */ /* */ /* if col_no>lsize | col_no<1 then col_no=1; */ /* /* AG94 doesn't say what to do if col_no<1 */ /* if col_no>kol then goto pc90; */ /* call put_new_line; */ /*pc90: */ /* iskip=col_no -1 -kol; /* number of intervening blanks */ /* kol =col_no -1; /* kol of last of these blanks is col_no -1 */ /* */ /* sptr=addr(blank_line); */ /* si=1; */ /*pc99: */ /* if iskip>100 then go to pc100; */ /* sl=iskip; */ /* call insert_string; */ /* return; */ /*pc100: */ /* sl=100; */ /* call insert_string; */ /* iskip=iskip-100; */ /* go to pc99; */ /* */ /* */ put_blanks_:entry(pspp,nn); psp=pspp; fsbp=ps.fsbp; do blanks_left=nn repeat(blanks_left-100) while (blanks_left>0); blanks_out=min(blanks_left,100); call put_field_(psp,addr(blank_line),blanks_out); end; return; /*put_skip_:entry(pspp,nn); */ /* psp=pspp; */ /* fsbp=ps.fsbp; */ /* skip_count=nn; */ /* call put_skip; */ /* return; */ /* */ /* */ put_skip:proc; if ps.job.string then goto err223; fsb.limit = min(fsb.bnc+fsb.lsize,fsb.bsize); if skip_count>0 then go to pso_1; if fsb.switch.print then do; x=ctl_char$cr; call insert_char; kol=0; emptyline="1"b; return; end; goto err224; pso_1: if lineno>psize | (lineno+skip_count)<=psize then do; call put_skip_fast; return; end; call fill_page_with_NLs; call plio2_signal_$s_(psp,"ENDPAGE","put_skip",225); return; end put_skip; /* */ /* */ /* */ /*put_line_:entry(pspp,nn); */ /* psp=pspp; */ /* fsbp=ps.fsbp; */ /* target_line=nn; */ /* call put_line; */ /* return; */ put_line:proc; if ps.job.string then goto err226; if ^fsb.switch.print then goto err227; if target_line<1 then target_line=1; /* AG94 says "must be >0" */ if target_line=lineno then return; if lineno > psize then do; if target_line > lineno then do; skip_count=target_line-lineno; call put_skip_fast; end; else call put_page; return; end; if target_line < lineno | target_line > psize then do; call fill_page_with_NLs; call plio2_signal_$s_(psp,"ENDPAGE","put_line",228); return; end; /* lineno < target_line */ skip_count=target_line-lineno; call put_skip_fast; return; end put_line; /* */ /* */ /* */ /*put_page_:entry(pspp); */ /* psp=pspp; */ /* fsbp=ps.fsbp; */ /* call put_page; */ /* return; */ put_page:proc; /* call fill_page_with_NLs; */ if (lineno<=psize) | (kol>0) | (kol=0 & emptyline) then do; x=NL; call insert_char; end; lineno=1; pageno=pageno+1; kol=0; emptyline="0"b; x=ctl_char$np; call insert_char; /* MULTICS must insert if necessary. */ /* This entry called by default handler for the endpage condition. */ return; end put_page; fill_page_with_NLs:proc; if ps.job.string then goto err229; if ^fsb.switch.print then goto err230; if psize=plio2_data_$max_page_size then do; kol=0; emptyline="0"b; lineno=1; return; /* RETURN */ end; /* returns with kol=0 emptyline="0"b lineno=pagesize*M+1 */ if kol^=0 then go to ppo_work; if lineno=1 then go to ppo_work; if mod(lineno,psize)^=1 then go to ppo_work; if emptyline then go to ppo_work; /* we are looking at the beginning of a page with lineno=1+N*psize, N^=1 Hence, when put_page_ is called by the handler of the PAGE condition, all that happens is that lineno=1 */ return; ppo_work: skip_count=1 - lineno + psize*(1+divide(lineno-1,psize,35,0)); call put_skip_fast; return; end fill_page_with_NLs; put_new_line:proc; /* puts the NL character duly considering psize. used by: put_field,put_tab,put_bl,put_col */ if ps.job.string then goto err226; x=NL; call insert_char; kol=0; emptyline="0"b; lineno=lineno+1; if lineno=psize+1 then call plio2_signal_$s_(psp,"ENDPAGE","new_line",231); return; end put_new_line; /* */ /* ABNORMAL RETURNS */ err220: erno=220; /* PUT STRING overflows the string */ goto sig_and_return; err221: erno=221; /* FILE used with PUT STATEMENT must have stream,output attributes */ goto sig_and_return; err223: erno=223; /* SKIP not allowed with STRING OPTION */ goto sig_and_return; err224: erno=224; /* SKIP with count<1 requires PRINT attribute */ goto sig_and_return; err226: erno=226; /* LINE not allowed with STRING OPTION */ goto sig_and_return; err227: erno=227; /* LINE requires the PRINT attribute */ goto sig_and_return; err229: erno=229; /* PAGE not allowed with STRING OPTION */ goto sig_and_return; err230: erno=230; /* PAGE requires PRINT attribute */ goto sig_and_return; err233: erno=233; goto sig_and_return; sig_and_return: call plio2_signal_$s_r_(psp,"ERROR","put_util",erno); /* signals and then returns abnormally to the user's procedure */ quick_condition: entry(pspp,condition_code); dcl condition_code fixed bin(35); psp=pspp; fsbp=ps.fsbp; goto quick_cond(condition_code); quick_cond(0): /* non-zero code returned by iox_$put_chars */ fsb.transmit_error="1"b; call plio2_signal_$s_(psp,"TRANSMIT","quick_stream",222); fsb.transmit_error="0"b; return; quick_cond(1): /* ENDPAGE is to be signalled */ call plio2_signal_$s_(psp,"ENDPAGE","quick_new_line",234); return; quick_cond(2): /* LINE or PAGE option or format in PUT stmnt */ /* on file without print attribute */ erno = 235; goto qs_signal_abnormal_ret; quick_cond(3): /* COL or LINE format/option with zero value */ erno = 236; goto qs_signal_abnormal_ret; quick_cond(4): /* CONTROL format with value <0 */ erno = 237; goto qs_signal_abnormal_ret; quick_cond(5): /* SKIP(0) found on non-print file */ erno = 224; goto qs_signal_abnormal_ret; quick_cond(6): /* fill_page_with_NL's when psize = max!!!! */ erno = 233; goto qs_signal_abnormal_ret; quick_cond(7): /* "buffer", i.e. target string, overflowed on put with string option */ erno = 220; goto qs_signal_abnormal_ret; quick_cond(8): /* request is for a string of over 260 final output length */ call plio2_signal_$s_(psp,"ERROR","quick_260_limit",242); return; quick_cond(9): /* request for line(0) was made */ erno = 262; goto qs_signal_abnormal_ret; quick_cond(10): /* no parameter to format item given where one was needed */ erno = 148; goto qs_signal_abnormal_ret; quick_cond(11): /* non-zero error code returned by stu_ while evaluating format */ erno = 195; goto qs_signal_abnormal_ret; quick_cond(12): /* max nesting depth of 10 for r_formats exceeded */ erno = 197; goto qs_signal_abnormal_ret; quick_cond(13): /* attempt to restart after ERROR or SIZE */ erno = 266; goto qs_signal_abnormal_ret; quick_cond(14): quick_cond(15): quick_cond(16): quick_cond(17): quick_cond(18): /* no such quick_cond codes! */ erno = 174; goto qs_signal_abnormal_ret; qs_signal_abnormal_ret: call plio2_signal_$s_r_(psp,"ERROR","quick_put_cond",erno); /* signals & returns abnormally to user's procedure */ end plio2_put_util_;  plio2_pve_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 178119 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_pve_:proc(pspp) options(support); put_value_edit_:entry(pspp); /* Ref: see AG94 section 12.12 page 12-17 ff format statement section 8.2.12 page 8-11 ff format controlled conversion */ dcl (/*p,*/psp,pspp/*,inpicture_p,outpicture_p*/) ptr; /* dcl erno fixed bin(15); */ /* dcl (i,ipreciz,code,idn,topdigits) fixed bin(15); */ /* dcl fake_arg bit(1) unaligned based; */ /* dcl based_bits bit(1000) unaligned based; */ /* */ /* dcl decimal_temp char(130) aligned; */ /* dcl decimal char(130) aligned; */ /* */ /* dcl 1 descriptive aligned, */ /* 2 type5 aligned, */ /* 3 ( cr,bd,ff,ls,pack ) char(1) unal, */ /* 2 (prec,scale,bit_length,typex) fixed bin(15); */ /* dcl 1 based_mask aligned based(addr(type5)), */ /* 2 bc2 char(2) unaligned; */ /* dcl 1 xm12 aligned based, */ /* 2 top_24 bit(24) unal, */ /* 2 m_12 bit(12) unal; */ /* dcl 1 xlc aligned based, */ /* 2 c3 char(3) unal, */ /* 2 last_char char(1) unal; */ /* */ /* dcl ( addr,addrel,baseptr,divide,fixed,length,mod,substr,unspec) builtin; */ /* */ /*dcl plio2_fl_$reset_ ext entry(ptr); */ /*dcl plio2_fl_$get_next_ ext entry(ptr); */ /*dcl plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15)); */ /*dcl plio2_put_util_$put_prep_ ext entry(ptr); */ /*dcl plio2_put_util_$put_page_ ext entry(ptr); */ /*dcl plio2_put_util_$put_line_ ext entry(ptr,fixed bin(15)); */ /*dcl plio2_put_util_$put_skip_ ext entry(ptr,fixed bin(15)); */ /*dcl plio2_put_util_$put_column_ ext entry(ptr,fixed bin(15)); */ /*dcl dnd$with_strings ext entry(bit(36) aligned,ptr,fixed bin(15)); */ dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*), fixed bin(15)); /*dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*), fixed bin(15)); */ /* */ /* dcl sign_char char(1) unaligned; */ /* dcl format_bp ptr; */ /* dcl expstr char(5) aligned; */ /* */ /* dcl v_output char(516) varying; */ /* */ /* dcl zeroes char(256) aligned static internal init((256)"0"); */ /* */ /* dcl dgt(0:9) char(1) static internal */ /* init("0","1","2","3","4","5","6","7","8","9"); */ /* */ /* dcl 1 second_part unaligned based, */ /* 2 xxx bit(bit_offset), */ /* 2 next_bit bit(1); */ /* */ /* dcl 1 format_block aligned based(format_bp), */ /* 2 ( type,nval,val(3)) fixed bin(15); */ /* */ /* dcl (exp,ftype,iw,icomplex,is,ip,id,nval) fixed bin(15); */ /* dcl bl24 char(24) aligned init(""); */ /* */ /* dcl ( ddfix,ddflo) bit(36) aligned; */ /* dcl char256 char(256) aligned; */ /* dcl vbit256 bit(256) varying aligned; */ /* dcl efbuf char(264) aligned; */ /* dcl (lzero,ief,dscale,lpref) fixed bin(15); */ /* */ /*dcl buffer char(64) aligned; */ /*dcl space char(128) aligned; */ /* */ /*dcl conversion condition; */ /*dcl plio2_resig_ ext entry(ptr); */ /* */ /*dcl 1 dec_fixed(2) based(addr(space)) unal, */ /* 2 sign_of_mantissa char(1) unal, */ /* 2 mantissa char(outprec) unal, */ /* */ /* 1 dec_float(2) based(addr(space)) unal, */ /* 2 sign_of_mantissa char(1) unal, */ /* 2 mantissa char(outprec) unal, */ /* 2 unused bit(1) unal, */ /* 2 exponent fixed bin(7) unal; */ /* */ /*%include desc_dcls; */ /*%include desc_types; */ /*%include descriptor; */ /*%include picture_desc_; */ /*%include picture_image; */ /*%include picture_util; */ /*%include plio_format_codes; */ /*%include plio2_ps; */ /* psp=pspp; */ /* if ps.prep^=0 then call plio2_put_util_$put_prep_(psp); */ /* on conversion call plio2_resig_(psp); */ /* ps.vp=ps.value_p; */ /* ps.descr=ps.descriptor; */ /* call dnd$with_strings(ps.descr,addr(descriptive),code); */ /* if code^=0 then goto err232; */ /* */ /* if type5.cr="s" */ /* then if type5.ff="v" */ /* then ps.vp = addrel(ps.vp,-1); */ /* */ /* icomplex=0; */ /* format_bp=ps.format_area_p; */ /* if ps.new_format^=0 then call plio2_fl_$reset_(psp); */ /* */ /*get_next_format_item: */ /* */ /* call plio2_fl_$get_next_(psp); */ /* */ /*complex_edit_1: */ /* ftype=format_block.type; */ /* nval=format_block.nval; */ /* iw=format_block.val(1); */ /* */ /* if nval>0 then if iw<0 then goto bad_param_values; */ /* */ /* if icomplex>0 then go to ef_prep; */ /* */ /* if ftype24 then is=24; */ /* else is=iw; */ /* iw=iw-is; */ /* call plio2_put_util_$put_field_(psp,addr(bl24),is); */ /* goto more_x; */ /* end; */ /* */ /* if ftype=skip_format then */ /* do; */ /* if nval<1 then iw=1; */ /* call plio2_put_util_$put_skip_(psp,iw); */ /* go to get_next_format_item; */ /* end; */ /* */ /* */ /* if ftype=column_format then */ /* do; */ /* if nval<1 then go to too_few_params; */ /* if iw<1 then iw=1; /* not AG94-0 ........... */ /* call plio2_put_util_$put_column_(psp,iw); */ /* go to get_next_format_item; */ /* end; */ /* */ /* */ /* if ftype=page_format then */ /* do; */ /* call plio2_put_util_$put_page_(psp); */ /* go to get_next_format_item; */ /* end; */ /* */ /* */ /* if ftype=line_format then */ /* do; */ /* if nval<1 then go to too_few_params; */ /* if iw<1 then goto bad_param_values; */ /* call plio2_put_util_$put_line_(psp,iw); */ /* go to get_next_format_item; */ /* end; */ /* */ /*pic_format: */ /* if ftype=picture_format */ /* then do; */ /* outpicture_p = addrel(baseptr(format_block.val(2)),format_block.val(3)); */ /* */ /* call assign_type_p(outpicture_p,outtype,outscale_prec); */ /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ /* */ /* if icomplex=2 */ /* then if outtype^=char_desc*2 */ /* then outtype = outtype+4; */ /* */ /* if ps.descr="0"b */ /* then if outtype=char_desc*2 */ /* then do; */ /* call assign_(addr(buffer),char_desc*2,outscale_prec,ps.vp,intype,inscale_prec); */ /* call pack_picture_(addr(char256)->char1,p->char1,addr(buffer)->char1); */ /* */ /* icomplex = 2; */ /* */ /* goto put_field_edit; */ /* end; */ /* else do; */ /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ /* call assign_(addr(space),outtype,outscale_prec,addr(buffer),intype,inscale_prec); */ /* end; */ /* else call assign_(addr(space),outtype,outscale_prec,ps.vp,intype,inscale_prec); */ /* */ /* if icomplex=2 */ /* then i = 2; */ /* else i = 1; */ /* */ /* if outtype=D_fixed_real_desc*2 */ /* | outtype=D_fixed_cplx_desc*2 */ /* then p = addr(dec_fixed(i)); */ /* else p = addr(dec_float(i)); */ /* */ /* call pack_picture_(addr(decimal)->char1,outpicture_p->char1,p->char1); */ /* */ /* iw = outpicture_p->picture_image.varlength; */ /* */ /* substr(char256,1,iw) = substr(decimal,1,iw); */ /* */ /* goto put_field_edit; */ /* end; */ /* */ /* goto no_such_format_type; */ /* */ /*err232: */ /* erno=232; */ /* /* bad output descriptor */ /* goto sandr; */ /* */ /*too_few_params: */ /* erno=148; */ /* /* too few parameters in format item */ /* goto sandr; */ /* */ /*no_such_format_type: */ /* */ /* erno=260; */ /* /* illegal format code assembled - containt maint-pers */ /* goto sandr; */ /* */ /*bad_string_size: */ /* erno=261; */ /* /* size of field ("w") not in range 0 to 256 */ /* goto sandr; */ /* */ /*bad_param_values: */ /* erno=262; */ /* /* bad parameter value in format item (output) */ /* goto sandr; */ /* */ /*err264: */ /* erno=264; */ /* /* put edit cannot handle a string longer than 256 */ /* goto sandr; */ /* */ /*err265: */ /* erno=265; */ /* /* put edit cannot handle a string of length <0. */ /* possible compiler error. contain maint-pers. */ /* goto sandr; */ /* */ /*sandr: */ /* call plio2_signal_$s_r_(psp,"ERROR","PVE",erno); */ /* */ /*data_format: */ /* if ftype=a_format then */ /* do; */ /* if bc2="sc" then */ /* do; */ /* if type5.ff="v" */ /* then do; */ /* descriptive.prec = ps.vp->based_int; */ /* ps.vp = addrel(ps.vp,1); */ /* end; */ /* */ /* if descriptive.prec>256 then goto err264; */ /* if descriptive.prec<0 then goto err265; */ /* substr(char256,1,descriptive.prec)=substr(ps.vp->based_chars,1,descriptive.prec); */ /* end; */ /* */ /* else do; */ /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ /* */ /* if ps.descr="0"b */ /* then do; */ /* intype = char_desc*2; */ /* inprec = inpicture_p->picture_image.varlength; */ /* inscale = 0; */ /* end; */ /* */ /* call assign_(addr(v_output),v_char_desc*2,256,ps.vp,intype,inscale_prec); */ /* */ /* descriptive.prec = length(v_output); */ /* */ /* if descriptive.prec>256 then goto err264; */ /* if descriptive.prec<0 then goto err265; */ /* substr(char256,1,descriptive.prec) = substr(v_output,1,descriptive.prec); */ /* end; */ /* goto put_field_string; */ /* */ /* end; */ /* */ /* if ftype=b_format then */ /* do; */ /* if bc2="sb" then */ /* do; */ /* if type5.ff="v" */ /* then do; */ /* descriptive.prec = ps.vp->based_int; */ /* ps.vp = addrel(ps.vp,1); */ /* end; */ /* */ /* if descriptive.prec>256 then goto err264; */ /* if descriptive.prec<0 then goto err265; */ /* substr(vbit256,1,descriptive.prec)=substr(vp->based_bits,1,descriptive.prec); */ /* end; */ /* */ /* else do; */ /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ /* */ /* if ps.descr="0"b */ /* then do; */ /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ /* call assign_(addr(vbit256),v_bit_desc*2,256,addr(buffer),intype,inscale_prec); */ /* end; */ /* else call assign_(addr(vbit256),v_bit_desc*2,256,ps.vp,intype,inscale_prec); */ /* */ /* descriptive.prec = length(vbit256); */ /* */ /* if descriptive.prec>256 then goto err264; */ /* if descriptive.prec<0 then goto err265; */ /* end; */ /* */ /* char256=(128)"0"||(128)"0"; */ /* do i= 1 to descriptive.prec; */ /* if substr(vbit256,i,1) then substr(char256,i,1)="1"; */ /* end; */ /* */ /* go to put_field_string; */ /* end; */ /* */ /* if ftype=c_format then */ /* do; */ /* icomplex=1; */ /* format_bp=addrel(format_bp,5); */ /* go to complex_edit_1; */ /* end; */ /* */ /*ef_prep: */ /* if nval<1 then goto too_few_params; */ /* if iw>256 then go to bad_string_size; */ /* if iw<0 then goto bad_param_values; */ /* if iw=0 then goto edit_exit; */ /* */ /* lzero=0; */ /* sign_char="+"; */ /* efbuf=""; */ /* */ /* if ftype=e_format then */ /* do; */ /* */ /* /* E format forms - AG94 preserves the Y33 forms */ /* */ /* zeros nonzeros */ /* */ /* 0e+000 56e-123 s>0,d=0 [s=2,d=0] */ /* 0.000e+000 56.123e-123 s>d>0 [s=5,d=3] */ /* 0.000e+000 0.123e-123 s=d>0 [s,d=3] */ /* */ /* */ /* /* check parameters, make defaults */ /* if nval<2 then id=iw-8; */ /* else do; */ /* id = format_block.val(2); */ /* if id>59 then goto bad_param_values; */ /* end; */ /* if nval<3 then is=id+1; */ /* else do; */ /* is=format_block.val(3); */ /* if id>59 then goto bad_param_values; */ /* end; */ /* */ /* if id<0 | isiw then goto sig_size_for_ef; */ /* */ /* */ /* /* prepare to convert INPUT to decimal float */ /* */ /* /* NB: Technically, according to AG94-0, two */ /* conversions take place. First, INPUT->FLO DEC(n_input) */ /* and then FLO DEC(n_input)->FLO DEC(n_format). */ /* */ /* However, AG94 says elsewhere that precision of */ /* floating point number is the _m_i_n_i_m_u_m number of */ /* digits which must be kept; I may elect to keep */ /* more; and no double rounding may occur (except due to */ /* bin->dec) and so the single conversion done here */ /* is functionally equivalent to the double conversion */ /* specified. */ /* */ /* if icomplex=2 then ddflo="1001100"b; */ /* else ddflo="1001010"b; */ /* if is>59 then */ /* do; */ /* lzero=is-59; */ /* ipreciz=59; */ /* end; */ /* */ /* else ipreciz=is; */ /* */ /* expstr="e+000"; */ /* if id>0 then idn=1; else idn=0; */ /* */ /* addr(ddflo)->m_12=addr(ipreciz)->m_12; */ /* */ /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ /* call assign_type_d(ddflo,psp,outpicture_p,outtype,outscale_prec); */ /* */ /* if ps.descr="0"b */ /* then do; */ /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ /* call assign_round_(addr(decimal),outtype,outscale_prec,addr(buffer),intype,inscale_prec); */ /* end; */ /* else call assign_round_(addr(decimal),outtype,outscale_prec,ps.vp,intype,inscale_prec); */ /* */ /* /* ************************** */ /* /* */ /* /* must contrive that this */ /* /* conversion is ROUNDED */ /* /* */ /* /* ************************** */ /* */ /* if icomplex=2 then substr(decimal,1,ipreciz+2)= */ /* substr(decimal,ipreciz+3,ipreciz+2); */ /* */ /* do i= 2 to ipreciz+1; */ /* if substr(decimal,i,1)^="0" then go to float_signif; */ /* end; */ /* */ /* lzero=id+1+idn; */ /* ief=260-lzero; */ /* goto finish_e_picture; */ /* */ /*float_signif: */ /* exp=0; */ /* addr(exp)->last_char=substr(decimal,ipreciz+2,1); */ /* if exp>=128 then exp=exp-256; */ /* if i>2 then */ /* do; */ /* exp=exp+2-i; */ /* decimal_temp=decimal; */ /* substr(decimal,2,ipreciz)= */ /* substr(decimal_temp,i,ipreciz+2-i)|| */ /* substr(decimal_temp,2,i-2); */ /* end; */ /* sign_char=substr(decimal,1,1); */ /* */ /* /* make up non-trivial expstr */ /* */ /* exp=exp +id +ipreciz -is; */ /* /* shift decimal point to left (ipreciz), */ /* then to far right (is), then to proper */ /* decimal point (id) */ /* */ /* */ /* if exp<0 then */ /* do; */ /* exp=-exp; */ /* substr(expstr,2,1)="-"; */ /* end; */ /* if exp>=100 then */ /* do; */ /* exp=exp-100; */ /* substr(expstr,3,1)="1"; */ /* end; */ /* substr(expstr,4,2)=dgt(divide(exp,10,35,0))||dgt(mod(exp,10)); */ /* */ /* ief=260 - is -idn; /* leaving space for decimal point if necessary */ /* topdigits=is - id; */ /* */ /* if topdigits >= ipreciz then */ /* do; /* -xxxxxx000.00000e+000 */ /* /* if id=0 then topdigits=is */ /* and topdigits >= ipreciz; */ /* thus, id=0 is handled here */ /* substr(efbuf,ief,ipreciz)=substr(decimal,2,ipreciz); */ /* lzero=lzero+idn; */ /* end; */ /* */ /* else do; */ /* /* -xxxxx.xx0000000e+000 */ /* /* id^=0 */ /* substr(efbuf,ief,topdigits)=substr(decimal,2,topdigits); */ /* substr(efbuf,ief+topdigits+1,ipreciz-topdigits)= */ /* substr(decimal,topdigits+2, ipreciz-topdigits); */ /* */ /* if is=id then */ /* do; */ /* /* -0.xxxxxxxx00000000e+000 */ /* ief=ief-1; */ /* substr(efbuf,ief,1)="0"; */ /* end; */ /* */ /* end; */ /* */ /*finish_e_picture: */ /* substr(efbuf,260-lzero,lzero)=substr(zeroes,1,lzero); */ /* if idn=1 then substr(efbuf,259-id,1)="."; */ /* substr(efbuf,260,5)=expstr; */ /* */ /* goto put_field_ef; */ /* */ /* end; */ /* */ /* */ /* if ftype=f_format then */ /* do; */ /* */ /* /* F-format output forms: */ /* zero nonzero */ /* 0 123 d=0 */ /* 0.000 0.012 d>0 */ /* 0.000 345.123 d>0 */ /* */ /* if nval<1 then go to too_few_params; */ /* if nval<2 then id=0; */ /* else id=format_block.val(2); */ /* if nval<3 then ip=0; */ /* else ip=format_block.val(3); */ /* if id<0 then go to bad_param_values; */ /* if id>iw then goto sig_size_for_ef; */ /* */ /* if icomplex=2 then ddfix="100101100000000000000000000000111011"b; */ /* else ddfix="100100100000000000000000000000111011"b; */ /* */ /* /* AG94-0 specifies two conversions: */ /* First, INPUT to DEC (fix/flo according to INPUT) */ /* (prec,scale according to INPUT) */ /* Multiply the result of this by 10**ip. */ /* Second, intermediate-value -> FIX DEC(p,q) where */ /* p and q come from the format: */ /* if d=0, (w-1,0) */ /* else (w-2,d) */ /* I do not do these two conversions at present. */ /* As a result, my CHAR->F-format can preserve */ /* the fractional part of a CHAR like "23.456" */ /* whereas AG94-0 calls for CHAR->FIX DEC(59,0) */ /* which would lose the fractional part. */ /* */ /* */ /* */ /* */ /* dscale=id+ip; */ /* substr(ddfix,13,12)=addr(dscale)->m_12; */ /* */ /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ /* call assign_type_d(ddfix,psp,outpicture_p,outtype,outscale_prec); */ /* */ /* if ps.descr="0"b */ /* then do; */ /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ /* call assign_round_(addr(decimal),outtype,outscale_prec,addr(buffer),intype,inscale_prec); */ /* end; */ /* else call assign_round_(addr(decimal),outtype,outscale_prec,ps.vp,intype,inscale_prec); */ /* */ /* /* ************************** */ /* /* */ /* /* must contrive that this */ /* /* conversion is ROUNDED */ /* /* */ /* /* ************************** */ /* */ /* if icomplex=2 then substr(decimal,1,60)=substr(decimal,61,60); */ /* */ /* */ /* do i=2 to 60; */ /* if substr(decimal,i,1)^="0" then go to fixed_signif; */ /* end; */ /* */ /* ipreciz=1; */ /* go to build_fixed_output; */ /* */ /*fixed_signif: */ /* ipreciz=61-i; */ /* sign_char=substr(decimal,1,1); */ /* */ /*build_fixed_output: */ /* if id=0|id>=ipreciz then */ /* do; */ /* ief=265-ipreciz; */ /* substr(efbuf,ief,ipreciz)=substr(decimal,61-ipreciz,ipreciz); */ /* if id=0 then go to put_field_ef; */ /* */ /* ief=263-id; */ /* lpref=id+2-ipreciz; */ /* substr(efbuf,ief,lpref)=substr(zeroes,2,lpref); */ /* substr(efbuf,ief+1,1)="."; */ /* end; */ /* */ /* else do; */ /* ief=264-ipreciz; */ /* substr(efbuf,ief,ipreciz+1)= */ /* substr(decimal,i,ipreciz-id)||"."|| */ /* substr(decimal,61-id,id); */ /* end; */ /* goto put_field_ef; */ /* end; */ /* */ /* if ftype=picture_format */ /* then goto pic_format; */ /* */ /* go to no_such_format_type; */ /* */ /* */ /* */ /* */ /*put_field_ef: */ /* if sign_char="-" then */ /* do; */ /* ief=ief-1; */ /* substr(efbuf,ief,1)="-"; */ /* end; */ /* if (265-ief)>iw then */ /* sig_size_for_ef: */ /* call plio2_signal_$s_(psp,"SIZE","put_edit",263); */ /* substr(char256,1,iw)=substr(efbuf,265-iw,iw); */ /* go to put_field_edit; */ /* */ /* */ /* */ /*put_field_string: */ /* if nval<1 then iw=descriptive.prec; */ /* if iw>256 then goto bad_string_size; */ /* if iw<0 then goto bad_param_values; */ /* */ /* if iwdescriptive.prec then substr(char256,descriptive.prec+1,iw-descriptive.prec)=" "; */ /* goto put_field_edit; */ /* */ /*put_field_edit: */ /* if iw>256 then goto bad_string_size; */ /* if iw>0 then call plio2_put_util_$put_field_(psp,addr(char256),iw); */ /*edit_exit: */ /* if icomplex=1 then */ /* do; */ /* icomplex=2; */ /* format_bp=addrel(format_bp,5); */ /* go to complex_edit_1; */ /* end; */ /* return; */ /* */ pve_error:entry(pspp); /* entry added for use by pl1_operators when */ /* in checking a f_format finds that the size */ /* has been violated. This way the buffer gets */ /* put out and full processing of the condiition */ /* is possible.*/ psp=pspp; call plio2_signal_$s_(psp,"SIZE","put_edit",263); return; end plio2_pve_;  plio2_qge_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 201708 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ quick_get_edit_: plio2_qge_: proc (pspp) options (support); /* Written by R.Schoeman Spring 1977 to replace plio2_gve_ with faster algorithms & code. */ /* Modified 780223 by PG to fix 1709 (get edit failed when very first thing was column format). */ /* Modified 780406 by RAB to fix 1724 (seg fault with get string edit doing col format with no newline). */ /* Modified 780718 by RAB to make slightly more quit-start proof */ /* plio2_qge_$ is called from the user's procedure to get one value in edit-directed mode and, of course, to perform such control functions as may correspond to formats preceeding the next data format. This procedure is called from put_format_.alm in the operators, which has already walked the format list and gotten the next prepared format item. This procedure gets the input field of the length defined by that format and does the necessary conversions, finally assigning the value to the variable specified by the ps. It is analagous to the latter half of put_format_.alm, which does the output conversions for pl1 edit_directed io. */ dcl (erno init (999), ftype, nval, i, j, radix_factor, first_bit, to_move, targ_index, si, cc, string_start, first_char_len, old_nl, from_old_nl, oncharind, icomplex) fixed bin (15); dcl (char_pic_format, warned) bit (1) aligned; dcl code fixed bin (35); dcl x char (1) aligned; dcl conname char (12); dcl ctl_char char (1) aligned; dcl ctl_chars char (4) aligned init ( " ") options (constant) int static; /* The preceding four characters were , in order: carriage_return, horizontal tab, new_line, and new_page */ dcl based_char256 char (256) based; dcl based_packed_ptr ptr unaligned based; dcl char_array (1000) char (1) unaligned based; dcl 1 based_byte_array (60) unal based (addr (buffer (icomplex))), 2 unused bit (1) unal, 2 exp_fac fixed bin (7) unal; dcl buf1000 char (1000); dcl new_line char (1) aligned int static options (constant) init (" "); dcl tab char (1) aligned int static options (constant) init (" "); dcl (error_table_$short_record, error_table_$long_record, error_table_$end_of_info) external static fixed bin (35); dcl (pspp, psp, fp, pic_ptr, targ_ptr, in_ptr) ptr; dcl 1 facts (2), 2 (pow, sc, iw, ef, use) fixed bin (15); dcl 1 info_struct, 2 next_position fixed (21), /* output */ 2 last_position fixed (21); /* output */ dcl (n_read, n_left, tk) fixed bin (21); dcl 1 fb based (ps.format_area_p), 2 type fixed bin (15), 2 nval fixed bin (15), 2 val (3) fixed bin (15); dcl 1 fbc (0:2) based (fp), 2 type fixed bin (15), 2 nval fixed bin (15), 2 val (3) fixed bin (15); dcl types (2) fixed bin (17), scale_prec (2) fixed bin (35), 1 fo (2) based (addr (scale_prec (1))) aligned, 2 scale fixed bin (17) unal, 2 prec fixed bin (17) unal; dcl 1 dec_fixed (2) based (addr (space)) unal, 2 sign_of_mantissa char (1) unal, 2 mantissa char (info.inprec) unal; dcl 1 dec_float (2) based (addr (space)) unal, 2 sign_of_mantissa char (1) unal, 2 mantissa char (info.inprec) unal, 2 unused bit (1) unal, 2 exponent fixed bin (7) unal; dcl (dec_pos, e_pos, exp_sign_pos) fixed bin (17); dcl buffer (2) char (64) aligned, space char (128) aligned; dcl (addr, addrel, fixed, index, min, max, mod, length, search, substr, unspec, reverse, size, ltrim, rtrim) builtin; dcl put_copy_ ext entry (ptr, fixed bin (21)); dcl iox_$get_chars ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$get_line ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl plio2_signal_$s_ ext entry (ptr, char (*), char (*), fixed bin (15)); dcl plio2_signal_$s_r_ ext entry (ptr, char (*), char (*), fixed bin (15)); dcl plio2_signal_$conversion_error_ ext entry (ptr, char (*), fixed bin (15), ptr, fixed bin (15), fixed bin (15), fixed bin (15)); dcl plio2_resig_ ext entry (ptr); dcl conversion condition; %include pl1_stack_frame; %include desc_dcls; %include desc_types; %include radix_factor_constants; %include descriptor; %include picture_desc_; %include picture_image; %include picture_types; %include picture_util; %include plio_format_codes; %include plio2_ps; %include system; /* QUICK declarations, i.e. dcls for quick_get_edit */ dcl 1 def_desc structure aligned based (addr (ps.descr)) like desc_; %include plio2_fsb; dcl iocbp ptr; dcl (targ_type) fixed bin (17) aligned; dcl 1 scale_prec_ aligned, 2 scale fixed bin (17) unal, 2 prec fixed bin (17) unal; dcl fb35_based fixed bin (35) based aligned; dcl 1 s, 2 width fixed bin (17), 2 chars char (256); dcl def_string char (256) varying based (addr (s)); dcl imag_def_string varying char (256); dcl bit_str bit (256) aligned; dcl max_io_string_length int static options (constant) fixed bin (17) init (256); /* */ psp = pspp; on conversion call plio2_resig_ (psp); ps.auxp = addr (s); icomplex = 1; /* This index is used to cycle through the 2 conversions needed for a complex format. If its not a complex format, this index is always "1". */ nval = fb.nval; ftype = fb.type; iocbp = ps.fsbp -> fsb.iocb_p; if ftype ^= bn_format then s.width = fb.val (1); else s.width = fb.val (2); goto char_length_action (ftype); char_length_action (3): /* complex stuff */ fp = ps.format_area_p; do i = 1 to 2; if fbc (i).nval < 1 then goto err148; facts.iw (i) = fbc (i).val (1); if facts.iw (i) < 0 then goto err145; end; s.width = facts.iw (1) + facts.iw (2); /* The length of a complex format item is the sum of the lengths of its real & cplx parts. */ /* INTENTIONAL FALL THROUGH HERE !! */ char_length_action (1): /* l_paren */ char_length_action (2): /* r_format */ char_length_action (4): /* f_format */ char_length_action (5): /* e_format */ char_length_action (6): /* b_format */ char_length_action (7): /* a_format */ char_length_action (8): /* x_format */ char_length_action (13): /* picture_format */ char_length_action (14): /* normal input chars */ /* bn_format */ if nval < 1 then goto err148; if s.width < 0 then goto err145; else if s.width > max_io_string_length then goto err149; /* Although it would be nice to optimize the case of char input string going to a char target, the problem of padding if too short and raising stringsize if too long means that a prohibitive amount of processing by hand would have to be done. */ if s.width>0 then do; targ_ptr = addr (s.chars); to_move = s.width; call get_chars; /* targ_ptr & to_move are the pseudo_args */ end; goto process_format (ftype); char_length_action (9): /* input lines */ /* skip format */ if nval < 1 then call get_skip (1); else call get_skip (s.width); goto all_done; char_length_action (10): /* column format */ if fb.nval ^= 1 /* This test should be unnecessary, because compiler should prevent this case from occuring */ then goto err148; if fb.val (1) < 1 then goto err145; else tk = fb.val (1)-1; /* tk is the target column number, starting at 0, therefore it is equal to the pl1 col #, which starts at one, minus 1. */ if fsb.kol = tk then goto all_done; warned = "0"b; if fsb.kol > tk then call get_skip (1); /* If the present column is greater than the desired column, look for that column on the NEXT line. */ n_left = chars_left_on_line (); /* This internal subroutine returns the number of chars left on the present line. If there are enough to go to the requested column,move the requisite distance, otherwise AG94 says skip to the next line & you're done. */ if n_left > tk-fsb.kol then do; to_move = tk-fsb.kol; if to_move > 1000 then goto err180; targ_ptr = addr (buf1000); call get_chars; if index (substr (buf1000, 1, to_move), tab) > 0 then call tab_in_col_input; goto all_done; end; else do; call get_skip (1); goto all_done; end; char_length_action (11): char_length_action (12): /* illegal input format */ goto err147; null_string: intype = char_desc * 2; in_ptr = addr (s.chars); inscale_prec = 0; goto final_conv; process_format (3): /* complex */ first_char_len = ps.format_area_p -> fbc (1).val (1); imag_def_string = substr (def_string, first_char_len+1); def_string = substr (def_string, 1, first_char_len); do icomplex = 1 to 2; ps.format_area_p = addrel (ps.format_area_p, size (fb)); if icomplex = 2 then def_string = imag_def_string; if fb.type = picture_format then call p_format_proc; else if fb.type = e_format then call e_format_proc; else if fb.type = f_format then call f_format_proc; else goto err259; types (icomplex) = intype; scale_prec (icomplex) = inscale_prec; end; ps.format_area_p = addrel (ps.format_area_p, -2* (size (fb))); if types (1) = D_fixed_real_desc*2 & types (2) = D_fixed_real_desc*2 then do; intype = D_fixed_real_desc*2+1; info.inprec = min (max_p_dec, max (fo.prec (1)-fo.scale (1), fo.prec (2)-fo.scale (2))+max (fo.scale (1), fo.scale (2))+1); info.inscale = max (fo.scale (1), fo.scale (2)); do i = 1 to 2; call assign_ (addr (dec_fixed (i)), intype, inscale_prec, addr (buffer (i)), types (i), scale_prec (i)); end; intype = D_fixed_cplx_desc*2+1; end; else do; intype = D_float_real_desc*2+1; info.inprec = max (fo.prec (1), fo.prec (2)); info.inscale = 0; do i = 1 to 2; call assign_ (addr (dec_float (i)), intype, inscale_prec, addr (buffer (i)), types (i), scale_prec (i)); end; intype = D_float_cplx_desc*2+1; end; in_ptr = addr (space); goto final_conv; process_format (4): /* fixed format */ string_start = 1; in_ptr = addr (buffer (icomplex)); call f_format_proc; goto final_conv; process_format (5): /* e_format */ string_start = 1; in_ptr = addr (buffer (icomplex)); call e_format_proc; goto final_conv; process_format (6): /* b_format */ process_format (14): /* bn_format */ def_string = ltrim (rtrim (def_string)); if s.width = 0 then goto null_string; if ftype = b_format | fb.val (1) = 1 then do; call assign_ (addr (bit_str), bit_desc * 2, addr (s.width) -> fb35_based, addr (s.chars), char_desc * 2, addr (s.width) -> fb35_based); radix_factor = 1; end; else do; ce_return: radix_factor = fb.val (1); if s.width * radix_factor > max_io_string_length then goto err144; if radix_factor = 4 then if search (def_string, capital_hex) > 0 then substr (digits (4), 11, 6) = capital_hex; else substr (digits (4), 11, 6) = lower_case_hex; do i = 1 to length (def_string); x = substr (def_string, i, 1); si = index (digits (radix_factor), x); if si = 0 then goto CE_for_bn; first_bit = (radix_factor* (si-1))+1; substr (bit_str, radix_factor* (i-1)+1, radix_factor) = substr (expand_bits (radix_factor), first_bit, radix_factor); end; end; in_ptr = addr (bit_str); intype = bit_desc * 2; /* bit_desc * 2 */ inscale_prec = s.width*radix_factor; goto final_conv; process_format (7): /* a_format */ /* 1st figure out output type, from ps.descr & ps.value_p, then call assign_ */ /* to convert it & store result in ps.value_p. */ intype = char_desc * 2; /* char_desc * 2 */ in_ptr = addr (s.chars); inscale_prec = s.width; final_conv: if ps.descr = "0"b then do; pic_ptr = psp -> ps.stack_frame_p -> pl1_stack_frame.text_base_ptr; pic_ptr = addrel (pic_ptr, psp -> ps.top_half); call set_pic_args; if targ_type = char_desc * 2 & ftype = picture_format & char_pic_format then do; if scale_prec_.prec < inscale_prec then call plio2_signal_$s_ (psp, "stringsize", "quick_get_edit", -1); else if scale_prec_.prec > inscale_prec then substr (s.chars, s.width+1) = ""; call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1, addr (s.chars) -> char1); end; else do; call assign_ (addr (buffer (1)), targ_type, addr (scale_prec_) -> fb35_based, in_ptr, intype, inscale_prec); call pack_picture_ (ps.value_p -> char1, pic_ptr -> char1, addr (buffer (icomplex)) -> char1); end; goto all_done; end; unspec (desc_) = unspec (ps.descr); targ_type = desc_.type_ * 2+ fixed (desc_.pack_, 17, 0); if targ_type = v_char_desc * 2 | targ_type = v_bit_desc * 2 then targ_ptr = addrel (ps.value_p, -1); else targ_ptr = ps.value_p; scale_prec_.scale = desc_.scale_; scale_prec_.prec = desc_.precision_; call assign_ (targ_ptr, targ_type, addr (scale_prec_) -> fb35_based, in_ptr, intype, inscale_prec); goto all_done; process_format (13): /* picture format */ string_start = 1; in_ptr = addr (buffer (icomplex)); call p_format_proc; goto final_conv; /* */ err180: erno = 180; goto allerr; err181: erno = 181; goto allerr; err182: erno = 182; goto allerr; err145: erno = 145; goto allerr; eof163: erno = 163; conname = "ENDFILE"; goto sandr; err147: erno = 147; goto allerr; err162: erno = 162; goto allerr; err163: erno = 163; goto allerr; err148: erno = 148; goto allerr; err144: erno = 144; goto allerr; err149: erno = 149; goto allerr; err150: erno = 150; goto allerr; err216: erno = 216; goto allerr; err217: erno = 217; goto allerr; err259: erno = 259; goto allerr; allerr: conname = "ERROR"; /* One can NEVER return from these error-raising calls except for conversion_error ! */ sandr: call plio2_signal_$s_r_ (psp, conname, "quick_get_edit", erno); CE_for_bn: call plio2_signal_$conversion_error_ (psp, "quick_get_edit_bn", 151, addr (s.chars), 1, (s.width), i); goto ce_return; raise_transmit: call plio2_signal_$s_r_ (psp, "TRANSMIT", "quick_get_edit", 183); process_format (8): /* x_format is total ignore so KEEP label on all_done */ all_done: return; /* */ p_format_proc: proc; pic_ptr = addr (fb.val (2)) -> based_packed_ptr; val_pic: call validate_picture_ (addr (s.chars) -> char1, pic_ptr -> char1, erno, oncharind); if erno ^= 0 then do; call plio2_signal_$conversion_error_ (psp, "quick_get_edit", erno, addr (s.chars), 1, (s.width), oncharind); goto val_pic; end; if pic_ptr -> picture_image.type = char_picture /* char */ then do; in_ptr = addr (s.chars); intype = char_desc * 2; inscale_prec = s.width; char_pic_format = "1"b; end; else do; call unpack_picture_ (addr (buffer (icomplex)) -> char1, pic_ptr -> char1, addr (s.chars) -> char1); intype = type (pic_ptr -> picture_image.type); info.inscale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor; info.inprec = pic_ptr -> picture_image.prec; /* type cant be char cause that already has been filtered out prior to unpack call */ in_ptr = addr (buffer (icomplex)); char_pic_format = "0"b; end; end p_format_proc; /* */ f_format_proc: proc; def_string = ltrim (rtrim (def_string)); dec_pos = index (def_string, "."); if length (def_string) = 0 then def_string = "0"; /* else char_to_numeric will call it fixed bin, not fixed dec */ call char_to_numeric_ (addr (buffer (icomplex)), intype, inscale_prec, addr (s.chars), length (def_string)); if intype ^= D_fixed_real_desc*2 then goto err150; if dec_pos > 0 then info.inscale = length (def_string) - dec_pos; else if fb.nval > 1 then info.inscale = fb.val (2); if fb.nval > 2 then info.inscale = info.inscale - fb.val (3); if info.inscale < min_scale then goto err217; else if info.inscale > max_scale then goto err216; end f_format_proc; /* */ e_format_proc: proc; def_string = ltrim (rtrim (def_string)); dec_pos = index (def_string, "."); e_pos = index (def_string, "e"); if length (def_string) = 0 then def_string = "0e0"; /* KLUDGE to make zero-len string work */ else do; exp_sign_pos = search (substr (def_string, 2), "+-")+1; if e_pos = 0 then if exp_sign_pos = 1 then def_string = def_string||"e0"; else def_string = substr (def_string, 1, exp_sign_pos-1)||"e"||substr (def_string, exp_sign_pos); end; call char_to_numeric_ (addr (buffer (icomplex)), intype, inscale_prec, addr (s.chars), length (def_string)); if intype ^= D_float_real_desc*2 then goto err182; if dec_pos = 0 then if fb.val (2) ^= 0 then do; based_byte_array (inscale_prec+2).exp_fac = based_byte_array (inscale_prec+2).exp_fac-fb.val (2); if based_byte_array (inscale_prec+2).exp_fac > max_scale then goto err216; else if based_byte_array (inscale_prec+2).exp_fac < min_scale then goto err217; end; end e_format_proc; /* */ set_pic_args: proc; targ_type = type (pic_ptr -> picture_image.type); scale_prec_.scale = pic_ptr -> picture_image.scale - pic_ptr -> picture_image.scalefactor; if targ_type = char_desc * 2 /* char_desc * 2 */ then scale_prec_.prec = pic_ptr -> picture_image.varlength; else scale_prec_.prec = pic_ptr -> picture_image.prec; end; /* */ get_chars: proc; /* INPUT ARGS are targ_ptr, to_move */ targ_index = 1; scan: si = min (to_move, fsb.blc-fsb.bnc+1); cc = search (substr (xbuf, fsb.bnc, si), ctl_chars); if cc = 0 then do; substr (targ_ptr -> based_char256, targ_index, si) = substr (xbuf, fsb.bnc, si); fsb.bnc = fsb.bnc + si; targ_index = targ_index + si; fsb.kol = fsb.kol + si; if to_move = si then return; to_move = to_move - si; call refill_buffer; if code ^= 0 then if targ_index = 1 then goto eof163; else goto err163; goto scan; end; ctl_char = substr (xbuf, fsb.bnc+cc-1, 1); if ctl_char ^= tab then do; /* The remaining ctl chars are new_line, new_page, and carriage return */ substr (targ_ptr -> based_char256, targ_index, cc-1) = substr (xbuf, fsb.bnc, cc-1); to_move = to_move - cc + 1; fsb.bnc = fsb.bnc+cc; targ_index = targ_index+cc-1; if ctl_char = new_line then fsb.kol = 0; else fsb.kol = fsb.kol+cc-1; goto scan; end; substr (targ_ptr -> based_char256, targ_index, cc) = substr (xbuf, fsb.bnc, cc); fsb.bnc = fsb.bnc+cc; targ_index = targ_index+cc; to_move = to_move-cc; fsb.kol = fsb.kol + cc; fsb.kol = fsb.kol+10-mod (fsb.kol, 10); goto scan; end get_chars; /* */ refill_buffer: proc; if ps.copy then do; call put_copy_ (psp, fsb.blc); ps.start_copy = 1; end; if ps.string then goto err162; fsb.blc = 0; /* protects us somewhat from quit-start */ fsb.bnc = 1; /* .. */ if fsb.console then call iox_$get_line (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code); else call iox_$get_chars (iocbp, fsb.bptr, fsb.bsize, fsb.blc, code); fsb.bnc = 1; if code ^= 0 then if code = error_table_$long_record|code = error_table_$short_record then code = 0; else if code = error_table_$end_of_info then ; else goto raise_transmit; end refill_buffer; /* */ chars_left_on_line: proc returns (fixed bin (21)); dcl n_left fixed bin (21); if fsb.blc = 0 /* never have read from file... */ then call refill_buffer; n_left = index (substr (xbuf, fsb.bnc, fsb.blc-fsb.bnc+1), new_line); if n_left > 0 then return (n_left); /* Have partial input line (no final NL). Find out why. */ from_old_nl = index (reverse (substr (xbuf, 1, fsb.blc)), new_line); if from_old_nl = 0 then do; if ps.string then return(fsb.blc - fsb.bnc + 1); call iox_$get_line (iocbp, addr (xbuf), fsb.bsize, n_read, code); if code = error_table_$end_of_info then return (fsb.blc - fsb.bnc + 1); else goto err181; end; /* It should be noted here that if we just returned 0, the col format handling mechanism will shorty raise an end_of_file anyway, by calling a guaranteed subsequent "get_skip(2)" */ old_nl = fsb.blc-from_old_nl; if ps.copy then do; call put_copy_ (psp, fsb.blc); ps.start_copy = 1; end; if ps.string then goto err162; substr (xbuf, 1, from_old_nl) = substr (substr (xbuf, 1, from_old_nl), old_nl+1, from_old_nl); /* the +1 is to flush the last NL, too */ call iox_$get_line (iocbp, addr (addr (xbuf) -> char_array (from_old_nl+1)), fsb.bsize-from_old_nl, n_read, code); if code ^= 0 then if code = error_table_$long_record then goto err181; else if code = error_table_$short_record|code = error_table_$end_of_info then code = 0; else goto raise_transmit; fsb.bnc = fsb.bnc - old_nl; fsb.blc = from_old_nl+n_read; n_left = fsb.blc-fsb.bnc+1; return (n_left); end; /* */ get_skip: proc (skip_count_param); dcl (skip_count, skip_count_param) fixed bin (17) aligned; skip_count = skip_count_param; fsb.kol = 0; do while (skip_count > 0); j = index (substr (xbuf, fsb.bnc, fsb.blc-fsb.bnc+1), new_line); if j = 0 then do; call refill_buffer; if code ^= 0 then goto eof163; end; else do; fsb.bnc = fsb.bnc + j; skip_count = skip_count-1; end; end; end; /* */ tab_in_col_input: proc; if ^warned then call plio2_signal_$s_ (psp, "ERROR", "quick_get_edit", 157); warned = "1"b; return; end; end;  plio2_recio_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 221130 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_recio_: procedure (pspp) options (support); /* Modified 780830 by RAB to fix bug 1755 (reads of lines > 848 chars fail) */ /* Modified 780718 by RAB to make stream I/O slightly more quit-start proof */ /* Modified 770825 by PG to implement read/write to stream files */ /* 76-09-08: changed to use the iox_$foo call forwarder */ /* 75-07-01: changed the error handling for rewrite statements to fix bug 1378. */ /* 75-05-08: changed the keyto_assignment_made bit to the keyto_keyset bit in the psr to support quick keyed record i/o and added code to the error entry block. */ /* 74-12-31: changed the rewrite error codes from the incorrect "480", "481", to the correct "280", "281". */ /* 74-12-17: updated to support bit_string stringvalue io and rewrite stringvalue io; to check that varying_array is off before accepting that stringvalue is valid; error entry and associated code added for use by quick record io. */ /* 74-12-2: updated to support env(stringvalue) */ /* 74-8-5: fixed for version-2 of compiler which sets ab-ret label in the KEYTO case. seereferences to keyto_keyset. */ /* fixed to perform the KEYTO copy before the SET/INTO copy 74-7-1 B U G : if abnormal return to user, KEYTO post-copy may copy JUNK */ /* 73-12-12: updated for change from File Manager to iox_ please note that the new KEY is char256v, the old KEY is c32, both starting in the same place. */ /* 1-3-73: removed all traces of locking. corrected test for no-file to include no-dir as well as noentry. */ /* parameters */ dcl (error_status fixed bin (35), pspp ptr ) parameter; /* automatic */ dcl buffer_len fixed bin (21); dcl bytes_read fixed bin(21); dcl char_buffer bit (1) aligned; dcl conname char (16); dcl copy_len fixed bin (21); dcl (psp, fsbp, wptr, copyp, statep) ptr; dcl (i, erno init (975), code init (0), ballocn) fixed bin (17); dcl (wlen, release, copyn, rlength, xrlength, vlength) fixed bin (21); dcl ends_in_NL bit (1) aligned; dcl iocb_p ptr; dcl iocb_status fixed bin (35); dcl onkeyx char (256) varying; dcl 1 reciofab aligned, 2 sw bit (36), 2 name char (32); dcl scan_index fixed bin (21); dcl signal_record bit(1) aligned; dcl (test_18, job_18) bit (18) aligned; dcl valid_stringvalue bit (1) aligned; dcl vptr ptr; dcl w_char_buffer bit (1) aligned; dcl 1 work aligned like psr.job; /* based */ dcl based_pointer ptr based; dcl 1 buffer_state based (statep) aligned, 2 blen fixed bin (15), 2 bmax fixed bin (15), 2 bptr ptr, 2 bsw aligned, 3 (exists, pad, use) bit (1) unaligned; dcl balloc char (ballocn) aligned based; /* ballocn must be a byte-length */ dcl based_packedptr ptr unaligned based; dcl bc32 char (32) aligned based; dcl based_label label based; dcl release_bits bit (36) aligned based (addr (release)); dcl string_len fixed bin (24) based; dcl variable_overlay char (vlength) based (vptr); dcl 1 work_overlay aligned based (addr (work)), 2 pad1 bit (27) unal, 2 nofrom bit (1) unal, 2 nokey bit (1) unal, 2 nokeyfrom bit (1) unal, 2 nolock bit (1) unal, 2 close bit (1) unal, 2 pad2 bit (4) unal; /* NOTE: the bits of "job" and, thus, of "work" ending on the 34-th (six bits are reserved) contain the "release-number" of the io_semantics which produced the calling program. Since these bits are reused by RECIO, the release number must be extracted and its bits reset to zero. release 1: implements the 256-char var KEY sets the not_bytebuffer bit. release 2: implements ab-return in KEYTO case. */ /* entries */ dcl iox_$delete_record entry (ptr, fixed bin (35)), iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$read_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); dcl iox_$read_length entry (ptr, fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl plio2_signal_$s_ ext entry (ptr, char (*), char (*), fixed bin (17)); dcl plio2_open_$open_implicit_ ext entry (ptr); /* builtins */ dcl (addr, addrel, divide, fixed, index, length, min, mod, string, substr) builtin; /* external static */ dcl (plio2_data_$pspstat, plio2_data_$fsbpstat) ptr external; dcl (error_table_$no_record, error_table_$long_record, error_table_$short_record, error_table_$key_order, error_table_$end_of_info ) fixed bin (35) external; /* internal static */ dcl NL char (1) internal static options(constant) init (" "); /* include files */ %include pl1_file_value; %include plio2_fsb; %include plio2_fsbr; %include plio2_psr; %include its; /* program */ plio2_data_$pspstat, psp = pspp; string (work) = string (psr.job); release = 0; substr (release_bits, 31, 6) = substr (string (work), 28, 6); /* release number of io_semantics */ substr (string (work), 28, 6) = "000000"b; /* these bits are re-used by RECIO */ if work.keyto then psr.keyto_keyset = "0"b; else addr (psr.ab_return) -> based_label = EXIT; /* ab-ret label is set by compiler/runtime only for KEYTO, version 2 and later. */ psr.file_p = psr.source_p; plio2_data_$fsbpstat, fsbp, psr.fsbp = psr.file_p -> file_value.fsb_ptr; if ^fsbr.switch.open then do; psr.fab2p = addr (reciofab); reciofab.name = " "; if work.read then reciofab.sw = "00000100001"b; if work.write then reciofab.sw = "00000010001"b; if work.rewrite then reciofab.sw = "00000001001"b; if work.delete then reciofab.sw = "0000000100101"b; if work.locate then reciofab.sw = "000000100011001"b; call plio2_open_$open_implicit_ (psp); end; valid_stringvalue = fsbr.switch.stringvalue & work.varying_string & ^work.varying_array; iocb_p = fsbr.iocb_p; vlength = psr.variable_bitlen; if work.varying_string & ^valid_stringvalue then do; /* special code inserted here to handle anomalous case of "into" or "from" option where "target" is a varying string. For the compiler addresses the data portion of such a string only. */ /* More queer, an array of varying strings is given its correct length but the address of its second word - whereas a scalar varying string is given the length of its data portion and the address of its data portion. */ if ^work.varying_array then vlength = vlength + 36; psr.variable_p = addrel (psr.variable_p, -1); end; onkeyx = ""; if work.read & substr (string (work), 24, 3) = "000"b /* (set, into, ignore) = 0 */ then do; work.ignore = "1"b; psr.number = 1; end; if (work.write | work.rewrite) & ^work.from then work_overlay.nofrom = "1"b; if work.write | work.locate then if ^work.keyfrom then work_overlay.nokeyfrom = "1"b; else; else if ^work.key then work_overlay.nokey = "1"b; if work_overlay.nokeyfrom & work_overlay.nokey then psr.keytemp = ""; /* TESTING AND SIGNALLING */ job_18 = substr (string (work), 14, 18); test_18 = job_18 & string (fsbr.nono); if test_18 ^= "0"b then do; i = index (test_18, "1"b); erno = 251; /* required option missing */ if i<15 then erno = 250; /* illegal option present or implied */ if i<8 then erno = 249; /* statement type conflicts with file attributes */ signal_error: conname = "ERROR"; goto sandr1; sandr: conname = "TRANSMIT"; sandr1: if iocb_status ^= 0 then fsbr.lnzc = iocb_status; call plio2_signal_$s_ (psp, conname, substr (onkeyx, 1, length (onkeyx)), erno); if work.keyto then if ^psr.keyto_keyset then goto addr (psr.ab_return) -> based_label; /* The abnormal label is only different from the following return statement if KEYTO is specified. We take it whenever the assignment to the KEYTO- TARGET has not been done. */ EXIT: /* the label EXIT M_ U_ S_ T_ identify this return statement !! */ return; sig_rec: conname = "RECORD"; go to sandr1; sig_eof: conname = "ENDFILE"; go to sandr1; sig_key: conname = "KEY"; go to sandr1; end; /* CHECK FOR READ/WRITE TO A STREAM FILE */ if fsbr.switch.stream /* A stream file... */ then do; if work.varying_string then vptr = addrel (psr.variable_p, 1); else vptr = psr.variable_p; if work.read /* A READ STATEMENT */ then do; if ^fsb.switch.input then do; erno = 289; /* Stream file referenced by read statement isn't input */ go to signal_error; end; /* Fill input buffer, if necessary */ if fsb.bnc > fsb.blc /* buffer is empty */ then do; fsb.blc = 0; call fill_stream_input_buffer ("0"b); end; /* Now grab 1 line out of the buffer */ /* initialize loop for reading */ vlength = divide(vlength,9,21,0); if work.varying_string then vlength = vlength - 4; bytes_read = 0; signal_record = "0"b; ends_in_NL = "0"b; /* loop until line is read */ do while( ^ ends_in_NL & fsb.blc ^= 0); /* scan for a newline */ buffer_len = fsb.blc - fsb.bnc + 1; scan_index = index(substr(xbuf, fsb.bnc, buffer_len), NL) - 1; /* remember if newline found */ if scan_index >= 0 then ends_in_NL = "1"b; else scan_index = buffer_len; /* check if buffer_load will fit in target */ if scan_index > vlength - bytes_read then do; signal_record = "1"b; copy_len = vlength - bytes_read; end; else copy_len = scan_index; /* move buffer_load into target */ if copy_len > 0 then do; substr(variable_overlay, bytes_read + 1, copy_len) = substr(xbuf, fsb.bnc, copy_len); bytes_read = bytes_read + copy_len; end; /* if newline not found, get another buffer_load, otherwise, step past the newline */ if ^ ends_in_NL then do; fsb.blc = 0; call fill_stream_input_buffer("1"b); end; else fsb.bnc = fsb.bnc + (scan_index + 1); end; fsb.kol = 0; /* finish assignment */ if work.varying_string then psr.variable_p -> string_len = bytes_read; else if bytes_read < vlength then substr(variable_overlay, bytes_read + 1) = " "; if signal_record then call plio2_signal_$s_(psp,"RECORD","",294); /* input line too long */ end; else if work.write /* A WRITE STATEMENT */ then do; if ^fsb.switch.output then do; erno = 290; /* Stream file referenced by write statement isn't output */ go to signal_error; end; if work.varying_string then vlength = psr.variable_p -> string_len; else vlength = divide (vlength, 9, 21, 0); /* Check that the record will fit on the current line. */ if vlength > fsb.lsize - fsb.kol then do; call plio2_signal_$s_ (psp, "RECORD", "", 288); vlength = fsb.lsize - kol; end; call iox_$put_chars (iocb_p, vptr, vlength, iocb_status); if iocb_status ^= 0 then go to write_error; call iox_$put_chars (iocb_p, addr (NL), 1, iocb_status); if iocb_status ^= 0 then go to write_error; fsb.kol = 0; if fsb.switch.print then do; fsb.lineno = fsb.lineno + 1; if fsb.lineno = fsb.psize + 1 then call plio2_signal_$s_ (psp, "ENDPAGE", "", 234); end; end; return; end; /* if FROM/INTO then prepare for buffer operations. IOX_ wants to use aligned byte buffers but the program may specify a buffer that is not byte aligned OR which is not byte-lengthed, either of which necessitates use of bitcopies. */ if (work.locate | work.from | work.into) then do; vlength = divide (vlength+8, 9, 21, 0); /* must be in units of words AND must be tested !! */ if release>0 then if ^work.not_bytebuffer then char_buffer = "1"b; else do; if mod (psr.variable_bitlen, 9) ^= 0 then goto not_byteish; if mod (fixed (addr (psr.variable_p) -> its.bit_offset, 6), 9) = 0 then char_buffer = "1"b; else not_byteish: char_buffer = "0"b; end; end; /* buffer is described as follows: char_buffer="1"b length in bytes given by _v_l_e_n_g_t_h char_buffer="0"b length in bits given by _p_s_r.__v_a_r_i_a_b_l_e___b_i_t_l_e_n */ /* DISPATCH ....................DISPATCH */ if job_18 & "0001001"b then go to WL; /* write and locate */ if job_18 & "000011"b then go to RD; /* rewrite and delete */ /* READ */ free_inbuf: if fsbr.inbuf_sw.exists then do; ballocn = fsbr.inbuf_maxlen; free fsbr.inbuf_ptr -> balloc; fsbr.switch.buffer_in_use, fsbr.inbuf_sw.exists = "0"b; end; if work_overlay.close then go to EXIT; if work.key then do; if release>0 then onkeyx = psr.keytemp; else onkeyx = addr (psr.keytemp) -> bc32; /* we can handle old as well as new KEYs */ call iox_$seek_key (iocb_p, onkeyx, rlength, iocb_status); if iocb_status ^= 0 then goto read_error; fsbr.key_saved = onkeyx; end; if work.ignore then do; if psr.number<1 then goto EXIT; call iox_$position (iocb_p, 0, psr.number, iocb_status); if iocb_status ^= 0 then goto read_error; fsbr.rec_valid = "1"b; goto EXIT; end; if ^work.key & work.keyto then do; call iox_$read_key (iocb_p, fsbr.key_saved, rlength, iocb_status); if iocb_status ^= 0 then goto read_error; end; fsbr.rec_valid = "1"b; if work.keyto then do; if release>0 then psr.keytemp = fsbr.key_saved; else addr (psr.keytemp) -> bc32 = fsbr.key_saved; keyto_keyset = "1"b; end; if work.set then do; statep = addr (fsbr.inbuf_curlen); if ^work.key & ^work.keyto /* if either of these, rlength has been already set */ then do; call iox_$read_length (iocb_p, rlength, iocb_status); if iocb_status ^= 0 then goto read_error; end; vlength = rlength; /* keyed or not, rlength is the length of the record in the file */ call obtain_buffer; copyp = buffer_state.bptr; if work.packedptr then psr.set_p_p -> based_packedptr = buffer_state.bptr; else psr.set_p_p -> based_pointer = buffer_state.bptr; char_buffer = "1"b; end; else /* INTO */ if char_buffer then copyp = psr.variable_p; /* vlength having been set above */ if char_buffer then do; call iox_$read_record (iocb_p, copyp, vlength, xrlength, iocb_status); if iocb_status ^= 0 then goto read_error; if valid_stringvalue then if work.bit_string then addrel (copyp, -1) -> string_len = xrlength*9; else addrel (copyp, -1) -> string_len = xrlength; else if vlength ^= xrlength then goto short_record; end; else /* BEGIN BLOCK to allocate a temporary bit-buffer */ begin; /* this is a READ INTO with a target which is either not byte-aligned or not an even number of bytes long. */ dcl tempbuffer char (vlength) aligned; /* vlength has been corrected, above */ dcl bitbuffer bit (nnn) unaligned based; dcl nnn fixed bin (17); call iox_$read_record (iocb_p, addr (tempbuffer), vlength, xrlength, iocb_status); if iocb_status ^= 0 then if iocb_status ^= error_table_$long_record then goto read_error; nnn = 9*min (vlength, xrlength); psr.variable_p -> bitbuffer = addr (tempbuffer) -> bitbuffer; if iocb_status = error_table_$long_record then goto long_record; if vlength ^= xrlength then goto short_record; /* ASSUMPTION: that record length equals variable length if variable_bitlen+8/9 = record_length */ end; return; read_error: if iocb_status = error_table_$end_of_info then do; erno = 258; /* unable to read beyond EOF in sequential file */ goto sig_eof; end; if iocb_status = error_table_$no_record then do; erno = 292; /* unable to perform keyed lookup - key not found */ goto sig_key; end; if iocb_status = error_table_$long_record then do; long_record: erno = 253; /* record in data set larger than variable */ goto sig_rec; end; /* mysterious case: */ erno = 293; /* unable to perform sequential access */ goto sandr; short_record: erno = 254; /* record in data set smaller than variable */ iocb_status = error_table_$short_record; /* this is so fsb.lnzc gets set, so dpe gets good info */ goto sig_rec; /* WRITE and LOCATE */ WL: if fsbr.outbuf_sw.use then do; w_char_buffer = "1"b; wptr = fsbr.outbuf_ptr; wlen = fsbr.outbuf_curlen; call write_x; ballocn = fsbr.outbuf_maxlen; free fsbr.outbuf_ptr -> balloc; fsbr.outbuf_sw.exists, fsbr.outbuf_sw.use = "0"b; end; if work_overlay.close then go to free_inbuf; if work.locate then do; fsbr.outbuf_sw.use = "1"b; if fsbr.switch.keyed then do; if release>0 then fsbr.outbuf_key = psr.keytemp; else fsbr.outbuf_key = addr (psr.keytemp) -> bc32; end; statep = addr (fsbr.outbuf_curlen); call obtain_buffer; if work.packedptr then psr.set_p_p -> based_packedptr = buffer_state.bptr; else psr.set_p_p -> based_pointer = buffer_state.bptr; end; else do; fsbr.outbuf_sw.use = "0"b; w_char_buffer = char_buffer; wptr = psr.variable_p; if valid_stringvalue then if work.bit_string then wlen = divide (addrel (psr.variable_p, -1) -> string_len+8, 9, 21, 0); else wlen = addrel (psr.variable_p, -1) -> string_len; else wlen = vlength; call write_x; end; return; write_error: if iocb_status = error_table_$key_order then do; erno = 282; /* unable to add record to keyed sequential output file : keys must be distinct and ascending */ goto sig_key; end; if iocb_status = 0 then do; erno = 296; /* unable to create keyed record because the specified key has already been used. */ goto sig_key; end; else do; erno = 284; /* unable to create new record for write, locate, or close statement. */ goto sandr; end; /* mysterious */ /* rewrite,delete . . . . . . . . . . . . . . . . . */ RD: if work.key then do; onkeyx = psr.keytemp; call iox_$seek_key (iocb_p, onkeyx, rlength, iocb_status); if iocb_status ^= 0 then goto rewrite_error; fsbr.recio.rec_valid = "1"b; end; else if fsbr.switch.keyed then onkeyx = fsbr.key_saved; if fsbr.recio.rec_valid = "0"b then do; erno = 256; go to sandr; end; /* record to be rewritten or deleted has already been deleted. */ if work.delete then do; call iox_$delete_record (iocb_p, iocb_status); if iocb_status ^= 0 then goto rewrite_error; /* unable to delete designated record. */ fsbr.recio.rec_valid = "0"b; /* cannot be deleted, rewritten */ go to EXIT; end; if work.from then wptr = psr.variable_p; else do; if fsbr.inbuf_sw.use = "0"b then do; erno = 255; go to sandr; end; /* There is no FROM OPTION or input buffer */ vlength = fsbr.inbuf_curlen; wptr = fsbr.inbuf_ptr; char_buffer = "1"b; end; if valid_stringvalue then if work.bit_string then vlength = divide (addrel (psr.variable_p, -1) -> string_len+8, 9, 21, 0); else vlength = addrel (psr.variable_p, -1) -> string_len; if char_buffer then call iox_$rewrite_record (iocb_p, wptr, vlength, iocb_status); else begin; dcl tempbuffer_r char (vlength) aligned; dcl bitbuffer_r bit (9*vlength) unaligned based; addr (tempbuffer_r) -> bitbuffer_r = wptr -> bitbuffer_r; call iox_$rewrite_record (iocb_p, addr (tempbuffer_r), vlength, iocb_status); end; if iocb_status ^= 0 then do; rewrite_error: if iocb_status = error_table_$long_record then do; erno = 280; goto sig_rec; end; if iocb_status = error_table_$short_record then do; erno = 280; goto sig_rec; end; if iocb_status = error_table_$no_record then do; erno = 292; goto sig_key; end; /* unable to rewrite record. */ if psr.job.delete then erno = 285; else erno = 281; goto sandr; end; return; recio_close_: entry (pspp); psp = pspp; fsbp = psr.source_p -> file_value.fsb_ptr; iocb_p = fsbr.iocb_p; string (work) = "00000000000000000000000000000001"b; /* close */ go to WL; error: entry (pspp, error_status); psp = pspp; string (work) = string (psr.job); psr.file_p = psr.source_p; plio2_data_$fsbpstat, fsbp, psr.fsbp = psr.file_p -> file_value.fsb_ptr; if fsbr.switch.keyed then onkeyx = psr.keytemp; else onkeyx = ""; iocb_status = error_status; if psp -> psr.job.read then if iocb_status>0 then goto read_error; else goto short_record; if psp -> psr.job.write then goto write_error; goto rewrite_error; /* INTERNAL PROCEDURES */ fill_stream_input_buffer: procedure (bv_ignore_eof); /* parameters */ declare bv_ignore_eof bit (1) aligned parameter; /* automatic */ declare buffer_ptr ptr, max_read_len fixed bin (21), read_len fixed bin (21); /* based */ declare buffer_array_overlay char (1) dim (fsb.bsize) based (fsb.bptr); /* program */ buffer_ptr = addr (buffer_array_overlay); max_read_len = fsb.bsize; fsb.bnc = 1; /* redundant stmt protects us somewhat from quit-start */ if fsb.console then call iox_$get_line (iocb_p, buffer_ptr, max_read_len, read_len, iocb_status); else call iox_$get_chars (iocb_p, buffer_ptr, max_read_len, read_len, iocb_status); fsb.bnc = 1; if iocb_status ^= 0 then if iocb_status = error_table_$short_record | iocb_status = error_table_$long_record then iocb_status = 0; else if iocb_status = error_table_$end_of_info then do; if bv_ignore_eof then do; iocb_status = 0; return; end; erno = 291; /* EOF during read to stream file */ go to sig_eof; end; else do; erno = 295; /* transmit */ go to sandr; end; fsb.blc = fsb.blc + read_len; end fill_stream_input_buffer; obtain_buffer: procedure (); if ^bsw.exists | vlength > bmax then do; if bsw.exists then do; ballocn = bmax; free buffer_state.bptr -> balloc; end; ballocn = vlength; allocate balloc set (buffer_state.bptr); bmax = ballocn; bsw.exists = "1"b; end; blen, copyn = vlength; fsbr.switch.buffer_in_use, bsw.use = "1"b; end obtain_buffer; write_x: proc; if fsbr.switch.keyed then do; if fsbr.outbuf_sw.use then onkeyx = fsbr.outbuf_key; else do; if release>0 then onkeyx = psr.keytemp; else onkeyx = addr (psr.keytemp) -> bc32; end; call iox_$seek_key (iocb_p, onkeyx, xrlength, iocb_status); if iocb_status ^= error_table_$no_record then goto write_error; end; if w_char_buffer then call iox_$write_record (iocb_p, wptr, wlen, iocb_status); else begin; dcl tempbuffer_w char (wlen) aligned; dcl bitbuffer_w bit (9*vlength) unaligned based; addr (tempbuffer_w) -> bitbuffer_w = psr.variable_p -> bitbuffer_w; call iox_$write_record (iocb_p, addr (tempbuffer_w), wlen, iocb_status); end; if iocb_status ^= 0 then goto write_error; fsbr.switch.buffer_in_use = "0"b; if fsbr.switch.keyed then fsbr.key_saved = onkeyx; fsbr.recio.rec_valid = "1"b; end write_x; end /* plio2_recio_ */;  plio2_resig_.pl1 10/03/83 1722.3rew 10/03/83 1005.5 14490 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_resig_:proc(pspp) options(support); dcl pspp ptr; dcl psp ptr; dcl fsbp ptr; dcl file_p ptr; dcl name33 char(33) aligned; dcl (index,null,substr) builtin; dcl addr builtin; dcl q ptr; dcl find_condition_info_ entry(ptr,ptr,fixed bin(35)); dcl continue_to_signal_ entry(fixed bin(35)); dcl code fixed bin(35); dcl 1 condition_structure_ aligned like condition_info; %include condition_info; %include on_data_; %include pl1_info; %include condition_info_header; %include plio2_fsb; %include plio2_ps; /* called by the following programs. LDI LDO GVE PVE P.Belmont 74.01.07 */ psp=pspp; if ps.job.string then goto resig; file_p=ps.file_p; fsbp=ps.fsbp; name33=fsb.filename; q=addr(condition_structure_); call find_condition_info_(null,q,code); if code^=0 then goto resig; q=condition_structure_.info_ptr; q->pl1_info.onfile=name33; q->pl1_info.onfile_sw="1"b; q->pl1_info.file_ptr=file_p; q->pl1_info.file_ptr_sw="1"b; ondata_$fileptr=file_p; ondata_$onfile=substr(name33,1,index(name33," ")-1); resig: call continue_to_signal_(code); end plio2_resig_;  plio2_signal_.pl1 10/03/83 1722.3rew 10/03/83 1005.6 42228 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_signal_: proc options(support); /* updated 5-13-72 by PAB to shift burden to HELP_PLIO2_SIGNAL_ */ /* plio2_signal_$ s_ signals s_l_ signals with datafield s_r_ signals and does abnormal return s_r_l_ signals with datafield and does abnormal return r_ does abnormal return conversion_error_ signals conversion condition, repairs string */ /* DECLARATION */ dcl (n1,n2,n3,oncharind) fixed bin(15); dcl (addr, null, string, substr) builtin; dcl CN char(20) aligned; dcl ( s,r,l,c,erno) fixed bin(15); dcl ( psp,pspp,fsbp,chp,file_ptr,p2(2) based) ptr; dcl based_chars char (1044480) based; dcl based_label label based; dcl onsource char(256) varying; dcl (condition_name,msg,datafield) char(*); dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl plio2_put_util_$put_publish_ ext entry (ptr); dcl put_copy_ ext entry(ptr,fixed bin(15)); dcl pl1_signal_$help_plio2_signal_ ext entry(char(*),ptr,fixed bin(15),char(256) varying,fixed bin(15)); % include plio2_fsb; % include plio2_ps; % include plio2_psr; /* ENTRIES */ s_: entry(pspp,condition_name,msg,erno); s = 1; c,l,r = 0; go to work; r_: entry(pspp); c,l,s = 0; r = 1; go to work; s_r_: entry(pspp,condition_name,msg,erno); c,l = 0; r,s = 1; go to work; s_r_l_: entry(pspp,condition_name,msg,erno,datafield); s,r,l = 1; c = 0; go to work; s_l_: entry(pspp,condition_name,msg,erno,datafield); s,l = 1; c,r = 0; go to work; conversion_error_: entry(pspp,msg,erno,chp,n1,n2,n3); c,s = 1; l,r = 0; CN="CONVERSION"; go to work_1; work: CN=condition_name; work_1: psp = pspp; if CN = "UNDEFINEDFILE" then plio2_data_$undef_file_sw = "1"b; else plio2_data_$undef_file_sw = "0"b; if psp^=null then do; fsbp=ps.fsbp; plio2_data_$badfsbp = ps.fsbp; plio2_data_$badjob = string(psr.job); /* MUST use psr.job, not ps.job, to get all 36 bits! */ end; else goto work_2; if CN = "UNDEFINEDFILE" then goto work_2; /* ps.job is garbage if error was in plio2_open_ ! */ /* Here there may be materials which need to be "put": either the present contents of the output buffer for PUT or the current content of the COPY-STACK for GET/COPY */ if ps.job.copy then do; call put_copy_(psp,fsb.bnc-1); ps.start_copy=fsb.bnc; end; if ps.job.put then if ^ps.job.string then call plio2_put_util_$put_publish_(psp); work_2: if s^=1 then go to return_test; oncharind=0; onsource=""; if psp^=null then file_ptr=ps.file_p; else file_ptr=null; if file_ptr^=null then do; fsbp=file_ptr->p2(2); if CN = "ENDFILE" | CN = "TRANSMIT" | CN = "UNDEFINEDFILE" | CN = "KEY" | CN = "RECORD" then; else fsb.lnzc = 0; if fsb.switch.record & fsb.switch.keyed then do; onsource=msg; oncharind=-1; end; /* SEVERAL conditions will be accompanied with KEY */ end; if CN = "CONVERSION" then CN = "conversion"; else if CN = "SIZE" then CN = "size"; else if CN = "ENDFILE" then CN = "endfile"; else if CN = "ENDPAGE" then CN = "endpage"; else if CN = "TRANSMIT" then CN = "transmit"; else if CN = "UNDEFINEDFILE" then CN = "undefinedfile"; else if CN = "NAME" then CN = "name"; else if CN = "KEY" then CN = "key"; else if CN = "RECORD" then CN = "record"; else if CN = "ERROR" then CN = "error"; else if CN = "OVERFLOW" then CN = "overflow"; else if CN = "UNDERFLOW" then CN = "underflow"; else if CN="MATH_ERROR" then CN = "error"; else if CN="FIXEDOVERFLOW" then CN = "fixedoverflow"; else if CN="ZERODIVIDE" then CN = "zerodivide"; else if CN="STRINGRANGE" then CN = "stringrange"; else if CN="STRINGSIZE" then CN = "stringsize"; else if CN="SUBSCRIPTRANGE" then CN = "subscriptrange"; if c = 1 then do; if n1>n2|n3n2 then call plio2_signal_$s_r_(psp,"ERROR","CE",116); onsource = substr(chp->based_chars,n1,n2+1-n1); oncharind=n3-n1+1; end; if l = 1 then onsource = datafield; call pl1_signal_$help_plio2_signal_((CN),pspp,erno,onsource,oncharind); if c = 1 then substr(chp->based_chars,n1,n2+1-n1) = onsource; return_test: if r = 1 then go to addr(ps.ab_return)->based_label; /* ABNORMAL RETURN */ return; end plio2_signal_;  plio2_sym_to_desc.pl1 10/03/83 1722.3rew 10/03/83 1005.6 29997 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ plio2_sym_to_desc:proc(sp,l1p,psp,new_sfp) returns(bit(36) aligned) options(support); /* Modified: 4 April 1978 by RAB to partially fix 1720 */ /* Modified: 1 May 1978 by PCK to implement unsigned binary */ dcl based_bit36 bit (36) aligned based; dcl (sp,l1p,psp,new_sfp) ptr; dcl (sfp,tp,tbp,sym_p,ref_p) ptr; dcl (bit,fixed,null,addrel,substr,addr) builtin; dcl ( i,icode ) fixed bin(15); dcl d bit(36) aligned; dcl old_type fixed bin(12); dcl size fixed bin(35); dcl old_symbol based bit(12) aligned; dcl data_type fixed bin (6); dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*),fixed bin(15)); dcl stu_$decode_runtime_value ext entry(fixed bin(35),ptr,ptr,ptr,ptr,ptr,fixed bin(15)) returns(fixed bin(35)); dcl stu_$get_implicit_qualifier entry(ptr,ptr,ptr,ptr,ptr) returns(ptr); %include stu_frame; /* */ %include runtime_symbol; %include symbol_node; %include plio2_ps; %include desc_types; /* */ start: sym_p=sp; size=sym_p->runtime_symbol.size; if size < 0 then do; sfp=new_sfp; if sfp=null then do; sfp=ps.stack_frame_p; tp=addrel(l1p,l1p->runtime_symbol.father); tbp=ps.ST_block_p; loop: if tbp ^= tp then do; if ^tbp->runtime_block.quick then sfp=sfp->frame.display; tbp=addrel(tbp,tbp->runtime_symbol.father); goto loop; end; end; /* sfp is symbol's stack_frame_ptr */ if sym_p -> runtime_symbol.class = "0011"b /* NOTE: if stu_ interface changes, this must change */ then ref_p = stu_$get_implicit_qualifier(tbp,sym_p,sfp,null,null); else ref_p = null; size=stu_$decode_runtime_value(size,tbp,sfp,null,null,ref_p,icode); /* NB: uses ST_block (tbp) and Stack_Frame (sfp) of proper block, not necessarily of current block. */ if icode^=0 then call plio2_signal_$s_r_(psp,"ERROR","s_to_d",239); end; test: d="0"b; if sym_p->runtime_symbol.flag then goto new_desc; old_type=fixed(sym_p->old_symbol,12); if old_type>524 then old_type=old_type-6; if old_type<519 & old_type>16 then old_type=old_type-16; substr(d,4,12)=bit(old_type,12); if substr(d,1,6) then go to make_string_desc; substr(d,19,1)=sym_p->symbol_node.bits.decimal; substr(d,20,8)=sym_p->symbol_node.scale; substr(d,28,9)=bit(fixed(size,9)); goto exit; make_string_desc: substr(d,19,18)=bit(fixed(size,18)); goto exit; /* */ new_desc: substr(d,1,1)="1"b; substr(d,2,6)=sym_p->runtime_symbol.type; /* no bits need be removed for arrays */ substr(d,8,1)=sym_p->runtime_symbol.bits.packed; data_type = fixed (sym_p -> runtime_symbol.type, 6); if data_type >= bit_desc & data_type <= v_char_desc then substr(d,13,24)=bit(fixed(size,24)); else do; substr(d,17,8)=sym_p->runtime_symbol.scale; if substr(d,17,1) then substr(d,13,4)="1111"b; /* negative scale */ substr(d,25,12)=bit(fixed(size,12)); end; exit: return(d); end plio2_sym_to_desc;  put_copy_.pl1 10/03/83 1722.3rew 10/03/83 1005.6 17766 %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ put_copy_:proc(pspp,nn) options(support); dcl pspp ptr; dcl nn fixed bin(21); dcl ( psp , cp , cpfp ) ptr; dcl ( n1 , n2 , i ) fixed bin(15); dcl (addr,null,substr) builtin; dcl copy_file file based; dcl ( pspstatsaved,fsbpstatsaved ) ptr; dcl NL char(1) aligned static internal init(" "); % include plio2_fsb; % include plio2_ps; psp=pspp; n1=psp->ps.start_copy; n2=nn; cp=psp->ps.fsbp->fsb.bptr; if psp->ps.copy_file_p=null then cpfp=addr_sysprint(); else cpfp=psp->ps.copy_file_p; /* dcl ioa_ entry ext implementation(variable); call ioa_("cpfp=^p,cp=^p,n1=^d,n2=^d,stuff=^a",cpfp,cp,n1,n2,substr(cp->xbuf,n1,n2+1-n1)); call ioa_("filename(get)=^a",psp->ps.fsbp->fsb.filename); call ioa_("filename(copy)=^a",psp->ps.copy_file_p->p_vector(2)->fsb.filename); */ pspstatsaved=plio2_data_$pspstat; fsbpstatsaved=plio2_data_$fsbpstat; /* TO OPEN THE COPY FILE PRIOR TO FIRST GET . . . */ if n2=-1 then do; put file(cpfp->copy_file) edit("")(a); goto exit; end; copy_loop: if n1 > n2 then do; exit: plio2_data_$pspstat=pspstatsaved; plio2_data_$fsbpstat=fsbpstatsaved; return; end; do i=n1 to n2; if substr(cp->xbuf,i,1)=NL then goto copy; end; i=n2+1; copy: if n1copy_file) edit(substr(cp->xbuf,n1,i-n1)) (a); n1=i+1; if i<=n2 then put file(cpfp->copy_file) skip; goto copy_loop; addr_sysprint:proc returns(ptr); dcl sysprint file output print stream; return(addr(sysprint)); end addr_sysprint; end put_copy_;  put_data_block_all_.pl1 10/03/83 1722.3rew 10/03/83 1005.6 19107 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* written 05.30.73 by A. Downing as part of the pl1 runtime suport */ put_data_block_all_: proc (psp) options(support); dcl (duplication, n) fixed bin; dcl (block_ptr, /* points at current block */ save_sp, /* save the stack pointer */ save_bp, /* save the block ptr */ sslpsaved, psp) ptr, /* points at ps */ more bit(1) aligned, ptrsave bit(72) aligned based, put_data_var_all_ ext entry (fixed bin, fixed bin, ptr, ptr, ptr), 1 bounds (128) aligned int static, 2 lower fixed bin, 2 upper fixed bin, (addrel,addr, rel, null) builtin; %include stu_frame; %include runtime_symbol; %include plio2_ps; block_ptr = ps.ST_block_p; addr(sslpsaved)->ptrsave=addr(ps.ss_list_p)->ptrsave; addr(save_bp )->ptrsave=addr( block_ptr )->ptrsave; addr(save_sp )->ptrsave=addr( ps.stack_frame_p )->ptrsave; duplication = 0; more="1"b; do while(more); n = 0; call put_data_var_all_ (duplication, n, addrel (block_ptr, block_ptr -> runtime_block.start), addr (bounds), psp); block_ptr = addrel (block_ptr, block_ptr -> runtime_block.father); if block_ptr -> runtime_block.father = block_ptr -> runtime_block.header then more="0"b; else do; if ^ block_ptr -> runtime_block.quick then psp -> ps.stack_frame_p = ps.stack_frame_p -> frame.display; psp -> ps.ST_block_p = block_ptr; end; end; addr(ps.ST_block_p )->ptrsave=addr( save_bp )->ptrsave; addr(ps.stack_frame_p)->ptrsave=addr( save_sp )->ptrsave; addr(ps.ss_list_p )->ptrsave=addr(sslpsaved )->ptrsave; return; end put_data_block_all_;  put_data_var_all_.pl1 10/03/83 1722.3rew 10/03/83 1005.6 66663 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* written 05.30.73 by A. Downing to suport put data; */ /* modified 04.04.78 by R. Barnes to more properly decide when to call stu_$get_implicit_qualifier */ /* Modified: 05/01/78 by PCK to implement unsigned binary */ put_data_var_all_: proc (duplication, n, vp, bounds_p, psp) options(support); dcl (link_p, text_p, ref_p) ptr init (null ()); dcl 1 bounds (128) based (bounds_p), 2 lower fixed bin, 2 upper fixed bin; dcl ss_list (0:128) int static fixed bin (26); dcl ssl (128) fixed bin (26) based (sslp), sslp ptr; dcl 1 val_struct based, 2 flag bit(2) unal, 2 type bit(4) unal, 2 rest bit(30) unal; dcl duplication fixed bin, /* number of duplicate variable declarations encountered */ (vp, bounds_p, var_ptr) ptr, p ptr, search_ptr ptr, /* used in searching through duplication chains */ psp ptr, /* points at the sp */ duplication_list (1000) bit (18) int static, /* holds the offset of the duplicated variable actually (put) */ more bit (1), (item_type,i, j, k, l, n, father_n, own_dims) fixed bin (26), com_err_ ext entry options (variable), plio2_signal_$s_r_ ext entry (ptr, char (*), char (*), fixed bin (15)), stu_$decode_runtime_value ext entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin (26)) returns (fixed bin), stu_$get_implicit_qualifier ext entry (ptr,ptr,ptr,ptr,ptr) returns(ptr), stu_$get_runtime_address ext entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), plio2_pdt_ ext entry (ptr), (addrel,addr, fixed, convert, null,rel,bit) builtin; %include runtime_symbol; %include plio2_ps; var_ptr = vp; ps.ss_list_p = addr (ss_list); sslp = addr (ss_list (n+1)); father_n = n; top: n = fixed (var_ptr -> runtime_symbol.ndims, 6); ss_list (0) = n; own_dims = n - father_n; search_ptr = addrel (var_ptr, var_ptr -> runtime_symbol.name); search_ptr = addrel (search_ptr, -1); search_ptr = addrel (search_ptr, search_ptr -> runtime_token.dcl); if search_ptr -> runtime_symbol.address.next ^= (14)"0"b then do; if fixed (var_ptr -> runtime_symbol.level, 6) < 2 then do; do i = 1 to duplication; if rel (search_ptr) = duplication_list (i) then go to found; end; /* end of i loop */ duplication = duplication + 1; duplication_list (duplication) = rel (search_ptr); end; /* end of looking at and adding to duplication_list */ end; /* end of do group */ do l = father_n + 1 to n; if var_ptr -> runtime_symbol.bounds (l).lower >= 0 then bounds_p -> bounds (l).lower = var_ptr -> runtime_symbol.bounds (l).lower; else do; if ref_p = null & var_ptr -> runtime_symbol.class = "0011"b then ref_p = stu_$get_implicit_qualifier(ps.ST_block_p,var_ptr,ps.stack_frame_p, link_p,text_p); else; bounds_p -> bounds (l).lower = stu_$decode_runtime_value (var_ptr -> runtime_symbol.bounds (l).lower, ps.ST_block_p, ps.stack_frame_p, null, null, ref_p, i); if i ^= 0 then go to bounds_error; end; if var_ptr -> runtime_symbol.bounds (l).upper >= 0 then bounds_p -> bounds (l).upper = var_ptr -> runtime_symbol.bounds (l).upper; else do; if ref_p = null & var_ptr -> runtime_symbol.class = "0011"b then ref_p = stu_$get_implicit_qualifier(ps.ST_block_p,var_ptr,ps.stack_frame_p, link_p,text_p); else; bounds_p -> bounds (l).upper = stu_$decode_runtime_value (var_ptr -> runtime_symbol.bounds (l).upper,ps.ST_block_p,ps.stack_frame_p,null,null,ref_p,i); if i ^= 0 then go to bounds_error; end; end; /* end of filling in lower and upper bounds */ if var_ptr -> runtime_symbol.son ^= (18)"0"b then do; if n = father_n then call put_data_var_all_ (duplication, n, addrel (var_ptr, var_ptr -> runtime_symbol.son), bounds_p, psp); else do; /* we have arrayness at this level */ do l = father_n + 1 to n -1; ss_list (l) = bounds_p -> bounds (l).lower; end; more = "1"b; do while (more); do i = bounds_p -> bounds (n).lower to bounds_p -> bounds (n).upper; ss_list (n) = i; call put_data_var_all_ (duplication, n, addrel (var_ptr, var_ptr -> runtime_symbol.son), bounds_p, psp); end; /* end of do i */ j = n -1; do while (j > father_n & ss_list (j)+1 > bounds_p -> bounds (j).upper); j = j - 1; end; if j > father_n then do; ss_list (j) = ss_list (j) + 1; do i = j + 1 to n - 1; ss_list (i) = bounds_p -> bounds (i).lower; end; /* end of i loop */ end; else more = "0"b; end; /* end of outer while */ end; /* end of having subscripts at this level */ end; /* end of having a son pointer */ else do; /* we are at the end of a branch */ item_type=fixed(var_ptr->runtime_symbol.type,6); if (item_type>23 & item_type<33) | (item_type>46 & item_type<63) then go to found; /* skip this item */ k = fixed (rel (var_ptr), 18) - fixed (rel (ps.ST_top_p), 18); ps.offset = bit (fixed (k, 18), 18); if own_dims = 0 then call put; else do; /* its an array */ do i = 1 to own_dims; ssl (i) = bounds_p -> bounds (i + father_n).lower; end; more = "1"b; do while (more); do i = bounds_p -> bounds (n).lower to bounds_p -> bounds (n).upper; ssl (own_dims) = i; call put; end; /* end of i loop */ j = own_dims -1; do while (j > 0 &ssl (j) +1 > bounds_p -> bounds (j + father_n).upper); j = j -1; end; /* end of do while */ if j > 0 then do; ssl (j) = ssl (j) + 1; do k = j+1 to own_dims - 1; ssl (k) = bounds_p -> bounds (k + father_n).lower; end; end; /* end of do group */ else more = "0"b; end; /* end of outer do while */ end; /* end of its an array */ end; /* end of handling a terminal element */ found: n = father_n; /* reset n */ ss_list (0) = n; if var_ptr -> runtime_symbol.brother ^= (18)"0"b then do; var_ptr = addrel (var_ptr, var_ptr -> runtime_symbol.brother); go to top; end; return; /* */ put: proc; ps.value_p = stu_$get_runtime_address (ps.ST_block_p, var_ptr, ps.stack_frame_p, link_p, text_p, ref_p, addr (ss_list (1))); if ps.value_p = null () then do; call com_err_ (0, "put_data_var_all_", "Can not get runtime address for symbol table offset ^o", fixed (ps.offset, 18)); go to found; end; if item_type^=20 then if item_type^=22 then goto non_varying; ps.value_p=addrel(ps.value_p,1); /* plio2_pdt_ needs the address of varying strings as for parameter passing */ non_varying: call plio2_pdt_ (psp); return; end put; bounds_error: call com_err_ (i, "put_data_var_all_", "Cannot decode runtime bounds for symbol table offset ^d", fixed (ps.offset, 18)); call plio2_signal_$s_r_ (psp, "ERROR", "put_data_var_all_", 239); go to found; end put_data_var_all_;  display_file_value_.pl1 10/03/83 1722.3rew 10/03/83 1005.7 36279 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ display_file_value_: proc (P_switch, P_file, P_code); /* formats information about the file, and outputs it on switch. Code is returned 0 for no errors, oterwise it is a standard system error code Designed 18 July 78 by James R. Davis */ dcl (P_switch ptr, /* to switch for io */ P_file file variable, /* the file whose value we print */ P_code fixed bin (35) /* standard system error code */ ) parameter; dcl fsbp ptr, /* to file state block */ fabp ptr, /* to file attribute block */ swp ptr, /* to switch for io */ ioa_$ioa_switch entry options (variable), chbuf char (fsb.bsize) based (fsb.bptr), (addr, substr, null) builtin; dcl iox_$user_output ptr external; /* default switch */ dcl TIC char (1) static options (constant) init ("!"); /* used in stream input */ P_code = 0; fsbp = addr (P_file) -> file_value.fsb_ptr; fabp = addr (P_file) -> file_value.fab_ptr; swp = P_switch; if swp = null () then swp = iox_$user_output; call ioa_$ioa_switch (swp, "fab: ^p, fsb: ^p", fabp, fsbp); if ^ fsb.switch.open then if fab.switch.stream then if fab.switch.input then call ioa_$ioa_switch (swp, "closed ^[internal^;external^] stream input file: ^32a", fab.switch.internal, fab.name); else if fab.switch.output then call ioa_$ioa_switch (swp, "closed ^[internal^;external^] stream output file: ^32a ^[print page size: ^d line size: ^d^;^2s^]", fab.switch.internal, fab.name, fab.switch.print, fab.page_size, fab.line_size); else call ioa_$ioa_switch (swp, "closed ^[internal^;external^] stream file not input or output: ^32a", fab.switch.internal, fab.name); else if fab.switch.record then call ioa_$ioa_switch ( "closed ^[internal^;external^] record ^[output ^;^] ^[input ^;^]^[update ^;^]^[keyed ^;^]^[sequential^;^]^[direct^;^]^[(stringvalue)^;^] file: ^32a", fab.switch.internal, fab.switch.output, fab.switch.input, fab.switch.update, fab.switch.keyed, fab.switch.sequential, fab.switch.direct, fab.switch.stringvalue, fab.name); else call ioa_$ioa_switch (swp, "closed file not record or stream name: ^32a", fab.name); else do; /* open file */ call ioa_$ioa_switch (swp, "^[internal^;external^] file name: ^32a ^/ path: ^168a^/iocb at ^p", fsb.switch.internal, fsb.filename, fsb.path_name, fsb.iocb_p); if fsb.switch.stream then if fsb.switch.input then do; call ioa_$ioa_switch (swp, "stream input last char ^d", fsb.blc); call ioa_$ioa_switch (swp, "^a^a^a", substr (chbuf, 1, fsb.bnc-1), TIC, substr (chbuf, bnc, blc -bnc + 1)); end; /* of input stream file */ else if fsb.switch.output then call ioa_$ioa_switch (swp, "stream output ^[print page size ^d line size ^d^/pageno ^d lineno ^d colno^d^;^5s^]", fsb.switch.print, /* if print then give print parms */ fsb.psize, fsb.lsize, fsb.pageno, fsb.lineno, fsb.kol); else call ioa_$ioa_switch (swp, "stream, but not input or output"); else if fsb.switch.record then call ioa_$ioa_switch (swp, "record ^[input^;^]^[output^;^]^[update^;^] ^[keyed^;^]^[sequential^;^]^[direct^;^] ^[(string value)^;^]", fsb.switch.input, fsb.switch.output, fsb.switch.update, fsb.switch.keyed, fsb.switch.sequential, fsb.switch.direct, fsb.switch.stringvalue); else call ioa_$ioa_switch (swp, "not stream or record"); end; /* of open file */ /* */ %include pl1_file_value; %include plio2_fsb; %include plio2_fab; end display_file_value_; 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