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 debug
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46 debug
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69 cobol:
70 proc;
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94 id:
95 entry;
96
97 string (trace) = ""b;
98 MODE = 0;
99 go to start;
100
101
102 trace:
103 entry;
104
105 string (trace) = "1000"b;
106 MODE = 0;
107
108 go to start;
109
110 rw:
111 entry;
112
113
114 MODE = 5;
115 go to start;
116
117 gcos:
118 entry;
119
120
121 call set_mode (1);
122 go to start;
123
124 ibm_ansi:
125 entry;
126
127
128 call set_mode (2);
129 go to start;
130
131 ibm_ef:
132 entry;
133
134
135 call set_mode (3);
136 go to start;
137
138 multics:
139 entry;
140
141
142 call set_mode (4);
143 go to start;
144
145 copy_file_size:
146 entry (bc);
147
148
149 call cobol_merge$copy_file_size (bc);
150 return;
151
152
153 dcl cobol_merge$copy_file_size
154 entry (fixed bin (24));
155 dcl bc fixed bin (24);
156
157 push_name:
158 entry (dir_name, entryname);
159
160
161
162
163
164
165 dcl dir_name char (168);
166 dcl entryname char (32);
167
168 call hcs_$status_long (dir_name, entryname, 1, addr (branch_status), null (), mcode);
169
170 c_name.ct = c_name.ct + 1;
171
172
173 allocate source_name in (cobol_area) set (source_name_ptr);
174
175 source_name.prev_name_ptr = c_name.last_name_ptr;
176 c_name.last_name_ptr = source_name_ptr;
177
178 l_dn = index (dir_name, " ") - 1;
179 l_en = index (entryname, " ") - 1;
180
181 source_name.sname = substr (dir_name, 1, l_dn) || ">" || substr (entryname, 1, l_en);
182
183 source_name.uid = branch_status.uid;
184 source_name.dtm = branch_status.dtcm;
185
186 return;
187
188
189 pop_name:
190 entry returns (ptr);
191
192
193
194
195
196 if c_name.last_name_ptr = null ()
197 then return (null ());
198
199 c_name.pname = c_name.last_name_ptr -> source_name.sname;
200
201 c_name.uid = c_name.last_name_ptr -> source_name.uid;
202
203 c_name.dtm = c_name.last_name_ptr -> source_name.dtm;
204
205 c_name.last_name_ptr = c_name.last_name_ptr -> source_name.prev_name_ptr;
206
207 c_name.size = index (c_name.pname, " ") - 1;
208 if c_name.size = -1
209 then c_name.size = 168;
210
211 return (addr (c_name));
212
213
214
215 alloc:
216 entry (alloc_size) returns (ptr);
217
218 declare alloc_size fixed bin (35);
219
220 allocate words in (cobol_area) set (source_name_ptr);
221
222
223 return (source_name_ptr);
224
225
226 clean_up:
227 entry;
228
229
230
231
232
233 if fpath ^= ""
234 then do segname = "cobol_seg1_", "cobol_seg2_", "cobol_seg3_", "cobol_initval_", "cobol_ntbuff_",
235 "cobol_minpral-1_", "cobol_minpral-2_",
236 "rwdd.incl.cobol", "rwpd.incl.cobol", "cobol_rmin2_", "cobol_r2min2_", "cobol_print_", "cobol_diags_",
237 "cobol_pdout_", "cobol_corrout_", "cobol_minpral-1_1", "cobol_minpral-2_1", "cobol_rmin2_1",
238 "cobol_pdout_1", "cobol_minpral-1_2", "cobol_minpral-2_2", "cobol_rmin2_2", "cobol_pdout_2",
239
240
241
242
243
244 "cobol_common_", "cobol_name_table_", "cobol_format_temp_";
245
246 call hcs_$delentry_file (fpath, segname, mcode);
247
248 end;
249
250 return;
251
252
253
254
255 restart:
256 entry;
257
258 if ^restart
259 then return;
260
261 if abort_sw
262 then go to finish;
263 else abort_sw = "1"b;
264
265 if intact
266 then call cu_$cl;
267 else if endgen_sw
268 then go to finish;
269 else if gen_sw
270 then go to no_gen;
271 else go to start_print_diag;
272
273 define_data:
274 entry;
275
276
277 call ided;
278 call dd;
279
280
281 return;
282
283
284
285
286 start:
287
288
289 if recursion
290 then do;
291
292
293 call ioa_$ioa_stream ("error_output",
294 "cobol: Translation failed. Attempt to invoke COBOL recursively use release first.");
295
296
297 return;
298 end;
299 else recursion = "1"b;
300
301
302 lex_quit = LEX_QUIT;
303 comp_term = COMP_TERM;
304
305
306
307
308 on command_abort call COND ("command_abort");
309 on command_abort_ call COND ("command_abort_");
310 on cleanup call CLEANUP;
311
312
313 restart = "0"b;
314 cobol_sfp = null ();
315 cobol_x2_fileno = 0;
316 p_err = "0"b;
317 area_info_area.areap = null ();
318
319 call cu_$af_arg_count (pc, mcode);
320
321 if mcode = 0
322 then do;
323
324 call com_err_ (0, "cobol", "This command may not be invoked as an active function");
325 go to comp_term;
326
327 end;
328 else if mcode ^= error_table_$not_act_fnc
329 then do;
330
331 call com_err_ (mcode, "cobol");
332 go to comp_term;
333
334 end;
335
336 if pc = 0
337 then
338 do;
339
340 call print_options;
341 go to comp_term;
342
343 end;
344
345
346
347 call init_cobol;
348
349
350 do i = 1 to pc;
351
352
353 call cu_$arg_ptr (i, arg_ptr, l, mcode);
354
355
356 call option;
357
358
359 end;
360
361
362 call setup;
363
364 call expand_phase;
365
366
367
368
369 call lex;
370
371
372 call cobol$define_data;
373
374
375 call ddalloc;
376
377
378 call replace;
379
380
381 call db_corr; debug
382
383
384
385
386
387
388 if time
389 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
390
391 fixed_common.syntax_trace = trace.pd;
392
393
394 call cobol_pdstax;
395
396
397 if mcode ^= 0
398 then return;
399
400 call cobol_swf_close (cobol_dfp, ST, tptr, 0);
401
402 if time
403 then call timer ("PD_SYNTAX.....");
404
405 start_print_diag:
406 call print_diag;
407 call generator;
408
409 no_gen:
410 endgen_sw = "1"b;
411
412
413 call analyzer;
414
415
416 if fixed_common.fatal_no = 0 & opts.cu & ^abort_sw
417 then call fixup;
418
419 finish:
420 call finish_proc;
421
422 return;
423
424
425
426
427 arg_error:
428 call com_err_ (error_table_$badopt, "cobol", argb);
429
430 go to COMP_TERM;
431
432 missing_arg_error:
433 call com_err_ (error_table_$noarg, "cobol");
434
435 go to COMP_TERM;
436
437
438
439 multics_error:
440 segname = "";
441
442 multics_file_error:
443 call com_err_ (mcode, "cobol", " ^a", segname);
444
445 COMP_TERM:
446 call finis;
447
448 recursion = "0"b;
449 return;
450
451 LEX_QUIT:
452 call CLEANUP;
453 call finis;
454
455
456 return;
457
458
459
460
461
462 set_mode:
463 proc (num);
464
465
466 declare num fixed bin;
467
468
469 MODE = num;
470 string (trace) = ""b;
471
472 end;
473
474 ssv:
475 proc;
476
477
478 declare ch char (1);
479
480
481 call cl_arg_check;
482
483
484 if m ^= 1
485 then go to arg_error;
486
487
488 ch = substr (argb, 1, 1);
489
490
491 if ch < "1" | ch > "4"
492 then go to arg_error;
493
494
495 call setsv (ch);
496
497
498 substr (arg, l, 2) = " " || ch;
499 l = l + 2;
500
501 end;
502
503 slv:
504 proc;
505
506
507 declare (ch1, ch2) char (1);
508
509
510 ch2 = " ";
511
512
513 call cl_arg_check;
514
515
516 ch1 = substr (argb, 1, 1);
517
518
519 if ch1 < "1" | ch1 > "5"
520 then go to arg_error;
521
522
523 if m = 1
524 then call setlev (ch1, "3");
525 else if m = 2
526 then do;
527 ch2 = substr (argb, 2, 1);
528
529
530 if ch2 < "1" | ch2 > "3"
531 then go to arg_error;
532
533
534 call setlev (ch1, ch2);
535 end;
536 else go to arg_error;
537
538
539 substr (arg, l, 3) = " " || ch1 || ch2;
540 l = l + 3;
541
542 end;
543
544 cl_arg_check:
545 proc;
546
547
548 if i = pc
549 then go to arg_error;
550
551
552 i = i + 1;
553
554
555 call cu_$arg_ptr (i, arg_ptr, m, mcode);
556
557
558 if mcode ^= 0
559 then go to multics_error;
560
561 end;
562
563 comp_env:
564 proc;
565
566
567
568
569 go to M (MODE);
570
571 M (0):
572 go to MM;
573
574 M (1):
575
576 fixed_common.compile_mode = "101"b;
577
578
579 go to MM;
580
581 M (2):
582
583 fixed_common.compile_mode = "01"b;
584
585
586 go to MM;
587
588 M (3):
589
590 fixed_common.compile_mode = "01"b;
591
592
593 go to MM;
594
595 M (4):
596
597 fixed_common.compile_mode = "00011"b;
598
599
600 go to MM;
601
602 M (5):
603
604 go to MM;
605
606
607
608
609
610
611
612 MM:
613 end;
614
615
616 init_cobol:
617 proc;
618
619
620
621 upto = 0;
622 cobol_options = "";
623 cobol_options_len = 1;
624
625 string (opts) = ""b;
626 opts.pd = "1"b;
627 opts.cu = "1"b;
628 opts.m_wn = "1"b;
629 opts.m_fat = "1"b;
630
631 opts.pst = "1"b;
632
633 cobol_xlast8 = "0"b;
634 time = "0"b;
635 intact = "0"b;
636 opts.card = "0"b;
637 opts.exp, expand = "0"b;
638 COMP_LEVEL = "5";
639 LEVSV = "001"b;
640 ddsyn_sw = "0"b;
641 repl_sw = "0"b;
642
643 rel = 1;
644
645 files_wd = "0"b;
646 temp_dir_sw = "0"b;
647 gen_sw = "0"b;
648 endgen_sw = "0"b;
649 abort_sw = "0"b;
650
651
652 no_tbl_pres, tbl_pres = "0"b;
653
654
655 call init;
656
657
658 if code ^= 0
659 then go to multics_error;
660
661 end;
662
663 option:
664 proc;
665
666 if substr (argb, 1, 1) = "-"
667 then do;
668
669 arg = substr (argb, 2);
670
671
672 if arg = "table" | arg = "tb"
673 then do;
674 opts.pst = "1"b;
675 tbl_pres = "1"b;
676 end;
677 else if arg = "symbols" | arg = "sb" | arg = "source" | arg = "sc"
678 then call ioa_ ("cobol: Option ^a is obsolete, use -ls or -map (see cobol command)", argb);
679 else if arg = "map"
680 then do;
681
682 opts.exs = "1"b;
683 opts.m_map = "1"b;
684 opts.xrn = "1"b;
685
686 end;
687
688
689 else
690 if substr (arg, 1, 8) = "severity"
691 then do;
692 if l = 10
693 then call setsv (substr (arg, 9, 1));
694
695 else
696 if l = 11
697 then call setsv (substr (arg, 9, 1));
698
699 else
700 if l = 9
701 then call ssv;
702 else go to arg_error;
703 end;
704 else
705 if substr (arg, 1, 2) = "sv"
706 then do;
707 if l = 4
708 then call setsv (substr (arg, 3, 1));
709
710 else
711 if l = 5
712 then call setsv (substr (arg, 3, 1));
713
714 else
715 if l = 3
716 then call ssv;
717 else go to arg_error;
718 end;
719
720 else if arg = "brief" | arg = "bf"
721 then opts.m_bf = "1"b;
722 else if arg = "format" | arg = "fmt"
723 then opts.fmt = "1"b;
724 else if arg = "runtime_check" | arg = "rck"
725 then opts.oc = "1"b;
726 else if arg = "profile" | arg = "pf"
727 then opts.profile, opts.pst = "1"b;
728 else if arg = "check" | arg = "ck"
729 then opts.cu = "0"b;
730 else if arg = "list" | arg = "ls"
731 then do;
732
733 opts.exs = "1"b;
734 opts.xrn = "1"b;
735 opts.obj = "1"b;
736
737 end;
738 else if arg = "no_warning" | arg = "nw"
739 then opts.nw = "1"b;
740 else if arg = "expand" | arg = "exp"
741 then opts.exp, expand = "1"b;
742
743 else if arg = "card"
744 then opts.card = "1"b;
745 else if arg = "time" | arg = "tm"
746 then time = "1"b;
747 else if arg = "debug" | arg = "db"
748 then do;
749
750 intact = "1"b;
751 rel = 0;
752
753 end;
754 else
755 if arg = "no_table" | arg = "ntb"
756 then do;
757 opts.pst = "0"b;
758 no_tbl_pres = "1"b;
759 end;
760 else if arg = "temp_dir" | arg = "td"
761 then do;
762
763 files_wd = "1"b;
764 temp_dir_sw = "1"b;
765 i = i + 1;
766
767 if i > pc
768 then go to missing_arg_error;
769
770 call cu_$arg_ptr (i, arg_ptr, l, mcode);
771 if mcode ^= 0
772 then go to multics_error;
773
774 if substr (argb, 1, 1) = "-"
775 then go to missing_arg_error;
776
777
778
779
780 call expand_pathname_ (argb, dpath, en_1, mcode);
781
782 if mcode ^= 0
783 then do;
784
785 PATHNAME_ERROR:
786 call com_err_ (mcode, "cobol", "^a", argb);
787
788 go to comp_term;
789
790 end;
791
792 call absolute_pathname_ (argb, fpath, mcode);
793
794
795 if mcode ^= 0
796 then goto PATHNAME_ERROR;
797
798 if fpath ^= ">"
799 then do;
800
801 call hcs_$status_minf (dpath, en_1, 1, entry_type, (0), mcode);
802
803 if mcode ^= 0
804 then do;
805
806 call com_err_ (mcode, "cobol", "^a", fpath);
807 go to comp_term;
808
809 end;
810
811 if entry_type ^= DIRECTORY
812 then do;
813
814 call com_err_ (error_table_$notadir, "cobol", "^a", fpath);
815 go to comp_term;
816
817 end;
818
819 end;
820
821
822
823 end;
824 else if arg = "working_dir" | arg = "wd"
825 then do;
826
827 files_wd = "1"b;
828 fpath = get_wdir_ ();
829
830 call ioa_ (
831 "cobol: Obsolete -working_dir option accepted: use ""-temp_dir [wd]"" in future.");
832
833 end;
834 else if trace.on & substr (arg, 1, 5) = "trace"
835 then do;
836
837 trace_arg = arg;
838
839 if substr (arg, 6, 2) = "id"
840 then trace.id = "1"b;
841 else if substr (arg, 6, 2) = "dd"
842 then trace.dd = "1"b;
843 else if substr (arg, 6, 2) = "pd"
844 then trace.pd = "1"b;
845 else if substr (arg, 6, 2) = "db"
846 then trace.db = "1"b;
847 else if substr (arg, 6, 2) = "rw"
848 then trace.rw = "1"b;
849 else go to arg_error;
850
851 call cobol_syntax_trace_$reset_trace;
852 call cobol_syntax_trace_$initialize (addr (trace_arg));
853
854 end;
855 else
856 if substr (arg, 1, 5) = "level"
857 then do;
858 if l = 7
859 then call setlev (substr (arg, 6, 1), "3");
860
861 else
862 if l = 8
863 then call setlev (substr (arg, 6, 1), substr (arg, 7, 1));
864
865 else
866 if l = 6
867 then call slv;
868 else go to arg_error;
869 end;
870 else
871 if substr (arg, 1, 3) = "lev"
872 then do;
873 if l = 5
874 then call setlev (substr (arg, 4, 1), "3");
875
876 else
877 if l = 6
878 then call setlev (substr (arg, 4, 1), substr (arg, 5, 1));
879
880 else
881 if l = 4
882 then call slv;
883 else go to arg_error;
884 end;
885 else go to arg_error;
886
887 if temp_dir_sw
888 then do;
889
890 temp_dir_sw = "0"b;
891 substr (cobol_options, cobol_options_len, 9) = "temp_dir,";
892
893 end;
894 else substr (cobol_options, cobol_options_len, l + 1) = substr (arg, 1, l - 1) || ",";
895
896 cobol_options_len = cobol_options_len + l + 1;
897
898 end;
899 else do;
900
901 if p_err = "0"b
902 then do;
903
904 tpath = argb;
905 ltp = l;
906 p_err = "1"b;
907 end;
908 else go to arg_error;
909
910 end;
911
912
913 if opts.profile
914 then do;
915 opts.pst, tbl_pres = "1"b;
916 no_tbl_pres = "0"b;
917 end;
918
919 end;
920
921 setup:
922 proc;
923
924
925 if cobol_options = " "
926 then do;
927 cobol_options = "tb,";
928 cobol_options_len = 5;
929 end;
930 else if ^no_tbl_pres & ^tbl_pres
931 then do;
932 substr (cobol_options, cobol_options_len, 4) = "tb,";
933
934 cobol_options_len = cobol_options_len + 4;
935
936 end;
937
938 if cobol_options_len = 1
939 then do;
940
941 cobol_options = "none";
942 cobol_options_len = 4;
943 end;
944 else do;
945
946 cobol_options_len = cobol_options_len - 2;
947 substr (cobol_options, cobol_options_len, 1) = ";";
948 end;
949
950 if p_err = "0"b
951 then go to missing_arg_error;
952
953
954
955 p_ptr = addr (dpath);
956 e_ptr = addr (ename);
957 tp_ptr = addr (tpath);
958 fd_ptr = addr (fpath);
959
960
961
962
963 call expand_pathname_$add_suffix (tpb, "cobol", dpath, en_1, mcode);
964
965 if mcode ^= 0
966 then go to multics_error;
967
968 call get_length (p_ptr, 168, ldp);
969 call get_length (addr (en_1), 32, en_len);
970
971 len = en_len - 6;
972 ename = substr (en_1, 1, len);
973
974 ln = substr (ename, 1, len) || ".list";
975
976 call expand_pathname_ (lname, pln, ln, mcode);
977
978 if mcode ^= 0
979 then go to multics_error;
980
981 tpath = dpb || ">" || enb;
982
983 call get_length (tp_ptr, 168, ltp);
984
985 pdpath = get_pdir_ ();
986
987 if ^files_wd
988 then fpath = pdpath;
989
990 call get_length (fd_ptr, 168, fdlen);
991
992
993
994 if fdlen < 0
995 then fdlen = 168;
996
997
998
999
1000 if time | intact
1001 then call hcs_$get_usage_values (rb_pf, rb_tm, rb_pp);
1002
1003 if intact
1004 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1005
1006 cc = cc + 1;
1007 cobol_$compile_count = cc;
1008
1009
1010
1011 call cobol_vdwf (cobol_cmfp, fdir || ">cobol_common_");
1012 call cobol_vdwf (cobol_ntfp, fdir || ">cobol_name_table_");
1013 call cobol_swf (cobol_m1fp, fdir || ">cobol_minpral-1_");
1014 call cobol_swf (cobol_m2fp, fdir || ">cobol_minpral-2_");
1015
1016 call cobol_swf (cobol_rwdd, fdir || ">rwdd.incl.cobol");
1017
1018 call cobol_swf (cobol_rwpd, fdir || ">rwpd.incl.cobol");
1019 call cobol_swf (cobol_rm2fp, fdir || ">cobol_rmin2_");
1020 call cobol_swf (cobol_dfp, fdir || ">cobol_diags_");
1021 call cobol_swf (cobol_pfp, fdir || ">cobol_print_");
1022 call cobol_swf (cobol_$initval_file_ptr, fdir || ">cobol_initval_");
1023 call cobol_vdwf_open (cobol_ntfp, ST);
1024 call cobol_vdwf_open (cobol_cmfp, ST);
1025 call cobol_vdwf_sput (cobol_cmfp, ST, addr (common), 4 * size (fixed_common), fcom_key);
1026
1027 call cobol_vdwf_dget (cobol_cmfp, ST, cobol_com_ptr, fcom_ln, fcom_key);
1028
1029
1030 call cobol_version$set;
1031
1032
1033 if MODE ^= 0
1034 then call comp_env;
1035
1036
1037
1038 if COMP_LEVEL ^= "5"
1039 then fixed_common.comp_level = COMP_LEVEL;
1040
1041
1042 fixed_common.levsv = LEVSV;
1043 fixed_common.compiler_id = 3;
1044 cobol_$obj_seg_name = enb;
1045
1046 call cobol_init_ (fpath, rtbuff_ptr);
1047
1048
1049 call cobol_gns$set_table;
1050
1051 if rtbuff_ptr = null ()
1052 then go to comp_term;
1053
1054 end;
1055
1056 expand_phase:
1057 proc;
1058
1059 if time
1060 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1061
1062
1063
1064
1065 call hcs_$initiate_count (dpath, en_1, "", BC, 1, cobol_sfp, mcode);
1066
1067
1068 include_ptr (0) = pointer (cobol_sfp, 1);
1069
1070 if cobol_sfp = null ()
1071 then do;
1072
1073 call com_err_ (mcode, "cobol", "^a", tpb || ".cobol");
1074
1075 goto comp_term;
1076
1077 end;
1078
1079
1080 if BC = 0
1081 then do;
1082 call com_err_ (0, "cobol", "Zero length segment. ^a", tpb || ".cobol");
1083
1084
1085 go to comp_term;
1086
1087
1088
1089
1090 end;
1091
1092 if ^opts.fmt
1093 then if substr (first_source_line, 1, 6) ^= " "
1094 then do;
1095
1096 ch1 = substr (first_source_line, 1, 1);
1097
1098 if ch1 > "9" | ch1 = "*" | ch1 = "/" | ch1 = " "
1099 then do;
1100
1101 if opts.card
1102 then do;
1103
1104 call ioa_ (M1);
1105 call ioa_ (M2);
1106
1107 go to comp_term;
1108
1109 end;
1110
1111 else call ioa_ (M1);
1112
1113 opts.fmt, fixed_common.options.fmt = "1"b;
1114
1115 call set_options (", (fmt);", 8);
1116
1117 end;
1118
1119 end;
1120
1121 else ;
1122
1123 else do;
1124
1125 if opts.card
1126 then do;
1127
1128 call ioa_ (M2);
1129
1130 go to comp_term;
1131
1132 end;
1133
1134 end;
1135
1136 ecs = expand | opts.card | opts.fmt;
1137
1138
1139 if ecs & en_len > 9
1140 then if substr (en_1, en_len - 8) = ".ex.cobol"
1141 then do;
1142
1143 call ioa_ (M4);
1144 expand, opts.exp, opts.card, opts.fmt = "0"b;
1145
1146 end;
1147
1148 call cobol_version$print;
1149
1150
1151
1152 if ecs
1153 then do;
1154
1155
1156 if opts.pst
1157 then call f_mess;
1158
1159 if time
1160 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1161
1162 save_sfp = cobol_sfp;
1163 ecs_info_ptr = addr (ecs_info_table);
1164 ecs_info_table.input_ptr = cobol_sfp;
1165 ecs_info_table.card_indicator = opts.card;
1166
1167 ecs_info_table.exp_indicator = expand;
1168 ecs_info_table.format_indicator = opts.fmt;
1169 ecs_info_table.compiler_level = fixed_common.comp_level;
1170 ecs_info_table.diag_indicators = "000"b;
1171 ecs_info_table.fatal_count = 0;
1172 ecs_info_table.levsv = fixed_common.levsv;
1173
1174
1175 ecs_info_table.dir = pdpath;
1176 ecs_info_table.ent = substr (ename, 1, len) || ".ex.cobol";
1177
1178 call expand_cobol_source$expand (ecs_info_ptr, mcode);
1179
1180 if mcode ^= 0
1181 then goto multics_error;
1182
1183
1184 BC = ecs_info_table.bc;
1185
1186 cobol_sfp = ecs_info_table.output_ptr;
1187 fixed_common.fatal_no = fixed_common.fatal_no + ecs_info_table.fatal_count;
1188
1189 if time
1190 then call timer ("EXPAND........");
1191 end;
1192
1193
1194 call cobol_merge$source_file_size (BC);
1195
1196 entry_ptr = addr (branch_status);
1197
1198 call hcs_$fs_get_path_name (cobol_sfp, dn, i, en, mcode);
1199
1200
1201 if mcode ^= 0
1202 then goto multics_error;
1203
1204 call push_name (dn, en);
1205
1206 end;
1207
1208 lex:
1209 proc;
1210
1211 call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "ou");
1212 call cobol_swf_open (cobol_m2fp, ST, tptr, tln, "ou");
1213 call cobol_swf_open (cobol_pfp, ST, tptr, tln, "ou");
1214
1215 fixed_common.descriptor = common.descriptor;
1216
1217 call cobol_swf_open (cobol_dfp, ST, tptr, tln, "ou");
1218
1219 save_m2fp = cobol_m2fp;
1220
1221
1222
1223 if time
1224 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1225
1226 endlex_sw = "0"b;
1227
1228 fixed_common.syntax_trace = trace.rw;
1229
1230 call cobol_lex (enb);
1231
1232
1233 fixed_common.syntax_trace = "0"b;
1234 endlex_sw = "1"b;
1235
1236 fixed_common.last_print_rec = cobol_lpr;
1237
1238 call cobol_swf_close (cobol_pfp, ST, tptr, 0);
1239
1240 cobol_sfp = pointer (cobol_sfp, 0);
1241
1242 if time
1243 then call timer ("LEX...........");
1244
1245 if fixed_common.prog_name = "" | fixed_common.prog_name = substr (ename, 1, len)
1246 then tname = substr (ename, 1, len);
1247 else tname = substr (ename, 1, len) || "$" || fixed_common.prog_name;
1248
1249 mcode = -3;
1250
1251 call cobol_control_$cancel (tname, 0, 1, mcode);
1252
1253
1254 if MODE = 5
1255 then go to lex_quit;
1256
1257 end;
1258
1259 ided:
1260 proc;
1261
1262
1263
1264
1265 if time
1266 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1267
1268 call cobol_swf_close (cobol_m1fp, ST, tptr, 0);
1269 call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "in");
1270
1271
1272
1273 cobol_com_fileno = cobol_cmfp;
1274 cobol_name_fileno, cobol_name_fileno_ptr = cobol_ntfp;
1275 cobol_min1_fileno = cobol_m1fp;
1276 fixed_common.syntax_trace = trace.id;
1277
1278 call cobol_idedsyn;
1279
1280 fixed_common.syntax_trace = "0"b;
1281
1282 if fixed_common.prog_name = ""
1283 then fixed_common.prog_name = substr (ename, 1, len);
1284
1285
1286 if time
1287 then call timer ("ID/ED SYNTAX..");
1288
1289 end;
1290
1291 dd:
1292 proc;
1293
1294
1295
1296
1297 if time
1298 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1299
1300 fixed_common.syntax_trace = trace.dd;
1301
1302 call cobol_ddsyntax;
1303
1304 fixed_common.syntax_trace = "0"b;
1305
1306 if time
1307 then call timer ("DD SYNTAX.....");
1308
1309 call cobol_swf_close (cobol_m1fp, ST, tptr, rel);
1310
1311 end;
1312
1313
1314 ddalloc:
1315 proc;
1316
1317
1318
1319
1320 if time
1321 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1322
1323 call cobol_swf_open (cobol_$initval_file_ptr, ST, tptr, tln, "ou");
1324
1325 ddsyn_sw = "1"b;
1326
1327 call cobol_init_$segs (mcode, tpath);
1328
1329 if mcode ^= 0
1330 then go to comp_term;
1331
1332
1333
1334
1335 linkoff = 0;
1336
1337 call cobol_make_link_$type_4 (linkoff, "cobol_rts_");
1338
1339 call cobol_ddalloc;
1340
1341 if time
1342 then call timer ("DD ALLOCATION.");
1343
1344 end;
1345
1346 replace:
1347 proc;
1348
1349
1350
1351
1352 if time
1353 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1354
1355 call cobol_swf_close (cobol_$initval_file_ptr, ST, tptr, 0);
1356 call cobol_swf_close (cobol_m2fp, ST, tptr, 0);
1357 call cobol_vdwf_close (cobol_ntfp, ST, tptr, 0);
1358 call cobol_swf_open (cobol_m2fp, ST, tptr, tln, "in");
1359 call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "ou");
1360 call cobol_vdwf_open (cobol_ntfp, ST);
1361
1362
1363
1364
1365 cobol_curr_in = cobol_m2fp;
1366 cobol_curr_out = cobol_rm2fp;
1367
1368
1369
1370 mem_size = 1048575;
1371
1372 call cobol_repl3 (mem_size, rtbuff_ptr);
1373
1374 if time
1375 then call timer ("REPLACEMENT...");
1376
1377 cobol_m2fp = cobol_curr_in;
1378 cobol_rm2fp = cobol_curr_out;
1379
1380 call cobol_swf_close (cobol_m2fp, ST, tptr, rel);
1381 call cobol_swf_close (cobol_rm2fp, ST, tptr, 0);
1382 call cobol_swf (cobol_pdofp, fdir || ">cobol_pdout_");
1383 call cobol_swf_open (cobol_pdofp, ST, tptr, tln, "ou");
1384
1385 repl_sw = "1"b;
1386
1387 end;
1388
1389 db_corr:
1390 proc;
1391
1392 call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "in");
1393
1394
1395 if fixed_common.corr | fixed_common.initl
1396 then do;
1397 call START;
1398
1399
1400 call cobol_ci_phase;
1401
1402
1403 if fixed_common.debug
1404 then do;
1405 call START_DB;
1406
1407
1408 fixed_common.syntax_trace = trace.db;
1409
1410 call cobol_db_phase;
1411 fixed_common.syntax_trace = "0"b;
1412
1413
1414 call FINISH_DB;
1415
1416
1417
1418 end;
1419 else call FINISH ("CORRESPONDING.");
1420
1421
1422 end;
1423 else if fixed_common.debug
1424 then do;
1425 call START;
1426
1427
1428 fixed_common.syntax_trace = trace.db;
1429 call cobol_db_phase;
1430 fixed_common.syntax_trace = "0"b;
1431
1432
1433 call FINISH ("DEBUG.........");
1434
1435
1436
1437 end;
1438
1439 end;
1440
1441 print_diag:
1442 proc;
1443
1444
1445
1446
1447
1448 if fixed_common.fatal_no ^= 0
1449 then do;
1450
1451 if fixed_common.fatal_no > 1
1452 then errorcon = "errors";
1453 else errorcon = "error";
1454
1455 call ioa_ ("");
1456
1457 if abort_sw
1458 then call com_err_ (0, "cobol", "^d other fatal ^a encountered in ^a to this point.",
1459 fixed_common.fatal_no, errorcon, enb);
1460 else call com_err_ (0, "cobol", "^d fatal ^a encountered in ^a.", fixed_common.fatal_no, errorcon,
1461 enb);
1462
1463 end;
1464
1465 if time
1466 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1467
1468 if opts.exs
1469 then do;
1470
1471 call delete_$path (pln, ln, "100111"b, "", mcode);
1472
1473
1474 wdir = get_wdir_ ();
1475 call cobol_cselfle (ST, cobol_hfp, enb || ".list", " ", 0, "h", ""b);
1476
1477
1478 end;
1479
1480 call cobol_swf_open (cobol_pfp, ST, tptr, tln, "in");
1481 call cobol_swf_open (cobol_dfp, ST, tptr, tln, "in");
1482
1483 if fixed_common.options.exp = "0"b
1484 then ecs_info_table.diag_indicators = "000"b;
1485
1486 call cobol_print_diag;
1487
1488 call cobol_swf_close (cobol_pfp, ST, tptr, rel);
1489 call cobol_swf_close (cobol_dfp, ST, tptr, rel);
1490 call cobol_swf_close (cobol_pdofp, ST, tptr, 0);
1491
1492 if time
1493 then call timer ("PRINT DIAG....");
1494
1495 call cobol_swf_close (cobol_rm2fp, ST, tptr, rel);
1496
1497 if opts.exs
1498 then call cobol_cselfle (ST, cobol_hfp, " ", " ", 1, "k", "0"b);
1499
1500
1501 if opts.exs
1502 then do;
1503
1504 segname = substr (cobol_$obj_seg_name, 1, index (cobol_$obj_seg_name, " ") - 1) || ".list";
1505
1506 call hcs_$initiate_count (wdir, segname, "", BC, 01b, cobol_$list_ptr, mcode);
1507
1508 if cobol_$list_ptr = null ()
1509 then go to multics_file_error;
1510
1511 cobol_$list_off = divide (BC + 8, 9, 24, 0) + 1;
1512
1513 end;
1514 else cobol_$list_ptr = null ();
1515
1516
1517
1518 if fixed_common.fatal_no ^= 0 | ^opts.cu | abort_sw
1519 then do;
1520
1521 if fixed_common.fatal_no ^= 0 & ^abort_sw
1522 then call com_err_ (error_table_$translation_failed, "cobol");
1523 else if ^opts.cu
1524 then call ioa_ ("cobol: No object program generated for ^a.", enb);
1525
1526 if intact & ^time
1527 then call timer ("Front:");
1528
1529 go to no_gen;
1530
1531 end;
1532
1533 if intact & ^time
1534 then do;
1535
1536 call timer ("Front:");
1537 call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1538
1539 end;
1540
1541
1542 end;
1543
1544
1545 generator:
1546 proc;
1547
1548
1549
1550
1551
1552 cobol_$next_tag = fixed_common.spec_tag_counter + 1;
1553 segname = "cobol_pdout_";
1554
1555
1556 call hcs_$initiate (fpath, segname, "", 0b, 00b, cobol_$minpral5_ptr, mcode);
1557
1558 if cobol_$minpral5_ptr = null ()
1559 then go to multics_file_error;
1560
1561 if opts.pst | opts.obj | opts.m_map
1562 then cobol_$pd_map_sw = 1;
1563 else cobol_$pd_map_sw = 0;
1564
1565 if opts.pst
1566 then do;
1567
1568 call cobol_vdwf_close (cobol_ntfp, ST, tptr, 0);
1569 call cobol_vdwf_open (cobol_ntfp, ST);
1570
1571 end;
1572
1573 gen_sw = "1"b;
1574
1575 if time
1576 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1577
1578 call cobol_gen_driver_;
1579
1580 if time
1581 then call timer ("GENERATOR.....");
1582
1583 cobol_$constant_offset = cobol_$con_wd_off - mod (cobol_$con_wd_off, 2);
1584
1585 end;
1586
1587 analyzer:
1588 proc;
1589
1590
1591
1592
1593 if opts.xrn & fixed_common.fatal_no = 0
1594 then do;
1595
1596 if time
1597 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1598
1599 call cobol_make_xref_;
1600
1601 if time
1602 then call timer ("ANALYZER......");
1603
1604 end;
1605
1606 end;
1607
1608 fixup:
1609 proc;
1610
1611
1612
1613
1614 if time
1615 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1616
1617 call cobol_fix_driver_;
1618
1619 if time
1620 then call timer ("FIXUP.........");
1621
1622 if intact & ^time
1623 then call timer ("Back :");
1624
1625 end;
1626
1627 finish_proc:
1628 proc;
1629
1630
1631
1632 if repl_sw
1633 then call cobol_swf_close (cobol_pdofp, ST, tptr, rel);
1634
1635
1636 if ddsyn_sw
1637 then call cobol_swf_close (cobol_$initval_file_ptr, ST, tptr, rel);
1638
1639
1640 call cobol_vdwf_close (cobol_cmfp, ST, tptr, rel);
1641
1642 call cobol_vdwf_close (cobol_ntfp, ST, tptr, rel);
1643
1644 if abort_sw
1645 then call com_err_ (error_table_$translation_aborted, "cobol");
1646
1647 call CLEANUP;
1648
1649
1650 call finis;
1651
1652 if time | intact
1653 then do;
1654
1655 pb_tm = rb_tm;
1656 pb_pf = rb_pf;
1657 pb_pp = rb_pp;
1658
1659 if time
1660 then call timer ("TOTAL:");
1661 else call timer ("Total:");
1662
1663 end;
1664
1665 end;
1666
1667
1668
1669
1670
1671
1672
1673 get_length:
1674 proc (p, l, j);
1675
1676 declare p ptr,
1677 l fixed bin,
1678 j fixed bin,
1679 name char (l) based (p);
1680
1681 j = index (name, " ");
1682
1683 if j = 0
1684 then j = l;
1685 else j = j - 1;
1686
1687 end get_length;
1688
1689
1690
1691 set_options:
1692 proc (str, size);
1693
1694 declare str char (*),
1695 size fixed bin;
1696
1697 if substr (cobol_options, cobol_options_len, 1) = ";"
1698 then cobol_options_len = cobol_options_len - 1;
1699
1700 substr (cobol_options, cobol_options_len + 1, 8) = substr (str, 1, size);
1701
1702 cobol_options_len = cobol_options_len + size;
1703
1704 end set_options;
1705
1706
1707
1708
1709 START:
1710 proc;
1711
1712
1713
1714 if time
1715 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1716
1717
1718 call cobol_swf (cobol_m1fp, fdir || ">cobol_corrout_");
1719
1720 call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "ou");
1721
1722
1723
1724 cobol_rmin2fp = cobol_rm2fp;
1725
1726 cobol_x3fp = cobol_m1fp;
1727
1728 end;
1729
1730
1731
1732 FINISH:
1733 proc (ph_name);
1734
1735
1736
1737 dcl ph_name char (14);
1738
1739
1740 call cobol_swf_close (cobol_rm2fp, ST, tptr, 1);
1741
1742
1743 cobol_rm2fp = cobol_x3fp;
1744
1745
1746 call cobol_swf_close (cobol_x3fp, ST, tptr, 0);
1747
1748 call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "in");
1749
1750
1751
1752 if time
1753 then call timer (ph_name);
1754
1755 end;
1756
1757
1758
1759 START_DB:
1760 proc;
1761
1762
1763
1764 if time
1765 then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1766
1767
1768 call cobol_swf_close (cobol_m1fp, ST, tptr, 0);
1769
1770 call cobol_swf_close (cobol_rm2fp, ST, tptr, 0);
1771
1772
1773 cobol_rmin2fp = cobol_m1fp;
1774
1775 cobol_x3fp = cobol_rm2fp;
1776
1777
1778 call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "in");
1779
1780
1781 call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "ou");
1782
1783
1784 end;
1785
1786 FINISH_DB:
1787 proc;
1788
1789
1790
1791 call cobol_swf_close (cobol_rmin2fp, ST, tptr, 1);
1792
1793
1794 cobol_rm2fp = cobol_x3fp;
1795
1796
1797 call cobol_swf_close (cobol_x3fp, ST, tptr, 0);
1798
1799 call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "in");
1800
1801
1802
1803 if time
1804 then call timer ("DEBUG.........");
1805
1806 end;
1807
1808
1809
1810
1811 timer:
1812 proc (phase);
1813
1814 dcl phase char (14);
1815 dcl (temp, lp, rp) fixed bin (35);
1816
1817 call hcs_$get_usage_values (pe_pf, pe_tm, pe_pp);
1818 temp = pe_tm - pb_tm;
1819 pb_pf = pe_pf - pb_pf;
1820 pb_pp = pe_pp - pb_pp;
1821 lp = divide (temp, 1000000, 35, 0);
1822 rp = mod (temp, 1000000);
1823 rp = divide (rp, 1000, 35, 0);
1824
1825 call ioa_ ("^a ^2d.^3d seconds,^3d pagefaults,^3d prepages.", phase, lp, rp, pb_pf, pb_pp);
1826 return;
1827 end timer;
1828
1829
1830
1831 setlev:
1832 proc (lv, sv);
1833
1834
1835 dcl (lv, sv) char (1);
1836
1837
1838 if lv < "1" | lv > "5"
1839 then go to arg_error;
1840
1841
1842 COMP_LEVEL = lv;
1843
1844
1845 if sv = "1"
1846 then LEVSV = "100"b;
1847 else if sv = "2"
1848 then LEVSV = "010"b;
1849 else if sv = "3"
1850 then LEVSV = "001"b;
1851 else go to arg_error;
1852
1853 end;
1854
1855
1856
1857
1858
1859 setsv:
1860 proc (sv);
1861
1862
1863
1864 dcl sv char (1);
1865
1866
1867 if sv < "1" | sv > "4"
1868 then go to arg_error;
1869
1870
1871 opts.m_obs = "1"b;
1872
1873
1874 if sv = "4"
1875 then opts.m_fat, opts.m_wn, opts.m_obs = "0"b;
1876 else if sv = "3"
1877 then opts.m_wn, opts.m_obs = "0"b;
1878 else if sv = "2"
1879 then opts.m_obs = "0"b;
1880
1881 end;
1882
1883
1884
1885
1886
1887
1888
1889 CLEANUP:
1890 proc;
1891
1892 if ^recursion
1893 then return;
1894
1895 recursion = "0"b;
1896 revert cleanup;
1897
1898
1899 if cobol_$include_cnt > 0
1900 then do i = 0 to cobol_$include_cnt;
1901 call cobol_cselfle (ST, include_ptr (i), " ", " ", 0, "k", "0"b);
1902 end;
1903
1904 if ^intact
1905 then do segname = "cobol_seg1_", "cobol_seg2_", "cobol_seg3_", "cobol_initval_", "cobol_ntbuff_",
1906 "cobol_minpral-1_", "cobol_minpral-2_",
1907 "rwdd.incl.cobol", "rwpd.incl.cobol", "cobol_rmin2_", "cobol_r2min2_", "cobol_print_", "cobol_diags_",
1908 "cobol_pdout_", "cobol_corrout_",
1909 "cobol_pdout_",
1910 "cobol_initval_",
1911 "cobol_print_",
1912 "cobol_diags_",
1913 "cobol_rmin2_",
1914 "cobol_minpral-1_", "cobol_minpral-2_",
1915 "cobol_name_table_", "cobol_common_", "cobol_name_table_", "cobol_format_temp_";
1916 call hcs_$truncate_file (fpath, segname, 0, mcode);
1917 call hcs_$terminate_file (fpath, segname, 0b, mcode);
1918
1919 call hcs_$set_bc (fpath, segname, 0, mcode);
1920 end;
1921
1922
1923 call finis;
1924
1925 return;
1926
1927 end CLEANUP;
1928
1929 COND:
1930 proc (cond_name);
1931
1932 declare cond_name char (*),
1933 code fixed bin (35);
1934 declare find_condition_info_
1935 entry (ptr, ptr, fixed bin (35));
1936
1937
1938 call find_condition_info_ (null (), addr (cond_info), code);
1939
1940
1941 call cobol_error (cond_name, cond_info.infoptr, "0"b);
1942
1943
1944
1945 call finis;
1946
1947 end;
1948
1949
1950 cobol_error:
1951 proc (cond_name, sptr, cont);
1952
1953 dcl sptr ptr;
1954 dcl cond_name char (*);
1955 dcl cont bit (1);
1956 dcl 1 s based (sptr),
1957 2 name char (32),
1958 2 len fixed bin,
1959 2 string char (0 refer (s.len));
1960
1961 dcl 1 io based (sptr),
1962 2 name char (32),
1963 2 code fixed bin (35),
1964 2 action fixed bin,
1965
1966
1967
1968
1969
1970
1971
1972
1973 2 iocb_ptr ptr,
1974 2 file_type fixed bin,
1975
1976
1977
1978
1979 2 key char (5);
1980
1981 dcl action_con (7) char (10)
1982 init ("initialize", "open", "get", "put", "direct get", "direct put", "close");
1983 dcl attach_descrip char (172) varying based (io.iocb_ptr -> iocb.attach_descrip_ptr);
1984
1985 start_error:
1986 if cond_name = "command_abort_" | cond_name = "command_abort"
1987
1988 then if s.name = "cobol_io_"
1989 then do;
1990
1991 if io.action > 7
1992 then do;
1993
1994 if action = 8
1995 then call com_err_ (error_table_$no_operation, "cobol", "Bad cobol_cselfle file type");
1996 else call com_err_ (error_table_$no_operation, "cobol",
1997 "Bad open mode for a sequential file");
1998
1999 end;
2000
2001 else if io.file_type = 0 | io.file_type > 3
2002 then do;
2003
2004 if io.file_type > 3
2005 then do;
2006
2007 call com_err_ (error_table_$no_operation, "cobol",
2008 "Attempting to ^a internal work file at ^p", action_con (io.action),
2009 io.iocb_ptr);
2010
2011 if io.file_type = 5 & (io.action = 4 | io.action = 5)
2012 then call com_err_ (0, "cobol", "Key is ^a", io.key);
2013
2014 end;
2015
2016 else call com_err_ (error_table_$no_operation, "cobol", "Referencing ^p", io.iocb_ptr);
2017
2018 call com_err_ (error_table_$translation_aborted, "cobol");
2019
2020 end;
2021
2022 else call com_err_ (io.code, "cobol", substr (attach_descrip, 7));
2023 go to comp_term;
2024
2025 end;
2026
2027 else do;
2028
2029 if substr (s.name, 1, 6) = "cobol_"
2030 then call com_err_ (0, "cobol", "Unrecoverable code generator error (^a). ^a.",
2031 substr (s.name, 7), s.string);
2032 else call com_err_ (0, "cobol", "Unrecoverable ^a error. ^a.", s.name, s.string);
2033
2034 end;
2035
2036 else do;
2037
2038 call com_err_ (0, "cobol", "Unrecoverable error. Unexpected condition signalled.");
2039
2040 if ^restart
2041 then do;
2042 restart = "1"b;
2043 call cobol$restart;
2044 end;
2045
2046 cont = "1"b;
2047
2048 return;
2049
2050 end;
2051
2052 if ^intact
2053 then do;
2054 if abort_sw
2055 then go to finish;
2056 else abort_sw = "1"b;
2057
2058 if ^endlex_sw
2059 then go to finish;
2060
2061 if endgen_sw
2062 then go to finish;
2063 else if gen_sw
2064 then go to no_gen;
2065 else go to start_print_diag;
2066 end;
2067 else call cu_$cl;
2068
2069 return;
2070
2071 end cobol_error;
2072
2073
2074
2075
2076 print_options:
2077 proc;
2078
2079 dcl message char (80);
2080
2081
2082
2083
2084 call com_err_ (error_table_$noarg, "cobol");
2085
2086 call cobol_version$print;
2087
2088
2089 call ioa_ ("Usage: cobol path {ctl_args}");
2090 call ioa_ ("Control arguments:-map -list -no_table -profile");
2091
2092 call ioa_ ("-brief -check -runtime_check -expand");
2093
2094 call ioa_ ("-format -card -temp_dir PATH");
2095 call ioa_ ("-severity N -level NM");
2096
2097 end print_options;
2098
2099
2100
2101
2102 init:
2103 proc;
2104
2105
2106
2107 code = 0;
2108
2109 call get_temp_segments_ ("cobol", temp_ptr, code);
2110
2111 if code ^= 0
2112 then return;
2113
2114 area_infop = addr (area_info_area);
2115
2116 area_info_area.version = area_info_version_1;
2117 area_info_area.owner = "cobol";
2118 area_info_area.areap = temp_ptr (1);
2119 area_info_area.size = sys_info$max_seg_size;
2120
2121 string (area_info_area.control) = "10001"b;
2122
2123 call define_area_ (area_infop, code);
2124
2125 if code ^= 0
2126 then return;
2127
2128 cobol_area_ptr = temp_ptr (1);
2129 c_name.last_name_ptr = null ();
2130 c_name.ct = 0;
2131
2132 end;
2133
2134
2135
2136 finis:
2137 proc;
2138
2139
2140
2141 if area_info_area.areap ^= null ()
2142 then call release_area_ (area_info_area.areap);
2143
2144 call release_temp_segments_ ("cobol", temp_ptr, code);
2145
2146 end;
2147
2148
2149
2150 f_mess:
2151 proc;
2152
2153
2154 call ioa_ (M3);
2155
2156
2157 call ioa_ ("cobol: "
2158 || "Compilation will take place using the source program [pd]>"
2159 || substr (ename, 1, len) || ".ex.cobol" );
2160
2161 end;
2162
2163 declare DIRECTORY fixed bin (2) static internal options (constant) init (2);
2164
2165 declare 1 stat static,
2166 2 (entry_ptr, save_m2fp, arg_ptr, p_ptr, e_ptr, tp_ptr, fd_ptr)
2167 ptr,
2168 2 (tptr, rtbuff_ptr, save_sfp, format_sfp)
2169 ptr,
2170 2 (cobol_area_ptr, source_name_ptr)
2171 ptr,
2172 2 temp_ptr (1) ptr,
2173 2 (rb_pf, rb_pp, pb_pf, pb_pp, pe_pf, pe_pp)
2174 fixed bin,
2175 2 (l_en, l_dn, linkoff, l, m, pc, i, MODE)
2176 fixed bin,
2177 2 (ldp, ltp, len, fdlen, upto, en_len)
2178 fixed bin,
2179 2 cc fixed bin init (0),
2180 2 (rb_tm, pb_tm, pe_tm)
2181 fixed bin (71),
2182 2 (mcode, code) fixed bin (35),
2183 2 entry_type fixed bin (2),
2184 2 mem_size fixed bin (31),
2185 2 (fcom_ln, tln, rel)
2186 fixed bin (15),
2187 2 BC fixed bin (24),
2188 2 recursion bit (1) init ("0"b),
2189 2 LEVSV bit (3),
2190 2 ST bit (32),
2191 2 (p_err, corr_sw, abort_sw, endlex_sw, gen_sw, endgen_sw, restart)
2192 bit (1),
2193 2 (time, intact, expand, files_wd, temp_dir_sw)
2194 bit (1),
2195 2 (repl_sw, ddsyn_sw, no_tbl_pres, tbl_pres, ecs)
2196 bit (1),
2197 2 (lex_quit, comp_term)
2198 label,
2199 2 answer char (3) varying,
2200 2 ename char (32) aligned,
2201 2 tpath char (168) aligned,
2202 2 fpath char (168) init (""),
2203 2 (tchar, COMP_LEVEL, ch1)
2204 char (1),
2205 2 (segname, trace_arg, ln, en, en_1)
2206 char (32),
2207 2 (pln, dn, dpath, pdpath, wdir)
2208 char (168),
2209 2 arg char (16),
2210 2 errorcon char (6),
2211 2 tname char (65),
2212 2 fcom_key char (5);
2213
2214
2215 dcl error_table_$noarg fixed bin (35) ext static;
2216 dcl error_table_$badopt fixed bin (35) ext static;
2217 dcl error_table_$translation_failed
2218 fixed bin (35) ext static;
2219 dcl error_table_$not_act_fnc
2220 fixed bin (35) ext static;
2221 dcl error_table_$no_operation
2222 fixed bin (35) ext static;
2223 dcl error_table_$translation_aborted
2224 fixed bin (35) ext static;
2225 dcl error_table_$notadir
2226 fixed bin (35) ext static;
2227 dcl sys_info$max_seg_size
2228 fixed bin (35) ext static;
2229
2230
2231
2232
2233
2234
2235 dcl 1 trace static,
2236 2 on bit (1) init ("0"b),
2237 2 id bit (1) init ("0"b),
2238 2 dd bit (1) init ("0"b),
2239 2 pd bit (1) init ("0"b),
2240 2 db bit (1) init ("0"b),
2241 2 rw bit (1) init ("0"b);
2242
2243 dcl 01 ecs_info_table automatic structure like ecs_info_table_;
2244 dcl 1 area_info_area aligned automatic structure like area_info;
2245
2246 dcl 1 common static,
2247 2 prog_name char (30) init (""),
2248 2 compiler_rev_no char (25) init (""),
2249 2 phase_name char (6) init (""),
2250 2 currency char (1) init ("$"),
2251 2 fatal_no fixed bin (15) init (0),
2252 2 warn_no fixed bin (15) init (0),
2253 2 proc_counter fixed bin (15) init (0),
2254 2 spec_tag_counter
2255 fixed bin (15) init (0),
2256 2 file_count fixed bin (7) init (0),
2257 2 filedescr_offsets
2258 (20) char (5) init ((20) (5)"0"),
2259 2 perf_alter_info char (5) init ("00000"),
2260 2 another_perform_info
2261 char (5) init ("00000"),
2262 2 sort_in_info char (5) init ("00000"),
2263 2 odo_info char (5) init ("00000"),
2264 2 size_seg fixed bin (15) init (0),
2265 2 size_offset fixed bin (31) init (0),
2266 2 size_perform_info
2267 char (5) init ("00000"),
2268 2 rename_info char (5) init ("00000"),
2269 2 report_names char (5) init ("00000"),
2270 2 rw_buf_seg fixed bin (15) init (0),
2271 2 rw_buf_offset fixed bin (31) init (0),
2272 2 rw_buf_length fixed bin (31) init (0),
2273 2 file_keys char (5) init ("00000"),
2274 2 search_keys char (5) init ("00000"),
2275 2 dd_seg_size fixed bin (31) init (65536),
2276 2 pd_seg_size fixed bin (31) init (0),
2277 2 seg_limit fixed bin (7) init (49),
2278 2 number_of_dd_segs
2279 fixed bin (15) init (0),
2280 2 seg_info char (5) init ("00000"),
2281 2 number_of_ls_pointers
2282 fixed bin (15) init (0),
2283 2 link_sec_seg fixed bin (15) init (0),
2284 2 link_sec_offset fixed bin (31) init (0),
2285 2 sra_clauses fixed bin (15) init (0),
2286 2 fix_up_info char (5) init ("00000"),
2287 2 linage_info char (5) init ("00000"),
2288 2 first_dd_item char (5) init ("00000"),
2289 2 sort_out_info char (5) init ("00000"),
2290 2 db_info char (5) init ("00000"),
2291 2 realm_info char (5) init ("00000"),
2292 2 rc_realm_info char (5) init ("00000"),
2293 2 last_file_key char (5) init ("00000"),
2294 2 prog_coll_seq fixed bin (15) init (0),
2295 2 sysin_fno fixed bin (15) init (0),
2296 2 sysout_fno fixed bin (15) init (0),
2297 2 dummy11 fixed bin (15) init (0),
2298 2 dummy12 fixed bin (15) init (0),
2299 2 dummy13 fixed bin (15) init (0),
2300 2 dummy14 fixed bin (15) init (0),
2301 2 dummy15 fixed bin (15) init (0),
2302 2 opts,
2303 3 cu bit (1) unaligned,
2304 3 pst bit (1) unaligned,
2305 3 wn bit (1) unaligned,
2306 3 obs bit (1) unaligned,
2307 3 dm bit (1) unaligned,
2308 3 xrl bit (1) unaligned,
2309 3 xrn bit (1) unaligned,
2310 3 src bit (1) unaligned,
2311 3 obj bit (1) unaligned,
2312 3 exs bit (1) unaligned,
2313 3 sck bit (1) unaligned,
2314 3 rno bit (1) unaligned,
2315 3 u_l bit (1) unaligned,
2316
2317
2318 3 cnv bit (1) unaligned,
2319 3 cos bit (1) unaligned,
2320 3 fmt bit (1) unaligned,
2321 3 profile bit (1) unaligned,
2322 3 nw bit (1) unaligned,
2323
2324 3 exp bit (1) unaligned,
2325 3 card bit (1) unaligned,
2326 3 fil2 bit (5) unaligned,
2327 3 m_map bit (1) unaligned,
2328 3 m_bf bit (1) unaligned,
2329 3 m_fat bit (1) unaligned,
2330 3 m_wn bit (1) unaligned,
2331 3 m_obs bit (1) unaligned,
2332 3 pd bit (1) unaligned,
2333 3 oc bit (1) unaligned,
2334 2 supervisor bit (1) init ("0"b),
2335 2 dec_comma bit (1) init ("0"b),
2336 2 init_cd bit (1) init ("0"b),
2337 2 corr bit (1) init ("0"b),
2338 2 initl bit (1) init ("0"b),
2339 2 debug bit (1) init ("0"b),
2340 2 report bit (1) init ("0"b),
2341 2 sync_in_prog bit (1) init ("0"b),
2342 2 pd_section bit (1) init ("0"b),
2343 2 list_switch bit (1) init ("1"b),
2344 2 alpha_cond bit (1) init ("0"b),
2345 2 num_cond bit (1) init ("0"b),
2346 2 spec_sysin bit (1) init ("0"b),
2347 2 spec_sysout bit (1) init ("0"b),
2348 2 dummy16 bit (1) init ("0"b),
2349 2 obj_dec_comma bit (1) init ("0"b),
2350 2 default_sign_type
2351 bit (3) init ("001"b),
2352 2 default_display bit (1) init ("0"b),
2353 2 syntax_trace bit (1) init ("0"b),
2354 2 dummy17_1 bit (17) init (""b),
2355 2 descriptor bit (2) init ("10"b),
2356 2 levsv bit (3) init ("001"b),
2357 2 dummy17 bit (5) init (""b),
2358 2 lvl_rstr bit (32) init (""b),
2359 2 inst_rstr bit (32) init (""b),
2360 2 comp_level char (1) init ("5"),
2361 2 dummy18 char (30) init (""),
2362 2 object_sign char (1) init (""),
2363 2 last_print_rec char (5) init ("00000"),
2364 2 coll_seq_info char (5) init ("00000"),
2365 2 sys_status_seg fixed bin (15) init (0),
2366 2 sys_status_offset
2367 fixed bin (31) init (0),
2368 2 compiler_id fixed bin (15) init (3),
2369 2 date_comp_ln fixed bin (15) init (0),
2370 2 compile_mode bit (36) init ("0"b),
2371 2 default_temp fixed bin (15) init (30),
2372 2 dummy26 fixed bin (15) init (0),
2373 2 display_device fixed bin (15) init (0),
2374 2 dummy28 fixed bin (15) init (0),
2375 2 alphabet_offset fixed bin init (0);
2376
2377 declare 1 MESS static,
2378 2 M1 char (77)
2379 init ("cobol: The -fmt option is assumed since the file is apparently in free format"),
2380 2 M2 char (60) init ("cobol: The -card option is inconsistant with the -fmt option"),
2381 2 M3 char (102)
2382 init (
2383 "cobol: A run time symbol table was requested and one of the options -expand, -format or -card was used"
2384 ),
2385 2 M4 char (111)
2386 init (
2387 "cobol: The -exp option may not be used if the entry name of the source program ends in "".ex.cobol"""
2388 );
2389
2390 dcl 1 c_name static,
2391 2 ct fixed bin,
2392 2 size fixed bin,
2393 2 last_name_ptr ptr,
2394 2 pname char (168) aligned,
2395 2 uid bit (36),
2396 2 dtm bit (36);
2397
2398 dcl 1 query_info aligned static,
2399 2 cobol_version fixed bin init (2),
2400 2 yes_or_no_sw bit (1) unal init ("1"b),
2401 2 suppress_name_sw
2402 bit (1) unal init ("0"b),
2403 2 status_code fixed bin (35) init (0),
2404 2 query_code fixed bin (35) init (0);
2405
2406 dcl 01 anarea based (rtbuff_ptr) aligned,
2407 02 dummy_ptr ptr,
2408 02 rtarea char (82000);
2409
2410
2411 dcl argb char (l) based (arg_ptr);
2412 dcl tpb char (ltp) based (tp_ptr);
2413 dcl dpb char (ldp) based (p_ptr);
2414 dcl enb char (len) based (e_ptr);
2415 dcl first_source_line char (32) based (cobol_sfp);
2416 dcl include_ptr (0:1000) ptr based (cobol_$include_info_ptr);
2417
2418
2419 dcl words (alloc_size) fixed bin (35) based;
2420
2421 dcl cobol_area area based (cobol_area_ptr);
2422 dcl lname char (len + 5) based (addr (ln));
2423
2424
2425 dcl 1 source_name based (source_name_ptr),
2426 2 prev_name_ptr ptr,
2427 2 sname char (168) aligned,
2428 2 uid bit (36),
2429 2 dtm bit (36);
2430
2431 declare fdir char (fdlen) based (fd_ptr);
2432
2433
2434 declare (command_abort, command_abort_, cleanup)
2435 condition;
2436
2437
2438 declare cobol$define_data entry;
2439
2440 dcl expand_cobol_source$expand
2441 entry (ptr, fixed bin (35));
2442 dcl hcs_$fs_get_path_name
2443 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
2444 declare hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
2445
2446 declare delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
2447
2448
2449 dcl (size, divide, index, mod, null, pointer, string, substr, addr)
2450 builtin;
2451
2452 dcl cobol$restart ext entry;
2453 dcl cobol_control_$cancel
2454 ext entry (char (*), fixed bin, fixed bin, fixed bin (35));
2455 dcl cobol_version$print entry;
2456 dcl cobol_make_link_$type_4
2457 entry (fixed bin, char (*));
2458 dcl cobol_version$set entry;
2459 dcl cu_$cl ext entry;
2460 dcl cobol_lex ext entry (char (*));
2461 dcl cobol_repl3 ext entry (fixed bin (31), ptr);
2462 dcl cobol_print_diag entry;
2463
2464 dcl (cobol_pdstax, cobol_ddsyntax, cobol_ddalloc, cobol_idedsyn, cobol_ci_phase, cobol_db_phase, cobol_gen_driver_,
2465 cobol_fix_driver_, cobol_make_xref_)
2466 ext entry;
2467
2468
2469 dcl (cobol_generator, cobol_fixup)
2470 ext entry;
2471 dcl cobol_source_formatter_
2472 entry (ptr, ptr, fixed bin (15), fixed bin, fixed bin);
2473 dcl cobol_init_ ext entry (char (168), ptr);
2474 dcl cobol_init_$segs ext entry (fixed bin (35), char (168) aligned);
2475
2476 dcl condition_ entry (char (*), entry);
2477 dcl get_pdir_ entry returns (char (168) aligned);
2478 dcl get_wdir_ entry returns (char (168) aligned);
2479
2480
2481 declare hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35));
2482
2483 dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
2484 dcl hcs_$truncate_file entry (char (*), char (*), fixed bin, fixed bin (35));
2485 dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
2486 dcl hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35));
2487 dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
2488 dcl revert_cleanup_proc_
2489 entry;
2490 dcl establish_cleanup_proc_
2491 entry (entry);
2492 dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
2493 dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
2494 dcl com_err_ entry options (variable);
2495 dcl hcs_$get_usage_values
2496 ext entry (fixed bin, fixed bin (71), fixed bin);
2497 dcl ioa_ entry options (variable);
2498 dcl ioa_$ioa_stream entry options (variable);
2499 dcl cu_$arg_count entry (fixed bin);
2500 dcl cu_$af_arg_count entry (fixed bin, fixed bin (35));
2501 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
2502 dcl cobol_syntax_trace_$initialize
2503 entry (ptr);
2504 dcl cobol_syntax_trace_$reset_trace
2505 entry;
2506 dcl cobol_gns$set_table entry;
2507
2508
2509 dcl command_query_ entry options (variable);
2510
2511 dcl cobol_cselfle entry (bit (32), ptr, char (*), char (3), fixed bin (15), char (1), bit (8)) ext;
2512 dcl (cobol_swf, cobol_vdwf)
2513 entry (ptr, char (*)) ext;
2514 dcl cobol_vdwf_open entry (ptr, bit (32)) ext;
2515 dcl (cobol_vdwf_dget, cobol_vdwf_sput)
2516 entry (ptr, bit (32), ptr, fixed bin (15), char (5));
2517 dcl cobol_swf_open entry (ptr, bit (32), ptr, fixed bin (15), char (2)) ext;
2518 dcl (cobol_swf_close, cobol_vdwf_close)
2519 entry (ptr, bit (32), ptr, fixed bin (15)) ext;
2520
2521 declare cobol_merge$source_file_size
2522 entry (fixed bin (24));
2523
2524
2525 dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
2526
2527 dcl release_temp_segments_
2528 entry (char (*), (*) ptr, fixed bin (35));
2529
2530 dcl define_area_ entry (ptr, fixed bin (35));
2531 dcl release_area_ entry (ptr);
2532
2533
2534 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
2535 absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
2536 hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
2537 expand_pathname_$add_suffix
2538 entry (char (*), char (*), char (*), char (*), fixed bin (35));
2539
2540
2541 %include cobol_;
2542 %include cobol_fixed_common;
2543 %include cobol_ext_;
2544 %include cobol_fsb;
2545 %include iocb;
2546 %include cobol_ecs_info;
2547
2548
2549
2550 declare 1 branch_status aligned like status_branch;
2551
2552 %include status_structures;
2553
2554 %include area_info;
2555
2556
2557 declare 1 cond_info static,
2558 %include cond_info;
2559 end cobol;