ucscompiler.pas

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

            name:= x0; link := t - 1 ; obj := x1;
            typ := x2; ref := 0;   normal:= true;
            lev := 0;  adr := x3;
        end
     end;  //enter

procedure TCSCompiler.enterarray(tp:types;L,H: integer);
     begin
        if l>h then    CCLex.error(27);
        if (abs(l)> xmax) or (abs(h)> xmax)
        then begin
            cclex.error(27); l:= 0; h := 0;
            end;
            if a=amax
            then cclex.fatal(4)
            else begin
                a:= a+1;
                with atab[a] do
                begin
                    inxtyp := tp; low:= l; high:= h;
                end
            end
     end;//enterarray

procedure TCSCompiler.enterblock;
begin
        if b= bmax
        then cclex.fatal(2)
        else begin
            b:= b+1; btab[b].last :=0; btab[b].lastpar:=0
        end
end;//enterblock

procedure TCSCompiler.enterreal(x:real);
     begin
        if c2 = c2max - 1
        then cclex.fatal(3)
        else begin
            rconst[c2+1]:= x; c1 :=  1;
            while rconst[c1] <> x do c1 := c1 + 1;
            if c1 > c2 then c2 := c1;
        end
     end;//enterreal

procedure TCSCompiler.emit(FCT: integer);
     begin
        if lc= cmax then
            cclex.fatal(6);
        code[lc].f := fct; lc := lc + 1;
     end;//emit

     procedure TCSCompiler.emit1(FCT,B: integer);
     begin
       if lc = cmax then CCLex.fatal(6);
       with code[lc] do
       begin
         f:= fct; y:= b;
       end;
       lc := lc + 1;
     end;//emit1

     procedure TCSCompiler.emit2(FCT,A,B:integer);
     begin
        if lc= cmax then CCLex.fatal(6);
        with code[lc] do
        begin
            f:= fct; x:= a; y:=b ;
        end;
        lc:= lc+1;
     end;//emit2

     procedure TCSCompiler.Printtables;
     var i: integer;
         o: order;
         mne: array [0..omax] of string;//modify by zhangyong
            //packed array[1..5] of char;
     begin
        mne[0]:= 'LDA ';    mne[1]:= 'LOD '; mne[2]:= 'LDI ';//??
        mne[3]:= 'DIS ';    mne[8]:= 'FCT '; mne[9]:= 'INT ';
        mne[10]:= 'JMP ';    mne[11]:= 'JPC '; mne[12]:= 'SWT ';
        mne[13]:= 'CAS ';    mne[14]:= 'F1U '; mne[15]:= 'F2U ';
        mne[16]:= 'F1D ';    mne[17]:= 'F2D '; mne[18]:= 'MKS ';
        mne[19]:= 'CAL ';    mne[20]:= 'IDX '; mne[21]:= 'IXX ';
        mne[22]:= 'LDB ';    mne[23]:= 'CPB '; mne[24]:= 'LDC ';
        mne[25]:= 'LDR ';    mne[26]:= 'FLT '; mne[27]:= 'RED ';
        mne[28]:= 'WRS ';    mne[29]:= 'WRW '; mne[30]:= 'WRU ';
        mne[31]:= 'HLT ';    mne[32]:= 'EXP '; mne[33]:= 'EXF ';
        mne[34]:= 'LDT ';    mne[35]:= 'NOT '; mne[36]:= 'MUS ';
        mne[37]:= 'WRR ';    mne[38]:= 'STO '; mne[39]:= 'EQR ';
        mne[40]:= 'NER ';    mne[41]:= 'LSR '; mne[42]:= 'LER ';
        mne[43]:= 'GTR ';    mne[44]:= 'GER '; mne[45]:= 'EQL ';
        mne[46]:= 'NEQ ';    mne[47]:= 'LSS '; mne[48]:= 'LEQ ';
        mne[49]:= 'GRT ';    mne[50]:= 'GEQ '; mne[51]:= 'ORR ';
        mne[52]:= 'ADD ';    mne[53]:= 'SUB '; mne[54]:= 'ADR ';
        mne[55]:= 'SUR ';    mne[56]:= 'AND '; mne[57]:= 'MUL ';
        mne[58]:= 'DIV ';    mne[59]:= 'MOD '; mne[60]:= 'MUR ';
        mne[61]:= 'DIR ';    mne[62]:= 'RDL '; mne[63]:= 'WRL ';

        writeln(psout); writeln(psout); writeln(psout);
        writeln(psout,'    identifiers  link   obj typ   ref nrm lev adr');
        writeln(psout);
        for i:= btab[1].last to t do
            with tab[i] do
                writeln(psout,i,' ',name,link:5,ord(obj):5,ord(typ):5,ref:5,
                    ord(normal):5,lev:5,adr:5);
                writeln(psout); writeln(psout);writeln(psout);

                writeln(psout,'blocks  last  lpar  psze  vsze ');
                writeln(psout);
                for i:=1 to b do
                    with btab[i] do
                        writeln(psout,i:4,last:9,lastpar:5,psize:5,vsize:5);
                writeln(psout);writeln(psout);writeln(psout);
                writeln(psout,'arrays xtyp etyp eref low high elsz size');
                writeln(psout);
                for i:=1 to a do
                    with atab[i] do
                      writeln(psout,i:4,ord(inxtyp):9,ord(eltyp):5,
                            elref:5,low:5,high:5,elsize:5,size:5);
                      writeln(psout);writeln(psout);writeln(psout);
                      writeln(psout,' code:'); writeln(psout);
                for i:= 0 to lc -1 do
                begin
                    write(psout,I:5);
                    o := code[i]; write(psout,mne[o.f]:8,o.f:5);
                    if o.f < 31
                    then if o.f<4
                        then write(psout,o.x:5,o.y:5)
                        else write(psout,o.y:10)
                    else write(psout,'           ');
                    writeln(psout,',');
                end;
                writeln(psout);
                writeln(psout,'Starting address is ',tab[btab[1].last].adr:5);//???
     end;//printtables

    procedure TCSCompiler.block(fsys: symset; isfun:boolean; level: integer);
    type    conrec = record case tp:types of
                    ints,chars,bools:(i:integer);
                    reals:(r:real)
            end;
    var dx:integer ;
        prt:integer;//??
        prb:integer;//??
        x: integer;

            procedure skip(fsys: symset; n:integer);
            begin
                CCLex.error(n); CCLex.skipflag:= true;
                while not (CCLex.sy in fsys) do CCLex.Insymbol;
                if CCLex.skipflag then CCLex.endskip
            end;

            procedure test(s1,s2: symset; n:integer);
            begin
                if not (CCLex.sy in s1) then
                 skip(s1+s2,n)
            end;

            procedure testsemicolon;
            begin
                if CCLex.sy= semicolon
                then CCLex.Insymbol
                else begin
                    CCLex.error(14);
                    if CCLex.sy in [comma,colon] then CCLex.Insymbol
                end;
                test([ident]+blockbegsys,fsys,6);
            end;
            procedure enter(id: alfa; k: xobject);
            var j,l:integer;
            begin
                if t= tmax
                then CCLex.fatal(1)
                else begin
                    tab[0].name:= id;
                    j:= btab[display[level]].last; l:= j;
                    while tab[j].name <> id do j:= tab[j].link;
                    if j<>0    then
                      CCLex.error(1)
                    else begin
                        t:= t+1;
                        with tab[t] do
                        begin
                            name:= id;  link:=l;
                            obj:= k; typ:= notyp; ref:= 0;
                            lev := level; adr:= 0; normal:= false //inital value
                        end;
                        btab[display[level]].last:= t
                        end
                    end
                end;//enter
            function loc(id: alfa):integer;
            var  i,j:integer;
            begin
                i:= level; tab[0].name:= id;
                repeat
                    j:= btab[display[i]].last;
                    while tab[j].name<>id do j := tab[j].link;
                    i:= i -1;
                until (i<0) or (j<>0);
                if j=0 then CCLex.error(0);
                loc:= j
            end;//loc

            procedure entervariable;
            begin
                if CCLex.sy = ident
                then begin
                    enter(id,vvariable); CCLex.Insymbol
                end else CCLex.error(2)
            end;//entervariable

            procedure constant(fsys: symset; var c:conrec); //处理常量
            var     x,sign: integer;
            begin
                c.tp:= notyp; c.i:= 0;
                test(constbegsys,fsys,50);
                if CCLex.sy in constbegsys
                then begin
                    if CCLex.sy = charcon
                    then begin
                      c.tp := chars; c.i:= inum;
                      CCLex.Insymbol
                end else
                begin
                    sign:= 1;
                    if CCLex.sy in [plus,minus]
                    then begin
                    if CCLex.sy= minus then sign := -1;
                    CCLex.Insymbol
                    end;
                    if CCLex.sy = ident
                    then begin
                        x:= loc(id);
                        if x<>0
                        then if tab[x].obj<>konstant
                            then CCLex.error(25)
                            else begin
                                c.tp := tab[x].typ;
                                if c.tp = reals
                                then c.r := sign*rconst[tab[x].adr]
                                else c.i := sign *tab[x].adr
                            end;
                        CCLex.Insymbol
                    end else if CCLex.sy = intcon

                        then begin
                            c.tp := ints; c.i:= sign*inum;
                            CCLex.Insymbol
                        end else if CCLex.sy= realcon
                                 then begin
                                    c.tp := reals; c.r := sign* CCLex.rnum;
                                    CCLex.Insymbol
                                 end else skip(fsys,50)
                    end;
                    test(fsys,[],6)
                end
            end;//constant

            procedure typ(fsys:symset;var tp:types;var rf,sz:integer);
            var eltp : types;
                elrf,x: integer;
                elsz,offset, t0,t1: integer;

                    procedure arraytyp(var aref,arsz:integer);
                    var eltp : types;
                        low,high:conrec;
                        elrf,elsz: integer;
                    begin//arraytyp
                        constant([colon,rbrack,rparent,ofsy]+fsys,low);
                        if low.tp =reals
                        then begin
                            CCLex.error(27);
                            low.tp := ints; low.i := 0
                        end;
                        if CCLex.sy= colon then CCLex.Insymbol else CCLex.error(13);
                        constant([rbrack,comma,rparent,ofsy]+fsys,high);
                        if high.tp <>low.tp
                        then begin
                            CCLex.error(27); high.i:= low.i
                        end;
                        enterarray(low.tp,low.i,high.i);
                        aref:= a;
                        if CCLex.sy=comma
                        then begin
                            CCLex.Insymbol;
                            eltp:= arrays;
                            arraytyp(elrf,elsz)
                        end else begin
                            if CCLex.sy = rbrack