/
semantio.c
6240 lines (5926 loc) · 175 KB
/
semantio.c
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
/*
* Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*
*/
/** \file
\brief Semantic analyzer routines which process IO statements.
*/
#include "gbldefs.h"
#include "global.h"
#include "gramsm.h"
#include "gramtk.h"
#include "error.h"
#include "symtab.h"
#include "symutl.h"
#include "dtypeutl.h"
#include "semant.h"
#include "scan.h"
#include "dinit.h"
#include "semstk.h"
#include "ast.h"
#include "feddesc.h"
#include "rte.h"
#include "rtlRtns.h"
/* generate asts for calling an io routine; must be performed in the
* the following order:
* begin_io_call()
* add_io_arg() [zero or more calls]
* end_io_call() [optional assignment of function]
*/
static struct { /* record info for begin_io_call - end_io_call */
int ast;
int ast_type;
int std;
} io_call;
/*-------- define data structures and macros local to this file: --------*/
/* define macros used to access table the I/O parameter table, "pt".
* All of the macros that can be used in the INQUIRE statement are at
* the beginning (their values range from 0 .. PT_LAST_INQUIRE_VAL).
* These are in the order specified by the fio_inquire routine in the
* HPF Execution Environment spec. and only include those which are passed
* as arguments. Note that ERR is not passed to fio_inquire.
*
* N O T E: The static array of struct, pt, is initialized the names of
* these parameters. If changes are made to the PT_ macros,
* R E M E M B E R to change ptname.
*/
#define PT_UNIT 0
#define PT_FILE 1
#define PT_IOSTAT 2
#define PT_EXIST 3
#define PT_OPENED 4
#define PT_NUMBER 5
#define PT_NAMED 6
#define PT_NAME 7
#define PT_ACCESS 8
#define PT_SEQUENTIAL 9
#define PT_DIRECT 10
#define PT_FORM 11
#define PT_FORMATTED 12
#define PT_UNFORMATTED 13
#define PT_RECL 14
#define PT_NEXTREC 15
#define PT_BLANK 16
#define PT_POSITION 17
#define PT_ACTION 18
#define PT_READ 19
#define PT_WRITE 20
#define PT_READWRITE 21
#define PT_DELIM 22
#define PT_PAD 23
#define PT_ID 24
#define PT_PENDING 25
#define PT_POS 26
#define PT_SIZE 27
#define PT_ASYNCHRONOUS 28
#define PT_DECIMAL 29
#define PT_ENCODING 30
#define PT_SIGN 31
#define PT_STREAM 32
#define PT_ROUND 33
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* end of INQUIRE parameters: make sure that PT_LAST_INQUIRE_VAL is set
* to the last inquire value.
* Values <= including PT_LAST_INQUIRE_VALf95 are f95 inquire specifiers
* values > PT_LAST_INQUIRE_VALf95 and <= PT_LAST_INQUIRE_VAL are the new
* f2003 inquire specifiers.
*
* PT_IOLENGTH is only present since certain utility functions, such as
* chk_var, require a 'pt' argument.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
#define PT_DISPOSE 34
#define PT_END 35
#define PT_ERR 36
#define PT_FMT 37
#define PT_NML 38
#define PT_REC 39
#define PT_STATUS 40
#define PT_ADVANCE 41
#define PT_EOR 42
#define PT_IOLENGTH 43
#define PT_CONVERT 44
#define PT_SHARED 45
#define PT_IOMSG 46
#define PT_NEWUNIT 47
#define PT_LAST_INQUIRE_VALf95 PT_PAD
#define PT_LAST_INQUIRE_VAL 33
#define PT_MAXV 47
/*
* define bit flag for each I/O statement. Used for checking
* illegal cases of I/O keyword specifiers.
*/
#define BT_ACCEPT 0x00001
#define BT_BKSPACE 0x00002
#define BT_CLOSE 0x00004
#define BT_DECODE 0x00008
#define BT_ENCODE 0x00010
#define BT_ENDFILE 0x00020
#define BT_INQUIRE 0x00040
#define BT_OPEN 0x00080
#define BT_PRINT 0x00100
#define BT_READ 0x00200
#define BT_REWIND 0x00400
#define BT_WRITE 0x00800
#define BT_WAIT 0x01000
#define BT_FLUSH 0x02000
/* define macros for the edit descriptors */
#define PUT(n) (_put((INT)(n), DT_INT))
/* define format type macros: */
typedef enum {
FT_UNFORMATTED = 1,
FT_LIST_DIRECTED = 2,
FT_ENCODED = 3,
FT_CHARACTER = 4,
FT_NML = 5,
FT_FMTSTR = 6,
FT_LAST = 7
} FormatType;
/* Array indexed by [is_read][<format type from above>] */
static int functype[2][FT_LAST] = {
{DT_IO_FWRITE, DT_IO_UWRITE, DT_IO_FWRITE, DT_IO_FWRITE, DT_IO_FWRITE,
DT_IO_FWRITE, DT_IO_FWRITE},
{DT_IO_FREAD, DT_IO_UREAD, DT_IO_FREAD, DT_IO_FREAD, DT_IO_FREAD,
DT_IO_FREAD, DT_IO_FREAD}};
/* miscellaneous macros: */
#define DEFAULT_UNIT (is_read ? 5 : 6)
#define IOERR(n) errsev(n)
#define IOERR2(n, s) error(n, 3, gbl.lineno, s, CNULL)
#define ERR170(s) error(170, 2, gbl.lineno, s, CNULL)
#define ERR204(s1, s2) error(204, 3, gbl.lineno, s1, s2)
#define PTV(d) pt[d].val
#define PT_CHECK(a, b) \
if (PTV(a) == 0) \
PTV(a) = b
#define PTS(a) pt[a].set
#define PT_SET(a) PTS(a) = 1
#define PTVARREF(a) pt[a].varref
#define PT_VARREF(a, v) PTVARREF(a) = (v)
#define PTTMPUSED(a) pt[a].tmp_in_use
#define PT_TMPUSED(a, v) (pt[a].tmp_in_use = (v))
#define PTARG(a) \
(PTVARREF(a) && PTVARREF(a) != 1 ? PT_TMPUSED(a, 1), PTV(a) : PTV(a))
#define PTNAME(a) pt[a].name
#define PTSTMT(a) pt[a].stmt
#define UNIT_CHECK \
if (PTV(PT_UNIT) == 0) \
IOERR(200)
/* typedef and macros to access io lists: */
typedef struct iol {
struct iol *next;
SST *element;
DOINFO *doinfo;
int id;
int l_std; /* list of stds added after the left paren of an
* implied-do is parsed */
} IOL;
#define IE_EXPR 0
#define IE_DOBEGIN 1
#define IE_DOEND 2
#define IE_OPTDO 3
/* local data */
static struct pt_tag { /* parameter table for I/O statements */
int val; /* pointer to AST of I/O keyword specifier, except
* for a keyword specifier for a label, in which
* case val is the sptr of the label.
*/
int set;
int varref; /* zero ==> io specifier is not a variable,
* non-zero ==> io specifier is a variable reference,
* where
* the value 1 means that the variable is
* being used directly, and any other
* non zero value implies that a temp
* value is being used in which case
* 1) val contains the ast referencing
* the temp
* 2) and varref (this field) contains
* the ast referencing the original
* variable.
*/
int tmp_in_use; /* 1==>a tmp is being used in the current call (see above) */
char *name;
int stmt; /* I/O stmts which may use parameter/keyword */
} pt[PT_MAXV + 1] = {
{0, 0, 0, 0, "UNIT",
BT_BKSPACE | BT_CLOSE | BT_ENDFILE | BT_INQUIRE | BT_OPEN | BT_READ |
BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH},
{0, 0, 0, 0, "FILE", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "IOSTAT",
BT_BKSPACE | BT_CLOSE | BT_DECODE | BT_ENCODE | BT_ENDFILE | BT_INQUIRE |
BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH},
{0, 0, 0, 0, "EXIST", BT_INQUIRE},
{0, 0, 0, 0, "OPENED", BT_INQUIRE},
{0, 0, 0, 0, "NUMBER", BT_INQUIRE},
{0, 0, 0, 0, "NAMED", BT_INQUIRE},
{0, 0, 0, 0, "NAME", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "ACCESS", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "SEQUENTIAL", BT_INQUIRE},
{0, 0, 0, 0, "DIRECT", BT_INQUIRE},
{0, 0, 0, 0, "FORM", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "FORMATTED", BT_INQUIRE},
{0, 0, 0, 0, "UNFORMATTED", BT_INQUIRE},
{0, 0, 0, 0, "RECL", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "NEXTREC", BT_INQUIRE},
{0, 0, 0, 0, "BLANK", BT_INQUIRE | BT_OPEN | BT_READ},
{0, 0, 0, 0, "POSITION", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "ACTION", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "READ", BT_INQUIRE},
{0, 0, 0, 0, "WRITE", BT_INQUIRE},
{0, 0, 0, 0, "READWRITE", BT_INQUIRE},
{0, 0, 0, 0, "DELIM", BT_INQUIRE | BT_OPEN | BT_WRITE},
{0, 0, 0, 0, "PAD", BT_INQUIRE | BT_OPEN | BT_READ},
{0, 0, 0, 0, "ID", BT_INQUIRE | BT_READ | BT_WRITE | BT_WAIT},
{0, 0, 0, 0, "PENDING", BT_INQUIRE},
{0, 0, 0, 0, "POS", BT_INQUIRE | BT_READ | BT_WRITE},
{0, 0, 0, 0, "SIZE", BT_INQUIRE | BT_READ | BT_WRITE},
{0, 0, 0, 0, "ASYNCHRONOUS", BT_INQUIRE | BT_OPEN | BT_READ | BT_WRITE},
{0, 0, 0, 0, "DECIMAL", BT_INQUIRE | BT_OPEN | BT_READ | BT_WRITE},
{0, 0, 0, 0, "ENCODING", BT_INQUIRE | BT_OPEN},
{0, 0, 0, 0, "SIGN", BT_INQUIRE | BT_OPEN | BT_WRITE},
{0, 0, 0, 0, "STREAM", BT_INQUIRE},
{0, 0, 0, 0, "ROUND", BT_INQUIRE | BT_OPEN | BT_READ | BT_WRITE},
{0, 0, 0, 0, "DISPOSE", BT_CLOSE | BT_OPEN},
{0, 0, 0, 0, "END", BT_READ | BT_WAIT},
{0, 0, 0, 0, "ERR",
BT_BKSPACE | BT_CLOSE | BT_DECODE | BT_ENCODE | BT_ENDFILE | BT_INQUIRE |
BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH},
{0, 0, 0, 0, "FMT", BT_READ | BT_WRITE},
{0, 0, 0, 0, "NML", BT_READ | BT_WRITE},
{0, 0, 0, 0, "REC", BT_READ | BT_WRITE},
{0, 0, 0, 0, "STATUS", BT_CLOSE | BT_OPEN},
{0, 0, 0, 0, "ADVANCE", BT_READ | BT_WRITE},
{0, 0, 0, 0, "EOR", BT_READ | BT_WAIT},
{0, 0, 0, 0, "IOLENGTH", BT_INQUIRE},
{0, 0, 0, 0, "CONVERT", BT_OPEN},
{0, 0, 0, 0, "SHARED", BT_OPEN},
{0, 0, 0, 0, "IOMSG",
BT_BKSPACE | BT_CLOSE | BT_DECODE | BT_ENCODE | BT_ENDFILE | BT_INQUIRE |
BT_OPEN | BT_READ | BT_REWIND | BT_WRITE | BT_WAIT | BT_FLUSH},
{0, 0, 0, 0, "NEWUNIT", BT_OPEN},
};
static FormatType fmttyp; /* formatted or unformatted I/O */
static int nml_group; /* sptr to namelist group ident */
static int intern_array; /* AST of array section used as internal unit*/
static int intern_tmp; /* AST of temp replacing 'intern_array' */
static LOGICAL intern; /* internal I/O flag */
static LOGICAL external_io; /* set for any external I/O statement */
static LOGICAL nondevice_io; /* set for any I/O statement not allowed in CUDA
device code */
static LOGICAL is_read; /* read flag */
static LOGICAL no_rw; /* statement DOES NOT read or write */
static LOGICAL print_star; /* PRINT * */
static LOGICAL unit_star; /* unit is * */
static int fmt_is_var; /* FMT specifier is a variable */
static int fasize; /* size in units of 32-bit words of the format
* list */
static int rescan; /* where formatted I/O begins rescanning if
* there are more I/O items than edit
* descriptors */
static int lastrpt; /* marks where the last repeat count seen while
* processing edit descriptors is in the
* format list */
static int edit_state; /* state transition value for edit descriptor
* processing -- used for checking "delimiter
* conformance" */
static int last_edit; /* last edit descriptor seen */
static int fmt_length; /* ast representing length of an unencoded
* format string (FT_CHARACTER).
*/
static INT num[2]; /* scratch area for making integer constants */
static int filename_type = 0; /* TY_CHAR or TY_NCHAR */
static int iolist; /* ASTLI list for io items in read/write */
static LOGICAL noparens; /* no parens enclosing control list */
static LOGICAL open03; /* any f2003 open specfiers */
static LOGICAL rw03; /* any f2003 read/write specifiers */
static INT bitv; /* bit vector for IOSTAT, END, and ERR: */
#define BITV_IOSTAT 0x01
#define BITV_ERR 0x02
#define BITV_END 0x04
#define BITV_EOR 0x08
#define BITV_IOMSG 0x10
/*
* the following values are not seen by the runtime and are just used to
* check for illegal combinations of I/O specifers.
*/
#define BITV_SIZE 0x020
#define BITV_ADVANCE 0x040
#define BYTE_SWAPPED_IO (XBIT(125, 0x2) != 0)
#define LARGE_ARRAY (XBIT(68, 1) != 0)
/* Selectable unfomatted i/o routines:
* Indexed by:
* 1) LARGE_ARRAY_IDX
*
* 2) 0 - normal unformatted i/o (file format matches native byte order)
* 1 - byte-swapped unf i/o (file format is reversed from native byte order).
* 2 - byte read/write
*
* '-x 125 2' is used to select one of the first two entries; aggregate
* unformatted i/o selects the third entry.
*/
#define BYTE_SWAPPED_IO_IDX ((BYTE_SWAPPED_IO) ? 1 : 0)
#define LARGE_ARRAY_IDX ((LARGE_ARRAY) ? 1 : 0)
#define BYTE_RW_IDX 2
typedef struct {
FtnRtlEnum init;
FtnRtlEnum read;
FtnRtlEnum write;
FtnRtlEnum end;
} UnformattedRtns;
UnformattedRtns unf_nm[][3] = {{
{RTE_f90io_unf_init, RTE_f90io_unf_reada,
RTE_f90io_unf_writea, RTE_f90io_unf_end},
{RTE_f90io_usw_init, RTE_f90io_usw_reada,
RTE_f90io_usw_writea, RTE_f90io_usw_end},
{RTE_f90io_unf_init, RTE_f90io_byte_reada,
RTE_f90io_byte_writea, RTE_f90io_unf_end},
},
{
{RTE_f90io_unf_init, RTE_f90io_unf_reada,
RTE_f90io_unf_writea, RTE_f90io_unf_end},
{RTE_f90io_usw_init, RTE_f90io_usw_reada,
RTE_f90io_usw_writea, RTE_f90io_usw_end},
{RTE_f90io_unf_init, RTE_f90io_byte_read64a,
RTE_f90io_byte_write64a, RTE_f90io_unf_end},
}};
UnformattedRtns array_unf_nm[][3] = {
{
{RTE_f90io_unf_init, RTE_f90io_unf_read_aa, RTE_f90io_unf_write_aa,
RTE_f90io_unf_end},
{RTE_f90io_usw_init, RTE_f90io_usw_read_aa, RTE_f90io_usw_write_aa,
RTE_f90io_usw_end},
{RTE_f90io_unf_init, RTE_f90io_byte_reada, RTE_f90io_byte_writea,
RTE_f90io_unf_end},
},
{
{RTE_f90io_unf_init, RTE_f90io_unf_read64_aa, RTE_f90io_unf_write64_aa,
RTE_f90io_unf_end},
{RTE_f90io_usw_init, RTE_f90io_usw_read64_aa, RTE_f90io_usw_write64_aa,
RTE_f90io_usw_end},
{RTE_f90io_unf_init, RTE_f90io_byte_read64a, RTE_f90io_byte_write64a,
RTE_f90io_unf_end},
}};
/* Selectable formatted init routines:
* 0 - external i/o
* 0 - encoded format or not present
* 1 - fmt specifier is a variable
* 1 - internal i/o
* 0 - encoded format or not present
* 1 - fmt specifier is a variable
*/
static struct {
FtnRtlEnum read[2];
FtnRtlEnum write[2];
} fmt_init[] = {{
{RTE_f90io_fmtr_init2003a, RTE_f90io_fmtr_initv2003a},
{RTE_f90io_fmtw_inita, RTE_f90io_fmtw_initva},
},
{
{RTE_f90io_fmtr_intern_inita, RTE_f90io_fmtr_intern_initva},
{RTE_f90io_fmtw_intern_inita, RTE_f90io_fmtw_intern_initva},
}};
/* Init routines for DECODE/ENCODE */
static struct {
FtnRtlEnum read[2];
FtnRtlEnum write[2];
} fmt_inite = {
{RTE_f90io_fmtr_intern_inite, RTE_f90io_fmtr_intern_initev},
{RTE_f90io_fmtw_intern_inite, RTE_f90io_fmtw_intern_initev},
};
/* Selectable prefixes for the I/O routines (craft, non-craft) passed
* to mkfunc_name();
*/
static int io_sc;
static int set_io_sc(void);
static int copy_replic_sect_to_tmp(int);
static void copy_back_to_replic_sect(int, int);
static void fix_iostat(void);
static int add_cgoto(int);
static int end_or_err(int, int, int);
static int fio_end_err(int, int);
static void chk_expr(SST *, int, int);
static void chk_var(SST *, int, int);
static void gen_spec_item_tmp(SST *, int, int);
static void chk_unitid(SST *);
static void chk_fmtid(SST *);
static void chk_iospec(void);
static void put_edit(int);
static void put_ffield(SST *);
static void kwd_errchk(int);
static int get_fmt_array(int, int);
static int ast_ioret(void);
static int mk_iofunc(FtnRtlEnum, int, int);
static int mk_hpfiofunc(FtnRtlEnum, int, int);
static LOGICAL need_descriptor_ast(int);
static void rw_array(int, int, int, FtnRtlEnum);
static void get_derived_iolptrs(SST *, int, SST *);
static void gen_derived_io(int, FtnRtlEnum, int);
static void gen_lastval(DOINFO *);
static int misc_io_checks(char *);
static void iomsg_check(void);
static void newunit_check(void);
static void put_vlist(SST *);
static FtnRtlEnum getBasicScalarRWRtn(LOGICAL, FormatType);
static FtnRtlEnum getAggrRWRtn(LOGICAL);
static FtnRtlEnum getWriteByDtypeRtn(int, FormatType);
static FtnRtlEnum getArrayRWRtn(LOGICAL, FormatType, int, LOGICAL);
static ITEM *gen_dtio_args(SST *, int, int, int);
static int gen_dtsfmt_args(int *, int *);
static int call_dtsfmt(int, int);
static int get_defined_io_call(int, int, ITEM *);
static int begin_io_call(int, int, int);
static void add_io_arg(int);
static int end_io_call(void);
static void _put(INT, int);
/*---------------------------------------------------------------------------*/
/** \brief Semantic analysis of IO statements.
\param rednum reduction number
\param top top of stack after reduction
*/
void
semantio(int rednum, SST *top)
{
int sptr, i, iofunc;
int len;
int dtype, ddtype;
int dum;
ADSC *ad;
SST *stkptr, *e1;
IOL *iolptr;
IOL *dobegin, *doend;
DOINFO *doinfo;
FtnRtlEnum rtlRtn;
int ast;
int argt;
int count;
int ast1, ast2, ast3;
int dim; /* dimension # of the index variable */
int asd; /* array subscript descriptor */
int subs[7];
int numdim;
int sptr1;
int nelems;
int last_inquire_val;
ITEM *itemp;
char *strptr;
LOGICAL needDescr;
switch (rednum) {
/* ------------------------------------------------------------------ */
/*
* <null> ::=
*/
case NULL1:
/*
* this reduction is made at the beginning of any I/O statement
* not involving the transfer of data. It is used to initialize for
* the processing of these statements.
*/
no_rw = TRUE;
goto io_shared;
/* ------------------------------------------------------------------ */
/*
* <write> ::=
*/
case WRITE1:
/*
* this reduction is made at the beginning of any I/O statement
* performing output. It is used to initialize for the processing
* of these statements.
*/
is_read = FALSE;
goto rw_init;
/* ------------------------------------------------------------------ */
/*
* <read> ::=
*/
case READ1:
/*
* this reduction is made at the beginning of any I/O statement
* performing input. It is used to initialize for the processing
* of these statements.
*/
is_read = TRUE;
rw_init:
sem.io_stmt = TRUE;
fmttyp = FT_UNFORMATTED;
intern = FALSE;
no_rw = FALSE;
print_star = FALSE;
unit_star = FALSE;
/* shared entry for all io statements except bufferin/bufferout */
io_shared:
set_io_sc();
bitv = 0;
for (i = 0; i <= PT_MAXV; i++) {
PTV(i) = 0;
PTS(i) = 0;
PTVARREF(i) = 0;
PT_TMPUSED(i, 0);
}
if (flg.smp || flg.accmp || XBIT(125, 0x1)) {
/* begin i/o critical section */
if (flg.smp || flg.accmp)
sptr = sym_mkfunc_nodesc("_mp_bcs_nest", DT_NONE);
else
sptr = mk_iofunc(RTE_f90io_begin, DT_NONE, 0);
(void)begin_io_call(A_CALL, sptr, 0);
ast = end_io_call();
STD_LINENO(io_call.std) = gbl.lineno;
/*
* if an I/O statement is labeled, ensure that the first 'statement'
* generated is labeled.
*/
if (scn.currlab && !DEFDG(scn.currlab)) {
STD_LABEL(io_call.std) = scn.currlab;
DEFDP(scn.currlab, 1);
}
}
/*
* Create a character variable which is data initialized with
* the name of the source file if character constants can't be
* passed to RTE_loc(). Certain systems (hp) may place character
* constants on the stack, in which case the run-time or generated
* code can't stash away the address of the constant.
*/
sptr = getstring(gbl.curr_file, strlen(gbl.curr_file));
if (!XBIT(49, 0x100000))
ast1 = mk_cnst(sptr);
else {
sptr1 = getcctmp_sc('t', sptr, ST_UNKNOWN, DTYPEG(sptr), io_sc);
if (STYPEG(sptr1) == ST_UNKNOWN) {
STYPEP(sptr1, ST_VAR);
DINITP(sptr1, 1);
if (SCG(sptr1) != SC_NONE)
sym_is_refd(sptr1);
dinit_put(DINIT_LOC, sptr1);
dinit_put(DINIT_STR, (INT)sptr);
dinit_put(DINIT_END, (INT)0);
}
ast1 = mk_id(sptr1);
}
sptr = mk_iofunc(RTE_f90io_src_info03a, DT_NONE, 0);
(void)begin_io_call(A_CALL, sptr, 2);
(void)add_io_arg(mk_cval((INT)gbl.lineno, DT_INT));
(void)add_io_arg(ast1);
ast = end_io_call();
STD_LINENO(io_call.std) = gbl.lineno;
/*
* if an I/O statement is labeled, ensure that the first 'statement'
* generated is labeled.
*/
if (!XBIT(125, 0x1) && !flg.smp && !flg.accmp && scn.currlab &&
!DEFDG(scn.currlab)) {
STD_LABEL(io_call.std) = scn.currlab;
DEFDP(scn.currlab, 1);
}
iolist = 0;
noparens = FALSE;
external_io = FALSE;
nondevice_io = FALSE;
open03 = FALSE;
rw03 = FALSE;
break;
/* ------------------------------------------------------------------ */
/*
* <IO stmt> ::= <null> BACKSPACE <unit info> |
*/
case IO_STMT1:
(void)misc_io_checks("BACKSPACE");
iomsg_check();
kwd_errchk(BT_BKSPACE);
if (BYTE_SWAPPED_IO)
rtlRtn = RTE_f90io_swbackspace; /* byte swap backspace */
else
rtlRtn = RTE_f90io_backspace;
goto rewind_shared;
/*
* <IO stmt> ::= <null> ENDFILE <unit info> |
*/
case IO_STMT2:
(void)misc_io_checks("ENDFILE");
iomsg_check();
kwd_errchk(BT_ENDFILE);
rtlRtn = RTE_f90io_endfile;
goto rewind_shared;
/*
* <IO stmt> ::= <null> REWIND <unit info> |
*/
case IO_STMT3:
(void)misc_io_checks("REWIND");
iomsg_check();
kwd_errchk(BT_REWIND);
rtlRtn = RTE_f90io_rewind;
rewind_shared:
sptr = mk_iofunc(rtlRtn, DT_INT, 0);
UNIT_CHECK;
fix_iostat();
(void)begin_io_call(A_FUNC, sptr, 3);
(void)add_io_arg(PTARG(PT_UNIT));
(void)add_io_arg(mk_cval(bitv, DT_INT));
(void)add_io_arg(PTARG(PT_IOSTAT));
ast = end_io_call();
ast = add_cgoto(ast);
external_io = TRUE;
nondevice_io = TRUE;
goto end_IO_STMT;
/*
* <IO stmt> ::= <null> CLOSE <iolp> <spec list> ) |
*/
case IO_STMT4:
(void)misc_io_checks("CLOSE");
iomsg_check();
UNIT_CHECK;
kwd_errchk(BT_CLOSE);
if (PTV(PT_STATUS)) {
if (PTV(PT_DISPOSE))
IOERR2(202, "STATUS and DISPOSE in CLOSE");
} else
PTV(PT_STATUS) = PTV(PT_DISPOSE);
PT_CHECK(PT_STATUS, astb.ptr0c);
sptr = mk_iofunc(RTE_f90io_closea, DT_INT, 0);
fix_iostat();
(void)begin_io_call(A_FUNC, sptr, 4);
(void)add_io_arg(PTARG(PT_UNIT));
(void)add_io_arg(mk_cval(bitv, DT_INT));
(void)add_io_arg(PTARG(PT_IOSTAT));
(void)add_io_arg(PTARG(PT_STATUS));
ast = end_io_call();
ast = add_cgoto(ast);
external_io = TRUE;
nondevice_io = TRUE;
goto end_IO_STMT;
/*
* <IO stmt> ::= <null> OPEN <iolp> <spec list> ) |
*/
case IO_STMT5:
(void)misc_io_checks("OPEN");
iomsg_check();
UNIT_CHECK;
newunit_check();
kwd_errchk(BT_OPEN);
PT_CHECK(PT_ACCESS, astb.ptr0c);
PT_CHECK(PT_ACTION, astb.ptr0c);
PT_CHECK(PT_BLANK, astb.ptr0c);
PT_CHECK(PT_DELIM, astb.ptr0c);
PT_CHECK(PT_FORM, astb.ptr0c);
fix_iostat();
PT_CHECK(PT_PAD, astb.ptr0c);
PT_CHECK(PT_POSITION, astb.ptr0c);
PT_CHECK(PT_RECL, astb.ptr0);
PT_CHECK(PT_STATUS, astb.ptr0c);
PT_CHECK(PT_FILE, astb.ptr0c);
PT_CHECK(PT_DISPOSE, astb.ptr0c);
if (PTS(PT_NEWUNIT)) {
sptr = sym_mkfunc(mkRteRtnNm(RTE_f90io_get_newunit), DT_INT);
INDEPP(sptr, 1);
TYPDP(sptr, 1);
INTERNALP(sptr, 0);
ast = mk_func_node(A_FUNC, mk_id(sptr), 0, 0);
ast = mk_assn_stmt(PTV(PT_NEWUNIT), ast, A_DTYPEG(PTV(PT_NEWUNIT)));
add_stmt_after(ast, io_call.std);
if (A_DTYPEG(PTV(PT_NEWUNIT)) != DT_INT) {
PTV(PT_UNIT) = mk_convert(PTV(PT_NEWUNIT), DT_INT);
}
}
if (PTS(PT_FILE) && PTS(PT_NAME))
IOERR2(202, "FILE and NAME in OPEN");
sptr = mk_iofunc(RTE_f90io_open2003a, DT_INT, 0);
(void)begin_io_call(A_FUNC, sptr, 14);
(void)add_io_arg(PTARG(PT_UNIT));
(void)add_io_arg(mk_cval(bitv, DT_INT));
(void)add_io_arg(PTARG(PT_ACCESS));
(void)add_io_arg(PTARG(PT_ACTION));
(void)add_io_arg(PTARG(PT_BLANK));
(void)add_io_arg(PTARG(PT_DELIM));
/* on open statement, FILE and NAME are the same. code previously
only set PT_FILE, but this created incorrect error messages */
if (PTV(PT_NAME))
(void)add_io_arg(PTARG(PT_NAME));
else
(void)add_io_arg(PTARG(PT_FILE));
(void)add_io_arg(PTARG(PT_FORM));
(void)add_io_arg(PTARG(PT_IOSTAT));
(void)add_io_arg(PTARG(PT_PAD));
(void)add_io_arg(PTARG(PT_POSITION));
(void)add_io_arg(PTARG(PT_RECL));
(void)add_io_arg(PTARG(PT_STATUS));
(void)add_io_arg(PTARG(PT_DISPOSE));
ast = end_io_call();
if (PTV(PT_CONVERT)) {
/* ast is an A_ASN of the form
* z_io = ...open(...)
*/
sptr = mk_iofunc(RTE_f90io_open_cvta, DT_INT, 0);
(void)begin_io_call(A_FUNC, sptr, 2);
(void)add_io_arg(A_DESTG(ast));
(void)add_io_arg(PTARG(PT_CONVERT));
ast = end_io_call();
}
if (PTV(PT_SHARED)) {
/* ast is an A_ASN of the form
* z_io = ...open(...)
*/
sptr = mk_iofunc(RTE_f90io_open_sharea, DT_INT, 0);
(void)begin_io_call(A_FUNC, sptr, 2);
(void)add_io_arg(A_DESTG(ast));
(void)add_io_arg(PTARG(PT_SHARED));
ast = end_io_call();
}
if (PTV(PT_ASYNCHRONOUS)) {
/* ast is an A_ASN of the form
* z_io = ...open(...)
*/
sptr = mk_iofunc(RTE_f90io_open_asynca, DT_INT, 0);
(void)begin_io_call(A_FUNC, sptr, 2);
(void)add_io_arg(A_DESTG(ast));
(void)add_io_arg(PTARG(PT_ASYNCHRONOUS));
ast = end_io_call();
}
if (open03) {
/* ast is an A_ASN of the form
* z_io = ...open(...)
*/
PT_CHECK(PT_DECIMAL, astb.ptr0c);
PT_CHECK(PT_ROUND, astb.ptr0c);
PT_CHECK(PT_SIGN, astb.ptr0c);
PT_CHECK(PT_ENCODING, astb.ptr0c);
sptr = mk_iofunc(RTE_f90io_open03a, DT_INT, 0);
(void)begin_io_call(A_FUNC, sptr, 5);
(void)add_io_arg(A_DESTG(ast));
(void)add_io_arg(PTARG(PT_DECIMAL));
(void)add_io_arg(PTARG(PT_ROUND));
(void)add_io_arg(PTARG(PT_SIGN));
(void)add_io_arg(PTARG(PT_ENCODING));
ast = end_io_call();
}
ast = add_cgoto(ast);
external_io = TRUE;
nondevice_io = TRUE;
goto end_IO_STMT;
/*
* <IO stmt> ::= <null> INQUIRE <iolp> <spec list> ) |
*/
case IO_STMT6:
(void)misc_io_checks("INQUIRE");
iomsg_check();
if (PTV(PT_UNIT)) {
if (PTV(PT_FILE))
IOERR2(201, "UNIT and FILE used in INQUIRE");
PTV(PT_FILE) = astb.ptr0c;
} else if (PTV(PT_FILE))
PTV(PT_UNIT) = astb.i0;
else
IOERR(200);
kwd_errchk(BT_INQUIRE);
last_inquire_val = PT_LAST_INQUIRE_VALf95;
for (i = PT_LAST_INQUIRE_VALf95 + 1; i <= PT_LAST_INQUIRE_VAL; i++) {
if (PTV(i)) {
last_inquire_val = PT_LAST_INQUIRE_VAL;
break;
}
}
for (i = 2; i <= last_inquire_val; i++) {
switch (i) {
case PT_NEXTREC:
case PT_NUMBER:
case PT_RECL:
case PT_SIZE:
case PT_IOSTAT:
case PT_EXIST:
case PT_NAMED:
case PT_OPENED:
case PT_ID:
case PT_PENDING:
case PT_POS:
PT_CHECK(i, astb.ptr0);
break;
default:
PT_CHECK(i, astb.ptr0c);
}
}
if (last_inquire_val < PT_LAST_INQUIRE_VAL) {
sptr = mk_iofunc(RTE_f90io_inquire2003a, DT_INT, 0);
} else {
sptr = mk_iofunc(RTE_f90io_inquire03_2a, DT_INT, 0);
}
filename_type = 0;
(void)begin_io_call(A_FUNC, sptr, last_inquire_val + 2);
(void)add_io_arg(PTARG(PT_UNIT));
(void)add_io_arg(PTARG(PT_FILE));
(void)add_io_arg(mk_cval(bitv, DT_INT));
for (i = 2; i <= last_inquire_val; i++)
(void)add_io_arg(PTARG(i));
ast = end_io_call();
ast = add_cgoto(ast);
external_io = TRUE;
nondevice_io = TRUE;
goto end_IO_STMT;
/*
* <IO stmt> ::= <write> WRITE <io spec> |
*/
case IO_STMT7:
(void)misc_io_checks("WRITE");
kwd_errchk(BT_WRITE);
external_io = !intern;
goto io_end;
/*
* <IO stmt> ::= <write> WRITE <io spec> <output list> |
*/
case IO_STMT8:
(void)misc_io_checks("WRITE");
kwd_errchk(BT_WRITE);
iolptr = (IOL *)SST_BEGG(RHS(4));
external_io = !intern;
goto io_items;
/*
* <IO stmt> ::= <write> PRINT <print spec> |
*/
case IO_STMT9:
(void)misc_io_checks("PRINT");
kwd_errchk(BT_PRINT);
external_io = !intern;
goto io_end;
/*
* <IO stmt> ::= <write> PRINT <print spec> , <output list> |
*/
case IO_STMT10:
(void)misc_io_checks("PRINT");
kwd_errchk(BT_PRINT);
iolptr = (IOL *)SST_BEGG(RHS(5));
external_io = !intern;
goto io_items;
/*
* <IO stmt> ::= <read> READ <io spec> <input list> |
*/
case IO_STMT11:
(void)misc_io_checks("READ");
kwd_errchk(BT_READ);
chk_iospec();
iolptr = (IOL *)SST_BEGG(RHS(4));
external_io = !intern;
nondevice_io = TRUE;
goto io_items;
/*
* <IO stmt> ::= <read> READ <read spec2> |
*/
case IO_STMT12:
(void)misc_io_checks("READ");
kwd_errchk(BT_READ);
external_io = !intern;
nondevice_io = TRUE;
goto io_end;
/*
* <IO stmt> ::= <read> READ <read spec3> , <input list> |
*/
case IO_STMT13:
(void)misc_io_checks("READ");
kwd_errchk(BT_READ);
iolptr = (IOL *)SST_BEGG(RHS(5));
external_io = !intern;
nondevice_io = TRUE;
goto io_items;
/*
* <IO stmt> ::= <read> ACCEPT <read spec4> |
*/
case IO_STMT14:
(void)misc_io_checks("ACCEPT");
iomsg_check();
kwd_errchk(BT_ACCEPT);
external_io = !intern;
nondevice_io = TRUE;
goto io_end;
/*
* <IO stmt> ::= <read> ACCEPT <read spec3> , <input list> |
*/
case IO_STMT15:
(void)misc_io_checks("ACCEPT");
iomsg_check();
kwd_errchk(BT_ACCEPT);
iolptr = (IOL *)SST_BEGG(RHS(5));
external_io = !intern;
nondevice_io = TRUE;
goto io_items;
/*
* <IO stmt> ::= <write> ENCODE <encode spec> <optional comma> <output
*list> |
*/
case IO_STMT16:
(void)misc_io_checks("ENCODE");
iomsg_check();
kwd_errchk(BT_ENCODE);
iolptr = (IOL *)SST_BEGG(RHS(5));
external_io = FALSE;
nondevice_io = TRUE;
goto io_items;
/*
* <IO stmt> ::= <write> ENCODE <encode spec> |
*/
case IO_STMT17:
(void)misc_io_checks("ENCODE");
iomsg_check();
kwd_errchk(BT_ENCODE);
external_io = FALSE;
nondevice_io = TRUE;
goto io_end;
/*
* <IO stmt> ::= <read> DECODE <encode spec> <optional comma> <input list>
*/
case IO_STMT18:
(void)misc_io_checks("DECODE");
iomsg_check();
kwd_errchk(BT_DECODE);
iolptr = (IOL *)SST_BEGG(RHS(5));
external_io = FALSE;
nondevice_io = TRUE;
goto io_items;
/*
* <IO stmt> ::= <read> DECODE <encode spec> |
*/
case IO_STMT19: