psvpas.pas

PIC 单片机 PAS SOURCE CODE SAMPLES

begin
  if KeyComp('String') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func88: TtkTokenKind;
begin
  if KeyComp('Program') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func91: TtkTokenKind;
begin
  if KeyComp('Downto') then Result := tkKey else
    if KeyComp('Private') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func92: TtkTokenKind;
begin
  if KeyComp('Inherited') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func94: TtkTokenKind;
begin
  if KeyComp('Assembler') then Result := tkKey else
    if KeyComp('Readonly') then
    begin
      if fRange = rsProperty then Result := tkKey else Result := tkIdentifier;
    end else Result := tkIdentifier;
end;

function TpsvPasRTF.Func95: TtkTokenKind;
begin
  if KeyComp('Absolute') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func96: TtkTokenKind;
begin
  if KeyComp('Published') then Result := tkKey else
    if KeyComp('Override') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func97: TtkTokenKind;
begin
  if KeyComp('Threadvar') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func98: TtkTokenKind;
begin
  if KeyComp('Export') then Result := tkKey else
    if KeyComp('Nodefault') then
    begin
      if fRange = rsProperty then Result := tkKey else Result := tkIdentifier;
    end else Result := tkIdentifier;
end;

function TpsvPasRTF.Func99: TtkTokenKind;
begin
  if KeyComp('External') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func100: TtkTokenKind;
begin
  if KeyComp('Automated') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func101: TtkTokenKind;
begin
  if KeyComp('Register') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func102: TtkTokenKind;
begin
  if KeyComp('Function') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func103: TtkTokenKind;
begin
  if KeyComp('Virtual') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func105: TtkTokenKind;
begin
  if KeyComp('Procedure') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func106: TtkTokenKind;
begin
  if KeyComp('Protected') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func117: TtkTokenKind;
begin
  if KeyComp('Exports') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func126: TtkTokenKind;
begin
  Result := tkIdentifier;
end;

function TpsvPasRTF.Func129: TtkTokenKind;
begin
  if KeyComp('Dispinterface') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func132: TtkTokenKind;
begin
  Result := tkIdentifier;
end;

function TpsvPasRTF.Func133: TtkTokenKind;
begin
  if KeyComp('Property') then
  begin
    Result := tkKey;
    fRange := rsProperty;
  end else Result := tkIdentifier;
end;

function TpsvPasRTF.Func136: TtkTokenKind;
begin
  if KeyComp('Finalization') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func141: TtkTokenKind;
begin
  if KeyComp('Writeonly') then
  begin
    if fRange = rsProperty then Result := tkKey else Result := tkIdentifier;
  end else Result := tkIdentifier;
end;

function TpsvPasRTF.Func143: TtkTokenKind;
begin
  if KeyComp('Destructor') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func166: TtkTokenKind;
begin
  if KeyComp('Constructor') then Result := tkKey else
    if KeyComp('Implementation') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func168: TtkTokenKind;
begin
  if KeyComp('Initialization') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.Func191: TtkTokenKind;
begin
  if KeyComp('Resourcestring') then Result := tkKey else
    if KeyComp('Stringresource') then Result := tkKey else Result := tkIdentifier;
end;

function TpsvPasRTF.AltFunc: TtkTokenKind;
begin
  Result := tkIdentifier
end;

function TpsvPasRTF.IdentKind(MayBe: PChar): TtkTokenKind;
var
  HashKey: Integer;
begin
  fToIdent := MayBe;
  HashKey := KeyHash(MayBe);
  if HashKey < 192 then Result := fIdentFuncTable[HashKey] else
    Result := tkIdentifier;
end;

procedure TpsvPasRTF.MakeMethodTables;
var
  I: Char;
begin
  for I := #0 to #255 do
    case I of
      #0: fProcTable[I] := NullProc;
      #10: fProcTable[I] := LFProc;
      #13: fProcTable[I] := CRProc;
      #1..#9, #11, #12, #14..#32:
        fProcTable[I] := SpaceProc;
      '#': fProcTable[I] := AsciiCharProc;
      '$': fProcTable[I] := IntegerProc;
      #39: fProcTable[I] := StringProc;
      '0'..'9': fProcTable[I] := NumberProc;
      'A'..'Z', 'a'..'z', '_':
        fProcTable[I] := IdentProc;
      '{': fProcTable[I] := BraceOpenProc;
      '}', '!', '"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~':
        begin
          case I of
            '(': fProcTable[I] := RoundOpenProc;
            '.': fProcTable[I] := PointProc;
            ';': fProcTable[I] := SemicolonProc;
            '/': fProcTable[I] := SlashProc;
            ':', '>': fProcTable[I] := ColonOrGreaterProc;
            '<': fProcTable[I] := LowerProc;
            '@': fProcTable[I] := AddressOpProc;
          else
            fProcTable[I] := SymbolProc;
          end;
        end;
    else
      fProcTable[I] := UnknownProc;
    end;
end;

constructor TpsvPasRTF.Create;
begin
  inherited Create;
  InitIdent;
  MakeMethodTables;
  fRange := rsUnknown;
  fAsmStart := False;
  CreateColorTable([clBlue,   //1  Comment
                    clBlack,  //2  Identifier
                    clBlack,  //3  Key
                    clBlack,  //4  Number
                    clNavy,   //5  Space
                    clBlack,  //6  String
                    clBlack,  //7  Symbol
                    clGreen]); //8 Unknown
end; { Create }

procedure TpsvPasRTF.SetLine(NewValue: string; LineNumber:Integer);
begin
  fLine := PChar(NewValue);
  Run := 0;
  fLineNumber := LineNumber;
  Next;
end; { SetLine }

procedure TpsvPasRTF.AddressOpProc;
begin
  fTokenID := tkSymbol;
  inc(Run);
  if fLine[Run] = '@' then inc(Run);
end;

procedure TpsvPasRTF.AsciiCharProc;
begin
  fTokenID := tkString;
  inc(Run);
  while FLine[Run] in ['0'..'9'] do inc(Run);
end;

procedure TpsvPasRTF.BorProc;
begin
  case fLine[Run] of
     #0: NullProc;
    #10: LFProc;
    #13: CRProc;
    else begin
      fTokenID := tkComment;
      repeat
        if fLine[Run] = '}' then begin
          Inc(Run);
          if fRange = rsBorAsm then
            fRange := rsAsm
          else
            fRange := rsUnKnown;
          break;
        end;
        Inc(Run);
      until fLine[Run] in [#0, #10, #13];
    end;
  end;
end;

procedure TpsvPasRTF.BraceOpenProc;
begin
  if fRange = rsAsm then
    fRange := rsBorAsm
  else
    fRange := rsBor;
  BorProc;
end;

procedure TpsvPasRTF.ColonOrGreaterProc;
begin
  fTokenID := tkSymbol;
  inc(Run);
  if fLine[Run] = '=' then inc(Run);
end;

procedure TpsvPasRTF.CRProc;
begin
  fTokenID := tkSpace;
  inc(Run);
  if fLine[Run] = #10 then inc(Run);
end;

procedure TpsvPasRTF.IdentProc;
begin
  fTokenID := IdentKind((fLine + Run));
  inc(Run, fStringLen);
  while Identifiers[fLine[Run]] do inc(Run);
end;

procedure TpsvPasRTF.IntegerProc;
begin
  inc(Run);
  fTokenID := tkNumber;
  while FLine[Run] in ['0'..'9', 'A'..'F', 'a'..'f'] do inc(Run);
end;

procedure TpsvPasRTF.LFProc;
begin
  fTokenID := tkSpace;
  inc(Run);
end;

procedure TpsvPasRTF.LowerProc;
begin
  fTokenID := tkSymbol;
  inc(Run);
  if fLine[Run] in ['=', '>'] then inc(Run);
end;

procedure TpsvPasRTF.NullProc;
begin
  fTokenID := tkNull;
end;

procedure TpsvPasRTF.NumberProc;
begin
  inc(Run);
  fTokenID := tkNumber;
  while FLine[Run] in ['0'..'9', '.', 'e', 'E'] do
  begin
    case FLine[Run] of
      '.':
        if FLine[Run + 1] = '.' then break;
    end;
    inc(Run);
  end;
end;

procedure TpsvPasRTF.PointProc;
begin
  fTokenID := tkSymbol;
  inc(Run);
  if fLine[Run] in ['.', ')'] then inc(Run);
end;

procedure TpsvPasRTF.AnsiProc;
begin
  case fLine[Run] of
     #0: NullProc;
    #10: LFProc;
    #13: CRProc;
  else
    fTokenID := tkComment;
    repeat
      if (fLine[Run] = '*') and (fLine[Run + 1] = ')') then begin
        Inc(Run, 2);
        if fRange = rsAnsiAsm then
          fRange := rsAsm
        else
          fRange := rsUnKnown;
        break;
      end;
      Inc(Run);
    until fLine[Run] in [#0, #10, #13];
  end;
end;

procedure TpsvPasRTF.RoundOpenProc;
begin
  Inc(Run);
  case fLine[Run] of
    '*':
      begin
        Inc(Run);
        if fRange = rsAsm then
          fRange := rsAnsiAsm
        else
          fRange := rsAnsi;
        fTokenID := tkComment;
        if not (fLine[Run] in [#0, #10, #13]) then
          AnsiProc;
      end;
    '.':
      begin
        inc(Run);
        fTokenID := tkSymbol;
      end;
  else
    fTokenID := tkSymbol;
  end;
end;

{begin}
procedure TpsvPasRTF.SemicolonProc;
begin
  Inc(Run);
  fTokenID := tkSymbol;
  if fRange = rsProperty then
    fRange := rsUnknown;
end;
{end}                                                                           

procedure TpsvPasRTF.SlashProc;
begin
  Inc(Run);
  if fLine[Run] = '/' then begin
    fTokenID := tkComment;
    repeat
      Inc(Run);
    until fLine[Run] in [#0, #10, #13];
  end else
    fTokenID := tkSymbol;
end;

procedure TpsvPasRTF.SpaceProc;
begin
  inc(Run);
  fTokenID := tkSpace;
  while FLine[Run] in [#1..#9, #11, #12, #14..#32] do inc(Run);
end;

procedure TpsvPasRTF.StringProc;
begin
  fTokenID := tkString;
  Inc(Run);
  while not (fLine[Run] in [#0, #10, #13]) do begin
    if fLine[Run] = #39 then begin
      Inc(Run);
      if fLine[Run] <> #39 then
        break;
    end;
    Inc(Run);
  end;
end;

procedure TpsvPasRTF.SymbolProc;
begin
  inc(Run);
  fTokenID := tkSymbol;
end;

procedure TpsvPasRTF.UnknownProc;
begin
  inc(Run);
  fTokenID := tkUnknown;
end;

procedure TpsvPasRTF.Next;
begin
  fAsmStart := False;
  fTokenPos := Run;
  case fRange of
    rsAnsi, rsAnsiAsm:
      AnsiProc;
    rsBor, rsBorAsm:
      BorProc;
  else
    fProcTable[fLine[Run]];
  end;
end;


function TpsvPasRTF.GetEol: Boolean;
begin
  Result := fTokenID = tkNull;
end;

function TpsvPasRTF.GetToken: string;
var
  Len: LongInt;
begin
  Len := Run - fTokenPos;
  SetString(Result, (FLine + fTokenPos), Len);
end;

function TpsvPasRTF.GetTokenID: TtkTokenKind;
begin
  if not fAsmStart and (fRange = rsAsm)
    and not (fTokenId in [tkNull, tkComment, tkSpace])
  then
    Result := tkAsm
  else
    Result := fTokenId;
end;

function TpsvPasRTF.GetTokenAttribute: integer;
begin
  case GetTokenID of
    tkAsm: Result := 9;
    tkComment: Result := 1;
    tkIdentifier: Result := 2;
    tkKey: Result := 3;
    tkNumber: Result := 4;
    tkSpace: Result := 5;
    tkString: Result := 6;
    tkSymbol: Result := 7;
    tkUnknown: Result := 8;
  else
    Result := 9;
  end;
end;

function TpsvPasRTF.GetTokenKind: integer;
begin
  Result := Ord(GetTokenID);
end;

function TpsvPasRTF.GetTokenPos: Integer;
begin
  Result := fTokenPos;
end;

function TpsvPasRTF.GetRange: Pointer;
begin
  Result := Pointer(fRange);
end;

procedure TpsvPasRTF.SetRange(Value: Pointer);
begin
  fRange := TRangeState(Value);
end;

procedure TpsvPasRTF.ResetRange;
begin
  fRange:= rsUnknown;
end;



procedure TpsvPasRTF.PrepareToken(var AToken : string);
var St : string;
begin
  St := AToken;
  St := StringReplace(St,'\','\\',[rfReplaceAll]);
  St := StringReplace(St,'{','\{',[rfReplaceAll]);
  St := StringReplace(St,'}','\}',[rfReplaceAll]);
  AToken := St;
end;

function TpsvPasRTF.PrepareOutput(Attr: integer; AToken : string): string;
begin
  case Attr of 
    1 : Result  := '\cf1 \i '+ AToken +'\i0 ';
    3 : Result  := '\cf3 \b '+ AToken +'\b0 ';
  else
   Result := Format('\cf%d %s',[Attr,AToken]);
  end;
end;

procedure TpsvPasRTF.SetupDefaultColors;
begin
  CreateColorTable([clBlue,   //1  Comment
                    clBlack,  //2  Identifier
                    clBlack,  //3  Key
                    clBlack,  //4  Number
                    clNavy,   //5  Space
                    clBlack,  //6  String
                    clBlack,  //7  Symbol
                    clGreen]); //8 Unknown
end;

initialization
  MakeIdentTable;


end.