COMPILATION LISTING OF SEGMENT compose_index Compiled by: Multics PL/I Compiler, Release 28e, of February 14, 1985 Compiled at: Honeywell Multics Op. - System M Compiled on: 04/23/85 1013.3 mst Tue Options: optimize map 1 /* *********************************************************** 2* * * 3* * * 4* * Copyright, (C) Honeywell Information Systems Inc., 1983 * 5* * * 6* * * 7* *********************************************************** */ 8 9 /* A compose support tool embodying all the functionality of the older 10* index_process.ted, index_sort.ted, and index_print. */ 11 12 /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */ 13 14 compose_index: 15 comp_index: 16 cndx: 17 proc; 18 19 /* SYNTAX 20* 21* compose_index path {-control_args} 22* 23* where: 24* 25* path 26* the pathname of the compin file producing the raw index data. 27* The compin suffix need not be given. 28* 29* {-control_args} may be: 30* 31* -alpha_header, -ahdr 32* insert centered uppercase alphabetic characters as group separators 33* whenever the first character of the primary key changes. 34* 35* -control_file CTL_PATH, -cf CTL_PATH 36* use CTL_PATH.index.control as the control file for this index. 37* The suffix "cndxctl" is assumed if not given. 38* 39* -number N, -nb N 40* one of the 10 (0 thru 9) possible raw index data files. 41* The default value is 0. See Notes below. 42* 43* UNDOCUMENTED 44* -debug 45* display debug info 46* 47* 48* Notes: 49* The raw index data files are produced by compose when the .hit 50* control is used. See WORDPRO Reference Guide (AZ98) for further 51* information on this control. The default raw data file is 52* .0.cndx. The output file is [wd]>.0.index. 53* 54* The raw data in .N.cndx is processed into a arbitrarily chosen 55* format the style of which is partially by constants built into the 56* program and partially by statements in the control file. The default 57* control file is .cndxctl. See Notes on Index Control 58* Files below. 59* 60* Notes on Index Control Files 61* 62* The output file created by this program is to be treated just like 63* any other section of the document to which it applies. That output 64* file contains references to several of the variables defined by the 65* documentation macros; therefore, the first line of a control file 66* must be a call to one of the various init.compin entrypoints. 67**/ 68 /* LOCAL STORAGE */ 69 70 dcl ahdr_sw bit (1); /* alpha header control switch */ 71 dcl arg /* a command line argument */ 72 char (argl) based (argp); 73 dcl argl fixed bin (21); 74 dcl argp ptr; /**/ 75 /* line array for sorting */ 76 dcl 1 bead aligned based (bead_ptr), 77 2 ct fixed bin, /* bead count */ 78 2 e (0 refer (bead.ct)), 79 3 linptr ptr, /* -> line text */ 80 3 len fixed bin (24), /* length of given text */ 81 3 type char (1), /* hit type */ 82 3 sortptr ptr; /* -> line text to be compared */ 83 dcl bead_ptr ptr; 84 dcl code fixed bin (35); /* error code */ 85 dcl 1 control_file aligned like null_file; 86 dcl d fixed bin; /* bead separation for sorting */ 87 dcl debug bit (1); /* debug option */ 88 dcl 1 delim, /* hit line delimiters */ 89 2 key char (1), 90 2 sep char (1), 91 2 end char (1); /**/ 92 /* default delimiters */ 93 dcl 1 dflt_delim static options (constant), 94 2 key char (1) init ("|"), 95 2 sep char (1) init ("~"), 96 2 end char (1) init (";"); 97 dcl EMPTY char (3) static options (constant) init ("`~'"); 98 dcl EN char (1) static options (constant) init (" "); 99 dcl END char (3) static options (constant) init ("  "); 100 /* = <035> */ 101 dcl excl_ptr ptr; /* exclusions for permuting */ 102 dcl 1 excl aligned based (excl_ptr), 103 2 ct fixed bin, /* count of entries */ 104 2 key (0 refer (excl.ct)) char (128) var; 105 dcl hit_type char (1); /* given hit type character */ 106 dcl (i, j, k) fixed bin; /* working index */ 107 dcl iarg fixed bin; /* argument counter */ 108 dcl ignore char (128) var; /* chars to ignore during sorting */ 109 dcl index_nbr char (1); /* index data number, 0-9 */ 110 dcl key_string char (1024) var; /* current key string */ 111 dcl lastkey char (1024) var; /* lastkey string */ 112 dcl 1 last_hit aligned, 113 2 key (5) char (1024) var, 114 2 pageref char (64) var; 115 dcl line char (1024) var; /* a working line */ 116 dcl linect fixed bin; /* line counter */ 117 dcl linstr char (1024) based; 118 dcl lower_case char (26) static options (constant) 119 init ("abcdefghijklmnopqrstuvwxyz"); 120 dcl max_chars fixed bin (21); /* limit for chars in a segment */ 121 dcl me char (13) static options (constant) 122 init ("compose_index"); 123 dcl nargs fixed bin; /* command argument count */ 124 dcl NL char (1) static options (constant) init (" 125 "); /**/ 126 /* empty file data structure */ 127 dcl 1 null_file aligned static options (constant), 128 2 charct fixed bin (24) init (0), 129 2 entryname char (32) aligned init (""), 130 2 dir char (168) aligned init (""), 131 2 lineno fixed bin init (0), 132 2 name char (32) var init (""), 133 2 path char (200) var init (""), 134 2 posn fixed bin (21) init (1), 135 2 ptr ptr init (null ()); 136 /* -> data file */ 137 dcl 1 output_file aligned like null_file; 138 dcl pageref char (1024) var; /* pageref string */ 139 dcl pct fixed bin; /* pct counter for sort routine */ 140 dcl 1 raw_file aligned like null_file; 141 dcl SEP char (3) static options (constant) init ("  "); 142 /* = <036> */ 143 dcl 1 sorted_file aligned like null_file; 144 dcl sortstr char (1024) var based (sortstr_ptr); 145 dcl sortstr_ptr ptr; 146 dcl swp bit (1); /* swap flag for sorting */ 147 dcl 1 tbead like bead.e; /* temporary for sorting */ 148 dcl 1 this_hit aligned, 149 2 key (5) char (1024) var, 150 2 pageref char (64) var; 151 dcl tline char (1024) var; /* a working line */ 152 /* transformations of permuting */ 153 dcl 1 tran aligned based (tran_ptr), 154 2 ct fixed bin, /* count of pairs */ 155 2 e (0 refer (tran.ct)), 156 3 in char (128) var, 157 3 out char (128) var; 158 dcl tran_ptr ptr; 159 dcl tsegs (6) ptr; /* temp seg pointers */ 160 dcl upper_case char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") 161 static options (constant); 162 dcl 1 work_file aligned like null_file; 163 164 dcl (addr, after, before, divide, index, length, null, rtrim, substr, 165 translate) builtin; 166 167 dcl cleanup condition; 168 169 dcl error_table_$bad_arg 170 fixed bin (35) ext static; 171 dcl error_table_$badopt 172 fixed bin (35) ext static; 173 dcl error_table_$zero_length_seg 174 fixed bin (35) ext static; 175 dcl sys_info$max_seg_size 176 fixed bin (18) ext static; 177 178 dcl com_err_ entry options (variable); 179 dcl cu_$arg_count entry (fixed bin); 180 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); 181 dcl expand_pathname_ 182 entry (char (*) aligned, char (*) aligned, 183 char (*) aligned, fixed bin (35)); 184 dcl get_temp_segments_ 185 entry (char (*), (*) ptr, fixed bin (35)); 186 dcl get_wdir_ entry returns (char (168)); 187 dcl hcs_$initiate_count 188 entry (char (*) aligned, char (*) aligned, 189 char (*) aligned, fixed bin (24), fixed bin (1), ptr, 190 fixed bin (35)); 191 dcl hcs_$make_seg entry (char (*) aligned, char (*) aligned, 192 char (*) aligned, fixed bin (5), ptr, fixed bin (35)); 193 dcl hcs_$set_bc_seg 194 entry (ptr, fixed bin (24), fixed bin (35)); 195 dcl hcs_$truncate_seg 196 entry (ptr, fixed bin (19), fixed bin (35)); 197 dcl ioa_ entry options (variable); 198 dcl release_temp_segments_ 199 entry (char (*), (*) ptr, fixed bin (35)); 200 dcl term_$seg_ptr entry (ptr, fixed bin (35)); 201 202 max_chars = 4 * sys_info$max_seg_size; 203 ahdr_sw, debug = "0"b; /* alpha headers & debug off */ 204 index_nbr = "0"; /* default index data number */ 205 /**** tsegs (*) = null (); /* clean up any garbage */ 206 ignore = ""; /* no ignore chars */ 207 raw_file = null_file; /* pl1 bug 1815 wont allow multiple */ 208 control_file = null_file; /* aggregate assignments */ 209 output_file = null_file; 210 211 /* PROCESS COMMAND LINE */ 212 213 call cu_$arg_count (nargs); /* how many args? */ 214 215 if nargs = 0 /* must have at least one arg */ 216 then 217 do; 218 call ioa_ ("^a: Proper usage is: compose_index path {-control_arg}", 219 me); 220 return; 221 end; 222 223 else 224 do iarg = 1 to nargs; /* process the args */ 225 call cu_$arg_ptr (iarg, argp, argl, code); 226 if code ^= 0 227 then 228 do; 229 arg_err: 230 call com_err_ (code, me, "Reading argument ^d", iarg); 231 return; 232 end; 233 234 if index (arg, "-") = 1 /* control arg? */ 235 then 236 do; 237 if arg = "-alpha_header" | arg = "-ahdr" 238 then ahdr_sw = "1"b; 239 240 else if arg = "-control_file" | arg = "-cf" 241 then 242 do; 243 iarg = iarg + 1; 244 call cu_$arg_ptr (iarg, argp, argl, code); 245 if code ^= 0 246 then goto arg_err; 247 248 control_file.path = before (arg, ".cndxctl") || ".cndxctl"; 249 250 if index (control_file.path, "<>") ^= 0 251 then 252 do; 253 call expand_pathname_ ((control_file.path), 254 control_file.dir, control_file.entryname, code); 255 if code ^= 0 256 then 257 do; 258 call com_err_ (code, me, "Expanding path for ""^a"".", 259 control_file.path); 260 return; 261 end; 262 end; 263 264 else 265 do; 266 control_file.dir = get_wdir_ (); 267 control_file.entryname = control_file.path; 268 end; 269 270 control_file.path = 271 rtrim (control_file.dir) || ">" 272 || rtrim (control_file.entryname); 273 end; 274 275 else if arg = "-number" | arg = "-nb" 276 then 277 do; 278 iarg = iarg + 1; 279 call cu_$arg_ptr (iarg, argp, argl, code); 280 if code ^= 0 281 then goto arg_err; 282 283 if argl > 1 | index ("0123456789", arg) = 0 284 then 285 do; 286 call com_err_ (error_table_$bad_arg, me, 287 "A single decimal digit expected for argument ^d.", 288 iarg); 289 return; 290 end; 291 292 index_nbr = arg; 293 end; /**/ 294 /* UNDOCUMENTED */ 295 else if arg = "-debug" 296 then debug = "1"b; 297 298 else 299 do; 300 call com_err_ (error_table_$badopt, me, 301 "Argument ^d - ""^a"".", iarg, arg); 302 return; 303 end; 304 end; 305 306 else 307 do; /* file name */ 308 raw_file.path = before (arg, ".compin"); 309 310 if search (raw_file.path, "<>") ^= 0 311 then 312 do; 313 call expand_pathname_ ((raw_file.path), raw_file.dir, 314 raw_file.entryname, code); 315 if code ^= 0 316 then 317 do; 318 call com_err_ (code, me, "Expanding path for ""^a"".", 319 raw_file.path); 320 return; 321 end; 322 end; 323 324 else 325 do; 326 raw_file.dir = get_wdir_ (); 327 raw_file.entryname = raw_file.path; 328 end; 329 330 raw_file.path = 331 rtrim (raw_file.dir) || ">" || rtrim (raw_file.entryname); 332 end; 333 end; 334 335 /* PROCESS THE RAW FILE */ 336 337 raw_file.name = rtrim (raw_file.entryname) || "." || index_nbr || ".cndx"; 338 339 call hcs_$initiate_count (raw_file.dir, (raw_file.name), "", 340 raw_file.charct, 0, raw_file.ptr, code); 341 if raw_file.ptr = null () 342 then 343 do; 344 call com_err_ (code, me, "Initiating ^a>^a.", rtrim (raw_file.dir), 345 raw_file.name); 346 return; 347 end; 348 349 on cleanup goto clean; /* we now have something to clean */ 350 351 if raw_file.charct = 0 352 then 353 do; 354 call com_err_ (error_table_$zero_length_seg, me, "^a>^a.", 355 rtrim (raw_file.dir), raw_file.name); 356 goto clean; 357 end; /**/ 358 /* we are GO for this run */ 359 work_file = null_file; 360 sorted_file = null_file; 361 output_file.dir = get_wdir_ (); /* hook up to the output file */ 362 output_file.entryname, output_file.name = 363 rtrim (raw_file.entryname) || "." || index_nbr || ".index"; 364 365 call hcs_$make_seg (output_file.dir, output_file.entryname, "", 10, 366 output_file.ptr, code); 367 if output_file.ptr = null () 368 then 369 do; 370 call com_err_ (code, me, "Accessing the output compin file."); 371 goto clean; 372 end; 373 374 call hcs_$truncate_seg (output_file.ptr, 0, code); 375 /* get some temp segs */ 376 call get_temp_segments_ (me, tsegs, code); 377 if code ^= 0 378 then 379 do; 380 call com_err_ (code, me, "Creating temporary segments."); 381 goto clean; 382 end; 383 work_file.ptr = tsegs (1); 384 bead_ptr = tsegs (2); 385 sorted_file.ptr = tsegs (3); 386 tran_ptr = tsegs (4); 387 excl_ptr = tsegs (5); 388 sortstr_ptr = tsegs (6); 389 390 if control_file.dir = "" /* no control file given? */ 391 then 392 do; /* use raw data file for control */ 393 control_file.dir = raw_file.dir; 394 control_file.entryname = raw_file.entryname; 395 control_file.name = rtrim (control_file.entryname) || ".cndxctl"; 396 end; 397 398 call hcs_$initiate_count (control_file.dir, (control_file.name), "", 399 control_file.charct, 0, control_file.ptr, code); 400 401 if control_file.ptr = null () /* no control file? */ 402 then 403 do; 404 no_ctl_file: 405 call write (output_file, "..init """""); 406 call write (output_file, "..l0index"); 407 goto GO; 408 end; 409 410 if control_file.charct = 0 /* empty control file? */ 411 then 412 do; 413 control_file.ptr = null (); 414 goto no_ctl_file; 415 end; /* in case the user forgets them */ 416 call write (output_file, ".srv MPM_SPACE"); 417 call write (output_file, ".srv INDEXSPACE 1"); 418 /* process control file */ 419 control_file.charct = divide (control_file.charct, 9, 21, 0); 420 tran.ct = 0; 421 excl.ct = 0; 422 423 do while (control_file.posn < control_file.charct); 424 line = read (control_file); /**/ 425 /* transformations */ 426 if substr (line, 1, 6) = ".*tran" 427 then 428 do; 429 tline = translate (after (line, ".*tran "), lower_case, upper_case); 430 if substr (tline, 1, 1) ^= "," 431 then 432 tran_err: 433 call ioa_ ("^a: Missing comma at line ^d.^/^-^a", me, 434 raw_file.lineno, line); 435 436 else 437 do; 438 tline = after (tline, ","); 439 if index (tline, ",") = 0 440 then goto tran_err; 441 442 else 443 do; 444 i = tran.ct + 1; 445 tran.in (i) = rtrim (before (tline, ",")); 446 tline = after (tline, ","); 447 tran.out (i) = rtrim (before (tline, ",")); 448 tran.ct = i; 449 end; 450 end; 451 end; 452 453 else if substr (line, 1, 8) = ".*phrase" 454 then 455 do; 456 i = tran.ct + 1; 457 tran.in (i) = tline; 458 tran.out (i) = translate (tline, " ", " "); 459 tran.ct = i; 460 end; 461 462 else if substr (line, 1, 6) = ".*excl" 463 /* exclusions */ 464 then 465 do; 466 tline = translate (after (line, ".*excl "), lower_case, upper_case); 467 468 do excl.ct = excl.ct + 1 by 1 while (tline ^= ""); 469 if tline ^= "," & substr (tline, 1, 2) ^= ",," 470 then excl.key (excl.ct) = before (tline, ","); 471 excl_loop: /* convert ~s to SEPs */ 472 j = index (excl.key (excl.ct), "~"); 473 if j > 0 474 then 475 do; 476 excl.key (excl.ct) = 477 substr (excl.key (excl.ct), 1, j - 1) || SEP 478 || substr (excl.key (excl.ct), j + 1); 479 end; 480 481 tline = after (tline, ","); 482 end; 483 484 excl.ct = excl.ct - 1; /* back out extra count */ 485 end; 486 487 else if substr (line, 1, 8) = ".*ignore" 488 | substr (line, 1, 7) = ".*blind" 489 then ignore = after (line, " "); /* write it to output & let compose */ 490 else call write (output_file, line); 491 /* worry about it */ 492 end; 493 494 GO: 495 work_file.name = "work_file"; 496 497 last_hit.key (*), this_hit.key (*) = EMPTY; 498 last_hit.pageref, this_hit.pageref = ""; 499 500 raw_file.charct = divide (raw_file.charct, 9, 21, 0); 501 linect, bead.ct = 0; /**/ 502 /* run thru raw data file */ 503 do while (raw_file.posn < raw_file.charct); 504 delim = dflt_delim; /* reinitialize delimiters */ 505 506 line = read (raw_file); /* read a line */ 507 linect = linect + 1; /* and count it */ 508 /* process only those lines having*/ 509 if index (line, ".~ HIT ") ^= 0 /* a hit flag string */ 510 then 511 do; 512 if debug 513 then call ioa_ ("HIT line: ""^a""", line); 514 515 tline = after (line, ".~ HIT "); 516 /* strip off hit flag string */ 517 518 if substr (tline, 1, 1) = "=" /* delimiter change for this line? */ 519 then 520 do; 521 delim.key = substr (tline, 2, 1); 522 delim.sep = substr (tline, 3, 1); 523 delim.end = substr (tline, 4, 1); 524 tline = substr (tline, 5); 525 end; /* skip null key strings */ 526 if substr (tline, 1, 1) = delim.end 527 then goto skip_hit; /* copy the hit type char */ 528 hit_type = substr (tline, 1, 1); 529 tline = after (tline, hit_type); 530 /* and strip it off */ 531 532 if index (tline, delim.key) = 0 533 /* check for required key delim */ 534 then 535 do; 536 call ioa_ ("No key delimiter for line ^d, one will be provided." 537 || "^/^-^a", raw_file.lineno, line); 538 tline = delim.key || tline; 539 end; 540 541 i = 0; /* convert given delimiters */ 542 do while (i <= length (tline)); 543 j, k = 0; 544 545 j = index (tline, delim.sep); 546 if j > 0 547 then tline = before (tline, delim.sep) || SEP 548 || after (tline, delim.sep); 549 550 k = index (tline, delim.end); 551 if k > 0 552 then tline = before (tline, delim.end) || END 553 || after (tline, delim.end); 554 555 if j > 0 | k > 0 556 then i = i + min (j, k); 557 else i = length (tline) + 1; 558 end; 559 560 if substr (tline, 1, 1) ^= delim.key 561 /* is there a lastkey? */ 562 then 563 do; 564 lastkey = before (tline, delim.key); 565 tline = after (tline, lastkey); 566 end; 567 else lastkey = ""; 568 569 tline = after (tline, delim.key); 570 /* strip key delim */ 571 pageref = /* copy pageref string */ 572 before (ltrim (after (tline, END)), " "); 573 tline = substr (tline, 1, length (tline) - length (pageref)); 574 /* trim pageref string */ 575 576 if tline = "" /* skip empty key strings */ 577 then goto skip_hit; 578 579 /* K type - specifed key */ 580 /* S type - "see" reference */ 581 if hit_type = "K" | hit_type = "S" 582 then 583 do while (tline ^= ""); 584 key_string = before (tline, delim.key) || lastkey; 585 if hit_type = "K" 586 then key_string = key_string || pageref; 587 /* make a new bead */ 588 call make_bead (key_string); 589 590 tline = after (tline, delim.key); 591 end; 592 593 /* U type - permuted upper case */ 594 595 /* The key string may be ONLY a level 1 key. Each "word" of the key is 596* translated to uppercase and emitted as a level 1 key and followed by the 597* given key string at level 2. */ 598 599 if hit_type = "U" 600 then 601 do; 602 603 /* 604*{trans:="1,$U/^.*%%%/"} " set special translation 605*>(permute) \B(exec) " call permuter 606* 607*1,$U/^.*~/ 1,$M(rf) " translate all to uppercase and copy to b(rf) 608*:(no_U) 609**/ 610 611 call permute (tline); 612 end; 613 skip_hit: 614 end; 615 end; /* sort the hits */ 616 if bead.ct > 0 617 then 618 do; 619 pct = 0; 620 d = bead.ct; 621 sort: 622 d = divide (d + 1, 2, 17, 0); 623 pass: 624 pct = pct + 1; 625 swp = "0"b; 626 do i = 1 to bead.ct - d; 627 j = i + d; 628 629 if bead.sortptr (i) -> sortstr > bead.sortptr (j) -> sortstr 630 then 631 do; 632 tbead = bead.e (j); 633 bead.e (j) = bead.e (i); 634 bead.e (i) = tbead; 635 swp = "1"b; 636 end; 637 end; 638 639 if swp 640 then goto pass; 641 if d > 1 642 then goto sort; 643 end; 644 645 sorted_file.name = "sorted_file"; 646 647 do i = 1 to bead.ct; 648 call write (sorted_file, 649 substr (bead.linptr (i) -> linstr, 1, bead.len (i))); 650 end; 651 652 pageref = ""; /* erase leftovers */ 653 sorted_file.posn = 1; /* "rewind" sorted file */ 654 linect = 0; 655 656 do while (sorted_file.posn <= sorted_file.charct); 657 /* get key strings from */ 658 call get_keys; /* next sorted file line */ 659 linect = linect + 1; 660 661 do i = 1 to 5 while (this_hit.key (i) ^= EMPTY); 662 /* break at this level? */ 663 if translate (this_hit.key (i), lower_case, upper_case) 664 ^= translate (last_hit.key (i), lower_case, upper_case) 665 then 666 do; 667 if pageref ^= "" 668 then 669 do; 670 call write (output_file, pageref); 671 pageref = ""; 672 end; 673 674 if i = 1 /* first level break? */ 675 then 676 do; 677 if ahdr_sw /* alpha headers wanted? */ 678 then 679 do; /* does first char change? */ 680 if translate (substr (this_hit.key (1), 1, 1), lower_case, 681 upper_case) 682 ^= 683 translate (substr (last_hit.key (1), 1, 1), 684 lower_case, upper_case) 685 then 686 do; 687 call write (output_file, 688 ".ur .ur .spt %%{%INDEXSPACE% + %MPM_SPACE%}%%"); 689 call write (output_file, 690 ".tlh 1 0 ||%.fnt HBR%" 691 || 692 translate (substr (this_hit.key (1), 1, 1), 693 upper_case, lower_case) || "%.fnt%||"); 694 end; 695 end; 696 697 call write (output_file, ".ur .spt %INDEXSPACE%"); 698 /* set split title */ 699 call write (output_file, 700 ".dfu block_split .stl |" || this_hit.key (1) 701 || " (cont.) |"); 702 end; 703 704 call write (output_file, ".unl " || ltrim (char (2 * (5 - i)))); 705 call write (output_file, this_hit.key (i)); 706 707 do j = i + 1 to 4; /* clear subordinate keys */ 708 last_hit.key (j) = EMPTY; 709 end; 710 end; 711 end; 712 713 if pageref = "" 714 then pageref = this_hit.pageref; 715 else if this_hit.pageref ^= last_hit.pageref 716 then pageref = pageref || ", " || this_hit.pageref; 717 718 last_hit = this_hit; 719 end; /* and finally, the pageref */ 720 if pageref ^= "" 721 then call write (output_file, pageref); 722 723 clean: 724 call term_$seg_ptr (raw_file.ptr, code); 725 if code ^= 0 726 then call com_err_ (code, me, "Terminating ^a>^a.", rtrim (raw_file.dir), 727 raw_file.name); 728 729 code = 0; 730 if control_file.ptr ^= null () 731 then call term_$seg_ptr (control_file.ptr, code); 732 if code ^= 0 733 then call com_err_ (code, me, "Terminating ^a>^a.", 734 rtrim (control_file.dir), control_file.name); 735 736 code = 0; 737 if output_file.ptr ^= null () 738 then 739 do; 740 call hcs_$set_bc_seg (output_file.ptr, 9 * output_file.charct, code); 741 if code ^= 0 742 then call com_err_ (code, me, "Setting bitcount for ^a>^a", 743 rtrim (output_file.dir), rtrim (output_file.entryname)); 744 code = 0; 745 746 call term_$seg_ptr (output_file.ptr, code); 747 if code ^= 0 748 then call com_err_ (code, me, "Terminating ^a>^a.", 749 rtrim (output_file.dir), output_file.name); 750 end; 751 752 code = 0; 753 call release_temp_segments_ (me, tsegs, code); 754 if code ^= 0 755 then call com_err_ (code, me, "Releasing temporary segments."); 756 757 /* convert digit strings to pictures for proper sorting */ 758 conv_nbrs: 759 proc (str); 760 761 /* PARAMETERS */ 762 763 dcl str char (1024) var; 764 765 /* LOCAL STORAGE */ 766 767 dcl (i, j, k) fixed bin; /* working index */ 768 dcl pic pic "(9)9"; /* output pciture */ 769 770 i = 1; /* scan the string */ 771 do while (i <= length (str)); 772 j = search (substr (str, i), "0123456789"); 773 /* look for numbers */ 774 775 if j > 0 /* found one */ 776 then 777 do; 778 i = i + j - 1; /* skip to first digit */ 779 k = verify (substr (str, i), "0123456789"); 780 /* how many? */ 781 if k = 0 /* all the rest of str */ 782 then k = length (str) - i + 1; 783 else k = k - 1; 784 785 pic = convert (pic, substr (str, i, k)); 786 /* convert to picture */ 787 str = substr (str, 1, i - 1) || pic || substr (str, i + k); 788 i = i + 9; 789 end; 790 791 else i = length (str) + 1; /* for loop control */ 792 end; 793 794 end conv_nbrs; 795 796 /* read a line from the sorted data file and break it into keys */ 797 get_keys: 798 proc; 799 800 dcl i fixed bin; /* working index */ 801 802 this_hit.key (*) = EMPTY; /* preset to empty */ 803 this_hit.pageref = ""; 804 805 line = read (sorted_file); /* read a line from the sorted file */ 806 807 do i = 1 to 5 while (line ^= ""); /* break it into key fields */ 808 j, k = 0; 809 j = index (line, SEP); /* look for a key separator */ 810 if j > 0 /* found a separator? */ 811 then 812 do; 813 this_hit.key (i) = before (line, SEP); 814 line = after (line, SEP); 815 end; 816 817 else k = index (line, END); /* look a key terminator */ 818 if k > 0 /* found a terminator? */ 819 then 820 do; 821 this_hit.key (i) = before (line, END); 822 line = after (line, END); 823 end; 824 825 if i = 1 826 then 827 do; 828 if hit_type = "U" 829 then this_hit.key (1) = 830 translate (this_hit.key (1), upper_case, lower_case); 831 end; 832 833 834 else if j = 0 /* found neither, rest is pageno */ 835 then 836 do; 837 this_hit.pageref = ltrim (line); 838 line = ""; 839 end; 840 end; 841 842 end get_keys; 843 844 /* cleans up a key string and add it to the list of sortable beads */ 845 make_bead: 846 proc (str); 847 848 /* PARAMETERS */ 849 850 dcl str char (1024) var; /* key string (INPUT) */ 851 852 /* LOCAL STORAGE */ 853 854 dcl end fixed bin; /* position of END */ 855 dcl (k, l) fixed bin; /* working index */ 856 dcl bdstr char (1024) var; /* working string */ 857 dcl blind_char char (1); /* blind sort character */ 858 859 bdstr = str; /* copy given string */ 860 861 k = 1; /* discard pad characters */ 862 do while (k > 0); 863 k = search (bdstr, "ÿ"); /* <177><777> */ 864 if k > 0 865 then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1); 866 end; 867 868 k = index (bdstr, SEP || END); /* trim trailing SEPs */ 869 if k > 0 870 then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 3); 871 872 bead.ct = bead.ct + 1; /* make a new bead */ 873 bead.linptr (bead.ct) = /* point to given line */ 874 addr (substr (work_file.ptr -> linstr, work_file.posn)); 875 bead.len (bead.ct) = length (bdstr);/* len of cleaned up key string */ 876 bead.type = hit_type; /* record hit type */ 877 call write (work_file, bdstr); /* save given line */ 878 /* force lower case */ 879 bdstr = translate (bdstr, lower_case, upper_case); 880 881 k = 1; /* discard blind pad char for sort */ 882 do while (k > 0); 883 k = search (bdstr, "¿"); /* <277> */ 884 if k > 0 885 then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1); 886 end; 887 888 call conv_nbrs (bdstr); /* convert numbers to pictures */ 889 /* process ignore chars */ 890 if hit_type = "S" /* S type? */ 891 then 892 do; /* position of "see" */ 893 end = index (bdstr, "see") - 1; 894 if end > 1 /* parens on it? */ 895 then if substr (bdstr, end, 1) = "(" 896 then end = end - 1; 897 end; 898 899 else end = index (bdstr, END); 900 l = end - 1; /* length of string to scan */ 901 902 k = 1; /* massage ignore chars */ 903 if ignore ^= "" 904 then 905 do while (k > 0); 906 k = search (bdstr, ignore); 907 if k > 0 908 then 909 do; 910 blind_char = substr (bdstr, k, 1); 911 /* copy blind char */ 912 blind_char = byte (rank (blind_char) + 128); 913 /* kick it upstairs */ 914 bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1, 1) 915 || blind_char || substr (bdstr, k + 2); 916 end; 917 end; 918 919 sortstr = bdstr; /* string to be sorted */ 920 bead.sortptr (bead.ct) = sortstr_ptr; 921 sortstr_ptr = addrel (sortstr_ptr, bin ((length (bdstr) + 7) / 4, 35, 0)); 922 923 end make_bead; 924 925 /* Permutes "words" in given key string and creates beads from them */ 926 permute: 927 proc (str); 928 929 /* PARAMETERS */ 930 931 dcl str char (1024) var; /* key string to be permuted */ 932 933 /* LOCAL STORAGE */ 934 935 dcl (i, j, k) fixed bin; /* working index */ 936 dcl lstr char (1024) var; /* local string for exclusions */ 937 dcl pkey char (128) var; /* permutation word */ 938 dcl pstr char (1024) var; /* local string for permuting */ 939 dcl tran_sw bit (1); /* control transformation loop */ 940 /* copy key string, translating HTs */ 941 /* to SPs, ltrimming, and */ 942 /* forcing lower case */ 943 pstr = ltrim (translate (before (str, END), " ", " ")); 944 pstr = translate (pstr, lower_case, upper_case); 945 946 i = 1; /* cast out multiple blanks */ 947 do while (i <= length (pstr)); 948 j = index (substr (pstr, i), " ") - 1; 949 if j > 0 950 then 951 do; 952 i = i + j; 953 j = verify (substr (pstr, i), " "); 954 /* how many? */ 955 if j > 0 956 then pstr = substr (pstr, 1, i) || substr (pstr, i + j - 1); 957 i = i + 1; 958 end; 959 else i = length (pstr) + 1; /* loop control */ 960 end; 961 962 j, k = 1; /* remove underscores */ 963 do while (j + k > 0); 964 j, k = 0; 965 966 j = index (pstr, "_"); /* _ */ 967 if j > 0 968 then pstr = substr (pstr, 1, j - 1) || substr (pstr, j + 2); 969 970 k = index (pstr, "_"); /* _ */ 971 if k > 0 972 then pstr = substr (pstr, 1, k - 1) || substr (pstr, k + 2); 973 974 if j + k > 0 975 then i = i + min (j, k); 976 else i = length (pstr) + 1; 977 end; 978 979 pstr = translate (pstr, " ", "_"); /* convert _'s to SPs */ 980 981 if tran.ct > 0 /* apply tran's to pstr */ 982 then 983 do i = 1 to tran.ct by 2; 984 tran_sw = "1"b; /* condition loop control switch */ 985 k = 1; /* string scan index */ 986 do while (tran_sw); 987 tran_sw = "0"b; 988 j = index (substr (pstr, k), tran.in (i)); 989 if j > 0 990 then 991 do; 992 pstr = substr (pstr, k, j - 1) || tran.out (i) 993 || 994 substr (pstr, k + j + length (tran.in (i)) - 1, 995 length (pstr) - k - j - length (tran.in (i)) + 2); 996 k = k + j; 997 tran_sw = "1"b; 998 end; 999 end; 1000 end; 1001 1002 lstr = pstr; /* save final result for exclusions */ 1003 /* finally, we get to permute! */ 1004 if pstr ^= "" & index (pstr, " ") = 0 1005 /* phsaw! nothing to permute */ 1006 then call make_bead (pstr || END || pageref); 1007 1008 else 1009 do while (pstr ^= ""); /* copy permute word */ 1010 pkey = ltrim (rtrim (before (pstr, " "), ")"), "("); 1011 1012 if excl.ct > 0 /* apply exclusions */ 1013 then 1014 do i = 1 to excl.ct; 1015 if pkey = excl.key (i) 1016 then goto skip_pkey; 1017 1018 if substr (pkey || SEP || lstr, 1, length (excl.key (i))) 1019 = excl.key (i) 1020 then goto skip_pkey; 1021 end; 1022 1023 call make_bead (pkey || SEP || str || pageref); 1024 1025 /* 1026*:(permute) 1027*" prepend every line with its own 1st string 1028*1,$S/^.*;/&%;&/ " followed by a % 1029*1,$S/;%;/ %%%/ " replace any null prepends with SP%%% 1030*1,$S/|/ / " make |'s SPs 1031* 1032*" CREATE key,phrase LINES 1033*b(hits) l 1034*1,$S/)/ ) / " move parens out of the way 1035*{level:=0} 1036*:(create) " generate a level of key 1037*1,$S/^(// " remove initial ( 1038*1,$S/^) <<*>>// 1,$S/^ *%%%/~~ %%%/ " remove initial ), drop empty keys created 1039*\v{trans} " apply translation for current type 1040*\B(tran) " DO SPECIFIED TRANSFORMATIONS 1041*1,$K(index) " copy all lines onto index 1042*1,$S/^.* // " strip off first word of key 1043*gd/^ *%%%/ " delete any lines with empty keys 1044*?1,1,$v<<*>>/%%%/ m(excl) 1045*b(excl) ?1 t!Improper .*tran causes these lines to appear during permutation; they were deleted.! l 1,$p l 1,$d 1046*b(hits) ?1 >(create) " if any lines left, try again 1047*b(index) 1048*gd/^~~ / " remove an excluded lines 1049*1,$S/ .*%%%/~/ " replace "surplus" key plus separator with tilde 1050*1,$S/ ) /)/ " put paren back together 1051*1,$S/// " remove the padding character \000 1052*1,$S/^~// " remove null keys which may have cropped up. 1053*\B(let) " do final changes 1054*"1,$S/&/ / " remove linking character 1055*1zif {debug} t|After:| l 1,$P l 1056*" return from permute 1057*> */ 1058 1059 skip_pkey: 1060 pstr = after (pstr, " "); 1061 end; 1062 1063 end permute; 1064 1065 /* Reads one line from the given file and puts it in the 1066* char (1024) var string 'line' */ 1067 read: 1068 proc (file) returns (char (*) var); 1069 1070 /* PARAMETERS */ 1071 1072 dcl 1 file aligned like null_file; 1073 /* file being read (INPUT) */ 1074 1075 /* LOCAL STORAGE */ 1076 1077 dcl input char (max_chars) based (file.ptr); 1078 /* input string */ 1079 dcl llen fixed bin (24); /* length of line */ 1080 dcl lptr ptr; /* -> line */ 1081 /* point to line */ 1082 lptr = addr (substr (input, file.posn)); 1083 /* set input line length */ 1084 if file.posn <= file.charct /* if not at EOF, take up to NL */ 1085 then llen = 1086 index (substr (input, file.posn, file.charct - file.posn + 1), 1087 NL) - 1; /* take all the rest */ 1088 else llen = file.charct - file.posn + 1; 1089 1090 if debug 1091 then call ioa_ ("read: (^a,^d) ""^a""", file.name, linect + 1, 1092 substr (input, file.posn, llen)); 1093 1094 file.posn = file.posn + llen + 1; /* advance file position */ 1095 file.lineno = file.lineno + 1; /* count input lines */ 1096 1097 return (substr (lptr -> input, 1, llen)); 1098 end read; 1099 1100 /* Writes the line to the given file */ 1101 write: 1102 proc (file, line); 1103 1104 /* PARAMETERS */ 1105 1106 dcl 1 file aligned like null_file; 1107 /* file being written */ 1108 dcl line char (1024) var; /* line to write */ 1109 1110 /* LOCAL STORAGE */ 1111 1112 dcl output char (max_chars) based (file.ptr); 1113 /* output string */ 1114 dcl linlen fixed bin; /* length of written */ 1115 /* set output line length */ 1116 linlen = length (line) + 1; /* 1 for NL */ 1117 1118 substr (output, file.posn, linlen) = line || NL; 1119 file.posn = file.posn + linlen; /* advance file position */ 1120 file.charct = file.charct + linlen; /* count output chars */ 1121 file.lineno = file.lineno + 1; /* and lines */ 1122 1123 if debug 1124 then call ioa_ ("write: (^a) ""^a""", file.name, line); 1125 end write; 1126 1127 end compose_index; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 04/23/85 0911.1 compose_index.pl1 >spec>online>comp>compose_index.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. EMPTY 000212 constant char(3) initial unaligned dcl 97 ref 497 661 708 802 END 000211 constant char(3) initial unaligned dcl 99 ref 551 571 817 821 822 868 899 943 1004 NL 013204 constant char(1) initial unaligned dcl 124 ref 1084 1118 SEP 000175 constant char(3) initial unaligned dcl 141 ref 476 546 809 813 814 868 1018 1023 addr builtin function dcl 164 ref 873 1082 after builtin function dcl 164 ref 429 438 446 466 481 487 515 529 546 551 565 569 571 590 814 822 1059 ahdr_sw 000100 automatic bit(1) unaligned dcl 70 set ref 203* 237* 677 arg based char unaligned dcl 71 set ref 234 237 237 240 240 248 275 275 283 292 295 300* 308 argl 000101 automatic fixed bin(21,0) dcl 73 set ref 225* 234 237 237 240 240 244* 248 275 275 279* 283 283 292 295 300 300 308 argp 000102 automatic pointer dcl 74 set ref 225* 234 237 237 240 240 244* 248 275 275 279* 283 292 295 300 308 bdstr 011063 automatic varying char(1024) dcl 856 set ref 859* 863 864* 864 864 868 869* 869 869 875 877* 879* 879 883 884* 884 884 888* 893 894 899 906 910 914* 914 914 914 919 921 bead based structure level 1 dcl 76 bead_ptr 000104 automatic pointer dcl 83 set ref 384* 501 616 620 626 629 629 632 633 633 634 647 648 648 648 648 872 872 873 873 875 875 876 920 920 before builtin function dcl 164 ref 248 308 445 447 469 546 551 564 571 584 813 821 943 1010 blind_char 011464 automatic char(1) unaligned dcl 857 set ref 910* 912* 912 914 charct 000110 automatic fixed bin(24,0) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 398* 410 419* 419 423 charct 005174 automatic fixed bin(24,0) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 339* 351 500* 500 503 charct 005360 automatic fixed bin(24,0) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* 656 charct 010624 automatic fixed bin(24,0) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* charct 004406 automatic fixed bin(24,0) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* 740 charct parameter fixed bin(24,0) initial level 2 in structure "file" dcl 1106 in procedure "write" set ref 1120* 1120 charct parameter fixed bin(24,0) initial level 2 in structure "file" dcl 1072 in procedure "read" ref 1084 1084 1088 cleanup 011010 stack reference condition dcl 167 ref 349 code 000106 automatic fixed bin(35,0) dcl 84 set ref 225* 226 229* 244* 245 253* 255 258* 279* 280 313* 315 318* 339* 344* 365* 370* 374* 376* 377 380* 398* 723* 725 725* 729* 730* 732 732* 736* 740* 741 741* 744* 746* 747 747* 752* 753* 754 754* com_err_ 000020 constant entry external dcl 178 ref 229 258 286 300 318 344 354 370 380 725 732 741 747 754 control_file 000110 automatic structure level 1 dcl 85 set ref 208* 424* ct based fixed bin(17,0) level 2 in structure "excl" dcl 102 in procedure "cndx" set ref 421* 468* 468* 469 471 476 476 476* 484* 484 1012 1012 ct based fixed bin(17,0) level 2 in structure "bead" dcl 76 in procedure "cndx" set ref 501* 616 620 626 647 872* 872 873 875 876 920 ct based fixed bin(17,0) level 2 in structure "tran" dcl 153 in procedure "cndx" set ref 420* 444 448* 456 459* 981 981 cu_$arg_count 000022 constant entry external dcl 179 ref 213 cu_$arg_ptr 000024 constant entry external dcl 180 ref 225 244 279 d 000274 automatic fixed bin(17,0) dcl 86 set ref 620* 621* 621 626 627 641 debug 000275 automatic bit(1) unaligned dcl 87 set ref 203* 295* 512 1090 1123 delim 000276 automatic structure level 1 packed unaligned dcl 88 set ref 504* dflt_delim 000000 constant structure level 1 packed unaligned dcl 93 ref 504 dir 11 005174 automatic char(168) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 313* 326* 330 339* 344 344 354 354 393 725 725 dir 11 005360 automatic char(168) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* dir 11 004406 automatic char(168) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* 361* 365* 741 741 747 747 dir 11 000110 automatic char(168) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 253* 266* 270 390 393* 398* 732 732 dir 11 010624 automatic char(168) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* divide builtin function dcl 164 ref 419 500 621 e 2 based structure array level 2 in structure "bead" dcl 76 in procedure "cndx" set ref 632 633* 633 634* e 1 based structure array level 2 in structure "tran" dcl 153 in procedure "cndx" end 0(18) 000276 automatic char(1) level 2 in structure "delim" packed unaligned dcl 88 in procedure "cndx" set ref 523* 526 550 551 551 end 011060 automatic fixed bin(17,0) dcl 854 in procedure "make_bead" set ref 893* 894 894 894* 894 899* 900 entryname 1 010624 automatic char(32) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* entryname 1 005360 automatic char(32) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* entryname 1 004406 automatic char(32) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* 362* 365* 741 741 entryname 1 000110 automatic char(32) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 253* 267* 270 394* 395 entryname 1 005174 automatic char(32) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 313* 327* 330 337 362 394 error_table_$bad_arg 000010 external static fixed bin(35,0) dcl 169 set ref 286* error_table_$badopt 000012 external static fixed bin(35,0) dcl 171 set ref 300* error_table_$zero_length_seg 000014 external static fixed bin(35,0) dcl 173 set ref 354* excl based structure level 1 dcl 102 excl_ptr 000300 automatic pointer dcl 101 set ref 387* 421 468 468 469 469 471 471 476 476 476 476 476 476 484 484 1012 1012 1015 1018 1018 expand_pathname_ 000026 constant entry external dcl 181 ref 253 313 file parameter structure level 1 dcl 1072 in procedure "read" set ref 1067 file parameter structure level 1 dcl 1106 in procedure "write" set ref 1101 get_temp_segments_ 000030 constant entry external dcl 184 ref 376 get_wdir_ 000032 constant entry external dcl 186 ref 266 326 361 hcs_$initiate_count 000034 constant entry external dcl 187 ref 339 398 hcs_$make_seg 000036 constant entry external dcl 191 ref 365 hcs_$set_bc_seg 000040 constant entry external dcl 193 ref 740 hcs_$truncate_seg 000042 constant entry external dcl 195 ref 374 hit_type 000302 automatic char(1) unaligned dcl 105 set ref 528* 529 581 581 585 599 828 876 890 i 011474 automatic fixed bin(17,0) dcl 935 in procedure "permute" set ref 946* 947 948 952* 952 953 955 955 957* 957 959* 974* 974 976* 981* 988 992 992 992* 1012* 1015 1018 1018* i 011050 automatic fixed bin(17,0) dcl 800 in procedure "get_keys" set ref 807* 813 821 825* i 011034 automatic fixed bin(17,0) dcl 767 in procedure "conv_nbrs" set ref 770* 771 772 778* 778 779 781 785 787 787 788* 788 791* i 000303 automatic fixed bin(17,0) dcl 106 in procedure "cndx" set ref 444* 445 447 448 456* 457 458 459 541* 542 555* 555 557* 626* 627 629 633 634 634 634 634* 647* 648 648 648 648* 661* 661* 663 663 674 704 705 707* iarg 000306 automatic fixed bin(17,0) dcl 107 set ref 223* 225* 229* 243* 243 244* 278* 278 279* 286* 300* ignore 000307 automatic varying char(128) dcl 108 set ref 206* 487* 903 906 in 1 based varying char(128) array level 3 dcl 153 set ref 445* 457* 988 992 992 index builtin function dcl 164 ref 234 250 283 439 471 509 532 545 550 809 817 868 893 899 948 966 970 988 1004 1084 index_nbr 000350 automatic char(1) unaligned dcl 109 set ref 204* 292* 337 362 input based char unaligned dcl 1077 set ref 1082 1084 1090 1090 1097 ioa_ 000044 constant entry external dcl 197 ref 218 430 512 536 1090 1123 j 000304 automatic fixed bin(17,0) dcl 106 in procedure "cndx" set ref 471* 473 476 476 543* 545* 546 555 555 627* 629 632 632 632 632 633 707* 708* 808* 809* 810 834 j 011035 automatic fixed bin(17,0) dcl 767 in procedure "conv_nbrs" set ref 772* 775 778 j 011475 automatic fixed bin(17,0) dcl 935 in procedure "permute" set ref 948* 949 952 953* 955 955 962* 963 964* 966* 967 967 967 974 974 988* 989 992 992 992 996 k 011476 automatic fixed bin(17,0) dcl 935 in procedure "permute" set ref 962* 963 964* 970* 971 971 971 974 974 985* 988 992 992 992 996* 996 k 011061 automatic fixed bin(17,0) dcl 855 in procedure "make_bead" set ref 861* 862 863* 864 864 864 868* 869 869 869 881* 882 883* 884 884 884 902* 903 906* 907 910 914 914 914 k 000305 automatic fixed bin(17,0) dcl 106 in procedure "cndx" set ref 543* 550* 551 555 555 808* 817* 818 k 011036 automatic fixed bin(17,0) dcl 767 in procedure "conv_nbrs" set ref 779* 781 781* 783* 783 785 787 key 000276 automatic char(1) level 2 in structure "delim" packed unaligned dcl 88 in procedure "cndx" set ref 521* 532 538 560 564 569 584 590 key 005556 automatic varying char(1024) array level 2 in structure "this_hit" dcl 148 in procedure "cndx" set ref 497* 661 663 680 689 699 705* 802* 813* 821* 828* 828 key 1 based varying char(128) array level 2 in structure "excl" dcl 102 in procedure "cndx" set ref 469* 471 476* 476 476 1015 1018 1018 key 001353 automatic varying char(1024) array level 2 in structure "last_hit" dcl 112 in procedure "cndx" set ref 497* 663 680 708* key_string 000351 automatic varying char(1024) dcl 110 set ref 584* 585* 585 588* l 011062 automatic fixed bin(17,0) dcl 855 set ref 900* last_hit 001353 automatic structure level 1 dcl 112 set ref 718* lastkey 000752 automatic varying char(1024) dcl 111 set ref 564* 565 567* 584 len 4 based fixed bin(24,0) array level 3 dcl 76 set ref 648 648 875* length builtin function dcl 164 ref 542 557 573 573 771 781 791 875 921 947 959 976 992 992 992 1018 1116 line 004001 automatic varying char(1024) dcl 115 in procedure "cndx" set ref 424* 426 429 430* 453 462 466 487 487 487 490* 506* 509 512* 515 536* 805* 807 809 813 814* 814 817 821 822* 822 837 838* line parameter varying char(1024) dcl 1108 in procedure "write" set ref 1101 1116 1118 1123* linect 004402 automatic fixed bin(17,0) dcl 116 set ref 501* 507* 507 654* 659* 659 1090 lineno 63 parameter fixed bin(17,0) initial level 2 in structure "file" dcl 1072 in procedure "read" set ref 1095* 1095 lineno 63 004406 automatic fixed bin(17,0) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* lineno 63 000110 automatic fixed bin(17,0) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* lineno 63 010624 automatic fixed bin(17,0) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* lineno 63 005174 automatic fixed bin(17,0) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 430* 536* lineno 63 005360 automatic fixed bin(17,0) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* lineno 63 parameter fixed bin(17,0) initial level 2 in structure "file" dcl 1106 in procedure "write" set ref 1121* 1121 linlen 012554 automatic fixed bin(17,0) dcl 1114 set ref 1116* 1118 1119 1120 linptr 2 based pointer array level 3 dcl 76 set ref 648 648 873* linstr based char(1024) unaligned dcl 117 set ref 648 648 873 llen 000100 automatic fixed bin(24,0) dcl 1079 set ref 1084* 1088* 1090 1090 1094 1097 lower_case 000202 constant char(26) initial unaligned dcl 118 ref 429 466 663 663 680 680 689 828 879 944 lptr 000102 automatic pointer dcl 1080 set ref 1082* 1097 lstr 011477 automatic varying char(1024) dcl 936 set ref 1002* 1018 max_chars 004403 automatic fixed bin(21,0) dcl 120 set ref 202* 1082 1084 1090 1090 1097 1118 me 000176 constant char(13) initial unaligned dcl 121 set ref 218* 229* 258* 286* 300* 318* 344* 354* 370* 376* 380* 430* 725* 732* 741* 747* 753* 754* name 64 010624 automatic varying char(32) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* 494* name 64 004406 automatic varying char(32) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* 362* 747* name 64 000110 automatic varying char(32) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 395* 398 732* name 64 parameter varying char(32) initial level 2 in structure "file" dcl 1106 in procedure "write" set ref 1123* name 64 parameter varying char(32) initial level 2 in structure "file" dcl 1072 in procedure "read" set ref 1090* name 64 005360 automatic varying char(32) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* 645* name 64 005174 automatic varying char(32) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 337* 339 344* 354* 725* nargs 004404 automatic fixed bin(17,0) dcl 123 set ref 213* 215 223 null builtin function dcl 164 ref 85 137 140 143 162 341 367 401 413 730 737 null_file 000002 constant structure level 1 dcl 127 ref 207 208 209 359 360 out 42 based varying char(128) array level 3 dcl 153 set ref 447* 458* 992 output based char unaligned dcl 1112 set ref 1118* output_file 004406 automatic structure level 1 dcl 137 set ref 209* 404* 406* 416* 417* 490* 670* 687* 689* 697* 699* 704* 705* 720* pageref 004572 automatic varying char(1024) dcl 138 in procedure "cndx" set ref 571* 573 585 652* 667 670* 671* 713 713* 715* 715 720 720* 1004 1023 pageref 2405 005556 automatic varying char(64) level 2 in structure "this_hit" dcl 148 in procedure "cndx" set ref 498* 713 715 715 803* 837* pageref 2405 001353 automatic varying char(64) level 2 in structure "last_hit" dcl 112 in procedure "cndx" set ref 498* 715 path 75 000110 automatic varying char(200) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 248* 250 253 258* 267 270* path 75 010624 automatic varying char(200) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* path 75 004406 automatic varying char(200) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* path 75 005174 automatic varying char(200) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 308* 310 313 318* 327 330* path 75 005360 automatic varying char(200) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* pct 005173 automatic fixed bin(17,0) dcl 139 set ref 619* 623* 623 pic 011037 automatic picture(9) unaligned dcl 768 set ref 785* 785 787 pkey 012100 automatic varying char(128) dcl 937 set ref 1010* 1015 1018 1023 posn 160 000110 automatic fixed bin(21,0) initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 423 posn 160 010624 automatic fixed bin(21,0) initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* 873 posn 160 005174 automatic fixed bin(21,0) initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 503 posn 160 004406 automatic fixed bin(21,0) initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* posn 160 parameter fixed bin(21,0) initial level 2 in structure "file" dcl 1106 in procedure "write" set ref 1118 1119* 1119 posn 160 005360 automatic fixed bin(21,0) initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* 653* 656 posn 160 parameter fixed bin(21,0) initial level 2 in structure "file" dcl 1072 in procedure "read" set ref 1082 1084 1084 1084 1088 1090 1090 1094* 1094 pstr 012141 automatic varying char(1024) dcl 938 set ref 943* 944* 944 947 948 953 955* 955 955 959 966 967* 967 967 970 971* 971 971 976 979* 979 988 992* 992 992 992 1002 1004 1004 1004 1008 1010 1059* 1059 ptr 162 parameter pointer initial level 2 in structure "file" dcl 1072 in procedure "read" ref 1082 1084 1090 1090 ptr 162 000110 automatic pointer initial level 2 in structure "control_file" dcl 85 in procedure "cndx" set ref 85* 398* 401 413* 730 730* ptr 162 parameter pointer initial level 2 in structure "file" dcl 1106 in procedure "write" ref 1118 ptr 162 005360 automatic pointer initial level 2 in structure "sorted_file" dcl 143 in procedure "cndx" set ref 143* 385* ptr 162 005174 automatic pointer initial level 2 in structure "raw_file" dcl 140 in procedure "cndx" set ref 140* 339* 341 723* ptr 162 004406 automatic pointer initial level 2 in structure "output_file" dcl 137 in procedure "cndx" set ref 137* 365* 367 374* 737 740* 746* ptr 162 010624 automatic pointer initial level 2 in structure "work_file" dcl 162 in procedure "cndx" set ref 162* 383* 873 raw_file 005174 automatic structure level 1 dcl 140 set ref 207* 506* release_temp_segments_ 000046 constant entry external dcl 198 ref 753 rtrim builtin function dcl 164 ref 270 270 330 330 337 344 344 354 354 362 395 445 447 725 725 732 732 741 741 741 741 747 747 1010 sep 0(09) 000276 automatic char(1) level 2 packed unaligned dcl 88 set ref 522* 545 546 546 sorted_file 005360 automatic structure level 1 dcl 143 set ref 360* 648* 805* sortptr 6 based pointer array level 3 dcl 76 set ref 629 629 920* sortstr based varying char(1024) dcl 144 set ref 629 629 919* sortstr_ptr 005544 automatic pointer dcl 145 set ref 388* 919 920 921* 921 str parameter varying char(1024) dcl 850 in procedure "make_bead" ref 845 859 str parameter varying char(1024) dcl 763 in procedure "conv_nbrs" set ref 758 771 772 779 781 785 787* 787 787 791 str parameter varying char(1024) dcl 931 in procedure "permute" ref 926 943 1023 substr builtin function dcl 164 set ref 426 430 453 462 469 476 476 487 487 518 521 522 523 524 526 528 560 573 648 648 680 680 689 772 779 785 787 787 864 864 869 869 873 884 884 894 910 914 914 914 948 953 955 955 967 967 971 971 988 992 992 1018 1082 1084 1090 1090 1097 1118* swp 005546 automatic bit(1) unaligned dcl 146 set ref 625* 635* 639 sys_info$max_seg_size 000016 external static fixed bin(18,0) dcl 175 ref 202 tbead 005550 automatic structure level 1 unaligned dcl 147 set ref 632* 634 term_$seg_ptr 000050 constant entry external dcl 200 ref 723 730 746 this_hit 005556 automatic structure level 1 dcl 148 set ref 718 tline 010204 automatic varying char(1024) dcl 151 set ref 429* 430 438* 438 439 445 446* 446 447 457 458 466* 468 469 469 469 481* 481 515* 518 521 522 523 524* 524 526 528 529* 529 532 538* 538 542 545 546* 546 546 550 551* 551 551 557 560 564 565* 565 569* 569 571 573* 573 573 576 581 584 590* 590 611* tran based structure level 1 dcl 153 tran_ptr 010606 automatic pointer dcl 158 set ref 386* 420 444 445 447 448 456 457 458 459 981 981 988 992 992 992 tran_sw 012542 automatic bit(1) unaligned dcl 939 set ref 984* 986 987* 997* translate builtin function dcl 164 ref 429 458 466 663 663 680 680 689 828 879 943 944 979 tsegs 010610 automatic pointer array dcl 159 set ref 376* 383 384 385 386 387 388 753* type 5 based char(1) array level 3 dcl 76 set ref 876* upper_case 000166 constant char(26) initial unaligned dcl 160 ref 429 466 663 663 680 680 689 828 879 944 work_file 010624 automatic structure level 1 dcl 162 set ref 359* 877* NAME DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. EN internal static char(1) initial unaligned dcl 98 NAMES DECLARED BY EXPLICIT CONTEXT. GO 003664 constant label dcl 494 ref 407 arg_err 001076 constant label dcl 229 ref 245 280 clean 005506 constant label dcl 723 ref 349 356 371 381 cndx 000750 constant entry external dcl 14 comp_index 000760 constant entry external dcl 14 compose_index 000770 constant entry external dcl 14 conv_nbrs 006157 constant entry internal dcl 758 ref 888 excl_loop 003501 constant label dcl 471 get_keys 006341 constant entry internal dcl 797 ref 658 make_bead 006626 constant entry internal dcl 845 ref 588 1004 1023 no_ctl_file 002766 constant label dcl 404 ref 414 pass 004737 constant label dcl 623 ref 639 permute 007275 constant entry internal dcl 926 ref 611 read 010303 constant entry internal dcl 1067 ref 424 506 805 skip_hit 004726 constant label dcl 613 ref 526 576 skip_pkey 010254 constant label dcl 1059 ref 1015 1018 sort 004733 constant label dcl 621 ref 641 tran_err 003130 constant label dcl 430 ref 439 write 010433 constant entry internal dcl 1101 ref 404 406 416 417 490 648 670 687 689 697 699 704 705 720 877 NAMES DECLARED BY CONTEXT OR IMPLICATION. addrel builtin function ref 921 bin builtin function ref 921 byte builtin function ref 912 char builtin function ref 704 convert builtin function ref 785 ltrim builtin function ref 571 704 837 943 1010 min builtin function ref 555 974 rank builtin function ref 912 search builtin function ref 310 772 863 883 906 verify builtin function ref 779 953 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 13456 13530 13213 13466 Length 13752 13213 52 206 243 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cndx 6310 external procedure is an external procedure. on unit on line 349 64 on unit conv_nbrs internal procedure shares stack frame of external procedure cndx. get_keys internal procedure shares stack frame of external procedure cndx. make_bead internal procedure shares stack frame of external procedure cndx. permute internal procedure shares stack frame of external procedure cndx. read 96 internal procedure uses returns(char(*)) or returns(bit(*)). write internal procedure shares stack frame of external procedure cndx. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cndx 000100 ahdr_sw cndx 000101 argl cndx 000102 argp cndx 000104 bead_ptr cndx 000106 code cndx 000110 control_file cndx 000274 d cndx 000275 debug cndx 000276 delim cndx 000300 excl_ptr cndx 000302 hit_type cndx 000303 i cndx 000304 j cndx 000305 k cndx 000306 iarg cndx 000307 ignore cndx 000350 index_nbr cndx 000351 key_string cndx 000752 lastkey cndx 001353 last_hit cndx 004001 line cndx 004402 linect cndx 004403 max_chars cndx 004404 nargs cndx 004406 output_file cndx 004572 pageref cndx 005173 pct cndx 005174 raw_file cndx 005360 sorted_file cndx 005544 sortstr_ptr cndx 005546 swp cndx 005550 tbead cndx 005556 this_hit cndx 010204 tline cndx 010606 tran_ptr cndx 010610 tsegs cndx 010624 work_file cndx 011034 i conv_nbrs 011035 j conv_nbrs 011036 k conv_nbrs 011037 pic conv_nbrs 011050 i get_keys 011060 end make_bead 011061 k make_bead 011062 l make_bead 011063 bdstr make_bead 011464 blind_char make_bead 011474 i permute 011475 j permute 011476 k permute 011477 lstr permute 012100 pkey permute 012141 pstr permute 012542 tran_sw permute 012554 linlen write read 000100 llen read 000102 lptr read THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this_desc return tra_ext enable shorten_stack ext_entry int_entry int_entry_desc trunc_fx2 set_cs_eis index_cs_eis return_chars_eis search_eis any_to_any_tr divide_fx1 index_before_cs index_after_cs THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ cu_$arg_count cu_$arg_ptr expand_pathname_ get_temp_segments_ get_wdir_ hcs_$initiate_count hcs_$make_seg hcs_$set_bc_seg hcs_$truncate_seg ioa_ release_temp_segments_ term_$seg_ptr THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_arg error_table_$badopt error_table_$zero_length_seg sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 85 000637 137 000655 140 000673 143 000711 162 000727 14 000747 202 000776 203 001002 204 001004 206 001006 207 001007 208 001012 209 001015 213 001020 215 001026 218 001030 220 001050 223 001051 225 001057 226 001074 229 001076 231 001126 234 001127 237 001143 240 001156 243 001166 244 001167 245 001204 248 001206 250 001236 253 001251 255 001306 258 001311 260 001344 262 001345 266 001346 267 001360 270 001364 273 001442 275 001444 278 001454 279 001455 280 001472 283 001474 286 001506 289 001536 292 001537 293 001544 295 001545 300 001554 302 001616 304 001617 308 001620 310 001635 313 001650 315 001705 318 001710 320 001743 322 001744 326 001745 327 001757 330 001763 332 002041 333 002042 337 002044 339 002117 341 002172 344 002177 346 002253 349 002255 351 002274 354 002276 356 002351 359 002353 360 002356 361 002361 362 002373 365 002451 367 002511 370 002515 371 002541 374 002542 376 002556 377 002577 380 002601 381 002625 383 002626 384 002630 385 002632 386 002634 387 002636 388 002640 390 002642 393 002646 394 002651 395 002654 396 002706 398 002707 401 002761 404 002766 406 002775 407 003004 410 003005 413 003007 414 003011 416 003012 417 003021 419 003030 420 003033 421 003034 423 003035 424 003041 426 003067 429 003075 430 003123 438 003161 439 003204 444 003216 445 003221 446 003255 447 003300 448 003330 451 003332 453 003333 456 003336 457 003341 458 003355 459 003374 460 003377 462 003400 466 003403 468 003431 469 003445 471 003501 473 003520 476 003521 479 003575 481 003576 482 003621 484 003623 485 003625 487 003626 490 003661 492 003663 494 003664 497 003671 498 003724 500 003726 501 003731 503 003733 504 003737 506 003743 507 003771 509 003773 512 004002 515 004025 518 004046 521 004052 522 004055 523 004060 524 004063 526 004074 528 004104 529 004105 532 004130 536 004142 538 004166 539 004207 541 004210 542 004211 543 004215 545 004217 546 004231 550 004317 551 004332 555 004420 557 004433 558 004436 560 004437 564 004446 565 004463 566 004504 567 004505 569 004506 571 004531 573 004577 576 004605 581 004612 584 004625 585 004655 588 004673 590 004675 591 004720 599 004721 611 004724 615 004726 616 004727 619 004731 620 004732 621 004733 623 004737 625 004740 626 004741 627 004751 629 004753 632 004775 633 005007 634 005015 635 005023 637 005025 639 005027 641 005031 645 005034 647 005041 648 005051 650 005067 652 005071 653 005072 654 005074 656 005075 658 005101 659 005102 661 005103 663 005120 667 005150 670 005156 671 005160 674 005161 677 005164 680 005166 687 005203 689 005212 694 005243 697 005244 699 005253 702 005307 704 005310 705 005362 707 005375 708 005403 709 005410 711 005412 713 005414 715 005427 718 005471 719 005476 720 005477 723 005506 725 005517 729 005575 730 005577 732 005614 736 005672 737 005674 740 005700 741 005716 744 006014 746 006016 747 006027 750 006105 752 006106 753 006107 754 006130 1127 006156 758 006157 770 006161 771 006163 772 006171 775 006210 778 006211 779 006214 781 006233 783 006241 785 006243 787 006261 788 006330 789 006333 791 006334 792 006337 794 006340 797 006341 802 006342 803 006356 805 006357 807 006405 808 006420 809 006422 810 006431 813 006432 814 006453 815 006474 817 006475 818 006504 821 006506 822 006527 825 006550 828 006553 831 006574 834 006576 837 006600 838 006622 840 006623 842 006625 845 006626 859 006630 861 006636 862 006640 863 006642 864 006655 866 006705 868 006707 869 006723 872 006755 873 006757 875 006770 876 006773 877 007011 879 007013 881 007031 882 007034 883 007036 884 007051 886 007101 888 007103 890 007105 893 007110 894 007120 897 007130 899 007131 900 007140 902 007143 903 007145 906 007154 907 007162 910 007163 912 007167 914 007174 916 007250 917 007251 919 007252 920 007260 921 007263 923 007274 926 007275 943 007277 944 007336 946 007355 947 007360 948 007363 949 007400 952 007401 953 007402 955 007422 957 007452 958 007454 959 007455 960 007460 962 007461 963 007464 964 007467 966 007471 967 007503 970 007535 971 007550 974 007602 976 007614 977 007617 979 007620 981 007636 984 007647 985 007651 986 007653 987 007656 988 007657 989 007701 992 007702 996 007754 997 007757 999 007761 1000 007762 1002 007765 1004 007772 1008 010050 1010 010057 1012 010121 1015 010131 1018 010142 1021 010200 1023 010203 1059 010254 1061 010300 1063 010301 1067 010302 1082 010310 1084 010320 1088 010340 1090 010344 1094 010413 1095 010422 1097 010423 1101 010433 1116 010435 1118 010441 1119 010464 1120 010467 1121 010470 1123 010471 1125 010520 ----------------------------------------------------------- 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