/*********************************************************************
 *
 *    *** HAPPy Pascal compiler ***
 *
 *      procedure or function call
 *        (主に標準手続き､標準関数)
 *
 *     void call(Set fsys,ctp *fcp)
 *
 *        Copyright (c) H.Asano 1992-1994.
 *
 **********************************************************************/

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

/***********************************/
/* 標準手続き･標準関数名の識別子   */
/***********************************/
typedef enum stdpf
{
    /** 標準手続き **/
             spWRITE,                   /* write                      */
             spWRITELN,                 /* writeln                    */
             spREAD,                    /* read                       */
             spREADLN,                  /* readln                     */
             spPAGE,                    /* page                       */
             spGET,                     /* get                        */
             spPUT,                     /* put                        */
             spRESET,                   /* reset                      */
             spREWRITE,                 /* rewrite                    */
             spNEW,                     /* new                        */
             spDISPOSE,                 /* dispose                    */
             spPACK,                    /* pack                       */
             spUNPACK,                  /* unpack                     */
    /** 標準関数   **/
             sfABS,                     /* abs                        */
             sfSQR,                     /* sqr                        */
             sfTRUNC,                   /* trunc                      */
             sfROUND,                   /* round                      */
             sfODD,                     /* odd                        */
             sfORD,                     /* ord                        */
             sfCHR,                     /* chr                        */
             sfPRED,                    /* pred                       */
             sfSUCC,                    /* succ                       */
             sfEOLN,                    /* eoln                       */
             sfEOF,                     /* eof                        */
             sfSIN,                     /* sin                        */
             sfCOS,                     /* cos                        */
             sfEXP,                     /* exp                        */
             sfSQRT,                    /* sqrt                       */
             sfLN,                      /* ln                         */
             sfARCTAN,                  /* arctan                     */
} stdpf ;


/********** 関数のプロトタイプ宣言 **********/

extern void calluser(Set,ctp*) ;
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 enterid(ctp*)    ;
extern ctp  *mkctp(char*,enum idclass,stp*,ctp*) ;
extern void pcerr(int,char*) ;
extern void insymbol(void)   ;
extern boolean string(stp*)  ;
extern boolean compatible(stp*,stp*) ;
extern boolean assigncompati(stp*,stp*) ;
extern void checkbounds(stp*,int) ;
extern void getbounds(stp*,long*,long*) ;
extern void constant(Set, stp**, union valu*);
extern int align(stp*,int) ;
extern void gen0(enum pcdmnc)     ;
extern void genp(enum pcdmnc, int) ;
extern void genq(enum pcdmnc, int) ;
extern void gen0t(enum pcdmnc,stp*) ;
extern void gen1t(enum pcdmnc,stp*,int) ;
extern void gen2t(enum pcdmnc,stp*,int,int) ;
extern void genldc(char,long) ;
extern void genlda(int,int)   ;
extern void genixa(long,int)  ;
extern void genchk(stp*,int,long,long) ;
extern void convertint(stp*)  ;
extern void load(void) ;
extern void loadaddress(void) ;
extern void store(attr) ;
extern void skip(Set) ;

static void pwrite(char*,Set,stdpf) ;
static void textwrite(Set,char*,attr)    ;
static void nottextwrite(Set,char*,attr) ;
static void pread(char*,Set,stdpf)  ;
static void nottextread(Set,char*,attr)  ;
static void ppage(char*,Set) ;
static void pgetputrstrwt(char*,Set,stdpf);
static void pnewdis(char*,Set,stdpf);
static void ppack(char*,Set) ;
static void punpack(char*,Set) ;
static void variable(Set)   ;
static void fabs(char*) ;
static void fsqr(char*) ;
static void ftrunc(char*) ;
static void fround(char*) ;
static void fodd(char*) ;
static void ford(char*) ;
static void fchr(char*) ;
static void fpredsucc(char*,stdpf) ;
static void feofeoln(char*,Set,stdpf)   ;
static void fcalc(char*,stdpf) ;
static void enterstdpf_sub(char*,enum idclass,stp*,stdpf) ;

static attr inputattr  ;                /* input ファイル省略時に使用 */
static attr outputattr ;                /* outputファイル省略時に使用 */

/**********************************************************************/

/***************************************/
/*  call() : 手続き･関数の呼出処理     */
/***************************************/
void call(Set fsys,ctp *fcp)
{
  int lkey ;
  char *name ;                          /* 手続き名(エラーメッセージ用)*/
  Set ws   ;

     if(fcp->n.pf.pfdeckind == standard) {  /* 標準手続きor標準関数の時 */
      lkey = fcp->n.pf.sd.key ;
      name = fcp->name        ;
      if(fcp->klass == proc) {          /* 手続きの時                 */
       mkset(&ws,spWRITE,spWRITELN,spREAD,spREADLN,spPAGE,-1);
       if(! inset(ws,lkey))      /* write,writeln,read,readln,page以外*/
        if(sy == lparent) insymbol() ;
        else pcerr(9,"") ;              /* ( がない                   */

       switch(lkey) {
        case spWRITE   :
        case spWRITELN :  pwrite(name,fsys,lkey) ;  break ;
        case spREAD    :
        case spREADLN  :  pread(name,fsys,lkey) ;   break ;
        case spPAGE    :  ppage(name,fsys) ;        break ;
        case spGET     :
        case spPUT     :
        case spRESET   :
        case spREWRITE :  pgetputrstrwt(name,fsys,lkey) ;  break ;
        case spNEW     :
        case spDISPOSE :  pnewdis(name,fsys,lkey) ;  break ;
        case spPACK    :  ppack(name,fsys) ;  break ;
        case spUNPACK  :  punpack(name,fsys) ; break ;
       }

       if(! inset(ws,lkey))      /* write,writeln,read,readln,page以外*/
        if(sy == rparent) insymbol() ;
        else pcerr(4,"") ;              /* ) がない　                 */
      }

      else {                            /* 標準関数の時               */
       ws = fsys ;
       addset(ws,rparent) ;
       if((lkey != sfEOLN) && (lkey != sfEOF)) { /* eoln,eof以外は(がある*/
        if(sy == lparent) insymbol() ;
        else pcerr(9,"") ;              /* ( がない                   */
        expression(ws)   ;              /* 引数の処理                 */
        load()           ;              /* 引数をload                 */
       }

       switch(lkey) {                   /* 関数により振り分ける       */
        case sfABS  : fabs(name)   ; break;
        case sfSQR  : fsqr(name)   ; break;
        case sfTRUNC: ftrunc(name) ; break;
        case sfROUND: fround(name) ; break;
        case sfODD  : fodd(name)   ; break;
        case sfORD  : ford(name)   ; break;
        case sfCHR  : fchr(name)   ; break;
        case sfPRED :
        case sfSUCC : fpredsucc(name,lkey)   ; break;
        case sfEOLN :
        case sfEOF  : feofeoln(name,ws,lkey) ; break;
        case sfSIN  :
        case sfCOS  :
        case sfEXP  :
        case sfSQRT :
        case sfLN   :
        case sfARCTAN: fcalc(name,lkey) ;break;  /* 算術関数          */
       }

       if((lkey != sfEOLN) && (lkey != sfEOF))  /* eoln,eof以外は)がある*/
        if(sy == rparent) insymbol() ;
        else pcerr(4,"") ;              /* ) がない                   */

      }
     }

     else calluser(fsys,fcp) ;          /* ユーザ定義の手続き･関数を呼ぶ*/
}

/*****************************************/
/* cspfile():ファイル入出力関係の命令生成*/
/*    以下の命令はこれを使わない         */
/*         (wrs,put,get,rst,rwt)         */
/*****************************************/
static void cspfile(attr fattr,enum pcdmnc mnc)
{
  int p = 2 ;                           /* 一般ファイルとしておく     */

     if(fattr.access == drct)           /* ファイル変数が実変数の時   */
      switch(fattr.dplmt) {
       case inputadr  : p=0 ; break ;   /* input ファイルへのアクセス */
       case outputadr : p=1 ; break ;   /* outputファイルへのアクセス */
       default        : genq(iLAO,fattr.dplmt) ;
      }
     else                               /* ファイル変数が変数引数     */
      gen2t(iLOD,nilptr,level-fattr.vlevel,fattr.dplmt) ;

     genp(mnc,p) ;                       /* 命令生成                  */
}

/******************************************/
/*  loadfilead() : ファイルアドレスロード */
/******************************************/
static void loadfilead(attr bufattr)
{
     if(bufattr.access == drct)         /* ファイル変数が実変数の時   */
      genq(iLAO,bufattr.dplmt) ;        /* HAPPyでは大域変数しかない  */
     else                               /* ファイル変数が変数引数     */
      gen2t(iLOD,nilptr,level-bufattr.vlevel,bufattr.dplmt) ;
}

/***************************************/
/* pwrite() : write/writeln手続きの処理*/
/***************************************/
void pwrite(char *name,Set fsys,stdpf fkey)
{
  stp *lsp ;
  attr fileattr ;
  boolean test ;
  boolean textflag;
  Set ws,ws1 ;

     fileattr = outputattr  ;           /* outputファイル省略時の属性 */
     textflag = true    ;
     mkset(&ws,comma,colon,rparent,-1) ;
     orset(&ws,&fsys) ;

     if(sy == lparent) {                /* ( がきたら引数がある       */
      insymbol() ;
      expression(ws) ;                  /* 最初の式                   */
      lsp = gattr.typtr ;
      test = false ;
      if(lsp)
       if(lsp->form == files) {         /***** ファイル変数の処理 *****/
        fileattr = gattr ;              /* ファイル変数の属性を退避   */
        if(!lsp->sf.fi.texttype) {      /*テキストファイルでない      */
         textflag = false ;
         if(fkey == spWRITELN) pcerr(116,name) ;/* writelnはテキストのみ*/
        }

        if(sy == rparent) {
         if(fkey == spWRITE) pcerr(116,name) ; /* writeの時は)は駄目  */
         test = true ;                  /* 処理終わり                 */
        }
        else if(sy == comma) {          /* ファイル変数に次ぐ文字が , */
         if(!textflag)
          loadfilead(fileattr);         /*  バッファ変数アドレスロード*/
         insymbol() ;
         expression(ws) ;               /* 出力対象式                 */
        }
        else {                          /* ) , 以外                   */
         pcerr(116,name);               /* 標準手続きの引数に誤り     */
         mkset(&ws1,comma,rparent);
         orset(&ws1,&fsys);
         skip(ws1) ;                    /* 読み飛ばし                 */
        }
       }
       else if(!defineoutput) pcerr(301,name) ; /* ファイル変数省略時
                                                  outputが未定義ならエラー*/

      if(! test)
       if(textflag)
        textwrite(ws,name,fileattr);        /*  出力対象式の処理      */
       else
        nottextwrite(fsys,name,fileattr);   /* テキスト以外への出力   */

      if(sy == rparent) insymbol() ;
      else pcerr(4,"") ;
     }

     else                               /* (がない ･･･ 引数がない     */
      if(fkey == spWRITE) pcerr(116,name) ;   /* writeは必ず引数が必要*/
      else if(!defineoutput) pcerr(301,name) ;/* output未定義は駄目   */

     if(fkey == spWRITELN)
      cspfile(fileattr,iWLN) ;
}

/***************************************/
/* textwrite() : text型への出力        */
/***************************************/
static void textwrite(Set fsys,char *fname,attr fattr)
{
  stp *lsp;
  int len ;
  int p   ;                             /* p operand                  */
  boolean defaultcolum  ;               /* default 桁数の時 true      */
  boolean test          ;

     do {
      defaultcolum = true ;

      lsp = gattr.typtr ;
      if(lsp)
       (lsp->form <= subrange) ? load() : loadaddress() ;

       if(sy==colon) {                  /* 桁数指定がある時           */
        insymbol() ;                    /* 桁数を読む                 */
        expression(fsys) ;              /* 桁数の処理                 */
        if(gattr.typtr)
         if(gattr.typtr != intptr)
          pcerr(116,fname) ;            /* 標準手続きの引数の型誤り   */
         load() ;                       /* 桁数をload                 */
         defaultcolum = false ;         /* 桁数指定あり               */
       }

       if(lsp == intptr) {              /* 整数型                     */
        if(defaultcolum) genldc('i',12L); /* 桁数省略時  12桁         */
        cspfile(fattr,iWRI) ;
       }
       else if(lsp == realptr) {        /* 実数型                     */
        if(sy!=colon) {                 /* 固定少数点指定でない時     */
         if(defaultcolum) genldc('i',14L) ; /* 桁数省略時 14桁        */
          cspfile(fattr,iWRR) ;         /*  wrr  (浮動小数点出力)     */
        }
        else {                          /* 固定小数点出力             */
         insymbol() ;                   /* 桁数を読む                 */
         expression(fsys) ;             /* 桁数の処理                 */
         if(gattr.typtr)
          if(gattr.typtr != intptr)
           pcerr(116,fname) ;           /* 標準手続きの引数の型誤り   */
         load() ;                       /* 桁数をload                 */
         cspfile(fattr,iWRF) ;          /* wrf  (固定少数点出力)      */
        }
       }
       else if(lsp == charptr) {        /* 文字型                     */
        if(defaultcolum) genldc('i',1L);/* 桁数省略時 1桁             */
        cspfile(fattr,iWRC) ;
       }
       else if(string(lsp)) {           /* 文字列型                   */
        len = lsp->size / charmax ;
        if(defaultcolum) genldc('i',(long)len); /* 省略時 文字列の桁数*/
        p = 2 ;                         /* 一般ファイルとしておく     */
        if(fattr.access == drct)        /* ファイル変数が実変数の時   */
         if(fattr.dplmt == outputadr)
          p = 1 ;                       /* outputファイル表示         */
         else
          genq(iLAO,fattr.dplmt) ;      /* HAPPyでは大域変数しかない  */
        else                            /* ファイル変数が変数引数     */
         gen2t(iLOD,nilptr,level-fattr.vlevel,fattr.dplmt) ;
        gen2t(iWRS,nil,p,len) ;         /* wrs命令生成　 q･･･ 文字列長*/
       }
       else if(lsp == boolptr) {        /* boolean型                  */
        if(defaultcolum) genldc('i',5L);/* 桁数省略時  5桁            */
        cspfile(fattr,iWRB) ;
       }
       else pcerr(116,fname) ;          /* 標準関数の引数の型の誤り   */

       if(test = (sy == comma)) {
       insymbol() ;
       expression(fsys) ;               /* 次の出力対象式             */
      }
     } while(test) ;                    /* , なら繰り返す             */
}

/*****************************************/
/* nottextwrite() : テキスト型以外の出力 */
/*****************************************/
static void nottextwrite(Set fsys,char *fname,attr bufattr)
{
  boolean test  ;
  Set ws ;

     bufattr.typtr = bufattr.typtr->sf.fi.filtype;/* バッファ変数の型 */
     mkset(&ws,comma,rparent,-1);
     orset(&ws,&fsys) ;

     do {
      if(gattr.typtr) {
       if(gattr.typtr->form <= power)   /* スカラー､範囲､ポインタ､集合*/
        load() ;
       else loadaddress() ;

       if((bufattr.typtr == realptr) &&      /* バッファ変数がreal    */
          (compatible(gattr.typtr,intptr))){ /* 書くものが整数型の時  */
        gen0(iFLT) ;                         /* 実数に変換 flt命令    */
        gattr.typtr = realptr ;
       }

       if(assigncompati(bufattr.typtr,gattr.typtr)) /* ﾊﾞｯﾌｧ変数に代入可能 */
        switch(bufattr.typtr->form) {   /* 型によって振り分ける       */
         case scalar   :
         case subrange :
           checkbounds(bufattr.typtr,18) ; /* 上限･下限のチェック     */
           store(bufattr) ;
           break ;
         case pointer  :
           store(bufattr) ;
           break ;
         case power :
           checkbounds(bufattr.typtr,72) ; /* 上限･下限のチェック     */
           store(bufattr) ;
           break ;
         case arrays  :
         case records :
           gen2t(iMOV,nil,1,bufattr.typtr->size) ;
           break ;
         case files :
           pcerr(116,fname) ;           /* 標準手続きの引数誤り       */
        }
       else pcerr(116,fname) ;          /* 代入可能でない場合         */

       loadfilead(bufattr) ;            /* ファイル変数アドレスロード */
       gen0(iPUT) ;                     /* 命令生成                   */
      }

      if(test = (sy == comma)) {
       loadfilead(bufattr) ;            /* バッファ変数アドレスロード */
       insymbol() ;
       expression(ws) ;                 /* 次の出力対象式             */
      }
     } while(test) ;                    /* , なら繰り返す             */
}

/***************************************/
/* pread() : read/readln手続きの処理   */
/***************************************/
static void pread(char* name,Set fsys,stdpf fkey)
{
  stp *lsp ;
  attr fileattr ;
  boolean textflag ;
  boolean test ;
  Set ws ;

     fileattr = inputattr ;             /* inputファイル省略時の属性  */
     textflag = true   ;
     mkset(&ws,comma,rparent,-1) ;
     orset(&ws,&fsys) ;

     if(sy == lparent) {                /* ( がきたら引数がある       */
      insymbol() ;
      variable(ws) ;                    /* 最初の変数                 */
      lsp = gattr.typtr;
      test = false ;
      if(lsp)
       if(lsp->form == files) {         /****** file 変数の処理 *******/
        fileattr = gattr ;              /* ファイル変数の属性を退避   */
        if(!lsp->sf.fi.texttype)  {     /* textファイル以外           */
         textflag = false ;
         if(fkey == spREADLN) pcerr(116,name) ;/* readlnはテキストのみ*/
        }
        if(sy == rparent) {
         if(fkey == spREAD) pcerr(116,name) ; /* readの時は)は駄目    */
         test = true ;                  /* 処理終わり                 */
        }
        else if(sy != comma) {          /* ファイル変数に次ぐ文字が,でない*/
         pcerr(116,name);               /* 標準手続きの引数に誤り     */
         skip(ws) ;                     /* 読み飛ばし                 */
        }
        if(sy == comma) {
         insymbol() ;
         variable(ws) ;                 /* ,に続く変数の処理          */
        }
        else test = true ;              /* ) の時                     */
       }
       else if(!defineinput) pcerr(300,name) ; /* ファイル変数省略時
                                               Inputが未定義ならエラー*/

      if(! test)                        /**** 読込対象変数の処理 ******/
       if(textflag)                     /* テキストファイルの時       */
        do {
         loadaddress() ;

         if(gattr.typtr)
          if(gattr.typtr->form <= subrange)
           if(compatible(intptr,gattr.typtr))
            cspfile(fileattr,iRDI) ;    /* integer型なら  rdi         */
           else if(realptr == gattr.typtr)
            cspfile(fileattr,iRDR) ;    /*  real型なら    rdr         */
           else if(compatible(charptr,gattr.typtr))
            cspfile(fileattr,iRDC) ;    /*  char型なら    rdc         */
           else pcerr(116,name) ;       /* 引数の型に誤り             */
          else  pcerr(116,name) ;       /* 引数の型に誤り             */

          if(test = (sy == comma)) {
          insymbol() ;
          variable(ws) ;                /* 次の変数の処理             */
          }
        } while(test) ;
       else nottextread(fsys,name,fileattr); /* テキスト以外の入力    */

      if(sy == rparent) insymbol() ;
      else pcerr(4,"") ;
     }
     else
      if(fkey == spREAD)    pcerr(116,name) ;
      else if(!defineinput) pcerr(300,name) ; /* readlnで引数がなく
                                                  input未定義は駄目   */

     if(fkey == spREADLN)               /* readln関数の時             */
      cspfile(fileattr,iRLN) ;          /*  csp rln                   */
}

/*****************************************/
/* nottextread() : テキスト型以外の入力  */
/*****************************************/
static void nottextread(Set fsys,char *fname,attr bufattr)
{
  boolean test ;
  Set ws ;

     bufattr.typtr = bufattr.typtr->sf.fi.filtype ; /*バッファ変数の型*/
     mkset(&ws,comma,rparent,-1);
     orset(&ws,&fsys) ;

     do {
      if(gattr.typtr) {
       if((gattr.access != drct) ||     /* 直接参照でないか           */
          (gattr.typtr->form > power))  /* 配列型､レコード型､ファイル型*/
       loadaddress() ;                  /* の時は、アドレスをのせる   */
       if(bufattr.access == drct)       /* ファイル変数が実変数       */
        if(bufattr.typtr->form<=power)  /* スカラ,範囲,ポインタ,集合  */
         gen1t(iLDO,bufattr.typtr,bufattr.dplmt); /* バッファ変数ﾛｰﾄﾞ */
        else genq(iLAO,bufattr.dplmt) ;
       else {                           /* ファイル変数が変数引数     */
        gen2t(iLOD,nilptr,level-bufattr.vlevel,bufattr.dplmt) ;
        if(bufattr.typtr->form <= power)/* スカラ,範囲,ポインタ,集合  */
         gen1t(iIND,bufattr.typtr,0) ;  /* ind命令で値をロード        */
       }
       if((gattr.typtr == realptr) &&          /* 読む変数がreal      */
          (compatible(bufattr.typtr,intptr))){ /* ﾊﾞｯﾌｧ変数が整数型の */
        gen0(iFLT) ;                           /* 実数に変換 flt命令  */
        gattr.typtr = realptr ;
       }

       if(assigncompati(gattr.typtr,bufattr.typtr)) /* 代入可能ﾁｪｯｸ   */
        switch(gattr.typtr->form) {     /* 型によって振り分ける       */
         case scalar   :
         case subrange :
           checkbounds(gattr.typtr,17) ;/* 上限･下限のチェック        */
           store(gattr) ;
           break ;
         case pointer  :
           store(gattr) ;
           break ;
         case power :
           checkbounds(gattr.typtr,71) ;/* 上限･下限のチェック        */
           store(gattr) ;
           break ;
         case arrays  :
         case records :
           gen2t(iMOV,nil,1,gattr.typtr->size) ;
           break ;
         case files :
           pcerr(116,fname) ;           /* 標準手続きの引数誤り       */
        }
       else pcerr(116,fname) ;          /* 代入可能でない場合         */

       loadfilead(bufattr) ;             /* ファイル変数アドレスロード */
       gen0(iGET) ;                      /* get命令生成               */
      }

      if(test = (sy == comma)) {
       insymbol() ;
       variable(ws) ;                 /* 次の出力対象式               */
      }
     } while(test) ;                  /* , なら繰り返す               */
}

/***************************************/
/* ppage() : page手続きの処理          */
/***************************************/
static void ppage(char* name,Set fsys)
{
  Set  ws    ;

     ws = fsys ;
     addset(ws,rparent) ;

     if(sy == lparent)  {               /* 引数がある時               */
      insymbol()   ;
      variable(ws) ;                    /* ファイル変数               */
      if(gattr.typtr != textptr)        /* テキストファイルでなければ */
       pcerr(116,name) ;                /* 標準手続きの引数誤り       */
      if(sy == rparent) insymbol() ;
      else pcerr(4,"") ;                /* )がない                    */
     }
     else {                             /* 引数がない時               */
      if(!defineoutput) pcerr(301,name);/* outputファイル未定義       */
      gattr = outputattr ;
     }

     cspfile(gattr,iPGE) ;
}

/***********************************************************/
/* pgetputrstrwt() : get/put/reset/rewrite手続きの処理     */
/***********************************************************/
static void pgetputrstrwt(char *name,Set fsys,stdpf fkey)
{
  enum pcdmnc opname ;                  /* オペレーション名           */
  Set ws ;

     ws = fsys ;
     addset(ws,rparent) ;
     variable(ws) ;                     /* ファイル変数               */

     if(gattr.typtr)
      if(gattr.typtr->form != files)    /* ファイル変数でない         */
       pcerr(116,name) ;                /* 標準手続きの引数誤り       */
      else
       if(gattr.typtr == textptr) {     /* テキストファイルの時       */
        switch(fkey) {
         case spGET    : opname = iTGT ; break ;
         case spPUT    : opname = iTPT ; break ;
         case spRESET  : opname = iTRS ; break ;
         case spREWRITE: opname = iTRW ; break ;
        }
        cspfile(gattr,opname) ;         /* 命令生成                   */
       }
       else {                           /* テキストファイル以外の時   */
        switch(fkey) {
         case spGET    : opname = iGET ; break ;
         case spPUT    : opname = iPUT ; break ;
         case spRESET  : opname = iRST ; break ;
         case spREWRITE: opname = iRWT ; break ;
        }
        loadfilead(gattr) ;             /* ファイル変数アドレスロード */
        gen0(opname) ;
       }
}

/***************************************/
/* pnewdis() : new/dispose手続きの処理 */
/***************************************/
static void pnewdis(char *name,Set fsys,stdpf fkey)
{
  stp *lsp = nil;
  stp *lsp1     ;
  stp *lspconst ;                       /* 定数の型                   */
  union valu lval ;                     /* 定数の値                   */
  int lsize = 0 ;                       /* 確保･解放するエリアサイズ  */
  Set ws ;

     mkset(&ws,rparent,comma,-1);
     orset(&ws,&fsys) ;
     if(fkey == spNEW) {
      variable(ws)  ;                   /* newは引数変数の処理        */
      loadaddress() ;
     }
     else {
      expression(ws);                   /* disposeは式が許される　    */
      load() ;
     }

     if(gattr.typtr)
      if(gattr.typtr->form == pointer) {
       if(gattr.typtr->sf.pt.eltype) {  /* 指し示す物の型がある       */
        lsize = gattr.typtr->sf.pt.eltype->size ;
        if(gattr.typtr->sf.pt.eltype->form == records)
         lsp = gattr.typtr->sf.pt.eltype->sf.re.recvar ; /* 可変部    */
       }
      }
      else pcerr(116,name) ;            /* 標準手続きの引数の型に誤り */

     while(sy == comma) {               /* 定数の指定がある時         */
      insymbol() ;
      constant(ws,&lspconst,&lval)  ;
      if(string(lspconst) || (lspconst==realptr)) /* 文字列､実数型    */
       pcerr(159,"") ;                  /* 文字列､実数型は指定不可    */
      if(!lsp) pcerr(162,"")  ;        /* 該当する可変要素選択子がない*/
      else if((lsp->form == tagfld) &&
              (lsp->sf.tg.tagtype)) {   /* 可変部がある場合           */
       if(compatible(lsp->sf.tg.tagtype,lspconst)) { /* 型が適合する  */
        if(lsp->sf.tg.tagtype->form == subrange)
         if((lval.ival < lsp->sf.tg.tagtype->sf.su.min) ||
            (lval.ival > lsp->sf.tg.tagtype->sf.su.max))  /* 範囲外   */
          pcerr(162,"") ;              /* 該当する可変要素選択子がない*/
        lsp1 = lsp->sf.tg.fstvar ;
        while(lsp1) {                   /* 該当する可変要素を探す     */
         if(lsp1->sf.vr.varval == lval.ival) {  /* 必ず一致するものがある*/
          lsize = lsp1->size ;
          break ;
         }
         else lsp1 = lsp1->sf.vr.nextvr ;
        }
       }
       else pcerr(162,"") ;             /* 該当する可変要素選択子がない*/
       lsp   = lsp1->sf.vr.subvar ;     /* 配下の可変部               */
      }
      else pcerr(162,"") ;              /* 該当する可変要素選択子がない*/
     }

     if(fkey == spNEW) genq(iNEW,lsize);/* new                        */
     else              genq(iDIS,lsize);/* dis                        */
}

/***************************************/
/*     ppack() : pack手続きの処理      */
/***************************************/
static void ppack(char *name,Set fsys)
{
  stp *lspuinx=nil;                      /* 詰めなし配列の添え字の型   */
  stp *lspuael=nil;                      /* 詰めなし配列の要素の型     */
  long lmin,lmax  ;
  int  lsize      ;
  Set ws ;

     mkset(&ws,comma,rparent,-1);
     orset(&ws,&fsys);
     variable(ws) ;                     /* 詰めなし配列               */
     if(gattr.typtr)
      if((gattr.typtr->form == arrays)  /* 詰めなし配列チェック       */
      && (!gattr.typtr->sf.ar.packed)) {
       lspuinx = gattr.typtr->sf.ar.inxtype;
       lspuael = gattr.typtr->sf.ar.aeltype;
       loadaddress() ;                  /* 転送元アドレスをロード     */
      }
      else pcerr(116,name) ;            /* 標準手続きの引き数の型誤り */
     if(sy == comma) insymbol() ;

     expression(ws) ;                   /* 詰めなし配列の添え字式     */
     if(gattr.typtr)
      if((gattr.typtr->form  == scalar)
      && (compatible(gattr.typtr,lspuinx))) { /* 型が適合すること     */
       load() ;                         /* 式の値をロード             */
       convertint(gattr.typtr) ;        /* 必要ならord命令生成        */
       getbounds(lspuinx,&lmin,&lmax) ; /* 添え字の範囲を調べる       */
       if(debug) genchk(intptr,26,lmin,lmax) ; /* chk命令を生成       */
       lsize = lspuael->size ;
       lsize = align(lspuael,lsize) ;   /* 境界合わせ                 */
       genixa(lmin,lsize) ;             /* ixa命令生成                */
      }
      else pcerr(116,name) ;            /* 標準手続きの引き数の型誤り */
     if(sy == comma) insymbol() ;

     ws = fsys;
     addset(ws,rparent) ;
     variable(ws) ;                     /* 詰め込み配列               */
     if(gattr.typtr)
      if((gattr.typtr->form == arrays)  /* 詰め込み配列チェック       */
      && (gattr.typtr->sf.ar.packed)
      && (compatible(gattr.typtr->sf.ar.inxtype,lspuinx))
      && (compatible(gattr.typtr->sf.ar.aeltype,lspuael))) {
       loadaddress() ;                  /* 転送先アドレスをロード     */
       gen2t(iMOV,nil,2,gattr.typtr->size) ; /* mov 2命令             */
      }
      else pcerr(116,name) ;            /* 標準手続きの引き数の型誤り */
}

/***************************************/
/*     punpack() : unpack手続きの処理  */
/***************************************/
static void punpack(char *name,Set fsys)
{
  stp *lsppinx=nil;                     /* 詰めあり配列の添え字の型   */
  stp *lsppael=nil;                     /* 詰めあり配列の要素の型     */
  stp *lspuinx=nil;                     /* 詰めなし配列の添え字の型   */
  stp *lspuael=nil;                     /* 詰めなし配列の要素の型     */
  long lmin,lmax  ;
  int  lsize      ;
  int  movleng    ;                     /* 転送長                     */
  Set ws ;

     mkset(&ws,comma,rparent,-1);
     orset(&ws,&fsys);
     variable(ws) ;                     /* 詰めあり配列               */
     if(gattr.typtr)
      if((gattr.typtr->form == arrays)  /* 詰めあり配列チェック       */
      && (gattr.typtr->sf.ar.packed)) {
       lsppinx = gattr.typtr->sf.ar.inxtype;
       lsppael = gattr.typtr->sf.ar.aeltype;
       movleng = gattr.typtr->size ;
       loadaddress() ;                  /* 転送元アドレスをロード     */
      }
      else pcerr(116,name) ;            /* 標準手続きの引き数の型誤り */
     if(sy == comma) insymbol() ;

     variable(ws) ;                     /* 詰めなし配列               */
     if(gattr.typtr)
      if((gattr.typtr->form == arrays)  /* 詰めなし配列チェック       */
      && (!gattr.typtr->sf.ar.packed)
      && (compatible(gattr.typtr->sf.ar.inxtype,lsppinx))
      && (compatible(gattr.typtr->sf.ar.aeltype,lsppael))) {
       lspuinx = gattr.typtr->sf.ar.inxtype;
       lspuael = gattr.typtr->sf.ar.aeltype;
       loadaddress() ;                  /* 基底アドレスをロード       */
      }
      else pcerr(116,name) ;            /* 標準手続きの引き数の型誤り */
     if(sy == comma) insymbol() ;

     ws = fsys;
     addset(ws,rparent) ;
     expression(ws) ;                   /* 詰めなし配列の添え字式     */
     if(gattr.typtr)
      if((gattr.typtr->form  == scalar)
      && (compatible(gattr.typtr,lspuinx))) { /* 型が適合すること     */
       load() ;                         /* 式の値をロード             */
       convertint(gattr.typtr) ;        /* 必要ならord命令生成        */
       getbounds(lspuinx,&lmin,&lmax) ; /* 添え字の範囲を調べる       */
       if(debug) {
        genchk(intptr,29,lmin,lmax) ;   /* chk命令を生成              */
        genldc('i',(long)(movleng-1));  /* 転送長-1                   */
        gen0(iADI) ;                    /* 転送後の配列添え字         */
        genchk(intptr,31,lmin,lmax) ;   /* 添え字範囲内か             */
        genldc('i',(long)(movleng-1));
        gen0(iSBI) ;                    /* もとに戻す                 */
       }
       lsize = lsppael->size ;
       lsize = align(lsppael,lsize) ;   /* 境界合わせ                 */
       genixa(lmin,lsize) ;             /* ixa命令生成                */
       gen2t(iMOV,nil,2,movleng) ;      /* mov 2命令                  */
      }
      else pcerr(116,name) ;            /* 標準手続きの引き数の型誤り */
}

/***************************************/
/*     fabs() : abs関数の処理          */
/***************************************/
static void fabs(char *name)
{
     if(gattr.typtr)
      if(gattr.typtr == intptr)       gen0(iABI) ;  /* integerならabi */
      else if(gattr.typtr == realptr) gen0(iABR) ;  /* real   ならabr */
      else {
       pcerr(125,name) ;                /* 標準関数の引数の型に誤り   */
       gattr.typtr = intptr ;
      }
}

/***************************************/
/*     fsqr() : sqr関数の処理          */
/***************************************/
static void fsqr(char *name)
{
     if(gattr.typtr)
      if(gattr.typtr == intptr)       gen0(iSQI) ;  /* integerならsqi */
      else if(gattr.typtr == realptr) gen0(iSQR) ;  /* real   ならsqr */
      else {
       pcerr(125,name) ;                /* 標準関数の引数の型に誤り   */
       gattr.typtr = intptr ;
      }
}

/***************************************/
/*    ftrunc() : trunc関数の処理       */
/***************************************/
static void ftrunc(char *name)
{
     if(gattr.typtr)
      if(gattr.typtr == realptr) gen0(iTRC) ; /* real ならtrc         */
      else pcerr(125,name) ;            /* 標準関数の引数の型に誤り   */
     gattr.typtr = intptr ;
}

/***************************************/
/*    fround() : round関数の処理       */
/***************************************/
static void fround(char *name)
{
     if(gattr.typtr)
      if(gattr.typtr == realptr) gen0(iROU) ; /* real ならrou         */
      else pcerr(125,name) ;            /* 標準関数の引数の型に誤り   */
     gattr.typtr = intptr ;
}

/***************************************/
/*     fodd() : odd関数の処理          */
/***************************************/
static void fodd(char *name)
{
     if(gattr.typtr)
      if(gattr.typtr == intptr) gen0(iODD) ; /* integerならodd        */
      else pcerr(125,name) ;            /* 標準関数の引数の型に誤り   */
     gattr.typtr = boolptr ;
}

/***************************************/
/*     ford() : ord関数の処理          */
/***************************************/
static void ford(char *name)
{
     if(gattr.typtr)
      if((gattr.typtr->form <= subrange) /* スカラ、部分範囲型         */
      && (gattr.typtr != realptr))       /* realでない時               */
       convertint(gattr.typtr) ;         /* 必要ならばord命令を生成    */
      else pcerr(125,name) ;             /* 標準関数の引数の型に誤り   */
     gattr.typtr = intptr ;
}

/***************************************/
/*     fchr() : chr関数の処理          */
/***************************************/
static void fchr(char *name)
{
     if(gattr.typtr)
      if(gattr.typtr == intptr) gen0(iCHR) ; /* integerなら chr命令   */
      else pcerr(125,name) ;            /* 標準関数の引数の型に誤り   */
     gattr.typtr = charptr ;
}

/***************************************/
/* fpredsucc() : pred / succ関数の処理 */
/***************************************/
static void fpredsucc(char *name,stdpf fkey)
{
   enum pcdmnc opname ;                  /* オペレーション名           */
   int kind ;
   long lmin,lmax ;

     if(gattr.typtr)
      if((gattr.typtr->form == scalar)  /* 引数はスカラのこと         */
       &&(gattr.typtr != realptr)) {    /*   ただし　real型はいけない */
       getbounds(gattr.typtr,&lmin,&lmax);/* その型の上限､下限を求める*/
       if(lmin==lmax)                   /* 取りえる値が1つしかない時  */
        pcerr(125,name) ;               /* 標準関数の引数の型に誤り   */
       if(fkey == sfSUCC) {
        opname = iINC ;
        kind   = 38   ;
        lmax-- ;
       }
       else {
        opname = iDEC ;
        kind   = 39   ;
        lmin++ ;
       }
       if(debug)
        genchk(gattr.typtr,kind,lmin,lmax) ; /* chk命令生成           */
       gen1t(opname,gattr.typtr,1) ;    /* succならinc, predならdec   */
      }
      else pcerr(125,name) ;            /* 標準関数の引数の型に誤り   */
}

/***************************************/
/* feofeoln() : eof,eoln関数の処理     */
/***************************************/
static void feofeoln(char *name,Set fsys,stdpf fkey)
{
     if(sy == lparent) {                /* 引数がある時               */
      insymbol()   ;
      variable(fsys) ;                  /* ファイル変数の処理         */
      if(sy == rparent) insymbol() ;
      else pcerr(4,"") ;                /* ) がない                   */
      if(gattr.typtr)
       if((gattr.typtr->form != files) ||/* 引数の型はfile型でない    */
          ((fkey==sfEOLN) && (gattr.typtr!=textptr)))
                                        /* eolnの時はtext型しか駄目   */
       pcerr(125,name) ;                /* 標準関数の引数の型に誤り   */
     }
     else {                             /* 引数がない時               */
      if(!defineinput) pcerr(300,name); /*  input未定義の時は駄目     */
      gattr = inputattr ;
     }

     if(fkey == sfEOLN)  cspfile(gattr,iEOL) ;
     else                cspfile(gattr,iEOF) ;

     gattr.typtr = boolptr ;
}

/***************************************/
/* fcalc(): 算術関数の処理             */
/***************************************/
static void fcalc(char *name,stdpf fkey)
{
  enum pcdmnc mnc;                      /* オペレーション名           */

     if(gattr.typtr) {
      if(gattr.typtr == intptr) {       /* 引数がinteger              */
       gen0(iFLT) ;                     /* 引数をrealに変換           */
       gattr.typtr = realptr ;
      }
      else if(gattr.typtr != realptr)
       pcerr(125,name) ;                /* 標準関数の引数の型に誤り   */
      switch(fkey) {
       case sfSIN    : mnc = iSIN; break;
       case sfCOS    : mnc = iCOS; break;
       case sfEXP    : mnc = iEXP; break;
       case sfSQRT   : mnc = iSQT; break;
       case sfLN     : mnc = iLOG; break;
       case sfARCTAN : mnc = iATN;
      }
      gen0(mnc) ;
     }
}

/***************************************/
/* variable() : 変数引数の処理         */
/***************************************/
static void variable(Set fsys)
{
  ctp *lcp ;
  Set ws;

     if(sy == ident) {                  /* 引数が名前の時             */
      mkset(&ws,vars,field,-1);
      lcp = searchid(ws) ;              /* 変数､フィールド名から探す  */
      insymbol() ;
     }
     else {
      pcerr(2,"") ;                     /* 名前がない                 */
      lcp = uvarptr ;                   /* 未定義変数用の名前エリア   */
     }
     selector(fsys,lcp) ;
}

/*****************************************/
/* enterstdf() : 標準手続き･関数名の登録 */
/*****************************************/
void enterstdpf(void)
{
     enterstdpf_sub("write"   ,proc,nilptr,spWRITE)   ;  /* write     */
     enterstdpf_sub("writeln" ,proc,nilptr,spWRITELN) ;  /* writeln   */
     enterstdpf_sub("read"    ,proc,nilptr,spREAD)    ;  /* read      */
     enterstdpf_sub("readln"  ,proc,nilptr,spREADLN)  ;  /* readln    */
     enterstdpf_sub("page"    ,proc,nilptr,spPAGE)    ;  /* page      */
     enterstdpf_sub("get"     ,proc,nilptr,spGET)     ;  /* get       */
     enterstdpf_sub("put"     ,proc,nilptr,spPUT)     ;  /* put       */
     enterstdpf_sub("reset"   ,proc,nilptr,spRESET)   ;  /* reset     */
     enterstdpf_sub("rewrite" ,proc,nilptr,spREWRITE) ;  /* rewrite   */
     enterstdpf_sub("new"     ,proc,nilptr,spNEW)     ;  /* new       */
     enterstdpf_sub("dispose" ,proc,nilptr,spDISPOSE) ;  /* dispose   */
     enterstdpf_sub("pack"    ,proc,nilptr,spPACK)    ;  /* pack      */
     enterstdpf_sub("unpack"  ,proc,nilptr,spUNPACK)  ;  /* unpack    */

     enterstdpf_sub("abs"     ,func,nilptr ,sfABS)    ;  /* abs       */
     enterstdpf_sub("sqr"     ,func,nilptr ,sfSQR)    ;  /* sqr       */
     enterstdpf_sub("trunc"   ,func,intptr ,sfTRUNC)  ;  /* trunc     */
     enterstdpf_sub("round"   ,func,intptr ,sfROUND)  ;  /* round     */
     enterstdpf_sub("odd"     ,func,boolptr,sfODD)    ;  /* odd       */
     enterstdpf_sub("ord"     ,func,intptr ,sfORD)    ;  /* ord       */
     enterstdpf_sub("chr"     ,func,charptr,sfCHR)    ;  /* chr       */
     enterstdpf_sub("pred"    ,func,nilptr ,sfPRED)   ;  /* pred      */
     enterstdpf_sub("succ"    ,func,nilptr ,sfSUCC)   ;  /* succ      */
     enterstdpf_sub("eoln"    ,func,boolptr,sfEOLN)   ;  /* eoln      */
     enterstdpf_sub("eof"     ,func,boolptr,sfEOF)    ;  /* eof       */
     enterstdpf_sub("sin"     ,func,realptr,sfSIN)    ;  /* sin       */
     enterstdpf_sub("cos"     ,func,realptr,sfCOS)    ;  /* cos       */
     enterstdpf_sub("exp"     ,func,realptr,sfEXP)    ;  /* exp       */
     enterstdpf_sub("sqrt"    ,func,realptr,sfSQRT)   ;  /* sqrt      */
     enterstdpf_sub("ln"      ,func,realptr,sfLN)     ;  /* ln        */
     enterstdpf_sub("arctan"  ,func,realptr,sfARCTAN) ;  /* arctan    */

   /* inputファイル省略時の属性  */
     inputattr.access  = drct    ;
     inputattr.vlevel  = 1       ;
     inputattr.dplmt   = inputadr;

   /* outputファイル省略時の属性 */
     outputattr.access  = drct    ;
     outputattr.vlevel  = 1       ;
     outputattr.dplmt = outputadr ;
}

/****************************************************/
/*  enterdtdpf_sub() : 標準手続き･関数名の登録サブ  */
/****************************************************/
static void enterstdpf_sub(char *name,enum idclass pf,
                           stp *typeptr,stdpf pfid)
{
  ctp *cp ;

     cp = mkctp(name,pf,typeptr,nil);   /* 名前エリアを確保する       */
     cp->n.pf.pfdeckind = standard    ; /* 標準関数                   */
     cp->n.pf.sd.key    = pfid        ; /* 識別子                     */
     enterid(cp)                      ; /* 名前登録                   */
}