ucscompiler.pas

本Delphi项目文件为本人在一个Pascal-s（子集）源代码基础上完成的。本人增加了类进行封装

unit uCSCompiler;

interface
uses SysUtils;

//program ProjectmathNew2004;
//APPTYPE CONSOLE
//uses SysUtils;
{ author: N.Wirth E.T.H CH-8092 Zurich,1.3.76}

//uses
//  Unit1 in 'I:\Program Files\Borland\Delphi7\Projects\Unit1.pas';

const
    nkw   =   27; {no. of key words}
    alng = 10; {no. of significant chars in identifiers}
    llng = 1200;//121; {input line length}
    emax = 322;{max exponent of real numbers}
    emin = -292;{mix exponent}
    kmax = 15;{ max no. of significant digits }

    tmax = 1000;//100;{size of table}
    bmax = 100;// 20; {size of block-table }
    amax = 100;//30;{size of array - table }
    c2max =100;// 20;{ size of real constant table }
    csmax = 50;//30;{max no. of cases}
    cmax = 1000;//800;{size of code}
    lmax = 10;//7; {maximum level}
    smax = 600;{size of string-table}
    ermax = 58;{max error no.}
    omax = 63;{highest order code}//即f操作码
    xmax = 32767;{2**15-1}
    nmax = 32767;{2**15-1}

    lineleng =2500;// 132;{output line length}//指输出的结果每行字符串的最大字符数
    linelimit = 200;//输出结果行数最大不超过linelimit
    stacksize = 1450;//数据堆栈大小

TYPE
    symbol = (intcon,realcon,charcon,stringcon,notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,
            eql,neq,gtr,geq,lss,leq,
            lparent,rparent,lbrack,rbrack,comma,semicolon,period,
            colon,becomes,constsy,typesy,varsy,funcsy,
            procsy,arraysy,recordsy,programsy,ident,
            beginsy,ifsy,casesy,repeatsy,whilesy,forsy,
            endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);
    index = -xmax..+xmax;
    alfa  =  packed array [1..alng] of char;
    xobject =  (konstant ,vvariable,typel,prozedure,funktion);//object
    types = (notyp,ints,reals,bools,chars,arrays,records);
    symset = set of symbol;
    typset = set of types;
    item = record
            typ:types;ref:index;
           end;

    order = packed record
                f: -omax..+omax;
                x: -lmax..+lmax;
                y: -nmax..+nmax;
            end;
    {TCCSrcProg=class(TObject)
    public
        ch: char;//last character read form source program
        FileName: string;
        procedure NextChar;
    end;//TCSSrcProg  程序}

    TCCTokenID = Symbol;//??
    {TCCError =class(TObject)
        public
            procedure error(N:integer);
            procedure errormsg;
            procedure fatal(N:integer);
    end;}
    TCSCompiler = class;
    TCSLex = class(TObject)
        private
           // function Getchar: Char;
        public
            //  ccError : TCCError;
            //SrcProg : TCCSrcProg;
            Compiler: TCSCompiler;

            TokenID : TCCTokenID;
            //rnum    : real;{real number from insymbol}
            rnum    : real;{real number from insymbol}
            inum    : integer;{integer from insymbol}
            prtables,stackdump : Boolean;
            ch   : char ;//read GetChar;//last character read from source program
            sy  : symbol;
            sx  : integer;
            ll      : integer;
            //lc      : integer;//不应该在这里，代码索引
            cc      : integer;//??
            sleng   : integer;
            psIn: Text;//??

            id      : alfa;
            key : array [1..nkw] of alfa; //??
            ksy : array [1..nkw] of symbol;
            sps : array [char] of symbol;
            stab : packed array [0..smax ] of char; {string table}//not reasonable
            line : array [1..llng] of char;

            errs : set of 0..ermax;
            skipflag : boolean;
            
            errpos  : integer;

            constructor Create;
            procedure Insymbol;
            procedure NextChar;
            procedure Setup;
            function  GetToken: alfa;
            procedure endskip;
            procedure error(N:integer);
            procedure errormsg;
            procedure fatal(N:integer);

    end;


    TCSCompiler= class(TObject)
    private
        FSourceFileName: string;
        FLastErrorString: string;
        procedure SetSourceFileName(_FileName: string);
        procedure SetLastErrorString(_Error: string);
        function  GetToken: alfa;
        procedure SetToken(_id: alfa);
        function  GetSy: Symbol;
        function  GetiNum: integer;
        procedure SetiNum(_inum: integer);
        {function  Getpsin: Text;
        function  Getpsout : Text;
        function  Getprr: Text;
        function  Getprd : Text;}
    public
        //        ccError: TCCError;
        CCLex   : TCSLex;
        //??ch: char;{last character read form source program }
        //rnum    : real;{real number from insymbol}
        i,j     : integer;
        //inum    : integer;{integer from insymbol}
        //sleng   : integer;
        //cc      : integer;
        lc      : integer;
        //ll      : integer;
        //errpos  : integer;
        t,a,b,{sx,}c1,c2:integer; {indices to tables}
        iflag,oflag,{ skipflag,stackdump,}prtables: boolean;
        //        sy  : symbol;
        //        errs : set of 0..ermax;



        progname: alfa;
        stantyps: typset;

        CompilerInfo : string;

        constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys : symset;

//        line : array [1..llng] of char;
        objectcode : array [1..5] of char;
        typescode : array [1..7] of char;
//        key : array [1..nkw] of alfa;
//        ksy : array [1..nkw] of symbol;
//        sps : array [char] of symbol;
        display : array [0..lmax] of integer;

        tab : array [0..tmax ] of
                packed record
                   name: alfa;
                   link: index;
                   obj:xobject;
                   typ: types;
                   ref: index;
                   normal: boolean;
                   lev: 0..lmax;
                   adr: integer;
                end;
        atab: array [1..amax] of {array - table}
                packed record
                    inxtyp,eltyp: types;
                    elref,low,high,elsize,size: index
                end;
        btab: array [1..bmax] of //block - table
                packed record
                   last,lastpar,psize,vsize:index
                end;
        //stab : packed array [0..smax ] of char; {string table}
        rconst:array [1..c2max] of real;
        code  : array [0..cmax] of order;

        inf,outf,fprr:string;

        ValidSourceFile: Boolean;
         psin,psout,prr,prd: text;{default in pascal P}
         {
        property psin : Text read Getpsin;
        property psout : Text read Getpsout;
        property prr  : Text read GetPrr;
        property prd  : text  read Getprd;}

        property  sy   : symbol  read GetSy;
        property id      : alfa read GetToken write SetToken;
        property inum    : integer read GetiNum write SetiNum;
        constructor Create;

        property SourceFileName : string read FSourceFileName write SetSourceFileName;
        property LastErrorString: string read FLastErrorString write SetLastErrorString;

        //function  GetToken: alfa;

        //procedure endskip;
        //procedure nextch;

        //procedure insymbol;
        procedure enter(x0:alfa; x1: xobject;
                     x2: types; x3: integer);

        procedure enterarray(tp:types;L,H: integer);
        procedure enterblock;

        procedure enterreal(x:real);
        procedure emit(FCT: integer);
        procedure emit1(FCT,B: integer);
        procedure emit2(FCT,A,B:integer);
        procedure printtables;
        procedure block(fsys: symset; isfun:boolean; level: integer);

        procedure  Interpret;
        //procedure Setup;
        procedure  enterids;
        procedure  Test;
        procedure  Compile;
        procedure  Run;
        function   GetLastErrorString: string;
        procedure  InitCompileData;
        destructor Destroy;
    end;
    TCSExec = class(TObject)
        public
        //2004-4-21 以下绝大部分数据就是要封装为执行期间的数据
                psout,prd,prr : Text;
                stantyps: typset;

                rconst  :   array [1..c2max] of real;
                btab    :   array [1..bmax]  of packed record //block - table
                   last,lastpar,psize,vsize:index
                end;

                stab : packed array [0..smax ] of char;   {string table}//not reasonable
                atab: array [1..amax] of  packed record   {array - table}
                    inxtyp,eltyp: types;
                    elref,low,high,elsize,size: index
                end;

                tab : array [0..tmax ] of packed record
                   name: alfa;
                   link: index;
                   obj:xobject;
                   typ: types;
                   ref: index;
                   normal: boolean;
                   lev: 0..lmax;
                   adr: integer;
                end;
                code  : array [0..cmax] of order;

            procedure   Execute;

    end;

implementation








procedure TCSCompiler.enter(x0:alfa; x1: xobject;
                     x2: types; x3: integer);
     begin
        t:= t+1;
        with tab[t] do
        begin