/**********************************************************************
 *
 *    ***  HAPPy Pascal Compiler ***
 *
 *             宣言部のコンパイル
 *
 *    ラベル宣言部        void labeldecl(Set fsys)
 *    定数定義部          void constdecl(Set fsys)
 *    型定義部            void typedecl(Set fsys)
 *    変数宣言部          void vardecl(Set fsys,ctp *fprocp)
 *    手続き/関数宣言部   void procfuncdecl
 *                            (Set fsys,enum symbol fsy,ctp **pffwdptr)
 *
 *           Copyrignt (c) H.Asano 1992
 *
 **********************************************************************/

#define EXTERN extern

#include <string.h>
#include "pascomp.h"

extern void block(Set,enum symbol,ctp*);
extern int crelabel(void) ;
extern void pcerr(int,char*) ;
extern char *inttoch(long)   ;
extern char *inttoch(long)   ;
extern Set  *mkset(Set*,int,...) ;
extern Set  *orset(Set*,Set*) ;
extern void insymbol(void) ;
extern void skip(Set) ;
extern void updatelc(int) ;
extern ctp  *mkctp(char*,enum idclass,stp*,ctp*) ;
extern void enterid(ctp*) ;
extern ctp *searchid(Set) ;
extern ctp *searchsection(ctp*)  ;
extern boolean typ(Set, stp**,int*) ;
extern void constant(Set,stp**,union valu*)  ;
extern int  align(stp*,int) ;
extern void applied(ctp*,int)   ;
extern ctp  *mkctp(char*,enum idclass,stp*,ctp*) ;
extern void *Malloc(int) ;
extern void *mark(void)  ;
extern void release(void*) ;
extern void putfilename(char*,int,int);

/*********************************************/
/*     labeldecl() : label宣言部コンパイル   */
/*********************************************/
void labeldecl(Set fsys)
{
  lbp     *llp  ;
  boolean redef ;                       /* redefine flag              */
  boolean test  ;                       /* 繰り返しのために使う       */
  Set     ws    ;                       /* 作業用集合                 */

     do {
      if(sy == intconst) {              /* 整数の時                   */ 
       redef = false ; 
       llp = display[top].flabel ;
       while(llp) {                     /* label テーブル サーチ      */
        if(llp->labval != (int)val.ival) llp = llp->nextlab ;
        else {                          /*  同じ値があった            */
         redef = true ;
         pcerr(166,inttoch(val.ival)) ; /*  ラベルが再度宣言された    */
         break ;
        }
       }
       if(! redef) {                       /* 再宣言でないとき (OKの時)*/
        llp = (lbp*)Malloc(sizeof(lbp)) ;  /* label テーブル 確保     */
        llp->labval  = (int)val.ival ;     /* ラベル値                */
        llp->labname = crelabel() ;        /* P-codeのラベル名生成    */
        llp->defined = false    ;          /* 定義未とする            */
        llp->nextlab = display[top].flabel ;
        display[top].flabel = llp ;        /* ﾎﾟｲﾝﾀのつなぎかえ       */

        if((val.ival < 0) || (val.ival > 9999)) /* 0〜9999の間でない時*/
         pcerr(164,"") ;                   /* ラベルが誤っている      */
       }
       insymbol() ;
      }
      else pcerr(164,"") ;              /* 整数でない時 ラベル誤り    */

      mkset(&ws, comma,semicolon, -1) ;
      orset(&ws, &fsys) ;
      if( ! inset(ws,sy)) {      /* 次のsymbolの正当性チェック       */
       pcerr(6,"")      ;        /*   不当な記号が現れた             */
       skip(ws)         ;        /*   正しいところまで読み飛ばし     */
      }

      test = (sy == comma) ;
      if(test) insymbol()  ;     /*  , ならば次のsymbolを読む        */
     } while(test)         ;     /*  , であれば繰り返す              */

     if(sy == semicolon) insymbol() ;    /* ; だったら次のsymbol     */
     else                pcerr(14,"");   /* ; がない　               */
}

/*********************************************/
/*     constdecl() : 定数定義部のコンパイル  */
/*********************************************/
void constdecl(Set fsys)
{
  ctp   *lcp ;
  stp   *lsp ;
  union valu  lvalu ;
  Set   ws1   ;
  Set   ws2   ;

     ws1 = fsys             ;
     addset(ws1, ident)     ;           /* ws1 = fsys + [ident]       */
     ws2 = fsys             ;
     addset(ws2, semicolon) ;           /* ws2 = fsys + [semicolon]   */

     if(sy != ident) {
      pcerr(2,id)    ;                  /* 名前がない                 */
      skip(ws1)            ;            /* fsys+[ident]まで読み飛ばし */
     }

     while(sy == ident) {
      lcp = mkctp(id,konst,nil,nil) ; 
      insymbol() ;
      if(op == eqop) insymbol() ;       /* = なら 次のsymbolを読む    */
      else           pcerr(16,"") ;     /* = がない                   */
      constant(ws2, &lsp, &lvalu) ;     /* 右辺の処理                 */
      lcp->idtype = lsp           ;     /* 右辺の型 (lsp)             */
      lcp->n.values = lvalu       ;     /* 右辺の値 (lavlu)           */
      enterid(lcp)                ;     /* 左辺の名前を登録           */

      if(sy == semicolon) {             /* ; ならば                   */ 
       insymbol()  ;                    /*  次のsymbolを読む          */
       if( ! inset(ws1,sy)) {           /*    fsysまたは名前でない　  */
        pcerr(6,"")   ;                 /*    不当な記号が現れた      */
        skip(ws1)  ;                    /* fsys+identのsymbolまでskip */
       }
      } else pcerr(14,"")  ;            /* ; がない　                 */
     }
}

/*********************************************/
/*      typedecl() : 型定義部のコンパイル    */
/*********************************************/
void typedecl(Set fsys)
{
  ctp *lcp ;
  ctp *lcp1 ;                           /* 前方参照解決用             */
  ctp *lcp2 ;                           /* lcp1の1つ前の値            */
  stp *lsp ;
  int lsize ;
  Set ws ;

     typevar = true ;                   /* 型定義部での型の処理       */
     
     if(sy != ident) {                  /* 名前でない                 */
      pcerr(2,"") ;                     /*  名前がない                */
      mkset(&ws, ident, -1) ;
      orset(&ws, &fsys)     ;
      skip(ws)              ;           /* fsys+[ident] まで読み飛ばし*/
     }

     while(sy == ident) {               /*                            */
      lcp = mkctp(id,types,nil,nil) ;   /*  名前のエリアを確保        */
      insymbol()            ;
      if(op == eqop) insymbol() ;       /* = ならば次のsymbol         */
      else pcerr(16,"")     ;           /*  =がない                   */

      mkset(&ws, semicolon,-1) ;
      orset(&ws,&fsys) ;
      typ(ws, &lsp, &lsize) ;
      if(lsp && !lsp->assignflag && lsp->form != files) 
                                        /* ファイル型を含む型の時     */
       pcerr(608,"") ;                  /* 局所ファイルは駄目         */
      lcp->idtype = lsp     ;
      enterid(lcp)          ;

   /*** 前方参照リストのうち今定義された型を参照しているものを解決 ***/
      lcp1 = fwptr ;
      while(lcp1) {
       if(strcmp(lcp1->name, lcp->name) == 0) {     /* 型名が等しい     */
        lcp1->idtype->sf.pt.eltype = lcp->idtype ;  /* 型を入れる       */
        if(lcp1 != fwptr) lcp2->next = lcp1->next ; /*  チェーンから外す*/
        else fwptr = lcp1->next ;       /* fwptr先頭の時は次を新fwptrに */
       }
       else lcp2 = lcp1 ;               /* 次のループのために退避     */
       lcp1 = lcp1->next ;
      }

      if(sy == semicolon) {
       insymbol() ;
       mkset(&ws,ident,-1) ;
       orset(&ws,&fsys) ;
       if(! inset(ws,sy)) {
        pcerr(6,"") ;                   /* 不当な記号が現れた         */
        skip(ws)    ;                   /* fsys+[ident]まで読み飛ばし */
       }
      } else pcerr(14,"") ;             /* ; がない                   */
     }

     while(fwptr) {                     /* 前方参照が未解決の時       */
      pcerr(117,fwptr->name) ;          /*   前方参照未解決           */
       fwptr = fwptr->next   ;
     } ;
}

/*********************************************/
/*      vardecl() : var節のコンパイル        */
/*********************************************/
void vardecl(Set fsys,ctp *fprocp)
{
  static fileno = 0 ;
  ctp *lcp ;
  ctp *nxt ;
  stp *lsp ;
  extfilep *extp ;
  int lsize ;
  boolean test;
  boolean notfound ;
  Set  ws ;

     nxt = nil ;
     typevar = false ;                  /* 変数定義部での型の処理     */

     do {
      do {
       if(sy == ident) {
        lcp = mkctp(id,vars,nil,nxt) ;  /* 名前を変数として登録       */
        lcp->n.v.vkind = actual ;
        lcp->n.v.vlev  = level  ;
        enterid(lcp) ;
        nxt = lcp ;

        insymbol() ;
       }
       else pcerr(2,id) ;               /* 名前がない                 */

       mkset(&ws, comma, colon, -1) ;   /* ws = [comma,colon]         */
       orset(&ws, &fsys)            ;   /*     + fsys                 */
       orset(&ws, &typedels)        ;   /*     + typedels             */
       if(! inset(ws,sy)) {
        pcerr(6,"")             ;       /*  不当な記号が現れた        */
        addset(ws,semicolon)    ;
        skip(ws)                ;       /*  誤り回復のため読み飛ばし  */
       }

       if(test = (sy == comma)) insymbol() ;  /* , なら次のsymbol     */
      } while(test) ;                   /*       , なら繰り返す       */

      if(sy == colon) insymbol() ;      /* : なら次のsymbol           */
      else pcerr(5,"")           ;      /* : がない                   */

      ws = fsys ;
      orset(&ws,&typedels) ;
      addset(ws,semicolon) ;
      typ(ws, &lsp, &lsize)   ;
      if(lsp && !lsp->assignflag && lsp->form != files) 
                                        /* ファイル型を含む型の時     */
       pcerr(608,"") ;                  /* 局所ファイルは駄目         */

      while(nxt) {
       updatelc(align(lsp,lc) - lc);    /* 変数の割りつけ開始番地     */
       nxt->idtype = lsp      ;         /* 変数の型                   */
       nxt->n.v.vaddr = lc    ;         /* 変数の割りつけ番地         */
       if(lsp && lsp->form == files)    /*  ファイル変数の時          */
        if(!fprocp && fextfilep) {      /*    メインブロックで
                                            プログラム引数がある時    */
         extp = fextfilep ;
         notfound = true  ;
         while(extp && notfound) {      /* プログラム引数と照合       */
          if(!strcmp(extp->filename,nxt->name)) { /* 引数に書いた名前 */
           if(++fileno > Maxfileno)     /* 最大ファイル数を越えている */
            pcerr(600,inttoch((long)Maxfileno)) ;
           putfilename(nxt->name,lc,nxt->idtype->size) ;
                                        /*  ファイル情報を出力する    */
           notfound = false ;
          }
          extp = extp->nextfile  ;
         }
         if(notfound) pcerr(608,"") ;   /* 局所ファイルは駄目         */
        }
        else pcerr(608,"") ;            /* メインブロック以外または
                                           プログラム引数がない時     */ 
       updatelc(lsize)  ;               /* lc 更新                    */
       nxt = nxt->next  ;
      }

      if(sy == semicolon) {
       insymbol() ;
       ws = fsys  ;
       addset(ws,ident) ;
       if(! inset(ws,sy)) {
        pcerr(6,"") ;                   /* 不当な記号が現れた         */
        skip(ws)    ;                   /* fsys+[ident]まで読み飛ばし */
       }
      }
      else pcerr(14,"") ;               /* ; がない                   */
     
     } while((sy == ident) || (inset(typedels,sy))) ;
}

/*************************************************/
/*  procfuncdecl() : procedure/function宣言部の  */
/*                             コンパイル        */
/*************************************************/

typedef enum prmkind { normal,          /* ブロックと結合された引数   */
                       procfunc }       /* 関数､手続き引数の引数      */
             prmkind ;
             
static void pfparmlist(ctp**,Set,Set,boolean,prmkind) ;
static void functype(Set,ctp*,boolean) ;
static ctp  *pfident(Set,enum symbol,boolean*,boolean*)   ;
static void prmpflist(Set,ctp**,prmkind) ;
static void prmvarlist(Set,Set,ctp**,prmkind)  ;
                       
void procfuncdecl(Set fsys,enum symbol fsy,ctp **pffwdptr)
{

  int oldlc ;                           /* location counter 退避域    */
  int oldlevel ;                        /* level退避域                */
  int oldtop   ;                        /* top退避域                  */
  ctp *lcp     ;                        /* proc/funcの名前ポインタ    */
  ctp *lcp1,*lcp2  ;                    /* 前方宣言解決用のポインタ   */
  void *markadr ;                       /* 一括解放アドレス           */
  boolean forw ;                        /* すでに宣言されている時true */
  boolean err160 ;
  Set ws       ;

     oldlc = lc   ;                     /* 今のlocation counterを退避 */
     lc  = lcaftermarkstack ;           /* 新しくlcを初期設定         */
     
     lcp = pfident(fsys,fsy,&forw,&err160) ; /* 名前の処理            */
     
     oldlevel = level ;                 /* 今の水準を退避             */
     oldtop   = top   ;                 /* 今のdisplay先頭位置を退避  */

     if(level < Maxlevel) level++ ;     /* 水準オーバでなければ水準を増やす*/
     else pcerr(604,inttoch((long)Maxlevel)) ;
                                        /* 手続き･関数の入れ子が深すぎ*/
     if(top   < Displimit) {            /* displayがまだある時        */
      top++ ;                           /* 新しい水準のdisplay初期設定*/
      display[top].fname  = (forw) ? lcp->next : nil ;
      display[top].flabel = nil  ;
      display[top].aname  = nil  ;
      display[top].occur  = blck ;
      display[top].funcname = (fsy==funcsy) ? lcp : nil ; /* 関数名   */
      display[top].funcassign = false ; /* 関数への代入未(手続き無効) */
     }
     else pcerr(603,inttoch((long)Displimit)) ;
                                        /* 名前の入れ子が深すぎる     */

     if(fsy == procsy) {                /* 手続きの時                 */
      mkset(&ws,semicolon,-1) ;
      pfparmlist(&(lcp->next),ws,fsys,forw,normal) ;
     }
     else {
      mkset(&ws,semicolon,colon,-1);
      pfparmlist(&(lcp->next),ws,fsys,forw,normal) ;
      functype(fsys,lcp,forw);          /* 関数の型の処理             */
     }

     if(sy == semicolon) insymbol() ;
     else pcerr(14,"") ;                /* ; がない                   */

     if((sy==ident) && (strcmp(id,"forward")==0)) {
                                        /* forward指令があった時      */
      if(forw)
       pcerr(161,lcp->name) ;           /* 再び前方宣言された         */
      else if(!err160 && ((lcp->klass==proc) || (lcp->klass==func))) {
       lcp->n.pf.sd.d.af.a.fwdptr=*pffwdptr; /* 前方宣言名をつなぐ    */
       *pffwdptr = lcp ;
       lcp->n.pf.sd.d.af.a.forwdecl = true ;
      } 
      insymbol() ;
      if(sy == semicolon) insymbol() ;
      else pcerr(14,"") ;               /* ; がない                   */
      if(! inset(fsys,sy)) {            /* 終端記号にない時           */
       pcerr(6,"") ;                    /*   不当な記号が現れた       */
       skip(fsys)  ;                    /*   読み飛ばし               */
      }
     }
     else {                             /* forward指令がない時        */
      lcp->n.pf.sd.d.af.a.forwdecl = false ;
      lcp1 = *pffwdptr ;                /* 前方宣言リストから外す     */
      while(lcp1) {
       if(strcmp(lcp1->name,lcp->name) == 0) {
        if(lcp1 != *pffwdptr)
         lcp2->n.pf.sd.d.af.a.fwdptr = lcp1->n.pf.sd.d.af.a.fwdptr ;
        else *pffwdptr = lcp1->n.pf.sd.d.af.a.fwdptr ;
       }
       else lcp2 = lcp1 ;
       lcp1 = lcp1->n.pf.sd.d.af.a.fwdptr ;
      }
      markadr = mark() ;                /* 一括解放アドレスをマーク   */
      do {
       block(fsys,semicolon,lcp) ;      /* ブロック処理               */
       if(sy == semicolon) {
        insymbol() ;
        mkset(&ws,beginsy,procsy,funcsy,-1);
        if(! inset(ws,sy)) {
         pcerr(6,"") ;                  /* 不当な記号が現れた         */
         skip(ws)    ;                  /* 読み飛ばし                 */
        }
       }
       else pcerr(14,"") ;              /* ; がない                   */
      } while(! inset(ws,sy)) ;         /* begin,procedure,functionなら抜ける*/
      release(markadr) ;                /* heapメモリを一括解放       */
     }

     level = oldlevel ;                 /* 前の水準に復帰             */
     top   = oldtop   ;                 /* 前のdisplay先頭に復帰      */
     lc    = oldlc    ;                 /* 前のlocation counterに復帰 */
}

/***************************************/
/* pfident() : proc/funcの名前の処理   */
/***************************************/
static ctp *pfident(Set fsys,enum symbol fsy,boolean *ffwd,boolean *err160)
{
  ctp *lcp,*lcp1 ;
  boolean forw = false ;                /* 前方参照宣言フラグ         */

     *err160 = false ;
     
     if(sy != ident) {                  /* 名前でない                 */
      pcerr(2,"") ;                     /*   名前がない               */
      insymbol()  ;
      return(ufctptr) ;                 /*  未定義用の名前エリアを返却*/
     }

     lcp = searchsection(display[top].fname) ; /* 同じ水準から名前を探す*/
     if(lcp)                            /* 名前が見つかった           */
      if((lcp->klass == proc) || (lcp->klass == func)) { /*forward宣言*/
       forw = (((lcp->klass==proc) && (fsy==procsy)) ||  /*されている */
               ((lcp->klass==func) && (fsy==funcsy)))    /*かチェック */
           && (lcp->n.pf.sd.d.pfkind==actual)
           && (lcp->n.pf.sd.d.af.a.forwdecl)  ;
       if(! forw) {
        pcerr(160,id) ;                 /* 既に正式な宣言が行われている*/
        *err160 = true ;                /* かなりヤクザなやり方です    */
        forw    = true ;
       }
      }
      else pcerr(101,lcp->name);        /* 名前の二重定義エラー       */
     else {                             /* 名前が見つからなかった     */
      lcp = (fsy == procsy) ? mkctp(id,proc,nil,nil)  /* 名前エリア確保*/
                            : mkctp(id,func,nil,nil) ;
      lcp->n.pf.pfdeckind     = declared  ;
      lcp->n.pf.sd.d.pfkind   = actual    ;
      lcp->n.pf.sd.d.pflev    = level     ;
      lcp->n.pf.sd.d.af.a.pfname   = crelabel();
      enterid(lcp) ;                    /* 名前の登録                 */
     }
     if(forw) {                         /* 前方宣言された名前の時     */
      lcp1 = lcp->next ;                /*    変数の割当をする        */
      while(lcp1 && lcp1->next)         /* 最後の引数を得る           */
       lcp1 = lcp1->next ;
      switch(lcp1->klass) {
       case vars :                     /* 変数                        */
              updatelc(lcp1->n.v.vaddr - lc) ;
              if(lcp1->n.v.vkind==actual){ /* 値引数                  */
               if(lcp1->idtype)        /*   型がエラーでない時        */
                updatelc(lcp1->idtype->size); /* サイズ分進める       */
              }
              else                     /*   変数引数                  */
               updatelc(ptrsize);      /*     ポインタサイズだけ進める*/
             break ;
       case proc :
       case func :                      /* 手続き 関数                */
             updatelc((lcp1->n.pf.sd.d.af.f.adradr + ptrsize) - lc) ;
             break ;
      }
     }

     insymbol()   ;
     *ffwd = forw ;
     return(lcp)  ;
}

/****************************************/
/*  functype() : 関数の型処理           */
/****************************************/
static void functype(Set fsys,ctp *fcp,boolean forw)
{
  ctp *lcp1;
  stp *lsp ;
  Set ws ;

     if(sy == colon) {                  /* : の 時                    */
      insymbol() ;                      /*  型を読む                  */
      if(sy == ident) {
       if(forw) pcerr(122,fcp->name) ;  /* 再び型を書いてはいけない   */
       mkset(&ws,types,-1) ;
       lcp1 = searchid(ws) ;            /* 型名より探す               */
       fcp->idtype = lsp = lcp1->idtype  ;
       if(lsp) {
        mkset(&ws,scalar,subrange,pointer,-1);
        if(! inset(ws,lsp->form)) {     /* 型がスカラ､範囲型､ポインタでない時*/
         pcerr(120,fcp->name) ;         /* 関数の型の誤り             */
         fcp->idtype = nil ;
        }
       } 
       insymbol() ;
      }
      else {
       pcerr(2,"") ;                    /* 名前がない                 */
       ws = fsys ;
       addset(ws,semicolon) ;
       skip(ws)  ;                      /* 読み飛ばし                 */
      }
     }
     else                               /* : がない時                  */
      if(! forw) pcerr(123,fcp->name);  /* 関数の宣言に型がない        */
}

/*****************************************/
/* pfparamlist() : パラメータリスト処理  */
/*****************************************/
static void pfparmlist(ctp **fcp,Set fsys,Set fpfsys,boolean forw,prmkind kind)
{
  ctp *lcp1,*lcp2,*lcp3 ;
  Set ws,ws1     ;
  Set prmbegsys  ;                      /* 引数の最初のsymbolとしてOKのもの*/

     mkset(&prmbegsys, ident,varsy,procsy,funcsy, -1);
     lcp1 = nil ;

     ws = fsys ;
     addset(ws,lparent) ;
     if(! inset(ws,sy)) { 
      pcerr(7,"") ;                     /* 引数の並びに誤りがある     */
      orset(&ws,&fpfsys) ;
      skip(ws)    ;                     /* 読み飛ばし                 */
     }

     if(sy == lparent) {
      if(forw) pcerr(119,"") ;          /* 前方宣言されているので引数は駄目*/
      insymbol() ;
      if(! inset(prmbegsys,sy)) {
       pcerr(7,"") ;                    /* 引数の並びに誤りがある     */
       mkset(&ws,ident,rparent,-1) ;
       orset(&ws,&fpfsys) ;
       skip(ws)    ;                    /* 読み飛ばし                 */
      }

      ws = prmbegsys ;
      orset(&ws,&fpfsys) ;
      while(inset(prmbegsys,sy)) {      /* 引数の開始symbolとしてokの間*/
       switch(sy) {
        case procsy :
        case funcsy : prmpflist(fpfsys,&lcp1,kind) ;   /* 手続き､関数引数*/
                      break ;      
        default     : prmvarlist(fsys,fpfsys,&lcp1,kind) ; /* 変数,値引数*/
       }
       if(sy == semicolon) {
        insymbol() ;
        if(! inset(ws,sy)) {
         pcerr(7,"") ;                  /* 引数の並びに誤りがある     */
         mkset(&ws1,ident,rparent,-1);
         skip(ws1) ;                    /* 読み飛ばし                 */
        } 
       }
      }

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

     /* reverse pointers and reserve local cells for copies of
        multiple values  */

     lcp3 = nil ;
     while(lcp1) {                      /* 最初のlcp1は最後のﾊﾟﾗﾒｰﾀを指す*/
      lcp2 = lcp1->next ;
      lcp1->next = lcp3 ;
      if(kind == normal)                /* ブロックと結合される引数   */ 
       if(lcp1->klass == vars)          /*  変数の時                  */
        if(lcp1->idtype)
         if((lcp1->n.v.vkind==actual) &&     /* 局所変数(値渡し)で    */
            (lcp1->idtype->form > power)) {  /* 配列･レコードの時     */
          updatelc(align(lcp1->idtype,lc) - lc) ;
          lcp1->n.v.vaddr = lc ;        /* 変数アドレス割りつけ       */  
          updatelc(lcp1->idtype->size);
         }
      lcp3 = lcp1 ;
      lcp1 = lcp2 ;
     }

     if(((kind==normal) && (!forw)) || (kind==procfunc) )
      *fcp = lcp3 ;                     /* 引数の並びを設定           */
}

/*******************************************/
/* prmpflist() : 手続き･関数パラメータ処理 */
/*******************************************/
static void prmpflist(Set fsys,ctp **fcp1,prmkind kind)
{
  ctp *lcp;
  enum symbol lsy ;
  int oldtop ;
  Set ws  ;
  
  /****** 手続き名･関数名の処理 *****/
   
     lsy = sy   ;
     insymbol() ;
     if(sy != ident) {                  /* 名前でない                 */
      pcerr(2,"") ;                     /*   名前がない               */
      insymbol()  ;
      lcp = ufctptr ;                   /* 名前がない時の仮のエリア   */
     }
     else {
      lcp = (lsy == procsy) ? mkctp(id,proc,nil,*fcp1)/* 名前エリア確保*/
                            : mkctp(id,func,nil,*fcp1) ;
      lcp->n.pf.pfdeckind     = declared  ;
      lcp->n.pf.sd.d.pfkind   = formal    ;       /* 仮手続き･仮関数  */
      lcp->n.pf.sd.d.pflev    = level     ;       /* 定義水準         */
      enterid(lcp) ;                    /* 名前の登録                 */
     }
     *fcp1 = lcp ;
     
  /***** 仮パラメータ並びの処理 *****/
  
     oldtop = top ;
     if(top   < Displimit) {            /* displayがまだある時        */
      top++ ;                           /* 新しい水準のdisplay初期設定*/
      display[top].fname  = nil  ;
      display[top].aname  = nil  ;
      display[top].flabel = nil  ;      /* 意味なし                   */
      display[top].occur  = blck ;      /* 意味なし                   */ 
     }
     else pcerr(603,inttoch((long)Displimit)) ;
                                        /* 名前の入れ子が深すぎる     */

     insymbol() ;  
     if(lsy == procsy) {                /* 手続きの時                 */
      mkset(&ws,rparent,semicolon,-1) ;
      pfparmlist(&(lcp->n.pf.sd.d.af.f.prm),ws,fsys,false,procfunc) ;
     }
     else {
      mkset(&ws,rparent,semicolon,colon,-1);
      pfparmlist(&(lcp->n.pf.sd.d.af.f.prm),ws,fsys,false,procfunc) ;
      functype(fsys,lcp,false);         /* 関数の型の処理             */
     }

     if(kind == normal) {               /* ブロックと結合される時     */
      updatelc(align(intptr,lc) - lc) ;
      lcp->n.pf.sd.d.af.f.levadr = lc ; /* 水準差をのせるアドレス     */
      updatelc(intsize) ;
      updatelc(align(nilptr,lc) - lc) ; 
      lcp->n.pf.sd.d.af.f.adradr = lc ; /*実行アドレスをのせるアドレス*/
      updatelc(ptrsize) ;                                  
     }

     top = oldtop ;
}

/*****************************************/
/* prmvarlist() : 変数､値パラメータ処理  */
/*****************************************/
static void prmvarlist(Set fsys,Set fpfsys,ctp **fcp1,prmkind kind)
{
  enum idkind lkind ;                   /* actual ･･･ 値パラメータ
                                           formal ･･･ 変数パラメータ  */
  ctp *lcp,*lcp2,*lcp3 ;
  stp *lsp             ;
  int count  = 0       ;
  int number = 0       ;
  int lsize            ;
  int llc              ;
  boolean test         ;
  Set ws               ;

     if(sy == varsy) {
      lkind = formal ;                  /* varの付くものは変数引数    */
      insymbol()     ;
     }
     else lkind = actual ;              /* varが付かなければ値引数    */

     lcp2 = nil ;
     do {
      if(sy == ident) {
       lcp = mkctp(id,vars,nil,lcp2) ;  /* 変数用のエリアを確保       */
       lcp->n.v.vkind = lkind ;
       lcp->n.v.vlev  = level ;
       enterid(lcp) ;
       lcp2 = lcp ;
       count++    ;
       insymbol() ;
      }
      mkset(&ws,comma,colon,-1);
      orset(&ws,&fpfsys) ;
      if(! inset(ws,sy)) {
       pcerr(7,"") ;                    /* 引数の並びに誤りがある     */
       addset(ws,rparent);
       skip(ws)    ;                    /* 読み飛ばし                 */
      }
      if(test=(sy==comma)) insymbol() ; /* , ならば次のsymbolを読む   */
     } while(test) ;                    /* , ならば次の名前の処理     */

     if(sy == colon) {
      insymbol() ;
      if(sy == ident) {
       mkset(&ws,types,-1) ;
       lcp = searchid(ws)  ;            /* 型名を探す                 */
       applied(lcp,top)    ;            /* 引用名チェーン             */
       lsp = lcp->idtype   ;
       lsize = ptrsize     ;            /*配列･ﾚｺｰﾄﾞ･変数ﾊﾟﾗ=ｱﾄﾞﾚｽｻｲｽﾞ*/
       if(lsp)
        if(lkind == actual)             /* 値パラメータ               */
         if(lsp->form <= power) lsize = lsp->size ; /* ｽｶﾗ､範囲､ﾎﾟｲﾝﾀ､集合 */
         else if(!lsp->assignflag) pcerr(121,"");
                                        /* ファイルの要素型として許されない*/
       if(kind == normal) {             /* ブロックと結合される引数   */  
        lsize = align(parmptr,lsize) ;  /* パラメータリストの境界調整 */
        updatelc(align(parmptr,lc) - lc);
        updatelc(count*lsize)        ;  /* パラメータリスト領域を確保 */
       }

       llc  = lc   ;
       lcp3 = lcp2 ;                    /* 変数並びの最後の変数の名前アドレス*/
       while(lcp2) {                    /* 各変数にエリアを割りつける */
        lcp = lcp2;
        lcp2->idtype = lsp ;            /* 型                         */
        lcp2->linkno = (char)number++ ; /* 同形リンク番号             */
        if(kind == normal) {            /* ブロックと結合される引数   */
         llc -= lsize ;
         lcp2->n.v.vaddr = llc ;        /* アドレス割りつけ           */
        } 
        lcp2 = lcp2->next ;
       }
       lcp->next = *fcp1 ;              /* 引数をチェーンしていく     */
       *fcp1 = lcp3 ;                   /* 次回呼び出しのために       */

       insymbol() ;
      }
      else pcerr(2,"") ;                /* 名前がない                 */

      mkset(&ws,semicolon,rparent,-1);
      orset(&ws,&fpfsys) ;
      if(! inset(ws,sy)) {
       pcerr(7,"") ;                    /* 引数の並びに誤りがある     */
       skip(ws)    ;                    /* 読み飛ばし                 */
      }
     }
     else pcerr(5,"") ;                 /* : がない                   */
}