/***************************************
                *                                     *
                *      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
*/

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

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

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


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

#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*/

#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 PLDFMS */
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;

#else

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

#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 PLDFMS static module*/
extern int fd$$rq,fd$$nm,fd$$cn,fd$$cx,fd$$in;
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 PLDFMS */
extern int *fd$fnc,*fd$req,*fd$nam,*fd$num,*fd$trm,*fd$val,*fd$len;
extern int *fd$sts,*fd$chn,*fd$imp;

#endif


/* 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;


/*********************/
/* 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*/
  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;
{
defimp; setimp;
  fdstat1 = &fs$suc; /*in case this one doesn't call FMS*/
  fdstat2 = 0;
#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 ARGUMENTS IN CALL");
	  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("WARNING: RETURNED STRING LONGER THAN DECLARED VARIABLE");
#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;
}