(*----------------------------------------------------------------------*) (* Process_Script --- Convert PibTerm script file to in-core code. *) (*----------------------------------------------------------------------*) OVERLAY PROCEDURE Process_Script; (*----------------------------------------------------------------------*) (* *) (* Procedure: Process_Script *) (* *) (* Purpose: Convert PibTerm script file to in-core instructions. *) (* *) (* Calling Sequence: *) (* *) (* Process_Script; *) (* *) (* Remarks: *) (* *) (* The entire script file is read and converted to an in-core *) (* representation which can be executed. *) (* *) (* At this time, user-defined labels are not allowed. There *) (* are some variable related to them here, however. The next *) (* time around (PibTerm v4.0) they will be used to allow for *) (* case statements and procedures in scripts. *) (* *) (*----------------------------------------------------------------------*) CONST (* Maximum # of labels allowed *) Max_Script_Labels = 20; (* Maximum stack depth *) Max_Script_Stack = 10; TYPE (* Points to a label reference *) Script_Label_Ptr = ^Script_Label_Reference; (* Records one label reference *) Script_Label_Reference = RECORD (* Offset in script buffer *) Buffer_Pos : INTEGER; (* Next reference *) Next_Ref : Script_Label_Ptr; END; Script_Label_Type = RECORD (* Label name *) Name : STRING[12]; (* Label definition position *) Buffer_Pos : INTEGER; (* Pointer to first reference *) First_Ref : Script_Label_Ptr; END; VAR (* Number of labels currently defined *) Script_Label_Count : INTEGER; (* Script label definition vector *) Script_Labels : ARRAY[1..Max_Script_Labels] OF Script_Label_Type; (* Current stack levels, conditional *) (* script commands. *) Script_Repeat_Level : INTEGER; Script_If_Level : INTEGER; Script_While_Level : INTEGER; (* Stacks for conditional commands *) Script_Repeat_Stack : ARRAY[1..Max_Script_Stack] OF INTEGER; Script_If_Stack : ARRAY[1..Max_Script_Stack] OF INTEGER; Script_While_Stack : ARRAY[1..Max_Script_Stack] OF INTEGER; L : INTEGER; I : INTEGER; K : INTEGER; IS : INTEGER; Local_Save : Saved_Screen_Ptr; Ch : CHAR; Text_Line : AnyStr; Byte_File : FILE OF BYTE; OK_Script_Command : BOOLEAN; Script_Command_Token : AnyStr; Script_Line : AnyStr; Saved_Script_Line : AnyStr; Current_Script_Command : PibTerm_Command_Type; Script_Debug_File : TEXT; Script_Debug_Mode : BOOLEAN; (*----------------------------------------------------------------------*) (* Get_Quoted_String --- pick up string in quotes *) (*----------------------------------------------------------------------*) PROCEDURE Get_Quoted_String( S : AnyStr; VAR IS : INTEGER; VAR QS : AnyStr; VAR Quote: CHAR ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Get_Quoted_String *) (* *) (* Purpose: Extracts quoted string from a string. *) (* *) (* Calling Sequence: *) (* *) (* Get_Quoted_String( S : AnyStr; *) (* VAR IS : INTEGER; *) (* VAR QS : AnyStr; *) (* VAR Quote : CHAR ); *) (* *) (* S --- string containing quoted string *) (* IS --- current position in S *) (* QS --- resultant extracted string (no quotes) *) (* Quote --- quote character (blank if quotes not found) *) (* *) (* Remarks: *) (* *) (* A quote within a string can be entered by putting two quotes *) (* together, e.g., 'ab''c' --> ab'c. *) (* *) (*----------------------------------------------------------------------*) VAR LS : INTEGER; End_String : BOOLEAN; BEGIN (* Get_Quoted_String *) (* Null string is default *) QS := ''; Quote := ' '; (* Skip leading blanks *) LS := LENGTH( S ); WHILE ( IS <= LS ) AND ( S[IS] = ' ' ) DO IS := IS + 1; (* See if we have a quote *) IF ( IS <= LS ) THEN BEGIN IF S[IS] IN ['''','"'] THEN BEGIN (* Pickup quoted string is so *) Quote := S[IS]; End_String := FALSE; REPEAT IS := IS + 1; (* Note: two quotes in a row used *) (* to indicate single quote *) (* to be inserted into string *) IF IS <= LS THEN IF S[IS] <> Quote THEN QS := QS + S[IS] ELSE BEGIN IF ( IS + 1 ) <= LS THEN IF S[IS+1] = Quote THEN BEGIN QS := QS + Quote; IS := IS + 1; END ELSE End_String := TRUE ELSE End_String := TRUE; END ELSE End_String := TRUE; UNTIL End_String; END; END; END (* Get_Quoted_String *); (*----------------------------------------------------------------------*) (* Get_String --- Pick up string *) (*----------------------------------------------------------------------*) PROCEDURE Get_String( S : AnyStr; VAR IS : INTEGER; VAR QS : AnyStr; VAR Delim: CHAR ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Get_String *) (* *) (* Purpose: Extracts string up to a delimeter. *) (* *) (* Calling Sequence: *) (* *) (* Get_String( S : AnyStr; *) (* VAR IS : INTEGER; *) (* VAR QS : AnyStr; *) (* VAR Delim : CHAR ); *) (* *) (* S --- string containing string to extract *) (* IS --- current position in S *) (* QS --- resultant extracted string *) (* Delim --- delimeter character *) (* *) (*----------------------------------------------------------------------*) VAR LS : INTEGER; End_String : BOOLEAN; Ch : CHAR; BEGIN (* Get_String *) (* Null string is default *) QS := ''; Delim := ' '; (* Skip leading blanks *) LS := LENGTH( S ); WHILE ( IS <= LS ) AND ( S[IS] = ' ' ) DO IS := IS + 1; (* Copy up to non-letter, non-digit *) End_String := FALSE; IF ( IS <= LS ) THEN REPEAT Ch := S[IS]; IF ( Ch IN ['A'..'Z','a'..'z','0'..'9'] ) THEN BEGIN QS := QS + Ch; IS := IS + 1; END ELSE BEGIN End_String := TRUE; Delim := Ch; END; UNTIL End_String; END (* Get_String *); (*----------------------------------------------------------------------*) (* Get_Integer --- pick up integer *) (*----------------------------------------------------------------------*) PROCEDURE Get_Integer( S : AnyStr; VAR IS : INTEGER; VAR Qnum : BOOLEAN; VAR IntVal: INTEGER ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Get_Integer *) (* *) (* Purpose: Extracts integer from a string. *) (* *) (* Calling Sequence: *) (* *) (* Get_Integer( S : AnyStr; *) (* VAR IS : INTEGER; *) (* VAR Qnum : BOOLEAN; *) (* VAR IntVal : INTEGER ); *) (* *) (* S --- string containing quoted string *) (* IS --- current position in S *) (* Qnum --- TRUE if a number extracted *) (* IntVal --- integer extracted or 0 if none *) (* *) (*----------------------------------------------------------------------*) VAR LS : INTEGER; End_Of_Num : BOOLEAN; Int_Sign : INTEGER; BEGIN (* Get_Integer *) (* Skip leading blanks *) LS := LENGTH( S ); WHILE ( IS <= LS ) AND ( S[IS] = ' ' ) DO IS := IS + 1; (* Default value is zero *) IntVal := 0; Qnum := FALSE; End_Of_Num := FALSE; Int_Sign := 1; (* Pick up minus sign *) IF ( IS <= LS ) THEN IF ( S[IS] = '-' ) THEN BEGIN Int_Sign := -1; IS := IS + 1; END; (* Pick up digits if any *) REPEAT IF ( IS <= LS ) THEN IF S[IS] IN ['0'..'9'] THEN BEGIN IntVal := IntVal * 10 + ORD( S[IS] ) - ORD('0'); Qnum := TRUE; END ELSE End_Of_Num := TRUE ELSE End_Of_Num := TRUE; IF ( NOT End_Of_Num ) THEN IS := IS + 1; UNTIL ( End_Of_Num ); IntVal := IntVal * Int_Sign; END (* Get_Integer *); (*----------------------------------------------------------------------*) (* Copy_String_To_Buffer --- Copy string from script line to buffer *) (*----------------------------------------------------------------------*) PROCEDURE Copy_String_To_Buffer; (*----------------------------------------------------------------------*) (* *) (* Procedure: Copy_String_To_Buffer *) (* *) (* Purpose: Copies quoted string from script line to buffer *) (* *) (* Calling Sequence: *) (* *) (* Copy_String_To_Buffer; *) (* *) (*----------------------------------------------------------------------*) VAR L : INTEGER; Quote : CHAR; I : INTEGER; BEGIN (* Copy_String_To_Buffer *) Get_Quoted_String( Script_Line, IS, Text_Line, Quote ); L := LENGTH( Text_Line ); IF ( NOT ( Quote IN ['''','"'] ) ) THEN L := 0; Script_Buffer_Pos := Script_Buffer_Pos + 1; Script_Buffer^[Script_Buffer_Pos] := L; IF Script_Debug_Mode THEN WRITE( Script_Debug_File , Script_Buffer_Pos:4 , ' ', L:4 ); FOR I := 1 TO L DO BEGIN Script_Buffer_Pos := Script_Buffer_Pos + 1; Script_Buffer^[Script_Buffer_Pos] := ORD( Text_Line[I] ); END; IF Script_Debug_Mode THEN BEGIN WRITE ( Script_Debug_File , ' ', Text_Line ); WRITELN( Script_Debug_File ); END; END (* Copy_String_To_Buffer *); (*----------------------------------------------------------------------*) (* Copy_Integer_To_Buffer --- Copy integer to script line buffer *) (*----------------------------------------------------------------------*) PROCEDURE Copy_Integer_To_Buffer( IntVal : INTEGER ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Copy_Integer_To_Buffer *) (* *) (* Purpose: Copies integer to script line buffer *) (* *) (* Calling Sequence: *) (* *) (* Copy_Integer_To_Buffer( IntVal : INTEGER ); *) (* *) (* IntVal --- Value to place in script buffer *) (* *) (*----------------------------------------------------------------------*) VAR Int_Bytes : ARRAY[1..2] OF BYTE ABSOLUTE IntVal; BEGIN (* Copy_Integer_To_Buffer *) Script_Buffer_Pos := Script_Buffer_Pos + 1; Script_Buffer^[Script_Buffer_Pos] := Int_Bytes[1]; IF Script_Debug_Mode THEN WRITELN( Script_Debug_File , Script_Buffer_Pos:4 , ' ', Int_Bytes[1]:4, Int_Bytes[2]:4, ' ', IntVal:8, ' (Integer)'); Script_Buffer_Pos := Script_Buffer_Pos + 1; Script_Buffer^[Script_Buffer_Pos] := Int_Bytes[2]; END (* Copy_Integer_To_Buffer *); (*----------------------------------------------------------------------*) (* Copy_Byte_To_Buffer --- Copy byte to script line buffer *) (*----------------------------------------------------------------------*) PROCEDURE Copy_Byte_To_Buffer( ByteVal : INTEGER ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Copy_Byte_To_Buffer *) (* *) (* Purpose: Copies byte to script line buffer *) (* *) (* Calling Sequence: *) (* *) (* Copy_Byte_To_Buffer( IntVal : INTEGER ); *) (* *) (* ByteVal --- Value to place in script buffer *) (* *) (*----------------------------------------------------------------------*) BEGIN (* Copy_Byte_To_Buffer *) Script_Buffer_Pos := Script_Buffer_Pos + 1; Script_Buffer^[Script_Buffer_Pos] := ByteVal; IF Script_Debug_Mode THEN BEGIN WRITE( Script_Debug_File , Script_Buffer_Pos:4 , ' ', ByteVal, ' (Byte)' ); IF ( ByteVal > 32 ) AND ( ByteVal < 127 ) THEN WRITE( Script_Debug_File , ' (',CHR( ByteVal ),')' ); WRITELN( Script_Debug_File ); END; END (* Copy_Integer_To_Buffer *); (*----------------------------------------------------------------------*) (* Copy_Protocol_To_Buffer --- Copy transfer protocol to buffer *) (*----------------------------------------------------------------------*) PROCEDURE Copy_Protocol_To_Buffer; (*----------------------------------------------------------------------*) (* *) (* Procedure: Copy_Protocol_To_Buffer *) (* *) (* Purpose: Copies file transfer protocol to buffer *) (* *) (* Calling Sequence: *) (* *) (* Copy_Protocol_To_Buffer; *) (* *) (*----------------------------------------------------------------------*) VAR LS : INTEGER; Transfer_Protocol : Transfer_Type; Trans_Mode : STRING[10]; End_Of_Protocol : BOOLEAN; Delim : CHAR; BEGIN (* Copy_Protocol_To_Buffer *) (* Get transfer mode *) Get_String( Script_Line, IS, Trans_Mode, Delim ); IF LENGTH( Trans_Mode ) > 0 THEN Trans_Mode := UpperCase( Trans_Mode ) ELSE Trans_Mode := 'Z'; Transfer_Protocol := Default_Transfer_Type; IF Trans_Mode = 'A' THEN Transfer_Protocol := Ascii ELSE IF Trans_Mode = 'X' THEN Transfer_Protocol := Xmodem_Chk ELSE IF Trans_Mode = 'XC' THEN Transfer_Protocol := Xmodem_CRC ELSE IF Trans_Mode = 'Y' THEN Transfer_Protocol := Ymodem ELSE IF Trans_Mode = 'YB' THEN Transfer_Protocol := Ymodem_Batch ELSE IF Trans_Mode = 'T' THEN Transfer_Protocol := Telink ELSE IF Trans_Mode = 'TC' THEN Transfer_Protocol := Telink ELSE IF Trans_Mode = 'M' THEN Transfer_Protocol := Modem7_Chk ELSE IF Trans_Mode = 'MC' THEN Transfer_Protocol := Modem7_CRC ELSE IF Trans_Mode = 'M7' THEN Transfer_Protocol := Modem7_CRC ELSE IF Trans_Mode = 'K' THEN BEGIN Transfer_Protocol := Kermit; Kermit_File_Type_Var := Kermit_Ascii; END ELSE IF Trans_Mode = 'KB' THEN BEGIN Transfer_Protocol := Kermit; Kermit_File_Type_Var := Kermit_Binary; END; Copy_Integer_To_Buffer( ORD( Transfer_Protocol ) + 1 ); END (* Copy_Protocol_To_Buffer *); (*----------------------------------------------------------------------*) (* Extract_Script_Command --- Extract command type from script line *) (*----------------------------------------------------------------------*) PROCEDURE Extract_Script_Command( VAR OK_Script_Command : BOOLEAN ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Extract_Script_Command *) (* *) (* Purpose: Extracts command name from script line *) (* *) (* Calling Sequence: *) (* *) (* Extract_Script_Command( VAR OK_Script_Command : BOOLEAN ); *) (* *) (* OK_Script_Command --- set TRUE if legitimate command *) (* *) (*----------------------------------------------------------------------*) VAR Found : BOOLEAN; L : INTEGER; BEGIN (* Extract_Script_Command *) (* Remove initial, trailing blanks *) Script_Line := LTRIM( TRIM( Script_Line ) ); L := LENGTH( Script_Line ); (* If nothing left, ignore this line *) IF ( L < 1 ) THEN Current_Script_Command := Null_Command ELSE BEGIN (* Append blank to script line *) Script_Line := Script_Line + ' '; (* Pick up command name *) Script_Command_Token := ''; I := 1; WHILE( Script_Line[I] <> ' ' ) DO BEGIN Script_Command_Token := Script_Command_Token + UpCase( Script_Line[I] ); I := I + 1; END; (* Abbreviate command to 8 chars *) IF ( LENGTH( Script_Command_Token ) > 8 ) THEN Script_Command_Token := COPY( Script_Command_Token, 1, 8 ); (* Strip command text from front *) (* of script text line *) I := I + 1; IF ( L - I + 1 ) > 0 THEN Script_Line := COPY( Script_Line, I, L - I + 1 ) ELSE Script_Line := ''; (* Look up command in valid command list *) I := 0; Found := FALSE; REPEAT I := I + 1; Found := ( Script_Command_Token = Script_File_Command_Names[I] ); UNTIL ( Found OR ( I >= Max_Script_File_Commands ) ); IF ( NOT Found ) THEN Current_Script_Command := Bad_Command ELSE Current_Script_Command := Script_File_Commands[I]; END; OK_Script_Command := Current_Script_Command <> Bad_Command; END (* Extract_Script_Command *); (*----------------------------------------------------------------------*) (* Emit_Wait_String_Command --- Emit wait for string command *) (*----------------------------------------------------------------------*) PROCEDURE Emit_Wait_String_Command( VAR OK_Script_Command: BOOLEAN ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Emit_Wait_String_Command *) (* *) (* Purpose: Emit command to wait for specified string *) (* *) (* Calling Sequence: *) (* *) (* Emit_Wait_String_Command( VAR OK_Script_Command : BOOLEAN ); *) (* *) (*----------------------------------------------------------------------*) VAR Qnum : BOOLEAN; IntVal : INTEGER; BEGIN (* Emit_Wait_String_Command *) (* String to wait for *) Copy_String_To_Buffer; (* Null reply string *) Copy_Byte_To_Buffer( 0 ); (* Number of seconds to wait *) IS := IS + 1; Get_Integer( Script_Line, IS, Qnum, IntVal ); IF ( NOT Qnum ) THEN IntVal := 30; Copy_Integer_To_Buffer( IntVal ); (* Failure label *) Copy_Integer_To_Buffer( Script_Buffer_Pos + 3 ); OK_Script_Command := TRUE; END (* Emit_Wait_String_Command *); (*----------------------------------------------------------------------*) (* Emit_If_Command --- Emit IF conditional command *) (*----------------------------------------------------------------------*) PROCEDURE Emit_If_Command( False_Label : INTEGER; VAR OK_Script_Command : BOOLEAN ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Emit_If_Command *) (* *) (* Purpose: Emit IF conditional command *) (* *) (* Calling Sequence: *) (* *) (* Emit_If_Command( False_Label : INTEGER; *) (* VAR OK_Script_Command : BOOLEAN ); *) (* *) (*----------------------------------------------------------------------*) VAR Qnum : BOOLEAN; IntVal : INTEGER; PStr : AnyStr; I : INTEGER; L : INTEGER; Delim : CHAR; Save_IS: INTEGER; NextP : INTEGER; NextP_Bytes: ARRAY[1..2] OF BYTE ABSOLUTE NextP; BEGIN (* Emit_If_Command *) (* Back up 1 byte in script buffer *) (* We overwrite existing instruction *) (* with the proper IF guy here. *) Script_Buffer_Pos := Script_Buffer_Pos - 1; (* Pick up type of condition *) Get_String( Script_Line, IS, PStr, Delim ); L := LENGTH( PStr ); PStr := UpperCase( PStr ); (* No condition -- bad *) IF ( L = 0 ) THEN BEGIN PStr := 'BAD'; L := 3; END; (* Look for NOT *) IF ( PStr = 'NOT' ) THEN BEGIN I := 0; Get_String( Script_Line, IS, PStr, Delim ); IS := IS + 1; L := LENGTH( PStr ); PStr := UpperCase( PStr ); END ELSE I := 1; (* True branch -- next statement *) NextP := Script_Buffer_Pos + 8; (* Analyze condition type *) IF ( L >= 3 ) THEN IF COPY( PStr, 1, 3 ) = 'CON' THEN BEGIN Copy_Byte_To_Buffer( ORD( IfConSy ) ); Copy_Integer_To_Buffer( I ); Copy_Integer_To_Buffer( NextP ); Copy_Integer_To_Buffer( False_Label ); END ELSE IF COPY( PStr, 1, 3 ) = 'WAI' THEN BEGIN Copy_Byte_To_Buffer( ORD( IfFoundSy ) ); Copy_Integer_To_Buffer( I ); Copy_Integer_To_Buffer( NextP ); Copy_Integer_To_Buffer( False_Label ); END ELSE IF COPY( PStr, 1, 3 ) = 'LOC' THEN BEGIN Save_IS := IS; Get_Quoted_String( Script_Line, IS, PStr, Delim ); L := LENGTH( PStr ); IF ( NOT ( Delim IN ['''','"'] ) ) THEN L := 0; Copy_Byte_To_Buffer( ORD( IfLocStrSy ) ); Copy_Integer_To_Buffer( I ); Copy_Integer_To_Buffer( NextP + L + 1 ); Copy_Integer_To_Buffer( False_Label ); IS := Save_IS; Copy_String_To_Buffer; END ELSE IF COPY( PStr, 1, 3 ) = 'REM' THEN BEGIN Save_IS := IS; Get_Quoted_String( Script_Line, IS, PStr, Delim ); L := LENGTH( PStr ); IF ( NOT ( Delim IN ['''','"'] ) ) THEN L := 0; Copy_Byte_To_Buffer( ORD( IfRemStrSy ) ); Copy_Integer_To_Buffer( I ); Copy_Integer_To_Buffer( NextP + L + 1 ); Copy_Integer_To_Buffer( False_Label ); IS := Save_IS; Copy_String_To_Buffer; END ELSE OK_Script_Command := FALSE ELSE OK_Script_Command := FALSE; END (* Emit_If_Command *); (*----------------------------------------------------------------------*) (* Parse_Script_Command --- Parse and convert script to internal code *) (*----------------------------------------------------------------------*) PROCEDURE Parse_Script_Command( VAR OK_Script_Command : BOOLEAN ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Parse_Script_Command *) (* *) (* Purpose: Parse and convert script line to internal code. *) (* *) (* Calling Sequence: *) (* *) (* Parse_Script_Command( VAR OK_Script_Command : BOOLEAN ); *) (* *) (* OK_Script_Command --- set TRUE if legitimate command *) (* *) (*----------------------------------------------------------------------*) VAR Qnum : BOOLEAN; IntVal : INTEGER; ByteVal: BYTE; Quote : CHAR; Delim : CHAR; L : INTEGER; I : INTEGER; J : INTEGER; SvPos : INTEGER; PStr : AnyStr; NextP : INTEGER; NextP_Bytes: ARRAY[1..2] OF BYTE ABSOLUTE NextP; BEGIN (* Parse_Script_Command *) (* Assume command is OK to start *) OK_Script_Command := TRUE; (* Insert command type into buffer *) Copy_Byte_To_Buffer( ORD( Current_Script_Command ) ); (* Pick up and insert command-dependent *) (* information into script buffer. *) IS := 1; CASE Current_Script_Command OF SuspendSy, DelaySy : BEGIN Get_Integer( Script_Line, IS, Qnum, IntVal ); IF ( NOT Qnum ) THEN IntVal := 1; Copy_Integer_To_Buffer( IntVal ); END; CaptureSy, DialSy, DosSy, InputSy, MessageSy, RedialSy, STextSy, TextSy, WaitSy : Copy_String_To_Buffer; RInputSy : BEGIN (* Copy prompt string to script buffer *) Copy_String_To_Buffer; (* Assume echo mode *) I := 1; (* See if NOECHO appears *) Get_String( Script_Line, IS, PStr, Delim ); PStr := UpperCase( PStr ); IF ( Pstr = 'NOECHO' ) THEN I := 0; (* Insert echo/noecho flag in buffer *) Copy_Integer_To_Buffer( I ); END; IfLocStrSy : BEGIN (* Increment IF level *) Script_If_Level := Script_If_Level + 1; Script_If_Stack[Script_If_Level] := -Script_Buffer_Pos; (* Emit a conditional *) Emit_If_Command( 0 , OK_Script_Command ); END; ElseSy : BEGIN IF ( Script_If_Level > 0 ) THEN BEGIN (* Get address of IF statement *) (* Remember offset is negative *) J := -Script_If_Stack[ Script_If_Level ]; (* Back up over Else *) Script_Buffer_Pos := Script_Buffer_Pos - 1; (* Insert GOTO here to branch *) (* around FALSE code. *) Copy_Byte_To_Buffer( ORD( GoToSy ) ); (* Address of GoTo not defined *) (* since we don't know it yet -- *) (* leave it zero, and stuff the *) (* address of cell to receive *) (* fixup address later on IF *) (* stack. *) Script_If_Stack[ Script_If_Level ] := Script_Buffer_Pos + 1; Copy_Integer_To_Buffer( 0 ); (* Fixup FALSE branch address in IF *) NextP := Script_Buffer_Pos + 1; Script_Buffer^[ J + 5 ] := NextP_Bytes[1]; Script_Buffer^[ J + 6 ] := NextP_Bytes[2]; IF Script_Debug_Mode THEN BEGIN WRITELN( Script_Debug_File , ' Fixup at ', ( J + 5 ):4, ' to be ',NextP_Bytes[1]:4, NextP_Bytes[2]:4, ' = ',NextP:8 ); END; END ELSE OK_Script_Command := FALSE; END; EndIfSy : BEGIN IF ( Script_If_Level > 0 ) THEN BEGIN J := Script_If_Stack[ Script_If_Level ]; Script_If_Level := Script_If_Level - 1; (* Fixup GoTo before ELSE or *) (* FALSE branch in original IF *) (* if no else. *) NextP := Script_Buffer_Pos; IF ( J > 0 ) THEN BEGIN Script_Buffer^[ J ] := NextP_Bytes[1]; Script_Buffer^[ J + 1 ] := NextP_Bytes[2]; IF Script_Debug_Mode THEN BEGIN WRITELN( Script_Debug_File , ' Fixup at ', ( J ):4, ' to be ',NextP_Bytes[1]:4, NextP_Bytes[2]:4, ' = ',NextP:8 ); END; END ELSE BEGIN J := -J; Script_Buffer^[ J + 5 ] := NextP_Bytes[1]; Script_Buffer^[ J + 6 ] := NextP_Bytes[2]; IF Script_Debug_Mode THEN BEGIN WRITELN( Script_Debug_File , ' Fixup at ', ( J + 5 ):4, ' to be ',NextP_Bytes[1]:4, NextP_Bytes[2]:4, ' = ',NextP:8 ); END; END; (* Erase EndIf from buffer *) Script_Buffer_Pos := Script_Buffer_Pos - 1; END ELSE OK_Script_Command := FALSE; END; KeySendSy : BEGIN Get_String( Script_Line, IS, PStr, Delim ); L := LENGTH( PStr ); PStr := UpperCase( PStr ); IF ( L > 0 ) THEN BEGIN I := POS( PStr[1] , 'FACS' ); IF ( I > 0 ) THEN BEGIN J := 2; Get_Integer( PStr, J, Qnum, IntVal ); IF ( Qnum AND ( IntVal >= 0 ) AND ( IntVal <= 10 ) ) THEN BEGIN CASE I OF 1: I := 58; 2: I := 103; 3: I := 93; 4: I := 83; END (* Case *); ByteVal := I + IntVal; Copy_Byte_To_Buffer( ByteVal ); END (* Qnum *); END (* I > 0 *); END (* L > 0 *); END; WaitStrSy : Emit_Wait_String_Command( OK_Script_Command ); WhenSy : BEGIN Copy_String_To_Buffer; IS := IS + 1; Copy_String_To_Buffer; END; ReceiveSy : BEGIN Copy_String_To_Buffer; IS := IS + 1; Copy_Protocol_To_Buffer; END; SendSy : BEGIN Copy_String_To_Buffer; IS := IS + 1; Copy_Protocol_To_Buffer; END; RepeatSy : BEGIN (* Increment repeat level *) Script_Repeat_Level := Script_Repeat_Level + 1; (* Remember where repeat starts. *) Script_Repeat_Stack[Script_Repeat_Level] := Script_Buffer_Pos; (* Erase repeat command *) Script_Buffer_Pos := Script_Buffer_Pos - 1; END; UntilSy : BEGIN IF ( Script_Repeat_Level > 0 ) THEN BEGIN (* Pop REPEAT address off stack *) J := Script_Repeat_Stack[ Script_Repeat_Level ]; Script_Repeat_Level := Script_Repeat_Level - 1; (* Emit end of loop test *) Emit_If_Command( J , OK_Script_Command ); END ELSE OK_Script_Command := FALSE; END; WhileSy : BEGIN (* Increment While level *) Script_While_Level := Script_While_Level + 1; Script_While_Stack[Script_While_Level] := Script_Buffer_Pos; (* Emit conditional command *) Emit_If_Command( 0 , OK_Script_Command ); END; EndWhileSy : BEGIN IF ( Script_While_Level > 0 ) THEN BEGIN J := Script_While_Stack[ Script_While_Level ]; Script_While_Level := Script_While_Level - 1; Script_Buffer^[Script_Buffer_Pos] := ORD( GoToSy ); Copy_Integer_To_Buffer( J ); NextP := Script_Buffer_Pos + 1; Script_Buffer^[ J + 5 ] := NextP_Bytes[1]; Script_Buffer^[ J + 6 ] := NextP_Bytes[2]; IF Script_Debug_Mode THEN BEGIN WRITELN( Script_Debug_File , ' Fixup at ', ( J + 5 ):4, ' to be ',NextP_Bytes[1]:4, NextP_Bytes[2]:4, ' = ',NextP:8 ); END; END ELSE OK_Script_Command := FALSE; END; ParamSy : BEGIN Get_String( Script_Line, IS, PStr, Delim ); Copy_Byte_To_Buffer( ORD( PStr[1] ) ); Copy_Byte_To_Buffer( ORD( PStr[2] ) ); IF Delim = '=' THEN IS := IS + 1; L := 0; Script_Buffer_Pos := Script_Buffer_Pos + 1; SvPos := Script_Buffer_Pos; FOR I := IS TO LENGTH( Script_Line ) DO BEGIN L := L + 1; Copy_Byte_To_Buffer( ORD( Script_Line[I] ) ); END; Script_Buffer^[SvPos] := L; END; ELSE; END (* CASE *); END (* Parse_Script_Command *); (*----------------------------------------------------------------------*) (* Fix_Label_References --- Fix up label references in script buffer *) (*----------------------------------------------------------------------*) PROCEDURE Fix_Label_References( VAR OK_Script_Command : BOOLEAN ); (*----------------------------------------------------------------------*) (* *) (* Procedure: Fix_Label_References *) (* *) (* Purpose: Fix up label references in script buffer *) (* *) (* Calling Sequence: *) (* *) (* Fix_Label_References( VAR OK_Script_Command : BOOLEAN ); *) (* *) (* OK_Script_Command --- set TRUE if fixups went OK *) (* *) (*----------------------------------------------------------------------*) BEGIN (* Fix_Label_References *) OK_Script_Command := TRUE; END (* Fix_Label_References *); (*----------------------------------------------------------------------*) BEGIN (* Process_Script *) (* Save current screen *) Save_Screen( Local_Save ); Draw_Menu_Frame( 10, 10, 78, 20, Menu_Frame_Color, Menu_Text_Color, 'Scan script file' ); (* Pick up script file name *) (* if not already supplied *) IF ( LENGTH( Script_File_Name ) = 0 ) THEN BEGIN WRITE('Script file name ? '); READLN( Script_File_Name ); END; (* Fix up script file name *) Script_File_Name := UpperCase( Script_File_Name ); IF ( POS( '.', Script_File_Name ) = 0 ) THEN Script_File_Name := Script_File_Name + '.SCR'; (* See if script file exists *) ASSIGN( Byte_File , Script_File_Name ); (*$I-*) RESET ( Byte_File ); (*$I+*) IF ( Int24Result <> 0 ) THEN BEGIN WRITELN(' '); WRITELN('Script file ',Script_File_Name,' not found.'); WRITELN(' '); Really_Wait_String := FALSE; Script_Suspend_Time := 0.0; Script_File_Mode := FALSE; (* Restore previous screen *) DELAY( Two_Second_Delay ); Restore_Screen( Local_Save ); Reset_Global_Colors; (* Quit now *) EXIT; END ELSE BEGIN WRITELN(' '); WRITELN('Beginning scan of script file ',Script_File_Name); WRITELN(' '); END; (* Get size of script file. *) (* Allocate command buffer of *) (* same length to hold compiled *) (* script commands. *) Script_Buffer_Size := FileSize( Byte_File ); CLOSE( Byte_File ); IF ( Script_File_Name = 'ZZBOGUS.SCR' ) THEN BEGIN ASSIGN ( Script_Debug_File , 'ZZBOGUS.DBG' ); REWRITE( Script_Debug_File ); Script_Debug_Mode := TRUE; END ELSE Script_Debug_Mode := FALSE; GetMem( Script_Buffer , Script_Buffer_Size ); (* Current offset in script buffer *) Script_Buffer_Pos := 0; (* No labels yet defined *) Script_Label_Count := 0; (* All stacks empty *) Script_Repeat_Level := 0; Script_If_Level := 0; Script_While_Level := 0; (* Open script file as text file *) ASSIGN( Script_File , Script_File_Name ); (*$I-*) RESET ( Script_File ); (*$I+*) (* Read and compile lines from *) (* script file *) REPEAT (* Read script line *) READLN( Script_File , Script_Line ); Saved_Script_Line := Script_Line; OK_Script_Command := TRUE; (* Check for serious read error *) IF Int24Result <> 0 THEN OK_Script_Command := FALSE (* Skip comment lines *) ELSE IF ( LENGTH( Script_Line ) > 0 ) THEN IF ( Script_Line[1] <> '*' ) THEN (* Parse and store compiled command *) BEGIN IF Script_Debug_Mode THEN BEGIN WRITELN( Script_Debug_File , '--- next statement --- ' ); WRITELN( Script_Debug_File , '<', Script_Line, '>' ); WRITELN( Script_Debug_File , '--- '); END; Extract_Script_Command( OK_Script_Command ); IF OK_Script_Command THEN Parse_Script_Command ( OK_Script_Command ); IF ( NOT Ok_Script_Command ) THEN BEGIN WRITELN('>>> Error in the following script line: '); WRITELN( Saved_Script_Line ); WRITE('Hit any key to continue ... '); READ( Kbd, Ch ); IF ( ORD( Ch ) = ESC ) AND KeyPressed THEN READ( Kbd, Ch ); END; END; UNTIL ( EOF( Script_File ) OR ( NOT OK_Script_Command ) ); (* Close script file. *) (*$I-*) CLOSE( Script_File ); (*$I+*) I := Int24Result; (* Drop "finish script" command *) (* into script buffer. *) IF Script_Debug_Mode THEN WRITELN( Script_Debug_File , '--- Exit statement follows ... '); Copy_Byte_To_Buffer( ORD( ExitSy ) ); (* Check if stacks empty. If not, *) (* error from unclosed loop. *) OK_Script_Command := OK_Script_Command AND ( Script_Repeat_Level = 0 ) AND ( Script_If_Level = 0 ) AND ( Script_While_Level = 0 ); (* Fix up label references *) IF OK_Script_Command THEN Fix_Label_References( OK_Script_Command ); (* Now point to start of buffer *) Script_Buffer_Pos := 0; (* If everything OK, allow script *) (* to execute, else release buffer. *) Really_Wait_String := FALSE; Script_Suspend_Time := 0.0; IF OK_Script_Command THEN BEGIN Script_File_Mode := TRUE; WRITELN('Script file OK.'); END ELSE BEGIN WRITELN('Script file will not be executed.'); Script_File_Mode := FALSE; FREEMEM( Script_Buffer , Script_Buffer_Size ); END; (* Restore previous screen *) DELAY( Two_Second_Delay ); Restore_Screen( Local_Save ); Reset_Global_Colors; IF Script_Debug_Mode THEN CLOSE( Script_Debug_File ); END (* Process_Script *);