untcompile.pas

运用delphi编写的小型解释器

         ocMul: begin
                v1 := Stack.Pop;
                v2 := Stack.Pop;
                Stack.Put(v2 * v1);
                end;

         ocDiv: begin
                v1 := Stack.Pop;
                v2 := Stack.Pop;
                Stack.Put(v2 / v1);
                end;

         ocEqual: begin
                  v1 := Stack.Pop;
                  v2 := Stack.Pop;
                  Stack.Put(v1 = v2);
                  end;

         ocGreater: begin
                    v2 := Stack.Pop;
                    v1 := Stack.Pop;
                    Stack.Put(v1 > v2);
                    end;

         ocGreaterEqual: begin
                         v2 := Stack.Pop;
                         v1 := Stack.Pop;
                         Stack.Put(v1 >= v2);
                         end;

         ocLess: begin
                 v2 := Stack.Pop;
                 v1 := Stack.Pop;
                 Stack.Put(v1 < v2);
                 end;

         ocLessEqual: begin
                      v2 := Stack.Pop;
                      v1 := Stack.Pop;
                      Stack.Put(v1 <= v2);
                      end;

         ocNotEqual: begin
                     v2 := Stack.Pop;
                     v1 := Stack.Pop;
                     Stack.Put(v1 <> v2);
                     end;

         ocIfFalseGoto: begin
                        v2 := Stack.Pop;
                        if not v2 then
                            begin
                            i := p2;
                            continue;
                            end;

                        end;

         ocGoto: begin
                 i := p2;
                 continue; 
                 end;

           else raise Exception.Create('未知命令！');
         end;

    Inc(i);

    end;

end;

function TCompile.getPCode: string;
begin
  Result := FProgList.getText;
end;

function TCompile.getConsts: string;
begin
  Result := FConsts.getText;
end;

function TCompile.ProcDef: integer;
var
  aProcName: string;
  aIdent, rIdent: TIdent;
  astr: string;
begin
  getIdentifier;

  aProcName := FCurToken.Data;

  aIdent := FVariables.Add(aProcName);

  aIdent.FIdentType := itFunction;

  if NextToken.ID = idOpenbracket then
      begin
      getOpenBracket;
      ProcParam(aProcName);
      getCloseBracket;
      end;

  if NextToken.id = id2points then
    begin
    ReadToken;

    getVarType;

    rIdent := FVariables.Add(genVarName(aProcName, 'Result'));
    rIdent.DataType := FCurToken.Data;
    end;

  getDelimeter;

  Result := aIdent.ID;
end;

procedure TCompile.ProcParam(aProcName: string);
var
  i, j: integer;
  pIdent, vIdent: TIdent;
begin
  pIdent := FVariables.getIdentByName(aProcName);
  
  while true do
    begin
    ReadToken;

    if FCurToken.ID <> idIdentifier then raiseError('期望变量！');

    if FVariables.IndexOf(genVarName(aProcName, FCurToken.Data)) >= 0 then raiseError(FCurToken.data + '变量重复声明！');

    i := FVariables.Count;

    vIdent := FVariables.Add(genVarName(aProcName, FCurToken.Data));

    pIdent.AddParam(vIdent);
    
    while NextToken.ID = idComma do
        begin
        ReadToken;

        ReadToken;

        if FCurToken.ID <> idIdentifier then raiseError('期望变量！');
        if FVariables.IndexOf(genVarName(aProcName, FCurToken.Data)) >= 0 then raiseError(FCurToken.data + '变量重复声明！');

        vIdent := FVariables.Add(genVarName(aProcName, FCurToken.Data));

        pIdent.AddParam(vIdent);
        end;

    if NextToken.ID = id2Points then
        begin
        ReadToken;
        getVarType;

        for j := i to FVariables.Count - 1 do
            begin
            FVariables.Idents[j].FDataType := getDataType(FCurToken.Data);
            end;

        if NextToken.id <> idCloseBracket then getDelimeter;
        end;

    if (NextToken.ID <= idReservedEnd) and (NextToken.ID >= idReservedBase) then exit;
    end;

end;

function TCompile.genVarName(aPreFix, aName: string): string;
begin
  if aPreFix = '' then Result := aName
    else Result := aPreFix + '.' + aName;

end;

procedure TCompile.ProcBody(aID: integer);
var
  pIdent: TIdent;
begin
  pIdent := FVariables.getIdentByID(aID);

  Declarations(pIdent.Name);
  Statement(pIdent.Name);;
  
end;

function TCompile.getVariableByName(aName: string): TIdent;
var
  i, j, l, k: integer;
begin
  repeat
    i := FVariables.IndexOf(aName);
    if i >= 0 then
      begin
      Result := FVariables.getIdentByIndex(i);
      exit;
      end;

    l := Length(aName);
    
    for j := l downto 1 do
      begin
      if aName[j] = '.' then
           begin
           for k := j - 1 downto 1 do
             begin
             if aName[k] = '.' then break;
             end;

           if k = 0 then aName := RightStr(aName, l - j)
               else aName := LeftStr(aName, k) + RightStr(aName, l - j);

           break;
           end;
      end;

    if j = 0 then aName := '';

  until aName <> '';

end;

function TCompile.getVariableByName(aPreFix, aName: string): TIdent;
begin
  Result := getVariableByName(genVarName(aPreFix, aName));
end;

{ TWordList }

procedure TWordList.AddWord(aWordName: String; aWordID: integer);
begin
  FList.AddObject(aWordName, TObject(aWordID));
  Inc(FCount);
end;

constructor TWordList.Create;
begin
  FList := TStringList.Create;
  FList.CaseSensitive := false;

  FCount := 0;
end;

destructor TWordList.Destroy;
begin
  FreeAndNil(FList);
end;

function TWordList.GetWordID(aWordName: string): integer;
var
  i: integer;
begin
  Result := -1;

  for i := 0 to FList.Count - 1 do
    begin
    if SameText(FList.Strings[i], aWordName) then
        begin
        Result := Integer(FList.Objects[i]);
        exit;
        end;
    end;

  inherited;
end;

function TWordList.GetWordName(aWordID: integer): string;
var
  i: integer;
begin
  Result := '';

  for i := 0 to FList.Count do
    begin
    if Integer(FList.Objects[i]) = aWordID then
        begin
        Result := FList.Names[i];
        exit;
        end;
    end;

end;

{ TConsts }

function TDynaWords.AddWord(aWordName: String): integer;
begin
  Inc(FConstID);

  inherited AddWord(aWordName, FConstID);

  Result := FConstID; 
end;

constructor TDynaWords.Create;
begin
  inherited;
  FConstID := 0;
end;

{ TResWords }

procedure TResWords.AddWord(aWordName: String; aWordID: integer);
begin
  inherited;
end;

{ TResConsts }

procedure TResConsts.AddWord(aWordName: String; aWordID: integer);
begin
  inherited;
end;


{ TProgList }

constructor TProgList.Create;
begin
  setLength(FProgList, 100);
  FCount := 0;
end;

destructor TProgList.Destroy;
begin
  setLength(FProgList, 0);
  
  inherited;
end;

function TProgList.getText: string;
var
  i: integer;
  aStr: string;
begin
  Result := '';

  for i := 0 to FCount - 1 do
    begin
    aStr := getPCodeName(FProgList[i].Cmd);

    if Length(aStr) < 10 then aStr := aStr + DupeString(' ', 10 - Length(aStr));

    Result := Result + '[' + IntToStr(i) + ']' + aStr + '  ' + 
              IntToStr(FProgList[i].P1) + ', ' + IntToStr(FProgList[i].P2) + #13#10;
    end;

end;

function TProgList.PutCode(aCmd, aP1, aP2: integer): integer;
begin
  if FCount >= Length(FProgList) then
    begin
    setLength(FProgList, FCount + 100);
    end;

  FProgList[FCount].Cmd := aCmd;
  FProgList[FCount].P1 := aP1;
  FProgList[FCount].P2 := aP2;

  Result := FCount;
  
  Inc(FCount);
end;

{ TIdent }

procedure TIdent.AddParam(aIdent: TIdent);
begin
  FParams.AddObject(aIdent.Name, aIdent);
  aIdent.OffPos := FParams.Count - 1;
  aIdent.DynaFlag := True;
end;

constructor TIdent.Create;
begin
  FParams := TStringList.Create;
  FDynaFlag := false;
end;

destructor TIdent.Destroy;
begin
  FreeAndNil(FParams);

  inherited;
end;

{ TIdentList }

function TIdentList.Add(aName: string; aID: Integer): TIdent;
begin
  if FCount >= Length(FIdents) then
      begin
      setLength(FIdents, FCount + 30);
      end;

  FIdents[FCount] := TIdent.Create;
  FIdents[FCount].Name := aName;
  FIdents[FCount].ID := aID;

  Result := FIdents[FCount];
  
  Inc(FCount);
end;

constructor TIdentList.Create;
begin
  FCount := 0;
  setLength(FIdents, 30);
end;

destructor TIdentList.Destroy;
begin
  FCount := 0;
  setLength(FIdents, 0);
  
  inherited;
end;

function TIdentList.getIdentByID(aID: integer): TIdent;
var
  i: integer;
begin
  for i := 0 to FCount - 1 do
    begin
    if FIdents[i].ID = aID then
         begin
         Result := FIdents[i];
         exit;
         end;
    end;

  raise Exception.Create('没有ID为' + IntToStr(aID) + '的变量！');

end;

function TIdentList.getIdentByIndex(aIndex: integer): TIdent;
begin

  if (aIndex < 0) or (aIndex >= FCount) then raise Exception.Create('索引超出范围！');

  Result := FIdents[aIndex];

end;

function TIdentList.getIdentByName(aName: String): TIdent;
var
  i: integer;
begin
  i := IndexOf(aName);

  if i < 0 then raise Exception.Create('没有名为' + aName + '的标识符！');

  Result := FIdents[i];
end;

function TIdentList.getText: string;
var
  i: integer;
  astr: string;
begin
  Result := '';

  for i := 0 to Count - 1 do
    begin
    if VarIsNull(FIdents[i].FValue) then astr := 'null'
      else astr := FIdents[i].FValue;

    Result := Result + '[' + IntToStr(i) + '] Name = ' + FIdents[i].FName +
              '; Value = ' + astr + '; ID = ' + IntToStr(FIdents[i].ID) +
              #13#10;
    end;

end;

function TIdentList.IndexOf(aName: string): integer;
var
  i: integer;
begin
  Result := -1;
  
  for i := 0 to FCount - 1 do
    begin
    if SameText(FIdents[i].Name, aName) then
         begin
         Result := i;
         exit;
         end;
    end;

end;

procedure TIdentList.SetValue(aID: integer; aValue: variant);
var
  i: integer;
begin
  for i := 0 to FCount - 1 do
    begin
    if FIdents[i].ID = aID then
        begin
        FIdents[i].Value := aValue;
        exit;
        end;
    end;

  raise Exception.Create('找不到ID为' + IntToStr(aID) + '变量！');

end;

{ TConstList }

function TConstList.Add(aName: string): TIdent;
begin
  Inc(FConstID);

  Result := inherited Add(aName, FConstID);
end;

constructor TConstList.Create;
begin
  inherited;

  FConstID := 0;
end;

{ TVariableList }

function TVariableList.Add(aName: string): TIdent;
begin
  Inc(FID);
  
  Result := inherited add(aName, FID);
end;

constructor TVariableList.Create;
begin
  FID := 0;
end;

{ TStack }

procedure TStack.Clear;
begin
  FCount := 0;
  setLength(FDatas, 30);  
end;

constructor TStack.Create;
begin
  setLength(FDatas, 100);
  FCount := 0;
end;

destructor TStack.Destroy;
begin
  setLength(FDatas, 0);
  
  inherited;
end;

function TStack.getData(aIndex: integer): variant;
begin
  if aIndex < 0 then raise Exception.Create('参数不应小于0!');
  if aIndex >= FCount then raise Exception.Create('参数大于堆栈上限!');

  Result := FDatas[aIndex];
end;

function TStack.Pop: variant;
begin
  if FCount = 0 then raise Exception.Create('堆栈下溢出!');

  Result := FDatas[FCount - 1];

  Dec(FCount);
end;

procedure TStack.Put(v: Variant);
begin
  if FCount >= Length(FDatas) then
    begin
    setLength(FDatas, FCount + 100);
    end;

  FDatas[FCount] := v;

  Inc(FCount);
end;

initialization
  ResWords := TResWords.Create;
  ResConsts := TResConsts.Create;
  Stack := TStack.Create;

  ResWords.AddWord('program', idProgram);
  ResWords.AddWord('label', idLabel);
  ResWords.AddWord('goto', idGoto);
  ResWords.AddWord('var', idVar);
  ResWords.AddWord('begin', idBegin);
  ResWords.AddWord('end', idEnd);;
  ResWords.AddWord('and', idAnd);
  ResWords.AddWord('or', idOr);
  ResWords.AddWord('xor', idXor);
  ResWords.AddWord('not', idNot);
  ResWords.AddWord('shl', idShl);
  ResWords.AddWord('shr', idShr);
  ResWords.AddWord('div', idDiv);
  ResWords.AddWord('mod', idMod);
  ResWords.AddWord('true', idTrue);
  ResWords.AddWord('false', idFalse);
  ResWords.AddWord('if', idIf);
  ResWords.AddWord('then', idThen);
  ResWords.AddWord('else', idElse);
  ResWords.AddWord('while', idWhile);
  ResWords.AddWord('repeat', idRepeat);
  ResWords.AddWord('until', idUntil);
  ResWords.AddWord('for', idFor);
  ResWords.AddWord('to', idTo);
  ResWords.AddWord('downto', idDownto);
  ResWords.AddWord('do', idDo);
  ResWords.AddWord('nil', idNil);
  ResWords.AddWord('null', idNull);
  ResWords.AddWord('Unitinit', idUnitinit);
  ResWords.AddWord('Unitfinal', idUnitfinal);
  ResWords.AddWord('class', idClass);
  ResWords.AddWord('type', idType);
  ResWords.AddWord('constr', idConstr);
  ResWords.AddWord('destr', idDestr);
  Reswords.AddWord('uses', idUses);
  ResWords.AddWord('unit', idUnit);
  ResWords.AddWord('interface', idInterface);
  ResWords.AddWord('implement', idImplement);
  ResWords.AddWord('procedure', idProcedure);
  ResWords.AddWord('private', idPrivate);
  ResWords.AddWord('public', idPublic);
  ResWords.AddWord('protected', idProtected);
  ResWords.AddWord('published', idPublished);
  ResWords.AddWord('function', idFunction);
  ResWords.AddWord('const', idConst);
  ResWords.AddWord('property', idProperty);
  ResWords.AddWord('virtual', idVirtual);
  ResWords.AddWord('override', idOverride);
  ResWords.AddWord('dynamic', idDynamic);
  ResWords.AddWord('record', idRecord);
  ResWords.AddWord('forward', idForward);
  ResWords.AddWord('index', idIndex);
  ResWords.AddWord('read', idRead);
  ResWords.AddWord('write', idWrite);
  ResWords.AddWord('stored', idStored);
  ResWords.AddWord('default', idDefault);
  ResWords.AddWord('abstract', idAbstract);
  ResWords.AddWord('stdcall', idStdcall);



finalization
  FreeAndNil(ResWords);
  FreeAndNil(ResConsts);
  
end.