COMPILATION LISTING OF SEGMENT rmdb_create_descriptor Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Multics Op. - System M Compiled on: 10/16/86 1349.8 mst Thu Options: optimize map 1 2 3 /* * * * * * * * * * * * * * * * * * * * * * * */ 4 /* */ 5 /* COMPILED OUTPUT OF SEGMENT rmdb_create_descriptor.rd */ 6 /* Compiled by: reduction_compiler, Version 2.5 of Oct 21, 1985 */ 7 /* Compiled on: 10/16/86 1349.8 mst Thu */ 8 /* */ 9 /* * * * * * * * * * * * * * * * * * * * * * * */ 10 11 /* *********************************************************** 12* * * 13* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 14* * * 15* * Copyright (C) 1975 by Massachusetts Institute of * 16* * Technology and Honeywell Information Systems Inc. * 17* * * 18* *********************************************************** */ 19 20 /* HISTORY COMMENTS: 21* 1) change(85-12-03,JBlair), approve(85-12-03,MCR7311), 22* audit(86-09-24,Gilcrease), install(86-10-16,MR12.0-1187): 23* Modified from the new_call subroutine. Added complex numbers. Enforce 24* max string length. 25* END HISTORY COMMENTS */ 26 27 /*++ 28*PUSH DOWN LANGUAGE \ 29*BEGIN / / / error \ 30* 31*attr / dimension / DELETE LEX(2) / error \ 32*3 / dim / DELETE LEX(2) / error \ 33*4 / aligned / set (aligned, 1) DELETE / attr \ 34*5 / unaligned / set (aligned, 0) DELETE / attr \ 35*6 / unal / set (aligned, 0) DELETE / attr \ 36*7 / fixed / set (type, 1) DELETE / attr \ 37*8 / float / set (type, 3) DELETE / attr \ 38*9 / binary / set (base, 1) DELETE / attr \ 39*10 / bin / set (base, 1) DELETE / attr \ 40*11 / decimal / set (base, 2) DELETE / attr \ 41*12 / dec / set (base, 2) DELETE / attr \ 42*13 / real / set (mode, 1) DELETE / attr \ 43*14 / complex / set (mode, 2) DELETE / attr \ 44*15 / cplx / set (mode, 2) DELETE / attr \ 45*16 / precision / DELETE LEX(2) / prec \ 46*17 / prec / DELETE LEX(2) / prec \ 47*18 / ( / LEX(2) / prec \ 48*19 / bit / set (type, 19) DELETE / length \ 49*20 / character / set (type, 21) DELETE / length \ 50*21 / char / set (type, 21) DELETE / length \ 51*22 / varying / set (varying, 1) DELETE / attr \ 52*23 / var / set (varying, 1) DELETE / attr \ 53*24 / nonvarying / set (varying, 0) DELETE / attr \ 54*25 / signed / set (signed, 1) DELETE / attr \ 55*26 / uns / set (signed, 0) DELETE / attr \ 56*27 / unsigned / set (signed, 0) DELETE / attr \ 57*28 / / [code = mrds_error_$bad_attribute] / RETURN \ 58*29 / / / RETURN \ 59* 60* 61*error / ) / [code = error_table_$improper_data_format] / RETURN \ 62* 63* 64*prec_err / / [code = mrds_error_$bad_precision] / RETURN \ 65* 66*length / ( / LEX(2) / length_ \ 67*33 / / / attr \ 68*length_ / ( ) / LEX(-1) set(LENGTH, token.Nvalue) DELETE(-1,+1) / attr \ 69*35 / ( * ) / set(LENGTH, 16777215) DELETE(-2,0) / attr \ 70*36 / / / error \ 71* 72*prec / ( ) / LEX(-1) set(SIZE, token.Nvalue) DELETE(-1,+1) / attr \ 73*38 / ( , / LEX(2) / \ 74*39 / ( , ) 75* / LEX(-3) set(SIZE, token.Nvalue) 76* LEX(+2) set(scale,token.Nvalue) DELETE(-3,+1) / attr \ 77*40 / / / prec_err \ 78* ++*/ 79 80 rmdb_create_descriptor: procedure (Astring, Ptemp, Pdesc, code); 81 /* This internal procedure converts an argument */ 82 /* declaration (PL/I style) into an argument */ 83 /* descriptor. */ 84 dcl Astring char(*), /* argument declaration. (In) */ 85 Ptemp ptr, /* ptr to a translator_temp_ segment in which */ 86 /* allocations can be made. (In) */ 87 /* ptr to created argument descriptor. (Out) */ 88 Saddr bit(1) aligned, /* on if addr(declaration) was given. (Out) */ 89 code fixed bin(35); /* error code diagnosing any errors. (Out) */ 90 91 dcl 1 D aligned, 92 2 type fixed bin, 93 2 Spacked bit(1), 94 2 Ndims fixed bin, 95 2 size fixed bin(24), 96 2 scale fixed bin(24), 97 Lit fixed bin, 98 Lstr fixed bin, 99 Ndims fixed bin, 100 Nparens fixed bin, 101 Pit ptr, 102 Pstr ptr, 103 (aligned, address, signed, 104 varying) fixed bin(1), 105 (base, mode) fixed bin(2), 106 i fixed bin, 107 (LENGTH, SIZE) fixed bin(24), 108 scale fixed bin(8), 109 type fixed bin(6); 110 111 dcl it char(Lit) based (Pit), 112 str char(Lstr) based (Pstr), 113 str_array (Lstr) char(1) based (Pstr), 114 value bit(36) aligned based (Pdesc); 115 dcl Pdesc ptr; 116 117 118 dcl (addr, bit, divide, length, null, search, size, string) 119 builtin; 120 121 dcl set generic ( set1 when (fixed bin(1),*), 122 set2 when (fixed bin(2),*), 123 set6 when (fixed bin(6),*), 124 set8 when (fixed bin(8),*), 125 set24 when (fixed bin(24),*)); 126 127 dcl (mrds_error_$bad_array_bounds, 128 mrds_error_$bad_attribute, 129 mrds_error_$bad_precision, 130 mrds_error_$inconsistent_attributes, 131 mrds_error_$invalid_string_length, 132 mrds_data_$max_string_size, 133 error_table_$improper_data_format, 134 error_table_$unbalanced_parentheses) 135 fixed bin(35) ext static; 136 137 Saddr = "0"b; 138 code = 0; /* clear error code. */ 139 Ptoken, Pthis_token = null; /* initialize semantic analysis variables. */ 140 Nparens = 0; /* initialize parenthesis depth count. */ 141 Pstr = addr(Astring); /* overlay PL/I argument declaration. */ 142 Lstr = length(Astring); 143 aligned = -1; 144 type = -1; 145 base = -1; 146 mode = -1; 147 signed = -1; 148 varying = -1; 149 address = -1; 150 Ndims = 0; 151 LENGTH = -1; 152 SIZE = -1; 153 scale = -129; 154 155 do while (Lstr > 0); /* parse declaration into tokens. */ 156 i = search (str, " _,():"); 157 if i = 0 then 158 i = Lstr + 1; 159 if i > 1 then do; 160 Pit = Pstr; 161 Lit = i-1; 162 call make_token (it); 163 if i <= Lstr then do; 164 Pstr = addr(str_array(i)); 165 Lstr = Lstr - (i-1); 166 end; 167 else Lstr = 0; 168 end; 169 if Lstr > 0 then do; 170 Pit = Pstr; 171 Lit = 1; 172 if it = "(" then Nparens = Nparens + 1; 173 else if it = ")" then Nparens = Nparens - 1; 174 if it = " " then; 175 else if it = "_" then; 176 else call make_token(it); 177 if Lstr > 1 then 178 Pstr = addr(str_array(2)); 179 Lstr = Lstr - 1; 180 end; 181 end; 182 if Nparens ^= 0 then do; 183 code = error_table_$unbalanced_parentheses; 184 return; 185 end; 186 call SEMANTIC_ANALYSIS(); 187 if code = -1 then do; 188 code = 0; 189 return; 190 end; 191 if code ^= 0 then return; 192 193 /* apply PL/I Lanuage Default Rules. */ 194 if type = -1 then /* default(^(character|bit|pointer|offset|area| */ 195 if base = -1 then /* label|entry|file|fixed|float|binary|decimal| */ 196 if mode = -1 then do; /* real|complex)) fixed binary real; */ 197 type = 1; 198 base = 1; 199 mode = 1; 200 end; 201 if type = -1 then do; 202 if mode ^= -1 then /* default((real|complex)&^float) fixed; */ 203 if type ^= 3 then type = 1; 204 if base ^= -1 then /* default((binary|decimal)&^float) fixed; */ 205 if type ^= 3 then type = 1; 206 end; 207 if (type = 1) | (type = 3) then /* default((fixed|float)&^complex) real; */ 208 if mode ^= 2 then mode = 1; 209 if (type = 1) | (type = 3) then /* default((fixed|float)&^decimal) binary; */ 210 if base ^= 2 then base = 1; 211 if type = 1 then /* default(fixed&binary&^precision) */ 212 if base = 1 then /* precison(17,0); */ 213 if SIZE = -1 then do; 214 SIZE = 17; 215 scale = 0; 216 end; 217 else if scale = -129 then 218 scale = 0; 219 if type = 1 then /* default(fixed&decimal&^precision) */ 220 if base = 2 then /* precision(7,0); */ 221 if SIZE = -1 then do; 222 SIZE = 7; 223 scale = 0; 224 end; 225 else if scale = -129 then 226 scale = 0; 227 if type = 3 then /* default(float&binary&^precision) */ 228 if base = 1 then /* precision(27); */ 229 if SIZE = -1 then SIZE = 27; 230 if type = 3 then /* default(float&decimal&^precision) */ 231 if base = 2 then /* precision(10); */ 232 if SIZE = -1 then SIZE = 10; 233 if type = 18 then /* default(character&^length) length(1024); */ 234 if LENGTH = -1 then LENGTH = 1024; 235 if (type = 19) | (type = 21) then do; /* default((character|bit)&^length) length(1); */ 236 if LENGTH = -1 then LENGTH = 1; 237 /* default((character|bit)&^varying) nonvarying; */ 238 if varying ^= 1 then varying = 0; 239 /* default((character|bit)&^aligned) unaligned; */ 240 if aligned ^= 1 then aligned = 0; 241 end; 242 if aligned ^= 0 then aligned = 1; /* default(^unaligned) aligned; */ 243 244 go to do(type); 245 246 do(1): /* it's a fixed number. */ 247 if base = 1 then do; /* a fixed binary number. */ 248 if SIZE > 35 then type = type + 1; /* a fixed binary long number. */ 249 if mode = 2 then type = type + 4; /* a complex fixed binary number. */ 250 if SIZE > 71 then go to error_oob; 251 if SIZE < 1 then go to error_oob; 252 if scale > +127 then go to error_oob; 253 if scale < -128 then go to error_oob; 254 end; 255 else /* if base = 2 then */ do; /* a fixed decimal number. */ 256 type = type + 8; 257 if mode = 2 then type = type + 2; /* a complex fixed decimal number. */ 258 if aligned = 0 then type = type + 34; /* 4-bit byte aligned. */ 259 if SIZE > 59 then go to error_oob; 260 if SIZE < 1 then go to error_oob; 261 if scale > +127 then go to error_oob; 262 if scale < -128 then go to error_oob; 263 end; 264 if varying ^= -1 then go to error; 265 if LENGTH ^= -1 then go to error; 266 if type < 3 & signed = 0 then 267 type = type + 32; 268 go to join; 269 270 do(3): /* it's a floating number. */ 271 if base = 1 then do; /* a float binary number. */ 272 if SIZE > 27 then type = type + 1; /* a float binary long number. */ 273 if mode = 2 then type = type + 4; /* a complex float binary number. */ 274 if SIZE > 63 then go to error_oob; 275 if SIZE < 1 then go to error_oob; 276 if scale = -129 then; 277 else go to error; 278 end; 279 else /* if base = 2 then */ do; /* a float decimal number. */ 280 type = type + 7; 281 if mode = 2 then type = type + 2; /* a complex float decimal number. */ 282 if aligned = 0 then type = type + 34; /* 4-bit byte aligned. */ 283 if SIZE > 59 then go to error_oob; 284 if SIZE < 1 then go to error_oob; 285 if scale = -129 then; 286 else go to error; 287 end; 288 if varying ^= -1 then go to error; 289 if LENGTH ^= -1 then go to error; 290 scale = 0; 291 go to join; 292 293 294 do(19): /* it's a bit string. */ 295 do(21): /* it's a character string. */ 296 if varying = 1 then do; /* a varying string. */ 297 type = type + 1; 298 if aligned ^= 1 then aligned = 1; 299 end; 300 if base ^= -1 then go to error; 301 if mode ^= -1 then go to error; 302 if scale ^= -129 then go to error; 303 if SIZE ^= -1 then go to error; 304 if LENGTH < 0 then go to error_oob; 305 if (type = 19 & divide (LENGTH+35, 36, 24, 0) > mrds_data_$max_string_size) | 306 (type = 21 & LENGTH > mrds_data_$max_string_size) 307 then do; 308 code = mrds_error_$invalid_string_length; 309 return; 310 end; 311 SIZE = LENGTH; 312 go to join; 313 314 join: 315 D.type = type; 316 D.Spacked = ^bit(aligned,1); 317 D.Ndims = 0; 318 D.size = SIZE; 319 D.scale = scale; 320 321 D.Ndims = Ndims; 322 call encode_descriptor (D.type, D.Spacked, D.Ndims, D.size, D.scale, value); 323 if address = 1 then Saddr = "1"b; 324 return; 325 326 error: code = mrds_error_$inconsistent_attributes; 327 return; 328 error_array: 329 code = mrds_error_$bad_array_bounds; 330 return; 331 error_oob: 332 code = mrds_error_$bad_precision; 333 return; 334 1 1 /* BEGINNING OF: translator_temp_alloc.incl.pl1 * * * * * * * * * * * * * * * * */ 1 2 1 3 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1 4 /* */ 1 5 /* N__a_m_e: translator_temp_alloc.incl.pl1 */ 1 6 /* */ 1 7 /* This include segment allocates space in a translator's temporary segment. It */ 1 8 /* contains a complete space allocation function 'allocate' which can be a quick PL/I */ 1 9 /* internal procedure in the program which includes this include segment. The temporary */ 1 10 /* segment should be one obtained by using the translator_temp_ subroutine. */ 1 11 /* */ 1 12 /* S__t_a_t_u_s */ 1 13 /* */ 1 14 /* 0) Created by: G. C. Dixon in January, 1975. */ 1 15 /* 1) Modified by: G. C. Dixon in February, 1981 - use limit area structure. */ 1 16 /* */ 1 17 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1 18 1 19 1 20 1 21 allocate: procedure (Parea, ANwords) returns (ptr); 1 22 1 23 dcl Parea ptr, /* ptr to the temporary segment. (In) */ 1 24 ANwords fixed bin; /* number of words to be allocated. (In) */ 1 25 1 26 dcl Nwords fixed bin, /* number of words to be allocated, rounded up */ 1 27 /* to a 0 mod 2 quantity. */ 1 28 P ptr, /* a temporary pointer. */ 1 29 code fixed bin(35), /* a status code. */ 1 30 (mod, null, ptr) builtin; 1 31 1 32 dcl 1 area based (Parea), 1 33 2 Pfirst_temp_seg ptr unal, /* ptr to first temp seg of a group. */ 1 34 2 Ofree fixed bin(35), /* offset of next free word in temp seg. */ 1 35 2 Lfree fixed bin(35); /* length of remaining free space in temp seg. */ 1 36 1 37 dcl translator_temp_$get_next_segment 1 38 entry (ptr, ptr, fixed bin(35)); 1 39 1 40 Nwords = ANwords + mod (ANwords, 2); /* round up word count to 0 + mod 2 quantity. */ 1 41 if Nwords > Lfree then do; /* handle area overflow. */ 1 42 call translator_temp_$get_next_segment (Parea, P, code); 1 43 if P = null then return (null); 1 44 Parea = P; 1 45 if Nwords > area.Lfree then return (null); 1 46 end; 1 47 P = ptr (Parea, area.Ofree); /* get pointer to next free word of area. */ 1 48 area.Ofree = area.Ofree + Nwords; /* increase offset of remaining free space. */ 1 49 area.Lfree = area.Lfree - Nwords; /* decrease length of remaining free space. */ 1 50 return (P); 1 51 1 52 end allocate; 1 53 1 54 /* END OF: translator_temp_alloc.incl.pl1 * * * * * * * * * * * * * * * * */ 335 336 337 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 338 339 340 make_token: proc (value); /* internal procedure to make a token descriptor. */ 341 342 dcl value char(*); /* value of the token. */ 343 dcl P ptr; /* ptr to newly-allocated token. */ 344 345 P = allocate (Ptemp, size(token)); 346 if Ptoken = null then do; 347 P->token.Plast = null; 348 Pthis_token = P; 349 Ptoken = P; 350 end; 351 else do; 352 token.Pnext = P; 353 P->token.Plast = Ptoken; 354 Ptoken = token.Pnext; 355 end; 356 token.Pnext = null; 357 token.Pvalue = addr(value); 358 token.Lvalue = length(value); 359 token.Nvalue = 0; 360 token.Pstmt = null; 361 token.Psemant = null; 362 string(token.S) = ""b; 363 364 end make_token; 365 366 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 367 368 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 369 370 371 set1: procedure (var1, value); /* if var hasn't been set1 yet, set1 it to value; */ 372 /* else complain. */ 373 dcl var1 fixed bin(1), 374 var2 fixed bin(2), 375 var6 fixed bin(6), 376 var8 fixed bin(8), 377 var24 fixed bin(24), 378 value fixed bin(35) unal; 379 380 if var1 ^= -1 then go to error; 381 var1 = value; 382 return; 383 384 385 set2: entry (var2, value); 386 387 if var2 ^= -1 then go to error; 388 var2 = value; 389 return; 390 391 392 393 set6: entry (var6, value); 394 395 if var6 ^= -1 then go to error; 396 var6 = value; 397 return; 398 399 set8: entry (var8, value); 400 401 if var8 ^= -129 then go to error; 402 var8 = value; 403 return; 404 405 406 set24: entry (var24, value); 407 408 if var24 ^= -1 then go to error; 409 var24 = value; 410 411 end set1; 412 413 414 encode_descriptor: procedure (type, packed, Ndims, size, scale, descriptor); 415 416 dcl type fixed bin, /* data type */ 417 packed bit(1) aligned, /* on if data packed*/ 418 Ndims fixed bin, /* dimension (data) */ 419 size fixed bin (24), /* size (data) */ 420 scale fixed bin (24), /* scale (data) */ 421 descriptor bit(36) aligned; /* descriptor (data)*/ 422 423 dcl 1 D based (addr (descriptor)) aligned, 424 (2 flag bit (1), 425 2 type bit (6), 426 2 packed bit (1), 427 2 Ndims bit (4), 428 2 size bit (24)) unaligned; 429 430 dcl (addr, bit, fixed, substr) builtin; 431 432 433 434 /* * * ** * * * * * * * * * * * * * * * * * * * * * * */ 435 436 437 D.flag = "1"b; /* new type desc. */ 438 D.type = bit (fixed (type, 6), 6); /* set type */ 439 D.packed = packed; /* set packed bit */ 440 go to set (type); 441 442 set( 1): /* real fixed bin short */ 443 set( 2): /* real fixed bin long */ 444 set( 3): /* real float bin short */ 445 set( 4): /* real float bin long */ 446 set( 5): /* complex fixed bin short */ 447 set( 6): /* complex fixed bin long */ 448 set( 7): /* complex float bin short */ 449 set( 8): /* complex float bin long */ 450 set( 9): /* real fixed decimal */ 451 set(10): /* real float decimal */ 452 set(11): /* complex fixed decimal */ 453 set(12): /* complex float decimal */ 454 set(33): /* real fixed binary short unsigned */ 455 set(34): /* real fixed binary long unsigned 456* */ 457 set(43): /* real fixed decimal 4-bit byte-aligned*/ 458 set(44): /* real float decimal 4-bit byte_aligned*/ 459 set(45): /* complex fixed dec 4-bit byte_aligned */ 460 set(46): /* complex float dec 4-bit byte_aligned */ 461 D.Ndims = bit (fixed (Ndims, 4), 4); 462 if scale < 0 then 463 substr (D.size, 1, 12) = bit (fixed (scale + 1000000000000b, 12), 12); 464 else 465 substr (D.size, 1, 12) = bit (fixed (scale, 12), 12); 466 substr (D.size, 13, 12) = bit (fixed (size, 12), 12); 467 return; 468 469 470 set(19): /* bit string */ 471 set(20): /* varying bit string */ 472 set(21): /* character string */ 473 set(22): /* varying character string */ 474 D.Ndims = bit (fixed (Ndims, 4), 4); 475 D.size = bit (fixed (size, 24), 24); 476 return; 477 478 end encode_descriptor; 479 480 481 dcl TRACING bit(1) aligned int static init("0"b); 482 483 2 1 /* START OF: rdc_start_.incl.pl1 * * * * * * */ 2 2 2 3 /* * * * * * * * * * * * * * * * * * * * * * * */ 2 4 /* */ 2 5 /* N__a_m_e: rdc_start_.incl.pl1 */ 2 6 /* */ 2 7 /* This include segment is used by compilers generated by the */ 2 8 /* reduction_compiler. Such compilers include a SEMANTIC_ANALYSIS */ 2 9 /* subroutine generated by the reduction_compiler. This subroutine */ 2 10 /* compares a chain of input tokens with token requirements */ 2 11 /* specified in reductions. This include segment declares the */ 2 12 /* structure of the input tokens (which are generated by lex_string_),*/ 2 13 /* defines the beginning of the SEMANTIC_ANALYSIS procedure, and */ 2 14 /* declares Pthis_token, a global pointer variable which points to */ 2 15 /* the "current" token being referenced by SEMANTIC_ANALYSIS. */ 2 16 /* */ 2 17 /* S__t_a_t_u_s */ 2 18 /* */ 2 19 /* 0) Created: April, 1974 by G. C. Dixon */ 2 20 /* */ 2 21 /* * * * * * * * * * * * * * * * * * * * * * * */ 2 22 2 23 dcl Pthis_token ptr; /* ptr to the "current" token being acted upon. */ 2 24 3 1 /* START OF: lex_descriptors_.incl.pl1 * * * * * * */ 3 2 3 3 /* * * * * * * * * * * * * * * * * * * * * * * */ 3 4 /* */ 3 5 /* Name: lex_descriptors_.incl.pl1 */ 3 6 /* */ 3 7 /* This include segment defines the structure of the token */ 3 8 /* descriptor, statement descriptor, and comment descriptor created */ 3 9 /* by the lex_string_ program. */ 3 10 /* */ 3 11 /* Status: */ 3 12 /* */ 3 13 /* 0) Created: Dec, 1973 by G. C. Dixon */ 3 14 /* */ 3 15 /* * * * * * * * * * * * * * * * * * * * * * * */ 3 16 3 17 3 18 3 19 3 20 dcl 3 21 1 comment aligned based (Pcomment), 3 22 /* descriptor for a comment. */ 3 23 2 group1 unaligned, 3 24 3 version fixed bin(17), /* comment descriptor version. */ 3 25 3 size fixed bin(17), /* comment descriptor size (in words). */ 3 26 2 Pnext ptr unal, /* ptr to next comment descriptor. */ 3 27 2 Plast ptr unal, /* ptr to last comment descriptor. */ 3 28 2 Pvalue ptr unal, /* ptr to comment. */ 3 29 2 Lvalue fixed bin(18), /* length of comment. */ 3 30 2 group2 unaligned, 3 31 3 line_no fixed bin(17), /* line no of line containing comment. */ 3 32 3 S, /* switches: */ 3 33 4 before_stmt bit(1), /* comment is before 1st token of stmt. */ 3 34 4 contiguous bit(1), /* no tokens between this and last comment. */ 3 35 4 pad bit(16), 3 36 comment_value char(comment.Lvalue) based (comment.Pvalue), 3 37 /* body of comment. */ 3 38 Pcomment ptr; /* ptr to comment descriptor. */ 3 39 3 40 dcl 3 41 1 stmt aligned based (Pstmt), 3 42 /* descriptor for a statement. */ 3 43 2 group1 unaligned, 3 44 3 version fixed bin(17), /* statement descriptor version. */ 3 45 3 size fixed bin(17), /* statement descriptor size (in words). */ 3 46 2 Pnext ptr unal, /* ptr to next statement descriptor. */ 3 47 2 Plast ptr unal, /* ptr to last statement descriptor. */ 3 48 2 Pvalue ptr unal, /* ptr to statement. */ 3 49 2 Lvalue fixed bin(18), /* length of statement. */ 3 50 2 Pfirst_token ptr unal, /* ptr to 1st token of statement. */ 3 51 2 Plast_token ptr unal, /* ptr to last token of statement. */ 3 52 2 Pcomments ptr unal, /* ptr to comments in statement. */ 3 53 2 Puser ptr unal, /* user-defined ptr. */ 3 54 2 group2 unaligned, 3 55 3 Ntokens fixed bin(17), /* number of tokens in statement. */ 3 56 3 line_no fixed bin(17), /* line no of line on which statement begins. */ 3 57 3 Istmt_in_line fixed bin(17), /* number of stmts in line containing this stmt. */ 3 58 /* (the number includes this stmt.) */ 3 59 3 semant_type fixed bin(17), /* semantic type of the statement. */ 3 60 3 S, /* switches: */ 3 61 4 error_in_stmt bit(1), /* stmt contains a syntactic error. */ 3 62 4 output_in_err_msg bit(1), /* stmt has been output in previous error message.*/ 3 63 4 pad bit(34), 3 64 stmt_value char(stmt.Lvalue) based (stmt.Pvalue), 3 65 /* text of the statement. */ 3 66 Pstmt ptr; /* ptr to a stmt descriptor. */ 3 67 3 68 dcl 3 69 1 token aligned based (Ptoken), 3 70 /* descriptor for a token. */ 3 71 2 group1 unaligned, 3 72 3 version fixed bin(17), /* token descriptor version. */ 3 73 3 size fixed bin(17), /* token descriptor size (in words). */ 3 74 2 Pnext ptr unal, /* ptr to next token descriptor. */ 3 75 2 Plast ptr unal, /* ptr to last token descriptor. */ 3 76 2 Pvalue ptr unal, /* ptr to token. */ 3 77 2 Lvalue fixed bin(18), /* length of token. */ 3 78 2 Pstmt ptr unal, /* ptr to descriptor of stmt containing token. */ 3 79 2 Psemant ptr unal, /* ptr to descriptor(s) of token's semantic value.*/ 3 80 2 group2 unaligned, 3 81 3 Itoken_in_stmt fixed bin(17), /* position of token within its statement. */ 3 82 3 line_no fixed bin(17), /* line number of the line containing the token. */ 3 83 3 Nvalue fixed bin(35), /* numeric value of decimal-integer tokens. */ 3 84 3 S, /* switches: */ 3 85 4 end_of_stmt bit(1), /* token is an end-of-stmt token. */ 3 86 4 quoted_string bit(1), /* token is a quoted string. */ 3 87 4 quotes_in_string bit(1), /* on if quote-close delimiters appear in quoted */ 3 88 /* string (as doubled quotes on input.) */ 3 89 4 quotes_doubled bit(1), /* on if quotes in the string are doubled after */ 3 90 /* string has been lexed into a token. */ 3 91 4 pad2 bit(32), 3 92 token_value char(token.Lvalue) based (token.Pvalue), 3 93 /* value of the token. */ 3 94 Ptoken ptr; /* ptr to a token descriptor. */ 3 95 3 96 /* END OF: lex_descriptors_.incl.pl1 * * * * * * */ 2 25 2 26 2 27 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 2 28 2 29 2 30 SEMANTIC_ANALYSIS: procedure; /* procedure which analyzes the syntax and */ 2 31 /* semantics of the tokens in the input list. */ 2 32 2 33 dcl /* automatic variables */ 2 34 LTOKEN_REQD_VALUE fixed bin(18), /* length of a token requirement. */ 2 35 NRED fixed bin, /* number of the reduction tokens are being */ 2 36 /* compared to. */ 2 37 PRED ptr, /* ptr to the reduction tokens are being */ 2 38 /* compared to. */ 2 39 PTOKEN_REQD ptr, /* ptr to token requirement descriptor associated */ 2 40 /* with reduction tokens are being compared to. */ 2 41 PTOKEN_REQD_VALUE ptr, /* ptr to a token requirement. */ 2 42 STOKEN_FCN bit(1) aligned, /* return value from a relative syntax function. */ 2 43 CODE fixed bin(35), /* an error code. */ 2 44 I fixed bin, /* a do-group index. */ 2 45 NUMBER fixed bin(35); /* fixed binary representation of a decimal */ 2 46 /* number character string. */ 2 47 2 48 dcl /* based variables */ 2 49 1 RED aligned based (PRED), 2 50 /* descriptor for reduction tokens are being */ 2 51 /* compared to. */ 2 52 2 TOKEN_REQD unaligned, 2 53 3 IFIRST fixed bin(17) unal, /* index of first token requirement. */ 2 54 3 ILAST fixed bin(17) unal, /* index of last token requirement associated */ 2 55 /* with this reduction. */ 2 56 1 TOKEN_REQD aligned based (PTOKEN_REQD), 2 57 /* a token requirement descriptor. */ 2 58 2 FORM fixed bin(17) unal, /* form of the token requirement: */ 2 59 /* -1 = relative token requirement function; */ 2 60 /* TYPE = index of the particular token */ 2 61 /* function in the token_fcn array. */ 2 62 /* 0 = built-in token requirement function; */ 2 63 /* TYPE = as defined below. */ 2 64 /* >0 = absolute token requirement: */ 2 65 /* FORM = index(TOKEN_STRINGS,TOKEN_REQD); */ 2 66 /* TYPE = length(TOKEN_REQD); */ 2 67 2 TYPE fixed bin(17) unal, /* TYPE of built-in token requirement function: */ 2 68 /* 1 = compile test to see if input token */ 2 69 /* chain is exhausted (). */ 2 70 /* 2 = compile test for any token value */ 2 71 /* (). */ 2 72 /* 3 = compile test for a PL/I identifier */ 2 73 /* () of 32 or fewer characters. */ 2 74 /* 4 = compile test for token which is a */ 2 75 /* . */ 2 76 /* 5 = compile test for token which is a single */ 2 77 /* backspace character (). */ 2 78 /* 6 = compile test for a token which is a */ 2 79 /* . */ 2 80 2 81 1 TOKEN_REQD_STRING aligned based (PTOKEN_REQD), 2 82 /* overlay for an absolute token requirement */ 2 83 /* descriptor. */ 2 84 2 I fixed bin(17) unal, /* index into list of token strings of the */ 2 85 /* absolute token string assoc w/ descriptor. */ 2 86 2 L fixed bin(17) unal, /* length of the absolute token string. */ 2 87 TOKEN_REQD_VALUE char(LTOKEN_REQD_VALUE) based (PTOKEN_REQD_VALUE); 2 88 /* absolute token string which token is reqd */ 2 89 /* to match in order for tokens which are */ 2 90 /* "current" on the list to match the reduction. */ 2 91 2 92 dcl /* builtin functions */ 2 93 (addr, max, null, search, substr, verify) 2 94 builtin; 2 95 2 96 dcl /* entries */ 2 97 cv_dec_check_ entry (char(*), fixed bin(35)) returns (fixed bin(35)); 2 98 2 99 dcl /* static variables */ 2 100 BACKSPACE char(1) aligned int static init (""); 2 101 2 102 /* END OF: rdc_start_.incl.pl1 * * * * * * */ 484 485 486 dcl DIRECTION fixed bin init(-1); /* direction in which tokens compared. */ 487 488 489 dcl 1 REDUCTION (40) unaligned based (addr (REDUCTIONS)), 490 /* object reductions. */ 491 2 TOKEN_REQD, 492 3 IFIRST fixed bin(17), /* index of first required token. */ 493 3 ILAST fixed bin(17), /* index of last required token. */ 494 495 REDUCTIONS (80) fixed bin(17) unaligned internal static options(constant) initial ( 496 1, 1, /* 1/ */ 497 2, 2, /* 2/ dimension */ 498 3, 3, /* 3/ dim */ 499 4, 4, /* 4/ aligned */ 500 5, 5, /* 5/ unaligned */ 501 6, 6, /* 6/ unal */ 502 7, 7, /* 7/ fixed */ 503 8, 8, /* 8/ float */ 504 9, 9, /* 9/ binary */ 505 10, 10, /* 10/ bin */ 506 11, 11, /* 11/ decimal */ 507 12, 12, /* 12/ dec */ 508 13, 13, /* 13/ real */ 509 14, 14, /* 14/ complex */ 510 15, 15, /* 15/ cplx */ 511 16, 16, /* 16/ precision */ 512 17, 17, /* 17/ prec */ 513 18, 18, /* 18/ ( */ 514 19, 19, /* 19/ bit */ 515 20, 20, /* 20/ character */ 516 21, 21, /* 21/ char */ 517 22, 22, /* 22/ varying */ 518 23, 23, /* 23/ var */ 519 24, 24, /* 24/ nonvarying */ 520 25, 25, /* 25/ signed */ 521 26, 26, /* 26/ uns */ 522 27, 27, /* 27/ unsigned */ 523 28, 28, /* 28/ */ 524 1, 1, /* 29/ */ 525 30, 29, /* 30/ ) */ 526 30, 31, /* 31/ */ 527 18, 18, /* 32/ ( */ 528 30, 31, /* 33/ */ 529 33, 31, /* 34/ ( ) */ 530 36, 34, /* 35/ ( * ) */ 531 36, 37, /* 36/ */ 532 33, 31, /* 37/ ( ) */ 533 39, 37, /* 38/ ( , */ 534 44, 40, /* 39/ ( , ) */ 535 44, 45); /* 40/ */ 536 537 dcl 1 TOKEN_REQUIREMENT (44) unaligned based (addr (TOKEN_REQUIREMENTS)), 538 /* object token requirements. */ 539 2 FORM fixed bin(17), /* form of the token requirement: */ 540 /* -1 = relative token requirement function; */ 541 /* TYPE = index of the particular token */ 542 /* function in the token_fcn array. */ 543 /* 0 = built-in token requirement function; */ 544 /* TYPE = as defined below. */ 545 /* >0 = absolute token requirement: */ 546 /* FORM = index(TOKEN_STRINGS,TOKEN_REQD); */ 547 /* TYPE = length(TOKEN_REQD); */ 548 2 TYPE fixed bin(17) unal, /* type of the built-in token requirement */ 549 /* function: */ 550 /* 1 = compile test to see if input token */ 551 /* chain is exhausted (). */ 552 /* 2 = compile test for any token value */ 553 /* (). */ 554 /* 3 = compile test for a PL/I identifier */ 555 /* () of 32 or fewer characters. */ 556 /* 4 = compile test for token which is a */ 557 /* . */ 558 /* 5 = compile test for token which is a single */ 559 /* backspace character (). */ 560 /* 6 = compile test for a token which is a */ 561 /* . */ 562 563 TOKEN_REQUIREMENTS (88) fixed bin(17) unaligned internal static options(constant) initial ( 564 0, 1, 1, 9, 1, 3, 10, 7, 17, 9, 17, 4, 26, 5, 565 31, 5, 36, 6, 36, 3, 42, 7, 42, 3, 49, 4, 53, 7, 566 60, 4, 64, 9, 64, 4, 73, 1, 74, 3, 77, 9, 77, 4, 567 86, 7, 86, 3, 93, 10, 103, 6, 109, 3, 112, 8, 0, 2, 568 120, 1, 0, 2, 73, 1, 0, 4, 120, 1, 73, 1, 121, 1, 569 120, 1, 73, 1, 0, 4, 122, 1, 73, 1, 0, 4, 122, 1, 570 0, 4, 120, 1); 571 572 573 dcl TOKEN_STRINGS char(122) aligned based (addr (TOKEN_STRING_ARRAYS)), 574 /* object token values. */ 575 TOKEN_STRING_ARRAYS (2) char(100) aligned internal static options(constant) initial ( 576 "dimensionalignedunalignedfixedfloatbinarydecimalrealcomplexcplxprecision(bitcharactervaryingnonvaryi", 577 "ngsignedunsunsigned)*,"); 578 579 /* START OF: rdc_end_.incl.pl1 * * * * * * * * * * * * * * * * */ 4 2 4 3 4 4 /****^ HISTORY COMMENTS: 4 5* 1) change(86-02-14,GWMay), approve(), audit(), install(): 4 6* old history comments: 4 7* 0) Created: April, 1974 by G. C. Dixon 4 8* 1) Modified: Feb, 1975 by G. C. Dixon 4 9* a) support for Version 2.0 of reduction_compiler. 4 10* 2) Modified: Feb, 1981 by G. C. Dixon 4 11* a) support for Version 2.2 of reduction_compiler 4 12* 3) Modified: Aug, 1983 by G. C. Dixon - support for Version 2.3 of 4 13* reductions command. 4 14* 2) change(86-03-04,GDixon), approve(86-03-04,MCR7362), audit(86-03-17,GWMay), 4 15* install(86-03-17,MR12.0-1032): 4 16* Changed how the PUSH DOWN LANGUAGE (SPDL) definition of is 4 17* implemented to avoid references through a null pointer. The two 4 18* accepted uses are: 4 19* 4 20* / / ... / ... \ 4 21* A 4 22* | 4 23* Pthis_token (points to top of push down stack) 4 24* 4 25* which checks to see if the push down stack is totally exhausted (ie, 4 26* Ptoken = null); and: 4 27* 4 28* / SPEC1 ... SPECN / ... / ... \ 4 29* A 4 30* | 4 31* Pthis_token (points to top of push down stack) 4 32* 4 33* which checks to see whether SPECN is topmost on the push down stack 4 34* AND is the final token in the input list. 4 35* END HISTORY COMMENTS */ 4 36 4 37 4 38 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4 39 /* */ 4 40 /* NAME: rdc_end_.incl.pl1 */ 4 41 /* */ 4 42 /* This include segment is used by compilers generated by the reduction_compiler. */ 4 43 /* Such compilers include a SEMANTIC_ANALYSIS subroutine generated by the */ 4 44 /* reduction_compiler. This subroutine compares a chain of input tokens with token */ 4 45 /* requirements specified in reductions. The code in this include segment performs the */ 4 46 /* actual comparisons. This code is the middle part of the SEMANTIC_ANALYSIS procedure. */ 4 47 /* */ 4 48 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4 49 4 50 TRACING = TRACING; /* Kludge to prevent pl1 from making TRACING */ 4 51 /* options(constant) because it is never set. */ 4 52 NRED = 1; 4 53 go to RD_TEST_REDUCTION; 4 54 4 55 RD_NEXT_REDUCTION: 4 56 NRED = NRED + 1; 4 57 4 58 RD_TEST_REDUCTION: 4 59 PRED = addr(REDUCTION(NRED)); 4 60 Ptoken = Pthis_token; 4 61 4 62 do I = RED.TOKEN_REQD.IFIRST to RED.TOKEN_REQD.ILAST by DIRECTION; 4 63 PTOKEN_REQD = addr(TOKEN_REQUIREMENT(I)); 4 64 if Ptoken = null then do; 4 65 if TOKEN_REQD.FORM = 0 then /* No more tokens. Only matches spec. */ 4 66 if TOKEN_REQD.TYPE = 1 then 4 67 go to RD_TEST_TOKEN(1); 4 68 go to RD_NEXT_REDUCTION; 4 69 end; 4 70 if TOKEN_REQD.FORM = 0 then do; /* built-in syntax function. */ 4 71 go to RD_TEST_TOKEN(TOKEN_REQD.TYPE); 4 72 4 73 RD_TEST_TOKEN(1): if SPDL then /* */ 4 74 /* In push-down-language, there are 2 */ 4 75 /* interpretations of . */ 4 76 if RED.TOKEN_REQD.IFIRST = RED.TOKEN_REQD.ILAST & 4 77 Ptoken = null then /* When is only spec, the spec asks */ 4 78 go to RD_MATCH_NO_TOKEN; /* "Is push down stack empty (all input gone)?" */ 4 79 else if RED.TOKEN_REQD.IFIRST^= RED.TOKEN_REQD.ILAST & 4 80 RED.TOKEN_REQD.IFIRST = I & 4 81 token.Pnext = null then /* For SPEC1 ... SPECN , the spec asks */ 4 82 go to RD_MATCH_NO_TOKEN; /* "Are the topmost tokens on stack SPEC1 - SPECN,*/ 4 83 /* and is SPECN the final input token?" */ 4 84 else go to RD_NEXT_REDUCTION; /* Those are the only two defs allowed in push */ 4 85 /* down language mode for . */ 4 86 else if Ptoken = null then 4 87 go to RD_MATCH_NO_TOKEN; 4 88 go to RD_NEXT_REDUCTION; 4 89 4 90 RD_TEST_TOKEN(2): go to RD_MATCH; /* */ 4 91 4 92 RD_TEST_TOKEN(3): if token.Lvalue > 0 & /* */ 4 93 token.Lvalue <= 32 & ^token.S.quoted_string then 4 94 if search(substr(token_value,1,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") 4 95 > 0 then 4 96 if verify(token_value,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_$") 4 97 = 0 then 4 98 go to RD_MATCH; 4 99 go to RD_NEXT_REDUCTION; 4 100 4 101 RD_TEST_TOKEN(4): /* */ 4 102 if token.Nvalue ^= 0 then /* token already determined to be a number. */ 4 103 go to RD_MATCH; 4 104 if token.S.quoted_string then 4 105 go to RD_NEXT_REDUCTION; 4 106 NUMBER = cv_dec_check_ (token_value, CODE); 4 107 if CODE = 0 then do; 4 108 token.Nvalue = NUMBER; 4 109 go to RD_MATCH; 4 110 end; 4 111 go to RD_NEXT_REDUCTION; 4 112 4 113 RD_TEST_TOKEN(5): if token.Lvalue = 1 then /* */ 4 114 if token_value = BACKSPACE & ^token.S.quoted_string then 4 115 go to RD_MATCH; 4 116 go to RD_NEXT_REDUCTION; 4 117 4 118 RD_TEST_TOKEN(6): if token.S.quoted_string then /* */ 4 119 go to RD_MATCH; 4 120 go to RD_NEXT_REDUCTION; 4 121 end; 4 122 4 123 else if TOKEN_REQD.FORM > 0 then do; /* absolute syntax specification. */ 4 124 if token.S.quoted_string then 4 125 go to RD_NEXT_REDUCTION; 4 126 PTOKEN_REQD_VALUE = addr(substr(TOKEN_STRINGS,TOKEN_REQD_STRING.I)); 4 127 LTOKEN_REQD_VALUE = TOKEN_REQD_STRING.L; 4 128 if token_value = TOKEN_REQD_VALUE then 4 129 go to RD_MATCH; 4 130 go to RD_NEXT_REDUCTION; 4 131 end; 4 132 4 133 /* END OF: rdc_end_.incl.pl1 * * * * * * * * * * * * * * * * */ 579 580 581 RD_MATCH: Ptoken = token.Plast; 582 RD_MATCH_NO_TOKEN: 583 end; 584 Ptoken = Pthis_token; 585 go to RD_ACTION(NRED); 586 587 588 RD_ACTION(1): /* / */ 589 NRED = 30; 590 go to RD_TEST_REDUCTION; /* / error \ */ 591 592 RD_ACTION(2): /* / */ 593 call DELETE ( 0, 0 ); 594 call LEX ( 2 ); 595 NRED = 30; 596 go to RD_TEST_REDUCTION; /* / error \ */ 597 598 RD_ACTION(3): /* / */ 599 call DELETE ( 0, 0 ); 600 call LEX ( 2 ); 601 NRED = 30; 602 go to RD_TEST_REDUCTION; /* / error \ */ 603 604 RD_ACTION(4): /* / */ 605 call set ( aligned, 1 ); 606 call DELETE ( 0, 0 ); 607 NRED = 2; 608 go to RD_TEST_REDUCTION; /* / attr \ */ 609 610 RD_ACTION(5): /* / */ 611 call set ( aligned, 0 ); 612 call DELETE ( 0, 0 ); 613 NRED = 2; 614 go to RD_TEST_REDUCTION; /* / attr \ */ 615 616 RD_ACTION(6): /* / */ 617 call set ( aligned, 0 ); 618 call DELETE ( 0, 0 ); 619 NRED = 2; 620 go to RD_TEST_REDUCTION; /* / attr \ */ 621 622 RD_ACTION(7): /* / */ 623 call set ( type, 1 ); 624 call DELETE ( 0, 0 ); 625 NRED = 2; 626 go to RD_TEST_REDUCTION; /* / attr \ */ 627 628 RD_ACTION(8): /* / */ 629 call set ( type, 3 ); 630 call DELETE ( 0, 0 ); 631 NRED = 2; 632 go to RD_TEST_REDUCTION; /* / attr \ */ 633 634 RD_ACTION(9): /* / */ 635 call set ( base, 1 ); 636 call DELETE ( 0, 0 ); 637 NRED = 2; 638 go to RD_TEST_REDUCTION; /* / attr \ */ 639 640 RD_ACTION(10): /* / */ 641 call set ( base, 1 ); 642 call DELETE ( 0, 0 ); 643 NRED = 2; 644 go to RD_TEST_REDUCTION; /* / attr \ */ 645 646 RD_ACTION(11): /* / */ 647 call set ( base, 2 ); 648 call DELETE ( 0, 0 ); 649 NRED = 2; 650 go to RD_TEST_REDUCTION; /* / attr \ */ 651 652 RD_ACTION(12): /* / */ 653 call set ( base, 2 ); 654 call DELETE ( 0, 0 ); 655 NRED = 2; 656 go to RD_TEST_REDUCTION; /* / attr \ */ 657 658 RD_ACTION(13): /* / */ 659 call set ( mode, 1 ); 660 call DELETE ( 0, 0 ); 661 NRED = 2; 662 go to RD_TEST_REDUCTION; /* / attr \ */ 663 664 RD_ACTION(14): /* / */ 665 call set ( mode, 2 ); 666 call DELETE ( 0, 0 ); 667 NRED = 2; 668 go to RD_TEST_REDUCTION; /* / attr \ */ 669 670 RD_ACTION(15): /* / */ 671 call set ( mode, 2 ); 672 call DELETE ( 0, 0 ); 673 NRED = 2; 674 go to RD_TEST_REDUCTION; /* / attr \ */ 675 676 RD_ACTION(16): /* / */ 677 call DELETE ( 0, 0 ); 678 call LEX ( 2 ); 679 NRED = 37; 680 go to RD_TEST_REDUCTION; /* / prec \ */ 681 682 RD_ACTION(17): /* / */ 683 call DELETE ( 0, 0 ); 684 call LEX ( 2 ); 685 NRED = 37; 686 go to RD_TEST_REDUCTION; /* / prec \ */ 687 688 RD_ACTION(18): /* / */ 689 call LEX ( 2 ); 690 NRED = 37; 691 go to RD_TEST_REDUCTION; /* / prec \ */ 692 693 RD_ACTION(19): /* / */ 694 call set ( type, 19 ); 695 call DELETE ( 0, 0 ); 696 NRED = 32; 697 go to RD_TEST_REDUCTION; /* / length \ */ 698 699 RD_ACTION(20): /* / */ 700 call set ( type, 21 ); 701 call DELETE ( 0, 0 ); 702 NRED = 32; 703 go to RD_TEST_REDUCTION; /* / length \ */ 704 705 RD_ACTION(21): /* / */ 706 call set ( type, 21 ); 707 call DELETE ( 0, 0 ); 708 NRED = 32; 709 go to RD_TEST_REDUCTION; /* / length \ */ 710 711 RD_ACTION(22): /* / */ 712 call set ( varying, 1 ); 713 call DELETE ( 0, 0 ); 714 NRED = 2; 715 go to RD_TEST_REDUCTION; /* / attr \ */ 716 717 RD_ACTION(23): /* / */ 718 call set ( varying, 1 ); 719 call DELETE ( 0, 0 ); 720 NRED = 2; 721 go to RD_TEST_REDUCTION; /* / attr \ */ 722 723 RD_ACTION(24): /* / */ 724 call set ( varying, 0 ); 725 call DELETE ( 0, 0 ); 726 NRED = 2; 727 go to RD_TEST_REDUCTION; /* / attr \ */ 728 729 RD_ACTION(25): /* / */ 730 call set ( signed, 1 ); 731 call DELETE ( 0, 0 ); 732 NRED = 2; 733 go to RD_TEST_REDUCTION; /* / attr \ */ 734 735 RD_ACTION(26): /* / */ 736 call set ( signed, 0 ); 737 call DELETE ( 0, 0 ); 738 NRED = 2; 739 go to RD_TEST_REDUCTION; /* / attr \ */ 740 741 RD_ACTION(27): /* / */ 742 call set ( signed, 0 ); 743 call DELETE ( 0, 0 ); 744 NRED = 2; 745 go to RD_TEST_REDUCTION; /* / attr \ */ 746 747 RD_ACTION(28): /* / */ 748 code = mrds_error_$bad_attribute; 749 return; /* / RETURN \ */ 750 751 RD_ACTION(29): /* / */ 752 return; /* / RETURN \ */ 753 754 RD_ACTION(30): /* / */ 755 code = error_table_$improper_data_format; 756 return; /* / RETURN \ */ 757 758 RD_ACTION(31): /* / */ 759 code = mrds_error_$bad_precision; 760 return; /* / RETURN \ */ 761 762 RD_ACTION(32): /* / */ 763 call LEX ( 2 ); 764 NRED = 34; 765 go to RD_TEST_REDUCTION; /* / length_ \ */ 766 767 RD_ACTION(33): /* / */ 768 NRED = 2; 769 go to RD_TEST_REDUCTION; /* / attr \ */ 770 771 RD_ACTION(34): /* / */ 772 call LEX ( -1 ); 773 call set ( LENGTH, token.Nvalue ); 774 call DELETE ( -1, +1 ); 775 NRED = 2; 776 go to RD_TEST_REDUCTION; /* / attr \ */ 777 778 RD_ACTION(35): /* / */ 779 call set ( LENGTH, 16777215 ); 780 call DELETE ( -2, 0 ); 781 NRED = 2; 782 go to RD_TEST_REDUCTION; /* / attr \ */ 783 784 RD_ACTION(36): /* / */ 785 NRED = 30; 786 go to RD_TEST_REDUCTION; /* / error \ */ 787 788 RD_ACTION(37): /* / */ 789 call LEX ( -1 ); 790 call set ( SIZE, token.Nvalue ); 791 call DELETE ( -1, +1 ); 792 NRED = 2; 793 go to RD_TEST_REDUCTION; /* / attr \ */ 794 795 RD_ACTION(38): /* / */ 796 call LEX ( 2 ); 797 go to RD_NEXT_REDUCTION; /* / \ */ 798 799 RD_ACTION(39): /* / */ 800 call LEX ( -3 ); 801 call set ( SIZE, token.Nvalue ); 802 call LEX ( +2 ); 803 call set ( scale, token.Nvalue ); 804 call DELETE ( -3, +1 ); 805 NRED = 2; 806 go to RD_TEST_REDUCTION; /* / attr \ */ 807 808 RD_ACTION(40): /* / */ 809 NRED = 31; 810 go to RD_TEST_REDUCTION; /* / prec_err \ */ 811 812 813 end SEMANTIC_ANALYSIS; 814 815 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 816 817 dcl SPDL bit(1) aligned init ("1"b); 818 /* on: This compiler parses a PUSH DOWN LANGUAGE. */ 819 820 /* START OF: rdc_lex_.incl.pl1 * * * * * * * * * * * * * * * * */ 5 2 5 3 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 5 4 /* */ 5 5 /* N__a_m_e: rdc_lex_.incl.pl1 */ 5 6 /* */ 5 7 /* This include segment is used by compilers generated by the reduction_compiler. */ 5 8 /* It contains the LEX subroutine which is used to manipulate the pointer to the */ 5 9 /* "current" token, Pthis_token. */ 5 10 /* */ 5 11 /* E__n_t_r_y: LEX */ 5 12 /* */ 5 13 /* This entry makes the |_nth|-next (or -preceding) token the "current" token, where */ 5 14 /* _n is its positive (or negative) input argument. */ 5 15 /* */ 5 16 /* U__s_a_g_e */ 5 17 /* */ 5 18 /* call LEX(n); */ 5 19 /* */ 5 20 /* 1) n is the number of the token to be made the "current" token, relative to the */ 5 21 /* token identified by Pthis_token (the present "current" token). If n is */ 5 22 /* positive, the nth token following the "current" token made "current". If n */ 5 23 /* is negative, the nth token preceding the "current" token is made "current". */ 5 24 /* */ 5 25 /* S__t_a_t_u_s */ 5 26 /* */ 5 27 /* 0) Created by: G. C. Dixon in February, 1975 */ 5 28 /* */ 5 29 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 5 30 5 31 LEX: procedure (n); 5 32 5 33 dcl n fixed bin, 5 34 i fixed bin; 5 35 5 36 Ptoken = Pthis_token; /* do everything relative to "current" token. */ 5 37 if Ptoken = null then return; /* can't lex if token list exhausted. */ 5 38 if n >= 0 then do; /* new "current" token will follow present one. */ 5 39 do i = 1 to n while (token.Pnext ^= null); /* find new "current" token, taking care not to */ 5 40 Ptoken = token.Pnext; /* run off end of token list. */ 5 41 end; 5 42 if ^SPDL then if i <= n then Ptoken = null; /* if not in 'PUSH DOWN LANGUAGE' mode, allow */ 5 43 /* running off end of token list. */ 5 44 end; 5 45 else /* new "current" token precedes present one. */ 5 46 do i = -1 to n by -1 while (token.Plast ^= null); 5 47 Ptoken = token.Plast; 5 48 end; 5 49 Pthis_token = Ptoken; /* simple wasn't it. */ 5 50 5 51 end LEX; 5 52 5 53 /* END OF: rdc_lex_.incl.pl1 * * * * * * * * * * * * * * * * */ 820 821 822 /* START OF: rdc_delete_.incl.pl1 * * * * * * * * * * * * * * * * */ 6 2 6 3 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6 4 /* */ 6 5 /* N__a_m_e: rdc_delete_.incl.pl1 */ 6 6 /* */ 6 7 /* This include segment is used by compilers generated by the reduction_compiler. */ 6 8 /* It defines a procedure which the compilers can use to delete tokens from their list of */ 6 9 /* input tokens. */ 6 10 /* */ 6 11 /* E__n_t_r_y: DELETE */ 6 12 /* */ 6 13 /* DELETE removes the input tokens identified by the starting and ending number */ 6 14 /* arguments from the list of input tokens. */ 6 15 /* */ 6 16 /* U__s_a_g_e */ 6 17 /* */ 6 18 /* call DELETE (start, end); */ 6 19 /* */ 6 20 /* 1) start is the number relative to the token identified by Pthis_token of the first */ 6 21 /* token to be removed from the list. (In) */ 6 22 /* 2) end is the number relative to the token identified by Pthis_token of the last */ 6 23 /* token to be removed from the list. (In) */ 6 24 /* */ 6 25 /* N__o_t_e_s */ 6 26 /* */ 6 27 /* The token identified by Pthis_token is regarded as token number 0. Tokens */ 6 28 /* which precede it have negative numbers, and those which follow have positive numbers. */ 6 29 /* */ 6 30 /* If the token identified by Pthis_token is one of those which are deleted, then */ 6 31 /* the first token in the list following those which have been deleted will be identified */ 6 32 /* by Pthis_token. If in 'PUSH DOWN LANGUAGE' mode and there are no tokens following */ 6 33 /* those which have been deleted, then the first token preceding those which have been */ 6 34 /* deleted will be indentified by Pthis_token. */ 6 35 /* */ 6 36 /* Note that DELETE(0,0) in 'PUSH DOWN LANGUAGE' mode has the effect of popping the */ 6 37 /* token off the top of the stack, and pushing a new token onto the stack in its place. */ 6 38 /* */ 6 39 /* S__t_a_t_u_s */ 6 40 /* */ 6 41 /* 0) Created by: G. C. Dixon in February, 1975. */ 6 42 /* */ 6 43 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6 44 6 45 6 46 DELETE: procedure (Astart, Aend); 6 47 6 48 dcl (Astart, Aend) fixed bin; 6 49 6 50 dcl (start, end) fixed bin; /* copies of our input arguments. */ 6 51 6 52 if Pthis_token = null then return; /* If input list already exhausted, cannot delete.*/ 6 53 if Astart > Aend then do; /* reverse input args if backwards. */ 6 54 start = Aend; 6 55 end = Astart; 6 56 end; 6 57 else do; 6 58 start = Astart; 6 59 end = Aend; 6 60 end; 6 61 Ptoken = Pthis_token; /* make sure these pointers are the same. */ 6 62 6 63 if start > 0 then call delete_positive (start, end); 6 64 /* deleted tokens all follow Pthis_token. */ 6 65 else if end < 0 then call delete_negative (start, end); 6 66 /* deleted tokens all precede Pthis_token. */ 6 67 else do; /* deleted tokens include Pthis_token. */ 6 68 if start < 0 then call delete_negative (start, -1); 6 69 /* first, delete those which precede Pthis_token. */ 6 70 if end > 0 then call delete_positive (1, end); 6 71 /* then, delete those which follow Pthis_token. */ 6 72 if token.Pnext = null then /* if no more tokens follow Pthis_token, */ 6 73 if SPDL then /* and in 'PUSH DOWN LANGUAGE' mode, */ 6 74 if token.Plast = null then /* and no more tokens precede Pthis_token, */ 6 75 Ptoken = null; /* then all tokens have been deleted. */ 6 76 else do; 6 77 Ptoken = token.Plast; /* else still tokens on stack. 2nd top of stack*/ 6 78 token.Pnext = null; /* becomes top, and old top is deleted. */ 6 79 end; 6 80 else Ptoken = null; /* not in 'PUSH DOWN LANGUAGE' mode; remaining */ 6 81 /* tokens have been deleted. */ 6 82 else do; /* if there is a following token, make it be */ 6 83 Ptoken = token.Pnext; /* identified by Pthis_token, and delete the */ 6 84 call delete_negative (-1, -1); /* old Pthis_token. */ 6 85 end; 6 86 Pthis_token = Ptoken; 6 87 end; 6 88 return; 6 89 6 90 6 91 delete_positive: procedure (start, end); /* This entry deletes tokens following Pthis_token*/ 6 92 6 93 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6 94 /* */ 6 95 /* The procedure below handles deletion of tokens which precede and follow Pthis_token */ 6 96 /* in the same way by mapping the starting and ending token numbers into an inner and */ 6 97 /* outer token number, as shown below. */ 6 98 /* */ 6 99 /* NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ -> NZ */ 6 100 /* A| */ 6 101 /* | */ 6 102 /* A| A| Pthis_token A| A| */ 6 103 /* | | | | */ 6 104 /* start end start end */ 6 105 /* outer inner inner outer */ 6 106 /* */ 6 107 /* This mapping allows preceding and following tokens to be deleted in the same way. */ 6 108 /* */ 6 109 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6 110 6 111 6 112 dcl (start, end) fixed bin; 6 113 6 114 dcl 1 token based, /* overlay for token converting token.Pnext/last */ 6 115 2 pad fixed bin, /* to a 2-element pointer array. */ 6 116 2 P (1:2) ptr unaligned, 6 117 (Pinner, Pouter) ptr, /* pointers to inner/outer tokens. */ 6 118 ( inner, outer) fixed bin, /* #s of inner/outer tokens (wrt Pthis_token) */ 6 119 ( in, out ) fixed bin, /* elements of token.P for next inner/outer token */ 6 120 direction fixed bin, /* increment added to inner # to reach outer #. */ 6 121 i fixed bin; /* a do-group index. */ 6 122 inner = start; outer = end; 6 123 in = 2; out = 1; 6 124 direction = +1; 6 125 6 126 go to common; 6 127 6 128 delete_negative: entry (start, end); /* This entry deletes tokens preceding Pthis_token*/ 6 129 6 130 inner = end; outer = start; 6 131 in = 1; out = 2; 6 132 direction = -1; 6 133 6 134 common: Pinner = Ptoken; /* start at Pthis_token. */ 6 135 do i = direction to inner by direction while (Pinner ^= null); 6 136 Pinner = Pinner -> token.P(out); /* work out from Pthis_token until inner token is */ 6 137 end; /* found. */ 6 138 if Pinner ^= null then do; /* if inner token doesn't exist, nothing to delete*/ 6 139 Pouter = Pinner; /* starting at inner token, work out to outer one.*/ 6 140 do i = inner+direction to outer by direction while (Pouter ^= null); 6 141 Pouter = Pouter -> token.P(out); 6 142 end; 6 143 if Pouter = null then /* if outer token not found, delete all tokens */ 6 144 /* from inner one to outer-most. */ 6 145 Pinner -> token.P(in) -> token.P(out) = null; 6 146 else do; /* otherwise, delete inner to outer token. */ 6 147 Pinner -> token.P(in) -> token.P(out) = Pouter -> token.P(out); 6 148 if Pouter -> token.P(out) ^= null then 6 149 Pouter -> token.P(out) -> token.P(in) = Pinner -> token.P(in); 6 150 end; 6 151 end; 6 152 6 153 end delete_positive; 6 154 6 155 end DELETE; 6 156 6 157 /* END OF: rdc_delete_.incl.pl1 * * * * * * * * * * * * * * * * */ 822 823 824 end rmdb_create_descriptor; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/16/86 1349.8 rmdb_create_descriptor.pl1 >special_ldd>install>MR12.0-1187>rmdb_create_descriptor.pl1 335 1 07/22/81 2045.0 translator_temp_alloc.incl.pl1 >ldd>include>translator_temp_alloc.incl.pl1 484 2 04/18/75 1242.4 rdc_start_.incl.pl1 >ldd>include>rdc_start_.incl.pl1 2-25 3 04/18/75 1242.4 lex_descriptors_.incl.pl1 >ldd>include>lex_descriptors_.incl.pl1 579 4 03/17/86 1534.3 rdc_end_.incl.pl1 >ldd>include>rdc_end_.incl.pl1 820 5 04/18/75 1242.4 rdc_lex_.incl.pl1 >ldd>include>rdc_lex_.incl.pl1 822 6 04/18/75 1242.4 rdc_delete_.incl.pl1 >ldd>include>rdc_delete_.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. ANwords parameter fixed bin(17,0) dcl 1-23 ref 1-21 1-40 1-40 Aend parameter fixed bin(17,0) dcl 6-48 ref 6-46 6-53 6-54 6-59 Astart parameter fixed bin(17,0) dcl 6-48 ref 6-46 6-53 6-55 6-58 Astring parameter char unaligned dcl 84 set ref 80 141 142 BACKSPACE 004335 constant char(1) initial dcl 2-99 ref 4-113 CODE 000216 automatic fixed bin(35,0) dcl 2-33 set ref 4-106* 4-107 D 000101 automatic structure level 1 dcl 91 in procedure "rmdb_create_descriptor" D based structure level 1 dcl 423 in procedure "encode_descriptor" DIRECTION 000221 automatic fixed bin(17,0) initial dcl 486 set ref 4-62 486* FORM based fixed bin(17,0) level 2 packed unaligned dcl 2-48 ref 4-65 4-70 4-123 I 000217 automatic fixed bin(17,0) dcl 2-33 in procedure "SEMANTIC_ANALYSIS" set ref 4-62* 4-63 4-79* I based fixed bin(17,0) level 2 in structure "TOKEN_REQD_STRING" packed unaligned dcl 2-48 in procedure "SEMANTIC_ANALYSIS" ref 4-126 IFIRST based fixed bin(17,0) level 3 packed unaligned dcl 2-48 ref 4-62 4-73 4-79 4-79 ILAST 0(18) based fixed bin(17,0) level 3 packed unaligned dcl 2-48 ref 4-62 4-73 4-79 L 0(18) based fixed bin(17,0) level 2 packed unaligned dcl 2-48 ref 4-127 LENGTH 000125 automatic fixed bin(24,0) dcl 91 set ref 151* 233 233* 236 236* 265 289 304 305 305 311 773* 778* LTOKEN_REQD_VALUE 000206 automatic fixed bin(18,0) dcl 2-33 set ref 4-127* 4-128 Lfree 2 based fixed bin(35,0) level 2 dcl 1-32 set ref 1-41 1-45 1-49* 1-49 Lit 000106 automatic fixed bin(17,0) dcl 91 set ref 161* 162 162 171* 172 173 174 175 176 176 Lstr 000107 automatic fixed bin(17,0) dcl 91 set ref 142* 155 156 157 163 165* 165 167* 169 177 179* 179 Lvalue 4 based fixed bin(18,0) level 2 dcl 3-68 set ref 358* 4-92 4-92 4-92 4-92 4-106 4-106 4-113 4-113 4-128 NRED 000207 automatic fixed bin(17,0) dcl 2-33 set ref 4-52* 4-55* 4-55 4-58 585 588* 595* 601* 607* 613* 619* 625* 631* 637* 643* 649* 655* 661* 667* 673* 679* 685* 690* 696* 702* 708* 714* 720* 726* 732* 738* 744* 764* 767* 775* 781* 784* 792* 805* 808* NUMBER 000220 automatic fixed bin(35,0) dcl 2-33 set ref 4-106* 4-108 Ndims 0(08) based bit(4) level 2 in structure "D" packed unaligned dcl 423 in procedure "encode_descriptor" set ref 442* 470* Ndims parameter fixed bin(17,0) dcl 416 in procedure "encode_descriptor" ref 414 442 470 Ndims 000110 automatic fixed bin(17,0) dcl 91 in procedure "rmdb_create_descriptor" set ref 150* 321 Ndims 2 000101 automatic fixed bin(17,0) level 2 in structure "D" dcl 91 in procedure "rmdb_create_descriptor" set ref 317* 321* 322* Nparens 000111 automatic fixed bin(17,0) dcl 91 set ref 140* 172* 172 173* 173 182 Nvalue 10 based fixed bin(35,0) level 3 packed unaligned dcl 3-68 set ref 359* 4-101 4-108* 773* 790* 801* 803* Nwords 000146 automatic fixed bin(17,0) dcl 1-26 set ref 1-40* 1-41 1-45 1-48 1-49 Ofree 1 based fixed bin(35,0) level 2 dcl 1-32 set ref 1-47 1-48* 1-48 P 1 based pointer array level 2 in structure "token" packed unaligned dcl 6-114 in procedure "delete_positive" set ref 6-136 6-141 6-143* 6-143 6-147* 6-147 6-147 6-148 6-148* 6-148 6-148 P 000162 automatic pointer dcl 343 in procedure "make_token" set ref 345* 347 348 349 352 353 P 000150 automatic pointer dcl 1-26 in procedure "allocate" set ref 1-42* 1-43 1-44 1-47* 1-50 PRED 000210 automatic pointer dcl 2-33 set ref 4-58* 4-62 4-62 4-73 4-73 4-79 4-79 4-79 PTOKEN_REQD 000212 automatic pointer dcl 2-33 set ref 4-63* 4-65 4-65 4-70 4-71 4-123 4-126 4-127 PTOKEN_REQD_VALUE 000214 automatic pointer dcl 2-33 set ref 4-126* 4-128 Parea parameter pointer dcl 1-23 set ref 1-21 1-41 1-42* 1-44* 1-45 1-47 1-47 1-48 1-48 1-49 1-49 Pdesc parameter pointer dcl 115 ref 80 322 Pinner 000276 automatic pointer dcl 6-114 set ref 6-134* 6-135 6-136* 6-136 6-138 6-139 6-143 6-147 6-148 Pit 000112 automatic pointer dcl 91 set ref 160* 162 170* 172 173 174 175 176 Plast 2 based pointer level 2 packed unaligned dcl 3-68 set ref 347* 353* 581 5-45 5-47 6-72 6-77 Pnext 1 based pointer level 2 packed unaligned dcl 3-68 set ref 352* 354 356* 4-79 5-39 5-40 6-72 6-78* 6-83 Pouter 000300 automatic pointer dcl 6-114 set ref 6-139* 6-140 6-141* 6-141 6-143 6-147 6-148 6-148 Psemant 6 based pointer level 2 packed unaligned dcl 3-68 set ref 361* Pstmt 5 based pointer level 2 packed unaligned dcl 3-68 set ref 360* Pstr 000114 automatic pointer dcl 91 set ref 141* 156 160 164* 164 170 177* 177 Ptemp parameter pointer dcl 84 set ref 80 345* Pthis_token 000132 automatic pointer dcl 2-23 set ref 139* 348* 4-60 584 5-36 5-49* 6-52 6-61 6-86* Ptoken 000134 automatic pointer dcl 3-68 set ref 139* 345 345 346 349* 352 353 354* 354 356 357 358 359 360 361 362 4-60* 4-64 4-73 4-79 4-86 4-92 4-92 4-92 4-92 4-92 4-92 4-92 4-101 4-104 4-106 4-106 4-106 4-108 4-113 4-113 4-113 4-113 4-118 4-124 4-128 4-128 581* 581 584* 773 790 801 803 5-36* 5-37 5-39 5-40* 5-40 5-42* 5-45 5-47* 5-47 5-49 6-61* 6-72 6-72 6-72* 6-77* 6-77 6-78 6-80* 6-83* 6-83 6-86 6-134 Pvalue 3 based pointer level 2 packed unaligned dcl 3-68 set ref 357* 4-92 4-92 4-106 4-113 4-128 RED based structure level 1 dcl 2-48 REDUCTION based structure array level 1 packed unaligned dcl 489 set ref 4-58 REDUCTIONS 000317 constant fixed bin(17,0) initial array unaligned dcl 489 set ref 4-58 S 11 based structure level 3 packed unaligned dcl 3-68 set ref 362* SIZE 000126 automatic fixed bin(24,0) dcl 91 set ref 152* 211 214* 219 222* 227 227* 230 230* 248 250 251 259 260 272 274 275 283 284 303 311* 318 790* 801* SPDL 000136 automatic bit(1) initial dcl 817 set ref 817* 4-73 5-42 6-72 Saddr 000100 automatic bit(1) dcl 84 set ref 137* 323* Spacked 1 000101 automatic bit(1) level 2 dcl 91 set ref 316* 322* TOKEN_REQD based structure level 1 dcl 2-48 in procedure "SEMANTIC_ANALYSIS" TOKEN_REQD based structure level 2 in structure "RED" packed unaligned dcl 2-48 in procedure "SEMANTIC_ANALYSIS" TOKEN_REQD_STRING based structure level 1 dcl 2-48 TOKEN_REQD_VALUE based char unaligned dcl 2-48 ref 4-128 TOKEN_REQUIREMENT based structure array level 1 packed unaligned dcl 537 set ref 4-63 TOKEN_REQUIREMENTS 000243 constant fixed bin(17,0) initial array unaligned dcl 537 set ref 4-63 TOKEN_STRINGS based char(122) dcl 573 set ref 4-126 TOKEN_STRING_ARRAYS 000161 constant char(100) initial array dcl 573 set ref 4-126 TRACING 000010 internal static bit(1) initial dcl 481 set ref 4-50* 4-50 TYPE 0(18) based fixed bin(17,0) level 2 packed unaligned dcl 2-48 ref 4-65 4-71 addr builtin function dcl 118 in procedure "rmdb_create_descriptor" ref 141 164 177 357 addr builtin function dcl 2-92 in procedure "SEMANTIC_ANALYSIS" ref 4-58 4-58 4-63 4-63 4-126 4-126 addr builtin function dcl 430 in procedure "encode_descriptor" ref 437 438 439 442 462 464 466 470 475 address 000117 automatic fixed bin(1,0) dcl 91 set ref 149* 323 aligned 000116 automatic fixed bin(1,0) dcl 91 set ref 143* 240 240* 242 242* 258 282 298 298* 316 604* 610* 616* area based structure level 1 unaligned dcl 1-32 base 000122 automatic fixed bin(2,0) dcl 91 set ref 145* 194 198* 204 209 209* 211 219 227 230 246 270 300 634* 640* 646* 652* bit builtin function dcl 430 in procedure "encode_descriptor" ref 438 442 462 464 466 470 475 bit builtin function dcl 118 in procedure "rmdb_create_descriptor" ref 316 code 000152 automatic fixed bin(35,0) dcl 1-26 in procedure "allocate" set ref 1-42* code parameter fixed bin(35,0) dcl 84 in procedure "rmdb_create_descriptor" set ref 80 138* 183* 187 188* 191 308* 326* 328* 331* 747* 754* 758* cv_dec_check_ 000034 constant entry external dcl 2-96 ref 4-106 descriptor parameter bit(36) dcl 416 set ref 414 437 438 439 442 462 464 466 470 475 direction 000306 automatic fixed bin(17,0) dcl 6-114 set ref 6-124* 6-132* 6-135 6-135 6-140 6-140 divide builtin function dcl 118 ref 305 end parameter fixed bin(17,0) dcl 6-112 in procedure "delete_positive" ref 6-91 6-122 6-128 6-130 end 000267 automatic fixed bin(17,0) dcl 6-50 in procedure "DELETE" set ref 6-55* 6-59* 6-63* 6-65 6-65* 6-70 6-70* error_table_$improper_data_format 000026 external static fixed bin(35,0) dcl 127 ref 754 error_table_$unbalanced_parentheses 000030 external static fixed bin(35,0) dcl 127 ref 183 fixed builtin function dcl 430 ref 438 442 462 464 466 470 475 flag based bit(1) level 2 packed unaligned dcl 423 set ref 437* group2 7 based structure level 2 packed unaligned dcl 3-68 i 000254 automatic fixed bin(17,0) dcl 5-33 in procedure "LEX" set ref 5-39* 5-42 5-45* i 000307 automatic fixed bin(17,0) dcl 6-114 in procedure "delete_positive" set ref 6-135* 6-140* i 000124 automatic fixed bin(17,0) dcl 91 in procedure "rmdb_create_descriptor" set ref 156* 157 157* 159 161 163 164 165 in 000304 automatic fixed bin(17,0) dcl 6-114 set ref 6-123* 6-131* 6-143 6-147 6-148 6-148 inner 000302 automatic fixed bin(17,0) dcl 6-114 set ref 6-122* 6-130* 6-135 6-140 it based char unaligned dcl 111 set ref 162* 172 173 174 175 176* length builtin function dcl 118 ref 142 358 mod builtin function dcl 1-26 ref 1-40 mode 000123 automatic fixed bin(2,0) dcl 91 set ref 146* 194 199* 202 207 207* 249 257 273 281 301 658* 664* 670* mrds_data_$max_string_size 000024 external static fixed bin(35,0) dcl 127 ref 305 305 mrds_error_$bad_array_bounds 000012 external static fixed bin(35,0) dcl 127 ref 328 mrds_error_$bad_attribute 000014 external static fixed bin(35,0) dcl 127 ref 747 mrds_error_$bad_precision 000016 external static fixed bin(35,0) dcl 127 ref 331 758 mrds_error_$inconsistent_attributes 000020 external static fixed bin(35,0) dcl 127 ref 326 mrds_error_$invalid_string_length 000022 external static fixed bin(35,0) dcl 127 ref 308 n parameter fixed bin(17,0) dcl 5-33 ref 5-31 5-38 5-39 5-42 5-45 null builtin function dcl 1-26 in procedure "allocate" ref 1-43 1-43 1-45 null builtin function dcl 2-92 in procedure "SEMANTIC_ANALYSIS" ref 4-64 4-73 4-79 4-86 null builtin function dcl 118 in procedure "rmdb_create_descriptor" ref 139 346 347 356 360 361 5-37 5-39 5-42 5-45 6-52 6-72 6-72 6-72 6-78 6-80 6-135 6-138 6-140 6-143 6-143 6-148 out 000305 automatic fixed bin(17,0) dcl 6-114 set ref 6-123* 6-131* 6-136 6-141 6-143 6-147 6-147 6-148 6-148 outer 000303 automatic fixed bin(17,0) dcl 6-114 set ref 6-122* 6-130* 6-140 packed 0(07) based bit(1) level 2 in structure "D" packed unaligned dcl 423 in procedure "encode_descriptor" set ref 439* packed parameter bit(1) dcl 416 in procedure "encode_descriptor" ref 414 439 ptr builtin function dcl 1-26 ref 1-47 quoted_string 11(01) based bit(1) level 4 packed unaligned dcl 3-68 set ref 4-92 4-104 4-113 4-118 4-124 scale 4 000101 automatic fixed bin(24,0) level 2 in structure "D" dcl 91 in procedure "rmdb_create_descriptor" set ref 319* 322* scale 000127 automatic fixed bin(8,0) dcl 91 in procedure "rmdb_create_descriptor" set ref 153* 215* 217 217* 223* 225 225* 252 253 261 262 276 285 290* 302 319 803* scale parameter fixed bin(24,0) dcl 416 in procedure "encode_descriptor" ref 414 462 462 464 search builtin function dcl 118 in procedure "rmdb_create_descriptor" ref 156 search builtin function dcl 2-92 in procedure "SEMANTIC_ANALYSIS" ref 4-92 set generic function dcl 121 ref 604 610 616 622 628 634 640 646 652 658 664 670 693 699 705 711 717 723 729 735 741 773 778 790 801 803 signed 000120 automatic fixed bin(1,0) dcl 91 set ref 147* 266 729* 735* 741* size 3 000101 automatic fixed bin(24,0) level 2 in structure "D" dcl 91 in procedure "rmdb_create_descriptor" set ref 318* 322* size parameter fixed bin(24,0) dcl 416 in procedure "encode_descriptor" ref 414 466 475 size builtin function dcl 118 in procedure "rmdb_create_descriptor" ref 345 345 size 0(12) based bit(24) level 2 in structure "D" packed unaligned dcl 423 in procedure "encode_descriptor" set ref 462* 464* 466* 475* start parameter fixed bin(17,0) dcl 6-112 in procedure "delete_positive" ref 6-91 6-122 6-128 6-130 start 000266 automatic fixed bin(17,0) dcl 6-50 in procedure "DELETE" set ref 6-54* 6-58* 6-63 6-63* 6-65* 6-68 6-68* str based char unaligned dcl 111 ref 156 str_array based char(1) array unaligned dcl 111 set ref 164 177 string builtin function dcl 118 set ref 362* substr builtin function dcl 430 in procedure "encode_descriptor" set ref 462* 464* 466* substr builtin function dcl 2-92 in procedure "SEMANTIC_ANALYSIS" ref 4-92 4-126 token based structure level 1 unaligned dcl 6-114 in procedure "delete_positive" token based structure level 1 dcl 3-68 in procedure "rmdb_create_descriptor" set ref 345 345 token_value based char unaligned dcl 3-68 set ref 4-92 4-92 4-106* 4-113 4-128 translator_temp_$get_next_segment 000032 constant entry external dcl 1-37 ref 1-42 type 0(01) based bit(6) level 2 in structure "D" packed unaligned dcl 423 in procedure "encode_descriptor" set ref 438* type parameter fixed bin(17,0) dcl 416 in procedure "encode_descriptor" ref 414 438 440 type 000130 automatic fixed bin(6,0) dcl 91 in procedure "rmdb_create_descriptor" set ref 144* 194 197* 201 202 202* 204 204* 207 207 209 209 211 219 227 230 233 235 235 244 248* 248 249* 249 256* 256 257* 257 258* 258 266 266* 266 272* 272 273* 273 280* 280 281* 281 282* 282 297* 297 305 305 314 622* 628* 693* 699* 705* type 000101 automatic fixed bin(17,0) level 2 in structure "D" dcl 91 in procedure "rmdb_create_descriptor" set ref 314* 322* value parameter fixed bin(35,0) unaligned dcl 373 in procedure "set1" ref 371 381 385 388 393 396 399 402 406 409 value based bit(36) dcl 111 in procedure "rmdb_create_descriptor" set ref 322* value parameter char unaligned dcl 342 in procedure "make_token" set ref 340 357 358 var1 parameter fixed bin(1,0) dcl 373 set ref 371 380 381* var2 parameter fixed bin(2,0) dcl 373 set ref 385 387 388* var24 parameter fixed bin(24,0) dcl 373 set ref 406 408 409* var6 parameter fixed bin(6,0) dcl 373 set ref 393 395 396* var8 parameter fixed bin(8,0) dcl 373 set ref 399 401 402* varying 000121 automatic fixed bin(1,0) dcl 91 set ref 148* 238 238* 264 288 294 711* 717* 723* verify builtin function dcl 2-92 ref 4-92 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Pcomment automatic pointer dcl 3-20 Pstmt automatic pointer dcl 3-40 STOKEN_FCN automatic bit(1) dcl 2-33 comment based structure level 1 dcl 3-20 comment_value based char unaligned dcl 3-20 max builtin function dcl 2-92 stmt based structure level 1 dcl 3-40 stmt_value based char unaligned dcl 3-40 NAMES DECLARED BY EXPLICIT CONTEXT. DELETE 003257 constant entry internal dcl 6-46 ref 592 598 606 612 618 624 630 636 642 648 654 660 666 672 676 682 695 701 707 713 719 725 731 737 743 774 780 791 804 LEX 003171 constant entry internal dcl 5-31 ref 594 600 678 684 688 762 771 788 795 799 802 RD_ACTION 000111 constant label array(40) dcl 588 ref 585 RD_MATCH 002322 constant label dcl 581 ref 4-90 4-92 4-101 4-109 4-113 4-118 4-128 RD_MATCH_NO_TOKEN 002325 constant label dcl 582 ref 4-73 4-79 4-86 RD_NEXT_REDUCTION 002037 constant label dcl 4-55 ref 4-68 4-84 4-88 4-99 4-104 4-111 4-116 4-120 4-124 4-130 797 RD_TEST_REDUCTION 002040 constant label dcl 4-58 ref 4-53 590 596 602 608 614 620 626 632 638 644 650 656 662 668 674 680 686 691 697 703 709 715 721 727 733 739 745 765 769 776 782 786 793 806 810 RD_TEST_TOKEN 000103 constant label array(6) dcl 4-73 ref 4-65 4-71 SEMANTIC_ANALYSIS 002026 constant entry internal dcl 2-30 ref 186 allocate 001436 constant entry internal dcl 1-21 ref 345 common 003420 constant label dcl 6-134 ref 6-126 delete_negative 003403 constant entry internal dcl 6-128 ref 6-65 6-68 6-84 delete_positive 003367 constant entry internal dcl 6-91 ref 6-63 6-70 do 000000 constant label array(21) dcl 246 ref 244 encode_descriptor 001725 constant entry internal dcl 414 ref 322 error 001420 constant label dcl 326 ref 264 265 276 285 288 289 300 301 302 303 380 387 395 401 408 error_array 001425 constant label dcl 328 error_oob 001432 constant label dcl 331 ref 250 251 252 253 259 260 261 262 274 275 283 284 304 join 001352 constant label dcl 314 ref 268 291 312 make_token 001533 constant entry internal dcl 340 ref 162 176 rmdb_create_descriptor 000454 constant entry external dcl 80 set 000025 constant label array(46) dcl 442 ref 440 set1 001620 constant entry internal dcl 371 ref 604 610 616 711 717 723 729 735 741 set2 001635 constant entry internal dcl 385 ref 634 640 646 652 658 664 670 set24 001707 constant entry internal dcl 406 ref 773 778 790 801 set6 001653 constant entry internal dcl 393 ref 622 628 693 699 705 set8 001671 constant entry internal dcl 399 ref 803 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 4534 4572 4346 4544 Length 5106 4346 36 277 166 2 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME rmdb_create_descriptor 274 external procedure is an external procedure. allocate internal procedure shares stack frame of external procedure rmdb_create_descriptor. make_token internal procedure shares stack frame of external procedure rmdb_create_descriptor. set1 internal procedure shares stack frame of external procedure rmdb_create_descriptor. encode_descriptor internal procedure shares stack frame of external procedure rmdb_create_descriptor. SEMANTIC_ANALYSIS internal procedure shares stack frame of external procedure rmdb_create_descriptor. LEX internal procedure shares stack frame of external procedure rmdb_create_descriptor. DELETE internal procedure shares stack frame of external procedure rmdb_create_descriptor. delete_positive internal procedure shares stack frame of external procedure rmdb_create_descriptor. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 TRACING rmdb_create_descriptor STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME rmdb_create_descriptor 000100 Saddr rmdb_create_descriptor 000101 D rmdb_create_descriptor 000106 Lit rmdb_create_descriptor 000107 Lstr rmdb_create_descriptor 000110 Ndims rmdb_create_descriptor 000111 Nparens rmdb_create_descriptor 000112 Pit rmdb_create_descriptor 000114 Pstr rmdb_create_descriptor 000116 aligned rmdb_create_descriptor 000117 address rmdb_create_descriptor 000120 signed rmdb_create_descriptor 000121 varying rmdb_create_descriptor 000122 base rmdb_create_descriptor 000123 mode rmdb_create_descriptor 000124 i rmdb_create_descriptor 000125 LENGTH rmdb_create_descriptor 000126 SIZE rmdb_create_descriptor 000127 scale rmdb_create_descriptor 000130 type rmdb_create_descriptor 000132 Pthis_token rmdb_create_descriptor 000134 Ptoken rmdb_create_descriptor 000136 SPDL rmdb_create_descriptor 000146 Nwords allocate 000150 P allocate 000152 code allocate 000162 P make_token 000206 LTOKEN_REQD_VALUE SEMANTIC_ANALYSIS 000207 NRED SEMANTIC_ANALYSIS 000210 PRED SEMANTIC_ANALYSIS 000212 PTOKEN_REQD SEMANTIC_ANALYSIS 000214 PTOKEN_REQD_VALUE SEMANTIC_ANALYSIS 000216 CODE SEMANTIC_ANALYSIS 000217 I SEMANTIC_ANALYSIS 000220 NUMBER SEMANTIC_ANALYSIS 000221 DIRECTION SEMANTIC_ANALYSIS 000254 i LEX 000266 start DELETE 000267 end DELETE 000276 Pinner delete_positive 000300 Pouter delete_positive 000302 inner delete_positive 000303 outer delete_positive 000304 in delete_positive 000305 out delete_positive 000306 direction delete_positive 000307 i delete_positive THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as call_ext_out_desc call_ext_out return_mac mdfx1 ext_entry_desc THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cv_dec_check_ translator_temp_$get_next_segment THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$improper_data_format error_table_$unbalanced_parentheses mrds_data_$max_string_size mrds_error_$bad_array_bounds mrds_error_$bad_attribute mrds_error_$bad_precision mrds_error_$inconsistent_attributes mrds_error_$invalid_string_length LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 80 000447 817 000467 137 000471 138 000472 139 000474 140 000477 141 000500 142 000502 143 000503 144 000505 145 000507 146 000511 147 000512 148 000514 149 000515 150 000516 151 000517 152 000521 153 000522 155 000524 156 000526 157 000541 159 000545 160 000547 161 000550 162 000552 163 000564 164 000567 165 000574 166 000600 167 000601 169 000602 170 000604 171 000606 172 000610 173 000617 174 000625 175 000633 176 000640 177 000653 179 000662 181 000664 182 000665 183 000667 184 000673 186 000674 187 000675 188 000701 189 000702 191 000703 194 000705 197 000716 198 000720 199 000722 201 000723 202 000726 204 000736 207 000746 209 000764 211 000773 214 001004 215 001006 216 001007 217 001010 219 001014 222 001025 223 001027 224 001030 225 001031 227 001035 230 001050 233 001063 235 001073 236 001100 238 001105 240 001111 242 001115 244 001121 246 001123 248 001126 249 001132 250 001137 251 001142 252 001144 253 001147 254 001151 256 001152 257 001154 258 001161 259 001165 260 001170 261 001172 262 001175 264 001177 265 001202 266 001205 268 001214 270 001215 272 001220 273 001224 274 001231 275 001234 276 001236 278 001241 280 001242 281 001244 282 001251 283 001255 284 001260 285 001262 288 001265 289 001270 290 001273 291 001274 294 001275 297 001300 298 001301 300 001306 301 001311 302 001314 303 001317 304 001322 305 001324 308 001344 309 001346 311 001347 312 001351 314 001352 316 001354 317 001362 318 001363 319 001365 321 001367 322 001371 323 001412 324 001417 326 001420 327 001424 328 001425 330 001431 331 001432 333 001435 1 21 001436 1 40 001440 1 41 001446 1 42 001452 1 43 001465 1 44 001475 1 45 001500 1 47 001510 1 48 001517 1 49 001523 1 50 001531 340 001533 345 001544 346 001561 347 001565 348 001570 349 001571 350 001572 352 001573 353 001576 354 001577 356 001601 357 001604 358 001607 359 001611 360 001613 361 001615 362 001616 364 001617 371 001620 380 001622 381 001625 382 001634 385 001635 387 001637 388 001643 389 001652 393 001653 395 001655 396 001661 397 001670 399 001671 401 001673 402 001677 403 001706 406 001707 408 001711 409 001715 411 001724 414 001725 437 001727 438 001731 439 001741 440 001746 442 001752 462 001762 464 001774 466 002002 467 002007 470 002010 475 002020 476 002025 2 30 002026 486 002027 4 50 002031 4 52 002034 4 53 002036 4 55 002037 4 58 002040 4 60 002043 4 62 002045 4 63 002070 4 64 002073 4 65 002077 4 68 002107 4 70 002110 4 71 002114 4 73 002116 4 79 002135 4 84 002146 4 86 002147 4 88 002153 4 90 002154 4 92 002155 4 99 002211 4 101 002212 4 104 002215 4 106 002220 4 107 002244 4 108 002246 4 109 002251 4 111 002252 4 113 002253 4 116 002267 4 118 002270 4 120 002274 4 123 002275 4 124 002276 4 126 002302 4 127 002307 4 128 002313 4 130 002321 581 002322 582 002325 584 002330 585 002332 588 002334 590 002336 592 002337 594 002343 595 002347 596 002351 598 002352 600 002356 601 002362 602 002364 604 002365 606 002371 607 002375 608 002377 610 002400 612 002404 613 002410 614 002412 616 002413 618 002417 619 002423 620 002425 622 002426 624 002432 625 002436 626 002440 628 002441 630 002445 631 002451 632 002453 634 002454 636 002460 637 002464 638 002466 640 002467 642 002473 643 002477 644 002501 646 002502 648 002506 649 002512 650 002514 652 002515 654 002521 655 002525 656 002527 658 002530 660 002534 661 002540 662 002542 664 002543 666 002547 667 002553 668 002555 670 002556 672 002562 673 002566 674 002570 676 002571 678 002575 679 002601 680 002603 682 002604 684 002610 685 002614 686 002616 688 002617 690 002623 691 002625 693 002626 695 002632 696 002636 697 002640 699 002641 701 002645 702 002651 703 002653 705 002654 707 002660 708 002664 709 002666 711 002667 713 002673 714 002677 715 002701 717 002702 719 002706 720 002712 721 002714 723 002715 725 002721 726 002725 727 002727 729 002730 731 002734 732 002740 733 002742 735 002743 737 002747 738 002753 739 002755 741 002756 743 002762 744 002766 745 002770 747 002771 749 002775 751 002776 754 002777 756 003003 758 003004 760 003010 762 003011 764 003015 765 003017 767 003020 769 003022 771 003023 773 003027 774 003040 775 003046 776 003050 778 003051 780 003055 781 003062 782 003064 784 003065 786 003067 788 003070 790 003074 791 003105 792 003113 793 003115 795 003116 797 003122 799 003123 801 003127 802 003140 803 003144 804 003155 805 003163 806 003165 808 003166 810 003170 5 31 003171 5 36 003173 5 37 003175 5 38 003202 5 39 003204 5 40 003217 5 41 003221 5 42 003223 5 44 003233 5 45 003234 5 47 003247 5 48 003251 5 49 003254 5 51 003256 6 46 003257 6 52 003261 6 53 003266 6 54 003271 6 55 003273 6 56 003275 6 58 003276 6 59 003277 6 61 003301 6 63 003303 6 65 003310 6 68 003315 6 70 003323 6 72 003331 6 77 003345 6 78 003347 6 79 003351 6 80 003352 6 83 003355 6 84 003357 6 86 003364 6 88 003366 6 91 003367 6 122 003371 6 122 003373 6 123 003375 6 123 003377 6 124 003401 6 126 003402 6 128 003403 6 130 003405 6 130 003410 6 131 003412 6 131 003414 6 132 003416 6 134 003420 6 135 003422 6 136 003446 6 137 003451 6 138 003454 6 139 003460 6 140 003462 6 141 003506 6 142 003511 6 143 003514 6 147 003526 6 148 003533 6 153 003541 ----------------------------------------------------------- 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