(* AMIS search module *)	(* -*-Pascal-*- *)

(****************************************************************************)
(*									    *)
(*  Copyright (C) 1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987 by	    *)
(*  Stacken, Royal Institute Of Technology, Stockholm, Sweden.		    *)
(*  All rights reserved.						    *)
(* 									    *)
(*  This software is furnished under a license and may be used and copied   *)
(*  only in  accordance with  the  terms  of  such  license  and with the   *)
(*  inclusion of the above copyright notice. This software or  any  other   *)
(*  copies thereof may not be provided or otherwise made available to any   *)
(*  other person.  No title to and ownership of  the  software is  hereby   *)
(*  transferred.							    *)
(* 									    *)
(*  The information in this software is  subject to change without notice   *)
(*  and should not be construed as a commitment by Stacken.		    *)
(*									    *)
(*  Stacken assumes no responsibility for the use or reliability of its     *)
(*  software on equipment which is not supported by Stacken.                *)
(* 									    *)
(****************************************************************************)

(*$E+,T-*)			(* Compiler directives. *)

module Search;

const (* Common constant declarations for all AMIS modules. 1981-07-26 / JMR *)
  CtrlAtSign = 0;	    CtrlA = 1;		      CtrlB = 2;
  CtrlC = 3;		    CtrlD = 4;		      CtrlE = 5;
  CtrlF = 6;		    CtrlG = 7;		      CtrlH = 8;
  CtrlI = 9;		    CtrlJ = 10;		      CtrlK = 11;
  CtrlL = 12;		    CtrlM = 13;		      CtrlN = 14;
  CtrlO = 15;		    CtrlP = 16;		      CtrlQ = 17;
  CtrlR = 18;		    CtrlS = 19;		      CtrlT = 20;
  CtrlU = 21;		    CtrlV = 22;		      CtrlW = 23;
  CtrlX = 24;		    CtrlY = 25;		      CtrlZ = 26;
  CtrlLeftBracket = 27;     CtrlBackSlash = 28;	      CtrlRightBracket = 29;
  CtrlUpArrow = 30;	    CtrlUnderScore = 31;      RubOut = 127;

  Null = CtrlAtSign;	    Bell = CtrlG;	      BackSpace = CtrlH;
  HorizontalTab = CtrlI;    LineFeed = CtrlJ;	      FormFeed = CtrlL;
  CarriageReturn = CtrlM;   Escape = CtrlLeftBracket;

  HelpChar = CtrlUnderscore; (* Gives you help almost everywhere in AMIS.    *)

  StrSize = 40; (* Length of fixed length PACKED ARRAY OF CHAR strings.	     *)

type (* Common type declarations for all AMIS modules. 1981-07-26 / JMR      *)
  string = packed array [1 .. StrSize] of char; (* Fixed length string.      *)
  bufpos = integer; (* *** SYSTEM DEPENDENT *** Position in the buffer.      *)

var
  OldStr	: string;	(* Contains the last search string. *)
  OldLen	: integer;	(* Holds significant length of string. *)

(* External procedures and functions in alphabetical order. *)

function BGetChar(i : bufpos) : char; external;
function BufSearch(Str : string; Len, RepeatCount : integer; HowFar : bufpos) :
  boolean; external;
procedure Bug(Str : string); external;
procedure CommandLoop(RecursiveName : string); external;
procedure Delete(Len : bufpos); external;
function Delim(C : char) : boolean; external;
procedure EchoArrow(C : char); external;
procedure EchoClear; external;
procedure EchoDec(Number : integer); external;
procedure EchoString(Str : string); external;
procedure EchoUpdate; external;
procedure EOLString(var Str : string; var Len : integer); external;
procedure Error(Str : string); external;
function GetChar(Dot : bufpos) : char; external;
function GetDot : bufpos; external;
function GetLine(Lines : integer) : bufpos; external;
function GetMark(Pop : boolean) : bufpos; external;
function GetNull(Dot : bufpos) : char; external;
function GetSize : bufpos; external;
procedure Insert(C : char); external;
function KbdStop : boolean; external;
function Letter(C : char) : boolean; external;
function DownCase(C : char) : char; external;
function MetaBit : boolean; external;
procedure ModeClear; external;
procedure ModeString(Str : string); external;
procedure OvWLine; external;
procedure OvWString(Str : string); external;
function QReadC : char; external;
function ReadC : char; external;
procedure ReadLine(Prompt : string; var Str : string; var Length : integer);
  external;
procedure ReMap(var c: char; searching: boolean); external;
procedure ReRead; external;
procedure SetDot(NewDot : bufpos); external;
procedure SetMark(NewMark : bufpos); external;
procedure TrmBeep; external;
procedure TtyWrite(c: char); external;
function UpCase(C : char) : char; external;
procedure WinOverWrite(ch : char); external;
procedure WinPos(row : integer); external;
procedure WinRefresh; external;
procedure WinUpdate; external;

(*---------------------------------------------------------------------------*)
(* Initialization procedure. Should be called at start of program execution. *)

(*@VMS: [global] *)
procedure SeaInit(Total: boolean);
begin
  if Total
  then OldLen := 0
end;

(*---------------------------------------------------------------------------*)
(* IncrementalSearch implements the AMIS functions ^R Incremental Search, ^R *)
(* Reverse Search and ^R String Search. Incremental should be true for ^R    *)
(* Incremental Search and ^R Reverse Search and false for ^R String Search.  *)
(* SearchArg is the numeric argument given to the command for ^R Incremental *)
(* Search and ^R String Search, and the negative of the numeric argument for *)
(* ^R Reverse Search.							     *)

(*@VMS: [global] *)
procedure IncrementalSearch(Incremental : boolean; SearchArg : integer);

type
  refcontext = ^context;
  context = packed record
    Previous : refcontext;
    CSuccess : boolean;
    CSearchLen : 0..StrSize;
    CSearchArg : integer;
    CBeginDot, CDot : bufpos
  end;

var
  SearchStr, ReturnStr : string;
  SearchLen, ReturnLen, ReturnPos : integer;
  BeginDot : bufpos;
  CurrentContext : refcontext;
  BVoid, Success, More : boolean;
  C : char;

  procedure Search;
  var
    TopLine : boolean;
    JumpBefore : (JumpToBeginning, DontJump, JumpToEnd);
    ReturnPos : integer;

    procedure GiveHelp;
    begin
      OvWString('You are typing a search string.         '); OvWLine;
      OvWString('You can rub out, or cancel with one or  ');
      OvWString('two C-G''s.                              '); OvWLine;
      OvWString('C-U cancels the search string.  Rubout  ');
      OvWString('rubs out one character.                 '); OvWLine;
      OvWString('C-R reverses the direction of the       ');
      OvWString('search.                                 '); OvWLine;
      OvWString('C-B starts searching from the beginning ');
      OvWString('of buffer, C-E starts at the end.       '); OvWLine;
      OvWString('C-F positions window so search object is');
      OvWString('displayed near top.                     '); OvWLine;
      OvWString('C-S searches, and returns to read in    ');
      OvWString('loop.  Escape searches and exits.       '); OvWLine;
      OvWString('C-Q quotes control characters to search ');
      OvWString('for them.                               ')
    end;

    function DotSearch : boolean;
    var
      OldDot : bufpos;
      Success : boolean;
    begin
      EchoUpdate;
      if JumpBefore = DontJump
      then begin
	OldDot := GetDot;
	if SearchArg < 0
	then SetDot(OldDot + SearchLen)
      end
      else begin
	if JumpBefore = JumpToBeginning
	then OldDot := 0
	else oldDot := GetSize;
	SetDot(OldDot)
      end (* if *);
      if SearchLen = 0
      then Success := BufSearch(OldStr, OldLen, SearchArg, 0)
      else begin
	Success := BufSearch(SearchStr, SearchLen, SearchArg, 0);
	OldStr := SearchStr;
	OldLen := SearchLen
      end (* if *);
      if Success
      then begin
	if SearchArg < 0
	then SetDot(GetDot - SearchLen);
	if TopLine
	then WinPos(2);
	DotSearch := true
      end
      else begin
	SetDot(OldDot);
	EchoString('FAIL                                    ');
	BVoid := KbdStop;
	DotSearch := false
      end (* if *)
    end (* DotSearch *);

    procedure RePaint;
    var
      Pos : integer;
    begin (* RePaint *)
      EchoClear;
      if JumpBefore = JumpToBeginning
      then EchoString('BJ                                      ')
      else
      if JumpBefore = JumpToEnd
      then EchoString('EJ                                      ');
      if TopLine
      then EchoString('Top Line                                ');
      if SearchArg < 0
      then EchoString('Reverse                                 ');
      EchoString('Search:                                 ');
      for Pos := 1 to SearchLen
      do EchoArrow(SearchStr[Pos])
    end (* RePaint *);

  begin (* Search *)
    TopLine := false;
    JumpBefore := DontJump;
    More := true;
    while More
    do begin
      RePaint;
      WinUpdate;
      C := ReadC;
      ReMap(c, true);
      if C = Chr(HelpChar)	(* C-_ => Display help message.		     *)
      then begin
	GiveHelp
      end
      else
      if C = Chr(CtrlB)		(* C-B => Search forward from beginning.     *)
      then begin
	JumpBefore := JumpToBeginning;
	if SearchArg < 0
	then SearchArg := - SearchArg
      end
      else
      if C = Chr(CtrlE)		(* C-E => Search backward from end.	     *)
      then begin
	JumpBefore := JumpToEnd;
	if SearchArg > 0
	then SearchArg := - SearchArg
      end
      else
      if C = Chr(CtrlF)		(* C-F => Position match near top of screen. *)
      then begin
	TopLine := true
      end
      else
      if C = Chr(CtrlR)		(* C-R => Reverse direction of search.	     *)
      then begin
	if SearchArg > 0
	then SearchArg := - 1
	else SearchArg := 1
      end
      else
      if C = Chr(CtrlS)		(* C-S => Search and return to read in loop. *)
      then begin
	EchoString('^S                                      ');
	More := DotSearch
      end
      else
      if C = Chr(Escape)	(* Escape => Search and exit.		     *)
      then begin
	EchoString('$                                       ');
	BVoid := DotSearch;
	More := false
      end
      else
      if C = Chr(RubOut)	(* Rubout => Rub out one character.	     *)
      then begin
	if SearchLen > 0
	then SearchLen := SearchLen - 1
	else TrmBeep
      end
      else
      if C = Chr(CtrlU)		(* C-U => Rub out the search string.	     *)
      then begin
	SearchLen := 0
      end
      else
      if C = Chr(CarriageReturn)(* Return => Insert end of line sequency into*)
      then begin		(* search string.			     *)
	if SearchLen + ReturnLen > StrSize
	then TrmBeep
	else begin
	  for ReturnPos := 1 to ReturnLen
	  do SearchStr[SearchLen + ReturnPos] := ReturnStr[ReturnPos];
	  SearchLen := SearchLen + ReturnLen
	end
      end
      else begin		(* Other character => Insert it into string. *)
	if C = Chr(CtrlQ)	(* C-Q => Insert next character into string. *)
	then begin
	  C := QReadC;
	end (* if *);
	if SearchLen + 1 > StrSize
	then TrmBeep
	else begin
	  SearchStr[SearchLen + 1] := C;
	  SearchLen := SearchLen + 1
	end
      end (* if *)
    end (* while *)
  end (* Search *);

  procedure GiveHelp;
  begin (* GiveHelp *)
    OvWString('You are typing a search string.         '); OvWLine;
    OvWString('You can rub out, or cancel with one or  ');
    OvWString('two C-G''s.                              '); OvWLine;
    OvWString('C-R and C-S change direction or repeat  ');
    OvWString('the search,                             '); OvWLine;
    OvWString('C-R backward and C-S forward.  Escape   ');
    OvWString('exits.                                  '); OvWLine;
    OvWString('C-Q quotes control characters to search ');
    OvWString('for them.                               ')
  end (* GiveHelp *);

  procedure PopContext;
  var
    OldContext : refcontext;
  begin
    if CurrentContext = nil
    then Bug('PopContext: CurrentContext = nil! /JMR  ');
    OldContext := CurrentContext;
    CurrentContext := CurrentContext^.Previous;
    Dispose(OldContext)
  end;

  procedure RestoreContext;
  begin (* RestoreContext *)
    if CurrentContext = nil
    then Bug('RestoreContext: CurrentContext = nil! /J');
    with CurrentContext^
    do begin
      Success := Csuccess;
      SearchLen := CSearchLen;
      SearchArg := CSearchArg;
      BeginDot :=CBeginDot;
      SetDot(CDot)
    end (* with *);
    PopContext
  end (* RestoreContext *);

  procedure SaveContext;
  var
    NewContext : refcontext;
  begin (* SaveContext *)
    New(NewContext);
    with NewContext^
    do begin
      Previous := CurrentContext;
      CSuccess := Success;
      CSearchLen := SearchLen;
      CSearchArg := SearchArg;
      CBeginDot := BeginDot;
      CDot := GetDot
    end (* with *);
    CurrentContext := NewContext
  end (* SaveContext *);

  procedure RePaint;
  var
    Pos : integer;
  begin (* RePaint *)
    EchoClear;
    if not Success
    then EchoString('Failing                                 ');
    if SearchArg < 0
    then EchoString('Reverse                                 ');
    EchoString('I-Search:                               ');
    for Pos := 1 to SearchLen
    do EchoArrow(SearchStr[Pos])
  end (* RePaint *);

  function DotSearch(StartDot : bufpos) : boolean;
  var
    OldDot : bufpos;
  begin (* DotSearch *)
    EchoUpdate;
    OldDot := getdot;
    SetDot(StartDot);
    if BufSearch(SearchStr, SearchLen, SearchArg, 0)
    then begin
      DotSearch := true;
      if SearchArg < 0
      then SetDot(GetDot - SearchLen)
    end
    else begin
      DotSearch:= false;
      BVoid := KbdStop;
      SetDot(OldDot)
    end
  end (* DotSearch *);

begin (* IncrementalSearch *)
  if SearchArg = 0
  then error('NYI? 0 Argument Is Not Yet Implemented  ');
  SearchLen := 0;
  EOLString(ReturnStr, ReturnLen);
  if Incremental
  then begin
    ReturnPos := 0;
    CurrentContext := nil;
    Success := true;
    BeginDot := GetDot;
    More := true;
    while More
    do begin
      RePaint;
      WinUpdate;
      if ReturnPos = 0
      then begin
        C := QReadC;
	ReMap(c, true);
      end (* if *);
      if (ReturnPos > 0)	(* End of line sequency *)
      or (not MetaBit) and	(* Or kind of printing char *)
	 (c in [chr(HorizontalTab), chr(LineFeed), chr(CtrlQ),
		' '..'~' (*@VMS: , chr(160)..chr(255) *)])
      then begin		(* Insert it into string and search. *)
	SaveContext;
	if ReturnPos > 0	(* End of line sequency => Insert next	     *)
	then begin		(* character from end of line sequency.	     *)
	  C := ReturnStr[ReturnPos];
	  ReturnPos := ReturnPos + 1;
	  if ReturnPos > ReturnLen
	  then ReturnPos := 0
	end
	else
	if C = Chr(CtrlQ)	(* C-Q => Read another character, and use    *)
	then begin		(* that character instead.		     *)
	  C := QReadC;
	end (* if *);
	if SearchLen = StrSize
	then TrmBeep
	else begin
	  SearchLen := SearchLen + 1;
	  SearchStr[SearchLen] := C;
	  if Success
	  then begin
	    if SearchArg > 0
	    then Success := DotSearch(GetDot - SearchLen + 1)
	    else
	    if SearchLen = 1
	    then Success := DotSearch(GetDot)
	    else
	    if BeginDot > GetDot + SearchLen
	    then Success := DotSearch(GetDot + SearchLen)
	    else Success := DotSearch(BeginDot)
	  end
	  else TrmBeep;
	end (* if *)
      end
      else
      if (C = Chr(HelpChar)) and (* C-_ => Display help message.	     *)
         (not MetaBit)
      then begin
        GiveHelp
      end
      else
      if (C = Chr(CarriageReturn)) and (* Return => Insert end of *)
         (not MetaBit)		(* line sequency into *)
      then begin		(* search string, instead of the characters  *)
        ReturnPos := 1		(* typed in, next time.			     *)
      end
      else
      if (C = Chr(RubOut)) and	(* Rubout => Rub out one character in the    *)
         (not MetaBit)
      then begin		(* search string, or one C-R or C-S command. *)
	if CurrentContext = nil
	then TrmBeep
	else RestoreContext
      end
      else
      if (C = Chr(CtrlG)) and	(* C-G => Rub out untill success, if failing,*)
         (not MetaBit)
      then begin		(* rub out all the way back, if successfull. *)
	if Success
	then begin
	  if CurrentContext <> nil
	  then begin
 	    while CurrentContext^.Previous <> nil
	    do PopContext;
	    RestoreContext
	  end (* if *);
	  More := false
	end
	else begin
	  while not Success
	  do RestoreContext
	end (* if *)
      end
      else
      if (C = Chr(CtrlR)) and	(* C-R => Search backward, recalling the old *)
          (not MetaBit)
      then begin		(* search string, if the current is empty.   *)
	SaveContext;
	if SearchLen = 0
	then begin
	  SearchArg := - 1;
	  SearchStr := OldStr;
	  SearchLen := OldLen;
	  RePaint;
	  Success := DotSearch(GetDot)
	end
	else
	if SearchArg < 0
	then begin
	  if Success
	  then Success := DotSearch(GetDot + SearchLen - 1)
	  else TrmBeep
	end
	else begin
	  Success := true;
	  SearchArg := - 1;
	  RePaint;
	  Success := DotSearch(GetDot)
	end (* if *)
      end
      else
      if (C = Chr(CtrlS)) and	(* C-S => Search forward, recalling the old  *)
         (not MetaBit)
      then begin		(* search string, if the current is empty.   *)
	SaveContext;
	if SearchLen = 0
	then begin
	  SearchArg := 1;
	  SearchStr := OldStr;
	  SearchLen := OldLen;
	  RePaint;
	  Success := DotSearch(GetDot)
	end
	else
	if SearchArg > 0
	then begin
	  if Success
	  then Success := DotSearch(GetDot - SearchLen + 1)
	  else TrmBeep
	end
	else begin
	  Success := true;
	  SearchArg := 1;
	  RePaint;
	  Success := DotSearch(GetDot)
	end (* if *)
      end
      else
      if (C = Chr(Escape)) and (not MetaBit) and
         (SearchLen = 0)	(* Escape AND Empty search     *)
      then begin		(* string => Enter ^R String Search.	     *)
        Search
      end
      else begin		(* Other character => Exit, and remember the *)
	OldStr := SearchStr;	(* search string. Reread the character unless*)
	OldLen := SearchLen;	(* it is Escape.			     *)
	EchoString('$                                       ');
        if (C <> Chr(Escape)) or MetaBit
	then ReRead;
	More := false
      end (* if *)
    end (* while *);
    while CurrentContext <> nil
    do PopContext
  end
  else Search
end (* IncrementalSearch *);

(*---------------------------------------------------------------------------*)
(* QueryReplace implements the AMIS functions Query Replace and Replace	     *)
(* String. Query should be true for Query Replace and false for Replace	     *)
(* String. Delimitered should be true if a numeric argument was given to     *)
(* Query Replace or Replace String. The routine prompts with 'Replace:' and  *)
(* reads the search string from the terminal. Thereafter it prompts with     *)
(* 'with:' and reads the replacement string. The last part of the routine    *)
(* is a loop, in which the replacement is done.				     *)

(*@VMS: [global] *)
procedure QueryReplace(Query, Delimitered : boolean);
var
  ModeName : string;
  SearchStr, ReplaceStr : string;
  SearchLen, ReplaceLen, SearchFirstLetter, ReplaceFirstLetter : integer;
  PreserveCase, DontSearch, DontReplace, More : boolean;
  C : char;

  procedure GiveHelp;
  begin (* GiveHelp *)
    OvWString('Space => replace, Rubout => don''t, Comma');
    OvWString('=> replace and show,                    ');
    OvWLine;
    OvWString('Period replaces once and exits, !       ');
    OvWString('replaces all the rest,                  ');
    OvWLine;
    OvWString('C-R enters editor recursively, C-W does ');
    OvWString('so after killing FOO,                   ');
    OvWLine;
    OvWString('^ returns to previous locus, ? gets     ');
    OvWString('help, C-L redisplays,                   ');
    OvWLine;
    OvWString('Escape exits, anything else exits and   ');
    OvWString('is reread.                              ');
    OvWLine;
    OvWLine;
    OvWString('Type a space to see buffer again.       ')
  end (* GiveHelp *);  

  procedure CheckCase(Str : string; Len : integer);
  var
    Pos : integer;
    FoundLower, FoundUpper : boolean;
    C : char;
  begin (* CheckCase *)
    if PreserveCase  
    then begin
      Pos := 1;
      FoundLower := false;
      FoundUpper := false;
      while (Pos <= Len) and not FoundUpper
      do begin
	C := Str[Pos];
	if C <> UpCase(C)
	then FoundLower := true
	else
	if C <> DownCase(C)
	then FoundUpper := true;
	Pos := Pos + 1
      end (* while *);
      PreserveCase := FoundLower and not FoundUpper
    end (* if *)
  end (* CheckCase *);

  function FindFirstLetter(Str : string; Len : integer) : integer;
  var
    Pos : integer;
    FoundLetter : boolean;
  begin (* FindFirstLetter *)
    Pos := 1;
    FoundLetter := false;
    while (Pos <= Len) and not FoundLetter
    do begin
      FoundLetter := Letter(Str[Pos]);
      Pos := Pos + 1
    end (* while *);
    if not FoundLetter
    then Bug('FindFirstLetter: None found! /JMR       ');
    FindFirstLetter := Pos - 1
  end (* FindFirstLetter *);

  function DotSearch : boolean;
  var
    More : boolean;
    OldDot : bufpos;
  begin (* DotSearch *)
    if Delimitered
    then begin
      OldDot := GetDot;
      More := true;
      while More
      do begin
	if not BufSearch(SearchStr, SearchLen, 1, 0)
	then begin
	  SetDot(OldDot);
	  DotSearch := false;
	  More := false
	end
	else
	if Delim(GetNull(GetDot - SearchLen - 1))
	and Delim(GetNull(GetDot))
	then begin
	  DotSearch := true;
	  More := false
	end (* if *)
      end (* while *)
    end
    else DotSearch := BufSearch(SearchStr, SearchLen, 1, 0);
  end (* DotSearch *);

  procedure Replace;
  var
    Pos : integer;
    FirstUpper, RestUpper, FoundLetter : boolean;
    Dot, Size : bufpos;
    C : char;
  begin (* Replace *)
    if PreserveCase
    then begin
      FirstUpper := false;
      RestUpper := false;
      Dot := GetDot - SearchLen + SearchFirstLetter - 1;
      C := GetChar(Dot);
      if C <> DownCase(C)
      then begin
	FirstUpper := true;
	RestUpper := true;
	Dot := Dot + 1;
	Size := GetSize;
	FoundLetter := false;
	while (Dot < Size) and not FoundLetter
	do begin
	  C := GetChar(Dot);
	  FoundLetter := Letter(C);
	  Dot := Dot + 1
	end (* while *);
	if FoundLetter
	then RestUpper := C <> DownCase(C)
      end (* if *);
      Delete (- SearchLen);
      for Pos := 1 to ReplaceFirstLetter
      do
      if FirstUpper
      then Insert(UpCase(ReplaceStr[Pos]))
      else Insert(ReplaceStr[Pos]);
      for Pos := ReplaceFirstLetter + 1 to ReplaceLen
      do
      if RestUpper
      then Insert(UpCase(ReplaceStr[Pos]))
      else Insert(ReplaceStr[Pos])
    end
    else begin
      Delete(- SearchLen);
      for Pos := 1 to ReplaceLen
      do Insert(ReplaceStr[Pos])
    end (* if *)
  end (* Replace *);

  procedure RePaint;
  var
    Pos : integer;
  begin (* RePaint *)
    ModeClear;
    ModeString(ModeName);
    EchoClear;
    EchoString('Replace:                                ');
    for Pos := 1 to SearchLen
    do EchoArrow(SearchStr[Pos]);
    EchoString(' with:                                  ');
    for Pos := 1 to ReplaceLen
    do EchoArrow(ReplaceStr[Pos])
  end (* RePaint *);

begin (* QueryReplace *)
  ModeName := 'Query Replace.                          ';
  EchoClear;
  ReadLine('Replace:                                ', SearchStr, SearchLen);
  ReadLine(' with:                                  ', ReplaceStr, ReplaceLen);
  PreserveCase := true;
  CheckCase(SearchStr, SearchLen);
  CheckCase(ReplaceStr, ReplaceLen);
  if PreserveCase
  then begin
    SearchFirstLetter := FindFirstLetter(SearchStr, SearchLen);
    ReplaceFirstLetter := FindFirstLetter(ReplaceStr, ReplaceLen)
  end (* if *);
  if Query
  then begin
    ModeClear;
    ModeString(ModeName)
  end
  else begin
    EchoClear;
    EchoUpdate
  end;
  DontSearch := false;
  DontReplace := false;
  More := true;
  while More
  do begin
    if not DontSearch
    then begin
      SetMark(GetDot);
      More := DotSearch
    end (* if *);
    if More
    then
    if Query
    then begin
      WinUpdate;
      C := QReadC;
      if ((C = Chr(HelpChar)) or (C = '?')) and
         (not MetaBit)		(* C-_ and ? => Show help message. *)
      then begin
	GiveHelp;
	DontSearch := true
      end
      else
      if (C = ' ') and (not MetaBit) (* Space => Replace, and continue.	     *)
      then begin
        if not DontReplace
        then Replace;
	DontSearch := false;
	DontReplace := false
      end
      else
      if (C = Chr(Rubout)) and (not MetaBit) (* Rubout => Don't replace, *)
				(* but continue. *)
      then begin
	DontSearch := false;
	DontReplace := false
      end
      else
      if (C = ',') and (not MetaBit) (* Comma => Replace, and stay there. *)
      then begin
        if not DontReplace
        then Replace;
	DontSearch := true;
	DontReplace := true
      end
      else
      if (C = '.') and (not MetaBit) (* Period => Replace, and exit.	     *)
      then begin
        if not DontReplace
        then Replace;
	More := false
      end
      else
      if (C = '!') and (not MetaBit) (* Exclamation point => Replace, *)
      then begin		(* and continue without asking *)
        EchoClear;
	EchoUpdate;
	if not DontReplace
        then Replace;
	DontSearch := false;
	DontReplace := false;
	Query := false
      end
      else
      if ((C = Chr(CtrlR)) or (C = Chr(CtrlW))) and (not MetaBit)
				(* C-R and C-W => Enter	recursive edit level *)
      then begin
	if (C = Chr(CtrlW)) and not DontReplace
	then Delete(- SearchLen);(* C-W => delete match before.		     *)
        CommandLoop(ModeName);
	RePaint;
	DontSearch := true;
	DontReplace := true
      end
      else
      if (C = '^') and (not MetaBit) (* ^ => Return to previous match.	     *)
      then begin
	SetDot(GetMark(true));
	DontSearch := true;
	DontReplace := true
      end
      else
      if (C = Chr(CtrlL)) and (not MetaBit) (* C-L => Redisplay window.	    *)
      then begin
	WinRefresh;
	DontSearch := true
      end
      else begin		(* Other character => Exit, and reread the   *)
        if (C <> Chr(Escape)) or (* character, unless it is Escape.	     *)
	   MetaBit
	then ReRead;
	More := false
      end
    end
    else Replace
  end (* while *);
  if Query
  then EchoClear
end (* QueryReplace *);

(*---------------------------------------------------------------------------*)
(* HowMany implements the AMIS function How Many. It prompts with 'Pattern:' *)
(* and reads the pattern string from the terminal. Then it counts the number *)
(* of occurences of the pattern string, after point.			     *)

(*@VMS: [global] *)
procedure HowMany;
var
  SearchStr : string;
  SearchLen, Occurences : integer;
  OldDot : bufpos;
begin (* HowMany *)
  EchoClear;
  OldDot := GetDot;
  ReadLine('Pattern:                                ', SearchStr, SearchLen);
  EchoClear;
  EchoUpdate;
  Occurences := 0;
  while BufSearch(SearchStr, SearchLen, 1, 0)
  do Occurences := Occurences + 1;
  EchoDec(Occurences);
  EchoString(' occurences                             ');
  EchoUpdate;
  SetDot(OldDot)
end (* HowMany *);

(*---------------------------------------------------------------------------*)
(* Occur implements the AMIS function Occur. It prompts with 'Pattern:'      *)
(* and reads the pattern string from the terminal. Then it shows every line, *)
(* after point, that contains the pattern string.                            *)

(*@VMS: [global] *)
procedure Occur;
var
  SearchStr : string;
  SearchLen : integer;
  OldDot, First, Last, P : bufpos;
  Ch : char;
begin (* Occur *)
  EchoClear;
  OldDot := GetDot;
  ReadLine('Pattern:                                ', SearchStr, SearchLen);
  while BufSearch(SearchStr, SearchLen, 1, 0)
  do begin
    First:= GetLine(0); Last:= GetLine(1);
    for P:= First to Last-1 do WinOverWrite(BGetChar(P));
    Setdot(Last);
  end;
  SetDot(OldDot)
end (* Occur *);

(*---------------------------------------------------------------------------*)

(*@TOPS: begin end. *)
(*@VMS: end. *)
