{*******************************************************} { } { 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}.