/***************************************
                *                                     *
                *      PL/I   FMS   Interface         *
                *                                     *
                ***************************************/


#include "plifmssw.c";
/*
 pick the version by copying plifmsxx.c to plifmssw.c, where xx is
	dr	debugging 	reentrant
	r	non-debugging	reentrant
	dnr	debugging	non-reentrant
	nr	non-debugging	non-reentrant
*/

/*
  note that the FMS interface must now initialize FCS; it does this on the
  first FMS call. since everybody should now be using RMS, this shouldn't 
  affect anyone, but if you do need to use FCS, you may need to be sure that 
  you make your first FMS call before any I/O-related activity, or else
  inhibit the FMS interface initialization by setting the VX$FMI
  word to one before the first FMS call (in C, copy the definition below
  and say fcs_inited = true; in MAC, say MOV $VEXT,R0; MOV #1,VX$FMI(R0);)
*/


/************************/
/* language definitions */
/************************/

#include <clang.c>;
#include <plistring.c>;
#include <signal.c>;

typedef int gparm; /*external global parameter (must reference with &)*/



/************************/
/* external definitions */
/************************/


/* common definitions */

#define namesize 6 /*FMS field name size*/

/* function codes (defined by FMS) */
extern gparm fc$all,fc$any,fc$cls,fc$csh,fc$dat,fc$get,fc$gsc,fc$lst,fc$opn;
extern gparm fc$pal,fc$psc,fc$put,fc$ral,fc$rtn,fc$sho,fc$spf,fc$spn,fc$trm;

/* error codes defined by FMS */
extern gparm fs$suc, fe$imp;

/* high level error codes (defined by FMS, though not documented in manual) */
extern gparm fe$arg,fe$ini,fe$str;


#ifdef reentrant

/* reentrant version - dirty variables are based off of pointers*/

extern charpointer $vext; /*pointer to task's vector of impure pointers*/
extern gparm vx$fms; /*offset in vector to our impure pointer*/
extern gparm vx$fme; /*offset in vector to our error/status block*/
extern gparm vx$fmi; /*offset in vector to FCS initialization flag*/
extern gparm vx$nrg; /*offset in vector to wrong # args message pointer*/
extern gparm vx$stl; /*offset in vector to string too long message pointer*/

#define defimp register charpointer imp
#define setimp imp=vximp;
#define vximp *(int *)($vext+(int)&vx$fms)
#define callfms fdnam=&fdnamblk; callfmsn;
#define callfmsn $cfdv();

#define fdargblk *(int *)(imp+(int)&fd$$ar)
#define fdreqblk *(int *)(imp+(int)&fd$$rq)
#define fdnamblk *(int *)(imp+(int)&fd$$nm)
#define fdcurnam *(int *)(imp+(int)&fd$$cn)
#define fdcuridx *(int *)(imp+(int)&fd$$cx)
#define fdfmsimp *(int *)(imp+(int)&fd$$im)
/* offsets defined in plifmsd */
extern gparm fd$$ar,fd$$rq,fd$$nm,fd$$st,fd$$cn,fd$$cx,fd$$im,fd$$sz;

/* status block must be allocated independent of impure area so we
   can report an error when there is no impure area: */
#define fdstsblk *(int *)($vext+(int)&vx$fme)
#define fdstat1 *(int *)($vext+(int)&vx$fme)
#define fdstat2 *(int *)($vext+(int)&vx$fme+2)

#define fdfnc *(int *)(imp+(int)&fd$$ar+(int)&f$fnc)
#define fdreq *(int *)(imp+(int)&fd$$ar+(int)&f$req)
#define fdnam *(int *)(imp+(int)&fd$$ar+(int)&f$nam)
#define fdnum *(int *)(imp+(int)&fd$$ar+(int)&f$num)
#define fdtrm *(int *)(imp+(int)&fd$$ar+(int)&f$trm)
#define fdval *(int *)(imp+(int)&fd$$ar+(int)&f$val)
#define fdlen *(int *)(imp+(int)&fd$$ar+(int)&f$len)
#define fdsts *(int *)(imp+(int)&fd$$rq+(int)&f$sts)
#define fdchn *(int *)(imp+(int)&fd$$rq+(int)&f$chn)
#define fdimp *(int *)(imp+(int)&fd$$rq+(int)&f$imp)
/* offsets defined by FMS */
extern gparm f$fnc,f$req,f$nam,f$num,f$trm,f$val,f$len;
extern gparm f$sts,f$chn,f$imp;

/* FCS initialization flag in impure vector */
#define fcs_inited *(int *)($vext+(int)&vx$fmi)

/* access to messages in plifmse */
#define wrong_number_of_args *(char **)($vext+(int)&vx$nrg)
#define string_longer_than_var *(char **)($vext+(int)&vx$stl)


#else

/* non-reentrant version - dirty variables are in static data module (plifmsd) */

#define defimp
#define setimp
#define callfms $cfdv();
#define callfmsn $cfdvn();

#define fdreqblk fd$$rq
#define fdnamblk fd$$nm
#define fdstsblk fd$$st
#define fdcurnam fd$$cn
#define fdcuridx fd$$cx
#define fdimpini fd$$in
/* data in plifmsd static module*/
extern int fd$$rq,fd$$nm,fd$$cn,fd$$cx,fd$$in,fd$$fi;
extern struct {int status1; int status2;} fd$$st;
#define fdstat1 fd$$st.status1
#define fdstat2 fd$$st.status2

#define fdfnc *fd$fnc
#define fdreq *fd$req
#define fdnam *fd$nam
#define fdnum *fd$num
#define fdtrm *fd$trm
#define fdval *fd$val
#define fdlen *fd$len
#define fdsts *fd$sts
#define fdchn *fd$chn
#define fdimp *fd$imp
/* pointers defined in plifmsd */
extern int *fd$fnc,*fd$req,*fd$nam,*fd$num,*fd$trm,*fd$val,*fd$len;
extern int *fd$sts,*fd$chn,*fd$imp;

/* FCS initialization flag */
#define fcs_inited fd$$fi

/* access to messages in plifmse */
#define wrong_number_of_args &fmsnrg
#define string_longer_than_var &fmsstl
extern char fmsnrg, fmsstl;

#endif


/*********************/
/* internal routines */
/*********************/

#ifdef dbug

/*
  routine to emulate FMS debug mode message handling
*/
procedure f$$dbm(msgstr)
cstring msgstr;
{
extern FGET(); /*foward reference*/
register int istat1,istat2;
  istat1=fdstat1; /*save error state (FGET will set)*/
  istat2=fdstat2;
  f$$dbp(msgstr); /*FPUTL*/
  callpli(&FGET,0); /*wait for operator to acknowledge. note: this only works 
  	if a form is being displayed, or we get illegal call error.
  	to generalize, call a PL/I routine doing a PL/I GET for a CHAR(1), 
  	or do a QIO reading 1 char*/
  fdstat1=istat1; /*restore error state*/
  fdstat2=istat2;
}


/*
  routine to show debug mode message via FPUTL
*/
procedure f$$dbp(msgstr)
cstring msgstr;
{
plisd msgd; extern FPUTL(); /*forward reference*/
register int istat1,istat2;
  istat1=fdstat1; /*save error state (FPUTL will set)*/
  istat2=fdstat2;
  plisdi(&msgd,fixed,msgstr,strlen(msgstr)); /*FPUTL doesn't modify arg*/
  callpli(&FPUTL,1,&msgd);
  fdstat1=istat1; /*restore error state*/
  fdstat2=istat2;
}


/*
  routine to show debug mode message when there's no impure area
*/
procedure f$$dbe(msgstr)
cstring msgstr;
{
  msg(msgstr);/*send direct to console - without impure, can't FPUTL*/
  signal(ERROR);
}

#endif


/*
  check for valid # args and initialized impure
  returned value is  <0 if error,
                     =0 (false) if ok, dont have all args,
                     >0 (true) if ok, have all args
*/
#define chkfail <0 /*symbolic way to test for error*/
#define chkok >=0
int function f$$chk(narg,lo,hi)
int narg,lo,hi;
{
extern fcsinit();
defimp; setimp;
  fdstat1 = &fs$suc; /*in case this one doesn't call FMS*/
  fdstat2 = 0;
  iff not fcs_inited
    then begin
      fcsinit();
      fcs_inited = true;
     end;
#ifdef reentrant
  iff imp==0
#else
  iff not fdimpini
#endif
    then begin
#ifdef dbug
	  f$$dbe("\033[1mIMPURE AREA NOT INITIALIZED\033[m");
		/* \033[1m = VT100 bold on, \033[m = off */
#endif
	  fdstat1 = &fe$ini;
	  return(-1);
	 end;
  iff narg<lo or narg>hi
    then begin
#ifdef dbug
	  f$$dbp(wrong_number_of_args); /*message is in plifmse*/
	  signal(NUMARGS); /*let user see routine name (in PL/I message)*/
#endif
	  fdstat1 = &fe$arg;
	  return(-1);
	 end;
  return(narg==hi);
}


/*
  routine to return a string value to a PL/I string
*/
procedure f$$onm(sdp,sptr,slen)
plistring sdp; char *sptr; int slen;
{
defimp; setimp;
  iff plicpy(sdp,sptr,slen) /*i.e., if string overflow*/
    then begin;
#ifdef dbug
	  f$$dbm(string_longer_than_var); /*message is in plifmse*/
#endif
	  iff fdstat1>=0 then fdstat1=&fe$str;
	  /*dont set error if have one (presumably more serious) from FMS*/
	 end;
}


/*
  routine to move a string from PL/I argument to fixed dirty name holder
*/
procedure f$$inm(sdp)
plistring sdp;
{
plisd fdnd; defimp;
  setimp;
  plisdi(&fdnd,fixed,&fdnamblk,namesize);
  plicpy(&fdnd,plistr(sdp),plilen(sdp)); /*ignore string overflow*/
}


/*
  routine to set up an input fval argument
*/
procedure f$$ivl(sdp)
plistring sdp;
{
defimp; setimp;
  fdval = plistr(sdp); fdlen = plilen(sdp);
}


/*
  routine to return an output fval string value to a PL/I string
*/
procedure f$$ovl(sdp)
plistring sdp;
{
defimp; setimp;
  f$$onm(sdp,fdval,fdlen);
}


/**************************/
/* FMS interface routines */
/**************************/

procedure FCLRSH(narg, fname, line)
int narg, *line; plistring fname;
{
register boolean hvline; defimp;
  plient("FCLRSH"); setimp;
  iff (hvline=f$$chk(narg,1,2)) chkok
    then begin
      fdnum = ifx hvline thenx *line elsex 0;
      f$$inm(fname);
      fdfnc=&fc$csh;
      callfms;
     end
}

procedure FGCF(narg, fid, fidx)
int narg, *fidx; plistring fid;
{
register boolean hvfidx; defimp;
  plient("FGCF"); setimp;
  iff (hvfidx=f$$chk(narg,1,2)) chkok
    then begin
      iff hvfidx then *fidx = fdcuridx;
      f$$onm(fid,fdcurnam,namesize);
     end
}

procedure FGET(narg, fval, term, fid, fidx)
int narg, *term, *fidx; plistring fval, fid;
{
register boolean hvfidx; defimp;
  plient("FGET"); setimp;
#ifdef dbug /*in debug version chk gives error message if #args not in range*/
  iff narg!=0 then begin
#endif
  iff (hvfidx=f$$chk(narg,3,4)) chkok
    then begin
      iff hvfidx then fdnum = *fidx;
      f$$inm(fid);
      fdfnc=&fc$get;
      callfms;
      *term = fdtrm;
      f$$ovl(fval);
      fdcurnam = fdnam; /*save current field name for fgcf*/
      fdcuridx = fdnum; /*also index*/
     end
#ifdef dbug
   end
#endif
   else
  iff f$$chk(narg,0,0) chkok
    then begin
      fdnam=0; fdfnc=&fc$get;
      callfmsn;
     end
}

procedure FGETAF(narg, fval, term, fid, fidx)
int narg, *term, *fidx; plistring fval, fid;
{
register boolean hvfidx; defimp;
  plient("FGETAF"); setimp;
  iff (hvfidx=f$$chk(narg,3,4)) chkok
    then begin
      fdfnc=&fc$any;
      callfms;
      *term = fdtrm;
      f$$ovl(fval);
      f$$onm(fid,fdnam,namesize);
      fdcurnam = fdnam; /*save current field name for fgcf*/
      fdcuridx = fdnum; /*also index*/
      iff hvfidx then *fidx = fdnum;
     end
}

procedure FGETAL(narg, fval, term)
int narg, *term; plistring fval;
{
register boolean hvterm; defimp;
  plient("FGETAL"); setimp;
  iff (hvterm=f$$chk(narg,0,2)) chkok
    then begin
      fdfnc=&fc$all;
      callfms;
      iff hvterm then *term = fdtrm;
      iff narg>0 then f$$ovl(fval);
     end
}

procedure FIDATA(narg, fidx, fval)
int narg, *fidx; plistring fval;
{
defimp;
  plient("FIDATA"); setimp;
  iff f$$chk(narg,2,2) chkok
    then begin
      fdnum = *fidx;
      fdfnc=&fc$dat; fdnam=0; callfmsn;
      f$$ovl(fval);
     end
}

procedure FINIT(narg, impure_area, size, status)
int narg, *size, *status; plistring impure_area; /*impure passed as string*/
{
register pointer fmsimp; register boolean hvimpure, hvstatus; defimp; 
/*in reentrant version, hvimpure is actually pointer...*/
#ifdef reentrant
pointer impp;
#endif
  plient("FINIT");
#ifdef reentrant
#define impini *impp /*impure initialized flag = impure pointer*/
		     /*(assume 0 means false, nonzero means true)*/
  impp = &vximp;
#else
#define impini fdimpini /*impure initialized flag is static (true/false)*/
#endif
  hvimpure = impini; /*remember whether we have an impure*/
  iff not hvimpure then impini = true; /*flag as initialized so f$$chk */
					/* doesn't give error*/
  iff (hvstatus=f$$chk(narg,2,3)) chkfail
    then impini = hvimpure; /*restore impure state*/
    else begin
      iff *size<240 /*240 is what the Fortran interface apparently tests for*/
	then begin
	  impini = hvimpure; /*restore impure state*/
#ifdef dbug
	  f$$dbe("\033[1mIMPURE AREA TOO SMALL\033[m");
		/* \033[1m = VT100 bold on, \033[m = off */
#endif
	  fdstat1 = &fe$imp;
	 end
	else begin
#ifdef reentrant
	  *impp = imp = plistr(impure_area); /*set vext pointer*/
  	  fdimp = fmsimp = &fdfmsimp; /*set pointer in argument block*/
	  *fmsimp = *size-(int)&fd$$sz; /*first word must contain size*/
#else
  	  fdimp = fmsimp = plistr(impure_area); /*set ptr in argument block*/
	  *fmsimp = *size; /*first word must contain size*/
#endif
	  fdreq = &fdreqblk; /*set up constant argument block pointers*/
	  fdsts = &fdstsblk;
	 end;
      iff hvstatus then *status = fdstat1;
     end
}

procedure FINLN(narg, fid, fval, term)
int narg, *term; plistring fid, fval;
{
register boolean hvterm; defimp;
  plient("FINLN"); setimp;
  iff (hvterm=f$$chk(narg,2,3)) chkok
    then begin
      f$$inm(fid);
      fdfnc=&fc$gsc;
      callfms;
      f$$ovl(fval);
      iff hvterm then *term = fdtrm;
     end
}

procedure FLCHAN(narg, chan)
int narg, *chan;
{
defimp;
  plient("FLCHAN"); setimp;
  iff f$$chk(narg,1,1) chkok then fdchn = *chan;
}

procedure FLCLOS(narg)
int narg;
{
defimp;
  plient("FLCLOS"); setimp;
  iff f$$chk(narg,0,0) chkok
    then begin
      fdfnc=&fc$cls;
      callfms; 
     end;
}

procedure FLEN(narg, fln, fid, fidx)
int narg, *fln, *fidx; plistring fid;
{
register boolean hvfidx; defimp;
  plient("FLEN"); setimp;
  iff (hvfidx=f$$chk(narg,2,3)) chkok
    then begin
      iff hvfidx then fdnum = *fidx;
      f$$inm(fid);
      fdfnc=&fc$rtn;
      callfms;
      *fln = fdlen;
     end
}

procedure FLOPEN(narg, flnm)
int narg; plistring flnm;
{
/*note: since FMS requires null-terminated name, we must make copy in a temp*/
char filenm[80]; defimp;
  plient("FLOPEN"); setimp;
  iff f$$chk(narg,1,1) chkok
    then begin
      plzcpy(fdnam=&filenm,sizeof(filenm),flnm); /*assume filenm big enough*/
      fdfnc=&fc$opn; callfmsn;
     end
}

procedure FNDATA(narg, fid, fval)
int narg; plistring fid, fval;
{
defimp;
  plient("FNDATA"); setimp;
  iff f$$chk(narg,2,2) chkok
    then begin
      f$$inm(fid);
      fdfnc=&fc$dat;
      callfms;
      f$$ovl(fval);
     end
}

procedure FOUTLN(narg, fid, fval)
int narg; plistring fid, fval;
{
register boolean hvfval; defimp;
  plient("FOUTLN"); setimp;
  iff (hvfval=f$$chk(narg,1,2)) chkok
    then begin
      iff hvfval
        then f$$ivl(fval);
        else fdlen = 0;
      f$$inm(fid);
      fdfnc=&fc$psc;
      callfms;
     end;
}

procedure FPFT(narg, term, fid, fval)
int narg, *term; plistring fid, fval;
{
register boolean hvfval; defimp;
  plient("FPFT"); setimp;
  iff (hvfval=f$$chk(narg,0,3)) chkok
    then begin
      iff hvfval then f$$ivl(fval); else fdlen=0;
      iff narg>1 then f$$inm(fid); /*if have fid*/
      iff narg>0 then fdtrm = *term;/*else fdtrm is unchanged from last call*/
      fdfnc=&fc$trm;
      callfms;
      fdcurnam = fdnam; /*save pointer to current name for fgcf*/
      fdcuridx = fdnum; /*save current index for fgcf*/
     end;
}

procedure FPUT(narg, fval, fid, fidx)
int narg, *fidx; plistring fval, fid;
{
register boolean hvfidx; defimp;
  plient("FPUT"); setimp;
  iff (hvfidx=f$$chk(narg,2,3)) chkok
    then begin
      iff hvfidx then fdnum = *fidx;
      f$$inm(fid);
      f$$ivl(fval);
      fdfnc=&fc$put;
      callfms;
     end;
}

procedure FPUTAL(narg, fval)
int narg; plistring fval;
{
register boolean hvfval; defimp;
  plient("FPUTAL"); setimp;
  iff (hvfval=f$$chk(narg,0,1)) chkok
    then begin
      iff hvfval
        then f$$ivl(fval);
        else fdlen = 0;
      fdfnc=&fc$pal;
      callfms;
     end;
}

procedure FPUTL(narg, fval)
int narg; plistring fval;
{
register boolean hvfval; defimp;
  plient("FPUTL"); setimp;
  iff (hvfval=f$$chk(narg,0,1)) chkok
    then begin
      iff hvfval
        then f$$ivl(fval);
        else fdlen = 0;
      fdfnc=&fc$lst;
      callfms;
     end;
}

procedure FRETAL(narg, fval)
int narg; plistring fval;
{
defimp;
  plient("FRETAL"); setimp;
  iff f$$chk(narg,1,1) chkok
    then begin
      fdfnc=&fc$ral;
      callfms;
      f$$ovl(fval);
     end;
}

procedure FRETN(narg, fval, fid, fidx)
int narg, *fidx; plistring fval, fid;
{
register boolean hvfidx; defimp;
  plient("FRETN"); setimp;
  iff (hvfidx=f$$chk(narg,2,3)) chkok
    then begin
      iff hvfidx then fdnum = *fidx;
      f$$inm(fid);
      fdfnc=&fc$rtn;
      callfms;
      f$$ovl(fval);
     end;
}

procedure FSHOW(narg, fname, line)
int narg, *line; plistring fname;
{
register boolean hvline; defimp;
  plient("FSHOW"); setimp;
  iff (hvline=f$$chk(narg,1,2)) chkok
    then begin
      fdnum = ifx hvline thenx *line elsex 0;
      f$$inm(fname);
      fdfnc=&fc$sho;
      callfms;
     end;
}

procedure FSPOFF(narg)
int narg;
{
defimp;
  plient("FSPOFF"); setimp;
  iff f$$chk(narg,0,0) chkok
    then begin
      fdfnc=&fc$spf;
      callfms;
     end;
}

procedure FSPON(narg)
int narg;
{
defimp;
  plient("FSPON"); setimp;
  iff f$$chk(narg,0,0) chkok
    then begin
      fdfnc=&fc$spn;
      callfms;
     end;
}

procedure FSTAT(narg, stat1, stat2)
int narg, *stat1, *stat2;
{
register int istat1, istat2; register boolean hvstat2;
  plient("FSTAT");
  istat1=fdstat1; /*save - f$$chk sets them*/
  istat2=fdstat2;
  iff (hvstat2=f$$chk(narg,1,2)) chkfail
    then istat1=fdstat1;
  fdstat1=istat1; /*restore so can call again*/
  fdstat2=istat2;
  *stat1 = istat1; /*better not call with 0 args...*/
  iff hvstat2 then *stat2 = ifx istat2<128 thenx istat2
					   elsex istat2-256; /*sign extend*/
	  /*patch up after fcs/fms, which store the error code as a byte 
		in a word (e.g., -1 is stored as 255)*/
}

/*
  special MMR routine to allow setting the status
*/
procedure FSETST(narg, stat1, stat2)
int narg, *stat1, *stat2;
{
  plient("FSETST");
  iff f$$chk(narg,2,2) chkok
    then begin
      fdstat1 = *stat1;
      fdstat2 = *stat2;
     end;
}