1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1987                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 
  16 
  17 /****^  HISTORY COMMENTS:
  18   1) change(87-06-26,Huen), approve(87-06-26,MCR7712), audit(87-12-01,RWaters),
  19      install(87-12-01,MR12.2-1005):
  20      Fix bug2164
  21   2) change(90-08-24,Huen), approve(90-08-24,MCR8187),
  22      audit(90-09-07,Zimmerman), install(90-10-17,MR12.4-1046):
  23      pl1_2224: Fix the PL1 compiler use of variables that are targets of "read
  24      into" statements.
  25                                                    END HISTORY COMMENTS */
  26 
  27 
  28 io_semantics:proc(bb,ss,tt) ;
  29           dcl    (bb,ss,tt) ptr;
  30 
  31           /* Written by P. A. Belmont on 9-29-71
  32              called by expression_semantics "on the way down"
  33              upon encountering any of the  "outer" io op_codes:
  34              get_file,get_string,put_file,put_string,open_file,
  35              xxx_file for various xxx's
  36 
  37              or "inner op_codes:
  38              get_list_trans,put_list_trans,get_edit_trans,
  39              put_edit_trans,get_data_trans,put_data_trans.
  40           */
  41 
  42 
  43           /* updated 12-17-74 to make not_bytebuffer in psr.job smarter and to add bit_string bit */
  44 
  45           /* updated 7-31-74 to add propagate_bit at line 913,
  46                     abnormal_return for keyto (release-2,action(19),keyto_join:  */
  47 
  48           /* updated 12-22-77 by P. Krupp to  fix bugs 1657, 1658, 1680          */
  49           /* Modified 780616 by PG for unsigned */
  50           /* Modified 790110 by RAB to fix 1813 (referenced but not set not diag for file vars) */
  51           /* Modified 4-10-87 by RW to fix bug 2164 */
  52 
  53 dcl type bit (36);
  54 dcl opcode_temp bit(9) aligned;
  55 dcl (a,b,cs,ns,vs,q,r,s,t,tp,tp1,dp) ptr;
  56 dcl (locate_var,locate_set,locate_size) ptr;
  57 dcl transop bit(9) aligned;
  58 dcl convtype bit(36) aligned;
  59 dcl (i,n,m,PS_offset,lal) fixed bin(15);
  60 dcl no_byte bit(1) aligned;
  61 dcl cbs fixed bin(24);
  62 dcl strlen fixed bin(31);
  63 dcl assign_list(21) ptr;
  64 dcl end_of_join ptr;
  65 
  66 /* builtins */
  67 
  68 dcl (addr, binary, bit, length, mod, null, substr, string) builtin;
  69 
  70 dcl job bit(36) aligned;
  71 dcl job_additions bit(36) aligned;
  72 dcl bb36 bit(36) aligned based;
  73 dcl constsize fixed bin(35);
  74 dcl stringdesc bit(36) aligned;
  75 
  76 dcl fab2mod2(7) ptr aligned;
  77 dcl fab2template_b bit(504) aligned based(addr(fab2mod2));
  78 dcl 1 fab2template based(addr(fab2mod2)),
  79           2 bits bit(36) aligned,
  80           2 name char(32) aligned,
  81           2 ( ls,ps,bs ) fixed bin(15),
  82           2 title168p         ptr;
  83 
  84 dcl pl1_stat_$generate_symtab ext bit(1);
  85 dcl pl1_stat_$check_ansi ext bit(1) aligned;
  86 
  87 dcl rand_index(35) fixed bin(15) static internal init(2,2,1,4,4, 4,1,1,1,1, 3,1,1,1,1,
  88                                                       1,1,1,1,4, 3,3,3,1,1, 1,1,1,2,0,
  89                                                       0,0,0,5,0);
  90 
  91 ^L
  92 /* program */
  93 
  94           t=tt;
  95           if t->operator.op_code >= terminate_trans then goto main_io_operator;
  96 
  97 transmission_operators:
  98 
  99           transop=t->operator.op_code;
 100           tp=t->operator.operand(2);
 101 
 102           if tp->node.type=operator_node
 103           then if tp->op_code=join then
 104                     do;
 105                     /* builtin, processing a pseudovariable target
 106                        of get-list or get-edit, will replace the PV
 107                        with join(assign(temp,PV),temp,assign(PV,temp)) in the cases
 108                        onsource, onchar, pageno.  This is because
 109                        these PVs are implemented as calls instead of
 110                        as storage references.  io_semantics must
 111                        now rearange things.
 112 
 113                        builtin must have completely processed its things
 114                        and operator_semantics must copy the tree ("tt")
 115                        argument back into the tree-proper. */
 116 
 117                     tt=tp;                        /* replace GET with JOIN */
 118                     t->operand(2)=tp->operand(2); /* GET's target is now the "temp"  */
 119                     tp->operand(2)=t;             /*  yielding JOIN(ASSIGN(temp,PV),GET(-,temp),ASSIGN(PV,temp)) */
 120                     tp=t->operand(2);             /* tp points to the target of GET */
 121                     end;
 122 
 123           if tp->node.type=token_node then
 124                     do;
 125                     if ^(transop=put_list_trans|transop=put_edit_trans) then goto err471;
 126                     if (tp -> token.type & is_constant) ^= is_constant
 127                     then go to err472;
 128 
 129                     tp, t -> operator.operand (2) = convert (tp, decoded_type (binary (tp -> token.type, 9)));
 130                     end;
 131 
 132           if tp->node.type=operator_node then
 133                     do;
 134                     if ^(transop=put_list_trans|transop=put_edit_trans) then
 135                               goto err471;
 136                     tp=tp->operator.operand(1);
 137                     end;
 138 
 139           if tp->node.type=label_node
 140                     then convtype=local_label_var_type;
 141           else if tp->reference.symbol->node.type=label_node
 142                     then convtype=local_label_var_type;
 143           else if tp->reference.symbol->symbol.constant
 144                & (tp->reference.symbol->symbol.entry | tp->reference.symbol->symbol.format)
 145                     then convtype=substr(string(tp->reference.symbol->symbol.attributes),1,36);
 146           else convtype=(36)"0"b;
 147 
 148           if convtype^=(36)"0"b
 149                     then if transop=put_list_trans
 150                               then do;
 151                               t->operator.operand(2)=create_operator(assign,2);
 152                               t->operator.operand(2)->operator.operand(2)=tp;
 153                               t->operator.operand(2)->operator.operand(1),tp=declare_temporary(convtype,0,0,null);
 154                               t->operator.operand(2)->operator.processed="1"b;
 155                               end;
 156                               else call semantic_translator$abort(358,tp);
 157 
 158           if tp->reference.symbol->symbol.picture
 159           then do;
 160                     tp->reference.symbol->symbol.general->reference.symbol->symbol.allocate = "1"b;
 161 
 162                     if transop=put_list_trans
 163                     then do;
 164                               t->operator.op_code = put_field;
 165                               t->operand(1) = declare_constant$integer((tp->reference.c_length));
 166                          end;
 167                end;
 168 
 169           type = substr (string (tp -> reference.symbol -> symbol.attributes), 1, 36);
 170 
 171           if (type & computational_mask) = ""b              /* is the symbol computational? */
 172           then if (transop = put_data_trans) | (transop = put_list_trans)       /* Not computational, is this a put? */
 173                then do;                                     /* yes. */
 174                               t->operand(1) = declare_descriptor(bb,ss,(tp->reference.symbol),
 175                                                   (tp->reference.qualifier),"0"b);
 176                               if pl1_stat_$check_ansi
 177                               then do;
 178                                         if t->operand(2)->node.type = operator_node
 179                                         then      n = 352;
 180                                         else      n = 351;
 181                                         call semantic_translator$error(n,tp);
 182                               end;
 183                     end;
 184                else go to err472;
 185 
 186           if transop=put_data_trans then
 187                     do;
 188                     t->operator.operand(1)=tp->reference.subscript_list;
 189                     tp=tp->reference.symbol;
 190                               do while(tp^=null);
 191                               tp->symbol.put_in_symtab="1"b;
 192                               tp=tp->symbol.father;
 193                               end;
 194                     return;
 195                     end;
 196 
 197           if (type & arithmetic_mask) ^= ""b                /* arithmetic? */
 198           then      if transop=put_list_trans
 199                     then do;
 200                               t->operator.op_code=put_field;
 201                               t->operator.operand(2)=convert$from_builtin((t->operand(2)),char_type);
 202                               t->operand(1)=declare_constant$integer((t->operand(2)->operand(1)->reference.c_length));
 203                               end;
 204                     else t->operand(1)=declare_descriptor(bb,ss,(tp->reference.symbol),(tp->reference.qualifier),"0"b);
 205 
 206           if (type & string_mask) ^= ""b                    /* string? */
 207                               /* NOTE: we do NOT make up a descriptor
 208                                         in the case of a pictured value.
 209                                         The lack of one tips off the code generator. */
 210 
 211           then do;            /* string case - must manufacture a descriptor */
 212                               /* Note: we must here handle a substr as a
 213                                  storage reference (i.e., the symbol of the
 214                                  whole string but a reference with a possibly
 215                                  shorter length).  declare_descriptor would
 216                                  return a descriptor for the whole string;  the
 217                                  situation is _^Hn_^Ho_^Ht analogous to argument passing
 218                                  since in that case a temporary is made.  */
 219 
 220                     if tp -> reference.symbol -> symbol.bit
 221                     then if tp -> reference.varying_ref
 222                          then stringdesc = "1010100"b;      /* descriptor type 20 */
 223                          else stringdesc = "1010011"b;      /* descriptor type 19 */
 224                     else if tp -> reference.varying_ref
 225                          then stringdesc = "1010110"b;      /* descriptor type 22 */
 226                          else stringdesc = "1010101"b;      /* descriptor type 21 */
 227 
 228                     substr(stringdesc,8,1)=tp->reference.symbol->symbol.packed;
 229                     q=null;
 230 
 231                     if tp->reference.varying_ref then
 232                               do;
 233                               s=tp->reference.symbol;
 234                               if s->symbol.dcl_size=null then
 235                               constsize=s->symbol.c_dcl_size;
 236                               else      do;
 237                                         q=copy_expression(s->symbol.dcl_size);
 238                                         if s->symbol.refer_extents then
 239                                         call refer_extent(q,(tp->reference.qualifier));
 240                                         string(context)="0"b;
 241                                         q = expression_semantics(bb,ss,q,context);
 242                                         end;
 243                               end;
 244 
 245                     else      do;       /* non varying */
 246                               if tp->reference.length=null then constsize=tp->reference.c_length;
 247                               else      q=copy_expression(tp->reference.length);
 248                               end;
 249 
 250                     if q=null then
 251                               do;
 252                               substr(stringdesc,13,24)=substr(addr(constsize)->bb36,13,24);
 253                               t->operator.operand(1)=declare_constant(stringdesc,arg_desc_type,length(stringdesc),0);
 254                               end;
 255                     else      do;
 256                               dp,t->operator.operand(1)=create_operator(make_desc,3);
 257                               dp->operator.operand(1)=declare_temporary(arg_desc_type,length(stringdesc),0,null);
 258                               dp->operator.operand(2)=declare_constant(stringdesc,arg_desc_type,length(stringdesc),0);
 259                               dp->operator.operand(3)=q;
 260                               end;
 261                     end;
 262 
 263           if transop<=get_edit_trans then
 264                     do;
 265                     tp=tp->reference.symbol;
 266                     call propagate_bit(tp,set_bit);
 267                     call propagate_bit(tp,passed_as_arg_bit);
 268                     end;
 269 
 270           return;
 271 
 272 err471:
 273           n=471;
 274           goto  abort_trans;
 275 
 276 err472:
 277           n=472;
 278 
 279 abort_trans:
 280           if t->operator.operand(2)->node.type=operator_node then n=n+3;
 281           call semantic_translator$error(n,tp);
 282           return;
 283 
 284 main_io_operator:
 285           vs,cs=ss;
 286           if ss->statement.labels=null then goto keep_statement;
 287           cs=create_statement((ss->statement.statement_type),ss,null,(ss->statement.prefix));
 288           cs->statement.root=ss->statement.root;
 289           ss->statement.root=null;
 290           ss->statement.statement_type=null_statement;
 291           return;
 292 
 293 keep_statement:
 294           lal=0;
 295           end_of_join=null;
 296           ns=cs->statement.next;
 297           b=bb;
 298           if b->block.plio_ps=null then
 299                     do;
 300                     call io_semantics_util$make_ps(b);
 301                     b -> block.why_nonquick.io_statements = "1"b;
 302                     b -> block.no_stack = "0"b;
 303                     end;
 304 
 305 
 306                     /* Map of PS for the curious:
 307 
 308                     PS|00 Stack_Frame_p
 309                     PS|02 Symbol_Table_Top_p
 310                     PS|04 Symbol_Table_Block_p
 311                     PS|06 Format_Area_p
 312                     PS|08 Subscript_List_p
 313                     PS|10 Abnormal_Return_Label
 314                     PS|16 Source_p      (addr(file) or addr(FFSB) or addr(ref))
 315                     PS|18 Special_List_p          /Set_P_p
 316                     PS|20 Copy_File_p
 317                     PS|21                         /Variable_Bit_Length
 318                     PS|22 Job
 319                     PS|23 Number
 320                     PS|24 Value_p                 /Variable_p
 321                     PS|26 Descriptor
 322                     PS|27 ..........
 323                     PS|28 Offset
 324                     PS|29 Prep_sw                 /Locking_sw
 325                     PS|30 New_Format_sw
 326                     .....
 327                     PS|48 Key (char(256) varying  )
 328                                                                       */
 329           m=t->operator.number;
 330                     t->operator.operand(m)=convert((t->operator.operand(m)),bit_type);
 331                     job=t->operator.operand(m)->reference.symbol->symbol.initial->bb36;
 332                     job_additions="0"b;
 333                     /* See: io_statement_parse;  the options etc are recorded as a bit 36. */
 334           m=m-1;
 335 
 336                               /* Now handle the special cases and then call expression_semantics
 337                                  for all the ordinary operands. Check that all items but
 338                                  into and from are scalar. */
 339 
 340           if substr(job,4,3)^="0"b then                               /* data,edit,list */
 341                     do;
 342                     call io_data_list_semantics(b,cs,(t->operator.operand(4)));
 343                     if t->operator.operand(4)->operator.op_code=get_data_trans then
 344                               do;
 345                               if lal<20 then lal=lal+1;
 346                               else goto err467;
 347                               assign_list(lal)=t->operator.operand(4);
 348                               end;
 349                     t->operator.operand(4)=null;
 350                     goto loop1;
 351                     end;
 352 
 353           if substr(job,20,1) then goto locate_prelim;                /* locate */
 354 
 355 loop1:
 356           do i=1 to m;
 357           if t->operator.operand(i)=null then goto end_loop1;
 358           string(context)="0"b;
 359 
 360           if i=1 then if (job & "000000000000000000000000101"b)^="0"b
 361                     then def_context.evaluate_offset="1"b;
 362                               /* force evaluation of offset for aggregate FROM,INTO */
 363 
 364           t->operand(i) = expression_semantics(b,cs,(t->operand(i)),context);
 365           if t -> operand (i) -> node.type = label_node
 366                then call semantic_translator$abort(78,null); /* illegal label constant */
 367           if t -> operand(i) -> node.type = reference_node
 368           then if t -> operand (i) -> reference.symbol -> node.type = label_node
 369                then call semantic_translator$abort(78,null); /* illegal label constant */
 370           if i=1 then         if (job & "00000000000000000000000010101"b) ^="0"b          /* into,from,(ref) */
 371                               then goto end_loop1;
 372           if def_context.aggregate then goto err62;         /* scalar */
 373 end_loop1:
 374           end;
 375 /* ^L
 376 
 377 
 378 
 379 
 380 
 381                     JOB BITS
 382 
 383           INPUT(PARSE)        AS ALTERED(HEREIN)            TO RUNTIME
 384 
 385           1  file
 386           2  string option
 387           3                   varying
 388           4  data
 389           5  edit
 390           6  list
 391           7  get
 392           8  put
 393           9  page
 394           10 line
 395           11 skip
 396           12 copy-file
 397           13 p1p2
 398           14 bit_string
 399           15 unlock
 400           16 read
 401           17 write
 402           18 rewrite
 403           19 delete
 404           20 locate
 405           21 key
 406           22 keyto
 407           23 keyfrom
 408           24 set              set
 409           25 into
 410           26 ignore
 411           27 from
 412           28                                                rel-6
 413           29                                                rel-5     NB: RELEASE-NUMBER 6-bits
 414           30                                                rel-4         copied and reset to 0 by RECIO
 415           31                                                rel-3
 416           32                                                rel-2
 417           33                                                rel-1
 418           34 open             not-byte-buffer               not-byte-buffer
 419           35
 420           36                  packedptr                     packedptr
 421 
 422           */
 423 
 424 loop2:
 425           do i=1 to 29,
 426                     34;       /* OPEN,TITLE,PSIZE,LSIZE */
 427           if substr(job,i,1) then
 428                     do;
 429                     tp=t->operator.operand(rand_index(i));
 430                     goto action(i);
 431                     end;
 432 action(3):                                                  /* varying */
 433 action(6):                                                  /* list */
 434 action(9):                                                  /* page */
 435 action(13):                                                 /* p1p2 */
 436 
 437 end_loop2:
 438           end;
 439 /* ^L */
 440 exit:
 441           if end_of_join ^=null then
 442                     do;
 443                     if job_additions^="0"b then job=job|job_additions;
 444                     substr(job,28,6)="000010"b;   /* release 2 */
 445 
 446                                         /* release-2 adds: abnormal-return after KEYTO.  See comment
 447                                                   at keyto_join:
 448                                            release-1 adds: char(256) var KEYs
 449                                                             not_byte_buffer switch  */
 450                     end_of_join->operator.operand(1)=declare_constant$bit(job); /* for record_io, stream_prep operators */
 451                                                   /* the bit36 "job" may have been changed  */
 452                     lal=lal+1;
 453                     assign_list(lal)=end_of_join;
 454                     end;
 455           vs=create_statement(assignment_statement,(cs->statement.back),null,(cs->statement.prefix));
 456           vs->statement.generated,vs->statement.processed="1"b;
 457           if lal=1 then vs->statement.root=assign_list(1);
 458           else      do;
 459                     vs->statement.root,tp=create_operator(join,lal);
 460                               do i=1 to lal;
 461                               tp->operator.operand(i)=assign_list(i);
 462                               end;
 463                     end;
 464 
 465 
 466           /* original operator is nulled out */
 467           do lal=1 to m+1;
 468           t->operator.operand(lal)=null;
 469           end;
 470 
 471 
 472           return;
 473 err62:
 474           n=62;
 475           goto abort_null;
 476 
 477 err114:
 478           n=114;
 479           goto abort_tp;
 480 
 481 err115:
 482           n=115;
 483           goto abort_tp;
 484 
 485 err468:
 486           n=468;
 487           tp=q;
 488           goto abort_tp;
 489 
 490 err461:
 491           n=461;
 492           goto abort_tp;
 493 
 494 err462:
 495           n=462;
 496           goto abort_tp;
 497 
 498 err463:
 499           n=463;
 500           goto abort_tp;
 501 
 502 err464:
 503           n=464;
 504           goto abort_tp;
 505 
 506 err465:
 507           n=465;
 508           goto abort_tp;
 509 
 510 err466:
 511           n=466;
 512           goto abort_null;
 513 
 514 err467:
 515           n=467;
 516           goto abort_null;
 517 
 518 
 519 abort_null:
 520           tp=null;
 521 abort_tp:
 522           call semantic_translator$error(n,tp);
 523           if n=467 then return;
 524           goto end_loop2;
 525 
 526 
 527 /* ^L */
 528 
 529 action(12):                                                                               /* copy_file */
 530           PS_offset=ps_copy;
 531           goto test_file;
 532 action(1):                                                                                /* file */
 533           PS_offset=ps_source;
 534 test_file:
 535           if ^tp->reference.symbol->symbol.file then goto err462;
 536           goto set_addr;
 537 
 538 action(11):                                                                               /* skip */
 539           if tp=null then tp=declare_constant$integer(1);
 540 action(10):                                                                               /* line */
 541 action(26):                                                                               /* ignore */
 542           call assign_ps(tp,ps_number,"int",null);
 543           goto end_loop2;
 544 
 545 action(21):                                                                               /* key */
 546 action(23):                                                                               /* keyfrom */
 547 
 548           r=b->block.plio_ps->list.element(50);
 549           if r=null then r=io_semantics_util$keys(b);
 550           if tp->node.type=token_node then tp=convert(tp,char_type);
 551           call assign_ps(tp,49,"aok",r);
 552                                         /* c_offset must address the first data-word of the
 553                                            char256varying KEY; not the length-word !!   */
 554           goto end_loop2;
 555 
 556 action(24):                                                                               /* set */
 557           PS_offset=ps_special_list;
 558           if substr(job,20,1) /* locate */
 559           then      tp=locate_set;
 560           if ^tp->reference.symbol->symbol.ptr then goto err463;
 561           call propagate_bit((tp->reference.symbol),set_bit);
 562           if tp->reference.symbol->symbol.unaligned then substr(job_additions,36,1)="1"b;
 563           goto set_addr;
 564 
 565 
 566 
 567 action(29):                                                                               /* (ref) for lock,unlock */
 568 
 569           n=476;    /* (REF) not implemented now */
 570                     /* when it is, then check for data type:LOCK */
 571           goto abort_tp;
 572 
 573 action(25):                                                                               /* into */
 574           call propagate_bit((tp->reference.symbol),set_bit);
 575           /* TR13134: Padded ref. bug occurs at read into statement */
 576           call propagate_bit((tp->reference.symbol),passed_as_arg_bit);
 577           /* if i=29 then goto set_variable_p; */
 578 action(27):                                                                               /* from */
 579 
 580 
 581           /* generate    BITSIZE   and   BYTE-ALIGNMENT   */
 582 
 583 
 584           no_byte="0"b;       /* we are prepared to find a byte-aligned, byte-length buffer */
 585 
 586           s=tp->reference.symbol;
 587           if s->symbol.dimensioned & ^tp->reference.array_ref then
 588                     do;
 589                                         /* array-element case is special */
 590                     a=s->symbol.array;
 591                     q=a->array.element_size_bits;
 592                     cbs=a->array.c_element_size_bits;
 593                     if a->array.element_boundary=bit_ then no_byte="1"b;                  /* BIT boundary */
 594                     end;
 595 
 596           else      do;
 597                     if s -> node.type = symbol_node
 598                     then do;
 599                               q=s->symbol.bit_size;
 600                               cbs=s->symbol.c_bit_size;
 601                          end;
 602                     else do;            /* bug2164: s is sometimes a reference node */
 603                               q = s -> reference.symbol -> symbol.bit_size;
 604                               cbs = s -> reference.symbol -> symbol.c_bit_size;
 605                          end;
 606                     if s->symbol.boundary=bit_ then no_byte="1"b;     /* aligned on BIT boundary */
 607                     end;
 608 
 609 
 610           if s->symbol.bit then substr(job_additions,14,1)="1"b;      /*bit info needed for stringvalue */
 611 
 612 
 613           if q=null then
 614                     do;
 615                     if mod(cbs,9)^=0 then no_byte="1"b;
 616                      q=declare_constant$integer((cbs));
 617                     end;
 618           else      do;
 619                     q=copy_expression((q));
 620                     if ^ byte_buffer(s)
 621                          then no_byte = "1"b;
 622                     if s->symbol.refer_extents then
 623                     call refer_extent(q,(tp->reference.qualifier));
 624                     q = expression_semantics(b,cs,q,"0"b);
 625                     end;
 626 
 627 
 628 
 629           if s->symbol.varying then
 630                     do;
 631                      if tp->reference.array_ref then substr(job_additions,35,1)="1"b;     /* varying_array */
 632                      substr(job_additions,3,1)="1"b;                                      /* varying */
 633                      no_byte="0"b;                /* padding always exists in a varying string */
 634                     end;
 635 
 636                               /* NB: unless the file has env(stringvalue),
 637                                  the runtime will do addrel(p,-1) on variable_p
 638                                  if work.varying (3) is set; and will add 36 to
 639                                  variable_bitlen if work.varying is set UNLESS
 640                                  work.varying_array (35) is also set.  */
 641 
 642           if no_byte then substr(job_additions,34,1)="1"b;  /* probable non-byte-buffer */
 643           call assign_ps(q,ps_var_bitlen,"int",null);                 /* variable_bitlen */
 644 
 645 set_variable_p:
 646           PS_offset=ps_var_p;
 647           goto set_addr;                          /* variable_p */
 648 
 649 action(22):                                                                               /* keyto */
 650           s=tp->reference.symbol;
 651           if ^s->symbol.char then goto err464;
 652           call propagate_bit(s,set_bit);
 653 
 654           vs=create_statement(assignment_statement,cs,null,(cs->statement.prefix));
 655           vs->statement.generated,vs->statement.processed="1"b;
 656           q=create_operator(assign,2);
 657           q->operator.operand(1)=tp;
 658 
 659 
 660           r=b->block.plio_ps->list.element(50);
 661           if r=null then r=io_semantics_util$keys(b);
 662           r=copy_expression((r));
 663 
 664           r->reference.c_length=0;      /* rule for varying string on RHS */
 665           q->operator.operand(2)=r;
 666           vs->statement.root=operator_semantics(b,cs,q,"0"b);
 667 
 668                     /* i.e., key=PS|48->defined,aligned,char(256) varying */
 669           goto end_loop2;
 670 
 671 
 672 
 673 action(28):                                                                               /* else for lock */
 674           t->operator.operand(1)=declare_temporary(bit_type,36,0,null);
 675                     /* code generator will call lock and then
 676                        assign PS|31 to this temp. */
 677 
 678           goto end_loop2;
 679 
 680 action(20):                                                                               /* locate */
 681           call alloc_semantics$init_only(locate_set,cs,(locate_var->reference.symbol));
 682 
 683 
 684 action(14):                                                                               /* lock */
 685 action(15):                                                                               /* unlock */
 686 action(16):                                                                               /* read */
 687 action(17):                                                                               /* write */
 688 action(18):                                                                               /* rewrite */
 689 action(19):                                                                               /* delete */
 690           if ss->statement.root=tt then
 691                     do;
 692                     ss->statement.statement_type=null_statement;
 693                     ss->statement.root=null;
 694                     end;
 695                               /* takes care of all RECIO except lock_file with ELSE */
 696 
 697           if  substr(job,22,1) /* KEYTO */ then
 698                     do;
 699                     opcode_temp=record_io;
 700                     goto keyto_join;
 701                     end;
 702 
 703           end_of_join=create_operator(record_io,1);
 704 
 705           goto end_loop2;
 706 
 707 action(2):                                                                                /* string option */
 708           r=tp;
 709           if substr(job,7,1) then
 710                     do;       /* get */
 711                     r,tp=convert(tp,char_type);
 712                     if tp->node.type=operator_node then r=tp->operator.operand(1);
 713                     s=r->reference.symbol;
 714                     end;
 715           else      do;       /* put */
 716                     if r->node.type ^= reference_node then goto err466;
 717                     s=r->reference.symbol;
 718                     if ^s->symbol.char then if ^s->symbol.picture then goto err466;
 719                     call propagate_bit(s,set_bit);
 720                     end;
 721 
 722           if b->block.plio_ffsb=null then call io_semantics_util$make_ffsb(b);
 723 
 724           if r->reference.varying_ref then
 725                     do;
 726                     substr(job_additions,3,1)="1"b;         /* set the varying bit */
 727                     q=s->symbol.dcl_size;
 728                     if q=null then q=declare_constant$integer((s->symbol.c_dcl_size));
 729                     else      do;
 730                               q=copy_expression((q));
 731                               if s->symbol.refer_extents then call refer_extent(q,(r->reference.qualifier));
 732                               q = expression_semantics(b,cs,q,"0"b);
 733                               end;
 734                     end;
 735           else      do;
 736                     q=r->reference.length;
 737                     if q=null then q=declare_constant$integer((r->reference.c_length));
 738                     else q=copy_expression((q));
 739                     end;
 740 
 741           call assign_ps(q,ps_number,"aok",null); /* ps|ps_number = (max)length */
 742           r=tp;
 743           tp=b->block.plio_ffsb->symbol.reference;
 744           call assign_ps(r,6,"adr",tp); /* ffsb|6 = addr(string expression)  */
 745           PS_offset=ps_source;
 746           goto set_addr;                /* ps|16 = addr(ffsb)  */
 747 
 748 action(4):                                                                                /* data */
 749           pl1_stat_$generate_symtab="1"b;         /* generate SOME of the s.t.  */
 750           if substr(job,7,1)
 751                then go to end_loop2;    /* get */
 752 
 753           if b->block.plio_ssl=null then call io_semantics_util$make_ssl(b);
 754 
 755           goto end_loop2;
 756 
 757 
 758 
 759 action(5):                                                                                /* edit */
 760 
 761           if b->block.plio_fa=null then call io_semantics_util$make_fa(b);
 762           goto end_loop2;
 763 
 764 action(7):                                                                                /* get */
 765 action(8):                                                                                /* put */
 766 
 767           vs=create_statement((cs->statement.statement_type),(ns->statement.back),null,(cs->statement.prefix));
 768           vs->statement.generated,vs->statement.processed="1"b;
 769 
 770           cs->statement.statement_type=null_statement;
 771           cs->statement.root=null;      /* place holder only */
 772 
 773           vs->statement.root=t;         /* will generate the terminate call */
 774           t->operator.op_code=terminate_trans;
 775           opcode_temp=stream_prep;
 776 
 777 keyto_join:
 778           /* of all the recio statements, read with keyto needs a null-statement
 779              for abnormal return since the assignment to the keyto variable
 780              follows the recio operator.  Changes must also be made in the CG
 781              and in pl1_operators, not to mention in PLIO.  version-2. (7-74)  */
 782 
 783 
 784           vs=create_statement(null_statement,(ns->statement.back),null,(cs->statement.prefix));
 785                                         /* creates a null-statement for abnormal returns;
 786                                            principally for the get and put statements
 787                                            but also (7-74) for recio with keyto  */
 788           vs->statement.generated,vs->statement.processed="1"b;
 789           r=create_label(b,null,by_compiler);
 790           r->label.statement=vs;
 791           vs->statement.labels=create_list(2);
 792           vs->statement.labels->list.element(2)=r;          /* return label */
 793 
 794           end_of_join=create_operator(opcode_temp,2);
 795           end_of_join->operator.operand(2)=r;     /* ab ret label */
 796           goto end_loop2;
 797 
 798 action(34):                                                                               /* OPEN */
 799           if b->block.plio_fab2=null then call io_semantics_util$make_fab2(b);
 800           r=b->block.plio_fab2->symbol.reference;
 801 
 802           if tp->node.type=token_node then fab2template.bits=bit(substr(tp->token.string,1,36),36);
 803           else fab2template.bits=tp->reference.symbol->symbol.initial->bb36;
 804           fab2template.bits=fab2template.bits | "001"b;     /* signifying the title168 changes */
 805           fab2template.name=" ";
 806           fab2template.ls,
 807           fab2template.ps,
 808           fab2template.bs=0;
 809           fab2template.title168p = null;
 810 
 811           tp=t->operator.operand(4);    /* pagesize */
 812           if tp^=null then call assign_ps(tp,10,"int",r);
 813 
 814           tp=t->operator.operand(1);    /* linesize */
 815           if tp^=null then call assign_ps(tp,9,"int",r);
 816 
 817           tp=t->operator.operand(3);    /* title */
 818           if tp^=null then
 819                     do;
 820                     call assign_ps(tp,1,"c32",r);
 821                     if b->block.plio_ffsb=null then call io_semantics_util$make_ffsb(b);
 822                                                   /* we'll use fake-fsb to store title168 */
 823                     tp1=b->block.plio_ffsb->symbol.reference;
 824                     call assign_ps(tp1,12,"adr",r);         /* fab2.title168p=addr(ffsb) */
 825                     call assign_ps(share_expression(tp), 0,"ttl",tp1);          /* ffsb=char(title_exp,168) */
 826                     end;
 827 
 828                               /* the mechanism "convert$to_target" might
 829                                  have been used, and used to be used, to
 830                                  handle constant page_size,line_size, and
 831                                  title options:  but (at least for title,
 832                                  i.e., for strings) this procedure was capable
 833                                  of returning an assignment operator
 834                                  rather than a reference to a constant: thus
 835                                  I could not rely on its use as a mechanism
 836                                  for producing constant components for FAB2.
 837 
 838                                  [I had used: fab2template.X=convert$to_target(
 839                                   tp,declare_temporary(XX,...)->reference.symbol->
 840                                   symbol.initial->based.XX  ]
 841                                                                       */
 842           q=declare_constant$bit((fab2template_b));
 843           call assign_ps(q,0,"aok",r);
 844           if lal>1 then
 845                     do;
 846                     q=assign_list(1);
 847                     assign_list(1)=assign_list(lal);
 848                     assign_list(lal)=q;           /* assign whole fab2 template
 849                                                      before filling in the individual
 850                                                      variable fields */
 851                     end;
 852           call assign_ps(r,ps_special_list,"adr",null);     /* PS|special_list_p=addr(fab2) */
 853           goto exit;
 854 
 855                     /* Code Generator generates calls to runtime routines as follows:
 856                     a) record_io:       call plio2_recio_(psp)
 857                     b) open_file:       call plio2_$open_explicit_(psp)
 858                     c) close_file:      call plio2_$close1_(psp)
 859                     d) stream_prep:     call plio2_$get_prep_(psp)
 860                                         call plio2_$put_prep_(psp)
 861                     e)terminate_trans:  if GET statement then call plio2_$get_terminate_(psp)
 862                                         if PUT statement then call plio2_$put_terminate_(psp)
 863                     f) put_data_trans:
 864                     g) put_edit_trans:
 865                     h) put_list_trans:
 866                     i) get_edit_trans:
 867                     j) get_list_trans:
 868                     */
 869 /* ^L */
 870 set_addr:
 871           call assign_ps(tp,PS_offset,"adr",null);
 872           goto end_loop2;
 873 
 874 locate_prelim:
 875           tp=t->operator.operand(4);
 876           if tp->node.type ^= token_node then goto err461;
 877           if tp->token.type ^= identifier then goto err461;
 878 
 879           if substr(job,24,1) then
 880                     do;
 881                     tp=create_reference(tp);
 882                     tp->reference.qualifier=t->operator.operand(1);
 883                     t->operator.operand(1)=null;
 884                     end;
 885           else      substr(job,24,1)="1"b;
 886                     /* we place this directly in job rather than in job_additions, as it will be tested */
 887 
 888           string(context)="0"b;
 889           tp = expression_semantics(b,cs,tp,context);
 890           s=tp->reference.symbol;
 891           if s->symbol.controlled then goto err114;
 892           if ^s->symbol.based then goto err115;
 893           if s->symbol.level>=2 then goto err465;
 894           locate_set,q=tp->reference.qualifier;
 895           if q=null then goto err468;
 896           if q->node.type=operator_node then goto err468;
 897                               /* assignment of pointer must be to a pointer variable
 898                                  not to a pointer expression */
 899           if ^q->reference.symbol->symbol.ptr then goto err468;
 900 
 901           locate_var=tp;
 902           locate_size=s->symbol.bit_size;
 903           if locate_size=null then locate_size=declare_constant$integer((s->symbol.c_bit_size));
 904           else      do;
 905                     locate_size=copy_expression((locate_size));
 906                     /* "refer_extent" is not called: we wish to use the left-hand sides */
 907                     string(context)="0"b;
 908                     locate_size = expression_semantics(b,cs,locate_size,context);
 909                     end;
 910 
 911           call assign_ps(locate_size,ps_var_bitlen,"aok",null);
 912 
 913           t->operator.operand(4)=null;
 914           goto loop1;
 915 /* ^L */
 916 
 917 assign_ps:proc(x,PS_offset,dtype,tref);
 918           dcl (x,tref) ptr;
 919           dcl PS_offset fixed bin(15);
 920           dcl dtype char(3) aligned;    /* "int","ptr","c32","ttl","adr","spf","aok","cvr" */
 921           dcl (tp,ap) ptr;
 922           dcl outtype bit(36) aligned;
 923 
 924           /* This subroutine has as its principal use
 925              the assignment with coercive conversion
 926              of some element to PS.  It has been extended
 927              to do addressing and to assign to storage blocks
 928              other than PS */
 929 
 930           if lal<20 then lal=lal+1;
 931           else goto err467;
 932           assign_list(lal),tp=create_operator(assign,2);
 933 
 934      /* SET TARGET */
 935           if tref ^= null then                    /* not directed at PS */
 936                     do;
 937                     tp->operator.operand(1)=copy_expression((tref));
 938                     tp->operator.operand(1)->reference.c_offset=PS_offset;      /* ? */
 939                     end;
 940           else      do;
 941                     tp->operator.operand(1),ap=b->block.plio_ps->list.element(PS_offset+2);
 942                     if PS_offset=ps_key then if ap=null then tp->operator.operand(1)=
 943                                                   io_semantics_util$keys(b);
 944                     end;
 945 
 946      /* SET "RIGHT-HAND-SIDE"  */
 947           if dtype="aok" then tp->operator.operand(2)=x;
 948 
 949           else if dtype="adr" then                /* store addr(x)  */
 950                     do;
 951                     tp->operator.operand(2),ap=create_operator(addr_fun_bits,2);
 952                     ap->operator.operand(2)=x;
 953                     if x->node.type = reference_node
 954                     then if ^ x->reference.symbol->symbol.file        /* 1-79 */
 955                          then call propagate_bit((x->reference.symbol), aliasable_bit);   /* 6-73, 7-74 */
 956                     ap->operator.operand(1)=declare_temporary(pointer_type,0,0,null);
 957                     end;
 958 
 959           else      do;                 /* COERCIONS */
 960                     if dtype="int" then
 961                               outtype=integer_type;
 962                     else if dtype="ptr" then
 963                               outtype=pointer_type;
 964                     else      outtype=char_type;
 965 
 966                     if dtype="ttl" then strlen=168;
 967                     else strlen=32;
 968                     tp->operator.operand(2)=convert$to_target(x,
 969                     declare_temporary(outtype,strlen,0,null));
 970                     end;
 971 end assign_ps;
 972 /* ^L */
 973 
 974 io_semantics_util:proc;
 975 
 976 dcl       (b,s,t,tp,q,r) ptr;
 977 dcl       (i,n) fixed bin(15);
 978 dcl       bp ptr unaligned based;
 979 
 980 
 981 
 982 
 983 
 984 io_semantics_util$make_ps:entry(b);
 985           n=48;               /* Builds the ordinary PS, 48 words long */
 986           q=addr(b->block.plio_ps);
 987           goto make;
 988 
 989 end_make_ps:
 990           tp=create_list(50);
 991           tp->list.element(1)=s;
 992           q->bp=tp; /* block.plio_ps -> list; list(1)->ps_symbol */
 993 
 994           do i=2 to 22 by 2     ,    23 to 31 ;   /* We leave element 32 null as a flag to io_data_l_sem,     */
 995                                                   /* if a new_format is needed they will make one,along       */
 996                                                   /* with a defined ref. to protect it from the optimizer     */
 997                                                   /* messing around with it.                                  */
 998           tp->list.element(i),r=copy_expression(s->symbol.reference);
 999           r->reference.c_offset=i-2;
1000           r->reference.units=word_;
1001           end;
1002           return;
1003 
1004 io_semantics_util$keys:entry(b) returns(ptr);
1005                               /* Extends the size of PS to 48+65 words long
1006                                  to accomodate the new key, which is char256varying.
1007                                  Also sets list.element(50)=ref to defined char256varying
1008                                  whose qualifier is PS|48  */
1009 
1010           t=b->block.plio_ps->list.element(1);
1011           t->symbol.c_word_size,
1012           t->symbol.c_dcl_size=113;
1013           t->symbol.c_bit_size=113*bits_per_word; /* 113=48+65, 65=length of c-256-var, KEY as of 73-12-6 */
1014 
1015                     s=create_symbol(null,null,by_compiler);
1016                     s->symbol.char,
1017                     s->symbol.varying,            /* key is c256var 73-12-6 */
1018                     s->symbol.aligned,
1019                     s->symbol.overlayed,
1020                     s->symbol.aliasable,                    /* 6-73 */
1021                     s->symbol.defined="1"b;
1022                     s->symbol.dcl_size=create_token("256",dec_integer);
1023                     /* s->symbol.initial=create_token("1",dec_integer); */
1024                     /* s->symbol.position="1"b; */
1025 
1026                     call declare(s);
1027 
1028           r=s->symbol.reference;
1029           r->reference.units=word_;
1030           r->reference.c_offset=49;
1031                               /* c_offset addresses first data-word, not length-word !! */
1032           r->reference.c_length=256;              /* must =0 if on R.H.S.  */
1033           r->reference.qualifier=copy_expression(t->symbol.reference);
1034 
1035           b->block.plio_ps->list.element(50)=r;
1036           return(r);
1037 
1038 
1039 io_semantics_util$make_fa:entry(b);
1040           n=122;
1041           q=addr(b->block.plio_fa);
1042           goto make;
1043 
1044 io_semantics_util$make_ffsb:entry(b);
1045           n=42;
1046                                         /* 32 are needed for the original use,
1047                                            viz., the "fake fsb" used for string option.
1048                                            But 42 are needed for the newer use (6-30-72)
1049                                            for the title168.  */
1050           q=addr(b->block.plio_ffsb);
1051           goto make;
1052 
1053 io_semantics_util$make_ssl:entry(b);
1054           n=1;      /* WILL BE RESET AT SEMANT TIME TO LENGTH OF LONGEST SSL */
1055           q=addr(b->block.plio_ssl);
1056           goto make;
1057 
1058 io_semantics_util$make_fab2:entry(b);
1059           n=14;
1060           q=addr(b->block.plio_fab2);
1061           goto make;
1062 
1063 make:
1064           if q->bp ^=null then return;                      /* this is a mild error. */
1065 
1066           q->bp,s=create_symbol(b,(null),by_compiler);
1067 
1068           s->symbol.storage_block,
1069           s->symbol.auto,
1070           s->symbol.allocate,
1071           s->symbol.internal="1"b;
1072 
1073           s->symbol.boundary=mod2_;
1074           s->symbol.c_word_size,
1075           s->symbol.c_dcl_size=n;
1076           s->symbol.c_bit_size=n*bits_per_word;
1077 
1078           if n=48 then goto end_make_ps;
1079           return;
1080 end io_semantics_util;
1081 
1082 /*^L*/
1083 byte_buffer:        proc(sym) reducible returns(bit(1) aligned);
1084 
1085 /* determines if a symbol is eligible to be a buffer whose length is an integral number of bytes */
1086 
1087 dcl       (adam,s,sym) ptr;
1088 
1089           s, adam = sym;
1090 
1091 loop:     do while(s -> symbol.structure);
1092                s = s -> symbol.son;
1093                end;
1094 
1095           if ^ s -> symbol.char
1096           then if ^ s -> symbol.picture
1097                then if ^ s -> symbol.decimal
1098                     then if s -> symbol.bit | s -> symbol.packed
1099                          then return("0"b);
1100 
1101           if s = adam
1102                then return("1"b);
1103 
1104           do while(s -> symbol.brother = null);
1105                s = s -> symbol.father;
1106                if s = adam
1107                     then return("1"b);
1108                end;
1109 
1110           s = s -> symbol.brother;
1111           go to loop;
1112 end byte_buffer;
1113 ^L
1114 /* include files */
1115 
1116 %include semant;
1117 /* ^L */
1118 %include nodes;
1119 %include block;
1120 %include list;
1121 %include operator;
1122 %include op_codes;
1123 %include semantic_bits;
1124 %include symbol;
1125 %include array;
1126 %include system;
1127 %include reference;
1128 %include token;
1129 %include token_types;
1130 %include statement;
1131 %include statement_types;
1132 %include declare_type;
1133 %include label;
1134 %include ps_map;
1135 %include symbol_bits;
1136 %include boundary;
1137 %include mask;
1138 %include decoded_token_types;
1139      end /* io_semantics */;