1
2
3
4
5
6 dfast_: proc (person_id, arg_home_dir, project_id, tty_line_id, logout_arg);
7
8
9
10 dcl arg_home_dir char (*);
11 dcl project_id char (*);
12 dcl tty_line_id char (*);
13 dcl logout_arg char (*);
14 dcl person_id char (*);
15
16
17
18
19 dcl command_names char (148) int static options (constant) init
20 ("com,edi,lis,tty,bri,nbr,sor,ren,new,uns,sav,rep,old,bui,app,ign,scr,use,bye,goo,hel,PUN,bil,len,sys,exp,ful,hal,one,two,TAP,KEY,DIR,typ,run");
21
22
23
24 dcl READ fixed bin init (1) int static options (constant);
25 dcl SAVE fixed bin init (2) int static options (constant);
26 dcl REPLACE fixed bin init (3) int static options (constant);
27 dcl DELETE fixed bin init (4) int static options (constant);
28 dcl TRUNCATE fixed bin init (6) int static options (constant);
29 dcl APPEND fixed bin init (1) int static options (constant);
30 dcl SORT fixed bin init (2) int static options (constant);
31 dcl BUILD fixed bin int static options (constant) init (5);
32 dcl ALTER fixed bin int static options (constant) init (6);
33 dcl LENGTH fixed bin int static options (constant) init (7);
34 dcl arg_delimit char (4) int static options (constant) init (" ,;");
35 dcl dfast_name char (5) int static options (constant) init ("dfast");
36 dcl white_space char (2) int static options (constant) init (" ");
37 dcl character_set char (68) int static options (constant) init (">._-0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ ");
38 dcl digit char (10) defined (character_set) pos (5);
39 dcl letter char (52) defined (character_set) pos (15);
40 dcl name_char char (68) defined (character_set) pos (1);
41 dcl lowercase_letters char (26) defined (character_set) pos (15);
42 dcl uppercase_letters char (26) defined (character_set) pos (41);
43
44
45
46 dcl input char (256);
47 dcl input_length fixed bin;
48 dcl arg char (256) var;
49 dcl ready bit (1);
50 dcl (length, index, verify, substr, addr, divide, search, null, translate) builtin;
51 dcl (i, num_1, request) fixed bin;
52 dcl header bit (1) unal;
53 dcl sort bit (1) unal;
54 dcl string char (256) var;
55 dcl code fixed bin (35);
56
57 dcl quit condition;
58
59
60
61
62 dcl clock_ entry () returns (fixed bin (71));
63 dcl condition_ entry (char (*), entry);
64 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
65 dcl date_time_ entry (fixed bin (71), char (*));
66 dcl error_table_$long_record fixed bin (35) ext;
67 dcl dfast_command_processor_ entry (ptr, char (*), char (*), fixed bin (35));
68 dcl dfast_compile_ entry (ptr, fixed bin (35));
69 dcl dfast_directory_ entry (fixed bin, char (*), ptr, ptr, fixed bin (35));
70 dcl dfast_edit_ entry (fixed bin, char (*), ptr, fixed bin (35));
71 dcl dfast_error_ entry (fixed bin (35), char (*), char (*));
72 dcl dfast_explain_ entry (char (*) var, char (*), fixed bin (35));
73 dcl dfast_line_edit_ entry (char (256) var, ptr, bit (1) unal, fixed bin (35));
74 dcl dfast_list_ entry (ptr, char (*), fixed bin, bit (1) unal, bit (1) unal, fixed bin (35));
75 dcl dfast_merge_ entry (bit (1), ptr, fixed bin (35));
76 dcl fast_related_data_$in_fast_or_dfast bit (1) aligned ext;
77 dcl fast_related_data_$in_dfast bit (1) aligned ext;
78 dcl dfast_run_ entry (ptr, fixed bin (35));
79 dcl dfast_set_system_ entry (char (256) var, bit (1) unal, char (*), fixed bin (35));
80 dcl dfast_terminal_control_ entry (fixed bin, char (*), ptr, fixed bin (35));
81 dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
82 dcl hmu entry options (variable);
83 dcl ioa_$ioa_switch entry options (variable);
84 dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin, fixed bin (35));
85 dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35));
86 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
87 dcl iox_$user_input ptr ext static;
88 dcl iox_$user_output ptr ext static;
89 dcl resource_usage entry ();
90
91 dcl sys_info$max_seg_size fixed bin (35) ext;
92
93 dcl edit_info_ptr ptr;
94 dcl 1 f aligned like dfast_edit_info;
95 %include dfast_edit_info;
96 %include dfast_error_codes;
97
98
99 call initial;
100 if code ^= 0 then return;
101 on quit begin;
102 ready = "1"b;
103 call iox_$control (iox_$user_input, "resetread", addr (input), code);
104 call ioa_$ioa_switch (iox_$user_output, "QUIT^/");
105 goto READY;
106 end;
107 call condition_ ("any_other", any_other_handler);
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123 READY:
124 do while ("1"b);
125 if ready then do;
126 call date_time_ (clock_ (), input);
127 call ioa_$ioa_switch (iox_$user_output, "ready ^a^/", substr (input, 11, 4));
128 end;
129 ready = "0"b;
130
131 call iox_$get_line (iox_$user_input, addr (input), 256, input_length, code);
132
133 if code ^= 0 then do;
134 if code = error_table_$long_record then call dfast_error_ (error_long_rec, "", "");
135 end;
136
137 else if f.build_mode then do;
138 if input_length = 1 then do;
139 f.build_mode = "0"b;
140 ready = "1"b;
141 end;
142
143 else call dfast_edit_ (BUILD, substr (input, 1, input_length), edit_info_ptr, code);
144 end;
145
146 else do;
147 i = verify (substr (input, 1, input_length -1), white_space);
148
149 if i > 0 then do;
150 if index (digit, substr (input, i, 1)) > 0
151 then call dfast_edit_ (ALTER, substr (input, i, input_length - i + 1), edit_info_ptr, code);
152
153 else do;
154 if ^f.brief_mode then ready = "1"b;
155
156 if index (letter, substr (input, i, 1)) > 0
157 then call command (substr (input, i, input_length - i), code);
158 else call multi_command ((i));
159 end;
160 end;
161 end;
162
163 end;
164
165 RETURN: return;
166
167
168
169
170
171
172
173
174
175
176 get_arg: proc (line, argument) returns (bit (1));
177
178 dcl argument char (256) var;
179
180 dcl line char (256) var;
181 dcl line_length fixed bin;
182 dcl argument_length fixed bin;
183 dcl start fixed bin;
184
185 line_length = length (line);
186
187 if line_length > 0 then do;
188
189 start = verify (line, white_space);
190 if start > 0 then do;
191 argument_length = search (substr (line, start), arg_delimit);
192
193 if argument_length = 0 then argument_length = line_length - start + 1;
194 else argument_length = argument_length - 1;
195 argument = substr (line, start, argument_length);
196 start = start + argument_length + 1;
197 if start > line_length then line = "";
198 else line = substr (line, start, line_length - start + 1);
199
200 return ("1"b);
201 end;
202 end;
203 return ("0"b);
204 end get_arg;
205
206
207 line_number: proc (string, num) returns (bit (1));
208 dcl string char (*) var;
209 dcl num fixed bin;
210
211 num = cv_dec_check_ ((string), code);
212 if code = 0 then do;
213 if num > 0 then return ("1"b);
214 else call dfast_error_ (error_bad_line, "", (arg));
215 end;
216 else return ("0"b);
217 end line_number;
218
219
220
221
222
223
224
225
226
227
228
229
230
231 get_name: proc (line, name, request, code);
232
233 dcl line char (256) var;
234 dcl name char (*) var;
235 dcl request bit (1);
236 dcl code fixed bin (35);
237
238 if ^get_arg (line, arg) then do;
239 if ^request then do;
240 name = "";
241 return;
242 end;
243
244 call get_user_response ("0"b, "enter name: ", arg);
245 if arg = "" then code = error_name_miss;
246 end;
247
248 if code = 0 then do;
249 if verify (arg, name_char) > 0 then code = error_bad_name;
250 else name = arg;
251 end;
252
253 if code ^= 0 then if code ^= error_name_miss then call dfast_error_ (code, dfast_name, (arg));
254
255 return;
256
257 end get_name;
258
259
260
261
262
263
264
265 command: proc (line, code);
266
267 dcl line char (256) var;
268 dcl code fixed bin (35);
269
270 if get_arg (line, arg) then do;
271 arg = translate (arg, lowercase_letters, uppercase_letters);
272 if length ((arg)) > 2 then do;
273 request = index (command_names, substr (arg, 1, 3));
274 if request ^= 0 then do;
275 request = divide (request +3, 4, 17);
276 goto command_label (request);
277 end;
278 end;
279 call dfast_command_processor_ (edit_info_ptr, (arg), (line), code);
280 end;
281
282 return;
283
284
285
286
287
288 command_label (1):
289
290 if get_arg (line, arg) then call set_system (code);
291 if code = 0 then call dfast_compile_ (edit_info_ptr, code);
292 return;
293
294
295
296
297 command_label (2):
298 if arg = "editns" | arg = "edins" then sort = "0"b;
299 else sort = "1"b;
300
301 call dfast_line_edit_ (line, edit_info_ptr, sort, code);
302 return;
303
304
305
306
307
308 command_label (3):
309
310 if f.brief_mode then header = "0"b;
311 else if substr (arg, length (arg), 1) = "n" then header = "0"b;
312 else if substr (arg, length (arg) -1, 2) = "nh" then header = "0"b;
313 else header = "1"b;
314
315 call parse_list_punch (line, header, "0"b);
316
317 return;
318
319
320 command_label (4):
321
322 if f.basic_system then if f.dbasic then string = "dbasic";
323 else string = "basic";
324 else string = "fortran";
325 call ioa_$ioa_switch (iox_$user_output, "name = ^a, system = ^a, user = ^a.^a, line = ^a",
326 f.current_name, string, person_id, project_id, tty_line_id);
327
328 return;
329
330
331 command_label (5):
332 f.brief_mode = "1"b;
333 ready = "0"b;
334
335 return;
336
337
338 command_label (6):
339
340 f.brief_mode = "0"b;
341 return;
342
343
344 command_label (7):
345
346 call dfast_edit_ (SORT, "", edit_info_ptr, code);
347 return;
348
349
350
351
352 command_label (8):
353 command_label (9):
354
355 call get_name (line, string, "1"b, code);
356 if code = 0 then do;
357 if index (string, ">") = 0 then do;
358 f.current_name = string;
359 call dfast_set_system_ (f.current_name, f.basic_system, "", 0);
360 end;
361 else do;
362 code = error_bad_name;
363 call dfast_error_ (code, "name", (string));
364 end;
365 end;
366 else if code = error_name_miss then code = 0;
367 if request = 9 then call reset_edit_info;
368
369 return;
370
371
372
373
374
375 command_label (10):
376
377 call segment_control (line, DELETE);
378 return;
379
380
381
382 command_label (11):
383
384 call segment_control (line, SAVE);
385 return;
386
387
388
389 command_label (12):
390
391 call segment_control (line, REPLACE);
392 return;
393
394
395
396 command_label (13):
397
398 call segment_control (line, READ);
399 if code = 0 then do;
400 if f.source_segment then do;
401 call dfast_set_system_ (f.current_name, f.basic_system, "", code);
402 if code ^= 0 then do;
403 code = 0;
404 if get_arg (line, arg) then call set_system (code);
405 else do;
406 call get_user_response ("0"b, "enter system name: ", arg);
407 call set_system (code);
408 do while (code ^= 0);
409 call get_user_response ("1"b, "answer 'basic', 'dbasic', or 'fortran': ", arg);
410 call set_system (code);
411 end;
412 end;
413 end;
414 end;
415 end;
416 return;
417
418
419 command_label (14):
420
421 if ^f.source_segment then call dfast_error_ (error_obj_nop, "build", "");
422 else do;
423 if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
424 if code = 0 then f.build_mode = "1"b;
425 end;
426
427 return;
428
429
430 command_label (15):
431
432 call dfast_edit_ (APPEND, "", edit_info_ptr, code);
433 return;
434
435
436 command_label (16):
437
438 f.alter_length = 0;
439 return;
440
441
442 command_label (17):
443
444 if verify (line, white_space) = 0 then call reset_edit_info;
445 else call segment_control (line, TRUNCATE);
446
447 return;
448
449
450
451 command_label (18):
452
453 call hmu ();
454 return;
455
456
457 command_label (19):
458 command_label (20):
459
460 logout_arg = "";
461 call bye_request;
462 return;
463
464
465
466
467
468
469 command_label (21):
470
471 if arg = "hello" then do;
472 logout_arg = "-hold";
473 call bye_request;
474 return;
475 end;
476
477 else call dfast_explain_ ("", "help", code);
478 return;
479
480
481 command_label (22):
482
483 call parse_list_punch (line, "0"b, "1"b);
484 return;
485
486
487
488 command_label (23):
489
490 call resource_usage;
491 return;
492
493
494 command_label (24):
495
496 call dfast_edit_ (LENGTH, "", edit_info_ptr, code);
497 return;
498
499
500
501 command_label (25):
502
503 if ^get_arg (line, arg) then call get_user_response ("1"b, "enter system: ", arg);
504
505 call set_system (code);
506
507 return;
508
509
510
511 command_label (26):
512
513 call dfast_explain_ (line, "explain", code);
514 return;
515
516
517
518
519
520
521
522
523
524
525
526 command_label (27):
527 command_label (28):
528 command_label (29):
529 command_label (30):
530 command_label (31):
531 command_label (32):
532 command_label (33):
533
534 call dfast_terminal_control_ (request - 26, "", edit_info_ptr, code);
535 if request = 33 then ready = "1"b;
536 return;
537
538
539
540
541
542 command_label (34):
543
544 if ^get_arg (line, arg) then arg = "";
545 call dfast_terminal_control_ (request - 26, (arg), edit_info_ptr, code);
546 return;
547
548
549
550 command_label (35):
551
552 if get_arg (line, arg) then call set_system (code);
553 if code = 0 then call dfast_run_ (edit_info_ptr, code);
554 return;
555
556 end command;
557
558
559
560
561
562
563
564
565 segment_control: proc (line, action);
566
567 dcl line char (256) var;
568 dcl action fixed bin;
569 dcl request bit (1);
570
571 if f.current_name = "no name" then request = "1"b;
572 else request = "0"b;
573
574 call get_name (line, string, request, code);
575
576 if code = error_name_miss then call dfast_error_ (code, dfast_name, "");
577 else if code = 0 then do;
578 if string = "" then string = f.current_name;
579 call dfast_directory_ (action, (string), edit_info_ptr, null, code);
580 if action ^= DELETE then f.edit_done = "0"b;
581 end;
582
583 return;
584
585 end segment_control;
586
587
588
589
590
591
592
593
594
595 get_user_response: proc (repeat, message, response);
596
597 dcl repeat bit (1);
598 dcl message char (*);
599 dcl response char (*) var;
600
601 dcl temp_buffer char (256);
602 dcl amt_read fixed bin;
603 dcl start fixed bin;
604 dcl num_chars fixed bin;
605
606 response = "";
607
608 do while ("1"b);
609 call iox_$put_chars (iox_$user_output, addr (message), length (message), code);
610 call iox_$get_line (iox_$user_input, addr (temp_buffer), 256, amt_read, code);
611 amt_read = amt_read - 1;
612 if amt_read > 0 then do;
613 start = verify (substr (temp_buffer, 1, amt_read), white_space);
614 if start > 0 then do;
615 num_chars = index (substr (temp_buffer, start, amt_read), white_space) -1;
616 if num_chars = -1 then num_chars = amt_read - start + 1;
617 response = substr (temp_buffer, start, num_chars);
618 return;
619 end;
620 end;
621
622 if ^repeat then return;
623 end;
624
625 end get_user_response;
626
627
628
629
630
631
632
633 set_system: proc (code);
634
635 dcl code fixed bin (35);
636 dcl tag char (7);
637
638 string = substr (arg, 1, 3);
639 if f.source_segment then do;
640 call dfast_set_system_ (f.current_name, f.basic_system, tag, (0));
641 if string = "bas" | string = "dba" then do;
642 if tag = "fortran" then code = error_name_sys;
643 if code = 0 then do;
644 f.basic_system = "1"b;
645 if string = "dba" then f.dbasic = "1"b;
646 else f.dbasic = "0"b;
647 end;
648 end;
649
650 else if string = "for" then do;
651 if tag = "basic" then code = error_name_sys;
652 if code = 0 then f.basic_system, f.dbasic = "0"b;
653 end;
654 else code = error_unkn_sys;
655 end;
656
657 else do;
658 if string = "bas" & f.basic_system & ^f.dbasic then;
659 if string = "dba" & f.basic_system & f.dbasic then;
660 else if string = "for" then if ^f.basic_system then;
661 else code = error_obj_nop;
662 end;
663
664 if code ^= 0 then do;
665 if code = error_name_sys then arg = f.current_name;
666 call dfast_error_ (code, "system", (arg));
667 end;
668
669 return;
670
671 end set_system;
672
673
674
675
676
677
678 multi_command: proc (start);
679
680 dcl start fixed bin;
681 dcl command_delimitor char (1);
682 dcl len fixed bin;
683
684 command_delimitor = substr (input, start, 1);
685 start = start + 1;
686 input_length = input_length - 1;
687
688 code = 0;
689 do while (start <= input_length & code = 0);
690
691 len = index (substr (input, start, input_length - start + 1), command_delimitor);
692 if len = 0 then len = input_length - start +2;
693 call command (substr (input, start, len -1), code);
694
695 start = start + len;
696 end;
697
698 return;
699
700 end multi_command;
701
702
703
704
705 reset_edit_info: proc;
706
707 f.current_length = 0;
708 f.alter_length = 0;
709 f.edit_done = "0"b;
710 f.source_segment = "1"b;
711
712 return;
713
714 end reset_edit_info;
715
716
717
718
719
720
721
722
723
724
725
726
727
728 parse_list_punch: proc (line, header, punch);
729
730 dcl line char (256) var;
731 dcl header bit (1) unal;
732 dcl punch bit (1) unal;
733
734 num_1 = -1;
735 string = "";
736 if get_arg (line, arg) then do;
737 string = substr (arg, 1, 3);
738 if string = "cur" | string = "alt" then do;
739 if get_arg (line, arg) then do;
740 if ^line_number (arg, num_1) then code = error_unknown_arg;
741 end;
742 end;
743 else do;
744 string = "";
745 if ^line_number (arg, num_1) then code = error_unknown_arg;
746 end;
747
748 end;
749
750 if code = 0 then call dfast_list_ (edit_info_ptr, (string), num_1, header, punch, code);
751
752 else do;
753 if punch then string = "punch";
754 else string = "list";
755 call dfast_error_ (code, (string), (arg));
756 end;
757
758 return;
759
760 end parse_list_punch;
761
762
763 bye_request: proc;
764
765
766 if f.edit_done | f.alter_length > 0 then do;
767 call get_user_response ("0"b, "editing will be lost if you quit. Do you want to quit ? ", arg);
768 do while ("1"b);
769 if arg = "yes" | arg = "YES" then goto RETURN;
770 if arg = "no" | arg = "NO" then return;
771 call get_user_response ("1"b, "answer 'yes' or 'no': ", arg);
772 end;
773 end;
774 goto RETURN;
775
776
777 end bye_request;
778
779
780
781
782 initial: proc;
783
784 dcl ptr_array (2) ptr based;
785
786 code = 0;
787 edit_info_ptr = addr (f);
788 f.home_dir = arg_home_dir;
789 f.current_ptr = null;
790 call get_temp_segments_ (dfast_name, addr (f.current_ptr) -> ptr_array, code);
791 if code ^= 0 then call dfast_error_ (code, dfast_name, "current_segment");
792 f.max_seg_size = sys_info$max_seg_size;
793
794 f.current_name = "no name";
795 f.basic_system = "1"b;
796 f.brief_mode, f.build_mode = "0"b;
797 call reset_edit_info;
798
799 fast_related_data_$in_fast_or_dfast = "1"b;
800 fast_related_data_$in_dfast = "1"b;
801
802
803 ready = "1"b;
804
805 return;
806
807 end initial;
808
809
810 any_other_handler: proc (mcptr, cond_name, wcptr, info_ptr, cont);
811
812 dcl mcptr ptr,
813 cond_name char (*),
814 wcptr ptr,
815 info_ptr ptr,
816 cont bit (1) aligned;
817 dcl area area (300);
818 dcl (i, l) fixed bin;
819 dcl NEW_LINE char (1) init ("
820 ");
821 dcl message_len fixed bin (21);
822 dcl message char (message_len) based (message_ptr);
823 dcl message_ptr ptr;
824
825 dcl condition_interpreter_ entry (ptr, ptr, fixed bin (21), fixed bin, ptr, char (*), ptr, ptr);
826
827 if cond_name = "command_error" |
828 cond_name = "command_question" | cond_name = "string_size" then return;
829
830 call condition_interpreter_ (addr (area), message_ptr, message_len, 1, mcptr, cond_name, wcptr, info_ptr);
831 if cond_name = "command_abort_" then goto READY;
832 if message_len > 0 then do;
833
834
835
836
837
838
839
840 if substr (message, 2, 6) = "Error:" then do;
841 l = index (substr (message, 2), NEW_LINE);
842 if l > 0 then do;
843 i = index (substr (message, 2, l), "by !");
844 if i > 0 then do;
845 i = i + 4;
846 if substr (message, i+15, 5) = ".temp" & substr (message, i + 25, 1) = "$" then do;
847 substr (message, i) = substr (message, i+26, message_len - i -26+1);
848 message_len = message_len - 26;
849 i = index (substr (message, 1, l+1), "(in process dir)");
850 if i > 0 then do;
851 substr (message, i) = substr (message, i+16);
852 message_len = message_len - 16;
853 end;
854 end;
855 end;
856 end;
857 end;
858
859 call iox_$put_chars (iox_$user_output, message_ptr, message_len, code);
860 end;
861
862 if cond_name = "finish" then return;
863
864 goto READY;
865
866 end any_other_handler;
867
868 end dfast_;