home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / pibterm / pibt41s3.arc / PROCESS2.MOD < prev    next >
Encoding:
Text File  |  1988-02-05  |  31.1 KB  |  860 lines
  1. (*----------------------------------------------------------------------*)
  2. (*    Parse_Declare_Command --- Parse DECLARE var type script command   *)
  3. (*----------------------------------------------------------------------*)
  4.  
  5. FUNCTION Parse_Declare_Command : BOOLEAN;
  6.  
  7. VAR
  8.    Token          : AnyStr;
  9.    Token_Type     : OperandType;
  10.    B              : BOOLEAN;
  11.    Name           : AnyStr;
  12.    Type_It        : OperandType;
  13.    Oper_Type      : OperType;
  14.    I              : LONGINT;
  15.  
  16. BEGIN (* Parse_Declare_Command *)
  17.  
  18.    B := Get_Next_Token( Name , Token_Type , Oper_Type , I );
  19.  
  20.    IF ( NOT B ) THEN
  21.       BEGIN
  22.          Parse_Declare_Command := FALSE;
  23.          Parse_Error( S11 );
  24.          EXIT;
  25.       END;
  26.  
  27.    B := Get_Next_Token( Token , Token_Type , Oper_Type , I );
  28.  
  29.    IF ( NOT B ) THEN
  30.       BEGIN
  31.          Parse_Declare_Command := FALSE;
  32.          Parse_Error( S12 );
  33.          EXIT;
  34.       END;
  35.  
  36.    Token := UpperCase( Token );
  37.  
  38.    IF Token = 'STRING' THEN
  39.       Type_It := String_Variable_Type
  40.    ELSE IF Token = 'INTEGER' THEN
  41.       Type_It := Integer_Variable_Type
  42.    ELSE
  43.       BEGIN
  44.          Parse_Error( S12 );
  45.          Parse_Declare_Command := FALSE;
  46.          EXIT;
  47.       END;
  48.  
  49.    INC( Script_Variable_Kount );
  50.    Script_Variable_MaxKount := MAX ( Script_Variable_MaxKount ,
  51.                                      Script_Variable_Kount );
  52. {--IMP
  53.    IF Script_Debug_Mode THEN
  54.       WRITELN( Script_Debug_File , '--- Declare:  Name = ',Name,
  55.                                    ', Type = ', Token, ', Index = ',
  56.                                    Script_Variable_Kount );
  57. }
  58.    WITH Script_Vars[Script_Variable_Kount] DO
  59.       BEGIN
  60.          Var_Name   := UpperCase( Name );
  61.          Var_Type   := Type_It;
  62.       END;
  63.  
  64.    Parse_Declare_Command := TRUE;
  65.                                    (* Store variable name *)
  66.    Copy_Byte_To_Buffer( 0 );
  67.    Copy_Byte_To_Buffer( LENGTH( Name ) );
  68.  
  69.    FOR I := 1 TO LENGTH( Name ) DO
  70.       Copy_Byte_To_Buffer( ORD( Name[I] ) );
  71.  
  72.                                    (* Store variable index *)
  73.  
  74.    Copy_Integer_To_Buffer( Script_Variable_Kount  , IntegerConsOnly );
  75.  
  76.                                    (* Store variable type  *)
  77.  
  78.    Copy_Integer_To_Buffer( ORD( Type_It ) , IntegerConsOnly );
  79.  
  80.                                    (* Pick up initial value if any *)
  81.  
  82.    B := Get_Next_Token( Token , Token_Type , Oper_Type , I );
  83.  
  84.                                    (* Store initial value  *)
  85.    IF ( NOT B ) THEN
  86.       CASE Type_It OF
  87.          String_Variable_Type : Token := '';
  88.          Integer_Variable_Type: Token := ^@^@^@^@;
  89.       END (* CASE *)
  90.    ELSE
  91.       IF ( Type_It = Integer_Variable_Type ) THEN
  92.          IF ( Token_Type <> Integer_Constant_Type ) THEN
  93.             BEGIN
  94.                Parse_Error( S25 );
  95.                Parse_Declare_Command := FALSE;
  96.                EXIT;
  97.             END
  98.          ELSE
  99.             BEGIN
  100.                MOVE( I, Token[1], SIZEOF( LONGINT ) );
  101.                TOKEN[0] := CHR( SIZEOF( LONGINT ) );
  102.             END;
  103.  
  104.    Copy_String_To_Buffer( Token, String_Constant_Type, LongZero );
  105.  
  106. END   (* Parse_Declare_Command *);
  107.  
  108. (*----------------------------------------------------------------------*)
  109. (*    Parse_Set_Command --- Parse SET var=expression script command     *)
  110. (*----------------------------------------------------------------------*)
  111.  
  112. FUNCTION Parse_Set_Command ( Stop_Token : AnyStr ): BOOLEAN;
  113.  
  114. VAR
  115.    Token          : AnyStr;
  116.    Token_Type     : OperandType;
  117.    Result_Type    : OperandType;
  118.    SResult_Type   : OperandType;
  119.    B              : BOOLEAN;
  120.    Oper_Type      : OperType;
  121.    I              : LONGINT;
  122.  
  123. BEGIN (* Parse_Set_Command *)
  124.  
  125.    Result_Index      := 0;
  126.    Parse_Set_Command := FALSE;
  127.  
  128.    IF ( Get_Next_Token( Token, Token_Type, Oper_Type, Result_Index ) ) THEN
  129.       IF ( Result_Index > 0 ) THEN
  130.          BEGIN
  131.             Copy_Integer_To_Buffer( Result_Index , IntegerConsOnly );
  132.             Result_Type := Script_Vars[Result_Index].Var_Type;
  133.             B           := Get_Next_Token( Token, Token_Type, Oper_Type , I );
  134.             IF B THEN
  135.                BEGIN
  136.                   B := Parse_Expression( Stop_Token );
  137.                   IF B THEN
  138.                      BEGIN
  139.                         B := Check_Types( SResult_Type );
  140.                         IF B THEN
  141.                            BEGIN
  142.                               B := ( Result_Type = SResult_Type );
  143.                               IF ( NOT B ) THEN
  144.                                  Parse_Error( S8 + COPY( S13, 2, LENGTH( S13 ) - 1 ) );
  145.                            END;
  146.                      END;
  147.                END;
  148.             Parse_Set_Command := B;
  149.          END
  150.       ELSE
  151.          Parse_Error( S8 + COPY( S5, 2, LENGTH( S5 ) - 1 ) )
  152.    ELSE
  153.       Parse_Error( S8 + COPY( S9, 2, LENGTH( S9 ) - 1 ) );
  154.  
  155. END   (* Parse_Set_Command *);
  156.  
  157. (*----------------------------------------------------------------------*)
  158. (*    Extract_Script_Command --- Extract command type from script line  *)
  159. (*----------------------------------------------------------------------*)
  160.  
  161. PROCEDURE Extract_Script_Command( VAR OK_Script_Command : BOOLEAN );
  162.  
  163. (*----------------------------------------------------------------------*)
  164. (*                                                                      *)
  165. (*     Procedure:  Extract_Script_Command                               *)
  166. (*                                                                      *)
  167. (*     Purpose:    Extracts command name from script line               *)
  168. (*                                                                      *)
  169. (*     Calling Sequence:                                                *)
  170. (*                                                                      *)
  171. (*        Extract_Script_Command( VAR OK_Script_Command : BOOLEAN );    *)
  172. (*                                                                      *)
  173. (*           OK_Script_Command --- set TRUE if legitimate command       *)
  174. (*                                                                      *)
  175. (*----------------------------------------------------------------------*)
  176.  
  177. VAR
  178.    Found   : BOOLEAN;
  179.    L       : INTEGER;
  180.    I       : INTEGER;
  181.    J       : INTEGER;
  182.    OldOnly : BOOLEAN;
  183.  
  184. LABEL 1;
  185.  
  186. BEGIN (* Extract_Script_Command *)
  187.  
  188.                                    (* Remove initial, trailing blanks *)
  189.  
  190.    Script_Line := LTRIM( TRIM( Script_Line ) );
  191.    L           := LENGTH( Script_Line );
  192.  
  193.                                    (* If nothing left, ignore this line *)
  194.  
  195.    IF ( L < 1 ) THEN
  196.       Current_Script_Command := Null_Command
  197.    ELSE
  198.       BEGIN
  199.                                    (* Append blank to script line *)
  200.  
  201.          Script_Line := Script_Line + ' ';
  202.  
  203.                                    (* Pick up command name        *)
  204.  
  205.          Script_Command_Token := '';
  206.          I                    := 1;
  207.  
  208.          WHILE ( ( Script_Line[I] <> ' ' ) AND ( Script_Line[I] <> '(' ) ) DO
  209.             BEGIN
  210.                IF ( I <= 8 ) THEN
  211.                   Script_Command_Token := Script_Command_Token +
  212.                                           UpCase( Script_Line[I] );
  213.                INC( I );
  214.             END;
  215.                                    (* Check for missing 'Set' in      *)
  216.                                    (* assignment statement by looking *)
  217.                                    (* for '='.                        *)
  218.  
  219.          IF ( I < LENGTH( Script_Line ) ) THEN
  220.             BEGIN
  221.                J := I;
  222.                WHILE ( ( J <= LENGTH( Script_Line ) ) AND
  223.                        ( Script_Line[J] = ' ' ) ) DO
  224.                   INC( J );
  225.                IF ( J <= LENGTH( Script_Line ) ) THEN
  226.                   IF ( Script_Line[J] = '=' ) THEN
  227.                      BEGIN
  228.                         Current_Script_Command := SetSy;
  229.                         GOTO 1;
  230.                      END;
  231.             END;
  232.                                    (* Strip command text from front *)
  233.                                    (* of script text line           *)
  234.  
  235.          DELETE( Script_Line, 1, PRED( I ) );
  236.  
  237.                                    (* See if first character of command *)
  238.                                    (* is $.  If so, scan only built-in  *)
  239.                                    (* script commands list.             *)
  240.  
  241.          IF ( Script_Command_Token[1] = '$' ) THEN
  242.             BEGIN
  243.                OldOnly := TRUE;
  244.                DELETE( Script_Command_Token, 1, 1 );
  245.             END
  246.          ELSE
  247.             OldOnly := FALSE;
  248.                                    (* Look up command in user-defined *)
  249.                                    (* commands list first.            *)
  250.          Found := FALSE;
  251.  
  252.          IF ( NOT OldOnly ) THEN
  253.             BEGIN
  254.  
  255.                I := 1;
  256.  
  257.                WHILE( ( I <= Script_New_Command_Count ) AND ( NOT Found ) ) DO
  258.                   BEGIN
  259.                      Found := ( Script_Command_Token = Script_New_Commands[I] );
  260.                      INC( I );
  261.                   END;
  262.  
  263.                IF Found THEN
  264.                   Current_Script_Command := ExeNewSy;
  265.  
  266.             END;
  267.                                    (* Look up command in built-in command *)
  268.                                    (* list if not in user-defined list    *)
  269.          IF ( NOT Found ) THEN
  270.             BEGIN
  271.  
  272.                I := 0;
  273.  
  274.                REPEAT
  275.                   INC( I );
  276.                   Found := ( Script_Command_Token = Script_File_Command_Names[I] );
  277.                UNTIL  ( Found OR ( I >= Max_Script_File_Commands ) );
  278.  
  279.                IF ( NOT Found ) THEN
  280.                   Current_Script_Command := Bad_Command
  281.                ELSE
  282.                   Current_Script_Command := Script_File_Commands[I];
  283.  
  284.             END;
  285.  
  286.       END;
  287.  
  288. 1:
  289.    Length_Script_Line := LENGTH( Script_Line );
  290.    OK_Script_Command  := ( Current_Script_Command <> Bad_Command );
  291.  
  292. END   (* Extract_Script_Command *);
  293.  
  294. (*----------------------------------------------------------------------*)
  295. (*      Emit_Wait_String_Command --- Emit wait for string command       *)
  296. (*----------------------------------------------------------------------*)
  297.  
  298. PROCEDURE Emit_Wait_String_Command( VAR OK_Script_Command: BOOLEAN );
  299.  
  300. (*----------------------------------------------------------------------*)
  301. (*                                                                      *)
  302. (*     Procedure:  Emit_Wait_String_Command                             *)
  303. (*                                                                      *)
  304. (*     Purpose:    Emit command to wait for specified string            *)
  305. (*                                                                      *)
  306. (*     Calling Sequence:                                                *)
  307. (*                                                                      *)
  308. (*        Emit_Wait_String_Command( VAR OK_Script_Command : BOOLEAN );  *)
  309. (*                                                                      *)
  310. (*----------------------------------------------------------------------*)
  311.  
  312. VAR
  313.    Qnum    : BOOLEAN;
  314.    IntVal  : LONGINT;
  315.    IntType : INTEGER;
  316.    QGotS   : BOOLEAN;
  317.  
  318. BEGIN (* Emit_Wait_String_Command *)
  319.  
  320.                                    (* String to wait for *)
  321.  
  322.    Get_And_Copy_String_To_Buffer( FALSE, TRUE, QGotS );
  323.  
  324.                                    (* Null reply string  *)
  325.    Copy_Byte_To_Buffer( 0 );
  326.    Copy_Byte_To_Buffer( 0 );
  327.                                    (* Number of seconds to wait *)
  328.  
  329.    Get_Integer( Qnum, IntVal, IntType, FALSE );
  330.  
  331.    IF ( NOT Qnum ) THEN
  332.       BEGIN
  333.          IntVal  := 0;
  334.          IntType := IntegerConstant;
  335.       END;
  336.  
  337.    Copy_Integer_To_Buffer( IntVal , IntType );
  338.  
  339.                                    (* Failure label *)
  340.  
  341.    Copy_Integer_To_Buffer( Script_Buffer_Pos + SUCC( SIZEOF( IntVal ) ) ,
  342.                            IntegerConsOnly );
  343.  
  344.    OK_Script_Command := TRUE;
  345.  
  346. END   (* Emit_Wait_String_Command *);
  347.  
  348. (*----------------------------------------------------------------------*)
  349. (*         Emit_WaitList_Command --- Emit WaitList command              *)
  350. (*----------------------------------------------------------------------*)
  351.  
  352. PROCEDURE Emit_WaitList_Command( VAR OK_Script_Command: BOOLEAN );
  353.  
  354. (*----------------------------------------------------------------------*)
  355. (*                                                                      *)
  356. (*     Procedure:  Emit_WaitList_Command                                *)
  357. (*                                                                      *)
  358. (*     Purpose:    Emit command to wait for specified strings           *)
  359. (*                                                                      *)
  360. (*     Calling Sequence:                                                *)
  361. (*                                                                      *)
  362. (*        Emit_WaitList_Command( VAR OK_Script_Command : BOOLEAN );     *)
  363. (*                                                                      *)
  364. (*----------------------------------------------------------------------*)
  365.  
  366. VAR
  367.    Qnum    : BOOLEAN;
  368.    IntVal  : LONGINT;
  369.    IntType : INTEGER;
  370.    ICountP : INTEGER;
  371.    SCount  : BYTE;
  372.    QGotS   : BOOLEAN;
  373.    MaxP    : INTEGER;
  374.    I       : LONGINT;
  375.  
  376. BEGIN (* Emit_WaitList_Command *)
  377.  
  378.                                    (* Get variable index to receive *)
  379.                                    (* waitlist index                *)
  380.    OK_Script_Command := FALSE;
  381.  
  382.    Get_Integer( QNum, I, IntType, TRUE );
  383.  
  384.    IF ( NOT Qnum ) THEN
  385.       BEGIN
  386.          IF ( IntType = IntegerMissing ) THEN
  387.             Parse_Error( S8 + COPY( S9, 2, LENGTH( S9 ) - 1 ) );
  388.          EXIT;
  389.       END;
  390.                                    (* Copy result index to buffer *)
  391.  
  392.    Copy_Integer_To_Buffer( I , IntType );
  393.  
  394.                                    (* Leave space for # strings *)
  395.    ICountP  := Script_Buffer_Pos;
  396.    Copy_Byte_To_Buffer( 0 );
  397.                                    (* Get strings to wait for; *)
  398.                                    (* may be strings or string *)
  399.                                    (* variables.               *)
  400.  
  401.    OK_Script_Command := TRUE;
  402.    SCount            := 0;
  403.    QGots             := TRUE;
  404.                                    (* Get legitimate waitstrings *)
  405.  
  406.    WHILE( QGots AND OK_Script_Command AND ( SCount <= MaxWaitStrings ) ) DO
  407.       BEGIN
  408.          Get_And_Copy_String_To_Buffer( FALSE , FALSE, QGotS );
  409.          IF QGots THEN
  410.             INC( SCount );
  411.       END;
  412.                                    (* Enter count into buffer *)
  413.  
  414.    IntVal            := Script_Buffer_Pos;
  415.    Script_Buffer_Pos := ICountP;
  416.  
  417.    Copy_Byte_To_Buffer( SCount );
  418.  
  419.    Script_Buffer_Pos := IntVal;
  420.                                    (* Failure label *)
  421.  
  422.    Copy_Integer_To_Buffer( Script_Buffer_Pos + SUCC( SIZEOF( IntVal ) ) ,
  423.                            IntegerConsOnly );
  424.  
  425. END   (* Emit_WaitList_Command *);
  426.  
  427. (*----------------------------------------------------------------------*)
  428. (*         Process_Call_List  ---  Process call/execute argument list   *)
  429. (*----------------------------------------------------------------------*)
  430.  
  431. PROCEDURE Process_Call_List(     ScrName          : AnyStr;
  432.                                  ScrType          : OperandType;
  433.                                  ScrIndex         : LONGINT;
  434.                                  ProcIndex        : INTEGER;
  435.                              VAR OK_Script_Command: BOOLEAN );
  436.  
  437. (*----------------------------------------------------------------------*)
  438. (*                                                                      *)
  439. (*     Procedure:  Process_Call_List                                    *)
  440. (*                                                                      *)
  441. (*     Purpose:    Processes call/execute argument list                 *)
  442. (*                                                                      *)
  443. (*     Calling Sequence:                                                *)
  444. (*                                                                      *)
  445. (*        Process_Call_List( VAR OK_Script_Command : BOOLEAN );         *)
  446. (*                                                                      *)
  447. (*----------------------------------------------------------------------*)
  448.  
  449. VAR
  450.    NArgs       : BYTE;
  451.    QGotS       : BOOLEAN;
  452.    Index       : LONGINT;
  453.    Save_VCount : INTEGER;
  454.    V_Type      : OperandType;
  455.    V_Init      : AnyStr;
  456.    Oper_Type   : OperType;
  457.    Token       : AnyStr;
  458.    Token_Type  : OperandType;
  459.    Arg_Type    : Proc_Arg_Type_Vector;
  460.    I           : LONGINT;
  461.  
  462. (*----------------------------------------------------------------------*)
  463.  
  464. PROCEDURE Create_Dummy_Variable;
  465.  
  466. BEGIN (* Create_Dummy_Variable *)
  467.  
  468.    Copy_Byte_To_Buffer( ORD( DeclareSy ) );
  469.  
  470.    INC( Script_Variable_Kount );
  471.    Script_Variable_MaxKount := MAX( Script_Variable_MaxKount ,
  472.                                     Script_Variable_Kount );
  473.  
  474.    Copy_String_To_Buffer ( '$TEMP', String_Constant_Type, LongZero );
  475.    Copy_Integer_To_Buffer( Script_Variable_Kount , IntegerConsOnly );
  476.    Copy_Integer_To_Buffer( ORD( V_Type ), IntegerConsOnly );
  477.    Copy_String_To_Buffer ( V_Init, String_Constant_Type, LongZero );
  478.  
  479. END   (* Create_Dummy_Variable *);
  480.  
  481. (*----------------------------------------------------------------------*)
  482.  
  483. BEGIN (* Process_Call_List *)
  484.                                    (* Remember current variable count *)
  485.  
  486.    Save_VCount := Script_Variable_Kount;
  487.  
  488.                                    (* Get arguments.  If variable,    *)
  489.                                    (* just record index; else         *)
  490.                                    (* generate DeclareSy for constant *)
  491.                                    (* so dummy variable index used.   *)
  492.  
  493.    NArgs     := 0;
  494.    QGots     := TRUE;
  495.  
  496.    WHILE( QGots AND ( NArgs <= MaxScriptArgs ) ) DO
  497.       BEGIN
  498.                                    (* Get next argument. *)
  499.  
  500.          QGots := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  501.  
  502.          IF QGots THEN
  503.             BEGIN
  504.                                    (* Increment argument count. *)
  505.  
  506.                INC( NArgs );
  507.  
  508.                                    (* If variable type, just record index.   *)
  509.                                    (* If constant, generate a dummy variable *)
  510.                                    (* initialized to that constant and       *)
  511.                                    (* record its type.                       *)
  512.  
  513.                CASE Token_Type OF
  514.                   String_Variable_Type,
  515.                   Integer_Variable_Type : BEGIN
  516.                                              Arg_Index[NArgs] := Index;
  517.                                              Arg_Type[NArgs]  := Token_Type;
  518.                                           END;
  519.                   String_Constant_Type  : BEGIN
  520.                                              V_Type := String_Variable_Type;
  521.                                              V_Init := Token;
  522.                                              Create_Dummy_Variable;
  523.                                              Arg_Index[NArgs] := Script_Variable_Kount;
  524.                                              Arg_Type[NArgs]  := V_Type;
  525.                                           END;
  526.                   Integer_Constant_Type : BEGIN
  527.                                              V_Type := Integer_Variable_Type;
  528.                                              V_Init[0] := CHR( SIZEOF( LONGINT ) );
  529.                                              MOVE( Index, V_Init[1], SIZEOF( LONGINT ) );
  530.                                              Create_Dummy_Variable;
  531.                                              Arg_Index[NArgs] := Script_Variable_Kount;
  532.                                              Arg_Type[NArgs]  := V_Type;
  533.                                           END;
  534.                   ELSE
  535.                      Parse_Error( S20 );
  536.                      EXIT;
  537.                END (* CASE *);
  538.  
  539.             END;
  540.  
  541.       END;
  542.                                    (* Put command type back into buffer *)
  543.  
  544.    Copy_Byte_To_Buffer( ORD( Current_Script_Command ) );
  545.  
  546.                                    (* Put script name or call address  *)
  547.                                    (* into buffer.  Also, for CallSy,  *)
  548.                                    (* check that correct # args given, *)
  549.                                    (* and that types are correct.      *)
  550.  
  551.    CASE Current_Script_Command OF
  552.  
  553.       ExecuteSy: Copy_String_To_Buffer ( ScrName, ScrType, ScrIndex );
  554.  
  555.       CallSy   : BEGIN
  556.  
  557.                     Copy_Integer_To_Buffer( ScrIndex, IntegerConsOnly );
  558.  
  559.                     IF ( NArgs <> Script_Procs[ProcIndex].NArgs ) THEN
  560.                        BEGIN
  561.                           Parse_Error( S24 );
  562.                           EXIT;
  563.                        END;
  564.  
  565.                     FOR I := 1 TO NArgs DO
  566.                        WITH Script_Procs[ProcIndex] DO
  567.                           IF ( Type_Ptr^[I] <> Arg_Type[I] ) THEN
  568.                              BEGIN
  569.                                 STR( I , Token );
  570.                                 Parse_Error( 'Argument ' + Token + S13 );
  571.                                 EXIT;
  572.                              END;
  573.  
  574.                  END;
  575.  
  576.    END (* CASE *);
  577.  
  578.                                    (* Enter count into buffer *)
  579.    Copy_Byte_To_Buffer( NArgs );
  580.                                    (* Copy in variable indices *)
  581.    FOR I := 1 TO NArgs DO
  582.       Copy_Byte_To_Buffer( Arg_Index[I] );
  583.  
  584.                                    (* Issue ZapVar command *)
  585.    IF ( NArgs > 0 ) THEN
  586.       IF ( Script_Variable_Kount > Save_VCount ) THEN
  587.          BEGIN
  588.             Copy_Byte_To_Buffer( ORD( ZapVarSy ) );
  589.             Copy_Integer_To_Buffer( Save_VCount + 1       , IntegerConstant );
  590.             Copy_Integer_To_Buffer( Script_Variable_Kount , IntegerConstant );
  591.          END;
  592.                                    (* Restore "real" variable count *)
  593.  
  594.    Script_Variable_Kount := Save_VCount;
  595.  
  596.    OK_Script_Command     := TRUE;
  597.  
  598. END   (* Process_Call_List *);
  599.  
  600. (*----------------------------------------------------------------------*)
  601. (*         Emit_Execute_Command --- Emit Execute command                *)
  602. (*----------------------------------------------------------------------*)
  603.  
  604. PROCEDURE Emit_Execute_Command( VAR OK_Script_Command: BOOLEAN );
  605.  
  606. (*----------------------------------------------------------------------*)
  607. (*                                                                      *)
  608. (*     Procedure:  Emit_Execute_Command                                 *)
  609. (*                                                                      *)
  610. (*     Purpose:    Emit command to execute another script               *)
  611. (*                                                                      *)
  612. (*     Calling Sequence:                                                *)
  613. (*                                                                      *)
  614. (*        Emit_Execute_Command( VAR OK_Script_Command : BOOLEAN );      *)
  615. (*                                                                      *)
  616. (*----------------------------------------------------------------------*)
  617.  
  618. VAR
  619.    NArgs       : BYTE;
  620.    QGotS       : BOOLEAN;
  621.    ScrName     : AnyStr;
  622.    ScrType     : OperandType;
  623.    ScrIndex    : LONGINT;
  624.    Index       : INTEGER;
  625.    Save_VCount : INTEGER;
  626.    V_Type      : OperandType;
  627.    V_Init      : AnyStr;
  628.    Oper_Type   : OperType;
  629.    Token       : AnyStr;
  630.    Token_Type  : OperandType;
  631.  
  632. BEGIN (* Emit_Execute_Command *)
  633.  
  634.                                    (* Back up over ExecuteSy   *)
  635.  
  636.    DEC( Script_Buffer_Pos );
  637.    OK_Script_Command := FALSE;
  638.  
  639.                                    (* Get script name          *)
  640.  
  641.    IF ( NOT Get_Next_Token( ScrName, ScrType, Oper_Type, ScrIndex ) ) THEN
  642.       BEGIN
  643.          Parse_Error( S10 + 'script name.' );
  644.          EXIT;
  645.       END;
  646.                                    (* Make sure script name is *)
  647.                                    (* legit.                   *)
  648.  
  649.    IF ( NOT ( ScrType IN [String_Variable_Type, String_Constant_Type] ) ) THEN
  650.       BEGIN
  651.          Parse_Error( S19 );
  652.          EXIT;
  653.       END;
  654.  
  655.    Process_Call_List( ScrName, ScrType, ScrIndex, 0, OK_Script_Command );
  656.  
  657. END   (* Emit_Execute_Command *);
  658.  
  659. (*----------------------------------------------------------------------*)
  660. (*           Emit_If_Command --- Emit IF conditional command            *)
  661. (*----------------------------------------------------------------------*)
  662.  
  663. PROCEDURE Emit_If_Command(     False_Label       : LONGINT;
  664.                            VAR OK_Script_Command : BOOLEAN );
  665.  
  666. (*----------------------------------------------------------------------*)
  667. (*                                                                      *)
  668. (*     Procedure:  Emit_If_Command                                      *)
  669. (*                                                                      *)
  670. (*     Purpose:    Emit IF conditional command                          *)
  671. (*                                                                      *)
  672. (*     Calling Sequence:                                                *)
  673. (*                                                                      *)
  674. (*        Emit_If_Command(     False_Label       : INTEGER;             *)
  675. (*                         VAR OK_Script_Command : BOOLEAN );           *)
  676. (*                                                                      *)
  677. (*----------------------------------------------------------------------*)
  678.  
  679. VAR
  680.    Qnum         : BOOLEAN;
  681.    IntVal       : LONGINT;
  682.    Token        : AnyStr;
  683.    Token_Type   : OperandType;
  684.    Oper_Type    : OperType;
  685.    Index        : LONGINT;
  686.    I            : LONGINT;
  687.    L            : INTEGER;
  688.    Save_IS      : INTEGER;
  689.    Save_BPos1   : INTEGER;
  690.    Save_BPos2   : INTEGER;
  691.    NextP        : LONGINT;
  692.    NextP_Bytes  : ARRAY[1..4] OF BYTE ABSOLUTE NextP;
  693.    SResult_Type : OperandType;
  694.    Stop_Token   : STRING[8];
  695.    QGotS        : BOOLEAN;
  696.  
  697. (*----------------------------------------------------------------------*)
  698.  
  699. PROCEDURE Short_If( IfType : PibTerm_Command_Type );
  700.  
  701. BEGIN (* Short_If *)
  702.  
  703.    Copy_Byte_To_Buffer   ( ORD( IfType ) );
  704.    Copy_Integer_To_Buffer( I           , IntegerConsOnly );
  705.    Copy_Integer_To_Buffer( NextP       , IntegerConsOnly );
  706.    Copy_Integer_To_Buffer( False_Label , IntegerConsOnly );
  707.  
  708. END   (* Short_If *);
  709.  
  710. (*----------------------------------------------------------------------*)
  711.  
  712. PROCEDURE Long_If( IfType : PibTerm_Command_Type );
  713.  
  714. BEGIN (* Long_If *)
  715.  
  716.    Save_IS := IS;
  717.  
  718.    IF ( NOT Get_Next_Token( Token, Token_Type, Oper_Type, Index ) ) THEN
  719.       BEGIN
  720.          Parse_Error( S10 + 'boolean condition.' );
  721.          EXIT;
  722.       END;
  723.  
  724.    IF ( Token_Type = String_Constant_Type ) THEN
  725.       L := SUCC( LENGTH( Token ) )
  726.    ELSE
  727.       L := 0;
  728.  
  729.    Copy_Byte_To_Buffer   ( ORD( IfType ) );
  730.    Copy_Integer_To_Buffer( I             , IntegerConsOnly );
  731.    Copy_Integer_To_Buffer( NextP + L + 1 , IntegerConsOnly );
  732.    Copy_Integer_To_Buffer( False_Label   , IntegerConsOnly );
  733.  
  734.    IS := Save_IS;
  735.    Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  736.  
  737. END   (* Long_If *);
  738.  
  739. (*----------------------------------------------------------------------*)
  740.  
  741. BEGIN (* Emit_If_Command *)
  742.                                    (* Back up 1 byte in script buffer   *)
  743.                                    (* We overwrite existing instruction *)
  744.                                    (* with the proper IF guy here.      *)
  745.  
  746.    DEC( Script_Buffer_Pos );
  747.  
  748.                                    (* Pick up type of condition *)
  749.  
  750.    IF ( NOT Get_Next_Token( Token, Token_Type, Oper_Type, Index ) ) THEN
  751.       BEGIN
  752.          Parse_Error( S10 + 'boolean condition.' );
  753.          EXIT;
  754.       END;
  755.  
  756.    L    := LENGTH( Token );
  757.    Token := UpperCase( Token );
  758.                                    (* '(' -- complex condition *)
  759.  
  760.    IF ( Token_Type = Left_Paren_Type ) THEN
  761.          BEGIN
  762.  
  763.             Save_BPos1        := Script_Buffer_Pos;
  764.  
  765.             Copy_Byte_To_Buffer   ( 0 );
  766.             Copy_Integer_To_Buffer( 0 , IntegerConsOnly );
  767.             Copy_Integer_To_Buffer( 0 , IntegerConsOnly );
  768.             Copy_Integer_To_Buffer( 0 , IntegerConsOnly );
  769.  
  770.             DEC( IS );
  771.  
  772.             CASE Current_Script_Command OF
  773.  
  774.                ForSy,
  775.                WhileSy  : Stop_Token := 'DO';
  776.                ElseIfSy,
  777.                CaseSy,
  778.                IfOpSy   : Stop_Token := 'THEN';
  779.                ELSE       Stop_Token := '';
  780.  
  781.             END (* CASE *);
  782.  
  783.             OK_Script_Command := Parse_Expression( Stop_Token );
  784.  
  785.             IF OK_Script_Command THEN
  786.                BEGIN
  787.                   OK_Script_Command := Check_Types( SResult_Type );
  788.                   IF OK_Script_Command THEN
  789.                      OK_Script_Command := ( SResult_Type = Integer_Variable_Type );
  790.                   IF ( NOT OK_Script_Command ) THEN
  791.                      Parse_Error( S14 );
  792.                END;
  793.  
  794.             IF OK_Script_Command THEN
  795.                BEGIN
  796.  
  797.                   Save_BPos2        := Script_Buffer_Pos;
  798.                   NextP             := SUCC( Script_Buffer_Pos );
  799.                   Script_Buffer_Pos := Save_BPos1;
  800.                   Copy_Byte_To_Buffer( ORD( IfOpSy ) );
  801.                   Copy_Integer_To_Buffer( 0 , IntegerConsOnly );
  802.                   Copy_Integer_To_Buffer( NextP , IntegerConsOnly );
  803.                   Copy_Integer_To_Buffer( False_Label , IntegerConsOnly );
  804.                   Script_Buffer_Pos := Save_BPos2;
  805.  
  806.                END;
  807.  
  808.             EXIT;
  809.  
  810.          END
  811.       ELSE IF ( Token_Type = Bad_Operand_Type ) THEN
  812.          BEGIN  (* No condition -- bad      *)
  813.             Token := 'BAD';
  814.             L    := 3;
  815.          END;
  816.                                    (* Look for NOT *)
  817.    IF ( Token = 'NOT' ) THEN
  818.       BEGIN
  819.  
  820.          I := 0;
  821.  
  822.          IF ( NOT Get_Next_Token( Token, Token_Type, Oper_Type, Index ) ) THEN
  823.             BEGIN
  824.                Parse_Error( S10 + 'boolean condition.' );
  825.                EXIT;
  826.             END;
  827.  
  828.          L    := LENGTH( Token );
  829.          Token := UpperCase( Token );
  830.  
  831.       END
  832.    ELSE
  833.       I := 1;
  834.                                    (* True branch -- next statement *)
  835.  
  836.    NextP := Script_Buffer_Pos + ( 3 * SIZEOF( LONGINT ) ) + 2;
  837.  
  838.                                    (* Analyze condition type *)
  839.    IF ( L >= 3 ) THEN
  840.       IF      COPY( Token, 1, 3 ) = 'CON' THEN
  841.          Short_If( IfConSy )
  842.       ELSE IF COPY( Token, 1, 3 ) = 'WAI' THEN
  843.          Short_If( IfFoundSy )
  844.       ELSE IF COPY( Token, 1, 3 ) = 'LOC' THEN
  845.          Long_If ( IfLocStrSy )
  846.       ELSE IF COPY( Token, 1, 3 ) = 'REM' THEN
  847.          Long_If ( IfRemStrSy )
  848.       ELSE IF COPY( Token, 1, 3 ) = 'DIA' THEN
  849.          Short_If( IfDialSy )
  850.       ELSE IF COPY( Token, 1, 3 ) = 'IOE' THEN
  851.          Short_If( IfOKSy )
  852.       ELSE IF COPY( Token, 1, 3 ) = 'EXI' THEN
  853.          Long_If ( IfExistsSy )
  854.       ELSE
  855.          OK_Script_Command := FALSE
  856.    ELSE
  857.       OK_Script_Command := FALSE;
  858.  
  859. END   (* Emit_If_Command *);
  860.