1 /* Loglan82 Compiler&Interpreter
2 Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
3 Copyright (C) 1993, 1994 LITA, Pau
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
16 =======================================================================
19 /*****************************************************************
21 * Package of the I/O routines to be called from FORTRAN, VAX *
22 * according to the Standard of VAX-11 Procedure Calls. *
23 * For the LOGLAN-82 VAX/VMS Compiler *
25 * (C) Andrzej I. Litwiniuk (AIL) *
26 * Institute of Informatics *
27 * University of Warsaw *
29 * Version 1988.10.17 *
31 *****************************************************************/
38 Define WSIZE to 2 or 4 !
46 FILE *file_arr[30]={NULL};
47 static char *file_names[30]={NULL};
49 void ffopen_(stream,name,one) /* open file for binary reading */
54 FILE *f=fopen(name,"rb"); /* read binary */
55 if (f == NULL) { printf("file %s cannot be opened\n",name); exit(1); }
59 void ffcreat_(stream,name,one) /* open a new file for binary writing */
64 FILE *f=fopen(name,"wb"); /* write binary */
65 if (f == NULL) { printf("file %s cannot be opened\n",name); exit(1); }
67 if( file_names[*stream] != NULL ) free( file_names[*stream] );
68 file_names[*stream]=(char *)malloc( strlen(name)+1 );
69 strcpy( file_names[*stream], name );
72 static int tmp_files[10];
74 static void clean_tmp()
77 for( i=0; i<tmp_cnt; i++ ){
78 fclose( file_arr[ tmp_files[i] ] );
79 unlink( file_names[ tmp_files[i] ] );
83 void ffcrtmp_(stream) /* open a temporary file for binary writing */
86 extern char *tempnam();
87 char *tmp=tempnam(NULL,"logl");
88 FILE *f=fopen(tmp,"w+b");
89 /* FILE *f=tmpfile(); /* temporary file opened for update */
90 if (f == NULL) { perror("temporary file cannot be opened"); exit(1); }
92 file_names[*stream]=strdup(tmp);
93 tmp_files[ tmp_cnt++ ] = *stream;
95 /* A.S. 18-03-94 atexit( clean_tmp ); */
98 void ffclose_(stream) word *stream; {
99 if(file_arr[*stream]!=NULL) fclose(file_arr[*stream]);
101 void ffunlink_(stream) word *stream; {
102 if( file_names[*stream] != NULL )
103 unlink( file_names[*stream] );
106 void ffseek_(stream,offset) word *stream,*offset; {
107 fseek(file_arr[*stream],(long)(*offset),0);
110 void ffread_(stream,mloc,bytes) word *stream,*mloc,*bytes; {
111 *bytes=fread((char *)mloc,1,(int)(*bytes),file_arr[*stream]);
114 void fferror_(code) word *code;{
115 fprintf(stderr," I/O Error number %d\n",(int)(*code));
119 void ffwrite_ints__(stream,mloc,ints) word *stream,*mloc,*ints;{
121 if( fwrite((char *)mloc,sizeof(word),(int)(*ints),file_arr[*stream]) != (int)(*ints) )
125 void ffwrite_(stream,mloc,bytes) word *stream,*mloc,*bytes; {
127 if( fwrite((char *)mloc,1,(int)(*bytes),file_arr[*stream]) != (int)(*bytes) )
131 void ffwrite_char__(stream,mloc,chars)
137 if( fwrite(mloc,1,(int)chars,file_arr[*stream]) != (int)chars)
141 void ffwrint_(unit,item) word *unit,*item;{
143 if(file_arr[*unit]==NULL) fferror_(&l);
144 fprintf(file_arr[*unit],"%6.6d",(int)(*item));
147 void ffwrhex_(unit,item) word *unit,*item;{
149 if(file_arr[*unit]==NULL) fferror_(&l);
150 fprintf(file_arr[*unit],"%04.4x",(int)(*item));
153 void nextch_(unit,ch) word *unit,*ch;{
154 FILE *f=file_arr[*unit];
156 if(*ch == EOF ) *ch = 2;
157 if(*ch == 26 ) *ch = 2;
158 if(*ch == '\n') *ch = 1;
159 /* if(*ch == '\r') *ch = 1; */
160 if(*ch == '\r') *ch = ' ';
163 void frdchr_(unit,c,count) word *unit; char *c; long count;{
164 FILE *f=file_arr[*unit];
171 if(i=='\n') goto skip_nl;
175 static int reclen=512;
177 void openf_(itab,ident) word *itab,*ident;{
181 reclen=256*sizeof(word);
184 void get_(itab,item) word *itab,*item;{
185 word recnr,offset,len;
189 ffseek_(itab+1,&offset);
191 ffread_(itab+1,item,&len);
198 void seek_(itab,number) word *itab,*number;{
202 void closf_(itab) int *itab;{
206 void put_(itab,item) word *itab,*item;{
211 ffseek_(itab+1,&offset);
212 ffwrite_(itab+1,item,&reclen);