Power-Programmierung/CD1.mdf/pascal/library/dos/pibsoft/pibcalc/gettok.pas

Pascal/Delphi Source File | 1986-01-13 | 21.1 KB | 556 lines

(*--------------------------------------------------------------------------*)
(*                  GetTok  --- Get Token from Command Line                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE GetTok( VAR Iline: AnyStr; VAR Ipos: INTEGER );

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  GetTok                                                   *)
(*                                                                          *)
(*     Purpose:    Extracts a token from the command line.                  *)
(*                                                                          *)
(*     Calling Sequence:                                                    *)
(*                                                                          *)
(*        GetTok( VAR Iline: AnyStr; VAR Ipos: INTEGER );                   *)
(*                                                                          *)
(*           Iline  --- command line                                        *)
(*           Ipos   --- current position in command line                    *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        Lookahead                                                         *)
(*        CrackWord                                                         *)
(*        CrackReal                                                         *)
(*        SynErr                                                            *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

(*--------------------------------------------------------------------------*)
(*                  CrackNum --- Get number from command line               *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackNum(      b:      INTEGER;
                         digset: CharSetTy;
                     VAR num:    REAL;
                     VAR len:    INTEGER    );

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  CrackNum                                                 *)
(*                                                                          *)
(*     Purpose:    Extracts a number from the command line.                 *)
(*                                                                          *)
(*     Calling Sequence:                                                    *)
(*                                                                          *)
(*        CrackNum(          b: INTEGER;                                    *)
(*                      digset: CharSetTy;                                  *)
(*                     VAR num: REAL        ;                               *)
(*                     VAR len: INTEGER );                                  *)
(*                                                                          *)
(*            b      --- base for number                                    *)
(*            digset --- set of legal characters for digits                 *)
(*            num    --- resultant number (REAL!)                           *)
(*            len    --- no. digits in number                               *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        ORD                                                               *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
   c: CHAR;

BEGIN  (* CrackNum *)

   num := 0.0;
   len := 0;

   WHILE Iline[Ipos] IN digset DO
      BEGIN

         c   := Iline[Ipos];
         num := b * num;

         IF c IN ['0'..'9'] THEN
            num := num + ORD(c) - ORD('0')
         ELSE
            num := num + ORD(c) - ORD('A') + 10;

         len  := len  + 1;
         Ipos := Ipos + 1;

      END;

END    (* CrackNum *);

(*--------------------------------------------------------------------------*)
(*                  CrackInt --- Get integer from command line              *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackInt( b:       INTEGER;
                    digset:  CharSetTy;
                    flagset: CharSetTy );

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  CrackInt                                                 *)
(*                                                                          *)
(*     Purpose:    Extracts an integer from the command line.               *)
(*                                                                          *)
(*     Calling Sequence:                                                    *)
(*                                                                          *)
(*        CrackInt( b:       INTEGER;                                       *)
(*                  digset:  CharSetTy;                                     *)
(*                  flagset: CharSetTy;                                     *)
(*                                                                          *)
(*            b       --- base for number                                   *)
(*            digset  --- set of legal characters for digits                *)
(*            flagset --- legal terminator for base                         *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        CrackNum                                                          *)
(*        SynErr                                                            *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
   num:  REAL;
   len:  INTEGER;

BEGIN (* CrackInt *)

   CrackNum( b, digset, num, len );

   IF len = 0 THEN SynErr
   ELSE IF num > MaxLint THEN
      Error('Number too big to be integer')
   ELSE
      BEGIN

         IF Iline[Ipos] IN flagset THEN Ipos := Ipos + 1;

         WITH constval DO
            BEGIN
               def := TRUE;
               typ := INT;
               i   := TRUNC( num );
               r   := num;
            END;

         Token := constsy;

      END;

END   (* CrackInt *);

(*--------------------------------------------------------------------------*)
(*            CrackDec --- Get decimal integer from command line            *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackDec;

BEGIN  (* CrackDec *)

   CrackInt( 10, ['0'..'9'], ['D'] );

END    (* CrackDec *);

(*--------------------------------------------------------------------------*)
(*             CrackOct --- Get octal integer from command line             *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackOct;

BEGIN  (* CrackOct *)

   CrackInt( 8, ['0'..'7'], ['B','O'] );

END    (* CrackOct *);

(*--------------------------------------------------------------------------*)
(*             CrackHex --- Get hex integer from command line               *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackHex;

BEGIN  (* CrackHex *)

   CrackInt( 16, ['0'..'9','A'..'F'], ['X'] );

END    (* CrackHex *);

(*--------------------------------------------------------------------------*)
(*              CrackReal --- Get real number from command line             *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackReal;

VAR
   intpart:  REAL;
   intlen:   INTEGER;
   fracpart: REAL;
   fraclen:  INTEGER;
   expon:    REAL;
   explen:   INTEGER;
   expsign:  INTEGER;

LABEL 99;

BEGIN (* CrackReal *)
                                   (* Get part up to '.' if any *)

   CrackNum(10, ['0'..'9'], intpart, intlen);

                                   (* Next char MUST be '.' *)
   IF Iline[Ipos] <> '.' THEN
      BEGIN
         SynErr;
         GOTO 99;
      END;
                                   (* Skip '.' *)
   Ipos := Ipos + 1;
                                   (* Get fractional part after '.' *)

   CrackNum(10, ['0'..'9'], fracpart, fraclen);

                                   (* If no digits found, error *)

   IF ( intlen + fraclen ) = 0 THEN
      BEGIN
         SynErr;
         GOTO 99;
      END;
                                   (* Look for E -- signals exponent *)
   expon   := 0;
   expsign := +1;

   IF Iline[Ipos] = 'E' THEN
      BEGIN
                                   (* Skip past E *)
         Ipos := Ipos + 1;
                                   (* Pick up sign of exponent *)

         IF Iline[Ipos] IN ['+','-'] THEN
            BEGIN
               IF Iline[Ipos] = '-' THEN expsign := -1;
               Ipos := Ipos + 1;
            END;
                                   (* Get numeric value of exponent *)

         CrackNum(10, ['0'..'9'], expon, explen);

                                   (* No digits -- syntax error *)
         IF explen = 0 THEN
            BEGIN
               SynErr;
               GOTO 99;
            END;

      END;
                                   (* Compose real result from parts *)
      WITH constval DO
         BEGIN
            def := TRUE;
            typ := rea;
            i   := 0;
            r   := ( intpart + fracpart * poweri( 10.0, -fraclen ) ) *
                   poweri( 10.0, expsign * TRUNC( expon ) );
         END;

      Token := constsy;

99:

END   (* CrackReal *);

(*--------------------------------------------------------------------------*)
(*                  CrackWord --- Get name from command line                *)
(*--------------------------------------------------------------------------*)

PROCEDURE CrackWord;

LABEL
   1;

VAR
   kw:    Alfa;
   i:     INTEGER;
   found: BOOLEAN;

BEGIN  (* CrackWord *)

   i := 0;
                                   (* Pick up name as letters, digits *)

   WHILE (i < 10 ) AND ( Iline[Ipos] IN ['A'..'Z','0'..'9'] ) DO
      BEGIN
         i     := i + 1;
         kw[i] := Iline[Ipos];
         Ipos  := Ipos + 1;
      END;
                                   (* Blank fill the keyword *)

   FOR i := i + 1 TO 10 DO kw[i] := ' ';

   found := FALSE;
   i     := 0;
                                   (* See if token a built-in name *)

   WHILE ( i < Maxtoknams ) AND ( NOT found ) DO
      BEGIN
         i     := i + 1;
         found := ( kw = toknams[i].name );
      END;
                                   (* If found, save type in Token and *)
                                   (* exit                             *)
   IF found THEN
      BEGIN
         Token := toknams[i].tok;
         GOTO 1;
      END;

   i := 0;
                                   (* Check user function names        *)

   WHILE ( i < Maxuserfuncs ) AND ( NOT found ) DO
      BEGIN
         i     := i + 1;
         found := kw = userfuncs[i].name
      END;
                                   (* If found, remember which function *)
                                   (* it was in 'iuserfunc'.            *)
   IF found THEN
      BEGIN
         Token     := userfuncsy;
         iuserfunc := i;
         GOTO 1;
      END;

                                   (* Now try single letter variable    *)
                                   (* If it is, save variable name in   *)
                                   (* 'varnam'.                         *)

   IF ( kw[1] IN ['A'..'Z'] ) AND ( kw[2] = ' ' ) THEN
      BEGIN
         Token  := varsy;
         varnam := kw[1];
         GOTO 1;
      END;

   i := 0;
                                   (* Last, try standard function names  *)

   WHILE (i < Maxstdfuncs) AND NOT found DO
      BEGIN
         i     := i + 1;
         found := ( kw = stdfuncs[i].name );
      END;
                                   (* If found, remember which function  *)
                                   (* in 'istdfunc'.                     *)
   IF found THEN
      BEGIN
         Token    := stdfuncsy;
         istdfunc := i;
         GOTO 1;
      END;
                                   (* If none of the above, syntax error *)
   SynErr;

1:

END   (* CrackWord *);

(*--------------------------------------------------------------------------*)
(*                  Lookahead -- Look ahead in command line                 *)
(*--------------------------------------------------------------------------*)

PROCEDURE Lookahead;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure: Lookahead                                                 *)
(*                                                                          *)
(*     Purpose:   Look ahead in command line                                *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        Lookahead;                                                        *)
(*                                                                          *)
(*     Calls:                                                               *)
(*                                                                          *)
(*        CrackReal                                                         *)
(*        CrackWord                                                         *)
(*        CrackOct                                                          *)
(*        CrackDec                                                          *)
(*        CrackHex                                                          *)
(*                                                                          *)
(*     Remarks:                                                             *)
(*                                                                          *)
(*        When the default base is hexadecimal many ambiguities can arise.  *)
(*        For example, the letters 'A' through 'F' could be either variable *)
(*        names or hex constants. 'DEC' could be either a command or a      *)
(*        hex constant, and '32B' could be either the octal constant        *)
(*        (= 26 dec.) or the hex constant 32B.  The rule is that ALL SUCH   *)
(*        AMBIGUITIES ARE RESOLVED IN FAVOR OF THE INTERPRETATION AS A HEX  *)
(*        CONSTANT.  To override this rule a colon (:) may be used to       *)
(*        prefix the construct.  For example, ':32B' always means the octal *)
(*        constant 32 (=26 dec.), whatever the default base may be.         *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
   spanset:  CharSetTy;
   k:        INTEGER;
   b:        basety;
   lastchar: CHAR;
   colon:    BOOLEAN;

BEGIN (* Lookahead *)

                                   (* See if colon found *)
   colon := ( Iline[Ipos] = ':' );
                                   (* Skip it if so *)
   IF colon THEN Ipos := Ipos + 1;

   spanset := [];
   k       := Ipos;
   b       := base;
                                   (* Scan assuming constant.    *)
                                   (* 'b' is default base.       *)
                                   (* 'k' is temporary Ipos      *)
                                   (* 'lastchar' remembers last  *)
                                   (* character in constant.     *)

   WHILE Iline[k] IN ['A'..'Z','0'..'9'] DO
      BEGIN
         IF k > Ipos THEN spanset := spanset + [lastchar];
         lastchar := Iline[k];
         k        := k + 1;
      END;
                                   (* Change base if last char was *)
                                   (* B, O, X, or D                *)

   IF ( lastchar IN ['D','B','O','X'] ) AND ( ( base <> hex ) OR colon )
      AND ( k > ( Ipos + 1 ) ) THEN
         CASE lastchar OF
            'D':      b := dec;
            'B', 'O': b := oct;
            'X':      b := hex
         END
      ELSE
         spanset := spanset + [lastchar];

                                   (* If '.' stopped scan, try getting *)
                                   (* real number                      *)

   IF Iline[k] = '.' THEN CrackReal

                                   (* Else try integer of appropriate  *)
                                   (* base, if only digits/letters     *)

   ELSE IF ( b = dec ) AND ( spanset <= ['0'..'9'] ) THEN CrackDec
   ELSE IF ( b = oct ) AND ( spanset <= ['0'..'7'] ) THEN CrackOct
   ELSE IF ( b = hex ) AND ( spanset <= ['0'..'9','A'..'F'] ) AND
         ( NOT colon ) THEN CrackHex

                                   (* Else must be name                *)
   ELSE CrackWord;

END   (* Lookahead *);

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

BEGIN (* GetTok *)

                                   (* Skip blanks *)

   WHILE Iline[Ipos] = ' ' DO Ipos := Ipos + 1;

                                   (* Take action on next character  *)
   CASE Iline[Ipos] OF
                                   (* End of line marker encountered *)
      COL: Token := eolsy;

                                   (* Name OR Constant           *)

      'A','B','C','D','E','F','0','1','2','3','4','5','6','7','8','9',
      ':':  Lookahead;

                                   (* Name                       *)

      'G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V',
      'W','X','Y','Z': CrackWord;

      '+': Token := plussy;

      '-': Token := minussy;
                                   (* *  = multiplication,     *)
                                   (* ** = exponentation       *)
      '*': BEGIN
              IF Iline[ Ipos + 1 ] = '*' THEN
                 Token := exponsy
              ELSE
                 Token := starsy;
              IF Token = exponsy THEN Ipos := Ipos + 1;
           END;

      '/': Token := slashsy;

      '(': Token := oparsy;

      ')': Token := cparsy;

      '=': Token := equalssy;

      ',': Token := commasy;

      '$': Token := dollarsy;

                                   (* '.' is accumulator OR start of   *)
                                   (* real number if followed by digit *)

      '.': IF Iline[ Ipos + 1 ] IN ['0'..'9'] THEN
              CrackReal
           ELSE
              Token := periodsy;

   ELSE
      SynErr;

   END;
                                   (* Skip those chars not yet skipped *)

   IF Token IN [plussy..periodsy] THEN Ipos := Ipos + 1;

END   (* GETTOK *);

(*--------------------------------------------------------------------------*)
(*             NextTok --- Advance to next token in command line            *)
(*--------------------------------------------------------------------------*)

PROCEDURE NextTok;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure:  NextTok                                                  *)
(*                                                                          *)
(*     Purpose:    Advance to next token in command line                    *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        NextTok;                                                          *)
(*                                                                          *)
(*     Calls:  GetTok                                                       *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

BEGIN (* NextTok *)

   GetTok( Iline , Ipos );

END   (* NextTok *);