sources/pass1/memfil.c

   1      /* Loglan82 Compiler&Interpreter
   2      Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3      Copyright (C)  1993, 1994 LITA, Pau
   4
   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.
   9
  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.
  14
  15
  16 =======================================================================
  17 */
  18
  19 /*****************************************************************
  20  *                                                               *
  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               *
  24  *                                                               *
  25  *               (C) Andrzej I. Litwiniuk (AIL)                  *
  26  *                   Institute of Informatics                    *
  27  *                   University of Warsaw                        *
  28  *                                                               *
  29  *                    Version 1988.10.17                         *
  30  *                                                               *
  31  *****************************************************************/
  32
  33 #if WSIZE==4
  34         typedef long word;
  35 #elif WSIZE==2
  36         typedef short word;
  37 #else
  38  Define WSIZE to 2 or 4 !
  39 #endif
  40
  41 #include <stdio.h>
  42 #include <string.h>
  43 #include <malloc.h>
  44 #include "f2c.h"
  45
  46 FILE *file_arr[30]={NULL};
  47 static char *file_names[30]={NULL};
  48
  49 void ffopen_(stream,name,one) /* open file for binary reading */
  50 word *stream;
  51 char *name;
  52 long one;
  53 {
  54    FILE *f=fopen(name,"rb"); /* read binary */
  55    if (f == NULL) { printf("file %s cannot be opened\n",name); exit(1); }
  56    file_arr[*stream]=f;
  57 }
  58
  59 void ffcreat_(stream,name,one) /* open a new file for binary writing */
  60 word *stream;
  61 char *name;
  62 long one;
  63 {
  64    FILE *f=fopen(name,"wb"); /* write binary */
  65    if (f == NULL) { printf("file %s cannot be opened\n",name); exit(1); }
  66    file_arr[*stream]=f;
  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 );
  70 }
  71
  72 static int tmp_files[10];
  73 static int tmp_cnt=0;
  74 static void clean_tmp()
  75 {
  76    int i;
  77    for( i=0; i<tmp_cnt; i++ ){
  78       fclose( file_arr[ tmp_files[i] ] );
  79       unlink( file_names[ tmp_files[i] ] );
  80    }
  81 }
  82
  83 void ffcrtmp_(stream) /* open a temporary file for binary writing */
  84 word *stream;
  85 {
  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); }
  91    file_arr[*stream]=f;
  92    file_names[*stream]=strdup(tmp);
  93    tmp_files[ tmp_cnt++ ] = *stream;
  94 /*   unlink(tmp);*/
  95 /* A.S. 18-03-94  atexit( clean_tmp );  */
  96 }
  97
  98 void ffclose_(stream) word *stream; {
  99    if(file_arr[*stream]!=NULL) fclose(file_arr[*stream]);
 100 }
 101 void ffunlink_(stream) word *stream; {
 102    if( file_names[*stream] != NULL )
 103       unlink( file_names[*stream] );
 104 }
 105
 106 void ffseek_(stream,offset) word *stream,*offset; {
 107    fseek(file_arr[*stream],(long)(*offset),0);
 108 }
 109
 110 void ffread_(stream,mloc,bytes) word *stream,*mloc,*bytes; {
 111    *bytes=fread((char *)mloc,1,(int)(*bytes),file_arr[*stream]);
 112 }
 113
 114 void fferror_(code) word *code;{
 115    fprintf(stderr," I/O Error number %d\n",(int)(*code));
 116    abort();
 117 }
 118
 119 void ffwrite_ints__(stream,mloc,ints) word *stream,*mloc,*ints;{
 120    word l=31;
 121    if( fwrite((char *)mloc,sizeof(word),(int)(*ints),file_arr[*stream]) != (int)(*ints) )
 122       fferror_(&l);
 123 }
 124
 125 void ffwrite_(stream,mloc,bytes) word *stream,*mloc,*bytes; {
 126    word l=30;
 127    if( fwrite((char *)mloc,1,(int)(*bytes),file_arr[*stream]) != (int)(*bytes) )
 128       fferror_(&l);
 129 }
 130
 131 void ffwrite_char__(stream,mloc,chars)
 132    word *stream;
 133    char *mloc;
 134    long chars;
 135 {
 136    word l=29;
 137    if( fwrite(mloc,1,(int)chars,file_arr[*stream]) != (int)chars)
 138       fferror_(&l);
 139 }
 140
 141 void ffwrint_(unit,item) word *unit,*item;{
 142    word l=28;
 143    if(file_arr[*unit]==NULL) fferror_(&l);
 144    fprintf(file_arr[*unit],"%6.6d",(int)(*item));
 145 }
 146
 147 void ffwrhex_(unit,item) word *unit,*item;{
 148    word l=27;
 149    if(file_arr[*unit]==NULL) fferror_(&l);
 150    fprintf(file_arr[*unit],"%04.4x",(int)(*item));
 151 }
 152
 153 void nextch_(unit,ch) word *unit,*ch;{
 154    FILE *f=file_arr[*unit];
 155    *ch=(word)getc(f);
 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 = ' ';
 161 }
 162
 163 void frdchr_(unit,c,count) word *unit; char *c; long count;{
 164    FILE *f=file_arr[*unit];
 165    int i;
 166   skip_nl:
 167    i=getc(f);
 168    if(i== EOF) i = 2;
 169    if(i==  26) i = 2;
 170    if(i=='\r') i = 1;
 171    if(i=='\n') goto skip_nl;
 172    *c=(char)i;
 173 }
 174
 175 static int reclen=512;
 176
 177 void openf_(itab,ident) word *itab,*ident;{
 178    itab[0]=0;
 179    itab[1]=*ident;
 180    ffcrtmp_(ident);
 181    reclen=256*sizeof(word);
 182 }
 183
 184 void get_(itab,item) word *itab,*item;{
 185    word recnr,offset,len;
 186    itab[0]++;
 187    recnr=itab[0]-1;
 188    offset=recnr*reclen;
 189    ffseek_(itab+1,&offset);
 190    len = reclen;
 191    ffread_(itab+1,item,&len);
 192    if(len!=reclen){
 193       len=30;
 194       fferror_(&len);
 195    }
 196 }
 197
 198 void seek_(itab,number) word *itab,*number;{
 199    itab[0]=*number;
 200 }
 201
 202 void closf_(itab) int *itab;{
 203    ffclose_(itab+1);
 204 }
 205
 206 void put_(itab,item) word *itab,*item;{
 207    word recnr,offset;
 208    itab[0]++;
 209    recnr=itab[0]-1;
 210    offset=recnr*reclen;
 211    ffseek_(itab+1,&offset);
 212    ffwrite_(itab+1,item,&reclen);
 213 }
 214
 215