📄 scanf_c.pas
字号:
inc esi
sub bl,'0'+10
add bl,10
jnc @@error
fmul single1000 // finally...
lea eax,[eax+eax*4]
lea eax,[ebx+eax*2]
mov Tmp,eax
inc esi
fiadd Tmp
sub edx,4 // Try next thousand group
jc @@ThDecSep // Less than 4 characters left, exit Thloop
mov ebx,[esi]
jmp @@Thloop
//============ End of ThSep block ====================
// Fractional part start
@@ThdecSep:
add edx,4 // compensate edx check in ThSep block
mov al,[esi]
sub al,'0'
@@bdecSep:
inc ebx // compensate ebx check in ThSep block
@@decSep:
mov ah,DecSep
sub ah,'0'
cmp al,ah
jne @@E // not DecSep, try E
inc esi
dec edx
jz @@OK // edx=0, finished anyway
xor eax,eax // initiate fraction loop
mov ecx,edx // remember edx in ecx
@@fracloop:
mov al,[esi]
sub al,'0'+10
add al,10
jnc @@fracEnd // two checks in one!
inc esi
fmul single10
mov Tmp,eax
fiadd Tmp
dec edx
jnz @@fracloop
xor edi,edi // bring edi back to 0
jmp @@OK // edx = 0, nothing to subtract from ecx
@@fracEnd:
sub ecx,edx // ecx now is number of digits in a fraction part
// Fractional part end
// Exponent start
@@E:
cmp edi,0
mov edi,0
jnz @@OK // edi was not 0, no exp
add ebx,ecx
jz @@Error // ebx=0 and ecx=0 mean no digits found, error
mov al,[esi]
and al,$df // Upcase(al)
cmp al,'E'
jnz @@OK
inc esi
dec edx
jz @@OK // width reached
mov al,[esi]
xor ebx,ebx // use ebx as '-' flag
cmp al,'+'
jz @@pmyes
cmp al,'-'
jnz @@doexp
dec ebx
@@pmyes:
inc esi
dec edx
jz @@OK // width reached
@@doexp:
xor eax,eax // inititate exponent loop
@@exploop:
mov al,[esi]
sub al,'0'+10
add al,10
jnc @@EndExp // two checks in one!
inc esi // accept
lea edi,[edi+4*edi] // edi:=edi*5
lea edi,[2*edi+eax] // edi = edi + edi + eax
dec edx
jnz @@exploop
@@EndExp:
cmp ebx,0 // ebx <> 0 means '-'
jz @@OK
neg edi
// Exponent end
// Combine parts start
// At this point, edi is the exponent and ecx is the fractional part length
@@OK:
mov eax,edi // get exponent into eax
sub eax,ecx // decrease by fractional part length
pop ecx // restore EFactor
add eax,ecx // add to exponent
jz @@NoPower
call FPower10 // multiply st(0) by eax^10
@@NoPower:
mov edx,1 // return Result=1
{$IFOPT Q+}
fstsw ax
and eax,8 // FPU overflow mask
or edx,eax // simply add to edx
{$ENDIF}
jmp @@finish
// Combine parts end
@@error:
fstp st(0) // clear up FPU stack
pop eax // clear up stack
xor edx,edx // set Result to 0
@@finish:
fnclex // clear up
fldcw SaveCW // restore FPU control word
pop eax
mov [eax],esi // store new Str
pop ebx
pop esi
pop edi
@@ret:
mov eax,edx // set result
end;
const singleINFasLongint : longint = $7f800000; // infinity
q_singleNANasLongint : longint = $7fC00000; // quiet NAN
var singleINF : single absolute singleINFasLongint;
q_singleNAN : single absolute q_singleNANasLongint;
type TCharSet = set of AnsiChar;
PInt = ^Integer;
TscRec = packed record // Has size of an integer
Case byte of
0: ( Typ : byte; Size : char; Flags : word;);
1: ( SizeType : word; iFlags : smallInt;);
end;
// Somewhat complicated structure of possible variable types.
const scIllegal = -1; // illegal value, no assignment possible
scChar = vtChar;
scPChar = vtPChar;
scInteger = vtInteger;
scFloat = vtExtended;
scCurrency= vtCurrency;
scCharSet = $7e;
scNspec = $7f; // "n" specifier
scUpperL = Ord('L') shl 8; // Size specifiers
scLowerL = Ord('l') shl 8;
scUpperH = Ord('H') shl 8;
scLowerh = Ord('h') shl 8;
scShortInt= scInteger + scUpperH;
scSmallInt= scInteger + scLowerH;
scLongInt = scInteger + scLowerL;
scInt64 = scInteger + scUpperL;
scReal = scFloat + scUpperH;
scSingle = scFloat + scLowerH;
scDouble = scFloat + scLowerL;
scExtended= scFloat + scUpperL;
scAnsi = scLowerL;
scShort = scLowerH;
scShortSet= scCharSet + scShort;
scAnsiSet = scCharSet + scAnsi;
scString = scPChar + scShort;
scAnsiStr = scPChar + scAnsi;
// Flags constants
scHex = $1;
scDecimal = $2;
scOctal = $4;
scBaseMask = scHex or scDecimal or scOctal;
sc1000Sep = $10;
scIntSpec = $20; // l8, l16, l32, l64 can be used only with integer types
scUnsigned = $40; // Not really implemented, as in BC++
scFormatted = $80; // Formatted currency in DeFormat
scNoAssign =$8000; // Just negative bit
defWidth = MaxInt; // no width limit by default
const
CurrFmts : array [0..3] of string =
( '%s%%m', // 0 = $1
'%%m%s', // 1 = 1$
'%s %%m', // 2 = $ 1
'%%m %s' // 3 = 1 $
);
NegCurrFmts : array [0..15] of string =
( '(%s%%m)', // 0 = ($1)
'-%s%%m', // 1 = -$1
'%s%%m', // 2 = $-1
'%s%%m-', // 3 = $1-
'(%%m%s)', // 4 = (1$)
'%%m%s', // 5 = -1$
'%%m-%s', // 6 = 1-$
'%%m%s-', // 7 = 1$-
'%%m %s', // 8 = -1 $
'-%s %%m', // 9 = -$ 1
'%%m %s-', // 10 = 1 $-
'%s%%m-', // 11 = $ 1-
'%s %%m', // 12 = $ -1
'%%m- %s', // 13 = 1- $
'(%s %%m)', // 14 = ($ 1)
'(%%m %s)' // 15 = (1 $)
);
function StrToCurrF_core(var Buffer : PChar; BufLen : Cardinal;
var Res : currency;
CurrStr : PChar; CurrF, NegCurrF : byte;
DecSep, ThSep : char) : Integer;
var Fmt : string;
FPtr : PChar;
begin
Fmt:=Format( NegCurrFmts[NegCurrF], [CurrStr]); // Try negative first
FPtr:=PChar(Fmt);
{$IFDEF DEFORMAT_EXCEPTIONS}
try
{$ENDIF}
Result:=DeFormat_core(Buffer, Buflen, FPtr, Length(Fmt), [@Res], DecSep, ThSep);
{$IFDEF DEFORMAT_EXCEPTIONS}
except on EConvertError do {nothing}; end;
{$ENDIF}
if (Result=1) then
Case NegCurrF of
1,4,9,14,15 : Res:=-Res;
2,5,8,12 : {Negative and positive formats are compatible} ;
else{3,6,7,10,11,13:}
If Fptr^=#0 then Res:=-Res {scanned FPtr to the end, minus was there!}
else Result:=0; {Something gone wrong!}
end;
If (Result <> 1) then begin {negative did not work, try positive}
Fmt:=Format(CurrFmts[CurrF],[CurrStr]);
FPtr:=PChar(Fmt);
Result:=DeFormat_core(Buffer, Buflen, FPtr, Length(Fmt), [@Res], DecSep, ThSep);
end;
end;
// *********** Common routines *******************************************//
// Scan numerical string (float, decimal, $hex or 0x..)
// Str : points to the first char in a string
// Width : maximum length and assumed to not exceed actual length
// FType : type and length of result, see scXXXX constants
// P : where to put the conversion result if scNoAssign is not set.
// Result : 0 on error, > 0 on success (e.g. scOverflow in $Q+ mode)
function NumScan(var Str : PChar; Width : integer;
FType : integer; P : Pointer;
DecSep, ThSep : char) : integer;
var X : extended;
i64 : int64 absolute X;
L : longint absolute X;
Cur : Currency absolute X;
{$IFOPT Q+} SaveCW, NewCW : word; {$ENDIF}
Negative : boolean;
Label doHex, doDec, doOct, Cont;
begin
With TscRec(FType) do begin
Negative:=False;
Case Str^ of // Get sign, if any
'-' : begin Negative:=True; Inc(Str); Dec(Width); end;
'+' : begin Inc(Str); Dec(Width); end;
end;
Result:=0; // keep compiler happy...
Case Typ of
scInteger :
begin
Case (Flags and scBaseMask) of
scHex : doHex: Result:=Hex_Scanner( Str, i64, Width);
scOctal : doOct: Result:=Oct_Scanner( Str, i64, Width);
scDecimal : doDec: Result:=Dec_Scanner( Str, i64, Width);
else // Base decision block
Case Str^ of
'$' : begin Inc(Str); Dec(Width); goto doHex; end;
'0' : If (Str[1] = 'x') or (Str[1] = 'X') then begin
Inc(Str,2); Dec(Width,2); goto doHex;
end else
if (Flags and scOctal <> 0) then goto doOct else goto doDec;
else goto doDec;
end;
end;
if (Result <= 0) then Exit;
if Negative then
asm
neg dword ptr [X][4]
neg dword ptr [X]
sbb dword ptr [X][4],0
end;
end;
scCurrency :
begin
Result:=Ext_Scanner(Str, Width, 4, DecSep, ThSep);
if Result > 0 then begin
{$IFOPT Q-}
if iFlags >= 0 then begin
if Negative then asm fchs; end;
asm
mov eax, [P]
fistp qword ptr [eax];
fnstsw ax
fnclex // Clear possible exceptions
end;
end else asm fstp; end; // Just clear the FPU stack
{$ELSE}
if Negative then asm fchs; end;
asm
fstcw SaveCW
mov NewCW,$33f // Mask exceptions
fldcw NewCW
fistp qword ptr [X];
fnstsw ax
and eax,8+1 // FPU overflow and invalidop mask
jz @@OK
or [Result],8
@@OK: fldcw SaveCW
fnclex // Clear exceptions
end;
if iFlags <> 0 then Currency(P^):=Cur;
{$ENDIF}
end;
Exit;
end;
scFloat :
begin
if (Width >=3) then begin // Check NAN and INF
Case ( (PInt(Str))^ and $00ffffff) of
$004e414e {'NAN'#0}: begin if Negative then X:=-q_singleNAN else X:=q_singleNAN; Inc(Str,3); Result:=scOK; goto Cont; end;
$00464e49 {'INF'#0}: begin if Negative then X:=-singleINF else X:=singleINF; Inc(Str,3); Result:=scOK; goto Cont; end;
end;
end;
Result:=Ext_Scanner(Str, Width, 0, DecSep, Char(Ord(ThSep)*Integer( (Flags and sc1000Sep) <> 0)));
if (Result <= 0) or (FType < 0) then Exit else begin
if Negative then asm fchs; end;
asm fstp [X]; end;
end;
Cont:
end;
end; {Case Typ}
if (FType > 0) then begin // If scNoAssign not set, assign
Case SizeType of
{$IFOPT R-}
scShortInt : ShortInt(P^):=L;
scSmallInt : SmallInt(P^):=L;
scInteger, scLongInt : LongInt(P^) :=L;
{$ELSE} //signed and unsigned have different ranges
scShortInt : If (Flags and scUnsigned) = 0 then ShortInt(P^):=L else Byte(P^):=L;
scSmallInt : If (Flags and scUnsigned) = 0 then SmallInt(P^):=L else Word(P^):=L;
scInteger, scLongInt : If (Flags and scUnsigned) = 0 then LongInt(P^) :=L else LongWord(P^):=L;
{$ENDIF}
scSingle : Single(P^):=X;
scReal : real48(P^):=X;
scDouble : Double(P^):=X;
scExtended : Extended(P^):=X;
scInt64 : int64(P^):=i64;
end;
end;
end;
end;
// Parse a search-set specifier in format string
// Return value : set of allowed characters
// Format is updated to the first unparsed character
// On error result is False
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -