{*******************************************************}
{                                                       }
{       WHY not a compiler? by Y [05-04-00]             }
{       Common constants and types                      }
{                                                       }
{       Copyright (c) 1999-2000 CROWELL, Inc.           }
{       All Rights Reserved.                            }
{                                                       }
{*******************************************************}

unit CConstants;

{$I CDEFINES.PAS} {$IFDEF TPC} {$N+} {$ENDIF}

interface

uses Objects;

const
  Version = '0.06 alpha';

type

  {Language specific}

  TReservedWord = (rwUnknown, rwAsm, rwBegin, rwConst, rwDo, rwDownto,
    rwDrop, rwDup, rwElse, rwIf, rwImports, rwInline, rwInt, rwLoop,
    rwPragma, rwRepeat, rwRot, rwString, rwSwap, rwThen, rwTo, rwUntil,
    rwWhile);

  TPreDefinedIdentifier = (idUnknown, idNull, idFalse, idTrue, idsDay,
    idnDay, idsMonth, idnMonth, idsYear, idnYear, idsDate, idsUsDate,
    idsShortDate, idsShortUsDate, idsWhyDate, idsWhyUsDate, idsTime,
    idsFile, idsLine, idnLine, idsName);

  {Compiler error codes}

  TCompilerError = (ceNoErrors, ceUnknownError, ceCommentNotClosed,
    ceStringNotClosed, ceStringConstantExceedsLine, ceConstantOutOfRange,
    ceErrorInRealConstant, ceEndOfFileExpected, ceIdentifierExpected,
    ceSemicolonExpected, ceLoopExpected, ceWhileExpected, ceUntilExpected,
    ceThenExpected, ceRepeatExpected, ceErrorInAsmStatement,
    ceCharacterConstantTooLong, ceIntegerConstantExpected,
    ceRightBracketExpected, ceArraySizeMustBeGreaterThanZero,
    ceStringConstantExpected,

    ceInternalError);

const

  {Stream objects error codes}

  stNoMorePlace = -20;
  stCompilerError = -21;

  {Miscellaneous constants}

  MaxTableSize = 1024; {values/strings/etc per one symbol table}
  ReadBufferSize = 4096; {low level file I/O buffer size}
  SecondBufferSize = 32; {must be 255 or less}
  CaseSensitive = False;
  MinFloat = 3.4e-4932;
  MaxFloat = 1.1e+4932;
  LoCaseDelta = Byte('a') - Byte('A'); {for LoCase and LowerCase}
  UpCaseDelta = -LoCaseDelta;

  {Language-specific constants}

  ReservedWords: array [1..Ord(High(TReservedWord))] of PChar =
    ('asm', 'begin', 'const', 'do', 'downto', 'drop', 'dup', 'else', 'if',
    'imports', 'inline', 'int',  'loop', 'pragma', 'repeat', 'rot', 'string',
    'swap', 'then', 'to', 'until', 'while');

  Delimiters: array [1..30] of char = '!"#$%&''()*+,-./:;<=>?@[\]^{|}~';
  Letters: set of char = ['A'..'Z', 'a'..'z', '_'];
  HexDigits: set of char = ['0'..'9', 'A'..'F', 'a'..'f'];
  Digits: set of char = ['0'..'9'];
  OctDigits: set of char = ['0'..'7'];
  BinDigits: set of char = ['0', '1'];

  SkipChars: set of char = [#0..' '];
  CR = #13;
  LF = #10;

  cCHexPrefix: String[2] = '0x';
  cPasHexPrefix = '$';

  sAdaDoubleLineComment = '--';
  sAsmEscape = '\';
  sAsmEscapeSequences: String = '\\;;'; { xor ax, ax \; zero register }
  sAssignment = ':=';
  sDoubleComment = '/**/';
  sDoubleLineComment = '//';
  sDoublePoint = '..';
  sGreaterEqual = '>=';
  sLeftBracket = '(.';
  sRightBracket = '.)';
  sLessEqual = '<=';
  sNotEqual = '<>';
  sSingleComment = '()';
  sSingleLineComment = '\';
  sStringChars = '""';
  sCharacterChars = ''''''; {nice, eh? ;}
  sStringEscape = '\'; {"Hello\n"}
  sStringEscapeSequences: String = '\\""''''n'#10'r'#13't'#9'b'#8; {"\" \\"}

  {Compiler error messages}

  ErrorMessages: array [TCompilerError] of PChar = ('ok', 'unknown error',
    'comment not closed', 'string not closed', 'string constant exceeds line',
    'constant out of range', 'error in real constant', 'end of file expected',
    'identifier expected', '";" expected', '"loop" expected',
    '"while" expected', '"until" expected', '"then" expected',
    '"repeat" expected', 'error in asm statement',
    'character constant too long', 'integer constant expected',
    'right bracket expected', 'array size must be greater than zero',
    'string constant expected',

    'internal error');

  PreDefinedIdentifiers: array[TPreDefinedIdentifier] of PChar =
    (nil, 'Null', 'False', 'True', '__sDay__', '__nDay__', '__sMonth__',
    '__nMonth__', '__sYear__', '__nYear__', '__sDate__', '__sUSDate__',
    '__sShortDate__', '__sShortUSDate__', '__sWhyDate__', '__sWhyUSDate__',
    '__sTime__', '__sFile__', '__sLine__', '__nLine__', '__sName__');

  idLast = idsName;
  rwLast = rwWhile;

  ShortMonths: array [1..12] of PChar = ('Jan', 'Feb', 'Mar', 'Apr', 'May',
    'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  Months: array [1..12] of PChar = ('January', 'February', 'March', 'April',
    'May', 'June', 'July', 'August', 'Septemnber', 'October', 'November',
    'December');
  ShortDayOfWeeks: array[1..7] of PChar = ('Sun', 'Mon', 'Tue', 'Wed',
    'Thi', 'Fri', 'Sat');
  DayOfWeeks: array[1..7] of PChar = ('Sunday', 'Monday', 'Tuesday',
    'Wednesday', 'Thirsday', 'Friday', 'Saturday');

type

  {Miscellaneous}

  SmallString = String[4]; {short string type}
  CharSet = set of char;
  PString = ^String;
  Float = Extended;
  PFloat = ^Float;

  TTokenKind = (tkUnknown, tkBigDelimiter, tkDelimiter, tkFloat,
    tkIdentifier, tkInteger, tkReservedWord, tkString);

  {TToken}

  TToken = record
    Line, Position: Integer;
    case Kind: TTokenKind of
      tkIdentifier, tkString, tkBigDelimiter:
        (S: String);
      tkDelimiter, tkInteger:
        (I: Longint); {index or integer value}
      tkReservedWord:
        (N: TReservedWord);
      tkFloat:
        (F: Float);
  end;

function IntToStr(Value: LongInt): String;
function LoCase(C: Char): Char;
function LowerCase(S: String): String;
function UpCase(C: Char): Char;
function UpperCase(S: String): String;
function DateTimeString(StringFormat: TPreDefinedIdentifier): String;
procedure FloatVal(S: String; var Value: Float; var Error: Integer);
procedure FreeToken(var Token: TToken);
procedure StringToToken(var Token: TToken; S: String);
function IsPreDefinedIdentifier(S: String): TPredefinedIdentifier;

implementation

uses DOS, Strings;

function IntToStr(Value: LongInt): String;
var
  Temp: String;
begin
  Str(Value, Temp);
  IntToStr := Temp;
end; {IntToStr}

function LoCase(C: Char): Char;
begin
  if (C >= 'A') and (C <= 'Z') then
    C := Char(Byte(C) + LoCaseDelta);
  LoCase := C;
end; {LoCase}

function LowerCase(S: String): String;
var
  i: Integer;
  C: Char;
begin
  for i := 1 to Length(S) do
  begin
    C := S[i];
    {if C in ['A'..'Z'] then}
    if (C >= 'A') and (C <= 'Z') then
      S[i] := Char(Byte(C) + LoCaseDelta);
  end;
  LowerCase := S;
end; {LowerCase}

function UpCase(C: Char): Char;
begin
  if (C >= 'a') and (C <= 'z') then
    C := Char(Byte(C) + UpCaseDelta);
  UpCase := C;
end; {UpCase}

function UpperCase(S: String): String;
var
  i: Integer;
  C: Char;
begin
  for i := 1 to Length(S) do
  begin
    C := S[i];
    {if C in ['A'..'Z'] then}
    if (C >= 'a') and (C <= 'z') then
      S[i] := Char(Byte(C) + UpCaseDelta);
  end;
  UpperCase := S;
end; {UpperCase}

function DateTimeNumber(NumberFormat: TPreDefinedIdentifier): LongInt;
var
  nDay, nMonth, nYear, nDayOfWeek, nHour, nMinute, nSecond, nSec100: Word;
begin
  GetDate(nYear, nMonth, nDay, nDayOfWeek);
  GetTime(nHour, nMinute, nSecond, nSec100);
  DateTimeNumber := 0;
end; {DateTimeNumber}

function DateTimeString(StringFormat: TPreDefinedIdentifier): String;
var
  nDay, nMonth, nYear, nDayOfWeek, nHour, nMinute, nSecond, nSec100: Word;
  sDay, sMonth, sYear, sDayOfWeek, sHour, sMinute, sSecond, Temp: String;

  procedure ReplaceSpacesWithZeros(var S: String);
  var
    i: Integer;
  begin
    for i := 1 to Length(S) do
      if S[i] = ' ' then
        S[i] := '0';
  end; {ReplaceSpacesWithZeros}

begin
  GetDate(nYear, nMonth, nDay, nDayOfWeek);
  GetTime(nHour, nMinute, nSecond, nSec100);

  {convert to strings}
  Str(nDay: 2, sDay); ReplaceSpacesWithZeros(sDay);
  Str(nMonth: 2, sMonth); ReplaceSpacesWithZeros(sMonth);
  Str(nYear: 4, sYear); ReplaceSpacesWithZeros(sYear);
  Str(nHour: 2, sHour); ReplaceSpacesWithZeros(sHour);
  Str(nMinute: 2, sMinute); ReplaceSpacesWithZeros(sMinute);
  Str(nSecond: 2, sSecond); ReplaceSpacesWithZeros(sSecond);

  {form the string needed}
  case StringFormat of
    idsDay: Temp := sDay;
    idsMonth: Temp := StrPas(Months[nMonth]);
    idsYear: Temp := sYear;
    idsDate: Temp := sDay + ' ' + StrPas(ShortMonths[nMonth]) + ' ' + sYear;
    idsUsDate: Temp := StrPas(ShortMonths[nMonth]) + ' ' + sDay + ' ' + sYear;
    idsShortDate: Temp := sDay + '/' + sMonth + '/' + Copy(sYear, 3, 2);
    idsShortUsDate: Temp := sMonth + '/' + sDay + '/' + Copy(sYear, 3, 2);
    idsWhyDate: Temp := sDay + '-' + sMonth + '-' + Copy(sYear, 3, 2);
    idsWhyUsDate: Temp := sMonth + '-' + sDay + '-' + Copy(sYear, 3, 2);

    idsTime: Temp := sHour + ':' + sMinute + ':' + sSecond;
    else Temp := ''
  end;

  {return the result}
  DateTimeString := Temp;
end; {DateTimeString}

{Warning! FloatVal accepts only high quality syntax-correct floating
point numbers with no leading spaces. The only possible error is a
floating point overflow or underflow.
Standard Val procedure cannot be used because it doesn't handle run-
time errors #205 (floating point overflow) and #206 (underflow). Un-
expected error may occur while processing too big or too small floa-
ting point values like 1.2e+4932 or 3.5e-4932.
In Delphi, try..except construction may be used to hook this occasi-
on to report a compiler error.}
procedure FloatVal(S: String; var Value: Float; var Error: Integer);
var
  TempFloat: Float;
  TempInteger, Position: Integer;
  TempString: String;
begin
  TempFloat := 0;

  {cut charasteristic and mantissa}
  Position := Pos('e', LowerCase(S));
  if (Position = 0) then
    TempString := S
  else
    TempString := Copy(S, 1, Position - 1);

  {evaluate it; no errors possible here}
  Val(TempString, TempFloat, Error);

  {cut order}
  if (Position <> 0) then
    TempString := Copy(S, Position + 1, Length(S) - Position)
  else
    TempString := '';

  if (TempString <> '') then
  begin
    if not (TempString[1] in ['+', '-']) then
      TempString := '+' +TempString;

    if (Length(TempString) < 6) then
    begin
      {evaluate order}
      Val(TempString, TempInteger, Error);

      {calculate the final value}
      if (TempInteger > (Ln(MaxFloat) / Ln(10))
        - (Ln(TempFloat) / Ln(10))) then
        Error := Position + Length(TempString)
      else
        if (TempInteger < (Ln(MinFloat) / Ln(10))
          + (Ln(TempFloat) / Ln(10))) then
          Error := Position + Length(TempString)
        else
          TempFloat := TempFloat * Exp(TempInteger * Ln(10));
    end
    else
      Error := Position + 6;
  end;

  if (Error = 0) then
    Value := TempFloat;
end; {FloatVal}

procedure EraseToken(var Token: TToken);
begin
  with Token do
  begin
    {Line := 0; Position := 0;} {8-D}
    Kind := tkUnknown;
    I := 0;
    F := 0;
    S := '';
  end;
end; {EraseTToken}

procedure FreeToken(var Token: TToken);
begin
  EraseToken(Token);
end; {FreeToken}

procedure StringToToken(var Token: TToken; S: String);
begin
  FreeToken(Token);
  Token.S := S;
end; {StringToToken}

function IsReservedWord(S: String): TreservedWord;
var
  i, Temp: TReservedWord;
begin
  Temp := rwUnknown;
  for i := rwUnknown to rwLast do
    if LowerCase(StrPas(ReservedWords[Ord(i)])) = LowerCase(S) then
      Temp := i;
  IsReservedWord := Temp;
end; {IsReservedWord}

function IsPreDefinedIdentifier(S: String): TPredefinedIdentifier;
var
  i, Temp: TPreDefinedIdentifier;
begin
  Temp := idUnknown;
  for i := idUnknown to idLast do
    if LowerCase(StrPas(PreDefinedIdentifiers[i])) = LowerCase(S) then
      Temp := i;
  IsPreDefinedIdentifier := Temp;
end; {IsPreDefinedIdentifier}

end {CConstants}.