1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54 debug
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119 Note
120
121
122
123
124
125
126
127
128
129 abbrev:
130 ab:
131 procedure () options (variable);
132
133
134
135
136 dcl P_code fixed binary (35) parameter;
137
138 dcl P_command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable parameter;
139
140
141 dcl P_breaks character (*) parameter;
142
143 dcl P_abbrev_type fixed bin;
144
145
146
147 dcl P_input_line_ptr pointer parameter;
148 dcl P_input_line_lth fixed binary (21) parameter;
149
150 dcl P_subsystem_name character (*) parameter;
151 dcl P_sci_ptr pointer parameter;
152 dcl P_execute_request entry () variable parameter;
153 dcl P_subsys_cp_info_ptr pointer parameter;
154 dcl P_subsys_cp entry (character (*), pointer, entry, pointer, character (*), fixed binary (35)) variable parameter;
155
156 dcl P_default_profile_ptr pointer parameter;
157 dcl P_profile_ptr pointer parameter;
158 dcl P_request_line character (*) parameter;
159
160 dcl P_workspace_ptr pointer parameter;
161 dcl P_workspace_lth fixed binary (21) parameter;
162 dcl P_output_line_ptr pointer parameter;
163 dcl P_output_line_lth fixed binary (21) parameter;
164
165
166
167
168 dcl abbrev_type fixed bin;
169
170
171
172 dcl input_line character (input_line_lth) based (input_line_ptr);
173 dcl input_line_lth fixed binary (21);
174 dcl input_line_ptr pointer;
175
176 dcl P_output_line character (P_output_line_lth) based (P_output_line_ptr);
177
178 dcl code fixed binary (35);
179
180
181
182
183 dcl system_area area based (system_area_ptr);
184 dcl system_area_ptr pointer;
185
186 dcl expanded_line character (expanded_line_lth) based (expanded_line_ptr);
187 dcl expanded_line_lth fixed binary (21);
188 dcl expanded_line_ptr pointer;
189
190 dcl expansion_stack_space_lth fixed binary (21);
191 dcl expansion_stack_space_ptr pointer;
192 dcl extended_stack bit (1) aligned;
193
194 dcl expansion_temp_segment character (4 * sys_info$max_seg_size) based (expansion_temp_segment_ptr);
195 dcl expansion_temp_segment_ptr pointer;
196 dcl used_temp_segment bit (1) aligned;
197
198 dcl based_word fixed binary (35) based;
199
200 dcl (subsystem_entry, return_expansion, allow_request_lines, have_return_code, null_line) bit (1) aligned;
201
202 dcl start fixed binary (21);
203
204 dcl cp_variable entry (pointer, fixed binary (21), fixed binary (35)) variable;
205
206 dcl ABBREV character (32) static options (constant) initial ("abbrev");
207
208 dcl EXPAND_BOL_ONLY fixed bin static options (constant) initial (1);
209
210 dcl EXPAND_INTERNAL_ONLY fixed bin static options (constant) initial (2);
211
212 dcl EXPAND_BOTH fixed bin static options (constant) initial (3);
213
214
215 dcl MAX_STACK_EXTENSION fixed binary (18) static options (constant) initial (16384);
216
217
218 dcl WHITE_SPACE character (4) static options (constant) initial (" ^K^L");
219
220 dcl WHITE_SPACE_AND_NL character (5) static options (constant) initial (" ^K^L
221 ");
222
223 dcl DEFAULT_ABBREV_ESCAPE_CHARACTER character (1) static options (constant) initial (".");
224
225 dcl DEFAULT_BREAKS character (21) static options (constant) initial ("
226 ^K^L ""$'().:;<>[]`{|}"); /* HT NL VT FF SP QUOTE, etc: must be in collating sequence */
227
228 dcl SP character (1) static options (constant) initial (" ");
229 dcl NL character (1) static options (constant) initial ("
230 ");
231 dcl LEFT_BRACKET character (1) static options (constant) initial ("[");
232 dcl SEMICOLON character (1) static options (constant) initial (";");
233 dcl VERTICAL_BAR character (1) static options (constant) initial ("|");
234 dcl QUOTE character (1) static options (constant) initial ("""");
235
236 dcl abbrev_data_$version character (32) unaligned external;
237 dcl abbrev_data_$default_breaks_list bit (36) aligned external;
238 dcl abbrev_data_$default_breaks_tct_table character (512) unaligned external;
239
240
241 dcl (error_table_$badopt, error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$command_line_overflow,
242 error_table_$moderr, error_table_$noarg, error_table_$noentry, error_table_$not_act_fnc,
243 error_table_$request_not_recognized, error_table_$unbalanced_quotes, error_table_$unimplemented_version)
244 fixed binary (35) external;
245
246
247 dcl sys_info$max_seg_size fixed binary (19) external;
248
249 dcl active_fnc_err_$suppress_name entry () options (variable);
250 dcl com_err_ entry () options (variable);
251 dcl com_err_$suppress_name entry () options (variable);
252 dcl command_processor_ entry (pointer, fixed binary (21), fixed binary (35));
253 dcl command_query_$yes_no entry () options (variable);
254 dcl cu_$af_return_arg_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
255 dcl cu_$arg_list_ptr entry () returns (pointer);
256 dcl cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
257 dcl cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
258 dcl cu_$get_command_processor entry (entry (pointer, fixed binary (21), fixed binary (35)));
259 dcl cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
260 dcl cu_$set_command_processor entry (entry (pointer, fixed binary (21), fixed binary (35)));
261 dcl cu_$shrink_stack_frame entry (pointer, fixed binary (35));
262 dcl debug entry () options (variable);
263 dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
264 dcl probe entry () options (variable);
265 dcl get_system_free_area_ entry () returns (pointer);
266 dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35));
267 dcl hcs_$fs_get_mode entry (pointer, fixed binary (5), fixed binary (35));
268 dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
269 dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
270 dcl initiate_file_$create
271 entry (character (*), character (*), bit (*), pointer, bit (1) aligned, fixed binary (24), fixed binary (35));
272 dcl ioa_ entry () options (variable);
273 dcl ioa_$nnl entry () options (variable);
274 dcl pathname_ entry (character (*), character (*)) returns (character (168));
275 dcl qedx_ entry (pointer, fixed binary (35));
276 dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35));
277 dcl sort_items_$char entry (pointer, fixed binary (24));
278 dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
279 dcl find_char_$first_in_table entry (char (*), char (512) aligned) returns (fixed bin (21)) reducible;
280 dcl user_info_ entry (character (*));
281 dcl user_info_$homedir entry (character (*));
282
283 dcl cleanup condition;
284
285 dcl (addcharno, addr, after, baseptr, before, codeptr, currentsize, divide, fixed, hbound, high, index, lbound, length,
286 low, ltrim, max, mod, null, pointer, rank, rel, reverse, rtrim, search, string, substr, verify) builtin;
287 %page;
288
289
290 dcl first_call bit (1) aligned static initial ("1"b);
291
292 dcl 1 abbrev_state aligned static,
293 2 command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable,
294 2 previous_command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable,
295 2 profile_ptr pointer,
296 2 remembered_line,
297 3 remembered_line_buffer_ptr pointer,
298 3 remembered_line_buffer_lth fixed binary (21),
299 3 remembered_line_lth fixed binary (21),
300 2 escape_character character (1) aligned,
301 2 flags,
302 3 set_cp bit (1) unaligned,
303 3 set_cp_explicit bit (1) unaligned,
304 3 remember_lines bit (1) unaligned,
305 3 default_breaks bit (1) unaligned,
306 3 pad bit (32) unaligned,
307 2 breaks_info,
308 3 user_breaks character (128) varying,
309 3 tct_table character (512),
310 3 breaks_list_ptr pointer;
311
312 dcl abbrev_state_tct_table_as_binary (0:511) fixed binary (9) unaligned unsigned based (addr (abbrev_state.tct_table));
313
314 dcl 1 breaks_list aligned based (abbrev_state.breaks_list_ptr),
315 2 n_break_sequences fixed binary,
316 2 break_strings_lth fixed binary,
317 2 break_sequences (breaks_list_n_break_sequences refer (breaks_list.n_break_sequences)),
318 3 start fixed binary,
319 3 lth fixed binary,
320 2 break_strings character (breaks_list_break_strings_lth refer (breaks_list.break_strings_lth)) unaligned;
321 dcl (breaks_list_n_break_sequences, breaks_list_break_strings_lth) fixed binary;
322
323 dcl remembered_line_buffer character (abbrev_state.remembered_line_buffer_lth)
324 based (abbrev_state.remembered_line_buffer_ptr);
325 dcl remembered_line character (abbrev_state.remembered_line_lth) based (abbrev_state.remembered_line_buffer_ptr);
326
327 dcl debug_entry_variable entry () options (variable) variable static;
328 dcl probe_entry_variable entry () options (variable) variable static;
329 %page;
330 dcl abbrev_rqd (87) char (72) static options (constant)
331 init (".",
332 " displays the current version of abbrev.",
333 "",
334 ".? <request1>...<requestN>", " describes the function and usage of the given abbrev control",
335 " request(s). If none are given, all abbrev requests are described.", ".<SP>LINE",
336
337 " passes LINE directly to the current command processor without", " expanding any embedded abbreviations.",
338 ".a name LINE, .af name LINE", " adds LINE as the definition of a new abbreviation with the given",
339 " name to the current profile. '.af' adds with no query.", ".ab name LINE, .abf name LINE",
340 " adds LINE as the definition of a new abbreviation with the given",
341 " name to the current profile. '.abf' adds with no query.", ".debug", " invokes debug.", "",
342 ".delete names, .dl names, .d names", " deletes the given abbreviations from the current profile.", "",
343 ".edit name", " invokes the qedx editor to edit the given abbreviation's", " definition.",
344 ".escape {STR}, .esc {STR}", " changes the escape character which is used to indicate that a",
345 " command line is actually an abbrev request line. ", ".forget, .f", " disables remember mode. ", "",
346 ".l {names}", " displays the names, switches, and definitions of the given",
347 " abbreviations in alphabetic order.", ".la STRs",
348 " displays the names, switches, and definitions of any abbreviations",
349 " whose name starts with one of the given strings.", ".lab STRs, .la^b STRs",
350 " displays beginning-line (.lab) or not-beginning-line (.la^b)",
351 " information for abbreviations beginning with STRs.", ".lb {names}",
352 " displays information on beginning-of-line abbreviations which",
353 " match {names}, or if no {names}, all bol abreviations.", ".l^b {names}",
354 " displays information on not-beginning-of-line abbreviations which",
355 " which match {name}, or if no {names}, all not-bol abbreviaions.", ".ls STRs",
356 " displays the names, switches, and definitions of any abbreviations", " which contain STRs.",
357 ".lsb STRs, .ls^b STRs", " displays beginning-of-line (.lsb) or not-beginning-of-line ",
358 " information of abbreviations which contain STRs.", ".lx STRs",
359 " displays information of abbreviation expansions which contain", " STRs.", ".lxb STRs, .lx^b STRs",
360 " displays information of beginning-line abbreviation expansions",
361 " (.lxb) or not-beginning-line (.lx^b) containing STRs.", ".probe", " invokes probe.", "", ".profile, .p",
362 " prints the pathname of the profile segment presently being used to", " expand abbreviations.",
363 ".quit, .q", " disables abbreviation processing of subsequent command lines.", "", ".remember, .r",
364 " enables remember mode. In remember mode, abbrev saves the expansion",
365 " of the last line that it has processed. See the '.show' request.",
366 ".rename old_name1 new_name1 ..., .rn old_name1 new_name1...",
367 " renames the given abbreviations. If an abbreviation is already",
368 " defined, abbrev will query for permission to replace it.", ".show {LINE}, .s {LINE}",
369 " if LINE is given, displays the expansion of that line without",
370 " executing it. If LINE is not given, displays the last line expanded.",
371 ".switch_on switch_name names, .swn switch_name names",
372 " turns on the given switch in the definitions of the given",
373 " abbreviations. See the 'abbrev' online help file for more details.",
374 ".switch_off switch_name names, .swf switch_name names",
375 " turns off the given switch in the definitions of the given",
376 " abbreviations. See the 'abbrev' online help file for more details.", ".terminate_process",
377 " causes a fatal process error. This request is intended for use ",
378 " only under special conditions. See the 'abbrev' online help file.", ".use {path}, .u {path}",
379 " changes the pathname of the profile segment. The 'profile' suffix",
380 " is assumed. If no {path} given, the default profile is used.");
381
382 dcl ard (46) char (19) varying static options (constant) init
383
384 (".", ".?", ". ", ".a", ".af", ".ab", ".abf", ".debug", ".delete", ".dl", ".d", ".edit", ".escape", ".esc",
385 ".forget", ".f", ".l", ".la", ".lab", ".la^b", ".lb", ".l^b", ".ls", ".lsb", ".ls^b", ".lx", ".lxb", ".lx^b",
386 ".probe", ".profile", ".p", ".quit", ".q", ".remember", ".r", ".rename", ".rn", ".show", ".s", ".switch_on",
387 ".swn", ".switch_off", ".swf", ".terminate_process", ".use", ".u");
388
389 dcl ardx (46) fixed bin static options (constant) init
390 (1, 4, 7, 10, 10, 13, 13, 16, 19, 19, 19, 22, 25, 25, 28, 28, 31, 34, 37, 37, 40, 43, 46, 49, 49, 52, 55, 55,
391 58, 61, 61, 64, 64, 67, 67, 70, 70, 73, 73, 76, 76, 79, 79, 82, 85, 85);
392 %page;
393
394
395 %page;
396
397
398
399
400
401
402 if first_call then
403 call initialize_abbrev_state ();
404
405 call process_abbrev_command_or_af (cu_$arg_list_ptr ());
406
407 return;
408
409
410
411
412
413 process_abbrev_command_or_af:
414 procedure (p_argument_list) options (non_quick);
415
416 dcl p_argument_list pointer parameter;
417
418 dcl argument character (argument_lth) unaligned based (argument_ptr);
419 dcl argument_ptr pointer;
420 dcl argument_lth fixed binary (21);
421 dcl (n_arguments, argument_idx) fixed binary;
422
423 dcl return_string character (return_string_max_lth) varying based (return_string_ptr);
424 dcl return_string_max_lth fixed binary (21);
425 dcl return_string_ptr pointer;
426
427 dcl active_function bit (1) aligned;
428
429 dcl enable_abbrev bit (1) aligned;
430 dcl new_escape_character character (1) aligned;
431
432 dcl new_profile_dirname character (168);
433 dcl new_profile_ename character (32);
434 dcl new_profile_ptr pointer;
435 dcl created_here bit (1) aligned;
436 dcl try_to_create bit (1);
437
438
439 call cu_$af_return_arg_rel (n_arguments, return_string_ptr, return_string_max_lth, code, p_argument_list);
440
441 if code = 0 then active_function = "1"b;
442
443 else if code = error_table_$not_act_fnc then active_function = "0"b;
444
445 else do;
446 call com_err_ (code, ABBREV);
447 return;
448 end;
449
450
451 if active_function then do;
452 if n_arguments = 0 then
453 if abbrev_state.set_cp then
454 return_string = "true";
455 else return_string = "false";
456
457 else call active_fnc_err_$suppress_name (0, ABBREV, "Usage: [^a]", ABBREV);
458
459 return;
460 end;
461
462
463
464
465 enable_abbrev = "1"b;
466 new_escape_character = abbrev_state.escape_character;
467
468 new_profile_ptr = null ();
469 created_here = "0"b;
470
471 on condition (cleanup)
472 begin;
473 if new_profile_ptr ^= null () then
474 if created_here then
475 call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0));
476 else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0));
477 end;
478
479
480 do argument_idx = 1 to n_arguments;
481
482 call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list);
483 if code ^= 0 then do;
484 call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx);
485 go to RETURN_FROM_ABBREV_COMMAND;
486 end;
487
488 if index (argument, "-") = 1 then
489 if argument = "-on" then enable_abbrev = "1"b;
490 else if argument = "-off" then enable_abbrev = "0"b;
491
492 else if (argument = "-escape") | (argument = "-esc") then
493 if argument_idx = n_arguments then do;
494 call com_err_ (error_table_$noarg, ABBREV, "Escape character after ""^a"".", argument);
495 go to RETURN_FROM_ABBREV_COMMAND;
496 end;
497 else do;
498 argument_idx = argument_idx + 1;
499 call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list);
500 if code ^= 0 then do;
501 call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx);
502 go to RETURN_FROM_ABBREV_COMMAND;
503 end;
504 if length (rtrim (argument)) > length (abbrev_state.escape_character) then do;
505 call com_err_ (0, ABBREV,
506 "The escape sequence must be a single character; not ""^a"".", argument);
507 go to RETURN_FROM_ABBREV_COMMAND;
508 end;
509 new_escape_character = argument;
510 end;
511
512 else if (argument = "-profile") | (argument = "-pf") then
513 if argument_idx = n_arguments then do;
514 call com_err_ (error_table_$noarg, ABBREV, "Profile pathname after ""^a"".", argument);
515 go to RETURN_FROM_ABBREV_COMMAND;
516 end;
517 else do;
518 argument_idx = argument_idx + 1;
519 call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list);
520 if code ^= 0 then do;
521 call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx);
522 go to RETURN_FROM_ABBREV_COMMAND;
523 end;
524 call expand_pathname_$add_suffix (argument, "profile", new_profile_dirname,
525 new_profile_ename, code);
526 if code ^= 0 then do;
527 call com_err_ (code, ABBREV, "^a", argument);
528 go to RETURN_FROM_ABBREV_COMMAND;
529 end;
530 if new_profile_ptr ^= null () then
531 if created_here then
532 call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0));
533 else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0));
534 created_here = "0"b;
535 call initiate_file_ (new_profile_dirname, new_profile_ename, R_ACCESS, new_profile_ptr, (0),
536 code);
537 if code ^= 0 then
538 if code = error_table_$noentry then do;
539 call command_query_$yes_no (try_to_create, 0, ABBREV, "",
540 "Profile ^a not found. Do you want to create it?",
541 pathname_ (new_profile_dirname, new_profile_ename));
542 if try_to_create then
543 call initiate_file_$create (new_profile_dirname, new_profile_ename,
544 RW_ACCESS, new_profile_ptr, created_here, (0), code);
545 else go to RETURN_FROM_ABBREV_COMMAND;
546
547 end;
548 if new_profile_ptr = null () then do;
549 call com_err_ (code, ABBREV, "^a", pathname_ (new_profile_dirname, new_profile_ename));
550 go to RETURN_FROM_ABBREV_COMMAND;
551 end;
552 end;
553
554 else do;
555 call com_err_ (error_table_$badopt, ABBREV, """^a""", argument);
556 go to RETURN_FROM_ABBREV_COMMAND;
557 end;
558
559 else do;
560 call com_err_$suppress_name (0, ABBREV, "Usage: ^a {-control_args}", ABBREV);
561 go to RETURN_FROM_ABBREV_COMMAND;
562 end;
563 end;
564
565
566
567
568 abbrev_state.escape_character = new_escape_character;
569
570 if enable_abbrev then
571 if ^abbrev_state.set_cp then do;
572 call cu_$get_command_processor (cp_variable);
573 if cp_variable ^= abbrev_processor then do;
574
575 abbrev_state.previous_command_processor = cp_variable;
576 if ^abbrev_state.set_cp_explicit then abbrev_state.command_processor = cp_variable;
577
578 call cu_$set_command_processor (abbrev_processor);
579 abbrev_state.set_cp = "1"b;
580 end;
581 end;
582
583 else ;
584
585 else do;
586 if abbrev_state.set_cp then do;
587 call cu_$set_command_processor (abbrev_state.previous_command_processor);
588 abbrev_state.set_cp = "0"b;
589 end;
590 if abbrev_state.profile_ptr ^= null () then
591 call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0));
592 end;
593
594 if new_profile_ptr ^= null () then do;
595 if abbrev_state.profile_ptr ^= null () then
596 call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0));
597 abbrev_state.profile_ptr, ap_ptr = new_profile_ptr;
598 new_profile_ptr = null ();
599 expansion_temp_segment_ptr = null ();
600 have_return_code = "0"b;
601 call initialize_profile (^created_here, created_here);
602 end;
603
604 RETURN_FROM_ABBREV_COMMAND:
605 if new_profile_ptr ^= null () then
606 if created_here then
607 call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0));
608 else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0));
609
610 return;
611
612 end process_abbrev_command_or_af;
613 %page;
614
615
616 get_version:
617 entry () returns (character (32));
618
619 return (abbrev_data_$version);
620 %page;
621
622
623
624 set_cp:
625 entry (P_command_processor);
626
627 if first_call then call initialize_abbrev_state ();
628
629 if codeptr (P_command_processor) = null () then
630 abbrev_state.command_processor = command_processor_;
631 else abbrev_state.command_processor = P_command_processor;
632
633 abbrev_state.set_cp_explicit = "1"b;
634
635 return;
636 %page;
637
638
639 set_break:
640 entry (P_breaks);
641
642 if first_call then call initialize_abbrev_state ();
643
644 call add_breaks (P_breaks);
645
646 return;
647
648
649
650
651
652 add_breaks:
653 procedure (p_breaks) options (non_quick);
654
655 dcl p_breaks character (*) parameter;
656 dcl current_breaks character (128) varying;
657 dcl break_character character (1) aligned;
658 dcl (idx, jdx) fixed binary (21);
659 dcl added bit (1) aligned;
660
661 if abbrev_state.default_breaks then
662 current_breaks = before (DEFAULT_BREAKS, ":") || after (DEFAULT_BREAKS, ":");
663 else current_breaks = abbrev_state.user_breaks;
664
665 do idx = 1 to length (p_breaks);
666 break_character = substr (p_breaks, idx, 1);
667 if break_character <= high (1) then do;
668 added = "0"b;
669 do jdx = 1 to length (current_breaks) while (^added);
670 if substr (current_breaks, jdx, 1) = break_character then added = "1"b;
671 else if substr (current_breaks, jdx, 1) > break_character then do;
672 current_breaks =
673 substr (current_breaks, 1, (jdx - 1)) || break_character
674 || substr (current_breaks, jdx);
675 added = "1"b;
676 end;
677 end;
678 if ^added then
679 current_breaks = current_breaks || break_character;
680 end;
681 end;
682
683 call set_user_breaks (current_breaks);
684
685 return;
686
687 end add_breaks;
688 %page;
689
690
691 reset_break:
692 entry (P_breaks);
693
694 if first_call then call initialize_abbrev_state ();
695
696 call delete_breaks (P_breaks);
697
698 return;
699
700
701
702
703
704 delete_breaks:
705 procedure (p_breaks) options (non_quick);
706
707 dcl p_breaks character (*) parameter;
708 dcl current_breaks character (128) varying;
709 dcl break_character character (1) aligned;
710 dcl (idx, jdx) fixed binary (21);
711 dcl deleted bit (1) aligned;
712
713 if abbrev_state.default_breaks then
714 current_breaks = before (DEFAULT_BREAKS, ":") || after (DEFAULT_BREAKS, ":");
715 else current_breaks = abbrev_state.user_breaks;
716
717 do idx = 1 to length (p_breaks);
718 break_character = substr (p_breaks, idx, 1);
719 deleted = "0"b;
720 do jdx = 1 to length (current_breaks) while (^deleted);
721 if substr (current_breaks, jdx, 1) = break_character then do;
722 current_breaks = substr (current_breaks, 1, (jdx - 1)) || substr (current_breaks, (jdx + 1));
723 deleted = "1"b;
724 end;
725 end;
726 end;
727
728 call set_user_breaks (current_breaks);
729
730 return;
731
732 end delete_breaks;
733 %page;
734
735
736 set_user_breaks:
737 procedure (p_new_breaks) options (non_quick);
738
739 dcl p_new_breaks character (128) varying parameter;
740 dcl idx fixed binary;
741
742 system_area_ptr = get_system_free_area_ ();
743
744 if ^abbrev_state.default_breaks then free breaks_list in (system_area);
745
746 breaks_list_n_break_sequences, breaks_list_break_strings_lth = length (p_new_breaks);
747 allocate breaks_list in (system_area) set (abbrev_state.breaks_list_ptr);
748
749
750 abbrev_state.user_breaks, breaks_list.break_strings = p_new_breaks;
751
752 abbrev_state.tct_table = low (length (abbrev_state.tct_table));
753
754 do idx = 1 to length (abbrev_state.user_breaks);
755 abbrev_state_tct_table_as_binary (rank (substr (abbrev_state.user_breaks, idx, 1))) = idx;
756 breaks_list.break_sequences (idx).start = idx;
757 breaks_list.break_sequences (idx).lth = 1;
758 end;
759
760 abbrev_state.default_breaks = "0"b;
761
762 return;
763
764 end set_user_breaks;
765 %page;
766
767
768 initialize_abbrev_state:
769 procedure () ;
770
771 code = codeptr (debug) -> based_word;
772 debug_entry_variable = debug;
773
774 code = codeptr (probe) -> based_word;
775 probe_entry_variable = probe;
776
777 string (abbrev_state.flags) = ""b;
778 abbrev_state.default_breaks = "1"b;
779
780 abbrev_state.profile_ptr = null ();
781
782 abbrev_state.remembered_line_buffer_ptr = null ();
783 abbrev_state.remembered_line_buffer_lth, abbrev_state.remembered_line_lth = 0;
784
785 abbrev_state.escape_character = DEFAULT_ABBREV_ESCAPE_CHARACTER;
786
787 abbrev_state.tct_table = abbrev_data_$default_breaks_tct_table;
788 abbrev_state.breaks_list_ptr = addr (abbrev_data_$default_breaks_list);
789
790 first_call = "0"b;
791
792 return;
793
794 end initialize_abbrev_state;
795 %page;
796
797
798 abbrev_:
799 abbrev_processor:
800 entry (P_input_line_ptr, P_input_line_lth, P_code);
801
802 abbrev_type = EXPAND_BOTH;
803
804 input_line_ptr = P_input_line_ptr;
805 input_line_lth = P_input_line_lth;
806
807 subsystem_entry = "0"b;
808 return_expansion = "0"b;
809 allow_request_lines, have_return_code = "1"b;
810
811 go to EXPAND_COMMON;
812
813
814
815
816
817 subsys_process_line:
818 entry (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, P_subsys_cp, P_default_profile_ptr,
819 P_profile_ptr, P_request_line, P_code);
820
821 abbrev_type = EXPAND_BOTH;
822
823 input_line_ptr = addr (P_request_line);
824 input_line_lth = length (P_request_line);
825
826 subsystem_entry = "1"b;
827 return_expansion = "0"b;
828 allow_request_lines, have_return_code = "1"b;
829
830 go to EXPAND_COMMON;
831
832
833
834
835 abbrev_$expand_line:
836 entry (P_abbrev_type, P_input_line_ptr, P_input_line_lth, P_workspace_ptr, P_workspace_lth, P_output_line_ptr,
837 P_output_line_lth);
838
839 abbrev_type = P_abbrev_type;
840 goto EXPANDED_LINE;
841
842
843
844
845 abbrev_$expanded_line:
846 entry (P_input_line_ptr, P_input_line_lth, P_workspace_ptr, P_workspace_lth, P_output_line_ptr, P_output_line_lth);
847
848 abbrev_type = EXPAND_BOTH;
849
850 EXPANDED_LINE:
851 input_line_ptr = P_input_line_ptr;
852 input_line_lth = P_input_line_lth;
853
854 subsystem_entry = "0"b;
855 return_expansion = "1"b;
856 allow_request_lines, have_return_code = "0"b;
857
858 go to EXPAND_COMMON;
859
860
861
862
863 EXPAND_COMMON:
864 if first_call then call initialize_abbrev_state ();
865
866 if ^abbrev_state.set_cp & ^abbrev_state.set_cp_explicit then
867 call cu_$get_command_processor (abbrev_state.command_processor);
868
869
870 code = 0;
871
872 system_area_ptr = get_system_free_area_ ();
873
874 extended_stack, used_temp_segment, null_line = "0"b;
875 expansion_stack_space_lth = 0;
876 expansion_temp_segment_ptr = null ();
877
878 if input_line_lth = 0 then do;
879 null_line = "1"b;
880 EXPANSION_IS_INPUT_LINE:
881 expanded_line_ptr = input_line_ptr;
882 expanded_line_lth = input_line_lth;
883 go to EXPANSION_COMPLETED;
884 end;
885
886 start = verify (input_line, WHITE_SPACE_AND_NL);
887
888 if start = 0 then do;
889 null_line = "1"b;
890 go to EXPANSION_IS_INPUT_LINE;
891 end;
892
893
894
895
896
897
898
899
900
901
902 if allow_request_lines & ^subsystem_entry then
903 if input_line_lth > (start + 1) then
904 if substr (input_line, start, 2) = ".." then do;
905 call cu_$cp (addcharno (input_line_ptr, (start + 1)), (input_line_lth - start - 1), code);
906 go to RETURN_FROM_ABBREV_PROCESSOR;
907 end;
908
909
910
911
912 if (substr (input_line, start, 1) = abbrev_state.escape_character) then
913
914 if allow_request_lines then do;
915 call process_request_line ();
916 code = 0;
917 go to RETURN_FROM_ABBREV_PROCESSOR;
918 end;
919
920 else go to EXPANSION_IS_INPUT_LINE;
921
922
923
924
925 call set_profile_ptr (return_expansion);
926
927 if return_expansion & (ap_ptr = null ()) then
928 go to EXPANSION_IS_INPUT_LINE;
929
930 on condition (cleanup)
931 begin;
932 if expansion_temp_segment_ptr ^= null () then
933 call release_temp_segment_ (ABBREV, expansion_temp_segment_ptr, (0));
934 end;
935
936 call expand_line (abbrev_type, start);
937
938 EXPANSION_COMPLETED:
939 if return_expansion then do;
940 if expanded_line_lth <= P_workspace_lth then
941 P_output_line_ptr = P_workspace_ptr;
942 else allocate expanded_line in (system_area) set (P_output_line_ptr);
943 P_output_line_lth = expanded_line_lth;
944 P_output_line = expanded_line;
945 go to RETURN_FROM_ABBREV_PROCESSOR;
946 end;
947
948 if abbrev_state.remember_lines & ^null_line then do;
949 if abbrev_state.remembered_line_buffer_lth < expanded_line_lth then do;
950 if abbrev_state.remembered_line_buffer_ptr ^= null () then
951 free remembered_line_buffer in (system_area);
952 abbrev_state.remembered_line_buffer_lth = 128 * divide (expanded_line_lth + 127, 128, 21, 0);
953 allocate remembered_line_buffer in (system_area) set (abbrev_state.remembered_line_buffer_ptr);
954 end;
955 abbrev_state.remembered_line_lth = expanded_line_lth;
956 remembered_line = expanded_line;
957 end;
958
959 if subsystem_entry then
960 call P_subsys_cp (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, expanded_line,
961 code);
962 else call abbrev_state.command_processor (expanded_line_ptr, expanded_line_lth, code);
963
964
965 RETURN_FROM_ABBREV_PROCESSOR:
966 if expansion_temp_segment_ptr ^= null () then
967 call release_temp_segment_ (ABBREV, expansion_temp_segment_ptr, (0));
968
969 if have_return_code then
970 P_code = code;
971
972 return;
973 %page;
974
975
976 profile_pathname:
977 procedure () returns (character (168)) options (non_quick);
978
979 dcl profile_dirname character (168);
980 dcl profile_ename character (32);
981
982 call hcs_$fs_get_path_name (ap_ptr, profile_dirname, (0), profile_ename, (0));
983
984 return (pathname_ (profile_dirname, profile_ename));
985
986 end profile_pathname;
987
988
989
990
991
992
993 abort_abbrev_processor:
994 procedure (p_code, p_message, p_pathname) options (non_quick);
995
996 dcl p_code fixed binary (35) parameter;
997 dcl (p_message, p_pathname) character (*) parameter;
998
999 if ap_ptr = abbrev_state.profile_ptr then do;
1000 if abbrev_state.set_cp then do;
1001 call cu_$set_command_processor (abbrev_state.previous_command_processor);
1002 abbrev_state.set_cp = "0"b;
1003 end;
1004 if ap_ptr ^= null () then
1005 call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0));
1006 abbrev_state.profile_ptr = null ();
1007 end;
1008
1009 call com_err_ (p_code, ABBREV, p_message, p_pathname);
1010
1011 code = p_code;
1012
1013 go to RETURN_FROM_ABBREV_PROCESSOR;
1014
1015 end abort_abbrev_processor;
1016 %page;
1017
1018
1019
1020 set_profile_ptr:
1021 procedure (p_dont_create_profile) ;
1022
1023 dcl p_dont_create_profile bit (1) aligned;
1024
1025 ap_ptr = null ();
1026
1027 if subsystem_entry then
1028 if (P_default_profile_ptr = null ()) & (P_profile_ptr = null ()) then
1029
1030 if abbrev_state.profile_ptr = null () then
1031 call get_default_profile (p_dont_create_profile);
1032
1033 else ap_ptr = abbrev_state.profile_ptr;
1034
1035 else do;
1036 if P_profile_ptr ^= null () then
1037 ap_ptr = P_profile_ptr;
1038 else ap_ptr = P_default_profile_ptr;
1039 call initialize_profile ("1"b, "0"b);
1040 end;
1041
1042 else do;
1043 if abbrev_state.profile_ptr = null () then
1044 call get_default_profile (p_dont_create_profile);
1045
1046 else ap_ptr = abbrev_state.profile_ptr;
1047 end;
1048
1049 return;
1050
1051 end set_profile_ptr;
1052 %page;
1053
1054
1055
1056
1057 get_default_profile:
1058 procedure (p_dont_create_profile) options (non_quick);
1059
1060 dcl p_dont_create_profile bit (1) aligned parameter;
1061 dcl profile_dirname character (168);
1062 dcl (profile_ename, person_id) character (32);
1063 dcl created_here bit (1) aligned;
1064
1065 call user_info_ (person_id);
1066 call user_info_$homedir (profile_dirname);
1067
1068 profile_ename = rtrim (person_id) || ".profile";
1069
1070 created_here = "0"b;
1071
1072 call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, abbrev_state.profile_ptr, (0), code);
1073
1074 if code = error_table_$noentry then
1075 if p_dont_create_profile then
1076 return;
1077 else do;
1078 call initiate_file_$create (profile_dirname, profile_ename, RW_ACCESS, abbrev_state.profile_ptr,
1079 created_here, (0), code);
1080 if code ^= 0 then
1081 call abort_abbrev_processor (code, "Profile ^a could not be created.",
1082 pathname_ (profile_dirname, profile_ename));
1083 end;
1084
1085 else if code ^= 0 then
1086 call abort_abbrev_processor (code, "^a", pathname_ (profile_dirname, profile_ename));
1087
1088 ap_ptr = abbrev_state.profile_ptr;
1089
1090 call initialize_profile ("1"b, created_here);
1091
1092 return;
1093
1094 end get_default_profile;
1095 %page;
1096
1097
1098 initialize_profile:
1099 procedure (p_announce, p_created_or_initialized) options (non_quick);
1100
1101 dcl p_announce bit (1) aligned parameter;
1102 dcl p_created_or_initialized bit (1) aligned parameter;
1103 dcl profile_mode fixed binary (5);
1104
1105 if abbrev_profile.version > 127 then
1106 call compact_profile ();
1107
1108 call hcs_$fs_get_mode (ap_ptr, profile_mode, code);
1109 if code ^= 0 then
1110 call abort_abbrev_processor (code, "Can not determine access to profile ^a", profile_pathname ());
1111
1112 if abbrev_profile.next_free = 0 then
1113 if (profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN) then do;
1114 if p_announce then
1115 call ioa_ ("^a: Profile ^a ^[created^;initialized^].", ABBREV, profile_pathname (),
1116 p_created_or_initialized);
1117 abbrev_profile.version = ABBREV_PROFILE_VERSION_1;
1118 abbrev_profile.next_free = fixed (rel (addr (abbrev_profile.data_space)), 18, 0);
1119 call terminate_file_ (ap_ptr, (36 * abbrev_profile.next_free), TERM_FILE_TRUNC_BC, (0));
1120 end;
1121
1122 else call abort_abbrev_processor (error_table_$moderr, "Can not complete initialization of profile ^a",
1123 profile_pathname ());
1124
1125 else if abbrev_profile.version = 0 then
1126 if (profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN) then
1127 abbrev_profile.version = ABBREV_PROFILE_VERSION_1;
1128
1129 return;
1130
1131 end initialize_profile;
1132 %page;
1133
1134
1135
1136 expand_line:
1137 procedure (p_abbrev_type, p_start) ;
1138
1139 dcl p_abbrev_type fixed bin;
1140 dcl p_start fixed binary (21) parameter;
1141
1142 dcl abbrev_name character (8) aligned;
1143 dcl break_character character (1) aligned;
1144 dcl (recognize_bol_abbrevs, need_break_sequence, found_end) bit (1) aligned;
1145 dcl (start, last_copied_idx, last_expanded_idx, last_quote_idx, break_idx, idx) fixed binary (21);
1146 dcl break_lth fixed binary;
1147
1148 expanded_line_ptr = input_line_ptr;
1149 expanded_line_lth = input_line_lth;
1150
1151 last_copied_idx = 0;
1152 last_expanded_idx = 0;
1153
1154 recognize_bol_abbrevs = "1"b;
1155
1156 start = p_start;
1157
1158 do while (start <= input_line_lth);
1159
1160 begin;
1161
1162 dcl rest_of_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start);
1163
1164 need_break_sequence = "1"b;
1165 break_idx, break_lth = 0;
1166 do while (need_break_sequence & (break_idx <= length (rest_of_line)));
1167 begin;
1168 dcl rest_of_rest_of_line character (length (rest_of_line) - break_idx) unaligned defined (input_line)
1169 position (start + break_idx);
1170 if abbrev_state.default_breaks then
1171 idx = search (rest_of_rest_of_line, DEFAULT_BREAKS);
1172 else idx = find_char_$first_in_table (rest_of_rest_of_line, abbrev_state.tct_table);
1173 end;
1174 if idx = 0 then
1175 break_idx = length (rest_of_line) + 1;
1176 else do;
1177 break_idx = break_idx + idx;
1178 break_character = substr (rest_of_line, break_idx, 1);
1179
1180 do idx = abbrev_state_tct_table_as_binary (rank (break_character))
1181 to breaks_list.n_break_sequences
1182 while (need_break_sequence &
1183 (substr (breaks_list.break_strings,
1184 breaks_list.break_sequences (idx).start, 1) =
1185 break_character));
1186 if (break_idx + breaks_list.break_sequences (idx).lth - 1) <= length (rest_of_line) then
1187 if substr (rest_of_line, break_idx, breaks_list.break_sequences (idx).lth) =
1188 substr (breaks_list.break_strings, breaks_list.break_sequences (idx).start,
1189 breaks_list.break_sequences (idx).lth)
1190 then do;
1191 need_break_sequence = "0"b;
1192 break_lth = breaks_list.break_sequences (idx).lth;
1193 end;
1194 end;
1195 end;
1196 end;
1197
1198 if break_idx > 1 then do;
1199 if break_idx <= (length (ape.name) + 1) then do;
1200 abbrev_name = substr (rest_of_line, 1, (break_idx - 1));
1201 ape_ptr = lookup_abbrev ();
1202 if ape_ptr ^= null () then
1203 if (recognize_bol_abbrevs & ape.bol & (p_abbrev_type ^= EXPAND_INTERNAL_ONLY))
1204 | (^ape.bol & (p_abbrev_type ^= EXPAND_BOL_ONLY)) then do;
1205 begin;
1206 dcl uncopied_text character (start - last_copied_idx - 1) unaligned defined (input_line) position (last_copied_idx + 1);
1207 call make_space (length (uncopied_text) + ape.value_lth);
1208 expanded_line_lth = expanded_line_lth + length (uncopied_text);
1209 substr (expanded_line, (last_expanded_idx + 1), length (uncopied_text)) =
1210 uncopied_text;
1211 last_expanded_idx = last_expanded_idx + length (uncopied_text);
1212 last_copied_idx = last_copied_idx + length (uncopied_text);
1213 end;
1214
1215 expanded_line_lth = expanded_line_lth + ape.value_lth;
1216 substr (expanded_line, (last_expanded_idx + 1), ape.value_lth) = ape.value;
1217 last_expanded_idx = last_expanded_idx + ape.value_lth;
1218 expanded_line_lth = last_expanded_idx;
1219 last_copied_idx = last_copied_idx + break_idx - 1;
1220 end;
1221 end;
1222 recognize_bol_abbrevs = "0"b;
1223 end;
1224 end;
1225
1226 start = start + break_idx + break_lth - 1;
1227
1228 if start <= input_line_lth then do;
1229
1230 if ape_ptr ^= null () then do;
1231 if substr (ltrim (reverse (expanded_line)), 1, length (SEMICOLON)) = SEMICOLON
1232 | substr (ltrim (reverse (expanded_line)), 1, length (LEFT_BRACKET)) = LEFT_BRACKET
1233 | substr (ltrim (reverse (expanded_line)), 1, length (VERTICAL_BAR || SEMICOLON))
1234 = VERTICAL_BAR || SEMICOLON then
1235 recognize_bol_abbrevs = "1"b;
1236 end;
1237
1238 if (start - 1) > 0 then
1239 break_character = substr (input_line, (start - 1), 1);
1240 else break_character = SP;
1241 if (break_character = NL) | (break_character = SEMICOLON) | (break_character = LEFT_BRACKET) then
1242 recognize_bol_abbrevs = "1"b;
1243 else if (break_character = VERTICAL_BAR) then do;
1244 if substr (input_line, (start - length (SEMICOLON || VERTICAL_BAR)), length (SEMICOLON))
1245 = SEMICOLON then
1246 recognize_bol_abbrevs = "1"b;
1247 end;
1248
1249 else recognize_bol_abbrevs = recognize_bol_abbrevs & (index (WHITE_SPACE, break_character) ^= 0);
1250 if break_character = QUOTE then do;
1251 begin;
1252 dcl rest_of_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start);
1253 found_end = "0"b;
1254 last_quote_idx = 0;
1255 do while (^found_end);
1256 begin;
1257 dcl rest_of_rest_of_line character (length (rest_of_line) - last_quote_idx) unaligned defined (input_line)
1258 position (start + last_quote_idx);
1259 idx = index (rest_of_rest_of_line, QUOTE);
1260 if idx = 0 then idx = length (rest_of_rest_of_line) + 1;
1261 if (idx + 1) <= length (rest_of_rest_of_line) then
1262 if substr (rest_of_rest_of_line, (idx + 1), 1) = QUOTE then
1263 last_quote_idx = last_quote_idx + idx + 1;
1264 else do;
1265 last_quote_idx = last_quote_idx + idx;
1266 found_end = "1"b;
1267 end;
1268 else do;
1269 last_quote_idx = length (rest_of_line) + 1;
1270 found_end = "1"b;
1271 end;
1272 end;
1273 end;
1274 end;
1275 start = start + last_quote_idx;
1276 end;
1277 end;
1278 end;
1279
1280 if extended_stack | used_temp_segment then do;
1281 begin;
1282 dcl uncopied_text character (input_line_lth - last_copied_idx) unaligned defined (input_line)
1283 position (last_copied_idx + 1);
1284 call make_space (length (uncopied_text));
1285
1286 expanded_line_lth = expanded_line_lth + length (uncopied_text);
1287 substr (expanded_line, (last_expanded_idx + 1), length (uncopied_text)) = uncopied_text;
1288 last_expanded_idx = last_expanded_idx + length (uncopied_text);
1289 end;
1290 expanded_line_lth = last_expanded_idx;
1291 end;
1292
1293 return;
1294 %page;
1295
1296
1297
1298 lookup_abbrev:
1299 procedure () returns (pointer) ;
1300
1301 dcl offset fixed binary (18);
1302
1303 do offset = abbrev_profile.hash_table (rank (substr (abbrev_name, 1, 1))) repeat (ape.next)
1304 while (offset ^= 0);
1305 ape_ptr = pointer (ap_ptr, offset);
1306 if ape.name = abbrev_name then return (ape_ptr);
1307 end;
1308
1309 return (null ());
1310
1311 end lookup_abbrev;
1312 %page;
1313
1314
1315
1316 make_space:
1317 procedure (p_amount) ;
1318
1319 dcl p_amount fixed binary (21) parameter;
1320 dcl extension_ptr pointer;
1321 dcl new_size fixed binary (21);
1322 dcl amount_to_grow fixed binary (18);
1323
1324 new_size = last_expanded_idx + p_amount;
1325
1326 if (new_size <= MAX_STACK_EXTENSION) & ^used_temp_segment then
1327 if new_size > expansion_stack_space_lth then do;
1328 amount_to_grow =
1329 16 * divide ((max (expansion_stack_space_lth, p_amount) + 63), 64, 18, 0);
1330 call cu_$grow_stack_frame (amount_to_grow, extension_ptr, code);
1331 if code ^= 0 then go to USE_TEMP_SEGMENT;
1332 if ^extended_stack then do;
1333 extended_stack = "1"b;
1334 expansion_stack_space_ptr, expanded_line_ptr = extension_ptr;
1335 expanded_line_lth = 0;
1336 end;
1337 expansion_stack_space_lth = expansion_stack_space_lth + (4 * amount_to_grow);
1338 end;
1339 else ;
1340
1341 else if new_size <= length (expansion_temp_segment) then
1342 USE_TEMP_SEGMENT:
1343 if ^used_temp_segment then do;
1344 call get_temp_segment_ (ABBREV, expansion_temp_segment_ptr, code);
1345 if code ^= 0 then go to RETURN_FROM_ABBREV_PROCESSOR;
1346 if extended_stack then do;
1347 substr (expansion_temp_segment_ptr -> expanded_line, 1, last_expanded_idx) =
1348 substr (expansion_stack_space_ptr -> expanded_line, 1, last_expanded_idx);
1349 call cu_$shrink_stack_frame (expansion_stack_space_ptr, (0));
1350 extended_stack = "0"b;
1351 end;
1352 expanded_line_ptr = expansion_temp_segment_ptr;
1353 used_temp_segment = "1"b;
1354 end;
1355 else ;
1356
1357 else do;
1358 code = error_table_$command_line_overflow;
1359 go to RETURN_FROM_ABBREV_PROCESSOR;
1360 end;
1361
1362 return;
1363
1364 end make_space;
1365
1366 end;
1367 %page;
1368
1369
1370 process_request_line:
1371 procedure () options (non_quick);
1372
1373 dcl profile_dirname character (168);
1374 dcl (request_name, token, profile_ename) character (32);
1375 dcl new_escape_character character (1) aligned;
1376 dcl used fixed binary (21);
1377
1378
1379 start = start + 1;
1380
1381 input_line_lth = length (rtrim (input_line, WHITE_SPACE_AND_NL));
1382
1383
1384 begin;
1385
1386 dcl request_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start);
1387
1388
1389
1390
1391
1392
1393 if length (request_line) = 0 then
1394 if subsystem_entry then do;
1395 null_line = "1"b;
1396 go to EXPANSION_IS_INPUT_LINE;
1397 end;
1398 else do;
1399 call ioa_ ("^a ^a", ABBREV, abbrev_data_$version);
1400 return;
1401 end;
1402
1403
1404
1405
1406 if (request_line = "quit") | (request_line = "q") then do;
1407 if subsystem_entry then
1408 call com_err_ (0, ABBREV, """^aq"" is not valid within subsystems.",
1409 abbrev_state.escape_character);
1410 else do;
1411 if abbrev_state.set_cp then do;
1412 call cu_$set_command_processor (abbrev_state.previous_command_processor);
1413 abbrev_state.set_cp = "0"b;
1414 end;
1415 if abbrev_state.profile_ptr ^= null () then
1416 call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0));
1417 end;
1418 return;
1419 end;
1420
1421
1422
1423
1424 if substr (request_line, 1, 1) = " " then
1425 begin;
1426 dcl rest_of_line character (length (request_line) - 1) unaligned defined (input_line) position (start + 1);
1427 if subsystem_entry then
1428 call P_subsys_cp (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr,
1429 rest_of_line, code);
1430 else call abbrev_state.command_processor (addr (rest_of_line), length (rest_of_line), code);
1431 go to RETURN_FROM_ABBREV_PROCESSOR;
1432 end;
1433
1434
1435
1436
1437 used = 0;
1438
1439 request_name = get_token ();
1440
1441 if (request_name = "use") | (request_name = "u") then do;
1442 call do_use_request ();
1443 return;
1444 end;
1445
1446 else if request_name = "terminate_process" then do;
1447 call validate_no_arguments ("terminate_process");
1448 code = pointer (baseptr (-2), "400000"b3) -> based_word;
1449 end;
1450
1451 else if request_name = "debug" then do;
1452 call validate_no_arguments ("debug");
1453 call ioa_ ("debug:");
1454 call debug_entry_variable (); debug
1455 return;
1456 end;
1457
1458 else if request_name = "probe" then do;
1459 call validate_no_arguments ("probe");
1460 call probe_entry_variable ();
1461 return;
1462 end;
1463
1464 else if request_name = "?" then do;
1465 call do_help_request ();
1466 return;
1467 end;
1468 call set_profile_ptr ("0"b);
1469
1470
1471
1472
1473 if (request_name = "profile") | (request_name = "p") then do;
1474 call validate_no_arguments ("p");
1475 call hcs_$fs_get_path_name (ap_ptr, profile_dirname, (0), profile_ename, (0));
1476 call ioa_ ("^a", pathname_ (profile_dirname, profile_ename));
1477 end;
1478
1479
1480
1481
1482 else if (request_name = "remember") | (request_name = "r") then do;
1483 call validate_no_arguments ("r");
1484 abbrev_state.remember_lines = "1"b;
1485 end;
1486
1487 else if (request_name = "forget") | (request_name = "f") then do;
1488 call validate_no_arguments ("f");
1489 abbrev_state.remember_lines = "0"b;
1490 if abbrev_state.remembered_line_buffer_ptr ^= null () then
1491 free remembered_line_buffer in (system_area);
1492 abbrev_state.remembered_line_buffer_ptr = null ();
1493 abbrev_state.remembered_line_buffer_lth, abbrev_state.remembered_line_lth = 0;
1494 end;
1495
1496
1497
1498
1499 else if (request_name = "escape") | (request_name = "esc") then do;
1500 token = get_token ();
1501 if token ^= "" then
1502 if length (rtrim (token)) > length (abbrev_state.escape_character) then
1503 call com_err_ (0, ABBREV, "The escape sequence must be a single character; not ""^a"".",
1504 token);
1505 else do;
1506 new_escape_character = substr (token, 1, 1);
1507 token = get_token ();
1508 if token = "" then
1509 abbrev_state.escape_character = new_escape_character;
1510 else call com_err_ (0, ABBREV, "Only one escape character may be specified. ""^a""", token);
1511 end;
1512 else call ioa_ ("Abbrev escape character: ^a", abbrev_state.escape_character);
1513 end;
1514
1515
1516
1517
1518 else if (request_name = "show") | (request_name = "s") then call do_show_request ();
1519
1520
1521 else if (request_name = "l") | (request_name = "la") | (request_name = "lab") | (request_name = "la^b")
1522 | (request_name = "lb") | (request_name = "l^b") | (request_name = "ls") | (request_name = "lsb")
1523 | (request_name = "ls^b") | (request_name = "lx") | (request_name = "lxb") | (request_name = "lx^b")
1524 then
1525 call do_list_request ();
1526
1527 else if (request_name = "a") | (request_name = "af") | (request_name = "ab") | (request_name = "abf") then
1528 call do_add_request ();
1529
1530 else if (request_name = "delete") | (request_name = "dl") | (request_name = "d") then
1531 call do_delete_request ();
1532
1533 else if (request_name = "rename") | (request_name = "rn") then call do_rename_request ();
1534
1535
1536 else if request_name = "edit" then call do_edit_request ();
1537
1538
1539
1540 else if (request_name = "switch_on") | (request_name = "swn") then call do_switch_request ("1"b);
1541
1542
1543 else if (request_name = "switch_off") | (request_name = "swf") then call do_switch_request ("0"b);
1544
1545
1546
1547
1548
1549 else call com_err_ (error_table_$request_not_recognized, ABBREV, """^a^a""", abbrev_state.escape_character,
1550 request_name);
1551
1552 return;
1553 %page;
1554
1555
1556
1557
1558 do_use_request:
1559 procedure ();
1560
1561 dcl expanded_pathname_buffer character (256);
1562 dcl expanded_pathname character (expanded_pathname_lth) based (expanded_pathname_ptr);
1563 dcl expanded_pathname_lth fixed binary (21);
1564 dcl expanded_pathname_ptr pointer;
1565
1566 dcl new_profile_dirname character (168);
1567 dcl (new_profile_ename) character (32);
1568
1569 dcl new_profile_ptr pointer;
1570
1571 dcl created_here bit (1) aligned;
1572 dcl try_to_create bit (1);
1573
1574
1575 call skip_whitespace ();
1576
1577 begin;
1578
1579 dcl original_pathname character (length (request_line) - used) unaligned defined (input_line) position (start + used);
1580
1581 new_profile_ptr = null ();
1582
1583 call set_profile_ptr ("1"b);
1584
1585 if original_pathname = "" then do;
1586 call terminate_old_profile ();
1587 if subsystem_entry then
1588 P_profile_ptr = null ();
1589 else call get_default_profile ("1"b);
1590 return;
1591 end;
1592
1593 if abbrev_state.profile_ptr = null () then do;
1594 expanded_pathname_ptr = addr (original_pathname);
1595 expanded_pathname_lth = length (original_pathname);
1596 end;
1597
1598 else call abbrev_$expand_line (EXPAND_INTERNAL_ONLY, addr (original_pathname), length (original_pathname),
1599 addr (expanded_pathname_buffer), length (expanded_pathname_buffer), expanded_pathname_ptr,
1600 expanded_pathname_lth);
1601
1602 if substr (expanded_pathname, 1, length (QUOTE)) = QUOTE then
1603 if substr (expanded_pathname, expanded_pathname_lth, length (QUOTE)) = QUOTE then
1604 expanded_pathname = substr (expanded_pathname, 2, expanded_pathname_lth - 2);
1605
1606 else do;
1607 call com_err_ (error_table_$unbalanced_quotes, ABBREV, expanded_pathname);
1608 return;
1609 end;
1610 else ;
1611
1612 call expand_pathname_$add_suffix (expanded_pathname, "profile", new_profile_dirname, new_profile_ename,
1613 code);
1614 if code ^= 0 then
1615 call com_err_ (code, ABBREV, "^a", expanded_pathname);
1616 if (expanded_pathname_ptr ^= addr (original_pathname))
1617 & (expanded_pathname_ptr ^= addr (expanded_pathname_buffer)) then
1618 free expanded_pathname in (system_area);
1619 if code ^= 0 then return;
1620
1621 created_here = "0"b;
1622
1623 call initiate_file_ (new_profile_dirname, new_profile_ename, R_ACCESS, new_profile_ptr, (0), code);
1624 if code ^= 0 then
1625 if code = error_table_$noentry then do;
1626 call command_query_$yes_no (try_to_create, 0, ABBREV, "",
1627 "Profile ^a not found. Do you want to create it?",
1628 pathname_ (new_profile_dirname, new_profile_ename));
1629 if try_to_create then
1630 call initiate_file_$create (new_profile_dirname, new_profile_ename, RW_ACCESS,
1631 new_profile_ptr, created_here, (0), code);
1632 else return;
1633 end;
1634
1635 if code ^= 0 then do;
1636 call com_err_ (code, ABBREV, "^a", pathname_ (new_profile_dirname, new_profile_ename));
1637 return;
1638 end;
1639
1640 call terminate_old_profile ();
1641
1642 if subsystem_entry then
1643 P_profile_ptr, ap_ptr = new_profile_ptr;
1644 else abbrev_state.profile_ptr, ap_ptr = new_profile_ptr;
1645
1646 call initialize_profile (^created_here, created_here);
1647
1648 return;
1649 end;
1650
1651
1652
1653
1654
1655 terminate_old_profile:
1656 procedure ();
1657
1658 if ap_ptr ^= null () then
1659 if subsystem_entry then
1660 if (ap_ptr ^= P_default_profile_ptr)
1661 & ((P_default_profile_ptr ^= null ())
1662 | ((P_default_profile_ptr = null ()) & (P_profile_ptr ^= null ()))) then
1663 call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0));
1664 else ;
1665
1666 else call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0));
1667
1668 return;
1669
1670 end terminate_old_profile;
1671
1672 end do_use_request;
1673 %page;
1674
1675
1676
1677 do_show_request:
1678 procedure ();
1679
1680 dcl result_line character (result_line_lth) based (result_line_ptr);
1681 dcl result_line_lth fixed binary (21);
1682 dcl result_line_ptr pointer;
1683
1684 call skip_whitespace ();
1685
1686 if used < length (request_line) then
1687 begin;
1688 dcl rest_of_line character (length (request_line) - used) unaligned defined (input_line) position (start + used);
1689 call abbrev_$expanded_line (addr (rest_of_line), length (rest_of_line), null (), 0, result_line_ptr,
1690 result_line_lth);
1691 call ioa_ ("^a", result_line);
1692 free result_line in (system_area);
1693 end;
1694
1695 else if abbrev_state.remember_lines then
1696 if abbrev_state.remembered_line_lth > 0 then
1697 call ioa_$nnl ("^a^[^/^]", remembered_line,
1698 (substr (remembered_line, abbrev_state.remembered_line_lth, 1) ^= NL));
1699 else call com_err_ (0, ABBREV, "Nothing has been remembered yet.");
1700
1701 else call com_err_ (0, ABBREV, "Remember mode is not enabled.");
1702
1703 return;
1704
1705 end do_show_request;
1706 %page;
1707
1708
1709
1710 do_list_request:
1711 procedure ();
1712
1713 dcl 1 list aligned based (list_segment_ptr),
1714 2 n_abbrevs fixed binary,
1715 2 pad bit (36),
1716 2 abbrevs (0 refer (list.n_abbrevs)) like lae;
1717 dcl list_segment_ptr pointer;
1718
1719 dcl 1 lae aligned based,
1720 2 name character (8),
1721 2 ptr pointer;
1722
1723 dcl 1 list_sort_list aligned based (list_sort_list_ptr),
1724 2 n fixed binary,
1725 2 ptrs (0 refer (list.n_abbrevs)) pointer unaligned;
1726 dcl list_sort_list_ptr pointer;
1727
1728 dcl offset fixed binary (18);
1729 dcl (hash_slot, previous_n_abbrevs, token_lth, idx) fixed binary;
1730 dcl exact_match bit (1) aligned;
1731 dcl (la, ls, lx, bol, nbol) bit (1);
1732 dcl emessage char (64);
1733
1734
1735 call skip_whitespace ();
1736 if used = length (request_line) & request_name ^= "l" & request_name ^= "lb" & request_name ^= "l^b" then do;
1737 call com_err_ (0, ABBREV, " Usage: ^a^a STRs", abbrev_state.escape_character, request_name);
1738 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1739 end;
1740
1741 call get_temp_segment_ (ABBREV, list_segment_ptr, code);
1742 if code ^= 0 then do;
1743 call com_err_ (code, ABBREV, "Getting sorting space for listing abbreviations.");
1744 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1745 end;
1746
1747 on condition (cleanup)
1748 begin;
1749 if list_segment_ptr ^= null () then call release_temp_segment_ (ABBREV, list_segment_ptr, (0));
1750 end;
1751
1752 exact_match = request_name = "l" | request_name = "lb" | request_name = "l^b";
1753 la = substr (request_name, 1, 2) = "la";
1754 ls = substr (request_name, 1, 2) = "ls";
1755 lx = substr (request_name, 1, 2) = "lx";
1756 bol = index (request_name, "b") ^= 0 & index (request_name, "^") = 0;
1757 nbol = index (request_name, "b") ^= 0 & index (request_name, "^") ^= 0;
1758
1759 if exact_match & (used = length (request_line)) then do;
1760 list.n_abbrevs = 0;
1761 do hash_slot = lbound (abbrev_profile.hash_table, 1) to hbound (abbrev_profile.hash_table, 1);
1762 do offset = abbrev_profile.hash_table (hash_slot) repeat (ape.next) while (offset ^= 0);
1763 ape_ptr = pointer (ap_ptr, offset);
1764 if ape.name ^= "" then do;
1765 if request_name = "l" then call set_list_entry ();
1766 if request_name = "lb" then do;
1767 if ape.bol then call set_list_entry ();
1768 end;
1769 if request_name = "l^b" then do;
1770 if ^ape.bol then call set_list_entry ();
1771 end;
1772 end;
1773 end;
1774 end;
1775 if list.n_abbrevs = 0 then do;
1776 call com_err_ (0, ABBREV, "No abbreviations defined.");
1777 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1778 end;
1779 end;
1780
1781 else if exact_match then do;
1782 list.n_abbrevs = 0;
1783 do token = get_token () repeat (get_token ()) while (token ^= "");
1784 if length (rtrim (token)) > length (ape.name) then
1785 call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
1786 length (ape.name), token);
1787 else do;
1788 ape_ptr = lookup_abbrev (token);
1789 if ape_ptr = null () then
1790 call com_err_ (0, ABBREV, """^a"" is not defined.", token);
1791 else do;
1792 if request_name = "l" then call set_list_entry ();
1793 if request_name = "lb" then do;
1794 if ape.bol then call set_list_entry ();
1795 end;
1796 if request_name = "l^b" then do;
1797 if ^ape.bol then call set_list_entry ();
1798 end;
1799 end;
1800 end;
1801 end;
1802 if list.n_abbrevs = 0 then go to RETURN_FROM_PROCESS_REQUEST_LINE;
1803 end;
1804
1805 else do;
1806 list.n_abbrevs = 0;
1807 do token = get_token () repeat (get_token ()) while (token ^= "");
1808 previous_n_abbrevs = list.n_abbrevs;
1809 token_lth = length (rtrim (token));
1810 if (token_lth > length (ape.name)) & ^lx then
1811 call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
1812 length (ape.name), token);
1813 else do;
1814 do hash_slot = lbound (abbrev_profile.hash_table, 1) to hbound (abbrev_profile.hash_table, 1);
1815 do offset = abbrev_profile.hash_table (hash_slot) repeat (ape.next) while (offset ^= 0);
1816 ape_ptr = pointer (ap_ptr, offset);
1817 if ape.name ^= "" then do;
1818 if ^bol & ^nbol then call set_list_entry ();
1819 if bol & ape.bol then call set_list_entry ();
1820 else if nbol & ^ape.bol then call set_list_entry ();
1821 end;
1822 end;
1823 end;
1824 if previous_n_abbrevs = list.n_abbrevs then do;
1825 emessage = "";
1826 if la then emessage = "No abbreviations defined which start with";
1827 else if lx then emessage = "No abbreviation expansions defined which contain";
1828 else emessage = "No abbreviations defined which contain";
1829 call com_err_ (0, ABBREV, "^a ""^a"".", emessage, token);
1830 end;
1831 end;
1832 end;
1833 if list.n_abbrevs = 0 then go to RETURN_FROM_PROCESS_REQUEST_LINE;
1834 end;
1835
1836 list_sort_list_ptr = pointer (list_segment_ptr, currentsize (list));
1837 list_sort_list.n = list.n_abbrevs;
1838
1839 do idx = 1 to list_sort_list.n;
1840 list_sort_list.ptrs (idx) = addr (list.abbrevs (idx).name);
1841 end;
1842
1843 call sort_items_$char (list_sort_list_ptr, length (ape.name));
1844
1845 do idx = 1 to list_sort_list.n;
1846 ape_ptr = list_sort_list.ptrs (idx) -> lae.ptr;
1847 call ioa_ ("^[b^;^x^]^x^a^12t^a", ape.bol, ape.name, ape.value);
1848 end;
1849
1850 call release_temp_segment_ (ABBREV, list_segment_ptr, (0));
1851
1852 return;
1853
1854 set_list_entry:
1855 proc ();
1856
1857 if ^ls & ^lx & ^la then go to set_entry;
1858 if la then do;
1859 if token = substr (ape.name, 1, token_lth) then go to set_entry;
1860 return;
1861 end;
1862 if ls then do;
1863 if index (ape.name, substr (token, 1, token_lth)) ^= 0 then go to set_entry;
1864 return;
1865 end;
1866 if lx then do;
1867 if index (ape.value, substr (token, 1, token_lth)) ^= 0 then go to set_entry;
1868 return;
1869 end;
1870 set_entry:
1871 list.n_abbrevs, idx = list.n_abbrevs + 1;
1872 list.abbrevs (idx).name = ape.name;
1873 list.abbrevs (idx).ptr = ape_ptr;
1874
1875 return;
1876
1877 end set_list_entry;
1878
1879 end do_list_request;
1880 %page;
1881
1882
1883
1884 do_add_request:
1885 procedure ();
1886
1887 dcl last_ape_ptr pointer;
1888 dcl abbrev_name character (32);
1889 dcl (old_size, hash_slot) fixed binary (18);
1890 dcl (force, bol) bit (1) aligned;
1891 dcl add_it bit (1);
1892
1893 if ^write_access () then do;
1894 call com_err_ (error_table_$moderr, ABBREV, "Can not add abbreviations to profile ^a", profile_pathname ())
1895 ;
1896 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1897 end;
1898
1899 token = get_token ();
1900
1901 if token = "" then do;
1902 PRINT_ADD_REQUEST_USAGE:
1903 call com_err_ (0, ABBREV, " Usage: ^a^a name expansion", abbrev_state.escape_character, request_name);
1904 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1905 end;
1906
1907 abbrev_name = token;
1908 if ^validate_abbrev_name (abbrev_name) then go to RETURN_FROM_PROCESS_REQUEST_LINE;
1909
1910 call skip_whitespace ();
1911 if used = length (request_line) then go to PRINT_ADD_REQUEST_USAGE;
1912
1913 force = (request_name = "af") | (request_name = "abf");
1914 bol = (request_name = "ab") | (request_name = "abf");
1915
1916 begin;
1917
1918 dcl definition character (length (request_line) - used) unaligned defined (input_line) position (start + used);
1919
1920 ape_ptr = lookup_abbrev (abbrev_name);
1921
1922 if ape_ptr ^= null () then
1923 if force then do;
1924 OVERWRITE_PREVIOUS_DEFINITION:
1925 if ape.value_lth >= length (definition) then do;
1926 old_size = currentsize (ape);
1927 ape.bol = bol;
1928 ape.value_lth = length (definition);
1929 ape.value = definition;
1930 abbrev_profile.garbage = abbrev_profile.garbage + old_size - currentsize (ape);
1931 end;
1932 else do;
1933 ape.name = "";
1934 abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape);
1935 go to CREATE_NEW_DEFINITION;
1936 end;
1937 end;
1938
1939 else do;
1940 call command_query_$yes_no (add_it, 0, ABBREV, "",
1941 "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it?",
1942 ape.bol, ape.name, ape.value);
1943 if add_it then go to OVERWRITE_PREVIOUS_DEFINITION;
1944 end;
1945
1946 else do;
1947 CREATE_NEW_DEFINITION:
1948 ape_ptr = pointer (ap_ptr, abbrev_profile.next_free);
1949 substr (ape.name, 1, length (ape.name)) = substr (abbrev_name, 1, length (ape.name));
1950 ape.next = 0;
1951 string (ape.flags) = ""b;
1952 ape.bol = bol;
1953 ape.value_lth = length (definition);
1954 ape.value = definition;
1955 abbrev_profile.next_free = abbrev_profile.next_free + currentsize (ape);
1956 hash_slot = rank (substr (abbrev_name, 1, 1));
1957 if abbrev_profile.hash_table (hash_slot) = 0 then
1958 abbrev_profile.hash_table (hash_slot) = fixed (rel (ape_ptr), 18, 0);
1959 else do;
1960 do last_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (hash_slot))
1961 repeat (pointer (ap_ptr, last_ape_ptr -> ape.next)) while (last_ape_ptr -> ape.next ^= 0);
1962 end;
1963 last_ape_ptr -> ape.next = fixed (rel (ape_ptr), 18, 0);
1964 end;
1965 end;
1966 end;
1967
1968 call compact_profile_if_needed ("1"b);
1969
1970 return;
1971
1972 end do_add_request;
1973 %page;
1974
1975
1976 do_delete_request:
1977 procedure ();
1978
1979 if ^write_access () then do;
1980 call com_err_ (error_table_$moderr, ABBREV, "Can not delete abbreviations from profile ^a",
1981 profile_pathname ());
1982 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1983 end;
1984
1985 call skip_whitespace ();
1986 if used = length (request_line) then do;
1987 call com_err_ (0, ABBREV, " Usage: ^ad names", abbrev_state.escape_character);
1988 go to RETURN_FROM_PROCESS_REQUEST_LINE;
1989 end;
1990
1991 do token = get_token () repeat (get_token ()) while (token ^= "");
1992 if length (rtrim (token)) > length (ape.name) then
1993 call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
1994 length (ape.name), token);
1995 else do;
1996 ape_ptr = lookup_abbrev (token);
1997 if ape_ptr = null () then
1998 call com_err_ (0, ABBREV, """^a"" is not defined.", token);
1999 else do;
2000 ape.name = "";
2001 abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape);
2002 end;
2003 end;
2004 end;
2005
2006 call compact_profile_if_needed ("0"b);
2007
2008 return;
2009
2010 end do_delete_request;
2011 %page;
2012
2013
2014 do_rename_request:
2015 procedure ();
2016
2017 dcl (old_abbrev_name, new_abbrev_name) character (32);
2018 dcl (old_ape_ptr, new_ape_ptr, the_ape_ptr, prior_ape_ptr) pointer;
2019 dcl rename_it bit (1);
2020 dcl (old_hash_slot, new_hash_slot) fixed binary;
2021
2022 if ^write_access () then do;
2023 call com_err_ (error_table_$moderr, ABBREV, "Can not rename abbreviations in profile ^a.",
2024 profile_pathname ());
2025 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2026 end;
2027
2028 old_abbrev_name = get_token ();
2029
2030 if old_abbrev_name = "" then do;
2031 call com_err_ (0, ABBREV, "Usage: ^arename old_name1 new_name1 {... old_nameN new_nameN}",
2032 abbrev_state.escape_character);
2033 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2034 end;
2035
2036 do while (old_abbrev_name ^= "");
2037
2038 new_abbrev_name = get_token ();
2039 if new_abbrev_name = "" then do;
2040 call com_err_ (error_table_$noarg, ABBREV, "New name for abbreviation ""^a"".", old_abbrev_name);
2041 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2042 end;
2043
2044 old_ape_ptr = lookup_abbrev (old_abbrev_name);
2045
2046 if old_ape_ptr ^= null () then
2047 if validate_abbrev_name (new_abbrev_name) then do;
2048 new_ape_ptr = lookup_abbrev (new_abbrev_name);
2049
2050 if new_ape_ptr = null () then do;
2051 RENAME_THE_OLD_ABBREVIATION:
2052 old_hash_slot = rank (substr (old_abbrev_name, 1, 1));
2053 new_hash_slot = rank (substr (new_abbrev_name, 1, 1));
2054 if old_hash_slot = new_hash_slot then
2055
2056 substr (old_ape_ptr -> ape.name, 1, length (old_ape_ptr -> ape.name)) =
2057 substr (new_abbrev_name, 1, length (old_ape_ptr -> ape.name));
2058 else do;
2059
2060 prior_ape_ptr = null ();
2061 do the_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (old_hash_slot))
2062 repeat (pointer (ap_ptr, the_ape_ptr -> ape.next))
2063 while ((the_ape_ptr ^= old_ape_ptr) & (the_ape_ptr -> ape.next ^= 0));
2064 prior_ape_ptr = the_ape_ptr;
2065 end;
2066 if the_ape_ptr ^= old_ape_ptr then
2067 call abort_abbrev_processor (error_table_$bad_segment, "^a", profile_pathname ());
2068 if prior_ape_ptr = null () then
2069 abbrev_profile.hash_table (old_hash_slot) = old_ape_ptr -> ape.next;
2070 else prior_ape_ptr -> ape.next = old_ape_ptr -> ape.next;
2071
2072 substr (old_ape_ptr -> ape.name, 1, length (old_ape_ptr -> ape.name)) =
2073 substr (new_abbrev_name, 1, length (old_ape_ptr -> ape.name));
2074 old_ape_ptr -> ape.next = 0;
2075 if abbrev_profile.hash_table (new_hash_slot) = 0 then
2076 abbrev_profile.hash_table (new_hash_slot) = fixed (rel (old_ape_ptr), 18, 0);
2077 else do;
2078 do prior_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (new_hash_slot))
2079 repeat (pointer (ap_ptr, prior_ape_ptr -> ape.next))
2080 while (prior_ape_ptr -> ape.next ^= 0);
2081 end;
2082 prior_ape_ptr -> ape.next = fixed (rel (old_ape_ptr), 18, 0);
2083 end;
2084 end;
2085 end;
2086
2087 else do;
2088 call command_query_$yes_no (rename_it, 0, ABBREV, "",
2089 "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it by renaming:^/^3x^[b^;^x^]^x^a^15t^a^/to ""^a""?",
2090 new_ape_ptr -> ape.bol, new_ape_ptr -> ape.name, new_ape_ptr -> ape.value,
2091 old_ape_ptr -> ape.bol, old_ape_ptr -> ape.name, old_ape_ptr -> ape.value,
2092 new_ape_ptr -> ape.name);
2093 if rename_it then do;
2094 new_ape_ptr -> ape.name = "";
2095 abbrev_profile.garbage = abbrev_profile.garbage + currentsize (new_ape_ptr -> ape);
2096 go to RENAME_THE_OLD_ABBREVIATION;
2097 end;
2098 end;
2099 end;
2100
2101 else ;
2102
2103 else call com_err_ (0, ABBREV, """^a"" is not defined.", old_abbrev_name);
2104
2105 old_abbrev_name = get_token ();
2106 end;
2107
2108 call compact_profile_if_needed ("0"b);
2109
2110 return;
2111
2112 end do_rename_request;
2113 %page;
2114
2115
2116 do_edit_request:
2117 procedure ();
2118
2119 dcl 1 local_qi aligned,
2120 2 header like qedx_info.header,
2121 2 buffer like qedx_info.buffers;
2122 dcl initial_abbrev_name character (32);
2123
2124
2125 if ^write_access () then do;
2126 call com_err_ (error_table_$moderr, ABBREV, "Can not edit abbreviations in profile ^a.",
2127 profile_pathname ());
2128 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2129 end;
2130
2131
2132
2133
2134 initial_abbrev_name = get_token ();
2135
2136 if initial_abbrev_name = "" then do;
2137 PRINT_EDIT_REQUEST_USAGE:
2138 call com_err_ (0, ABBREV, "Usage: ^aedit name", abbrev_state.escape_character);
2139 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2140 end;
2141
2142 token = get_token ();
2143 if token ^= "" then go to PRINT_EDIT_REQUEST_USAGE;
2144
2145 if ^validate_abbrev_name (initial_abbrev_name) then go to RETURN_FROM_PROCESS_REQUEST_LINE;
2146
2147
2148 ape_ptr = lookup_abbrev (initial_abbrev_name);
2149 if ape_ptr = null () then do;
2150 call com_err_ (0, ABBREV, """^a"" is not defined.", initial_abbrev_name);
2151 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2152 end;
2153
2154
2155
2156
2157 call ioa_ ("^[b^;^x^]^x^a^12t^a", ape.bol, ape.name, ape.value);
2158 call ioa_ ("Edit:");
2159
2160
2161
2162
2163 local_qi.version = QEDX_INFO_VERSION_1;
2164 local_qi.editor_name = ABBREV;
2165 local_qi.buffer_io = abbrev_io;
2166
2167 string (local_qi.header.flags) = ""b;
2168 local_qi.query_if_modified, local_qi.caller_does_io = "1"b;
2169
2170 local_qi.n_buffers = 1;
2171 local_qi.buffer_name = "0";
2172 local_qi.buffer_pathname = initial_abbrev_name;
2173 string (local_qi.buffer.flags) = ""b;
2174
2175 call qedx_ (addr (local_qi), (0));
2176
2177 return;
2178 %page;
2179
2180
2181 abbrev_io:
2182 procedure (p_qbii_ptr, p_ok);
2183
2184 dcl p_qbii_ptr pointer parameter;
2185 dcl p_ok bit (1) aligned parameter;
2186
2187 dcl 1 qbii aligned based (qbii_ptr) like qedx_buffer_io_info;
2188 dcl qbii_value character (qbii.buffer_lth) based (qbii.buffer_ptr);
2189 dcl last_ape_ptr pointer;
2190 dcl (old_size, hash_slot) fixed binary (18);
2191 dcl bol bit (1) aligned;
2192 dcl redefine_it bit (1);
2193
2194
2195 qbii_ptr = p_qbii_ptr;
2196
2197 if qbii.version ^= QEDX_BUFFER_IO_INFO_VERSION_1 then do;
2198 call com_err_ (error_table_$unimplemented_version, ABBREV, "Buffer I/O from qedx_.");
2199 p_ok = "0"b;
2200 end;
2201
2202
2203 else if qbii.direction = QEDX_READ_FILE then do;
2204
2205
2206
2207 if validate_abbrev_name (rtrim (qbii.pathname)) then do;
2208 ape_ptr = lookup_abbrev (rtrim (qbii.pathname));
2209
2210 if ape_ptr ^= null () then
2211 if (ape.value_lth + 1) <= qbii.buffer_max_lth then do;
2212 qbii.buffer_lth = ape.value_lth;
2213 qbii_value = ape.value;
2214 if substr (qbii_value, qbii.buffer_lth, 1) ^= NL then do;
2215 qbii.buffer_lth = qbii.buffer_lth + 1;
2216 substr (qbii_value, qbii.buffer_lth, 1) = NL;
2217 end;
2218 p_ok = "1"b;
2219 end;
2220
2221 else do;
2222 call com_err_ (0, qbii.editor_name,
2223 "Definition of ""^a"" is too large for the editor.", qbii.pathname);
2224 p_ok = "0"b;
2225 end;
2226
2227 else do;
2228 call com_err_ (0, qbii.editor_name, """^a"" is not defined.", qbii.pathname);
2229 p_ok = "0"b;
2230 end;
2231 end;
2232
2233 else p_ok = "0"b;
2234 end;
2235
2236
2237 else if qbii.direction = QEDX_WRITE_FILE then do;
2238
2239
2240
2241
2242 if validate_abbrev_name (rtrim (qbii.pathname)) then do;
2243 if substr (qbii_value, qbii.buffer_lth, 1) = NL then qbii.buffer_lth = qbii.buffer_lth - 1;
2244
2245
2246 ape_ptr = lookup_abbrev (rtrim (qbii.pathname));
2247
2248 if ape_ptr ^= null () then do;
2249 bol = ape.bol;
2250
2251 if ^qbii.default_pathname then do;
2252
2253 call command_query_$yes_no (redefine_it, 0, ABBREV, "",
2254 "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it?",
2255 ape.bol, ape.name, ape.value);
2256 if ^redefine_it then do;
2257 p_ok = "0"b;
2258 return;
2259 end;
2260 end;
2261
2262 if ape.value_lth >= qbii.buffer_lth then do;
2263 old_size = currentsize (ape);
2264 ape.value_lth = qbii.buffer_lth;
2265 ape.value = qbii_value;
2266 abbrev_profile.garbage = abbrev_profile.garbage + old_size - currentsize (ape);
2267 end;
2268 else do;
2269 ape.name = "";
2270 abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape);
2271 go to CREATE_NEW_DEFINITION;
2272 end;
2273 end;
2274
2275 else do;
2276 bol = "0"b;
2277 CREATE_NEW_DEFINITION:
2278 ape_ptr = pointer (ap_ptr, abbrev_profile.next_free);
2279 substr (ape.name, 1, length (ape.name)) = substr (qbii.pathname, 1, length (ape.name));
2280 ape.next = 0;
2281 string (ape.flags) = ""b;
2282 ape.bol = bol;
2283 ape.value_lth = qbii.buffer_lth;
2284 ape.value = qbii_value;
2285 abbrev_profile.next_free = abbrev_profile.next_free + currentsize (ape);
2286 hash_slot = rank (substr (qbii.pathname, 1, 1));
2287 if abbrev_profile.hash_table (hash_slot) = 0 then
2288 abbrev_profile.hash_table (hash_slot) = fixed (rel (ape_ptr), 18, 0);
2289 else do;
2290 do last_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (hash_slot))
2291 repeat (pointer (ap_ptr, last_ape_ptr -> ape.next))
2292 while (last_ape_ptr -> ape.next ^= 0);
2293 end;
2294 last_ape_ptr -> ape.next = fixed (rel (ape_ptr), 18, 0);
2295 end;
2296 end;
2297
2298 call compact_profile_if_needed ("1"b);
2299
2300 p_ok = "1"b;
2301 end;
2302
2303 else p_ok = "0"b;
2304 end;
2305
2306
2307 else do;
2308 call com_err_ (error_table_$bad_subr_arg, qbii.editor_name, "Buffer operation type ^d.",
2309 qbii.direction);
2310 p_ok = "0"b;
2311 end;
2312
2313 return;
2314
2315 end abbrev_io;
2316
2317 end do_edit_request;
2318 %page;
2319
2320
2321 do_switch_request:
2322 procedure (p_switch_value);
2323
2324 dcl p_switch_value bit (1) aligned parameter;
2325
2326 dcl (request_name, the_switch, abbrev_name) character (32);
2327 dcl switch_idx fixed binary;
2328 dcl (have_switch, first_abbrev) bit (1) aligned;
2329
2330
2331 dcl SWITCH_NAMES (1, 2) character (32) static options (constant) initial (
2332 "beginning_of_line", "bol");
2333
2334
2335 if ^write_access () then do;
2336 call com_err_ (error_table_$moderr, ABBREV, "Can not change abbreviation switches in profile ^a.",
2337 profile_pathname ());
2338 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2339 end;
2340
2341 if p_switch_value then
2342 request_name = "switch_on";
2343 else request_name = "switch_off";
2344
2345
2346
2347
2348 the_switch = get_token ();
2349
2350 if the_switch = "" then do;
2351 PRINT_SWITCH_REQUEST_USAGE:
2352 call com_err_ (0, ABBREV, "Usage: ^a^a switch_name abbrev_names", abbrev_state.escape_character,
2353 request_name);
2354 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2355 end;
2356
2357 have_switch = "0"b;
2358 switch_idx = 0;
2359
2360 do while (^have_switch & (switch_idx < hbound (SWITCH_NAMES, 1)));
2361 switch_idx = switch_idx + 1;
2362 if (the_switch = SWITCH_NAMES (switch_idx, 1)) | (the_switch = SWITCH_NAMES (switch_idx, 2)) then
2363 have_switch = "1"b;
2364 end;
2365
2366 if ^have_switch then do;
2367 call com_err_ (0, ABBREV, "Unrecognized switch name. ""^a""", the_switch);
2368 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2369 end;
2370
2371
2372
2373
2374 first_abbrev = "1"b;
2375
2376 abbrev_name = "foo";
2377
2378 do while (abbrev_name ^= "");
2379 abbrev_name = get_token ();
2380
2381 if abbrev_name ^= "" then do;
2382 first_abbrev = "0"b;
2383
2384 if validate_abbrev_name (abbrev_name) then do;
2385 ape_ptr = lookup_abbrev (abbrev_name);
2386
2387 if ape_ptr ^= null () then do;
2388 go to SET_SWITCH (switch_idx);
2389
2390 SET_SWITCH (1):
2391 ape.bol = p_switch_value;
2392 go to PROCEED_WITH_NEXT_ABBREVIATION;
2393
2394 PROCEED_WITH_NEXT_ABBREVIATION:
2395 end;
2396
2397 else call com_err_ (0, ABBREV, """^a"" is not defined.", abbrev_name);
2398 end;
2399 end;
2400 end;
2401
2402 if first_abbrev then go to PRINT_SWITCH_REQUEST_USAGE;
2403
2404 return;
2405
2406 end do_switch_request;
2407 %page;
2408
2409
2410 write_access:
2411 procedure () returns (bit (1) aligned);
2412
2413 dcl profile_mode fixed binary (5);
2414
2415 call hcs_$fs_get_mode (ap_ptr, profile_mode, code);
2416 if code ^= 0 then do;
2417 call com_err_ (code, ABBREV, "Can not determine access to profile ^a", profile_pathname ());
2418 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2419 end;
2420
2421 return ((profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN));
2422
2423 end write_access;
2424
2425
2426
2427
2428
2429 validate_abbrev_name:
2430 procedure (p_abbrev_name) returns (bit (1) aligned);
2431
2432 dcl p_abbrev_name character (32) parameter;
2433 dcl abbrev_name character (32) varying;
2434 dcl idx fixed binary;
2435
2436 if length (rtrim (p_abbrev_name)) > length (ape.name) then do;
2437 call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
2438 length (ape.name), p_abbrev_name);
2439 return ("0"b);
2440 end;
2441
2442 abbrev_name = rtrim (p_abbrev_name);
2443
2444 do idx = 1 to breaks_list.n_break_sequences;
2445 begin;
2446 dcl break_sequence character (breaks_list.break_sequences (idx).lth) unaligned
2447 defined (breaks_list.break_strings) position (breaks_list.break_sequences (idx).start);
2448 if index (abbrev_name, break_sequence) ^= 0 then do;
2449 call com_err_ (0, ABBREV, "Abbreviation names may not contain break sequences. ^a in ""^a""",
2450 break_sequence, abbrev_name);
2451 return ("0"b);
2452 end;
2453 end;
2454 end;
2455
2456 return ("1"b);
2457
2458 end validate_abbrev_name;
2459 %page;
2460
2461
2462 skip_whitespace:
2463 procedure ();
2464
2465 dcl idx fixed binary (21);
2466
2467 idx = verify (substr (request_line, (used + 1)), WHITE_SPACE_AND_NL);
2468
2469 if idx = 0 then
2470 used = length (request_line);
2471 else used = used + idx - 1;
2472
2473 return;
2474
2475 end skip_whitespace;
2476
2477
2478
2479
2480
2481
2482 get_token:
2483 procedure () returns (character (32));
2484
2485 dcl (token_start, token_lth, idx) fixed binary (21);
2486
2487 call skip_whitespace ();
2488
2489 if used = length (request_line) then
2490 return ("");
2491
2492 idx = search (substr (request_line, (used + 1)), WHITE_SPACE);
2493 if idx = 0 then
2494 idx = length (request_line) - used + 1;
2495
2496 token_start = used + 1;
2497 token_lth = idx - 1;
2498
2499 used = used + token_lth;
2500
2501 return (substr (request_line, token_start, token_lth));
2502
2503 end get_token;
2504 %page;
2505
2506
2507
2508
2509 set_profile_ptr:
2510 procedure (p_dont_create_profile) ;
2511
2512 dcl p_dont_create_profile bit (1) aligned;
2513
2514 ap_ptr = null ();
2515
2516 if subsystem_entry then
2517 if (P_default_profile_ptr = null ()) & (P_profile_ptr = null ()) then
2518
2519 if abbrev_state.profile_ptr = null () then
2520 call get_default_profile (p_dont_create_profile);
2521
2522 else ap_ptr = abbrev_state.profile_ptr;
2523
2524 else do;
2525 if P_profile_ptr ^= null () then
2526 ap_ptr = P_profile_ptr;
2527 else ap_ptr = P_default_profile_ptr;
2528 call initialize_profile ("1"b, "0"b);
2529 end;
2530
2531 else do;
2532 if abbrev_state.profile_ptr = null () then
2533 call get_default_profile (p_dont_create_profile);
2534
2535 else ap_ptr = abbrev_state.profile_ptr;
2536 end;
2537
2538 return;
2539
2540 end set_profile_ptr;
2541
2542
2543
2544
2545
2546
2547 lookup_abbrev:
2548 procedure (p_name) returns (pointer) ;
2549
2550 dcl p_name character (32) parameter;
2551 dcl offset fixed binary (18);
2552
2553 do offset = abbrev_profile.hash_table (rank (substr (p_name, 1, 1))) repeat (ape.next) while (offset ^= 0);
2554 ape_ptr = pointer (ap_ptr, offset);
2555 if ape.name = p_name then return (ape_ptr);
2556 end;
2557
2558 return (null ());
2559
2560 end lookup_abbrev;
2561 %page;
2562
2563
2564
2565 validate_no_arguments:
2566 procedure (p_request_name);
2567
2568 dcl p_request_name character (*) parameter;
2569
2570 call skip_whitespace ();
2571
2572 if used ^= length (request_line) then do;
2573 call com_err_ (0, ABBREV, "The ""^a^a"" request does not accept arguments.", abbrev_state.escape_character,
2574 p_request_name);
2575 go to RETURN_FROM_PROCESS_REQUEST_LINE;
2576 end;
2577
2578 return;
2579
2580 end validate_no_arguments;
2581
2582
2583
2584
2585
2586 compact_profile_if_needed:
2587 procedure (p_set_bit_count);
2588
2589 dcl p_set_bit_count bit (1) aligned parameter;
2590
2591 if (((4 * abbrev_profile.garbage) > abbrev_profile.next_free) | (abbrev_profile.garbage > 512))
2592 & (abbrev_profile.garbage > mod (abbrev_profile.next_free, 1024)) then
2593 call compact_profile ();
2594
2595
2596 else if p_set_bit_count then
2597 call terminate_file_ (ap_ptr, (36 * abbrev_profile.next_free), TERM_FILE_BC, (0));
2598
2599 return;
2600
2601 end compact_profile_if_needed;
2602 %page;
2603 do_help_request:
2604 proc ();
2605
2606 dcl (element, ndx) fixed binary;
2607
2608 call skip_whitespace ();
2609
2610 if used = length (request_line) then do;
2611 call ioa_ ("Abbrev requests:");
2612 do element = 1 to hbound (abbrev_rqd, 1);
2613 call display_help_line (abbrev_rqd (element));
2614 end;
2615 end;
2616
2617 else do token = get_token () repeat (get_token ()) while (token ^= "");
2618
2619 do element = 1 to hbound (ard, 1);
2620 if ard (element) = rtrim (token) then go to found_request;
2621 end;
2622 call com_err_ (0, ABBREV, """^a"" is not a legal abbrev request.", token);
2623 go to end_request_lookup;
2624 found_request:
2625 element = ardx (element);
2626 do ndx = 0 to 2;
2627 call display_help_line (abbrev_rqd (element + ndx));
2628 end;
2629 end_request_lookup:
2630 end;
2631
2632 return;
2633
2634 display_help_line:
2635 proc (display_line);
2636
2637 dcl display_line char (*) parameter;
2638
2639 if display_line ^= "" then call ioa_ ("^a", display_line);
2640
2641 return;
2642
2643 end display_help_line;
2644
2645 end do_help_request;
2646
2647 end;
2648
2649 RETURN_FROM_PROCESS_REQUEST_LINE:
2650 return;
2651 %page;
2652 %include qedx_info;
2653 %page;
2654 %include qedx_buffer_io_info;
2655
2656 end process_request_line;
2657 %page;
2658
2659
2660 compact_profile:
2661 procedure () options (non_quick);
2662
2663 dcl 1 new_profile aligned based (new_profile_ptr) like abbrev_profile;
2664 dcl new_profile_ptr pointer;
2665
2666 dcl new_profile_words (new_profile.next_free) bit (36) aligned based (new_profile_ptr);
2667
2668 dcl 1 new_ape aligned based (new_ape_ptr),
2669 2 header like ape.header,
2670 2 value character (0 refer (new_ape.value_lth));
2671 dcl new_ape_ptr pointer;
2672
2673 dcl 1 old_profile aligned based (old_profile_ptr) like abbrev_profile;
2674 dcl 1 old_old_profile aligned based (old_profile_ptr),
2675 2 next_free fixed binary (18),
2676 2 pad (3) bit (36),
2677 2 hash_table (4:127) fixed binary (18);
2678 dcl old_profile_ptr pointer;
2679
2680 dcl 1 old_ape aligned based (old_ape_ptr),
2681 2 header like ape.header,
2682 2 value character (0 refer (old_ape.value_lth));
2683 dcl old_ape_ptr pointer;
2684
2685 dcl old_style_profile bit (1) aligned;
2686 dcl old_profile_mode fixed binary (5);
2687 dcl (hash_slot, lower_hash_bound) fixed binary;
2688 dcl (first_offset, old_offset) fixed binary (18);
2689 dcl last_new_ape_ptr pointer;
2690
2691
2692 old_profile_ptr = ap_ptr;
2693 old_style_profile = (old_profile.version > 127);
2694
2695 call hcs_$fs_get_mode (old_profile_ptr, old_profile_mode, code);
2696 if code ^= 0 then
2697 call abort_abbrev_processor (code, "Can not determine access to profile ^a", profile_pathname ());
2698
2699 if (old_profile_mode ^= RW_ACCESS_BIN) & (old_profile_mode ^= REW_ACCESS_BIN) then
2700 if old_style_profile then
2701 call abort_abbrev_processor (error_table_$moderr, "Can not upgrade profile ^a to current version.",
2702 profile_pathname ());
2703 else return;
2704
2705 call get_temp_segment_ (ABBREV, new_profile_ptr, code);
2706 if code ^= 0 then return;
2707
2708 on condition (cleanup)
2709 begin;
2710 if new_profile_ptr ^= null () then call release_temp_segment_ (ABBREV, new_profile_ptr, code);
2711 end;
2712
2713 new_profile.version = ABBREV_PROFILE_VERSION_1;
2714 new_profile.next_free = fixed (rel (addr (new_profile.data_space)), 18, 0);
2715
2716 if old_style_profile then
2717 lower_hash_bound = lbound (old_old_profile.hash_table, 1);
2718 else lower_hash_bound = lbound (old_profile.hash_table, 1);
2719
2720 do hash_slot = lower_hash_bound to hbound (new_profile.hash_table, 1);
2721 last_new_ape_ptr = null ();
2722 if old_style_profile then
2723 first_offset = old_old_profile.hash_table (hash_slot);
2724 else first_offset = old_profile.hash_table (hash_slot);
2725 do old_offset = first_offset repeat (old_ape.next) while (old_offset ^= 0);
2726 old_ape_ptr = pointer (old_profile_ptr, old_offset);
2727 if old_ape.name ^= "" then do;
2728 new_ape_ptr = pointer (new_profile_ptr, new_profile.next_free);
2729 new_ape.header = old_ape.header;
2730 new_ape.next = 0;
2731 new_ape.value = old_ape.value;
2732 new_profile.next_free = new_profile.next_free + currentsize (new_ape);
2733 if last_new_ape_ptr = null () then
2734 new_profile.hash_table (hash_slot) = fixed (rel (new_ape_ptr), 18, 0);
2735 else last_new_ape_ptr -> new_ape.next = fixed (rel (new_ape_ptr), 18, 0);
2736 last_new_ape_ptr = new_ape_ptr;
2737 end;
2738 end;
2739 end;
2740
2741 old_profile_ptr -> new_profile_words = new_profile_ptr -> new_profile_words;
2742
2743 call terminate_file_ (old_profile_ptr, (36 * new_profile.next_free), TERM_FILE_TRUNC_BC, (0));
2744
2745 call release_temp_segment_ (ABBREV, new_profile_ptr, (0));
2746
2747 return;
2748
2749 end compact_profile;
2750 %page;
2751 %include "_abbrev_profile";
2752 %page;
2753 %include access_mode_values;
2754
2755 %include terminate_file;
2756
2757 end abbrev;