/*********************************************************************
 *
 *   *** HAPPy Pascal Compiler ***
 *      ユーザ定義の手続き､関数の呼出処理
 *
 *    void calluser(Set fsys, ctp *fcp) ;
 *
 *             Copyright (c) H.Asano 1992,1994.
 *
 *********************************************************************/

#define EXTERN extern
#include "pascomp.h"
#include "pcpcd.h"

extern void expression(Set) ;
extern void selector(Set,ctp*) ;
extern ctp  *searchid(Set)  ;
extern Set  *mkset(Set*,int,...) ;
extern Set  *orset(Set*,Set*);
extern void pcerr(int,char*) ;
extern void insymbol(void)   ;
extern boolean compatible(stp*,stp*) ;
extern boolean assigncompati(stp*,stp*) ;
extern int align(stp*,int)   ;
extern void gen0(enum pcdmnc) ;
extern void genp(enum pcdmnc,int) ;
extern void gen2t(enum pcdmnc, stp*,int,int);
extern void gencupejp(enum pcdmnc,int,int) ;
extern void genjump(enum pcdmnc,int) ;
extern void load(void)        ;
extern void loadaddress(void) ;
extern void checkbounds(stp*,int) ;
extern void skip(Set) ;

static int  pfparm(ctp *) ;
static int actualparm(Set,ctp*) ;
static boolean congruity(ctp*,ctp*) ;

/**********************************************/
/* calluser() : ユーザ定義の手続き･関数の呼出 */
/**********************************************/
void calluser(Set fsys,ctp *fcp)
{
  ctp *nxt ;
  enum idkind lkind ;
  int locpar = 0;                       /* スタックにのせる引数のサイズ*/
  boolean err126 = false ;

     lkind = fcp->n.pf.sd.d.pfkind ;    /* actual / formal            */

     if(lkind == actual) {              /* 実手続き､実関数の呼出の時  */
      genp(iMST,level-fcp->n.pf.sd.d.pflev) ; /* mst 命令 を 生成     */
      nxt = fcp->next ;
     }
     else {                             /* 仮手続き､仮関数の呼出の時  */
      gen2t(iLOD,nilptr,level-fcp->n.pf.sd.d.pflev,
                fcp->n.pf.sd.d.af.f.levadr) ; /* loda  mark           */
      gen0(iMSI) ;                            /*  msi                 */
      nxt = fcp->n.pf.sd.d.af.f.prm ;
     }

     if(sy ==lparent) {
      do {
       insymbol() ;
       if(!nxt && !err126) {
        pcerr(126,"") ;                 /* 実引数と仮引数の数が違う   */
        err126 = true ;
       }
       if(nxt &&
        ((nxt->klass==proc) || (nxt->klass==func)))
        locpar += pfparm(nxt) ;         /* 関数引数､手続き引数        */
       else                             /* 値引数､変数引数            */
        locpar += actualparm(fsys,nxt) ;
       locpar = align(parmptr,locpar) ;

       if(nxt) nxt = nxt->next ;        /* 次の引数                   */

      } while(sy==comma) ;

      if(sy == rparent) insymbol() ;
      else pcerr(4,"") ;                /* ) がない                   */
     }

     if(nxt && !err126) pcerr(126,"") ; /* 実引数と仮引数の数が違う   */


     if(lkind == actual)                /* 実手続き､実関数の呼出の時  */
      gencupejp(iCUP,locpar,fcp->n.pf.sd.d.af.a.pfname);/* cup命令生成*/
     else {                             /* 仮手続き､仮関数の呼出の時  */
      gen2t(iLOD,nilptr,level-fcp->n.pf.sd.d.pflev,
                         fcp->n.pf.sd.d.af.f.adradr) ; /*loda 実行adr */
      genp(iCUI,locpar) ;               /* cui命令生成                */
     }

     gattr.typtr = fcp->idtype ;        /* 手続き･関数の型            */
}

/********************************************/
/* actualparm() : 値､変数パラメータ処理     */
/********************************************/
static int actualparm(Set fsys,ctp *fnxt)
{
  stp *lsp ;
  ctp *lcp ;
  int locpar = 0 ;
  Set ws,ws2 ;

     mkset(&ws,comma,rparent,-1) ;
     mkset(&ws2,vars,field,-1)   ;
     if(fnxt) {                         /* 引数がある                 */

      lsp = fnxt->idtype ;
      if(fnxt->n.v.vkind == actual) {   /* 値引数の時                 */
       expression(ws) ;                 /* 式の処理                   */
       if(!assigncompati(lsp,gattr.typtr)) /* 代入可能性チェック      */
        pcerr(155,"") ;                 /* 代入不可能                 */
       if(lsp->form <= power) {         /* スカラ､範囲型､ポインタ､集合*/
        load() ;                        /*   load命令                 */
        if(lsp->form == power)
         checkbounds(lsp,8) ;           /*  集合値の範囲チェック      */
        else if(lsp->form <= subrange)
         checkbounds(lsp,7) ;           /*  順序型の範囲チェック      */
        if((lsp == realptr) &&          /*   宣言がreal型で           */
          compatible(gattr.typtr,intptr)) {  /* 実引数がintegerの時   */
         gen0(iFLT) ;                   /*    flt命令生成             */
         gattr.typtr = realptr ;
        }
        locpar = lsp->size ;            /* スタックに積む引数サイズ計算*/
       }
       else {                           /* 配列､レコード              */
        loadaddress() ;                 /*   loadaddress命令          */
        locpar = parmsize ;             /*   アドレス分のサイズ       */
       }
      }
      else  {                           /* 変数引数の時               */
       if(sy == ident) {
        lcp = searchid(ws2) ;           /* 変数､フィールド名から探す  */
        insymbol() ;
        selector(ws,lcp) ;
        if(lsp != gattr.typtr)          /*   型が違う                 */
         pcerr(142,"") ;                /*   仮引数と実引数の型不一致 */
        if((gattr.typtr->form == files) /* 変数引数のファイルの時は   */
         &&(gattr.access == indrct))    /*     自前でloda する        */
         gen2t(iLOD,nilptr,level-gattr.vlevel,gattr.dplmt) ;
        else loadaddress() ;            /*   loadaddress命令          */
        locpar = parmsize ;             /*   アドレス分のサイズ       */
       }
       else {
        pcerr(6,"") ;                   /* 不当な記号が現れた         */
        skip(ws)    ;
       }
      }
     }
     else expression(ws) ;            /* 仮引数がない時､とりあえず
                                        実引数を式として処理しておく*/
     return(locpar) ;
}

/**************************************************/
/* pfparm() : 手続き名､関数名実パラメータ処理     */
/**************************************************/
static int pfparm(ctp *fnxt)            /* fnxt:仮引数                */
{
  ctp *lcp , *lcp1;
  Set ws;

     mkset(&ws, func,proc, -1);
     lcp = searchid(ws) ;               /* 手続き名､関数名から探す    */
     if(lcp->klass != fnxt->klass)      /* 引数の種類が違う           */
      pcerr(142,"") ;                   /* 仮引数と実引数の型が不一致 */
     else
      if(lcp->n.pf.pfdeckind == standard)
       (lcp->klass==proc) ? pcerr(174,lcp->name) : pcerr(175,lcp->name);
                                        /* 標準手続き･関数は実引数駄目*/
      else {
       lcp1 = (lcp->n.pf.sd.d.pfkind==actual)
                 ? lcp->next : lcp->n.pf.sd.d.af.f.prm ;
       if(!congruity(lcp1,fnxt->n.pf.sd.d.af.f.prm))
        pcerr(127,lcp->name);           /* 同形でない                 */
       else if(lcp->klass == func)
        if(lcp->idtype != fnxt->idtype)
         pcerr(173,lcp->name) ;         /* 関数の結果の型が違う       */
      }

     if(lcp->n.pf.sd.d.pfkind==actual) {/* 実引数の時                 */
      genp(iBAS,level - lcp->n.pf.sd.d.pflev) ;/* baseアドレスを求める*/
      genjump(iLAP,lcp->n.pf.sd.d.af.a.pfname);/*実行アドレス         */
     }
     else {                             /* 仮引数の時                 */
      gen2t(iLOD,nilptr,level - lcp->n.pf.sd.d.pflev,
                         lcp->n.pf.sd.d.af.f.levadr) ; /*loda 定義水準*/
      gen2t(iLOD,nilptr,level - lcp->n.pf.sd.d.pflev,
                         lcp->n.pf.sd.d.af.f.adradr) ; /*loda 実行adr */
     }

     insymbol() ;
     return(2)  ; /* 暫定  アドレスサイズ×2を返せば良い */
}

/******************************************/
/* congruity() : パラメータの同形チェック */
/******************************************/
static boolean congruity(ctp *fcp1,ctp *fcp2)
{
     while(fcp1 && fcp2) {              /* 2つとも引数があれば        */
      if(fcp1->klass != fcp2->klass)    /* 引数の種類が違う           */
       return(false) ;
      if(fcp1->klass == vars) {         /* 値､変数の時                */
       if(fcp1->linkno != fcp2->linkno) /* 名前並びの数が違う         */
        return(false) ;
       if(fcp1->n.v.vkind != fcp2->n.v.vkind) /* 値､変数の種類が違う  */
        return(false) ;
       if(fcp1->idtype != fcp2->idtype) /* 型が違う                   */
        return(false) ;
      }
      else {
       if(fcp1->klass == func)          /* 関数引数の時               */
        if(fcp1->idtype != fcp2->idtype)/*  関数の結果型が違う        */
         return(false);
       if(!congruity(fcp1->n.pf.sd.d.af.f.prm, fcp2->n.pf.sd.d.af.f.prm))               return(false) ;            /* それぞれの仮引数についてチェック*/
      }
      fcp1 = fcp1->next ;
      fcp2 = fcp2->next ;
     }
     return((!fcp1) && (!fcp2))          ;/* 両方とも数が同じならOK
                                             数が違えば          NG   */
}