tvhc.pas

还是一个词法分析程序

      True:  (Value: Word);
      False: (FixUpList: PFixUp);
  end;

  PRefTable = ^TRefTable;
  TRefTable = object(TSortedCollection)
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    procedure FreeItem(Item: Pointer); virtual;
    function GetReference(var Topic: String): PReference;
    function KeyOf(Item: Pointer): Pointer; virtual;
  end;

const
  RefTable: PRefTable = nil;

procedure DisposeFixUps(P: PFixUp);
var
  Q: PFixUp;
begin
  while P <> nil do
  begin
    Q := P^.Next;
    Dispose(P);
    P := Q;
  end;
end;

{----- TRefTable -------------------------------------------------------}
{  TRefTable is a collection of PReference's used as a symbol table.    }
{  If the topic has not been seen, a forward reference is inserted and  }
{  a fix-up list is started.  When the topic is seen all forward        }
{  references are resolved.  If the topic has been seen already the     }
{  value it has is used.                                                }
{-----------------------------------------------------------------------}

function TRefTable.Compare(Key1, Key2: Pointer): Integer;
var
  K1,K2: String;
begin
  K1 := UpStr(PString(Key1)^);
  K2 := UpStr(PString(Key2)^);
  if K1 > K2 then Compare := 1
  else if K1 < K2 then Compare := -1
  else Compare := 0;
end;

procedure TRefTable.FreeItem(Item: Pointer);
var
  Ref: PReference absolute Item;
  P, Q: PFixUp;
begin
  if not Ref^.Resolved then DisposeFixUps(Ref^.FixUpList);
  DisposeStr(Ref^.Topic);
  Dispose(Ref);
end;

function TRefTable.GetReference(var Topic: String): PReference;
var
  Ref: PReference;
  I: Integer;
begin
  if Search(@Topic, I) then
    Ref := At(I)
  else
  begin
    New(Ref);
    Ref^.Topic := NewStr(Topic);
    Ref^.Resolved := False;
    Ref^.FixUpList := nil;
    Insert(Ref);
  end;
  GetReference := Ref;
end;

function TRefTable.KeyOf(Item: Pointer): Pointer;
begin
  KeyOf := PReference(Item)^.Topic;
end;

{----- InitRefTable ----------------------------------------------------}
{  Make sure the reference table is initialized.                        }
{-----------------------------------------------------------------------}

procedure InitRefTable;
begin
  if RefTable = nil then
    RefTable := New(PRefTable, Init(5,5));
end;

{----- RecordReference -------------------------------------------------}
{  Record a reference to a topic to the given stream.  This routine     }
{  handles forward references.                                          }
{-----------------------------------------------------------------------}

procedure RecordReference(var Topic: String; var S: TStream);
var
  I: Integer;
  Ref: PReference;
  FixUp: PFixUp;
begin
  InitRefTable;
  Ref := RefTable^.GetReference(Topic);
  if Ref^.Resolved then
    S.Write(Ref^.Value, SizeOf(Ref^.Value))
  else
  begin
    New(FixUp);
    FixUp^.Pos := S.GetPos;
    I := -1;
    S.Write(I, SizeOf(I));
    FixUp^.Next := Ref^.FixUpList;
    Ref^.FixUpList := FixUp;
  end;
end;

{----- ResolveReference ------------------------------------------------}
{  Resolve a reference to a topic to the given stream.  This routine    }
{  handles forward references.                                          }
{-----------------------------------------------------------------------}

procedure ResolveReference(var Topic: String; Value: Word; var S: TStream);
var
  I: Integer;
  Ref: PReference;

procedure DoFixUps(P: PFixUp);
var
  Pos: LongInt;
begin
  Pos := S.GetPos;
  while P <> nil do
  begin
    S.Seek(P^.Pos);
    S.Write(Value, SizeOf(Value));
    P := P^.Next;
  end;
  S.Seek(Pos);
end;

begin
  InitRefTable;
  Ref := RefTable^.GetReference(Topic);
  if Ref^.Resolved then
    Error('Redefinition of ' + Ref^.Topic^)
  else
  begin
    DoFixUps(Ref^.FixUpList);
    DisposeFixUps(Ref^.FixUpList);
    Ref^.Resolved := True;
    Ref^.Value := Value;
  end;
end;

{======================== Help file parser =============================}

{----- GetWord ---------------------------------------------------------}
{   Extract the next word from the given line at offset I.              }
{-----------------------------------------------------------------------}

function GetWord(var Line: String; var I: Integer): String;
var
  J: Integer;
const
  WordChars = ['A'..'Z','a'..'z','0'..'9','_'];

procedure SkipWhite;
begin
  while (I <= Length(Line)) and (Line[I] = ' ') or (Line[I] = #8) do
    Inc(I);
end;

procedure SkipToNonWord;
begin
  while (I <= Length(Line)) and (Line[I] in WordChars) do Inc(I);
end;

begin
  SkipWhite;
  J := I;
  if J > Length(Line) then GetWord := ''
  else
  begin
    Inc(I);
    if Line[J] in WordChars then SkipToNonWord;
    GetWord := Copy(Line, J, I - J);
  end;
end;

{----- TopicDefinition -------------------------------------------------}
{  Extracts the next topic definition from the given line at I.         }
{-----------------------------------------------------------------------}

type
  PTopicDefinition = ^TTopicDefinition;
  TTopicDefinition = object(TObject)
    Topic: PString;
    Value: Word;
    Next: PTopicDefinition;
    constructor Init(var ATopic: String; AValue: Word);
    destructor Done; virtual;
  end;

constructor TTopicDefinition.Init(var ATopic: String; AValue: Word);
begin
  Topic := NewStr(ATopic);
  Value := AValue;
  Next := nil;
end;

destructor TTopicDefinition.Done;
begin
  DisposeStr(Topic);
  if Next <> nil then Dispose(Next, Done);
end;

function TopicDefinition(var Line: String; var I: Integer): PTopicDefinition;
var
  J,K: Integer;
  TopicDef: PTopicDefinition;
  Value: Word;
  Topic, W: String;
  HelpNumber: Word;
const
  HelpCounter: Word = 2; {1 is hcDragging}
begin
  Topic := GetWord(Line, I);
  if Topic = '' then
  begin
    Error('Expected topic definition');
    TopicDefinition := nil;
  end
  else
  begin
    J := I;
    W := GetWord(Line, J);
    if W = '=' then
    begin
      I := J;
      W := GetWord(Line, I);
      Val(W, J, K);
      if K <> 0 then Error('Expected numeric')
      else
      begin
        HelpCounter := J;
        HelpNumber := J;
      end
    end
    else
      if not IsBuiltInContext(Topic, HelpNumber) then
      begin
        Inc(HelpCounter);
        HelpNumber := HelpCounter;
      end;
    TopicDefinition := New(PTopicDefinition, Init(Topic, HelpNumber));
  end;
end;

{----- TopicDefinitionList----------------------------------------------}
{  Extracts a list of topic definitions from the given line at I.       }
{-----------------------------------------------------------------------}

function TopicDefinitionList(var Line: String; var I: Integer):
  PTopicDefinition;
var
  J: Integer;
  W: String;
  TopicList, P: PTopicDefinition;
begin
  J := I;
  TopicList := nil;
  repeat
    I := J;
    P := TopicDefinition(Line, I);
    if P = nil then
    begin
      if TopicList <> nil then Dispose(TopicList, Done);
      TopicDefinitionList := nil;
      Exit;
    end;
    P^.Next := TopicList;
    TopicList := P;
    J := I;
    W := GetWord(Line, J);
  until W <> ',';
  TopicDefinitionList := TopicList;
end;

{----- TopicHeader -----------------------------------------------------}
{  Parse a the Topic header                                             }
{-----------------------------------------------------------------------}

const
  CommandChar = '.';

function TopicHeader(var Line: String): PTopicDefinition;
var
  I,J: Integer;
  W: String;
  TopicDef: PTopicDefinition;

begin
  I := 1;
  W := GetWord(Line, I);
  if W <> CommandChar then
  begin
    TopicHeader := nil;
    Exit;
  end;
  W := UpStr(GetWord(Line, I));
  if W = 'TOPIC' then
    TopicHeader := TopicDefinitionList(Line, I)
  else
  begin
    Error('TOPIC expected');
    TopicHeader := nil;
  end;
end;

{----- ReadParagraph ---------------------------------------------------}
{ Read a paragraph of the screen.  Returns the paragraph or nil if the  }
{ paragraph was not found in the given stream.  Searches for cross      }
{ references and updates the XRefs variable.                            }
{-----------------------------------------------------------------------}
type
  PCrossRefNode = ^TCrossRefNode;
  TCrossRefNode = record
    Topic: PString;
    Offset: Integer;
    Length: Byte;
    Next: PCrossRefNode;
  end;
const
  BufferSize = 4096;
var
  Buffer: array[0..BufferSize-1] of Byte;
  Ofs: Integer;

function ReadParagraph(var TextFile: TStream; var XRefs: PCrossRefNode;
 var Offset: Integer): PParagraph;
var
  Line: String;
  State: (Undefined, Wrapping, NotWrapping);
  P: PParagraph;

procedure CopyToBuffer(var Line: String; Wrapping: Boolean); assembler;
asm
        PUSH    DS
        CLD
        PUSH    DS
        POP     ES
        MOV     DI,OFFSET Buffer
        ADD     DI,Ofs
        LDS     SI,Line
        LODSB
        XOR     AH,AH
        ADD     ES:Ofs,AX
        XCHG    AX,CX
        REP     MOVSB
        XOR     AL,AL
        TEST    Wrapping,1      { Only add a #13, line terminator, if not }
        JE      @@1             { currently wrapping the text. Otherwise  }
        MOV     AL,' '-13       { add a ' '.                              }
@@1:    ADD     AL,13
@@2:    STOSB
        POP     DS
        INC     Ofs
end;

procedure AddToBuffer(var Line: String; Wrapping: Boolean);
begin
  if Length(Line) + Ofs > BufferSize - 1 then
    Error('Topic too large.')
  else
    CopyToBuffer(Line, Wrapping);
end;