Пример 1. Сканер

(**************************************)
(*        Данные для сканера          *)
(**************************************)
const ExprLen = 240;
Type LexEnum  = (LexKeyword, LexNames, LexNumber, LexSpecs, LexExpr);
     SpecEnum = (SemiColn, Comma, Assign);
var LexType : LexEnum;
    LexVal : integer;
      (* Буфер для кое-чего в квадратных скобках *)
    Buf : string [ExprLen];
    EndStream, LogEOF : boolean;
      (* Буфер и указатель буфера
         строки входного файла*)
    LineBuf : string [81];
    LinePtr : integer;
      (* А вот здесь мы храним символ,
      от которого мы отказались
       с помощью функции UngetCh *)
    OldCh : char;
      (* True, если в OldCh что-то лежит*)
    Suspend : boolean;

procedure IniScan;
begin
    LineBuf := ' ';
    LinePtr := 1;
    Suspend :=False;
end;

(*
    Сканер. Оставляет в переменных
       LexType и LexVal.
    Нечто в квадратных скобках
      остается в буфере Buf.
    Функции Alpha (c) и  Num (c)
       равны True, если их аргумент
       буква или цифра соответственно.
*)
procedure Scan;
var Ch : char;
begin
    if Ch = ' ' then    (* Бог с Ним! *)
        else UngetCh;
    if EndStream then LogEOF := true  (* Конец файла! *)
        (* Встретили квадратную скобку - впереди выражение *)
    else if Ch = '['   then Brackets
        (* Впереди ключевое слово или переменная,
            а вот что неясно *)
    else if Alpha (Ch) then KeyOrNames
    else if Num   (Ch) then Numbers     (* Число!*)
    else if Ch = ';'   then Spech (SemiColn)
    else if Ch = ','   then Spech (Comma)
    else if Ch = ':'   then begin
        Ch := GetCh;
        Ch := GetCh;
        if Ch = '=' then Spech (Assign); (* := *)
    end;
end;

(*
    Сначала прочитать нечто алфавитно-цифровое,
    а потом уже разобраться, что это -
    ключевое слово или идентификатор
*)

procedure KeyOrNames;
var LexBuf : bloc;
    i,t : integer;
    Ch : char;
begin
    Ch := GetCh;
    i := 1;
    repeat
        LexBuf [i] := Ch;
        i := i+1;
        Ch := GetCh;
      until not (Alpha (Ch) or Num (Ch));
    LexBuf [0] := chr (i);
    UngetCh;
    t := Find (LexBuf);
    if KeyEntry (t) then begin
        LexType := LexKeyword;
        LexVal  := t;
    end else if t  0 then begin
        LexType := LexNames;
        Lexal := t;
    end else begin
        LexVal := LexNames;
        t := PutIn (LexBuf);
    end;
end;

(* Считать число *)
procedure Numbers;
    Count : integer;
    Ch : char;
begin
    Ch := GetCh;
    Count := 0;
    repeat
        Count := 10*Count + (ord (Ch)-ord ('0'));
        Ch := GetCh;
      until not Num (Ch);
    UngetCh;
    LexType := LexNumber;
    LexVal := Counter;
end;

(* Установить переменные LexType и LexVal
    для спецсимволов *)
procedure Spech (Sym : EnumSpec);
begin
    LexType := LexSpecs;
    LexVal  := ord (Sym);
end;

( Нечто в квадратных скобках **)
procedure Brackets;
var  Ch : char;
     i  : integer;
begin
    Ch := GetCh;
    Ch := GetCh;
    i := 1;
    while Ch  ']' do
    begin
        Buf [i] := Ch;
        Ch := GetCh;
        i := i+1;
    end;
    Buf [0] := chr (i-1);
    LexType := LexExpr;
end;

(* Вспомогательные подпрограммы для сканера *)
Function GetCh : char;
var i  : integer;
    Ch : char;
begin
    if Suspend then begin
        GetCh := OldCh;
        Suspend := False;
      end
   else repeat
       if LinePtr>legth (LineBuf) begin
           Ch := ' ';
           NewLine;
       end else begin
           Ch := LineBuf [LinePtr];
           LinePtr := LinePtr+1;
       end;
     until ((Ch' ') and (Chchr (Tab))) or Eof (SRC);
   if Eof (SRC) then EndStream := 1;
end;

procedure UngetCh;
begin
    Suspend :=True;
end;

procedure NewLine;
begin
    ReadLn (LineBuf);
    if Eof (SRC) then LinePtr := 1;
    LinePtr := 1;
end;