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

IMPLEMENTATION MODULE Execute;

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

FROM SYSTEM IMPORT ADDRESS, WORD;
FROM Strings IMPORT CopyCC, LengthC;

FROM Universe IMPORT BYTE;
FROM List IMPORT ListP, True, False, Self, ActionName, HelpText, Cons,
		 MakeAtom, ListType, NameValueType, NameListP, ValueP;
FROM Actions IMPORT ActionR,
		    BuiltInAction, BuiltInActionWithParams, DeclareAction, Bind;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
IMPORT Errors, Interface, List, Actions, Windows, Display, StringData,
       Sets;

IMPORT Debug;

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

CONST
   MaxSequence		      = 200 ;
   MacroBufferSize	      = 20 ;

TYPE
   MacroP		      = POINTER TO MacroR ;
   MacroR		      = RECORD
      String			 : ARRAY [ 0..MacroBufferSize ] OF BYTE ;
      Length			 : CARDINAL ;
      Action			 : ActionR ;
      Args			 : ListP ;
      Body			 : ListP ;
      Next			 : MacroP ;
				END ;

   MacroEnvironmentP	      = POINTER TO MacroEnvironmentR ;
   MacroEnvironmentR	      = RECORD
      Previous			 : MacroEnvironmentP ;
      Index			 : CARDINAL ;
      Operations		 : MacroP ;
				END ;

   SequenceEnvironmentP       = POINTER TO SequenceEnvironmentR ;
   SequenceEnvironmentR       = RECORD
      Previous			 : SequenceEnvironmentP ;
      Length			 : CARDINAL ;
      Index			 : CARDINAL ;
      String			 : ARRAY [ 0..MaxSequence ] OF BYTE ;
				END ;

   LearnEnvironmentP	      = POINTER TO LearnEnvironmentR ;
   LearnEnvironmentR	      = RECORD
      Previous			 : LearnEnvironmentP ;
      Head			 : MacroP ;
      Tail			 : MacroP ;
      Terminator		 : BYTE ;
      Name			 : ActionName ;
      Description		 : HelpText ;
				END ;

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

VAR
   Macro		      : MacroEnvironmentP ;
   Sequence		      : SequenceEnvironmentP ;
   Learn		      : LearnEnvironmentP ;
   VariableDoMacro	      : List.ActionProc ;

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

PROCEDURE Remind (Offset: CARDINAL; Text: ARRAY OF CHAR);

   VAR
      Length  : CARDINAL;
      Index   : CARDINAL;

   BEGIN
      Length := LengthC (Text);
      Index := 0;
      WITH Display.EnclosingWindow^.Buffer^ DO
         WHILE Index < Length DO
  	    Array.Data^ [Index + Offset] := BYTE (Text [Index]);
	    INC (Index)
         END (* while *)
      END (* with *);
      EXCL (Display.EnclosingWindow^.Status, Windows.DisplayCompletedF)
   END Remind;

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

PROCEDURE RemindLearning;

   BEGIN
      Remind (48, "[ Learning ]")
   END RemindLearning;

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

PROCEDURE UnRemindLearning;

   BEGIN
      Remind (48, "            ");
   END UnRemindLearning;

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

PROCEDURE DefineMacro (Arg: ListP): ListP;

   (* Defines a list of actions *)

   VAR NewLearn  : LearnEnvironmentP;

   BEGIN
      NEW (NewLearn);
      IF NewLearn = NIL THEN
         Errors.Report (INTEGER (Errors.ErrorsInsufficientMemory));
         RETURN False
      ELSE
         WITH NewLearn^ DO
  	    Previous := Learn;
	    Head := NIL;
	    Tail := NIL;
	    Terminator := Self^.Byte;
	    Name := "Learnt";
	    Description := "Perform learnt sequence"
         END (* with *);
         Learn := NewLearn;
         RemindLearning
      END (* if *);
      RETURN True
   END DefineMacro;

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

PROCEDURE LearnNextKey (Char: BYTE; Action: ActionR): BOOLEAN;

   VAR
      P	   : MacroP;
      T	   : MacroP;
      Arg  : ListP;

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

(*
   PROCEDURE ConvertToListStructure (Macro: MacroP): ListP;

      VAR
         Params  : ListP;
         String  : StringData.StringP;

      BEGIN
         IF Macro = NIL THEN RETURN NIL END;

	 IF (Macro^.Action.Binding^.CurrentValue^.Type = BuiltInT)
	  AND (Macro^.Action.Binding^.CurrentValue^.ArgsText = NIL) THEN
            Params := NIL;
	 (* Should have got the type when it went by, now might be too late *)
	 ELSIF Macro^.Action.Binding^.CurrentValue^.Type = DefinedT THEN
	    RETURN Cons (Macro^.Body, Macro^.Args)
	 ELSIF NOT StringData.EqualCD ("Text", Macro^.Action.Binding^.CurrentValue^.ArgsText) THEN
	    Params := Cons (MakeAtom (Macro^.Length, NumberT), NIL)
	 ELSE
	    IF Macro^.Length > 1 THEN
	       (* Not correct, fails on nulls *)
	       Macro^.String [Macro^.Length] := 0C;
	       IF StringData.CopyCD (Macro^.String, String) THEN END;
	       Params := Cons (MakeAtom (String, StringT), NIL)
	    ELSE
	       Params := Cons (MakeAtom (Macro^.String [0], ByteT), NIL)
	    END (* if *)
	 END (* if *);

	 RETURN Cons (
                 Cons (MakeAtom (Macro^.Action.Binding, NameT), Params),
		 ConvertToListStructure (Macro^.Next)
                )

      END ConvertToListStructure;
*)

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

   VAR L: ListP;

   BEGIN
      IF Char = Learn^.Terminator THEN

         WITH Learn^ DO
	    IF Head = NIL THEN Bind (BYTE (094H), "Nothing", NIL)
  	    ELSE
	       NEW (Arg);
	       IF Arg = NIL THEN Errors.Report (INTEGER (Errors.ErrorsInsufficientMemory))
	       ELSE
	          Arg^.Type := NoneT;
	          Arg^.Word := WORD (Head);
(*
	          L := ConvertToListStructure (Head);
*)
                  (* Zap head & tail to avoid geting disposed by PopLearn *)

	          Head := NIL;
	          Tail := NIL;

(*
		  BuiltInAction (Name, DoMacro, Description);
		  Bind (BYTE (094H), Name, Arg);
*)
		  Bind (BYTE (094H), "DoMacro", Arg);
(*
	          DeclareAction ("Testing", "A Test macro", NIL, L);
	          Bind (BYTE (094H), "Testing", L);
*)

	       END (* if *)
 	    END (* if *);
 	    PopLearn
         END (* with *);
         RETURN FALSE

      ELSIF CARDINAL (VariableDoMacro) = CARDINAL (Actions.DispatchTable [
       CARDINAL (Char)].Binding^.CurrentValue^.Proc ) THEN

         (* Dont learn these, they cause infinite recursion *)

         RETURN TRUE

      ELSE

         RemindLearning;
         T := Learn^.Tail;
         IF (T # NIL) AND
          (T^.Action.Arg = Action.Arg) AND
          (T^.Action.Binding = Action.Binding) AND
          (T^.Length < MacroBufferSize) THEN
	    T^.String [T^.Length] := Char;
	    INC (T^.Length)
         ELSE
	    NEW (P);
	    IF P = NIL THEN
	       Errors.Report (INTEGER (Errors.ErrorsInsufficientMemory));
	       PopLearn;
	       RETURN FALSE
	    ELSE
	       P^.Action := Action;
	       P^.String [0] := Char;
	       P^.Length := 1;
	       P^.Next := NIL;
	       IF Action.Binding^.CurrentValue^.Type = DefinedT THEN
	          P^.Args := Action.Binding^.CurrentValue^.Args;
	          P^.Body := Action.Binding^.CurrentValue^.Body
	       END (* if *);
	       IF Learn^.Tail = NIL THEN Learn^.Head := P
	       ELSE Learn^.Tail^.Next := P
	       END (* if *);
	       Learn^.Tail := P
	    END (* if *)
         END (* if *);
         RETURN TRUE

      END (* if *)

   END LearnNextKey;

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

PROCEDURE PopLearn ();

   VAR
      CurrentLearn  : LearnEnvironmentP;
      P	            : MacroP;

   BEGIN
      UnRemindLearning;
      IF Learn = NIL THEN Errors.Panic ("Execute : PopLearn NIL")
      ELSE
         CurrentLearn := Learn;
         Learn := CurrentLearn^.Previous;
         WHILE CurrentLearn^.Head # NIL DO
 	    P := CurrentLearn^.Head;
	    CurrentLearn^.Head := CurrentLearn^.Head^.Next;
	    DISPOSE (P)
         END (* while *);
         DISPOSE (CurrentLearn)
      END (* if *)
   END PopLearn;

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

PROCEDURE UnLearnLastLearn ();

   VAR P: MacroP;

   BEGIN
      IF Learn # NIL THEN
         IF (Learn^.Tail # NIL) AND (Learn^.Tail^.Length > 1) THEN
	    DEC (Learn^.Tail^.Length);
 	    RETURN
         END (* if *);
         P := Learn^.Head;
         IF P = Learn^.Tail THEN
 	    DISPOSE (P);
 	    Learn^.Head := NIL;
	    Learn^.Tail := NIL
         ELSE
   	    WHILE P^.Next # Learn^.Tail DO P := P^.Next END;
	    DISPOSE (P^.Next);
	    Learn^.Tail := P
         END (* if *)
      END (* if *)
   END UnLearnLastLearn;

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

PROCEDURE Idle (): BOOLEAN;

   (* Return TRUE if there are no tasks outstanding *)

   BEGIN
      RETURN ((Sequence = NIL) OR (Sequence^.Index >= Sequence^.Length)) AND
       (Macro = NIL) AND
       NOT Interface.KeyTypedAhead ()
   END Idle;

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

(*
PROCEDURE ProcAddr (proc: PROC): ADDRESS;

   TYPE MoP = POINTER TO
                 RECORD
                    s  : CARDINAL;
                    l  : CARDINAL;
                    p  : CARDINAL;
                  END;

   VAR
     mop  : MoP;
     off  : CARDINAL;

   BEGIN
      mop := MoP (CARDINAL (proc) MOD 010000H);
      off := CARDINAL (proc) DIV 010000H;
      RETURN ADDRESS (mop^.p + off)
   END ProcAddr;
*)
(*----------------------------------------------------------------------*)

PROCEDURE NextAction (VAR Action: Actions.ActionR): BYTE;

   (* Returns the next key to be executed in the current context *)

   VAR
      Key     : BYTE;
      P	      : MacroP;
      oldSeq  :  SequenceEnvironmentP;
      oldMac  : MacroEnvironmentP;

   BEGIN
      IF Sequence # NIL THEN

         WITH Sequence^ DO
            Errors.Assert (Index < Length, "NextAction: exhausted sequence");
	    Key := String [Index];
	    IF Sets.In (Key, Windows.Selected^.Buffer^.LocalBindings.Active)
	     AND Actions.LocalBinding (Windows.Selected^.Buffer, Action, Key) THEN
	       (* use the local binding, not the global one *)
	    ELSE Action := Actions.DispatchTable [CARDINAL (Key)]
	    END (* if *);
            IF Index + 1 < Length THEN INC (Index)
            ELSE
               oldSeq := Sequence;
               Sequence := Sequence^.Previous;
               DISPOSE (oldSeq)
            END (* if *)
         END (* with *)

      ELSIF Macro # NIL THEN

         P := Macro^.Operations;
         Errors.Assert (P # NIL, "NextAction: exhausted macro");
	 Action := P^.Action;
	 Key := P^.String [Macro^.Index];
	 INC (Macro^.Index);
	 IF Macro^.Index = P^.Length THEN
            IF P^.Next # NIL THEN
	       Macro^.Operations := P^.Next;
	       Macro^.Index := 0
            ELSE
               oldMac := Macro;
               Macro := Macro^.Previous;
               DISPOSE (oldMac)
            END (* if *)
	 END (* if *)

      ELSE

         Key := Interface.GetKey ();
         IF Sets.In (Key, Windows.Selected^.Buffer^.LocalBindings.Active)
          AND Actions.LocalBinding (Windows.Selected^.Buffer, Action, Key) THEN
	    (* use the local binding, not the global one *)

         ELSE Action := Actions.DispatchTable [CARDINAL (Key)];

         END (* if *)

      END (* if *);

      IF Learn # NIL THEN
         IF LearnNextKey (Key, Action) THEN (* Still learning *)
         ELSE Key := NextAction (Action)
         END (* if *)
      END (* if *);

      RETURN Key

   END NextAction;

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

PROCEDURE SetSequence (String: ARRAY OF BYTE; Length: CARDINAL);

   (* Executes the sequence of bytes in the string *)

   VAR NewSequence: SequenceEnvironmentP;

   BEGIN
      IF Length = 0 THEN RETURN END;
      NEW (NewSequence);
      IF NewSequence = NIL THEN Errors.Report (INTEGER (Errors.ErrorsInsufficientMemory))
      ELSE
         NewSequence^.Previous := Sequence;
         NewSequence^.Length := Length;
         NewSequence^.Index := 0;
         CopyCC (String, NewSequence^.String);
         Sequence := NewSequence;
         UnLearnLastLearn ()
      END (* if *)
   END SetSequence;

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

PROCEDURE DoMacro (Arg: ListP): ListP;

   (* Just inserts macro argument at head of macro list *)

   VAR m: MacroEnvironmentP;

   BEGIN
      IF Arg = NIL THEN
      ELSE
         IF Arg^.Type # NoneT (* MacroT *) THEN
            Errors.Panic ("DoMacro: Wrong ArgType")
         END (* if *);

         NEW (m);
         IF m = NIL THEN
            Errors.Report (INTEGER (Errors.ErrorsInsufficientMemory));
            RETURN False
         ELSE
            m^.Previous := Macro;
            m^.Index := 0;
            m^.Operations := MacroP (Arg^.Word (* Macro *));
            Macro := m
         END (* if *)

      END (* if *);
      RETURN True
   END DoMacro;

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

PROCEDURE Apply( Function : ValueP ; Arg : ListP ) : ListP ;

   (* Executes a list of actions *)

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

   PROCEDURE DoList (Arg: ListP): ListP;

      VAR Result: ListP;

      BEGIN
         WHILE Arg # NIL DO
	    IF Arg^.Type #ListT THEN Errors.Panic ("Apply grooty list") END;
	    Result := DoIt (Arg^.Head);
 	    IF Result # True THEN RETURN Result END;
	    Arg := Arg^.Tail
         END (* while *);
         RETURN True
      END DoList;

   (*-------------------------------------------------------------------*)
   
   PROCEDURE DoIt (Arg: ListP): ListP;

      VAR
         NameP  : NameListP;
         WaJ    : ListP;

      BEGIN

         (* If this works at all, it will never works with ordinary
         structures *)

         WaJ := List.Head (Arg);
         IF WaJ^.Type = ListT THEN RETURN DoList (WaJ)
         ELSIF WaJ^.Type = NameT THEN
 	    NameP := List.NameOfList (List.Head (Arg));
 	    IF WaJ^.Name^.CurrentValue^.Type = BuiltInT THEN
	       IF (Arg^.Tail # NIL) AND (Arg^.Tail^.Type = ListT) THEN
	          IF Arg^.Tail^.Head^.Type = ByteT THEN
		     Self^.Byte := List.ByteOfList (List.HeadOfTail (Arg))
	          ELSIF (Arg^.Tail^.Head^.Type = NumberT) AND
	           (Arg^.Tail^.Head^.Number < 256) THEN
		     Self^.Byte :=
                      BYTE (List.NumberOfList (List.HeadOfTail (Arg)))
	          ELSE Self^.Byte := BYTE (0)
	          END (* if *)
	       END (* if *);
	       RETURN NameP^.CurrentValue^.Proc (List.Tail (Arg))
	    ELSIF WaJ^.Name^.CurrentValue^.Type = DefinedT THEN
	       RETURN Apply (NameP^.CurrentValue, List.Tail (Arg))
	    END (* if *)
         ELSE Errors.Panic ("Cannot Apply unless it is a function")
         END (* if *)
      END DoIt;

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

   VAR Result: ListP;

   BEGIN

      (* Evaluate arguments and bind them *)

      Result := DoList (Function^.Body);

      (* restore bound variables and dispose arguments *)

      RETURN Result

   END Apply;

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

PROCEDURE Initialise;

   BEGIN
      BuiltInAction ("DefMacro", DefineMacro, "Learn a sequence");
      BuiltInAction ("DoMacro", DoMacro, "Execute learnt sequence");

      Bind (BYTE (084H), "DefMacro", NIL);
   END Initialise;

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

PROCEDURE Terminate;

   BEGIN
   END Terminate;

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

BEGIN
   Macro := NIL;
   Sequence := NIL;
   Learn := NIL;
   VariableDoMacro := DoMacro
END Execute.

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