-
Notifications
You must be signed in to change notification settings - Fork 1
/
guicobol.cbl
1521 lines (1521 loc) · 51.5 KB
/
guicobol.cbl
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
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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. guicobol.
000030*---------------------------------------------------------------------
000040*
000050* Gui builder for OPENCOBOL
000060* pre-release agar 18 october 2020 0.1.2.25 other..... *
000070* pre-release agar 26 february 2020 0.1.2.24 line of error. *
000080* pre-release agar 26 february 2020 0.1.2.23 fixedcolor *
000090* pre-release agar 22 february 2020 0.1.2.23
000100* pre-release agar 1 August 2019 0.1.2.18
000110* FIRST 1 SEPTEMBER 2011 0.1.0
000120*
000130* Copyright (C) 2010-2019 Federico Priolo
000140*
000150* This program is free software; you can redistribute it and/or modify
000160* it under the terms of the GNU General Public License as published by
000170* the Free Software Foundation; either version 2, or (at your option)
000180* any later version.
000190*
000200* This program is distributed in the hope that it will be useful,
000210* but WITHOUT ANY WARRANTY; without even the implied warranty of
000220* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
000230* GNU General Public License for more details.
000240*
000250* You should have received a copy of the GNU General Public License
000260* along with this software; see the file COPYING. If not, write to
000270* the Free Software Foundation, 51 Franklin Street, Fifth Floor
000280* Boston, MA 02110-1301 USA
000290*
000300*
000310*---------------------------------------------------------------------
000320 ENVIRONMENT DIVISION.
000330 CONFIGURATION SECTION.
000340 SOURCE-COMPUTER. PC-IBM.
000350 OBJECT-COMPUTER. PC-IBM.
000360 SPECIAL-NAMES.
000370
000380 DECIMAL-POINT IS COMMA.
000390
000400 INPUT-OUTPUT SECTION.
000410 FILE-CONTROL.
000420
000430 SELECT ARK-IN ASSIGN TO FILE-IN
000440 ORGANIZATION IS LINE SEQUENTIAL
000450 FILE STATUS IS STATUS-IN.
000460
000470 SELECT ARK-DO ASSIGN TO FILE-DO
000480 ORGANIZATION IS LINE SEQUENTIAL
000490 FILE STATUS IS STATUS-DO.
000500
000510
000520 SELECT ARK-OUT ASSIGN TO FILE-OUT
000530 ORGANIZATION IS LINE SEQUENTIAL
000540 FILE STATUS IS STATUS-OUT.
000550
000560 SELECT ARK-WORK ASSIGN TO FILE-WORK
000570 ORGANIZATION IS LINE SEQUENTIAL
000580 FILE STATUS IS STATUS-WORK.
000590
000600
000610 DATA DIVISION.
000620 FILE SECTION.
000630
000640 FD ARK-WORK.
000650 01 REC-WORK.
000660 02 DATI-WORK PIC X(80).
000670
000680
000690 FD ARK-IN.
000700 01 REC-IN.
000710 02 DATI-IN PIC X(256).
000720
000730 FD ARK-DO.
000740 01 REC-DO.
000750 02 DATI-DO PIC X(500).
000760
000770
000780
000790
000800 FD ARK-OUT.
000810 01 REC-OUT.
000820 02 DATI-OUT PIC X(256).
000830
000840 WORKING-STORAGE SECTION.
000850 01 COLOR-REQUIRED PIC X(50) VALUE SPACE.
000860 01 TAB-FUNZIONE.
000870 12 MIN-FUNZIONE PIC 99.
000880 12 MAX-FUNZIONE PIC 99.
000890 12 DUMMY PIC X.
000900
000910 01 PARAMETRI.
000920 07 DEFAULT-CLOSED PIC X VALUE SPACE.
000930 07 IDENTIFICATION-DIVISION pic is X(30).
000940 07 COUNT-LINE PIC 9(9) VALUE ZERO.
000950 07 EXIT-WITH-ERRORS PIC X VALUE SPACE.
000960 07 TAB-PARAMETRI.
000970 12 METTI-DOT PIC X VALUE SPACE.
000980 12 CONTA-PARAM PIC 99 VALUE ZEROS.
000990 12 PARAMETRO PIC X(128) OCCURS 50 TIMES.
001000 12 USAGE-PARAM PIC X(30) OCCURS 50 TIMES.
001010 07 REMEMBER-METTI-DOT PIC X VALUE SPACE.
001020 07 PARAMETRO1 PIC X(128) VALUE SPACE.
001030 07 PARAMETRO2 PIC X(128) VALUE SPACE.
001040 07 PARAMETRO3 PIC X(128) VALUE SPACE.
001050 07 PARAMETRO4 PIC X(128) VALUE SPACE.
001060 07 CONTA-LINE PIC 9(6) VALUE ZEROS.
001070 07 DONE-SOMETHING PIC X VALUE SPACE.
001080 07 TIME-SYS PIC 9(6) VALUE ZEROS.
001090 07 FILE-SYS PIC X(6) VALUE SPACE.
001100 07 ISTRUZIONE PIC X(40) VALUE SPACE.
001110 07 VALORE PIC X(512) VALUE SPACE.
001120 07 FINE-FILE PIC X VALUE SPACE.
001130 07 FILE-IN PIC X(200) VALUE SPACE.
001140 07 FILE-OUT PIC X(200) VALUE SPACE.
001150 07 FILE-WORK PIC X(200) VALUE SPACE.
001160 07 FILE-DO PIC X(200) VALUE SPACE.
001170 07 FILE-COLOR PIC X(200) VALUE SPACE.
001180 07 STATUS-IN PIC XX VALUE SPACE.
001190 07 STATUS-OUT PIC XX VALUE SPACE.
001200 07 STATUS-DO PIC XX VALUE SPACE.
001210 07 STATUS-COLOR PIC XX VALUE SPACE.
001220 07 STATUS-WORK PIC XX VALUE SPACE.
001230 07 IND PIC 9(9) VALUE ZEROS.
001240 07 IND1 PIC 9(9) VALUE ZEROS.
001250 07 IND2 PIC 9(9) VALUE ZEROS.
001260 07 END-COBOL PIC 9(3) VALUE ZEROS.
001270 07 START-COBOL PIC 9(3) VALUE ZEROS.
001280 07 STRINGA PIC X(256) VALUE SPACE.
001290 07 STRINGA1 PIC X(256) VALUE SPACE.
001300 07 COMPARA PIC X(10) VALUE SPACE.
001310 07 LCOMPARA PIC 99 VALUE ZEROS.
001320 07 STRINGA2 PIC X(256) VALUE SPACE.
001330 07 LSTRINGA2 PIC 99 VALUE ZEROS.
001340 07 CHIUSO PIC XX VALUE SPACE.
001350 07 COMANDO PIC X(1024) VALUE SPACES.
001360 07 COPY1 PIC X(100) VALUE SPACE.
001370 07 COPY2 PIC X(100) VALUE SPACE.
001380 07 DO-DLL PIC XX VALUE SPACE.
001390 07 TAB-OPTIONS.
001400 09 SW-OPTION PIC X OCCURS 20 TIMES.
001410 78 MAXOPZ VALUE 20.
001420 07 SW-NOCOMPILA PIC X.
001430 07 SW-SAVE PIC X.
001440 07 SW-DATI PIC X.
001450 07 SW-DATI-OK PIC X.
001460 07 SW-HELP PIC X.
001470 07 SW-MANUAL PIC X.
001480 07 SW-CODICE PIC X.
001490 07 SW-FREE PIC X.
001500 07 SW-CONST PIC X.
001510 07 SW-STOP PIC X.
001520 07 SW-EXE PIC X.
001530 07 SW-ANALYSIS PIC X.
001540 07 SW-VERBOSE PIC X.
001550 07 XX PIC XX.
001560 07 REM-COLUMN PIC 9.
001570 07 CAMPO1 PIC X(30).
001580 07 CAMPO2.
001590 09 LIVELLO PIC 99.
001600 88 LIVELLO-OK VALUE 01 THRU 77
001610 79 THRU 87.
001620
001630 07 CAMPO3 PIC X(30).
001640 07 CAMPO4 PIC X(30).
001650 07 CAMPO5 PIC X(30).
001660 07 RIC-LIVELLO PIC 99.
001670 07 INSIDE-OCCURS PIC XX.
001680 07 EOF-DO PIC X.
001690 07 EOF-COLOR PIC X.
001700 07 AREA-DATI PIC X.
001710 07 TYPE-SYSTEM PIC X(10).
001720 07 CONTA-STACK PIC 9(9).
001730 07 CONTA-RECORD PIC 9(9).
001740 07 MIN-RECORD PIC 9(9).
001750 07 MAX-RECORD PIC 9(9).
001760 07 START-RECORD PIC 9(9).
001770 07 POINT-RECORD PIC 9(9).
001780 07 ESCI PIC XX VALUE SPACE.
001790 07 PARENT PIC X(30) VALUE SPACE.
001800 07 GLOBAL-LEVEL PIC 99 VALUE ZEROS.
001810 07 LAST-LABEL PIC X(30) VALUE SPACE.
001820 07 THIS-LABEL PIC X(30) VALUE SPACE.
001830 07 CONTA-WORKING-STORAGE PIC 99 VALUE ZERO.
001840
001850
001860
001870 PROCEDURE DIVISION.
001880 INIZIO SECTION.
001890
001900 PERFORM INIZIALI THRU EX-INIZIALI.
001910
001920 PERFORM LOGO THRU EX-LOGO.
001930
001940 ACCEPT FILE-IN FROM COMMAND-LINE.
001950
001960 IF FILE-IN = SPACES
001970 PERFORM HELP THRU EX-HELP
001980 STOP RUN
001990 END-IF.
002000
002010 PERFORM OPZIONI THRU EX-OPZIONI.
002020
002030 PERFORM APERTURE THRU EX-APERTURE.
002040
002050 PERFORM ELABORA THRU EX-ELABORA UNTIL FINE-FILE = "S".
002060
002070 PERFORM CHIUSURE THRU EX-CHIUSURE.
002080
002090 GOBACK.
002100
002110 LETTURA.
002120
002130 IF FINE-FILE = "S" GO TO EX-LETTURA.
002140
002150 MOVE SPACES TO REC-IN REC-OUT.
002160
002170 IF FINE-FILE NOT = "S"
002180 READ ARK-IN NEXT AT END
002190 MOVE "S" TO FINE-FILE
002200 END-IF.
002210
002220 IF FINE-FILE = "S" GO TO EX-LETTURA.
002230
002240 ADD 1 TO COUNT-LINE.
002250
002260
002270 MOVE ZEROS TO IND.
002280 INSPECT FUNCTION UPPER-CASE(REC-IN)
002290 TALLYING IND FOR ALL ">>SOURCE FORMAT IS FREE"
002300*
002310* before to set true the FREE FORMAT switch
002320* we must decide if it is not another ... for example
002330* if you want to debug the animator with animator itself..
002340* it could find the sentence but with other meaning...
002350*
002360 IF IND = 1
002370 MOVE FUNCTION UPPER-CASE(REC-IN) TO STRINGA
002380 MOVE SPACES TO COMANDO
002390 UNSTRING STRINGA
002400 DELIMITED BY ">>SOURCE FORMAT IS FREE"
002410 INTO COMANDO ISTRUZIONE
002420 END-UNSTRING
002430 IF ISTRUZIONE = SPACES
002440 MOVE "S" TO SW-FREE
002450 MOVE 1 TO REM-COLUMN
002460 MOVE REC-IN TO REC-OUT
002470 WRITE REC-OUT
002480 GO TO LETTURA.
002490
002500 IF REC-IN(7:1) = "*" GO TO LETTURA.
002510
002520*
002530** manage the free format option
002540*
002550
002560 IF SW-FREE = "S"
002570 AND REC-IN > SPACES
002580 PERFORM VARYING IND FROM 1 BY 1 UNTIL IND > 100
002590 OR REC-IN(IND:1) NOT = SPACES
002600 CONTINUE
002610 END-PERFORM
002620
002630 MOVE SPACES TO STRINGA
002640
002650 IF REC-IN(IND:1) = "*"
002660
002670 MOVE 7 TO IND1
002680
002690 IF REC-IN((IND + 1):1) = SPACES
002700 MOVE ">" TO REC-IN((IND + 1) :1)
002710 END-IF
002720
002730 ELSE
002740
002750 MOVE 8 TO IND1
002760
002770 END-IF
002780
002790 MOVE REC-IN(IND: ) TO STRINGA(IND1:)
002800 MOVE STRINGA TO REC-IN
002810
002820 END-IF.
002830
002840 IF REC-IN(7:) = SPACES GO TO LETTURA.
002850
002860
002870 if REC-IN(1:6) NUMERIC
002880 MOVE 7 TO IND
002890 ELSE
002900 MOVE 1 TO IND.
002910
002920 PERFORM VARYING IND FROM IND BY 1 UNTIL IND > 100
002930 OR REC-IN(IND:1) > SPACES
002940 CONTINUE
002950 END-PERFORM.
002960*
002970**** a line with only a character is skiped (.) or other...
002980*
002990 IF REC-IN(IND + 1:) = " " GO TO LETTURA.
003000
003010 MOVE REC-IN(IND:) TO STRINGA.
003020
003030
003040 MOVE ZEROS TO IND.
003050 INSPECT FUNCTION UPPER-CASE(REC-IN)
003060 TALLYING IND FOR ALL ' "CLOSED"'
003070
003080 IF IND = 1 MOVE "N" TO DEFAULT-CLOSED.
003090*
003100
003110
003120 EX-LETTURA.
003130 EXIT.
003140
003150 ELABORA SECTION.
003160
003170 IF FINE-FILE NOT = "S"
003180 PERFORM LETTURA THRU EX-LETTURA
003190 PERFORM TRATTA THRU EX-TRATTA.
003200
003210 EX-ELABORA.
003220 EXIT.
003230
003240 UNSTRINGA-AGAIN.
003250
003260 IF SW-VERBOSE = "S"
003270 display " VERBOSE:loop again for " conta-param " OF "
003280 min-funzione
003290 " " FUNCTION TRIM(STRINGA).
003300
003310 PERFORM LETTURA THRU EX-LETTURA.
003320
003330 IF FINE-FILE = "S" GO TO EX-UNSTRINGA-AGAIN.
003340
003350 PERFORM UNSTRINGA THRU EX-UNSTRINGA.
003360
003370 EX-UNSTRINGA-AGAIN.
003380 EXIT.
003390
003400 UNSTRINGA.
003410
003420 MOVE 1 TO IND.
003430
003440 CICLO-UNSTRINGA.
003450
003460 PERFORM VARYING IND FROM IND BY 1 UNTIL IND > 100
003470 OR STRINGA(IND:1) > SPACES
003480 CONTINUE
003490 END-PERFORM.
003500
003510 IF IND > 100 GO TO FINE-UNSTRINGA.
003520
003530
003540 MOVE STRINGA TO STRINGA1
003550
003560 IF STRINGA(IND:1) = '"'
003570 MOVE IND TO IND2
003580 ADD 1 TO IND2
003590 PERFORM VARYING IND2 FROM IND2 BY 1 UNTIL IND2 > 100
003600 OR STRINGA(IND2:1) = '"'
003610 IF STRINGA1(IND2:1) = SPACE
003620 MOVE "!" TO STRINGA1(IND2:1)
003630 END-IF
003640 END-PERFORM
003650 END-IF.
003660
003670 MOVE 1 TO IND1.
003680 ADD 1 TO CONTA-PARAM.
003690
003700 PERFORM VARYING IND FROM IND BY 1 UNTIL IND > 100
003710 OR STRINGA1(IND:1) = SPACES
003720
003730 IF IND1 NOT > LENGTH OF PARAMETRO(CONTA-PARAM)
003740 MOVE STRINGA(IND:1) TO PARAMETRO(CONTA-PARAM)(IND1:1)
003750 ADD 1 TO IND1
003760 END-IF
003770
003780 END-PERFORM.
003790
003800 IF FUNCTION UPPER-CASE(PARAMETRO(CONTA-PARAM)) = "SELF"
003810 MOVE "agar-Form" TO PARAMETRO(CONTA-PARAM).
003820
003830 IF FUNCTION UPPER-CASE(PARAMETRO(CONTA-PARAM)) = "SELF."
003840 MOVE "agar-Form." TO PARAMETRO(CONTA-PARAM).
003850
003860 IF FUNCTION UPPER-CASE(PARAMETRO(CONTA-PARAM)) = "TRUE "
003870 MOVE "1" TO PARAMETRO(CONTA-PARAM).
003880
003890 IF FUNCTION UPPER-CASE(PARAMETRO(CONTA-PARAM)) = "FALSE "
003900 MOVE "0" TO PARAMETRO(CONTA-PARAM).
003910
003920
003930 GO TO CICLO-UNSTRINGA.
003940
003950 FINE-UNSTRINGA.
003960
003970 MOVE "N" TO METTI-DOT.
003980
003990 IF PARAMETRO(CONTA-PARAM) = "."
004000 MOVE "S" TO METTI-DOT.
004010
004020 PERFORM VARYING IND FROM
004030 LENGTH OF PARAMETRO(CONTA-PARAM)
004040 BY -1 UNTIL IND = ZEROS
004050 OR PARAMETRO(CONTA-PARAM) (IND:1) > SPACES
004060 CONTINUE
004070 END-PERFORM
004080 IF IND > ZEROS
004090 AND PARAMETRO(CONTA-PARAM) (IND:1) = "."
004100 MOVE SPACES TO PARAMETRO(CONTA-PARAM)(IND:1)
004110 MOVE "S" TO METTI-DOT.
004120
004130 EX-UNSTRINGA.
004140 EXIT.
004150
004160 TRATTA.
004170
004180 MOVE SPACES TO TAB-PARAMETRI.
004190
004200 MOVE ZEROS TO IND1.
004210 MOVE ZEROS TO CONTA-PARAM.
004220
004230 PERFORM UNSTRINGA THRU EX-UNSTRINGA.
004240
004250
004260 EVALUATE FUNCTION UPPER-CASE(PARAMETRO(1))
004270
004280*
004290* CASE A: IF "title" of gtk-form .......
004300*
004310
004320 WHEN "IF"
004330
004340 PERFORM ADDED-LINES THRU EX-ADDED-LINES
004350
004360 MOVE ZEROS TO IND1
004370
004380 INSPECT PARAMETRO(2) TALLYING IND1 FOR ALL '"'
004390
004400 IF IND1 = 2
004410 AND FUNCTION UPPER-CASE(PARAMETRO(3)) = "OF"
004420 PERFORM DO-IF THRU EX-DO-IF
004430 GO TO EX-TRATTA
004440
004450
004460 WHEN "INVOKE"
004470
004480 PERFORM ADDED-LINES THRU EX-ADDED-LINES
004490
004500 PERFORM DO-INVOKE THRU EX-DO-INVOKE
004510 GO TO EX-TRATTA
004520
004530 WHEN "MOVE"
004540
004550 PERFORM ADDED-LINES THRU EX-ADDED-LINES
004560*
004570* CASE A: move "name of the window" to "title" of gtk-form.
004580*
004590 MOVE ZEROS TO IND1
004600 INSPECT PARAMETRO(4) TALLYING IND1 FOR ALL '"'
004610
004620 IF IND1 = 2
004630 AND FUNCTION UPPER-CASE(PARAMETRO(3)) = "TO"
004640 PERFORM FAI-SET THRU EX-FAI-SET
004650 GO TO EX-TRATTA
004660 END-IF
004670*
004680*
004690* CASE --- move function uppercase("gray") to "title" of gtk-form.
004700*
004710 MOVE ZEROS TO IND1
004720 INSPECT PARAMETRO(5) TALLYING IND1 FOR ALL '"'
004730
004740 IF IND1 = 2
004750 AND (FUNCTION UPPER-CASE(PARAMETRO(2)) = "FUNCTION"
004760 AND FUNCTION UPPER-CASE(PARAMETRO(4)) = "TO"
004770 AND FUNCTION UPPER-CASE(PARAMETRO(6)) = "OF" )
004780
004790 PERFORM VARYING IND1 FROM 3 BY 1
004800 UNTIL IND1 > CONTA-PARAM
004810
004820 MOVE PARAMETRO(IND1) TO PARAMETRO( IND1 - 1)
004830
004840 END-PERFORM
004850
004860 MOVE SPACES TO PARAMETRO(CONTA-PARAM)
004870 SUBTRACT 1 FROM CONTA-PARAM
004880
004890 PERFORM FAI-SET THRU EX-FAI-SET
004900 GO TO EX-TRATTA
004910 END-IF
004920
004930** a token with ---> " OF " ----> MEANS move to get a value
004940* infact you could have coded:
004950*
004960* CASE B: move "title" of gtk-form to TITLE-OF-THE-FORM.
004970*
004980*
004990 MOVE ZEROS TO IND1
005000
005010 INSPECT PARAMETRO(2) TALLYING IND1 FOR ALL '"'
005020
005030 IF IND1 = 2
005040 AND FUNCTION UPPER-CASE(PARAMETRO(3)) = "OF"
005050 AND FUNCTION UPPER-CASE(PARAMETRO(7)) NOT = "OF"
005060
005070 MOVE PARAMETRO(2) (2:) TO ISTRUZIONE
005080 INSPECT ISTRUZIONE REPLACING ALL '"' BY " "
005090 PERFORM DO-GET THRU EX-DO-GET
005100 GO TO EX-TRATTA
005110 END-IF
005120*
005130* CASE C: move "title" of gtk-form to "Text" of EDIT.
005140*
005150
005160 MOVE ZEROS TO IND1
005170
005180 INSPECT PARAMETRO(2) TALLYING IND1 FOR ALL '"'
005190
005200 IF IND1 = 2
005210 AND FUNCTION UPPER-CASE(PARAMETRO(3)) = "OF"
005220 AND FUNCTION UPPER-CASE(PARAMETRO(7)) = "OF"
005230
005240 MOVE PARAMETRO(6) TO PARAMETRO1
005250 MOVE PARAMETRO(7) TO PARAMETRO2
005260 MOVE PARAMETRO(8) TO PARAMETRO3
005270 MOVE PARAMETRO(9) TO PARAMETRO4
005280
005290 MOVE "agar-text" TO PARAMETRO(6)
005300 MOVE SPACES TO PARAMETRO(7)
005310 MOVE SPACES TO PARAMETRO(8)
005320 MOVE SPACES TO PARAMETRO(9)
005330 MOVE METTI-DOT TO REMEMBER-METTI-DOT
005340
005350 MOVE PARAMETRO(2) (2:) TO ISTRUZIONE
005360 INSPECT ISTRUZIONE REPLACING ALL '"' BY " "
005370
005380 PERFORM DO-GET THRU EX-DO-GET
005390
005400 INITIALIZE TAB-PARAMETRI
005410
005420
005430 MOVE REMEMBER-METTI-DOT TO METTI-DOT
005440 MOVE "move" TO PARAMETRO(1)
005450 MOVE "agar-text" TO PARAMETRO(2)
005460 MOVE "to" TO PARAMETRO(3)
005470 MOVE PARAMETRO1 TO PARAMETRO(4)
005480 MOVE PARAMETRO2 TO PARAMETRO(5)
005490 MOVE PARAMETRO3 TO PARAMETRO(6)
005500 MOVE PARAMETRO4 TO PARAMETRO(7)
005510 MOVE SPACES TO STRINGA
005520
005530 STRING
005540 PARAMETRO(1) DELIMITED BY " "
005550 " " DELIMITED BY SIZE
005560 PARAMETRO(2) DELIMITED BY " "
005570 " " DELIMITED BY SIZE
005580 PARAMETRO(3) DELIMITED BY " "
005590 " " DELIMITED BY SIZE
005600 PARAMETRO(4) DELIMITED BY " "
005610 " " DELIMITED BY SIZE
005620 PARAMETRO(5) DELIMITED BY " "
005630 " " DELIMITED BY SIZE
005640 PARAMETRO(6) DELIMITED BY " "
005650 " " DELIMITED BY SIZE
005660 PARAMETRO(7) DELIMITED BY " "
005670 " " DELIMITED BY SIZE
005680 INTO STRINGA
005690
005700 PERFORM FAI-SET THRU EX-FAI-SET
005710
005720 MOVE SPACES TO DATI-IN STRINGA
005730
005740 GO TO EX-TRATTA
005750 END-IF
005760
005770
005780 END-EVALUATE.
005790
005800 MOVE ZEROS TO IND1.
005810
005820 move function upper-case(DATI-IN) TO DATI-OUT
005830
005840 INSPECT DATI-OUT TALLYING IND1 FOR
005850 ALL "WORKING-STORAGE SECTION".
005860
005870 IF IND1 = 1
005880 MOVE DATI-IN TO DATI-OUT
005890 PERFORM SCRITTURA THRU EX-SCRITTURA
005900 MOVE ' copy "global".' tO DATI-OUT
005910 PERFORM SCRITTURA THRU EX-SCRITTURA
005920
005930 ADD 1 TO CONTA-WORKING-STORAGE
005940
005950 IF CONTA-WORKING-STORAGE > 1
005960 MOVE ' copy "working".' tO DATI-IN
005970 ELSE
005980 MOVE SPACES TO DATI-IN
005990 END-IF
006000
006010 go to FINE-TRATTA.
006020
006030 MOVE ZEROS TO IND1.
006040
006050 INSPECT DATI-OUT TALLYING IND1 FOR ALL
006060 '"COPY GLOBAL".'.
006070 IF IND1 = 1 GO TO END-TRATTA.
006080
006090 INSPECT DATI-OUT TALLYING IND1 FOR ALL
006100 '"COPY GLOBAL.CPY".'.
006110
006120 IF IND1 = 1 GO TO END-TRATTA.
006130
006140
006150 FINE-TRATTA.
006160
006170 MOVE ZEROS TO IND1
006180 INSPECT
006190 FUNCTION UPPER-CASE(DATI-IN)
006200 TALLYING IND1 FOR ALL "END "
006210
006220 IF IND1 = 1
006230
006240 move zeros to IND1
006250
006260 INSPECT
006270 FUNCTION UPPER-CASE(DATI-IN)
006280 TALLYING IND1 FOR ALL "METHOD."
006290
006300 IF IND1 = 1
006310 PERFORM ADDED-LINES THRU EX-ADDED-LINES
006320
006330 PERFORM FAI-ENDMETHOD THRU EX-FAI-ENDMETHOD
006340 GO TO EX-TRATTA.
006350
006360 MOVE ZEROS TO IND1
006370 INSPECT
006380 FUNCTION UPPER-CASE(DATI-IN)
006390 TALLYING IND1 FOR ALL "METHOD-ID."
006400
006410 IF IND1 = 1
006420 PERFORM ADDED-LINES THRU EX-ADDED-LINES
006430 PERFORM FAI-METHOD THRU EX-FAI-METHOD
006440 GO TO EX-TRATTA.
006450
006460 MOVE DATI-IN TO DATI-OUT.
006470
006480 PERFORM SCRITTURA THRU EX-SCRITTURA.
006490
006500 END-TRATTA.
006510
006520 MOVE ZEROS TO IND1
006530 INSPECT
006540 FUNCTION UPPER-CASE(DATI-IN)
006550 TALLYING IND1 FOR ALL "EXTERNAL"
006560
006570 IF IND1 = 1
006580 MOVE DATI-IN TO REC-WORK
006590 WRITE REC-WORK.
006600
006610 EX-TRATTA.
006620 EXIT.
006630
006640
006650 FAI-METHOD.
006660
006670 MOVE SPACES TO IDENTIFICATION-DIVISION.
006680
006690 UNSTRING DATI-IN DELIMITED BY "."
006700 INTO dummy IDENTIFICATION-DIVISION
006710
006720 DISPLAY "METHOD:" IDENTIFICATION-DIVISION.
006730
006740 move spaces to DATI-OUT
006750 MOVE " identification division." TO REC-OUT
006760 PERFORM SCRITTURA THRU EX-SCRITTURA
006770 STRING " program-id. "
006780 FUNCTION TRIM(IDENTIFICATION-DIVISION)
006790 "."
006800 delimited by size into DATI-OUT
006810 PERFORM SCRITTURA THRU EX-SCRITTURA
006820
006830 MOVE " environment division." TO REC-OUT
006840 PERFORM SCRITTURA THRU EX-SCRITTURA
006850
006860 MOVE " data division." TO REC-OUT
006870 PERFORM SCRITTURA THRU EX-SCRITTURA
006880
006890 MOVE " working-storage section." TO REC-OUT
006900 PERFORM SCRITTURA THRU EX-SCRITTURA
006910
006920 MOVE ' copy "global".' tO DATI-OUT
006930 PERFORM SCRITTURA THRU EX-SCRITTURA
006940
006950 MOVE ' copy "working".' TO DATI-OUT
006960 PERFORM SCRITTURA THRU EX-SCRITTURA
006970
006980 *> MOVE " procedure division." TO REC-OUT
006990 *> PERFORM SCRITTURA THRU EX-SCRITTURA
007000
007010
007020 MOVE SPACES TO DATI-IN.
007030
007040 EX-FAI-METHOD.
007050 EXIT.
007060
007070 FAI-ENDMETHOD.
007080*
007090**** do not remove: leave this split into separate lines to allows the tp-cobol-debugger to run inside guicobol.cbl itself for testing...
007100*
007110 STRING " end"
007120 " program "
007130 FUNCTION TRIM(IDENTIFICATION-DIVISION)
007140 "."
007150 delimited by size into DATI-OUT
007160 PERFORM SCRITTURA THRU EX-SCRITTURA
007170 MOVE SPACES TO DATI-IN.
007180
007190 EX-FAI-ENDMETHOD.
007200 EXIT.
007210
007220
007230 FAI-SET.
007240
007250 MOVE ZEROS TO IND
007260 INSPECT STRINGA TALLYING IND FOR ALL '"'
007270
007280 IF IND = ZEROS GO TO EX-FAI-SET.
007290
007300 MOVE " TO " TO COMPARA
007310 MOVE 4 TO LCOMPARA
007320 PERFORM VARYING IND FROM 1 BY 1 UNTIL IND >
007330 ( LENGTH OF STRINGA - 4 )
007340 OR FUNCTION UPPER-CASE(STRINGA(IND:LCOMPARA))
007350 = COMPARA(1:LCOMPARA)
007360 CONTINUE
007370 END-PERFORM.
007380
007390 IF IND NOT > ( LENGTH OF STRINGA - 4 )
007400 AND FUNCTION UPPER-CASE(STRINGA(IND:LCOMPARA))
007410 = COMPARA(1:LCOMPARA)
007420 MOVE IND TO END-COBOL
007430 MOVE STRINGA(1:END-COBOL) TO STRINGA2
007440 ADD 3 TO IND
007450 PERFORM VARYING IND FROM IND BY 1
007460 UNTIL IND > LENGTH OF STRINGA
007470 OR STRINGA(IND:1) > SPACES
007480 CONTINUE
007490 END-PERFORM
007500 IF IND NOT > LENGTH OF STRINGA
007510 AND STRINGA(IND:1) = '"'
007520 ADD 1 TO IND
007530 MOVE ZEROS TO IND1
007540 MOVE SPACES TO ISTRUZIONE
007550 PERFORM VARYING IND FROM IND BY 1
007560 UNTIL IND > LENGTH OF STRINGA
007570 OR STRINGA(IND:1) = '"'
007580 ADD 1 TO IND1
007590 MOVE STRINGA(IND:1) TO ISTRUZIONE(IND1:1)
007600 END-PERFORM
007610 PERFORM DO-SET THRU EX-DO-SET.
007620
007630 EX-FAI-SET.
007640 EXIT.
007650
007660 SCRITTURA.
007670
007680 IF REC-OUT = SPACES GO TO EX-SCRITTURA.
007690
007700 ADD 1 TO CONTA-LINE.
007710
007720 IF SW-FREE = "S"
007730 MOVE REC-OUT(7:) TO STRINGA
007740 MOVE STRINGA TO REC-OUT
007750 ELSE
007760 MOVE CONTA-LINE TO REC-OUT(1:6).
007770
007780 WRITE REC-OUT.
007790
007800 move SPACES TO REC-OUT.
007810
007820 EX-SCRITTURA.
007830 EXIT.
007840
007850
007860 APERTURE SECTION.
007870
007880 IF SW-VERBOSE = "S"
007890 Display "VERBOSE:Processing open file..".
007900
007910 MOVE ZEROS TO IND.
007920 INSPECT FILE-IN TALLYING IND FOR ALL ".gui".
007930 IF IND = 1
007940 DISPLAY "Source cannot contains .gui extension"
007950 STOP RUN.
007960
007970 MOVE ZEROS TO IND
007980 INSPECT FILE-IN TALLYING IND FOR ALL ".cbl".
007990 INSPECT FILE-IN TALLYING IND FOR ALL ".src".
008000 INSPECT FILE-IN TALLYING IND FOR ALL ".cpy".
008010 INSPECT FILE-IN TALLYING IND FOR ALL ".CBL".
008020 INSPECT FILE-IN TALLYING IND FOR ALL ".SRC".
008030 INSPECT FILE-IN TALLYING IND FOR ALL ".CPY".
008040 INSPECT FILE-IN TALLYING IND FOR ALL ".COB".
008050 INSPECT FILE-IN TALLYING IND FOR ALL ".cob".
008060*
008070* ADD THE DEFAULT .CBL ESTENSION....
008080*
008090 IF IND = ZEROS
008100 PERFORM VARYING IND FROM 100 BY -1 UNTIL IND = ZEROS
008110
008120 IF FILE-IN(IND:1) NOT = SPACES
008130 ADD 1 TO IND
008140 MOVE ".cbl" TO FILE-IN(IND:)
008150 MOVE 1 TO IND
008160 END-IF
008170 END-PERFORM
008180 END-IF.
008190
008200
008210 MOVE FILE-IN TO FILE-OUT.
008220
008230 INSPECT FILE-OUT REPLACING ALL ".CBL" BY ".gui".
008240 INSPECT FILE-OUT REPLACING ALL ".SRC" BY ".gui".
008250 INSPECT FILE-OUT REPLACING ALL ".CPY" BY ".gui".
008260 INSPECT FILE-OUT REPLACING ALL ".cbl" BY ".gui".
008270 INSPECT FILE-OUT REPLACING ALL ".src" BY ".gui".
008280 INSPECT FILE-OUT REPLACING ALL ".cpy" BY ".gui".
008290 INSPECT FILE-OUT REPLACING ALL ".COB" BY ".gui".
008300 INSPECT FILE-OUT REPLACING ALL ".cob" BY ".gui".
008310 MOVE ZEROS TO IND
008320 INSPECT FILE-OUT TALLYING IND FOR ALL ".gui"
008330 IF IND NOT = 1
008340 DISPLAY "Source must contains cbl/src/cpy/cob " &
008350 "(upper/lower case) extension"
008360 STOP RUN.
008370
008380 OPEN INPUT ARK-IN.
008390
008400 IF STATUS-IN NOT = 00
008410 DISPLAY "The source supplied is not available "
008420 STATUS-IN
008430 " (file:" function trim(FILE-IN) " )"
008440 STOP RUN
008450 END-IF.
008460
008470
008480 IF SW-CONST = "S"
008490 MOVE "ANDATI" TO FILE-SYS
008500 ELSE
008510 ACCEPT TIME-SYS FROM TIME
008520 MOVE TIME-SYS TO FILE-SYS
008530 END-IF.
008540
008550 OPEN OUTPUT ARK-OUT.
008560
008570 IF STATUS-OUT NOT = 00
008580 DISPLAY "Unable to create:" FILE-OUT
008590 STOP RUN
008600 END-IF.
008610
008620 MOVE "working.cpy" to FILE-WORK.
008630 OPEN OUTPUT ARK-WORK.
008640
008650 IF STATUS-WORK NOT = 00
008660 DISPLAY "Unable to create:" FILE-WORK
008670 STOP RUN
008680 END-IF.
008690
008700 move SPACES TO REC-WORK.
008710
008720 MOVE " *" TO REC-WORK. WRITE REC-WORK.
008730
008740 MOVE " * INTERNAL WORKING STORAGE" TO REC-WORK.
008750 WRITE REC-WORK.
008760
008770 MOVE " *" TO REC-WORK. WRITE REC-WORK.
008780
008790 EX-APERTURE.
008800 EXIT.
008810
008820
008830 CHIUSURE SECTION.
008840 CHIUSUREX.
008850
008860 MOVE SPACES TO STRINGA.
008870
008880 IF EXIT-WITH-ERRORS = "Y"
008890 MOVE "Found errors, please check them" TO STRINGA
008900 ELSE
008910 STRING "Done...please compile the build "
008920 function trim(FILE-OUT)
008930 " source program. " DELIMITED BY SIZE INTO STRINGA.
008940
008950 DISPLAY STRINGA.
008960
008970 MOVE SPACES TO STRINGA.
008980
008990 CLOSE ARK-IN ARK-OUT ARK-WORK.
009000
009010 IF SW-VERBOSE = "S"
009020 IF DEFAULT-CLOSED = "Y"
009030 display "VERBOSE: added a closed default procedure..."
009040 else
009050 display
009051 "VERBOSE: A custom closed was found not used default".
009060
009070
009080
009090 EX-CHIUSURE.
009100 EXIT.
009110
009120 READ-NEXT-DO.
009130
009140 MOVE SPACES TO REC-DO EOF-DO.
009150
009160 READ ARK-DO NEXT RECORD AT END
009170 MOVE "S" TO EOF-DO.
009180
009190
009200 IF EOF-DO = "S"
009210 MOVE SPACES TO REC-DO
009220 GO TO EX-READ-NEXT-DO.
009230
009240 IF DATI-DO = SPACES GO TO READ-NEXT-DO.
009250
009260 IF DATI-DO(1:1) = "*" GO TO READ-NEXT-DO.
009270
009280
009290 EX-READ-NEXT-DO.
009300 EXIT.
009310
009320 LOGO.
009330 DISPLAY
009340 "GuiCOBOL builder for GNUCOBOL "
009350 "Versione 0.1.2.25 Package 18-10-2020".
009360 DISPLAY "CopyRight(C) 2011-2020 Federico Priolo "
009370 DISPLAY " ".
009380 DISPLAY "federico.priolo@tp-one.it ".
009390 DISPLAY " ".
009400 DISPLAY " ".
009410
009420 IF SW-VERBOSE = "S"
009430 DISPLAY "VERBOSE: Running on " TYPE-SYSTEM
009440 DISPLAY "VERBOSE: Processing command line..".
009450 EX-LOGO.
009460 EXIT.
009470
009480 INIZIALI.
009490
009500 INITIALIZE PARAMETRI.
009510
009520
009530 MOVE 7 TO REM-COLUMN.
009540
009550 ACCEPT TYPE-SYSTEM FROM ENVIRONMENT 'OS' END-ACCEPT.
009560
009570 IF TYPE-SYSTEM NOT > SPACES
009580 ACCEPT TYPE-SYSTEM FROM ENVIRONMENT 'OSTYPE' END-ACCEPT
009590 END-IF.
009600
009610* if true at end guicobol adds a default closed procedure
009620
009630 MOVE "Y" TO DEFAULT-CLOSED.
009640
009650
009660 EX-INIZIALI.
009670 EXIT.
009680
009690 HELP.
009700
009710 DISPLAY "Usage: guicobol projectfile [options]".
009720 DISPLAY " ".
009730 DISPLAY "File: cobol source.cbl/cpy/src (if no suplied"
009740 '".cbl" is added by default....)'.
009750 DISPLAY " ".
009760 DISPLAY "Options: ".
009770 DISPLAY "-? This support panel "
009780 DISPLAY "-F use free format "
009790 DISPLAY "-v Turn on verbose ".
009800
009810 EX-HELP.
009820 EXIT.
009830
009840 OPZIONI.
009850
009860 ACCEPT FILE-DO FROM ENVIRONMENT "guicobol_inf"
009870 END-ACCEPT.
009880
009890 IF FILE-DO = SPACES
009900 MOVE "guicobol.inf" TO FILE-DO.
009910
009920
009930****************** > here we are sure that the command have something
009940
009950 PERFORM VARYING IND FROM 1 BY 1 UNTIL IND > 100
009960 OR FILE-IN(IND:1) NOT = SPACES
009970 CONTINUE
009980 END-PERFORM.
009990