Category : Pascal Source Code
Archive   : ALLSWAG4.ZIP
Filename : STRINGS.SWG

SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00081 STRING HANDLING ROUTINES 1 05-28-9313:58ALL SWAG SUPPORT TEAM Convert ASCIIZ to Turbo IMPORT 6 ^&4Ó Function Asc2Str(Var s; Max : Byte): String;ã{ Converts an ASCIIZ String to a Turbo Pascal String }ã{ With a maximum length of max. }ãVarã StArray : Array[1..255] of Char Absolute s;ã Len : Integer;ãbeginã Len := Pos(#0,StArray)-1; { Get the length }ã if (Len > Max) or (Len < 0) then { length exceeds maximum }ã Len := Max; { so set to maximum }ã Asc2Str := StArray;ã Asc2Str[0] := Chr(Len); { Set length }ãend; { Asc2Str }ã 2 05-28-9313:58ALL SWAG SUPPORT TEAM CLEANSTR.PAS IMPORT 6 ^&t Procedure CleanString(Var s:String);ãbeginã fillChar(s,sizeof(s),0);ãend;ã{ I think that I already posted this form once, but here it is again...ã This is the best way, For what the original poster wanted it for- toã clear out a String to Write to a File. Method #1 above will overfillã any subranged String, yours only clears out the current size of theã String (ie if you had s:String; s := 'a'; then your Procedure wouldã only fill the first Character. The last version merely fills theã entire String no matter what the size of it is.ã-Brian Papeã} 3 05-28-9313:58ALL SWAG SUPPORT TEAM COMMA.PAS IMPORT 17 ^&ê { CB> ...I work For a bank and would like to create a Program toã CB> maintain better Record of our Cashier Checks and also anyã CB> stop payments on them..I have done very little Programmingã CB> on pascal. Ok here goes:ã CB> I would like to make the input of numbers to moveã CB> from a fixed point to the left and insert commasã CB> every three digits For monetary figures?ããYou will need to set up a dedicated Character by Character input routine usingãReadKey and controlling the display yourself. After each Character is enteredãexamine it and determine whether or not to add a comma. The following veryãsimple (and untested) routine demonstrates this.ããFor a better way to do such input find and download TCSEL003.* from a PDN nodeãnear you and study the KEYINPUT Unit. You may be able to modify it to doãexactly what you want or perhaps use it as a guide to producing your ownã"bullet proof" input routine.ã}ãUsesã Crt;ããFunction LastPos(ch : Char; S : String): Byte;ã { Returns the last position of ch in S or zero if ch not in S }ã Varã x : Word;ã len : Byte Absolute S;ã beginã x := succ(len);ã Repeatã dec(x);ã Until (x = 0) or (S[x] = ch);ã LastPos := x;ã end; { LastPos }ãããProcedure GetNumber(fieldwidth: Byte);ã Var ch : Char;ã x,y: Byte;ã i : Word;ã st : String;ã beginã st := '';ã Write('Enter a number: ');ã x := WhereX;ã y := WhereY;ã Repeatã ch := ReadKey;ã Case ch ofã '0'..'9': beginã if LastPos(',',st) = length(st)-3 thenã st := st + ',';ã st := st + ch;ã end;ã #8 : beginã delete(st,length(st),1);ã if st[length(st)] = ',' thenã delete(st,length(st),1);ã end;ã #13 : Exit;ã end;ã gotoXY(x,y);ã Write(st:fieldwidth);ã Until False;ã end;ããbeginã Writeln;ã Writeln;ã getnumber(14);ãend. 4 05-28-9313:58ALL SWAG SUPPORT TEAM FIND-STR.PAS IMPORT 5 ^&2
Function FirstOccurence(s : String;ã c : Char) : Integer; Assembler;ãAsmã CLDã LES DI, sã xor CH, CHã xor AH, AHã MOV CL, ES:[DI]ã JCXZ @1ã MOV BX, CXã inC DIã MOV AL, cã REPNE SCASBã JCXZ @1ã SUB BX, CXã XCHG AX, BXã JMP @2ã@1:ã xor AX, AXã@2:ãend;ããbegin { This example returns 7 }ã WriteLn(FirstOccurence('smullen met de pet op dat is pas je ware', 'n'));ãend.ã 5 05-28-9313:58ALL SWAG SUPPORT TEAM PERM-STR.PAS IMPORT 10 ^&Jö {ããHere it is. note that this permutes a set of Characters. if you want toãdo something different, you will have to modify the code, but that shouldãbe easy.ãã}ããTypeã tThingRec = Recordã ch : Char;ã occ : Boolean;ã end;ããVarã Thing : Array[1..255] of tThingRec;ã EntryString : String;ããProcedure Permute(num : Byte);ã{ N.B. Procedure _must_ be called With num = 1;ã it then calls itself recursively,ã incrementing num }ãVarã i : Byte;ãbeginã if num > length(EntryString) thenã beginã num := 1;ã For i := 1 to length(EntryString) doã Write(Thing[i].Ch); { You'll want to direct }ã Writeln; { output somewhere else }ã endã elseã beginã For i := 1 to length(EntryString) doã beginã if (not Thing[i].Occ) thenã beginã Thing[i].Occ := True;ã Thing[i].Ch := EntryString[num];ã Permute(succ(num));ã Thing[i].Occ := False;ã end;ã end;ã end;ãend;ãããbeginã FillChar(Thing,sizeof(Thing),0);ã Write('Enter String of Characters to Permute: ');ã Readln(EntryString);ã Permute(1);ã Writeln;ã Writeln('Done');ãend.ã 6 05-28-9313:58ALL SWAG SUPPORT TEAM SPACES.PAS IMPORT 6 ^&)Ï Function Spaces(NumSpaces : Byte) : String;ããVarã s : String;ããbeginã s[0] := Chr(Numspaces);ã If NumSpaces = 0 Thenã Exit;ã FillChar(s[1], NumSpaces, ' ');ã Spaces := s;ãend;ãã{ãThis still too slow For my taste, though... there's a superfluous Stringãcopy and it still needs 512 Bytes of stack space.ã}ããFunction Spaces(NumSpaces : Byte) : String; Assembler;ããAsmã LES DI, @Resultã CLDã MOV AL, NumSpacesã xor AH, AHã STOSBã XCHG AX, CXã JCXZ @Exitã MOV AL, ' 'ã SHR CX, 1ã JNC @Evenã STOSBã@Even: REP STOSWã@Exit:ãend; { Spaces }ã 7 05-28-9313:58ALL SWAG SUPPORT TEAM ST-CASE1.PAS IMPORT 9 ^&-q today class we are looking at some String routines. Routines toãconvert Strings to upper Case, lower Case,etc.ããRemember to turn off CHECK String Var PARAMETER LENGTHS With {$V-}ãbeFore calling the String Procedures. Turn it back on after callingãthis proc.ãã{--[UPPER CASinG StringS]--}ããProcedure UPCaseL(Var CString:String);ããVar I:Byte;ãã beginã For I:=1 to LENGTH(CString) do CString[I]:=UPCase(CString[I])ã end;ãã{--[LOWER CASinG CharS]--}ããFunction DWNCase(DWNCH:Char):Char;ããbeginãif ('A' <= DWNCH) and (DWNCH <= 'z') then DWNCase:=CHR(orD(DWNCH)+32)ãend;ãã{--[LOWER CASinG StringS]--}ããProcedure DWNCaseL(Var CString:String);ããVar I:Byte;ããbeginã For I:=1 to LENGTH(CString) do CString[I]:=DWNCase(CString[I])ãend;ãã--------------ãif you are offended at the subject line, then please don't read theãmessage. if you think that I, TL, am calling you an idiot because myãsubject line said IDIOT PASCAL LESSONS and you read this message...ãwell, hey, I'm not.ã-------------ã 8 05-28-9313:58ALL SWAG SUPPORT TEAM ST-CASE2.PAS IMPORT 3 ^&à€ Function DnCase(Ch: Char): Char;ãVarã n : Byte Absolute ch;ãbeginã Case ch ofã 'A'..'Z': n := n or 32;ã end;ã DnCase := chr(n);ãend;ã 9 05-28-9313:58ALL SWAG SUPPORT TEAM ST-CASE3.PAS IMPORT 21 ^&‰U {ãHere's a few routines you might find useful For your name problem.ãI call the Function "UpperName" whenever the user presses aãvalid Text key in a name field, but it can also be called justãonce after the entire input String is entered.ã}ãã(* First, some general routines: *)ã(* ----------------------------- *)ããFunction FindStrLength(S: String): Byte;ã{ Finds "S"'s length, not counting trailing spaces }ãVarã StrLen: Byte Absolute S;ã I : Byte;ããbeginã I := StrLen;ã if StrLen > 0 thenã For I := StrLen downto 0 doã if S[I] <> ' ' thenã Break;ã FindStrLength := I;ãend; { FindStrLength }ããFunction WordDelimiter(C: Char): Boolean;ã{ -Checks if "C" qualifies as a String Word-delimiter }ãConstã WordDels: Array[1..34] of Char =ã #32#9#13#10#39',./?;:"<>[]{}-=\+|()*%@&^$#!~';ãVarã I: Integer;ããbeginã WordDelimiter := False;ã For I := 1 to 34 doã if C = WordDels[I] thenã beginã WordDelimiter := True;ã Break;ã end;ãend; { WordDelimiter }ããFunction ParceWord(S: String; Ind, L: Integer): String;ã{ Returns the next Word from "Ind" index in "S" }ãVarã I: Integer;ããbeginã ParceWord := '';ã I := Ind;ã For I := Ind to L doã if WordDelimiter(S[I+1]) thenã beginã ParceWord := Copy(S, Ind, I-Ind+1);ã Break;ã end;ãend; { ParceWord }ããã(* Now down to business: *)ã(* --------------------- *)ããProcedure UpperName(Var S: String);ã{ Converts the first Character in Words to upper Case letters }ãVarã I, L: Integer;ã St : String;ããbeginã L := FindStrLength(S);ã if L = 0 thenã Exit;ã For I := L downto 2 doã if WordDelimiter(S[I-1]) thenã beginã St := StUpCase(ParceWord(S, I, L));ã { you can put in exception Words here... }ã if (St = 'DE') or (St = 'DEN') thenã { ie: Markis de Bleuchamp or van den Haag }ã S[I] := 'd'ã elseã S[I] := UpCase(S[I]);ã end;ã S[1] := UpCase(S[1]);ãend; { UpperName }ãã{ã(The Function "StupCase" is from TurboPower Tpro, but anyãroutine that converts a String to upper Case letters will do).ããPlease note that I had to modify this source beForeãposting it here (it was full of norwegian name styleãidentifiers that only would've confused you), so it's notãtested in the current Form and may contain bugs.ã...But I'm sure you get the general idea. :-)ããposting it here (it was full of norwegian name styleãidentifiers that only would've confused you), so it's notãtested in the current Form and may contain bugs.ã...But I'm sure you get the general idea. :-)ã} 10 05-28-9313:58ALL SWAG SUPPORT TEAM ST-CASE4.PAS IMPORT 41 ^&Ü { Many will recall a series of messages that I posted a few weeksã ago regarding the Implementation of XLAT in BAsm.ãã I have revisited it With the idea of using it not For filteringã but just For up- and low-casing Pascal Strings. I came With aã pure Assembler Function With a loop of only 4 instructions (TXlatã in Unit TXLATU.PAS). The acCompanying Program TXLATE1.PAS showsã examples on how to use TXlat both For up- or low-casing a String.ãã The intriguing finding was that when I bench-marked it againstã other Assembler Upcasing routines posted in this echo or againstã the one in Hax 144 in PC-Techniques (Vol.3, No.6, Feb 1993, p.40)ã TXlat got to be 20-30% faster! if anyone is interested I couldã upload the benchmarking routines.ãã So, here is my question: could this possibly be the fastestã routine For String conversion in Turbo Pascal?ãã Please note that XLAT has special requirements respect to theã location of the source and destination buffers as well as theã translation table. Turbo Pascal memory model places globalã Variables in the data segment wh local Variables are located inã the stack segment. The code in TXlat requires that both the tableã and the source buffer be located in the data segment.ãã Another point of interest is that a Pascal String Variabe (Table) isã used as the 256-Byte long table required by XLAT.ãã -Jose- (1:163/513.3)ãã ============================================================================ãã}ã Unit TXLATU;ãã {ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿}ã {³Unit TXlatU.PAS by Jos‚ Campione, Feb.1993.³}ã {³This Unit implements Function TXlat and ³}ã {³declares Variables in the data segment. ³}ã {ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ}ãã Interfaceãã Varã Source, Table : String; {ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿}ã {³This Forces these Variables to be ³}ã {³in the data segment. Both Variables³}ã {³passed to TXlat must be created in ³}ã {³this segment. ³}ã {ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ}ãã Function TXlat(Var Source: String; Var Table: String):String;ãã Implementationãã {ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿}ã {³This Function translates or filters a String as per the Byte values³}ã {³in the Table buffer. It implements the Assembler XLAT instruction. ³}ã {ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ}ã Function TXlat(Var Source: String; Var Table: String):String; Assembler;ã Asmã push ds {preserve data segment}ã lds bx,table {load ds:bx With table address}ã lds si,source {load ds:si With source address}ã {both are in datasegment...}ã les di,@result {load es:di With result}ã cld {si will increment}ã lodsb {load al With length of source}ã stosb {store al in es:di}ã mov cx,ax {assign length of source to counter}ã or cx,cx {if counter = 0}ã jz @end {jump to end}ã @filter: lodsb {load Byte in ax}ã xlat {tans-xlat-e...}ã stosb {store it in destination Array}ã loop @filter {loop back}ã @end: pop ds {restore data segment}ã end;ãã end.ã{ã ---------------------------------------------------------------------ã}ã Program TXLATE1;ãã {ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿}ã {³Program TXlate1.PAS by Jos‚ Campione, Feb.1993.³}ã {³Test Program For Function TXlat in Unit TXlatU ³}ã {³It shows how the same Function can be used For ³}ã {³up-casing of low-casing a String. ³}ã {ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ}ãã Uses TXLATU, HAX144U;ãã Varã UpSource, LowTable, {These must be global Variables}ã LowSource, UpTable : String; {created in the data segment }ã i : Byte;ãã beginãã {ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿}ã {³Set Table For upper Case translation by XLAT³}ã {ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ}ã For i:= 0 to 255 doã if i in [$61..$7A] then UpTable[i]:= Char(i - $20)ã else UpTable[i]:= Char(i);ãã {ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿}ã {³Set Table For lower Case translation by XLAT³}ã {ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ}ã For i:= 0 to 255 doã if i in [$41..$5A] then LowTable[i]:= Char(i + $20)ã else LowTable[i]:= Char(i);ãã LowSource:= 'this is a low-Case String to be up-Cased';ã UpSource:= 'THIS IS AN UP-Case String to BE LOW-CaseD';ãã Writeln(TXlat(LowSource,UpTable));ã Writeln(TXlat(UpSource,LowTable));ãã ReadLn;ãã end.ã 11 05-28-9313:58ALL CHRIS PRIEDE FAST Upper/Justify StringIMPORT 27 ^&Œ` {ã> For some routins you may have.. Stuff like converting a String toã> upperCase, padding a String, and things like that.. Mainly stuff to doã> With Strings, as that seems to be my problem.. if you could, pleaseã> document your source so i can see how it is done.ããã1)The Good Old String UpCase Routine. I'm sure there are at leastã several thousand Programmers, who have independently come up With codeã exactly like this:ã}ããProcedure StrUpr(Var S: String); Assembler;ãAsmã push ds { Save DS on stack }ã lds si, S { Load DS:SI With Pointer to S }ã cld { Clear direction flag - String instr. Forwardã lodsb { Load first Byte of S (String length Byte) }ã sub ah, ah { Clear high Byte of AX }ã mov cx, ax { Move AX in CX }ã jcxz @Done { Length = 0, done }ã mov ax, ds { Set ES to the value in DS through AX }ã mov es, ax { (can't move between two segment Registers) }ã mov di, si { DI and SI now point to the first Char. }ã@UpCase:ã lodsb { Load Character }ã cmp al, 'a'ã jb @notLower { below 'a' -- store as is }ã cmp al, 'z'ã ja @notLower { above 'z' -- store as is }ã sub al, ('a' - 'A') { convert Character in AL to upper Case }ã@notLower:ã stosb { Store upCased Character in String }ã loop @UpCase { Decrement CX, jump if not zero }ã@Done:ã pop ds { Restore DS from stack }ãend;ãã{ã2)Right justify routine. if Length(S) < Width then S will beã padded With spaces on the left.ã}ããProcedure RightJustify(Var S: String; Width: Byte); Assembler;ãAsmã push ds { Save DS }ã lds si, S { Load Pointer to String }ã mov al, [si] { Move length Byte in AL }ã mov ah, Width { Move Width in AH }ã sub ah, al { Subtract }ã jbe @Done { if Length(S) >= Width then Done... }ã push si { Save SI on stack }ã mov cl, alã sub ch, ch { CX = length of the String }ã add si, cx { SI points to the last Character }ã mov dx, dsã mov es, dx { ES = DS }ã mov di, si { DI = SI }ã mov dl, ahã sub dh, dh { DX = number of spaces to padd }ã add di, dx { DI points to the new end of the String }ã std { String ops backward }ã rep movsb { Copy String to the new location }ã pop si { SI points to S }ã mov di, si { DI points to S }ã add al, ah { AL = new length Byte }ã cld { String ops Forward }ã stosb { Store new length Byte }ã mov al, ' 'ã mov cx, dx { CX = number of spaces }ã rep stosb { store spaces }ã@Done:ã pop ds { Restore DS }ãend;ãã{ã I wrote both examples specifically For posting in thisãconference (my regular code is For external Assembler and nowhere Nearlyãas well commented). Both Functions appear to work as advertised andãshould be very fast.ã}ãã 12 05-28-9313:58ALL NORBERT IGL ST-CASE6.PAS IMPORT 17 ^&ðj {ãNORBERT IGLãã> Note that your uppercase characters do not include the german Umlautsã> and overlap sometimes with other foreign characters. There is a DOSã> function call to convert a string to all upcercase letters. Norbertã> Igl and I wrote a ASM end implementation, maybe he could repost his all-ã> Pascal version that conforms to the DOS country information.ãã}ããUnit Upper;ã{ Country-independent upcase-procedures (c) 1992 N.Iglãã Uses the COUNRY=??? from your CONFIG.SYS to get the correct uppercase.ã SpeedUp with a table-driven version to avoid multiple DOS-Calls.ãã Released to the public domain ( FIDO: PASCAL int'l ) in 12/92 }ãããInterfaceããfunction UpCase(ch : char) : Char;ãfunction UpCaseStr(S : String) : String;ããImplementation uses Dos;ããConstã isTableOk : Boolean = FALSE;ãVarã theTable : Array[0..255] of Char;ããProcedure SetUpTable; { called only at Unit-init }ãvarã Regs: Registers;ã x : byte;ãbeginã FillChar(theTable, Sizeof( theTable ), #0); { Fill with NULL }ã For x := 1 to 255 doã theTable[x] := CHAR(x); { predefined values }ã if Lo(DosVersion) < 4 then { n/a in this DOS... }ã begin { use Turbo's Upcase }ã for x := 1 to 255 doã theTable[x] := System.Upcase(CHAR(x));ã exit;ã end;ã Regs.AX := $6521; { "Capitalize String" }ã Regs.CX := 255; { "string"-length }ã Regs.DS := Seg(theTable); { DS:DX... }ã Regs.DX := Ofs(theTable[1]); { ...points to the "string"}ã Intr($21,Regs); { let DOS do it ! }ã isTableOK := (Regs.Flags and FCarry = 0); { OK ? }ãend;ããfunction UpCase(ch : char) : char;ãbeginã UpCase := theTable[BYTE(ch)]ãend;ããfunction UpCaseStr(S : String) : String;ãvar x: Byte;ãbeginã for x := 1 to length(S) doã S[x]:= theTable[BYTE(S[x])];ã UpCaseStr := Sãend;ããbeginã SetUpTableãend.ãã 13 05-28-9313:58ALL SWAG SUPPORT TEAM STR-INFO.PAS IMPORT 17 ^&#ª {ãFunctions returning Strings are generally space wasters. For example,ãsuppose you have :ããFunction UpCaseStr(s : String) : String;ããif you're implementing it in plain Pascal, you'll need 1024 Bytes of dataãat a minimum:ã- 256 Bytes are allocated For "s", the Formal parameterã- 256 Bytes For a local copy of "s" since it was passed as a value parameterã- 256 Bytes For a local Variable of the Type String, working storage to buildã the Function resultã- 256 Bytes For assigning the result to the Function resultã (as in: "UpCaseStr := Result").ããYou can cut this figure by 50% by taking the following steps:ã- (Version 7) Change the parameter header intoã "Function UpCaseStr(Const s : String) : String". Provided you don'tã change "s", no local copy of the String will be created.ã- (Version 6) Implement the routine in Assembler. Requires knowledge ofã Asm, of course - but it generally will do away With the need of allocatingã 256 Bytes of working storage.ããNow you have reduced data space to 512 Bytes: it has become a basicãinput-output Function. One question remains: it is necessary to load theãString to examine the result of such a Function. Suppose we want to figure outãwhether the user has entered a switch on the command line: do we need aãVariable of the Type String to acComplish this? You don't. The followingãsnippet of code will show how: using a 2 Bytes macro, we'll convert a Stringãinto a Pointer to a String. You only have to dereference the Pointer to getãthe result - and save 256 Bytes of data space in the process.ã}ããTypeã PString = ^String;ããFunction StrPtr(Const s : String) : PString;ããInLine(ã $58/ { POP AX }ã $5A); { POP DX }ããVarã i : Integer;ã sp : PString;ã QuietFlag : Boolean;ããbeginã For i := 1 to ParamCount Doã beginã sp := StrPtr(ParamStr(i));ã if (sp^[1] in ['/', '-']) and (UpCase(sp^[2]) = 'Q') thenã QuietFlag := True;ã { Et cetera }ã end;ãend.ã 14 05-28-9313:58ALL SWAG SUPPORT TEAM STRNGSF4.PAS IMPORT 24 ^&Ë{ {ãThis code has been slightly shrunk to fit into one message.ã}ããProgram input;ãUsesã Dos, Crt;ããConstã Word_wrap = 50;ããVarã tick,ã mlines : Integer;ã modem : String[1];ã incom,ã waiting : String[128];ããProcedure outread(avr1, avr2, avr3 : Integer);ããVar { avr1= 1=passWord, 2=normal }ã i,y,o, { avr2= 1=none, 2=Word wrap }ã count:Integer; { avr3= 1=pull from String, 2=none }ã Word:String[10]; Charout:Char;ããbeginã incom:=''; count:=0; mlines:=0;ã if avr3=2 then waiting:='';ã if avr3=1 then if waiting<>'' thenã beginã incom:=waiting;ã waiting:='';ã Write(incom);ã count:=length(incom);ã end;ã modem:=''; TextColor(3);ã While modem<>chr(13) doã beginã Charout:=ReadKey; modem:=Charout;ã Case ord(modem[1]) ofã 13:begin { return }ã Writeln; Exit;ã end;ã 8:begin { backspace }ã if count>0 thenã beginã Write(chr(8)+chr(32)+chr(8));ã delete(incom,count,1);ã count:=count-1;ã end;ã modem:='';ã end;ã 9:begin { tab }ã Write(' '); incom:=incom+' '; count:=count+5;ã modem:='';ã end;ã 10:modem:=''; { line feed }ã 1..26,ã 28..31,ã 128..255:begin { inappropriate Characters }ã modem:='';ã end;ã end;ã if modem<>'' thenã beginã count:=count+1;ã if count 5 then Writeln;ãend; { end of Procedure }ããbeginã ClrScr;ã TextColor(15);ã Write('This is a passWord input: ');ã outread(1,1,2);ã TextColor(11);ã Writeln('Return = ',incom);ã TextColor(15);ã Write('This is a normal input: ');ã outread(2,1,2);ã TextColor(11);ã Writeln('Return = ',incom);ã TextColor(15);ã Writeln('This is a controlled Word-wrap input at length 50:');ã Writeln;ã tick := 0;ã For tick := 1 to 5 doã outread(2, 2, 1);ãend.ã 15 05-28-9313:58ALL KELD R. HANSEN TIDYSTR.PAS IMPORT 4 ^&|q {ãKELD R. HANSENã}ããPROCEDURE TidyString(VAR Str : String); ASSEMBLER;ãASMã LES DI,STRã XOR BH,BHã MOV BL,ES:[DI]ã LEA DI,[DI+BX+1]ã MOV SI,WORD PTR STR-2ã NEG BXã LEA CX,[SI+BX]ã XOR AL,ALã CLDã REP STOSBãEND;ãã{ãwhich fills up the garbage after the current string length with zeroes.ã}ãã 16 05-28-9313:58ALL SWAG SUPPORT TEAM WILDCRD1.PAS IMPORT 14 ^&¸V Program wild_card;ããVarã check:Boolean;ããFunction Wild(flname,card:String):Boolean;ã{Returns True if the wildcard description in 'card' matches 'flname'ãaccording to Dos wildcard principles. The 'card' String MUST have a period!ãExample: Wild('test.tat','t*.t?t' returns True}ããVarã name,temp:String[12];ã c:Char;ã p,i,n,l:Byte;ã period:Boolean;ããbeginã wild:=True;ã {test For special Case first}ã if flname='*.*' then Exit;ã wild:=False;ã p:=pos('.',card);ã i:=pos('.',flname);ã if p > 0 then period:=True else Exit; {not a valid wildcard if no period}ã N:=1;ã Repeatã if card[n]='*' then n:=p-1 elseã if (upCase(flname[n]) <> upCase(card[n])) thenã if card[n]<>'?' then Exit;ã inc(n);ã Until n>=p;ã n:=p+1; {one position past the period of the wild card}ã l:=length(flname);ã inc(i); {one position past the period of the Filename}ã Repeatã if n > length(card) then Exit;ã c:=upCase(card[n]);ã if c='*' then i:=l+1 {in order to end the loop}ã elseã if (upCase(flname[i]) = c) or (c = '?') thenã beginã inc(n);ã inc(i);ã endã else Exit;ã Until i > l;ãã wild:=True;ããend;ããbeginã check:=False;ã check:=wild('TEST.Tat','T*.T?T'); {True}ã Writeln(check);ã check:=wild('TEST.Taq','T*.T?T'); {False}ã Writeln(check);ã check:=wild('12345678.pkt','*.pkt'); {True}ã Writeln(check);ã check:=wild('test.tat','T*.t?'); {False}ã Writeln(check);ã check:=wild('12345678.pkt','1234?678.*'); {True}ã Writeln(check);ããend. 17 05-28-9313:58ALL SWAG SUPPORT TEAM WILDCRD2.PAS IMPORT 14 ^&; {ã> Does anyone know how to pass a wildcard Filename to a parameter String andã> have the code grab the actual full Filename?ããnot quite, but close. Consider the Function Wild below. if you should do aãfindfirst/findnext and run the Function wild on each found name you get whatãyou want.ã}ããFunction Wild(FileName, Card : String) : Boolean;ã{Returns True if the wildcard description in 'card' matches 'flname'ãaccording to Dos wildcard principles. The 'card' String MUST have a period!ãExample: Wild('test.tat','t*.t?t' returns True}ãVarã c : Char;ã p,i,n,l : Byte;ããbeginã Wild := True;ã {test For special Case first}ã if Card = '*.*' thenã Exit;ã Wild := False;ã p := Pos('.', Card);ã i := Pos('.', FileName);ã if p = 0 thenã beginã Writeln('Invalid use of Function "wild". Program halted.');ã Writeln('Wild card must contain a period.');ã Halt;ã end;ã {test the situation beFore the period}ã n := 1;ã Repeatã c := UpCase(Card[n]);ã if c = '*' thenã n := pã elseã if (upCase(FileName[n]) = c) or (c = '?') thenã inc(n)ã elseã Exit;ã Until n >= p;ãã {Now check after the period}ã n := p + 1; {one position past the period of the wild card}ã l := Length(FileName);ã Inc(i); {one position past the period of the Filename}ã Repeatã if n > Length(Card) thenã Exit;ã c := UpCase(Card[n]);ã if c = '*' thenã i := l + 1 {in order to end the loop}ã elseã if (UpCase(FileName[i]) = c) or (c = '?') thenã beginã Inc(n);ã Inc(i);ã endã elseã Exit;ã Until i > l;ãã Wild := True;ãEnd; 18 05-31-9307:16ALL SWAG SUPPORT TEAM Three ways to Uppercase IMPORT 11 ^&gY Three ways to convert a string to uppercase (without international support).ãã{$R-,S-,I- }ããProcedure UpCaseStr0(Var s : String);ããVarã i : Integer;ããBeginã For i := 1 to Length(s) Doã s[i] := UpCase(s[i]);ãend; { UpCaseStr0 }ããProcedure UpCaseStr1(Var s : String);ããVarã i, len : Integer;ããBeginã i := 0;ã len := Ord(s[0]);ã Repeatã Inc(i);ã If i > len Thenã Break;ã If s[i] in ['a'..'z'] Thenã Dec(s[i], 32);ã Until False;ãend; { UpCaseStr1 }ããProcedure UpCaseStr2(Var s : String); Assembler;ããASMã PUSH DSã LDS SI, sã LES DI, sã CLDã XOR AH, AHã LODSBã STOSBã XCHG AX, CXã JCXZ @2ã@1: LODSBã SUB AL, 'a'ã CMP AL, 'z'-'a'+1ã SBB AH, AHã AND AH, 'a'-'A'ã SUB AL, AHã ADD AL, 'a'ã STOSBã LOOP @1ã@2: POP DSãend; { UpCaseStr2 }ããã Procedure Size Execution timing*ã (bytes) (seconds)ãã UpCaseStr0 76 4.32 = 1.00ã UpCaseStr1 67 2.76 = 0.63ã UpCaseStr2 39 1.31 = 0.30ãã *30,000 times on a 40 MHz 386ããWilbertãã--- GEcho 1.00/betaã * Origin: Charge of the Light Bregade (2:281/256.14)ã 19 06-08-9308:29ALL SWAG SUPPORT TEAM Fastest UPPERCASE IMPORT 11 ^&<Ž ã{ The following remains the fastest all-purpose UpperCase routine (using only 32ãbytes): }ãã procedure Upper4(var Str: String);ã InLine(ã $8C/$DA/ { mov DX,DS }ã $5E/ { pop SI }ã $1F/ { pop DS }ã $FC/ { cld }ã $AC/ { lodsb }ã $30/$E4/ { xor AH,AH }ã $89/$C1/ { mov CX,AX }ã $E3/$12/ { jcxz @30 }ã $BB/Ord('a')/Ord('z')/ { mov BX,'za' }ã $AC/ { @15: lodsb }ã $38/$D8/ { cmp AL,BL }ã $72/$08/ { jb @28 }ã $38/$F8/ { cmp AL,BH }ã $77/$04/ { ja @28 }ã $80/$6C/$FF/$20/ { sub BYTE PTR [SI-1],$20 }ã $E2/$F1/ { @28: loop @15 }ã $8E/$DA); { @30: mov DS,DX }ãã{ > *30,000 times on a 40 MHz 386 Tested on a 33 Mhz 386. }ãã 20 07-16-9306:04ALL GUY MCLOUGHLIN String Centering IMPORT 25 ^&…š (*ã===========================================================================ã BBS: Canada Remote SystemsãDate: 06-25-93 (13:52) Number: 25767ãFrom: GUY MCLOUGHLIN Refer#: NONEã To: CHRIS PRIEDE Recvd: NOãSubj: STRING CENTERING ROUTINES Conf: (552) R-TPã---------------------------------------------------------------------------ãã Hi, Chris:ããCP>Ideally such function should be written in assembly, but since thisãCP>is Pascal conference and I've flooded it with my assembly code enoughãCP>lately, we will use plain Turbo Pascal.ãã Try running this program using your routine and the one I posted,ã you might notice something "funny" about the ouput displayed. ã*)ãã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+}ã{$M 1024,0,0}ããprogram DemoStringRoutines;ããUSES Crt;ãã function FCenter(S: string; W: byte): string;ã varã SpaceCnt: byte;ã beginã if Length(S) < W thenã beginã SpaceCnt := (W - Length(S)) div 2;ã Move(S[1], S[1+SpaceCnt], Length(S));ã FillChar(S[1], SpaceCnt, '-');ã S[0] := Chr(Length(S) + SpaceCnt);ã end;ã FCenter := S;ã end;ãã (* Set these constants according to your needs. *)ã constã BlankChar = '-';ã ScreenWidth = 80;ãã (***** Create video-display string with input string centered. *)ã (* *)ã function CenterVidStr({input} InText : string) : {output} string;ã varã InsertPos : byte;ã TempStr : string;ã beginã (* Initialize TempStr. *)ã TempStr[0] := chr(ScreenWidth);ã fillchar(TempStr[1], ScreenWidth, BlankChar);ãã (* Calculate string insertion position. *)ã InsertPos := succ((ScreenWidth - length(InText)) div 2);ãã (* Insert text in the center of TempStr. *)ã move(InText[1], TempStr[InsertPos], length(InText));ãã (* Return function result. *)ã CenterVidStr := TempStrãã end; (* CenterVidStr. *)ããvarã TempStr : string;ããBEGINã Clrscr;ã fillchar(TempStr[1], 30, 'X');ã TempStr[0] := #30;ã writeln(FCenter(TempStr, 80));ã writeln(CenterVidStr(TempStr))ãEND.ãã ...I tried timing these two routines on my PC (Recently upgradedã to a 386dx-40 AMD motherboard), and here are the results:ãã Compiler ³ Length ³ Your routine ³ My routine ³ RatioãÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄã TP 7 ³ 30 ³ 0.03167 ³ 0.04043 ³ 1.28ãÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄã PASCAL+ ³ 30 ³ 0.02037 ³ 0.01959 ³ 0.96ãã *** Both functions were called in a loop 1000 times on each run,ã result was discarded ($X+ directive).ãã For curiosity sake I'll post the StonyBrook PASCAL+ machine-codeã listing in the next message.ã - Guyã---ã þ DeLuxeý/386 1.25 #5060 þã 21 07-16-9306:09ALL GAYLE DAVIS Format Number Strings IMPORT 21 ^& n ãUses DOS, Crt;ããVAR S : String;ããfunction CommaString (number : longint) : string;ã varã TempStr : string;ã OrgLen : byte;ã beginã Str (number, tempstr);ã OrgLen := Length (tempstr);ã if OrgLen > 3 thenã beginã if OrgLen < 7 thenã Insert (',', tempstr, Length (tempstr) - 2);ã if OrgLen >= 7 thenã beginã Insert (',', tempstr, length (tempstr) - 5);ã Insert (',', tempstr, length (tempstr) - 2);ã end;ã end;ã CommaString := tempstr;ã end;ããFUNCTION FmtStr (STR, Fmt : STRING) : STRING;ãVARãTempStr : STRING;ãI, J : BYTE;ãBEGINãTempStr := '';ãã IF (POS (',', Fmt) > 0) THENã BEGINã FmtStr := STR;ã IF LENGTH (STR) <= 3 THEN EXIT;ã J := 0;ã FOR I := LENGTH (STR) DOWNTO 1 DOã BEGINã TempStr := STR [i] + TempStr;ã INC (j);ã IF (J MOD 3 = 0) AND (TempStr[1] <> '.') THEN TempStr := ',' + TempStr;ã END;ãã WHILE TempStr [1] = ',' DOã TempStr := COPY (TempStr, 2, LENGTH (TempStr) );ã END ELSEã BEGINã J := 0;ã FOR I := 1 TO LENGTH (Fmt) DOã BEGINã IF NOT (Fmt [I] IN ['#', '!', '@', '*']) THENã BEGINã TempStr [I] := Fmt [I] ; {force any none format charcters into string}ã J := SUCC (J);ã ENDã ELSE {format character}ã BEGINã IF I - J <= LENGTH (STR) THENã TempStr [I] := STR [I - J]ã ELSEã TempStr [I] := ' '; {pad with underlines}ã END;ã END;ãã TempStr [0] := CHAR (LENGTH (Fmt) ); {set initial byte to string length}ã END;ãã FmtStr := Tempstr;ããEND; {Func FmtStr}ããFUNCTION FmtReal(Num : REAL; FMT : STRING) : STRING;ãVAR Tmp : STRING;ãBEGINã STR (Num : 12 : 2, Tmp);ã WHILE (NOT (Tmp[1] in ['0'..'9','.'])) AND (Tmp > '') DO DELETE(Tmp,1,1);ã FmtReal := FmtStr(Tmp, FMT);ãEND;ãã(*ããHi boys,ããThese routines are fairly simple to understand and should work for you inãin just about any situation. I've used them for years, and I've foundãthem to be the answer to all my needs.ããIf you need more help with these, just call !!ããGayleã*)ããããBEGINãClrScr;ãWriteLn(CommaString(123456789)); { Format any type of INTEGER }ãWriteLn(FmtReal(1234567.89,'##,###,###,###.##')); { Format Type REAL with decimals }ãWriteLn(FmtStr('2198758811','(###) ###-####')); { Format a Phone number }ãWriteLn(FmtStr('062593','##/##/##')); { Format a date number }ãReadkey;ãEND. 22 07-16-9306:47ALL SWAG SUPPORT TEAM A Complete String LibraryIMPORT 193 ^&dÏ (*ã TURBO PASCAL LIBRARY 2.0ã STRINGS unit: Extended string-handling routinesã*)ããUNIT STRINGS;ãã{ THESE FILES ARE XX34 AT THE BOTTOM OF THE LISTING }ãã{$L SUCASE}ã{$L SUTRIM}ã{$L SUPAD}ã{$L SUTRUNC}ã{$L SUCNVRT}ã{$L SUMISC}ãã{$V-}ããINTERFACEããTYPEã FormatConfigRec = RECORDã Fill, { Symbol for padding }ã Currency, { Floating currency sign }ã Overflow, { Overflow indicator }ã FracSep: CHAR; { Int/frac seperator }ã END;ãããCONSTã UCaseLetters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';ã LCaseLetters = 'abcdefghijklmnopqrstuvwxyz';ã Letters = UCaseLetters+LCaseLetters;ã DecDigits = '0123456789';ã HexDigits = '0123456789ABCDEF';ã OctDigits = '01234567';ã BinDigits = '01';ãã { Format symbol record }ã FormatConfig: FormatConfigRec =ã (Fill: '*'; Currency: '$'; Overflow: '?'; FracSep: '-');ããããFUNCTION LoCase(ch: CHAR): CHAR;ãFUNCTION UpperCase(s: STRING): STRING;ãFUNCTION LowerCase(s: STRING): STRING;ãFUNCTION DuplChar(ch: CHAR; count: BYTE): STRING;ãFUNCTION DuplStr(s: STRING; count: BYTE): STRING;ãFUNCTION TrimL(s: STRING): STRING;ãFUNCTION TrimR(s: STRING): STRING;ãFUNCTION PadL(s: STRING; width: BYTE): STRING;ãFUNCTION PadR(s: STRING; width: BYTE): STRING;ãFUNCTION TruncL(s: STRING; width: BYTE): STRING;ãFUNCTION TruncR(s: STRING; width: BYTE): STRING;ãFUNCTION JustL(s: STRING; width: BYTE): STRING;ãFUNCTION JustR(s: STRING; width: BYTE): STRING;ãFUNCTION JustC(s: STRING; width: BYTE): STRING;ãFUNCTION Precede(s,target: STRING): STRING;ãFUNCTION Follow(s,target: STRING): STRING;ãFUNCTION Break(VAR s: STRING; d: STRING): STRING;ãFUNCTION Span(VAR s: STRING; d: STRING): STRING;ãFUNCTION Replace(s,srch,repl: STRING): STRING;ãFUNCTION Remove(s,srch: STRING): STRING;ãFUNCTION StripBit7(s: STRING): STRING;ãFUNCTION FileSpecDefault(s,path,name,extn: STRING): STRING;ãFUNCTION HexStr(n: WORD; count: BYTE): STRING;ãFUNCTION OctStr(n: WORD; count: BYTE): STRING;ãFUNCTION BinStr(n: WORD; count: BYTE): STRING;ãFUNCTION Format(n: REAL; form: STRING): STRING;ãããIMPLEMENTATIONããUSESã DOS;ãããFUNCTION LoCase(ch: CHAR): CHAR; EXTERNAL;ãFUNCTION UpperCase(s: STRING): STRING; EXTERNAL;ãFUNCTION LowerCase(s: STRING): STRING; EXTERNAL;ãFUNCTION DuplChar(ch: CHAR; count: BYTE): STRING; EXTERNAL;ãããFUNCTION DuplStr(s: STRING; count: BYTE): STRING;ãã VARã ds: STRING;ã i: BYTE;ãã BEGINã ds:='';ã FOR i:=1 TO count DOã ds:=CONCAT(ds,s);ã DuplStr:=ds;ã END;ãããFUNCTION TrimL(s: STRING): STRING; EXTERNAL;ãFUNCTION TrimR(s: STRING): STRING; EXTERNAL;ãFUNCTION PadL(s: STRING; width: BYTE): STRING; EXTERNAL;ãFUNCTION PadR(s: STRING; width: BYTE): STRING; EXTERNAL;ãFUNCTION TruncL(s: STRING; width: BYTE): STRING; EXTERNAL;ãFUNCTION TruncR(s: STRING; width: BYTE): STRING; EXTERNAL;ãããFUNCTION JustL(s: STRING; width: BYTE): STRING;ãã BEGINã JustL:=PadR(TruncR(TrimL(TrimR(s)),width),width);ã END;ãããFUNCTION JustR(s: STRING; width: BYTE): STRING;ãã BEGINã JustR:=PadL(TruncL(TrimL(TrimR(s)),width),width);ã END;ãããFUNCTION JustC(s: STRING; width: BYTE): STRING;ãã BEGINã s:=TruncR(TrimL(TrimR(s)),width);ã IF LENGTH(s)>=width THENã JustC:=sã ELSEã JustC:=PadR(CONCAT(DuplChar(#32,(width-LENGTH(s)) DIV 2),s),width);ã END;ãããFUNCTION Precede(s,target: STRING): STRING;ãã VARã i: BYTE;ãã BEGINã i:=POS(target,s);ã IF i=0 THEN { Return entire string if target not found }ã Precede:=sã ELSEã Precede:=COPY(s,1,i-1);ã END;ãããFUNCTION Follow(s,target: STRING): STRING;ãã VARã i: BYTE;ãã BEGINã i:=POS(target,s);ã IF i=0 THEN { Return null string if target not found }ã Follow:=''ã ELSEã Follow:=COPY(s,i+LENGTH(target),255);ã END;ãããFUNCTION Break(VAR s: STRING; d: STRING): STRING;ãã VARã i,j: BYTE;ã f: BOOLEAN;ãã BEGINã i:=0; { Index to input string }ã f:=FALSE; { Set when delim. found }ã WHILE (iLENGTH(repl) THEN { Ignore search chrs. }ã srch[0]:=CHR(LENGTH(repl)); { without replacements }ã FOR i:=1 TO LENGTH(s) DO { For each char. in input }ã BEGINã j:=1;ã f:=FALSE; { Scan all search characters }ã WHILE (j<=LENGTH(srch)) AND (NOT(f)) DOã IF s[i]=srch[j] THENã BEGINã s[i]:=repl[j]; { Replace if found }ã f:=TRUE;ã ENDã ELSEã INC(j);ã END;ã Replace:=s;ã END;ãããFUNCTION Remove(s,srch: STRING): STRING;ãã VARã i,j: BYTE;ãã BEGINã FOR i:=1 TO LENGTH(srch) DO { For each search character }ã REPEATã j:=POS(srch[i],s); { Repeat search in input string & }ã IF j<>0 THEN { delete if found until no more }ã DELETE(s,j,1);ã UNTIL j=0;ã Remove:=s;ã END;ãããFUNCTION StripBit7(s: STRING): STRING; EXTERNAL;ãããFUNCTION FileSpecDefault(s,path,name,extn: STRING): STRING;ãã VARã d: DirStr;ã n: NameStr;ã e: ExtStr;ãã BEGINã FSplit(s,d,n,e); { Split file spec. into path, name, & ext. }ã IF LENGTH(d)=0 THEN { For each field, add default if none }ã d:=path;ã IF LENGTH(n)=0 THENã n:=name;ã IF LENGTH(e)=0 THENã e:=extn;ã FileSpecDefault:=CONCAT(d,n,e);ã END;ãããFUNCTION HexStr(n: WORD; count: BYTE): STRING; EXTERNAL;ãFUNCTION OctStr(n: WORD; count: BYTE): STRING; EXTERNAL;ãFUNCTION BinStr(n: WORD; count: BYTE): STRING; EXTERNAL;ãããFUNCTION Format(n: REAL; form: STRING): STRING;ãã VARã s1,s2: STRING;ã width,dp,sign,i,j: BYTE;ã pad,currency: CHAR;ã blank,zero,left,paren,ã comma,adjust,reduce: BOOLEAN;ã x: INTEGER;ããã { Reduce fraction to lowest possible denominator }ãã PROCEDURE ReduceFraction(VAR num,denom: BYTE);ãã VARã i: BYTE;ãã BEGINã FOR i:=denom DOWNTO 2 DOã IF ((num MOD i)=0) AND ((denom MOD i)=0) THENã BEGINã num:=num DIV i;ã denom:=denom DIV i;ã END;ã END; { ReduceFraction }ããã BEGIN { Format }ã form:=UpperCase(form);ã s1:=Break(form,CONCAT(DecDigits,':')); { Get leading options }ã IF POS('A',s1)<>0 THEN { Absolute value, no sign }ã n:=ABS(n);ã blank:=POS('B',s1)<>0; { Blank if zero }ã zero:=POS('Z',s1)<>0; { Zero-fill/zero-show }ã left:=POS('L',s1)<>0; { Left justify }ã comma:=(POS(',',s1)<>0) OR (POS('C',s1)<>0); { Commas }ã reduce:=POS('R',s1)=0; { No reduction }ã paren:=POS('P',s1)<>0; { Negative in parenth. }ã IF POS('+',s1)<>0 THEN { Check leading + }ã sign:=1ã ELSEã sign:=0;ã IF POS('*',s1)<>0 THEN { Set fill character }ã pad:='*'ã ELSEã IF POS('F',s1)<>0 THENã pad:=FormatConfig.Fillã ELSEã pad:=' ';ã IF POS('$',s1)<>0 THEN { Set currency symbol }ã currency:=FormatConfig.Currencyã ELSEã currency:=#0;ã s1:=Break(form,CONCAT('+- ',#9)); { Get width:decimals }ã IF POS('-',form)<>0 THEN { Check trailing +/- sign }ã sign:=3;ã IF POS('+',form)<>0 THEN ã sign:=2;ãã s2:=Follow(s1,':'); { s2 is decimals }ã s1:=Precede(s1,':'); { s1 is width }ã VAL(s1,width,x);ã IF x<>0 THEN { Default width 12 }ã width:=12;ã IF COPY(s2,1,1)='/' THEN { Use vulgar fractions }ã BEGINã n:=ABS(n); { Force absolute value }ã sign:=0; { Disable sign display }ã DELETE(s2,1,1);ã VAL(s2,i,x);ã IF (x<>0) OR (i<2) OR (i>99) THEN { Default resolution 1/2 }ã i:=2;ã j:=ROUND(FRAC(n)/(1.0/i)); { Calculate fraction }ã adjust:=(j=i); { Allow for rounding }ã IF adjust THENã j:=0;ã IF reduce THEN { Reduce fraction }ã ReduceFraction(j,i);ã STR(j,s1);ã STR(i,s2);ã IF j=0 THEN { Format fraction }ã s2:=DuplChar(pad,6)ã ELSEã BEGINã s2:=CONCAT(s1,'/',s2);ã IF (INT(n)=0) AND NOT(zero) THENã s2:=CONCAT(pad,s2)ã ELSEã s2:=CONCAT(FormatConfig.FracSep,s2);ã s2:=CONCAT(s2,DuplChar(pad,6-LENGTH(s2)));ã END;ã IF (INT(n)=0) AND NOT(zero) AND (j<>0) THENã s1:=s2ã ELSEã BEGIN { Format integral part }ã IF adjust THENã STR(INT(n)+1:0:0,s1)ã ELSEã STR(INT(n):0:0,s1);ã s1:=CONCAT(s1,s2);ã END;ã zero:=FALSE; { Disable zero-fill }ã ENDã ELSEã BEGIN { Use decimal fractions }ã VAL(s2,dp,x); { Get number of decimal places }ã IF x<>0 THEN { Default to zero decimals }ã dp:=0;ã STR(ABS(n):0:dp,s1);ã END;ãã IF comma THEN { Insert commas if necessary }ã BEGINã s2:=Span(s1,DecDigits);ã i:=(LENGTH(s2)-1) DIV 3; { i is no. of commas to insert }ã FOR j:=1 TO i DOã INSERT(',',s2,LENGTH(s2)-(j-1)-(j*3-1));ã s1:=CONCAT(s2,s1);ã END;ã IF currency<>#0 THEN { Add floating currency symbol }ã s1:=CONCAT(currency,s1);ã IF paren THEN { Add signs as required }ã BEGINã IF n<0 THENã s1:=CONCAT('(',s1,')')ã ELSEã IF NOT(left) THENã s1:=CONCAT(s1,' ');ã ENDã ELSEã CASE sign OFã 0: IF n<0 THEN { Leading - }ã s1:=CONCAT('-',s1);ã 1: IF n<0 THEN { Leading + }ã s1:=CONCAT('-', s1)ã ELSEã s1:=CONCAT('+',s1);ã 2: IF n<0 THEN { Trailing + }ã s1:=CONCAT(s1,'-')ã ELSEã s1:=CONCAT(s1,'+');ã 3: IF n<0 THEN { Trailing - }ã s1:=CONCAT(s1,'-')ã ELSEã IF NOT(left) THENã s1:=CONCAT(s1,' ');ã END;ã WITH FormatConfig DOã IF LENGTH(s1)>width THEN { Check for field overflow }ã Format:=DuplChar(Overflow,width)ã ELSEã IF blank ANDã (LENGTH(Remove(s1,CONCAT('0. ()+-*',Fill,Currency)))=0) THENã Format:=DuplChar(#32,width) { Blank if rounded=zero }ã ELSEã IF zero THEN { Pad field to width }ã BEGINã s2:=Break(s1,DecDigits);ã Format:=CONCAT(s2,DuplChar('0',ã width-(LENGTH(s2)+LENGTH(s1))),s1);ã ENDã ELSEã IF left THENã Format:=CONCAT(s1,DuplChar(pad,width-LENGTH(s1)))ã ELSEã Format:=CONCAT(DuplChar(pad,width-LENGTH(s1)),s1);ã END; { Format }ãããEND.ãã(*ããThe following contains the ASM and OBJ files needed for this unit.ããDo the following :ãã1. Cut the code out to another file. Call it STRASM.XXã2. Execute -> XX3401 D STRASM.XX. The file STRASM.ZIP will be created.ã3. Unzip to have OBJ and ASM files needed.ãã------------------ CUT HERE --------------------------ãã*XX3401-007122-160793--68--85-58879------STRASM.ZIP--1-OF--2ãI2g1--E++U+6+BRwjVcn7M7VxU6++1wC+++8++++IpJ1EJB39Y3HHSpLHLCPA-0xSwPzãMGyRh3CGgRpC1gsZTAKa6kC1QCAaYkBpZ6G46+cWbTHL3m360EXWBeRqcggmW5qvSfjvãN-z-oyKjDQo-JwKuWU-NaeRuLq-qA-aDqZzeEINUGyBvYaMVXS4CLiMF4Mz46qVXKXsmã0viq9Fykvpbq+gxvzRjSfffUnb-se2kzn9fvPnH9tbMusv3pln0PixVQf2nPVpD5Aveyã8gPfJT4xXiTQgTg-QUcSg0GdhMMgLSlXIs4puteSS2HCeLXYuLFdCpbPiawtBW-OAj-qãSpBkgJGxRw76W0stMf0x0R7UmoU8X272Tt-oTwgFmDQwj+wW2XASHqHImBFnx16iVysQãkr39eqp+ictUEFWYVCJd1A5ZNIem18tGSUQN0vOrzM1udbxD5EnqytFV10fekiWf0UMdãSyeS1AOaFOvTwcl-S+Il9H0174F-pALud+ZvT6makt5CxWHSud0rso5hDNggNLbKVQqHãd33Is2IRXnXcz2b5sOJUhcwxXqGAdeFJ9Zbj0WFBIWDDx9ghNBe48thfDdbDBDaO5oroãSHOjNjxRzR1TuVZ9kzWOIm8s2NGAFsxXhZBnpyRoirgftvBcT3T-fdFBH5VVF7z1JFfQã2IVc41CGxYQm72e-10m2m36A9Y9UyVuQOyvvksgeYghV0xwthjW7knX7OkMYQ8O+AxdkãowZ32wv2QuC2cnYPkhCFoQyCXdFnP3roH4eNu5tJecX2pym4nulgx1TJACV9FJx8sq2BãyVQTZSGVCgBy3Sff+tDQ3dzonJYpYlzYIDUqH00WB0bJ6MyWFqvO6sQQstaoOg2u286sãL9eab+Gv0JRH2+OoOnMQvCSkRYawJRicjGT4mL7+ioG4fI5Zc2oWgSxUHLOtWVh-u0Sjãq3lmLJHnAmVspq54G7cBL50iJCh8yv4f8mxEDAE7SMbWBKjChTXoJT3S3SzTJvkRTucpãNSHj3SzgXlJjxpxfzsTWhLKZJfnqzuTWDNMdMT4Sjzs3I2g1--E++U+6+BNwjVfCAxypãEUA++0cC+++8++++IpJIIYZB9Y3HHSpLHKzPC-0x-z-za2i-LOkGl5MGcD6Z2eZBJB0GãEAehqw+5BOMP6PPYZSGUuOwjeExLAGYtKTGoK3pcYC9AawTVSz62LXvVXBcy--N13U5WãqhGWbq3oRXssIRvAsUpwLIT7MkuPR9ZPww57s+ECrr71scVltfYVg70urUonhLgDRkPKãXRk6JpT4Q1lGpxzNfWT5sIXaFHtqqejAiNYuLUWTT6fJjFNXguZs5n3HPZFT69ucbqZ+ãnKnW6Z2KROT28+Qeoujoz1rnICXuLZYfUHxmgmvznyN5-uJf5WrXt3h1nmd9Bt+LaNWGãOQf2PI1IFqIuWyfEgZgtqc4uBjIzEfJag+1INk8A3v1PWhnFzOC+2KosPBAs8LXKbEZfãC0CMJITW4ZUS-kEVVHgvyCheIKQ8N3WlpqEi30b2mLNLv4hKkXZJC5kMPbWyO6Rna6b9ãQCaiu6i50CtVNqu661dqF5VvLV4Ghv8gST8hS60jnkLLRFJaBbEz2vUFb7TZbpNkarVlã+aXS1FAFkm9ewhmbpT8hUKvJNRR1BNBRQBVXj8ofCyqhf+40WM46BVF8hwyEfif1zJIKãpi1yUCNTt5VxHGtuUAIfG5PfRIBJ4LZk6XMBnHSHbj1j-RkzF3ZofqpkB8oiWIKAwIVTãs+CLxmHBedifeOcK8+3kp7jUjKOjtnFvlqK7crO7q8YDYbGJu8seJ+MgyTrNmqPJxOYTãpBa45NGZgiSDYTOVfcbRyXEgHvD2DatXNu3zt5U2xWEh4jltYKNQBYtJUteo6EBd4cguãUKnJncEH09AcmJQwUsljcXVNWZzdOewRgUFHozMCAyzgyQ6sD6+7g-9iOwEVe1XLGaWnãdVBmucHZS84OUyDVE4T8oZdTsJfo1OtJN34wvfQh0jzPpiyn9FPWLXysMys0SUnaW9AQãgMuKEczVe26TcQP0i42OnPL-diYHVsfZRNGzo7nzihlTe57zL7tPQeyex820hoIAikj3ãk-gFyw4nh3z039qzv7TAjamjYQna+sNpTg1g9ySyPQsUszzgsckjilgFRnPWzbP842yFãE3T+BgrX6YuHTqArtJTFzanmYet9wzSv+hKski3T7X5DR4sVtiLoHp-9+kEI++6+0+1JãT9sOCDOSb+E1++-g1E++0E+++3BJI2329Y3HHSpLLKyPA-FxfxHzQ3waPFe9aYme7f77ã-NiZP+sUaumdeXnEs9Gc8KFweBizbloUHMAVKPjhOHn2kiOSSyu5vp44wDHl7xFokHAMãAUUEquE4jMF-vyHsODR99kUVmxAcjc5v70mKzDXcy+VqsKmTK48RC9MDn8SqAq8umbHLão1B4oUtCHvLyyo5nz7JdCr9h1uFPt47fytFNcv5Zy51VIhmoBFWPXALrWCbGgDY-QILoãH23eMV6PGL8MOD8LGiTBp5mSCAWrLIQ4Gi-pdZSV1y2V0jBP5Ql9rrdHvrOaxW58Pq57ãUp0yL0y1y0u1D63glSTF6i7VWGV7G37DE8W9paEAece2bQjJx7dbMzQPZ4QOwu1t165lã56eJc-XAvq0F-jQQJYYItnlhxsEJyGGMZSKmBGl9-NtDsQforbuMJNsw0GhgRKP9g8BsãJSFJOVFkJUa5Ry5uUxYqbAJoj6N9Wfk9fos2aacGtLHKGAF6709ZrkiStLId-2RVo+GPãifE2CxTESITGdtfUdYfuJwtLA2xKDm3NpAm1A2ltZXLV2A4ehgPAP4snrqIah1x1wBAUãnVMwVGKDPoG6axGpls47Nd1qC9M9KO2eUVVvJH+0erbwlGnjzBYNuOhtgvh6i3f62YYbã5nyJPhjwpRkhdZyNota4G+AkHp7Sko4EpLIEPnp3MWTa6rwZEFEgtnq6YtuguSDh3aJhãNqQEPL0Wu0-eSNqZfBZLPe7shzpZ5bJJylABYnoBrHcao5FnPxzh8PQAEDXg041HVqIRãCxfEQwjKeEOA+cjmP7qC6+t3ETAWXRhFJ3CGKjtuDKpCLgj-bYcAdOPh3knu-kEXHsBcãSMVWIDWj45x1AMVqlSnNQmuBZ7HhARKa7th-CxLER9xUR2wyqo4JoXpPaFsbcGHxSw7oãqAozuC9zGwrSoWTw6bq82y+zwXGcfij9Z8aAu6YqRIcHJYiHIxlTWsHjuh8yRbmyCZqYãIQurbCpFdwAbTAdj6Z5fB5j7U8Se+PzvhoDgAxLU3zhmylREGkA23++0++U+ormy4jzrãJb1n+U++GEk+++g+++-HJJFGJIt19Y3HHSpKoKfPA-Fx1yETvghUMqtNAUX14Omqv0IiãWaoYNohLwa+GdHJfvAmK4RjLHsdgG0AtvI9rBfw6R8JnnvauCj6M5bz7b9UFl+t31UMQãiAEVBn0wTBTjOGj9CZyZb253mmmzUqqlfVxMjxTjkT586A4y4CRVY+-BG--CeBqtzrVrãv2nYNVWBfA5vcFtztEOV5+R1aFh3bbwMdTtYtcQ7T6q6dyxp87rDl5d2PPZFLs+XIEReã61JrQM02B16D2PPq+t5txHdx3e2YW26Z4ADfmau8A6OTqNfTqy1S7DuPRjPdGaz8MUgDãPAC-3p1hq0fPN4mhk0E1FSe+96bEbcZ1H2fcJ6tifARaoFREAMj4c5xXc6l1jFD2ohJrãkGjRAhUJKQtNqNr7AxEHSpERJq1Rij5P1oghImlVlJuP-Z7qZixerVH2+CQfC2z-1MN9ãAtlDPKwDJxHw33tP04Sllljdx0OW20LvIPC8hoQVC681RP-3F-HMp58arPYEhatdg1EIãLSPOuvxc4i8-tLQe5pdotoBH0lbm-G3eGez521NQ4XFHjS-U0lbYLPhej9f0+n+qnLKxãrI4q+OvuCWjmTSamYepDZVshX51--j80Kv+eRfzO8t7KY6YWJENu1LguXIUWGEvvDIbJãDXGBiR8+3dNXnVYKZp-gM5KTZia8gv8GHRHcALWMsrZhSrS6IDqcSbhEQM3Q5VF3obl2ãA6ac0xrT40UjGhOqhSeD2urq57rJdR8MthL4R9qjoS7PQyvjxGXlMtaiYzIMY1kyzGd8ãi2DdQOHCnyEWPQnYNQFDxiB6xoQzx49HimJTbiRsCbYdHmyniziHdYvUjuaza8YPnEp5ãrVArusHvCcjnrTtjLtMnb9spPcEh-lipYQRtDec1IE6zbKDpfHTL3MB1A2WfYmxT-vwXãDnjqvFP+dzOh3mkhVAymlTN3x68H9XQoGov8R+SzKJZQB37JapHbS49GiCqV4kvzVFgGãrEqDzuH3D1Ktd7WLorw+I2g1--E++U+6+B7wjVfA7sv1RkA++3QG+++9++++IpJ1HZNGãJ0t-IorhK3pjqnMITEyEzr-T0amMKjUXG+fZdF8ZK-dYGF1ZnJqF-wKaMu2C4J-IajHLãZlGJn7Pcf5KlPYCa3xcGRLXisPrbGXe5rGCTNKs0eMCF2o2IidaHjMTFaw5lILRaLBxQã2TtOgBSJs0KxVUKXRsFL7OBkktPpVVkT5Fx-3nzA6pyCgnXA+SRN42ykzJJMLOHIaGUUãC1qpViBFzzcfBsnJC-kd5WXlzCqfq7xAzHW5rtDAuxzfM1mPmjY6qyf4zcEcYTdU+uaNã4sI66D1bAXUfEPYO7-AtaCFEEOXnTLYjNX58kmG4UBlXkS2bOXRYnuIqBFIqiCxnzqSvãpP-zToN2nGagmToPsCGKYsdEIEWZ83g-VN70evLwqo10MZrkMW4YvceE1a49OdOUVdWHãaS94UFfRh5xhajk4yde3IyUTts07UDdKwWYK5q53Wlg0humYYgZyB1GrDfXd9uSLzGbnãFBB4UMI0ss6HiO0CKQe+tjhLwTEePmyB27wMLs7UPPMqM7s-9D8l-UgPgC5UgUiKeaX-ãlvML8XlKWxhOhDinbtmQzw299moIxEEJX7BR4BUESWrKTPFToTkDBPtv3soBZS-tXxnFãr8WZteu7Psde8sruO1XrbgaDm-eQ-APwK7Qf+LT3dWOkMbn95MuD7CqVPI-ntdNd9tlMãlyD6lGuAWoq9uaAH0mbid6OIk98w9cLwhLbcsvKddj14+mASOdB1EXcMVS3nye-dycHaãaB5KFBK6384dP+T2ahRkMRVKJsxGbx5yPJImb+KBWWBvNuAGvA9ysn534V7ObmR1AFEYã0WPB1gwhIv5V65gghasevmE+eoKvJZhkNDbBOoJ7YfOm1Aq-HFUg4J-mjtD7eXeq-IcpãXB5kAXxjldCyWTelZlvM-t83y6syk-OWq-nK05EHyvwFj8-4ADf54w5sFnO0grxR6zVOãzxJZzI6AS5G++LTBungAq0rdLljkyJs5jWddkFyA3ZlLydqbvvrunS43SixzlWtDziOyãwKFZSvp34wdbkhYDQSuipqsNm7uWpUNmJHPqhmUsTqUAL7-848GBoRCnelYiLA5EIXHdãBN4mzCadX-cy3MEhbVARzeHPyBunJATaqnANcU8E9AgJI96UJJJkEkTlz-qKCsyPryGOãJsecGgg1z97fC6xyqTpy6gxXYsz8wyfo3p-9+kEI++6+0+1MT9sOuigk5cM0+++a0E++ã0U+++3BJHIZHEmt-IorBJh3ian+ITMyITvUjYneBHIoq7FBt8FWOA1a+A8ndeXtEuUOoã***** END OF XX-BLOCK *****ããã*XX3401-007122-160793--68--85-04457------STRASM.ZIP--2-OF--2ã106kojPrgu328HN7JKbGz56Zv5hwvj2xBpb+mlJ4USa-Pl-YMA0C4FX-9IkzLMt5zNDfãf2fcPVTbh8Uf86iONHahs3TlKCzcS1ESEFzO0P5BMyEu6N+kQBkZoQz-x23wMmYkM1PHã7dybwjsvor33b2k3-SFNxj2igNRfqkrVlUggCRQU73fnwsXc6Z2yU1qi0Z4EWYng6++fãwX3O4M5KZCSPHXUL94HhfWALVMvbUZLjRmWBGvV6IVp2vU8GcguN1iNhO9zLbsKG6IFaãZgGAEg9nssHFIhnIIHVE0nnIr4U28htY7O9dmrhfvnioSlflEJs967F-jMS8lQZDS0fXãLlHqFNMrF0HZPB8mRfEvozwkiPnjczYW3KmWKkuk+ceOvKj4kQggrkunAnMBrilSMfTYãv-cZ6Qj-k162kccK6835H-VSj4dKZ-HWeaCsczaKdT1kVx3VaUVf-ZP0VKKQJoyoTCP8ã8oQP4KTXhEy8JVdOmRjToCO5W3RLS57Keuw1KbJRB8FLMDgbtSaYCKd5kIQzvXTDVu3yã0ymkWJzY5fNRmpQB3129njW9g19PalaPkoLJSSa2eR0ClWKYqHPxK7GDL6i5X25l-1FCãodQ8RMot5Vqgzbwtffj7IgkfP9Ji7AuESpcrKYEbXFinz7ENztKt2RPiW5Cj226oP7jRãyMwzmFiActk-zDcnAy-UqdDaDr9ZJDM0xeknhsUWQzeP5Hh8ygZmfHNWPLuxIe4cKjchãQyyan-VxlSBVfnKte5SUfU8qWh82H8dVcKfUJkuGjXKvER9zKw0z2xK+sRzPyT6LI2g1ã--E++U+6++ZxjVeTUjEtok++++U-+++8++++IpJ1EJB39Yx0GajUMS+81bJq15PJQknqãbRuVkA1+237OZ7Gjs3VQb7ePZ7BOd8+EZZdIb7aTdq0cNq1MoG52sD1mSgoy8GFxdVrAãE24TOIkA1-bHq-VMbDpRL3pbg1AsF12kAH6SbW1+kA16uSATvVc2oa58k3+nUFQclCPXã1y61fJk8IF6O2+-F+iHBuq-VQ3X2C53-5+AX+oBoN6GBMl4PHJEt2sx0MD1doCsrQYT9ãq6vIQTrdsX3uiyElrlePF8-wJHaHmjpJXnv7lttWMQ0a04s6H33h3x1J7E-EGkA23++0ã++U+15qy4XV5qhLL++++yE++++c+++-HJJFGGIoiHo78Oy-Vs+cC1EbmxBJn1DMhvp-UãM4+68Gp8mZRk90tCnIr8GGpGI+V99GfCnAxHABEnACnc247kS5ahNdwIYXul1aOUcAwoã7UO4X4Zg10nCzWuifXDM4FmG4NUM4LRBs43UM4E38TM-4bwBkEomNa0Mqw50s906QS80ãR+N4-cPEvXRmFwjMXhFlzSayjuPfVB3Pxuu9XoLKq0WIgBVkZf9xCzLcwqjKJTxCTZuWãpW2i5ri8-Ib9rmsScvSDSNYzkdGnDzeepg5vaUB6i15zz9k2fDt03x0N7E-EGkA23++0ã++U+1rqy4ifHluP7++++vE++++Y+++-HJJ--F0tDEYdfs4PU1+sBQ5HFQknqTR0VkA1+ã237OZ7Gjs3VQb7ePZ7BOd8+EZZdIb7aTdq0cNq1MoG56sD1mOgoy8MGqVUtac7XDB0M4ãVcldP+kgnjsifesnq-YQcVaM4-YDHS-aM4-Y+Ofp+Fdi1yQ3uH2kQ5SkA1UgMdms67u-ãYM2VhDiBrB2mXWBpDBpyP2NjiyzzKPCeus9JWH7ChEtyfFAP31ujuXdZxDPn2jbMIql6ãefhsU6cjCU9JTps0paZp0e9Z32U9KD579e1XGU-EGkA23++0++U+2bqy4ibgE-T8++++ãvE++++g+++-HJJFGJIt19Yx0GajUNS+C1Uo70jJnpbAAxZLhI4-UM+Ud9If8Jr+g9YvBãHQd79J7E02gh8gvAnpAkp1AkvCUENb-sSPZablGmliARn2-FbqZA1+kNoxUMK7nxLJlRãNv+nC+EnA12mbdf+mw1+m+NKvECoc+K75uH9k-1MkQ9Ug6Vlsc7k-YM4Vh1iBr75mnWCãpD3oiv2NDSbWALffxgTeM-39xw5L9Bcba1yiuXvlaCbn2jbMIql6WjygALfGvQRaxBPeãF-3Hpkap1Ztri8eC9e11GU-EGkA23++0++U+3Lqy4i0NFEo5+E++9k2+++g+++-HJIBCãJZ7I9Yx0GaqDAIX1M--4jnw7GR24-rLdx+z3AGGCsd+O+kcpVGMB1fcI+Ude6R3BWcjoãpmmuZ6vWq2Zk3l3-QJCbfbKmuW-C1cdLeh1-tS+Rvr5QbctFjy7sMHYk0jtGLb++kItQãfT30YYGPpMoctXmAsaGxhgIhkvG246Txz9-vYFgCPsFAqq7H+hOO8VGbBCyu9ErqDWH4ãKYQukBGtFQwDmWi+AS+3RtaM1hM5L560MUgc0ULq8HgyCE+18iZfuebHPqaMiOuDH+bxã8GRzTdofuJJy94jCngGGcfIPbQRScxBxKPpHzUYayc3AUNMpzxHrMTLLauHYn0HtjdR6ãrtRh4fTRXvuMCOHLhbw+I2g1--E++U+6+-ZxjVfyc8wEm++++BE++++8++++IpJBGJB1ã9Yx0GajUMS+81jLp15PKQknqPSxEM4-U00YhGgdLQ0kiHgpBmYYhIZ+6GmoengnDIn1IãAn1gu--WQ5VtcqOT376yZEtac81DB0M4VcldP+kgnjsifesnq-YQn-aM4-aTHF-UM41Yã1+s7wUlkwUklZq7Ua18-5mX2sF6OsCDgsFU2h7GpUsL-MF5Xl+LK16kA185RPsvIQLKvãgTpNpLL0uCpXpasrXgyfMYylU4HYXdOl+KKvS6nSzZbma4qBGjqeFvzYEN65is+i8+2+ãI2g-+VE+3++0++U+prmy4XAZUa5q+U++Dks+++c++++++++++E+U+++++++++3BJEo3HãFGt-IopEGk203++I++6+0+1KT9sOnXDThI61+++e1U++0U+++++++++-+0+++++S+k++ãIpJIIYZB9Y3HHJ-9+E6I+-E++U+6+BJwjVcsxduQ-+A++4kB+++7++++++++++2+6+++ã+6U4++-HJJ--F0t-IopEGk203++I++6+0+1HT9sOzzRKQDA0++-71+++0k+++++++++-ã+0++++0n0E++IpJIIZJCEmt-IopEGk203++I++6+0+1GT9sOn0SCkrQ1++-L2U++0k++ã+++++++-+0++++1D1+++IpJ1HZNGJ0t-IopEGk203++I++6+0+1MT9sOuigk5cM0+++aã0E++0U+++++++++-+0++++-j2+++IpJBGJB19Y3HHJ-9+E6I+-E++U+6++ZxjVeTUjEtãok++++U-+++8++++++++++2+6++++-oH++-HJIB-IoIiHo78I2g-+VE+3++0++U+15qyã4XV5qhLL++++yE++++c++++++++++E+U++++4-E++3BJJ377HGtDEYdEGk203++I++6+ã0++DTPsOuhD5dgY+++1h++++0E+++++++++-+0+++++L3E++IpJEEIEiHo78I2g-+VE+ã3++0++U+2bqy4ibgE-T8++++vE++++g++++++++++E+U++++-lM++3BJJ37JHYAiHo78ãI2g-+VE+3++0++U+3Lqy4i0NFEo5+E++9k2+++g++++++++++E+U++++yVM++3BJEotKãIZEiHo78I2g-+VE+3++0++U+4Lqy4juUfl16++++p+++++c++++++++++E+U++++8VU+ã+3BJHIZHEmtDEYdEGkI4++++++k+1+0W+U++4VY+++++ã***** END OF XX-BLOCK *****ããã 23 08-18-9312:30ALL JOSE ALMEIDA Complete Set of Strings IMPORT 56 ^&Hb UNIT HTstr;ã{ Complete set of defined string types.ã Part of the Heartware Toolkit v2.00 (HTstr.PAS) for Turbo Pascal.ã Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.ã I can also be reached at RIME network, site ->TIB or #5314.ã Feel completely free to use this source code in any way you want, and, ifã you do, please don't forget to mention my name, and, give me and Swag theã proper credits. }ããINTERFACEããtypeã String1 = string[1];ã String2 = string[2];ã String3 = string[3];ã String4 = string[4];ã String5 = string[5];ã String6 = string[6];ã String7 = string[7];ã String8 = string[8];ã String9 = string[9];ã String10 = string[10];ã String11 = string[11];ã String12 = string[12];ã String13 = string[13];ã String14 = string[14];ã String15 = string[15];ã String16 = string[16];ã String17 = string[17];ã String18 = string[18];ã String19 = string[19];ã String20 = string[20];ã String21 = string[21];ã String22 = string[22];ã String23 = string[23];ã String24 = string[24];ã String25 = string[25];ã String26 = string[26];ã String27 = string[27];ã String28 = string[28];ã String29 = string[29];ã String30 = string[30];ã String31 = string[31];ã String32 = string[32];ã String33 = string[33];ã String34 = string[34];ã String35 = string[35];ã String36 = string[36];ã String37 = string[37];ã String38 = string[38];ã String39 = string[39];ã String40 = string[40];ã String41 = string[41];ã String42 = string[42];ã String43 = string[43];ã String44 = string[44];ã String45 = string[45];ã String46 = string[46];ã String47 = string[47];ã String48 = string[48];ã String49 = string[49];ã String50 = string[50];ã String51 = string[51];ã String52 = string[52];ã String53 = string[53];ã String54 = string[54];ã String55 = string[55];ã String56 = string[56];ã String57 = string[57];ã String58 = string[58];ã String59 = string[59];ã String60 = string[60];ã String61 = string[61];ã String62 = string[62];ã String63 = string[63];ã String64 = string[64];ã String65 = string[65];ã String66 = string[66];ã String67 = string[67];ã String68 = string[68];ã String69 = string[69];ã String70 = string[70];ã String71 = string[71];ã String72 = string[72];ã String73 = string[73];ã String74 = string[74];ã String75 = string[75];ã String76 = string[76];ã String77 = string[77];ã String78 = string[78];ã String79 = string[79];ã String80 = string[80];ã String81 = string[81];ã String82 = string[82];ã String83 = string[83];ã String84 = string[84];ã String85 = string[85];ã String86 = string[86];ã String87 = string[87];ã String88 = string[88];ã String89 = string[89];ã String90 = string[90];ã String91 = string[91];ã String92 = string[92];ã String93 = string[93];ã String94 = string[94];ã String95 = string[95];ã String96 = string[96];ã String97 = string[97];ã String98 = string[98];ã String99 = string[99];ã String100 = string[100];ã String101 = string[101];ã String102 = string[102];ã String103 = string[103];ã String104 = string[104];ã String105 = string[105];ã String106 = string[106];ã String107 = string[107];ã String108 = string[108];ã String109 = string[109];ã String110 = string[110];ã String111 = string[111];ã String112 = string[112];ã String113 = string[113];ã String114 = string[114];ã String115 = string[115];ã String116 = string[116];ã String117 = string[117];ã String118 = string[118];ã String119 = string[119];ã String120 = string[120];ã String121 = string[121];ã String122 = string[122];ã String123 = string[123];ã String124 = string[124];ã String125 = string[125];ã String126 = string[126];ã String127 = string[127];ã String128 = string[128];ã String129 = string[129];ã String130 = string[130];ã String131 = string[131];ã String132 = string[132];ã String133 = string[133];ã String134 = string[134];ã String135 = string[135];ã String136 = string[136];ã String137 = string[137];ã String138 = string[138];ã String139 = string[139];ã String140 = string[140];ã String141 = string[141];ã String142 = string[142];ã String143 = string[143];ã String144 = string[144];ã String145 = string[145];ã String146 = string[146];ã String147 = string[147];ã String148 = string[148];ã String149 = string[149];ã String150 = string[150];ã String151 = string[151];ã String152 = string[152];ã String153 = string[153];ã String154 = string[154];ã String155 = string[155];ã String156 = string[156];ã String157 = string[157];ã String158 = string[158];ã String159 = string[159];ã String160 = string[160];ã String161 = string[161];ã String162 = string[162];ã String163 = string[163];ã String164 = string[164];ã String165 = string[165];ã String166 = string[166];ã String167 = string[167];ã String168 = string[168];ã String169 = string[169];ã String170 = string[170];ã String171 = string[171];ã String172 = string[172];ã String173 = string[173];ã String174 = string[174];ã String175 = string[175];ã String176 = string[176];ã String177 = string[177];ã String178 = string[178];ã String179 = string[179];ã String180 = string[180];ã String191 = string[191];ã String192 = string[192];ã String193 = string[193];ã String194 = string[194];ã String195 = string[195];ã String196 = string[196];ã String197 = string[197];ã String198 = string[198];ã String199 = string[199];ã String200 = string[200];ã String201 = string[201];ã String202 = string[202];ã String203 = string[203];ã String204 = string[204];ã String205 = string[205];ã String206 = string[206];ã String207 = string[207];ã String208 = string[208];ã String209 = string[209];ã String210 = string[210];ã String211 = string[211];ã String212 = string[212];ã String213 = string[213];ã String214 = string[214];ã String215 = string[215];ã String216 = string[216];ã String217 = string[217];ã String218 = string[218];ã String219 = string[219];ã String220 = string[220];ã String221 = string[221];ã String222 = string[222];ã String223 = string[223];ã String224 = string[224];ã String225 = string[225];ã String226 = string[226];ã String227 = string[227];ã String228 = string[228];ã String229 = string[229];ã String230 = string[230];ã String231 = string[231];ã String232 = string[232];ã String233 = string[233];ã String234 = string[234];ã String235 = string[235];ã String236 = string[236];ã String237 = string[237];ã String238 = string[238];ã String239 = string[239];ã String240 = string[240];ã String241 = string[241];ã String242 = string[242];ã String243 = string[243];ã String244 = string[244];ã String245 = string[245];ã String246 = string[246];ã String247 = string[247];ã String248 = string[248];ã String249 = string[249];ã String250 = string[250];ã String251 = string[251];ã String252 = string[252];ã String253 = string[253];ã String254 = string[254];ã String255 = string[255];ããããIMPLEMENTATIONããããEND. { HTstr.PAS }ããã 24 08-18-9312:30ALL JOSE ALMEIDA Convert byte to hex IMPORT 11 ^&CÅ { Converts a byte into hexadecimal string, and a word into hexadecimal string.ã Part of the Heartware Toolkit v2.00 (HTstring.PAS) for Turbo Pascal.ã Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.ã I can also be reached at RIME network, site ->TIB or #5314.ã Feel completely free to use this source code in any way you want, and, ifã you do, please don't forget to mention my name, and, give me and Swag theã proper credits. }ããFUNCTION Byte_To_Hex(X : byte) : String2;ã{ DESCRIPTION:ã Converts a byte into hexadecimal string.ã SAMPLE CALL:ã S := Byte_To_Hex(255);ã RETURNS:ã The hexadecimal representation of the specified value in a 2-bytes typeã string }ãvarã Digits : array [0..15] of char = '0123456789ABCDEF';ããBEGIN { Byte_To_Hex }ã Byte_To_Hex := Concat(Digits[X shr 4],Digits[X and 15]);ãEND; { Byte_To_Hex }ããããFUNCTION Word_To_Hex(X : word) : String4;ã{ DESCRIPTION:ã Converts a word into hexadecimal string.ã SAMPLE CALL:ã S := Word_To_Hex(65535);ã RETURNS:ã The hexadecimal representation of the specified value in a 4-bytes typeã string }ããBEGIN { Word_To_Hex }ã Word_To_Hex := Concat(Byte_To_Hex(X shr 8),Byte_To_Hex(X and $FF));ãEND; { Word_To_Hex }ã 25 08-27-9320:03ALL SEAN PALMER AsciiZ Strings IMPORT 8 ^&¬s {ãSEAN PALMERããthese routines change formats 'in place' without changing the number ofãbytes, ever, so you can safely use $V-ã}ããunit asciiz; {routines for converting strings to asciiz and back}ããinterfaceããprocedure asciiz2string(var a : string);ãprocedure string2asciiz(var s : string);ããimplementationãã{note: any asciiz must be length 255 or less}ããprocedure asciiz2string(var a : string); assembler;ãasmã push dsã cldã lds si, aã mov cx, 0ã @L:ã xchg al, byte ptr[si]ã inc siã or al, alã jnz @Lã mov ax, siã mov si, word ptr aã sub ax, si {calc length}ã dec axã mov [si], alã pop dsãend;ããprocedure string2asciiz(var s : string); assembler;ãasmã push dsã lds si, sã les di, sã lodsbã mov cl, alã xor ch, chã cldã rep movsbã xor al, alã stosbã pop dsãend;ããend.ãã 26 08-27-9320:24ALL GUY MCLOUGHLIN String Centering IMPORT 16 ^&–È {ãGUY MCLOUGHLINãã>What's the easiest way to center an arbitrary string on a line?ã}ããprogram CenterStringDemo;ãã{ Return a copy of the MainString, with the SubString centered }ã{ within it. Routine passes copies of variables on the STACK, }ã{ taking up more STACK space than the one below, however variable }ã{ strings passed as parameters are not permanently changed. }ã{ }ãfunction CenterStr1(MainString, SubString : String) : String;ãVarã InsertPos : byte;ã TempString : string;ãbeginã TempString := MainString;ã InsertPos := succ((length(MainString) - length(SubString)) div 2);ã move(SubString[1], TempString[InsertPos], length(SubString));ã CenterStr1 := TempString;ãend;ãã{ Center a sub-string withing the main-string. Routine uses VAR }ã{ parameters which pass pointers to the actual variable being }ã{ passed, making the changes permanent and saving on STACK space. }ã{ }ãprocedure CenterStr2(var MainString : string; var SubString : string);ãvarã InsertPos : byte;ãbeginã InsertPos := succ((length(MainString) - length(SubString)) div 2);ã move(SubString[1], MainString[InsertPos], length(SubString))ãend;ãããvarã SubStr,ã MainStr,ã TempStr : string;ããBEGINã SubStr := '----------';ã MainStr := '012345678901234567890123456789';ã { Return string with sub-string centered in main- }ã { string. Neither sub-string or main-string variables }ã { are permanently affected. }ã TempStr := CenterStr1(MainStr, SubStr);ã writeln(SubStr);ã writeln(MainStr);ã writeln(TempStr);ã writeln;ãã { Position sub-string in the center of main-string. }ã { Changes to main-string are permanent. }ã CenterStr2(MainStr, SubStr);ã writeln(SubStr);ã writeln(MainStr);ã writeln(TempStr)ãEND.ãã 27 08-27-9320:27ALL SWAG SUPPORT TEAM Compare Strings IMPORT 4 ^&'• Function CompareStr(Str1, Str1 : String) : Boolean;ãbeginã if (Length(Str1) = Length(Str2)) and (Pos(Str1, Str2) <> 0)) thenã CompareStr := Trueã elseã CompareStr := False;ãend;ããFunction CompareStrContext(Str1, Str2 : String) : Boolean;ãbeginã CompareStrContext := CompareStr(StUpCase(Str1), StUpCase(Str2));ãend;ã 28 08-27-9322:00ALL KELD HANSEN Adding Strings together IMPORT 7 ^&-? { KELD R. HANSEN }ããPROCEDURE AddStr(VAR STR : OpenString ; CONST ADD : STRING); ASSEMBLER;ãASMã PUSH DSã LDS SI,ADDã LES DI,STRã CLDã XOR BH,BHã MOV BL,ES:[DI]ã LODSBã MOV AH,BYTE PTR STR-2ã ADD AL,BLã JC @OVFã CMP AL,AHã JBE @OKã @OVF:ã MOV AL,AHã @OK:ã STOSBã XOR CH,CHã MOV CL,ALã SUB CL,BLã ADD DI,BXã REP MOVSBã POP DSãEND;ããPROCEDURE AddChar(VAR STR : OpenString ; C : CHAR); ASSEMBLER;ãASMã LES DI,STRã XOR AH,AHã MOV AL,ES:[DI]ã CMP AX,WORD PTR STR-2ã JAE @OUTã INC ALã JZ @OUTã MOV ES:[DI],ALã ADD DI,AXã MOV AL,Cã STOSBã @OUT:ãEND;ã 29 09-26-9308:45ALL MARTIN RICHARDSON Trim spaces from string IMPORT 7 ^&"k {*****************************************************************************ã * Function ...... AllTrim()ã * Purpose ....... To trim off spaces from either side of a stringã * Parameters .... str String to trimã * Returns ....... str with leading and trailing spaces removedã * Notes ......... Uses function LTrim and RTrimã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION AllTrim( str : STRING ) : STRING;ãBEGINã IF LENGTH( Str ) > 0 THENã AllTrim := LTrim(RTrim(str, ' '), ' ')ã ELSEã AllTrim := Str;ãEND;ãã 30 09-26-9308:47ALL MARTIN RICHARDSON Integer to string w/commaIMPORT 7 ^&"ã {*****************************************************************************ã * Function ...... Commaã * Purpose ....... To return an integer as a string with separating commasã * Parameters .... i Integer to return as stringã * Returns ....... i as a string, with seperating commasã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION Comma( i: LONGINT ): STRING;ã{ FUNCTION to place commas in a number for printing }ãVAR ã s: STRING;ã x: INTEGER;ãBEGINã STR( i:0, s );ã x := LENGTH( s ) - 2;ã WHILE x > 1 DO BEGINã INSERT( ',', s, x );ã DEC( x, 3 );ã {W}END;ã Comma := s;ãEND;ãã 31 09-26-9308:48ALL MARTIN RICHARDSON Return commandline stringIMPORT 5 ^&"; {*****************************************************************************ã * Function ...... Commandã * Purpose ....... To return the command line as a stringã * Parameters .... Noneã * Returns ....... The entire command line as one stringã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION Command: STRING;ãBEGINã Command := STRING( PTR(PREFIXSEG, $0080)^ );ãEND;ãã 32 09-26-9308:51ALL MARTIN RICHARDSON Determine empty string IMPORT 8 ^&"; {*****************************************************************************ã * Function ...... Empty()ã * Purpose ....... To determine if a string is emptyã * Parameters .... s String to checkã * Returns ....... TRUE if is 0 bytes in length, or is filled with #0 orã * spaces.ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION Empty( s: STRING ): BOOLEAN; ASSEMBLER;ãASMã CLDã XOR CH, CHã LES DI, sã MOV CL, BYTE PTR ES:[DI]ã JCXZ @@1ã INC DIã MOV AL, ' 'ã REPE SCASBã JZ @@1 { empty }ã MOV AL, Falseã JMP @@2ã@@1: MOV AL, Trueã@@2:ãEND;ãã 33 09-26-9309:04ALL MARTIN RICHARDSON Get File Extension StringIMPORT 8 ^&"Û {*****************************************************************************ã * Function ...... GetExt()ã * Purpose ....... To return the extention (minus the dot) of a filepathã * Parameters .... Path Filepath/mask to return the extension ofã * Returns ....... Three character DOS file extensionã * Notes ......... Uses functions Right, Empty, and PadRã * Author ........ Martin Richardsonã * Date .......... October 23, 1992ã *****************************************************************************}ãFUNCTION GetExt( Path: DirStr ): ExtStr;ãVAR dir : DirStr;ã name : NameStr;ã ext : ExtStr;ãBEGINã FSPLIT( path, dir, name, ext );ã IF NOT Empty( Name ) THENã GetExt := Right( PadR( ext, 4, ' ' ), 3 )ã ELSEã GetExt := ' ';ãEND;ãã 34 09-26-9309:05ALL MARTIN RICHARDSON Get MASK from path/mask IMPORT 7 ^&"k {*****************************************************************************ã * Function ...... GetMask()ã * Purpose ....... To return the mask from a path/mask stringã * Parameters .... Path String to extract the mask fromã * Returns ....... The file mask portion of ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãTYPEã String13 = STRING[13];ãFUNCTION GetMask( Path: DirStr ): String13;ãVAR dir : DirStr;ã name : NameStr;ã ext : ExtStr;ãBEGINã FSPLIT( path, dir, name, ext );ã GetMask := name + ext;ãEND;ãã 35 09-26-9309:06ALL MARTIN RICHARDSON Get name MINUS EXT IMPORT 8 ^&"k {*****************************************************************************ã * Function ...... GetName()ã * Purpose ....... To return the file name (minus .EXT) from a path/maskã * string.ã * Parameters .... Path File path/mask to return the name fromã * Returns ....... 8 character DOS file name without extensionã * Notes ......... Uses functions Empty and Replicateã * Author ........ Martin Richardsonã * Date .......... October 23, 1992ã *****************************************************************************}ãFUNCTION GetName( Path : DirStr ): NameStr;ãVAR dir : DirStr;ã name : NameStr;ã ext : ExtStr;ãBEGINã FSPLIT( path, dir, name, ext );ã IF NOT Empty( Name ) THENã GetName := Nameã ELSE IF NOT Empty( Ext ) THENã GetName := Extã ELSEã GetName := Replicate( ' ', SIZEOF( Name ) );ãEND;ãã 36 09-26-9309:06ALL MARTIN RICHARDSON Get Path from path/mask IMPORT 7 ^&"k {*****************************************************************************ã * Function ...... GetPath()ã * Purpose ....... To return the path from a path/mask stringã * Parameters .... Path String to extract the path fromã * Returns ....... minus the maskã * Notes ......... Trailing slash *IS* included if it is thereã * (eg, C:\PROGRAM\PASCAL\)ã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION GetPath( Path: DirStr ): DirStr;ãVARã dir : DirStr;ã name: NameStr;ã ext : ExtStr;ãBEGINã FSPLIT( path, dir, name, ext );ã GetPath := Dir;ãEND;ãã 37 09-26-9309:07ALL MARTIN RICHARDSON Show HEX Byte as string IMPORT 16 ^&;¹ TYPEã String2 = STRING[2];ã String4 = STRING[4];ã String8 = STRING[8];ãã{*****************************************************************************ã * Function ...... HexB()ã * Purpose ....... To return a byte's hexidecimal representationã * Parameters .... b Byte to convert to Hexã * Returns ....... The hex string equivalent of ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION HexB( b: BYTE ): String2;ãCONSTã HexChar : ARRAY[0..15] OF Char = '0123456789ABCDEF';ãBEGINã Hexb := HexChar[b SHR 4] + HexChar[b AND $F];ãEND;ãã{*****************************************************************************ã * Function ...... HexW()ã * Purpose ....... To return a word's hexidecimal representationã * Parameters .... w Word to convert to Hexã * Returns ....... The hex string equivalent of ã * Notes ......... Uses function HexBã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION HexW( w: WORD ): String4;ãBEGINã HexW := HexB(HI(w)) + HexB(LO(w));ãEND;ãã{*****************************************************************************ã * Function ...... HexDW()ã * Purpose ....... To return a double-word's hexidecimal representationã * Parameters .... dw Double-word to convert to Hexã * Returns ....... The hex string equivalent of ã * Notes ......... Uses functions HexB, wHi, and wLoã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION HexDW( dw: LONGINT ): String8;ãBEGINã HexDW := HexB(HI(wHi(dw))) + HexB(LO(wHi(dw))) +ã HexB(HI(wLo(dw))) + HexB(LO(wLo(dw)))ãEND;ã 38 09-26-9309:09ALL MARTIN RICHARDSON "IF" Boolean processing IMPORT 27 ^&"ã {*****************************************************************************ã * Function ...... CIF()ã * Purpose ....... To return a character based on a boolean expressionã * Parameters .... Exp Boolean expression to evaluateã * tVar Result if is TRUEã * fVar Result if is FALSEã * Returns ....... if is TRUE, if is FALSEã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION CIF( Exp: BOOLEAN; tVar, fVar: CHAR ): CHAR; ASSEMBLER;ãASMã TEST Exp, 1ã JZ @@1ã MOV AL, tVarã JMP @@2ã@@1: MOV AL, fVarã@@2:ãEND;ãã{*****************************************************************************ã * Function ...... SIF()ã * Purpose ....... To return a string based on a boolean expressionã * Parameters .... Exp Boolean expression to evaluateã * tVar Result if is TRUEã * fVar Result if is FALSEã * Returns ....... if is TRUE, if is FALSEã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION SIF( Exp: BOOLEAN; tVar, fVAR: STRING ): STRING; ASSEMBLER;ãASMã PUSH DSã TEST Exp, 1ã JZ @@1ã LDS SI, tVarã JMP @@2ã@@1: LDS SI, fVarã@@2: LES DI, @Resultã XOR CH, CHã MOV CL, BYTE PTR DS:[SI]ã MOV BYTE PTR ES:[DI], CLã INC DIã INC SIã CLDã REP MOVSBã POP DSãEND;ãã{*****************************************************************************ã * Function ...... IIF()ã * Purpose ....... To return an integer based on a boolean expressionã * Parameters .... Exp Boolean expression to evaluateã * tVar Result if is TRUEã * fVar Result if is FALSEã * Returns ....... if is TRUE, if is FALSEã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION IIF( Exp: BOOLEAN; tVar, fVar: LONGINT ): LONGINT; ASSEMBLER;ãASMã TEST Exp, 1ã JZ @@1ã MOV AX, WORD PTR tVar[0]ã MOV DX, WORD PTR tVar[2]ã JMP @@2ã@@1: MOV AX, WORD PTR fVar[0]ã MOV DX, WORD PTR fVar[2]ã@@2:ãEND;ãã{*****************************************************************************ã * Function ...... RIF()ã * Purpose ....... To return a real based on a boolean expressionã * Parameters .... Exp Boolean expression to evaluateã * tVar Result if is TRUEã * fVar Result if is FALSEã * Returns ....... if is TRUE, if is FALSEã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION RIF( Exp : BOOLEAN; tVar, fVAR : REAL ) : REAL;ãBEGINã IF Exp THEN RIF := tVAR ELSE RIF := fVar;ãEND;ã 39 09-26-9309:09ALL MARTIN RICHARDSON Locate String in SUB-Str IMPORT 8 ^&"; {*****************************************************************************ã * Function ...... InStr()ã * Purpose ....... To locate a substring in a string starting at a givenã * position.ã * Parameters .... n Position in the string to start searchingã * sub Substring to search forã * s String to search inã * Returns ....... Numeric position of _{in string after position ã * Notes ......... Uses function Rightã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION InStr( n: BYTE; sub: STRING; s: STRING ): BYTE;ãBEGINã InStr := POS( sub, Right( s, LENGTH(s)-n+1 ) ) + n - 1;ãEND;ãã 40 09-26-9309:10ALL MARTIN RICHARDSON Locate SubStr at Right IMPORT 9 ^&"› {*****************************************************************************ã * Function ...... InStrRã * Purpose ....... To locate a substring in a string starting at a givenã * position from the right of the string.ã * Parameters .... n Position in the string to start searchingã * sub Substring to search forã * s String to search inã * Returns ....... Numeric position of in string after position ã * from right to left.ã * Notes ......... Uses function Rightã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION InStrR( n: BYTE; sub: STRING; s: STRING ): BYTE;ãVAR i: INTEGER;ãBEGINã i := POS( sub, Right( s, LENGTH(s)-n+1 ) ) + n - 1;ã IF i = 0 THENã InStrR := iã ELSEã InStrR := LENGTH( s ) - i + 1;ãEND;ãã 41 09-26-9309:12ALL MARTIN RICHARDSON Convert INTEGER to stringIMPORT 8 ^&"› {*****************************************************************************ã * Function ...... ITOS()ã * Purpose ....... Convert an integer to a string in lengthã * Parameters .... nNum Integer to convertã * nSpaces Length of resultant stringã * Returns ....... nNum as a string, in lengthã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION ITOS( nNum: LONGINT; nSpaces: INTEGER ): STRING;ãVARã s: ^STRING;ãBEGINã ASM ã mov sp, bp ã push ssã push WORD PTR @RESULTã END;ãã IF nSpaces > 0 THENã STR( nNum:nSpaces, s^ )ã ELSEã STR( nNum:0, s^ );ãEND;ãã 42 09-26-9309:13ALL MARTIN RICHARDSON Get LEFT part of STRING IMPORT 9 ^&"› {*****************************************************************************ã * Function ...... Left()ã * Purpose ....... To return the left part of a stringã * Parameters .... s String to return the left part ofã * n Number of characters to returnã * Returns ....... A string containing the leftmost characters of .ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION Left( s: STRING; n: BYTE ): STRING; ASSEMBLER;ãASMã PUSH DSãã LES DI, @Resultã LDS SI, sã MOV AL, nã CLDã XOR CX, CXãã MOV CL, BYTE PTR [SI]ã INC SIã CMP CX, 0ã JZ @@2ã CMP AL, 0ã JLE @@1ãã MOV BYTE PTR ES:[DI], ALã INC DIã MOV CL, ALãã REP MOVSBã JMP @@3ãã@@1: MOV CL, 0ã@@2: MOV ES:[DI],CLãã@@3: POP DSãEND;ã ã 43 09-26-9309:14ALL HELGE HELGESEN Convert Long to HEX Str IMPORT 34 ^&…š (*ã===========================================================================ã BBS: Canada Remote SystemsãDate: 09-16-93 (08:30) Number: 27395ãFrom: HELGE HELGESEN Refer#: NONEã To: KURTIS LINDQVIST Recvd: NOãSubj: Longint to HEX Conf: (552) R-TPã---------------------------------------------------------------------------ãHere's a simple - unoptimized - function to convert aãlongint to hex.ã*)ãfunction LongInt2Str(no: longint): string; assembler;ãconstã Digits: array[0..$f] of char =ã ( '0', '1', '2', '3', '4' ,'5', '6', '7', '8', '9', 'A', 'B', 'C',ã 'D', 'E', 'F'ã );ãasmã les di, @Result { get address to result }ã mov al, 8 { size of result }ã stosbã lea bx, Digits { get adress to digit table }ã mov dx, word ptr no+2ã mov cx, 2ã@1:ã mov al, dhã shr al, 4ã xlatã stosbã mov al, dhã and al, 15ã xlatã stosbã mov al, dlã shr al, 4ã xlatã stosbã mov al, dlã and al, 15ã xlatã stosbã mov dx, word ptr noã loop @1ãend;ã---ã þ RM 1.2 00308 þ C program run. C program crash. C programmer quitã * Midnight Sun BBS, Norway +47 81 84545 HST/DS, 9 Gbã * PostLink(tm) v1.07 MIDNIGHT (#602) : RelayNet(tm)ã===========================================================================ã BBS: Canada Remote SystemsãDate: 09-16-93 (20:19) Number: 27393ãFrom: PHIL NICKELL Refer#: NONEã To: KURTIS LINDQVIST Recvd: NOãSubj: Longint to HEX Conf: (552) R-TPã---------------------------------------------------------------------------ãKL³Allright, I have been struggling with this problem for awhile but I give up.ã ³A friend of mine wrote a unit that would convert a longint to a HEX number inã ³string. This is for a program that stores one file for each user (it's an ordã ³door), the name of the file is equal to the HEX number representing theãã I'll include two functions named HEXLONG that produce identicalã results. The first is pure classic Turbo Pascal, the second is a Turboã Pascal Assembler function that is blinding-speed vs size optimized.ã You pass them a longint value, they return an 8 byte string. Voila.ã Take your pick.ããã(* Return a 8 byte ascii string of the hex value of the longintã argument *)ãFUNCTION Hexlong (argument : longint): namestr;ã var i :longint;ã res :namestr;ã Constã HexTable :array[0..15] of char = '0123456789ABCDEF';ã beginã res[0] := #8;ã for i := 0 to 7 doã res[8-i] := HexTable[ argument shr (i shl 2) and $f];ã hexlong := res;ã end;ããFUNCTION Hexlong (argument : longint): namestr; Assembler;ã asmã cldã les di,@resultã mov al,8 { store string length }ã stosbã mov cl, 4 { shift count }ãã mov dx,Word Ptr Argument+2 { hi word }ã call @1 { convert dh to ascii }ã mov dh, dl { lo byte of hi word }ã call @1 { convert dh to ascii }ã mov dx,Word Ptr Argument { lo word }ã call @1 { convert dh to ascii }ã mov dh, dl { lo byte of lo word }ã call @1 { convert dh to ascii }ã jmp @2ãã @1:ã mov al, dh { 1 byte }ã and al, 0fh { low nybble }ã add al, 90hã daaã adc al, 40hã daaã mov ah, al { store }ã mov al, dh { 1 byte }ã shr al, cl { get high nybble }ã add al, 90hã daaã adc al, 40hã daaã stosw { move characters to result }ã retn { return near }ã @2:ã end;ããbeginã Writeln( Hexlong($1234ABCD) );ãend.ã---ã þ SLMR 2.1a þ doesn't take a rocket scientist to be a rocket scientistã þ KMail 3.00d Twin Peaks (303)-651-0225 þ Home of KMail þã þ RNET 2.00b: þ Twin Peaks BBS þ (303)-651-0225, Longmont, Co.ã * The DC Information Exchange (703)836-0748ã * PostLink(tm) v1.07 DCINFO (#16) : MetroLink(tm)ã 44 09-26-9309:14ALL MARTIN RICHARDSON Convert to LOWER case IMPORT 8 ^& {*****************************************************************************ã * Function ...... LowerCase()ã * Purpose ....... To convert a string to all lower caseã * Parameters .... s String to convertã * Returns ....... in all lower case letersã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION LowerCase( s: STRING ): STRING; ASSEMBLER;ãASMã PUSH DSã CLDã LDS SI, sã XOR AX, AXã LODSBã XCHG AX, CXã LES DI, @Resultã MOV BYTE PTR ES:[DI], CLã JCXZ @@3ãã@@1: LODSBã CMP AL, 'A'ã JB @@2ã CMP AL, 'Z'ã JA @@2ã OR AL, $20ãã@@2: STOSBã LOOP @@1ãã@@3: POP DSãEND;ãã 45 09-26-9309:15ALL MARTIN RICHARDSON Trim LEFT side of STRING IMPORT 9 ^&"; {*****************************************************************************ã * Function ...... LTrim()ã * Purpose ....... To trim a character off the left side of a stringã * Parameters .... s String to trimã * c Character to trim from ã * Returns ....... with all characters removed from the left sideã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION LTrim( s: STRING; c: CHAR ): STRING; Assembler;ãASMã PUSH DSã LDS SI, sã XOR AX, AXã LODSBã XCHG AX, CXã LES DI, @Resultã INC DIã JCXZ @@2ãã MOV BL, cã CLDã@@1: LODSBã CMP AL, BLã LOOPE @@1ã DEC SIã INC CXã REP MOVSBãã@@2: XCHG AX, DIã MOV DI, WORD PTR @Resultã SUB AX, DIã DEC AXã STOSBã POP DSãEND;ãã 46 09-26-9309:21ALL MARTIN RICHARDSON Pad STRING to the LEFT IMPORT 10 ^&"› {*****************************************************************************ã * Function ...... PadL()ã * Purpose ....... To pad the left side of a string with a characterã * Parameters .... s String to padã * c Character to pad withã * n New length for ã * Returns ....... padded with character with length ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION PADL( s: STRING; n: BYTE; c: CHAR ): STRING; ASSEMBLER;ãASMã PUSH DSã CLDãã LES DI, @Resultã INC DIã LDS SI, sã XOR AX, AXã LODSBã PUSH AXãã XOR CX, CXã MOV CL, nã SUB CL, ALãã CMP CX, 0ã JNB @@1ã XOR CX, CXãã@@1: MOV AL, cã REP STOSBãã POP CXã REP MOVSBãã MOV DI, WORD PTR @Resultã MOV AL, nã MOV BYTE PTR ES:[DI], ALã POP DSãEND;ã 47 09-26-9309:21ALL MARTIN RICHARDSON Pad STRING to RIGHT IMPORT 9 ^&"› {*****************************************************************************ã * Function ...... PadR()ã * Purpose ....... To pad the right side of a string with a characterã * Parameters .... s String to padã * c Character to pad withã * n New length for ã * Returns ....... padded with character with length ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION PADR( s: STRING; n: BYTE; c: CHAR ): STRING; ASSEMBLER;ãASMã PUSH DSã CLDã LDS SI, sã XOR AX, AXã LODSBã MOV CX, AXãã LES DI, @Resultã INC DIã REP MOVSBãã MOV CL, nã SUB CL, ALãã CMP CX, 0ã JNB @@1ã XOR CX, CXãã@@1: MOV AL, cã REP STOSBãã MOV DI, WORD PTR @Resultã MOV AL, nã MOV BYTE PTR ES:[DI], ALãã POP DSãEND;ãã 48 09-26-9309:23ALL MARTIN RICHARDSON Get LAST SUB in STRING IMPORT 13 ^&"ã {*****************************************************************************ã * Function ...... Rat()ã * Purpose ....... Locate the last occurance of a substring in a stringã * Parameters .... sub Substring to locateã * s String to look for inã * Returns ....... Numeric last position of in s, counting fromã * left to right.ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION Rat( sub: STRING; s: STRING ): BYTE; ASSEMBLER;ãVARã nResult: WORD;ãASMã PUSH DSã XOR CX, CXã XOR BX, BXãã LDS SI, subã XOR AX, AXã LODSBã XCHG BX, AXãã CMP BX, 0ã JBE @@3ãã LES DI, sã LODSBã MOV DX, AXã CMP DX, 0ã JBE @@3ãã CMP BX, DXã JAE @@3ãã DEC BXã CLDã@@1: MOV SI, WORD PTR subã INC SIã LODSBãã MOV CX, DXã REPNE SCASBã JNZ @@3ãã MOV DX, CXã MOV CX, BXã REPE CMPSBã JZ @@4ãã ADD DI, CXã SUB DI, BXã@@2: CMP DX, BXã JA @@1ã@@3: XOR AL, ALã JMP @@5ã@@4: SUB DI, BXã DEC DIã SUB DI, WORD PTR sã MOV nResult, DIã ADD DI, WORD PTR sã ADD DI,CXã INC DIã JMP @@2ã@@5:ã MOV AX, nResultã POP DSãEND;ãã 49 09-26-9309:24ALL MARTIN RICHARDSON Replicate CHAR in STRING IMPORT 7 ^& {*****************************************************************************ã * Function ...... Replicate()ã * Purpose ....... To duplicate a character a certain number of timesã * Parameters .... c Character to duplicateã * n Number of times to duplicate ã * Returns ....... A string long filled with character ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION Replicate( c: CHAR; n: BYTE ): STRING; ASSEMBLER;ãASMã XOR CX, CXã MOV AL, cã MOV CL, nã LES DI, @Resultã MOV BYTE PTR ES:[DI], CLã INC DIã CLDã REP STOSBãEND;ãã 50 09-26-9309:24ALL MARTIN RICHARDSON Get RIGHT part of STRING IMPORT 10 ^&"; {*****************************************************************************ã * Function ...... Right()ã * Purpose ....... To return the right part of a stringã * Parameters .... s String to return the right part ofã * n Number of characters to returnã * Returns ....... A string containing the rightmost characters of .ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION Right( s: STRING; n: BYTE ): STRING; ASSEMBLER;ãASMã PUSH DSã LES DI, @Resultãã LDS SI, sã MOV AL, nã CLDã XOR CX, CXãã MOV CL, BYTE PTR [SI]ã INC SIã CMP CX, 0ã JZ @@2ã CMP AL, 0ã JLE @@1ãã MOV BYTE PTR ES:[DI], ALã INC DIãã SUB CL, ALã ADD SI, CXã MOV CL, ALãã REP MOVSBã JMP @@3ãã@@1: MOV CL, 0ã@@2: MOV BYTE PTR ES:[DI], CLã@@3: POP DSãEND;ãã 51 09-26-9309:24ALL MARTIN RICHARDSON Get SUB STRING at RIGHT IMPORT 15 ^&"k {*****************************************************************************ã * Function ...... RightAt()ã * Purpose ....... Return the last position of a substring as viewed fromã * the right side of the stringã * Parameters .... sub Substring to locateã * s String to find inã * Returns ....... Numeric last position of in s, counting fromã * right to left.ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã*****************************************************************************}ãFUNCTION RightAt( sub: STRING; s: STRING ): BYTE; ASSEMBLER;ãVARã nResult: WORD;ãASMã PUSH DSã XOR CX, CXãã LDS SI, subã XOR AX, AXã LODSBã MOV BX, AXã CMP BX, 0ã JBE @@3ãã LES DI, sã XOR DX, DXã MOV DL, BYTE PTR ES:[DI]ã INC DIã CMP DX, 0ã JBE @@3ãã PUSH DXãã CMP BX, DXã JAE @@3ãã DEC BXã CLDã@@1: MOV SI, WORD PTR subã INC SIã LODSBãã MOV CX, DXã REPNE SCASBã JNZ @@3ãã MOV DX, CXã MOV CX, BXã REPE CMPSBã JZ @@4ãã ADD DI, CXã SUB DI, BXã@@2: CMP DX, BXã JA @@1ã@@3: XOR AL, ALã JMP @@5ã@@4: SUB DI, BXã DEC DIã SUB DI, WORD PTR sã MOV nResult, DIã ADD DI, WORD PTR sã ADD DI,CXã INC DIã JMP @@2ã@@5:ã POP BXã MOV AX, nResultã CMP AX, 0ã JE @@6ã XCHG AX, BXã SUB AX, BXã INC AXã@@6: POP DSãEND;ãã 52 09-26-9309:25ALL MARTIN RICHARDSON Convert REAL to STRING IMPORT 8 ^&"› {*****************************************************************************ã * Function ...... RTOS()ã * Purpose ....... To convert a REAL to a stringã * Parameters .... nNum REAL to convert to string formatã * nLength Length of resultant stringã * nDec Decimal placesã * Returns ....... as a string, long to decimal placesã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION RTOS( nNum: REAL; nLength, nDec: INTEGER ): STRING;ãVARã s: ^STRING;ãBEGINã ASM ã mov sp, bp ã push ssã push WORD PTR @RESULTã END;ã STR( nNum:nLength:nDec, s^ );ãEND;ãã 53 09-26-9309:25ALL MARTIN RICHARDSON Trim STRING on the RIGHT IMPORT 7 ^&"; {*****************************************************************************ã * Function ...... RTrim()ã * Purpose ....... To trim a character off the right side of a stringã * Parameters .... s String to trimã * c Character to trim from ã * Returns ....... with all characters removed from the right sideã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION RTrim( s: STRING; c: CHAR ): STRING;ãBEGINã WHILE (LENGTH(s) > 0) AND (s[LENGTH(s)] = c) DO DEC(s[0]);ã RTrim := s;ãEND;ãã 54 09-26-9309:29ALL MARTIN RICHARDSON Strip CHARS from STRING IMPORT 9 ^&" {*****************************************************************************ã * Function ...... StripChar;ã * Purpose ....... To removed a specified character from a string.ã * Parameters .... s String to remove character fromã * c Character to removeã * Returns ....... String with character removed.ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION StripChar( s: STRING; c: CHAR ): STRING; Assembler;ãASMã PUSH DSã CLDã LDS SI, sã XOR AX, AXã LODSBã XCHG AX, CXã LES DI, @Resultã INC DIã JCXZ @@3ã MOV BL, cãã@@1: LODSBã CMP AL, BLã JE @@2ã STOSBãã@@2: LOOP @@1ãã@@3: XCHG AX, DIã MOV DI, WORD PTR @Resultã SUB AX, DIã DEC AXã STOSBã POP DSãEND;ãã 55 09-26-9309:29ALL MARTIN RICHARDSON Replace portion of STRINGIMPORT 9 ^&"k {*****************************************************************************ã * Function ...... StrTran()ã * Purpose ....... To replace portions of a stringã * Parameters .... Source Master string to do the replace inã * Old Portion to replaceã * New New portion to replace withã * Returns ....... Source with all occurances of replaced with ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION StrTran( Source, Old, New : STRING ) : STRING;ãVAR p : INTEGER;ãBEGINã WHILE POS( Old, Source ) <> 0 DO BEGINã p := POS( Old, Source );ã DELETE( Source, p, LENGTH( Old ) );ã INSERT( New, Source, p );ã {W}END;ã StrTran := Source;ãEND; { StrTran }ãã 56 09-26-9309:29ALL MARTIN RICHARDSON Get number STRING w/ZEROSIMPORT 7 ^&"k {*****************************************************************************ã * Function ...... StrZero()ã * Purpose ....... To return a number as a string with leading zerosã * Parameters .... Num Number to make into a stringã * Len Length of resultant stringã * Returns ....... as a string, in length with leading zerosã * Notes ......... Uses the functions PadL and ITOSã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION StrZero( Num, Len : LONGINT ) : STRING;ãBEGINã StrZero := PadL( ITOS( Num, 0 ), Len, '0' );ãEND; { StrZero }ãã 57 09-26-9309:30ALL MARTIN RICHARDSON Stuff SUB in STRING IMPORT 9 ^&"; {*****************************************************************************ã * Function ...... Stuff()ã * Purpose ....... To stuff a string with a sub-stringã * Parameters .... Dest String to stuff intoã * Pos Position in to start insertingã * Num Number of characters to overwrite in ã * Source String to stuff into ã * Returns ....... stuffed with at postion ã * Notes ......... Uses the function Left.ã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION Stuff( Dest : STRING; Pos, Num : INTEGER; Source : STRING ) : STRING;ãBEGINã IF LENGTH( Source ) > Num THEN Source := Left( Source, Num );ã DELETE( Dest, Pos, Num );ã INSERT( Source, Dest, Pos );ã Stuff := Dest;ãEND; { Stuff }ãã 58 09-26-9309:30ALL MARTIN RICHARDSON Uppercase STRING IMPORT 8 ^& {*****************************************************************************ã * Function ...... UpperCase()ã * Purpose ....... To convert a string to upper caseã * Parameters .... s String to convertã * Returns ....... with all capital lettersã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... October 2, 1992ã *****************************************************************************}ãFUNCTION UpperCase( s: STRING ): STRING; ASSEMBLER;ãASMã PUSH DSã CLDã LDS SI, sã XOR AX, AXã LODSBã XCHG AX, CXã LES DI, @Resultã MOV BYTE PTR ES:[DI], CLã JCXZ @@3ã INC DIãã@@1: LODSBã CMP AL, 'a'ã JB @@2ã CMP AL, 'z'ã JA @@2ã XOR AL, $20ãã@@2: STOSBã LOOP @@1ãã@@3: POP DSãEND;ãã 59 09-26-9310:09ALL LEE BARKER Fast Upper/Lower Case IMPORT 10 ^&Pc (*ãFrom: LEE BARKERãSubj: FAST Up/Low Case CORRECTIONã*)ããUses CRT;ãã function LoStr(const s:string):string; assembler;ã asmã push dsã lds si,sã les di,@resultã lodsb { load and store length of string }ã stosbã xor ch,chã mov cl,alã jcxz @empty { FIX for null string }ã @LowerLoop:ã lodsbã cmp al,'A'ã jb @contã cmp al,'Z'ã ja @contã add al,' 'ã @cont:ã stosbã loop @LowerLoopã @empty:ã pop dsã end; { LoStr }ãã function UpStr(const s:string):string; assembler;ã asmã push dsã lds si,sã les di,@resultã lodsb { load and store length of string }ã stosbã xor ch,chã mov cl,alã jcxz @empty { FIX for null length string }ã @upperLoop:ã lodsbã cmp al,'a'ã jb @contã cmp al,'z'ã ja @contã sub al,' 'ã @cont:ã stosbã loop @UpperLoopã @empty:ã pop dsã end; { UpStr }ããVAR S : String;ããBEGINã ClrScr;ã WriteLn(LoStr('LEE BARKER'));ã WriteLn(UpStr('lee barker'));ã Readkey;ãEND.ã 60 10-28-9311:26ALL BRUCE LACLORE BOOLEAN String Function IMPORT 113 ^&ၠUnit BoolPos;ãã{ Version 1.3.3.P.ãã Requires Borland Turbo Pascal version 6.0 or later to compile.ãã Author: Bruce J. Lackore. Created Friday, July 23, 1993.ã Copyright (c) 1993 Bruce J. Lackore. ALL RIGHTS RESERVED.ã}ãã{$IFDEF Test}ã {$A+,B-,D+,F-,G-,I+,L+,O-,R+,S+,V-,X+}ã{$ELSE}ã {$A+,B-,D-,F-,G-,I-,L-,O-,R-,S-,V-,X+}ã{$ENDIF}ãã{ This unit comprises a function capable of searching a string for multipleã occurences of substrings using Boolean operators. In the search string,ã Boolean operators And and Or are defined as follows:ãã & - Andã | - Orãã Parentheses are supported for doing multiple searches. Search strings areã submitted as follows:ãã i.e. In the source string "The quick brown fox jumped over the lazy dog"ã and the search is for the word blue and the words quick or fox,ã the search string is entered as follows:ãã (blue&(quick|fox))ãã The way the function is currently written, And (&) and Or (|) have the sameã precedence level hence the above search string without parentheses would beã interpretted to be (blue&quick|fox):ãã blue And quick would be searched for first, the result Or'd with theã results of the search for fox.ãã Notice the difference in that (blue&(quick|fox)) is a False statement whilstã (blue&quick|fox) is True.ãã The function will automatically scan for () pairs, adding the necessary )ã at the end of the search string or ( at the beginning if required.ãã The function will also search for (|, |), (& and &) symbols, these beingã illegal.ãã}ãã{ Bug fixes:ãã 10/04/1993: Noticed that length of Src_str in function Next_CPos wasã incorrectly calculated because of positioning of INC DI.ã INC DI precedes the MOV CL,[ES:DI] causing the function toã consider the first character of Src_str to represent theã length rather than the actual length byte. Fix is to moveã the INC DI to the line following the MOV CL,[ES:DI].ã}ããInterfaceããFunction BPos(Srch_str, Src_str: String; Ignore_case: Boolean): Boolean;ãã{ This function accepts a source string and a search string as described aboveã and returns a Boolean value based on whether or not the parsed searchã string was found.ã}ãã{ ************************************************************************** }ããImplementationããConstã Lt_pn: Char = '(';ã Rt_pn: Char = ')';ããFunction Cnt_ch(Scan_char: Char; In_str: String): Byte; Assembler;ãã{ This function will scan a string for occurences of a particular character.ã The function will return the number of occurences.ã}ãã Asm { Function Cnt_ch }ã XOR AX,AX { 0 AX }ã MOV BL,Scan_char { Put char to count in BL }ã LES SI,In_str { Set ES:SI to point to start of string }ã XOR CX,CX { 0 CX }ã MOV CL,[ES:SI] { Move string length to CX }ã ADD SI,CX { Set ES:SI to point to END of string }ã @LOOK: CMP BL,[ES:SI] { Start Loop, compare current char and BL }ã JNE @NEXT { If not equal, jump to end of loop }ã INC AX { If equal, Inc char cnt (AX) }ã @NEXT: DEC SI { Set ES:SI back one character }ã LOOP @LOOK { Decrement CX and jump to start of loop }ã End; { Function Cnt_ch }ããFunction Fill_str(Dupe_ch: Char; How_many: Byte): String; Assembler;ãã{ This function returns How_many of Dupe_char.ã}ãã Asm { Function Fill_str }ã LES DI, @Result { Set ES:DI to function result area }ã CLD { Clear direction flag }ã XOR CH,CH { 0 CH }ã MOV CL,How_many { Length in CX }ã MOV AX,CX { and in AX }ã STOSB { Store length byte }ã MOV AL,Dupe_ch { Put char to dupe in AL }ã REP STOSB { Fill string with char }ã End; { Function Fill_str }ããFunction PosC(Srch_ch: Char; Src_str: String): Boolean; Assembler;ãã{ This function is similar to the Pos function of Pascal except that itã accepts only a single character to search for. This function returns aã True if a Srch_ch is encountered, a False if not.ã}ãã Asm { Function PosC }ã XOR BX,BX { 0 BX }ã MOV AL,Srch_ch { Put char to look for in AL }ã LES DI,Src_str { Set ES:DI to start of Src_str }ã XOR CX,CX { 0 CX }ã MOV CL,[ES:DI] { Store length of Src_str in CL }ã ADD DI,CX { Set ES:DI to end of string }ã STD { Set direction flag }ã @LOOK: REPNZ SCASB { Look for AL in Src_str }ã JNZ @DONE { If not found, jump to end (BX = 0) }ã INC BX { If Found, Inc Bx to 1 = Pascal True }ã @DONE: MOV AX,BX { Move BX to AX (return result) }ã End; { Function PosC }ããFunction Last_Cpos(Srch_ch: Char; Src_str: String): Byte; Assembler;ãã{ This function performs the same function as the Pascal POS function exceptã that it works only with a single character and rather than returning theã first position the character is found in, it returns the LAST position thatã the search character is found in.ã}ãã Asm { Function Last_Cpos }ã MOV AL,Srch_ch { Put char to look for in AL }ã LES DI,Src_str { Set ES:DI to start of Src_str }ã XOR CX,CX { 0 CX }ã MOV CL,[ES:DI] { Move length of Src_str to CL }ã ADD DI,CX { Set ES:DI to end of Src_str }ã INC CX { Add one to CX (correct for string length }ã STD { Set direction flag }ã REPNZ SCASB { Look for character in string }ã MOV AX,CX { If found CX indicates position, else 0 }ã End; { Function Last_Cpos }ããFunction Next_CPosã (Srch_ch: Char; Src_str: String; Strt_at: Byte): Byte; Assembler;ãã{ This function searches for the next occurence of Srch_ch in Src_str AFTERã position Strt_at. The function returns the offset from the beginning ofã the string, NOT the offset from Strt_at.ã}ãã Asm { Function Next_CPos }ã XOR AX,AX { 0 AX }ã MOV AL,Strt_at { Move position to start at to AL }ã LES DI,Src_str { Set ES:DI to start of Src_str }ã XOR CX,CX { 0 CX }ã MOV CL,[ES:DI] { Store length of Src_str in CL }ã INC DI { Set ES:DI to first char of Src_str }ã MOV BX,CX { Move CX to BX }ã SUB CX,AX { Set CX to length of string after Strt_at }ã ADD DI,AX { Set ES:DI to char at Strt_at in Src_str }ã MOV AL,Srch_ch { Move Srch_ch to AL }ã CLD { Clear direction flag }ã REPNZ SCASB { Look for character following Strt_at }ã JNZ @NOTFND { If not found, jump to end of procedure }ã SUB BX,CX { Set BX to position char found in }ã JMP @DONE { Jump to end of procedure }ã @NOTFND: XOR BX,BX { Srch_ch not found, set BX to 0 }ã @DONE: MOV AX,BX { Move position found at (BX) to AX }ã End; { Function Next_CPos }ããFunction Up_cs(In_str: String): String;ãã{ This function converts In_str to all upper case characters.ã}ãã Begin { Function Up_cs }ã Inline(ã $1E/ { PUSH DS }ã $C4/$7E/$0A/ { LES DI,[BP+$0A] }ã $C5/$76/$06/ { LDS SI,[BP+$06] }ã $30/$E4/ { XOR AH,AH }ã $AC/ { LODSB }ã $AA/ { STOSB }ã $89/$C1/ { MOV CX,AX }ã $E3/$0F/ { JCXZ DONE }ã $FC/ { CLD }ã $AC/ {DOCHAR: LODSB }ã $3C/$61/ { CMP AL,'a' }ã $72/$06/ { JB NEXTCH }ã $3C/$7A/ { CMP AL,'z' }ã $77/$02/ { JA NEXTCH }ã $24/$DF/ { AND AL,$DF }ã $AA/ {NEXTCH: STOSB }ã $E2/$F2/ { LOOP DOCHAR }ã $1F) {DONE: POP DS }ã End; { Function Up_cs }ããFunction Fixup_srch_str(Srch_str: String): String;ãã{ This functions sole purpose in life is to count the number of paranthesesã pairs and correct for a deficient number of either by adding the appropriateã character either at the beginning or the end of the search string. Thisã may not yield the correct result as the searcher intended but is aã requirement of the algorithm (it searches for paran pairs). Note that theã function will add one set of parantheses if none are found. This functionã also looks for illegal character pairs (&, &), (| and |), these pairsã indicate an illegal Boolean search. The function returns the correctedã Srch_str if all is well, an empty string if not.ã}ãã Varã Left_para,ã Right_para,ã How_many: Integer;ãã Begin { Function Fixup_srch_str }ã Left_para := Cnt_ch(Lt_pn, Srch_str); { Count the parens }ã Right_para := Cnt_ch(Rt_pn, Srch_str);ã How_many := Abs(Left_para - Right_para); { Get the difference }ã If How_many > 0 Thenã If Right_para < Left_para Thenã Srch_str := Srch_str + Fill_str(Rt_pn, How_many)ã Elseã Srch_str := Fill_str(Lt_pn, How_many) + Srch_strã Elseã If (Srch_str[1] <> Lt_pn) Or { No parens? Add 'em }ã (Srch_str[Ord(Srch_str[0])] <> Rt_pn) Thenã Srch_str := Lt_pn + Srch_str + Rt_pn;ã If (Pos(Lt_pn + '&', Srch_str) <> 0) Or { Illegal call? }ã (Pos('&' + Rt_pn, Srch_str) <> 0) Orã (Pos(Lt_pn + '|', Srch_str) <> 0) Orã (Pos('|' + Rt_pn, Srch_str) <> 0) Thenã Fixup_srch_str := ''ã Elseã Fixup_srch_str := Srch_str { All is well }ã End; { Function Fixup_srch_str }ããFunction Parse_srch_str(Srch_str, Src_str: String): String;ãã{ This function simply extracts each string to search for, tests to see ifã it exists in the original string and replaces the extracted substring withã the appropriate token. It should be noted that each substring is determinedã solely by the characters used for parantheses. Any other characters areã assumed to be part of the search string (except the & and | operators).ãã Each substring is searched for in the original Search_str and its presenseã or absense noted with a T or F respectively.ã}ãã Varã Rtn_str,ã Token_str: String;ã End_token: Boolean;ãã Begin { Function Parse_srch_str }ã Token_str := '';ã Rtn_str := '';ã While Srch_str <> '' Doã Beginã If (Srch_str[1] In [Lt_pn, Rt_pn, '&', '|']) Then { Token starts? }ã Beginã End_token := (Token_str <> ''); { End of token? If not }ã If Not(End_token) Then { then start one. }ã Rtn_str := Rtn_str + Srch_str[1]ã Endã Elseã Beginã Token_str := Token_str + Srch_str[1]; { Add a char to substring }ã End_token := Falseã End;ã If End_token Then { If complete token, look }ã Begin { for it in the source str }ã If Pos(Token_str, Src_str) <> 0 Thenã Rtn_str := Rtn_str + 'T' { If found, return T }ã Elseã Rtn_str := Rtn_str + 'F'; { If not, return F }ã Rtn_str := Rtn_str + Srch_str[1];ã Token_str := ''; { Reset to look for more }ã End_token := Falseã End; { If End_token }ã Delete(Srch_str, 1, 1) { Delete the char justã processed and start againã }ã End; { While Srch_str <> '' }ã Parse_srch_str := Rtn_strã End; { Function Parse_srch_str }ããFunction Process_token_str(Token_str: String): Char;ãã Varã One_token: String;ã One_token_len,ã Left_para: Byte;ãã Function Process_one_token_str(The_token: String): Char;ãã Varã Lcv: Byte;ã Curr_answer,ã Do_and: Boolean;ãã Begin { Function Process_one_token_str }ã Curr_answer := (The_token[1] = 'T'); { Establish current answerã by checking first token.ã }ã For Lcv := 2 to Length(The_token) Do { Look at the rest of theã token str.ã }ã Case The_token[Lcv] of { Boolean op is And }ã '&': Do_and := True; { Boolean op is Or }ã '|': Do_and := False;ã 'T': If Do_and Thenã Curr_answer := Curr_answer And True { If And }ã Elseã Curr_answer := True; { If Or }ã 'F': If Do_and Then { If And (Or stays T) }ã Curr_answer := False;ã End; { Case }ã If Curr_answer Then { Final result }ã Process_one_token_str := 'T'ã Elseã Process_one_token_str := 'F'ã End; { Function Process_one_token_str }ãã Begin { Function Process_token_str }ãã { Are parens present? If so process as tokenized phrase, if not, finalã result has been received.ã }ãã If PosC(Lt_pn, Token_str) Thenã Beginã While Length(Token_str) > 1 Doã Beginãã { Find leftmost left paren }ãã Left_para := Last_Cpos(Lt_pn, Token_str);ãã { Find first right paren after leftmost left paren }ãã One_token_len :=ã Succ(Next_CPos(Rt_pn, Token_str, Left_para) - Left_para);ãã { Copy everything between the two }ãã One_token := Copy(Token_str, Left_para, One_token_len);ãã { Remove the parens }ãã Delete(One_token, 1, 1);ã Dec(One_token[0]);ãã { Remove the original substring from the phrase }ãã Delete(Token_str, Left_para, One_token_len);ãã { Insert the resultant single character in place of the oldã substring.ã }ãã Insert(Process_one_token_str(One_token), Token_str, Left_para)ã End; { While Length(Token_str) > 1 }ã Process_token_str := Token_str[1]ã Endã Elseã Process_token_str := Process_one_token_str(One_token)ã End; { Function Process_token_str }ããFunction BPos;ãã Begin { Function BPos }ã If Ignore_case Thenã Beginã Srch_str := Up_cs(Srch_str);ã Src_str := Up_cs(Src_str)ã End; { If Ignore_case }ãã { Is this a Boolean expression? If so process with this function, elseã process with Pascal POS function.ã }ãã If PosC('|', Srch_str) Or PosC('&', Srch_str) Thenã Beginã Srch_str := Parse_srch_str(Fixup_srch_str(Srch_str), Src_str);ã If Srch_str <> '' Thenã BPos := (Process_token_str(Srch_str) = 'T')ã Endã Elseã BPos := Pos(Srch_str, Src_str) <> 0ã End; { Function BPos }ããEnd. { Unit BoolPos } 61 10-28-9311:40ALL ERIK HJELME ASM Uppercase IMPORT 10 ^&žž {===========================================================================ãDate: 10-02-93 (16:28)ãFrom: ERIK HJELMEãSubj: Upcase/Locase string or Charã---------------------------------------------------------------------------ããBF> Does anybody know if DOS' multi-country support willãBF> spit out a character uppercase/lowercase conversion table ?ããYes, function $6502 will let you see the conversion tables.ããYou can also use two conversion interrupts in your own programmes, theãfunction isn't supported by older versions of DOS, but I don't know wich : }ããfunction upcase(c:char):char; { will replace TP's built-in upcase }ãasm mov dl,cã mov ax,$6520ã int $21ã mov al,dl { function result in AL }ã end;ããprocedure upstr(var s); { this will convert any TP string }ãasm push dsã lds dx,s { address of the s[0] character }ãã mov bx,dxã mov ch,0ã mov cl,[bx] { length of string in CX }ãã inc dx { characters to convert in DS:DX }ã mov ax,$6521ã int $21ã pop dsã end;ã 62 11-02-9306:24ALL MIKE COPELAND Convert Numbers to STRINGIMPORT 8 ^&- {ãMIKE COPELANDãã> Does anybody know how to make a variable for a procedure orã> function use the special formatting like the write procedure?ã> I can;t figure this out after several weeks of investigation..ã> the str function is too 'clunky' is that the only way to doã> this?ãã Write yourself a function which invokes the Str procedure. Such aãroutine should be in your global Unit, so you can access for every/anyãprogram you create. Here are mine:ã}ããfunction FSI(N : Longint; W : byte) : string; { Convert LongInt to String }ãvarã S : string;ãbeginã if W > 0 thenã Str(N : W, S)ã elseã Str(N, S);ã FSI := S;ãend;ããfunction FSR(N : real; W, D : byte) : string; { Convert Real to String }ãvarã S : string;ãbeginã Str(N : W : D, S);ã FSR := S;ãend;ã 63 11-02-9306:27ALL FRED JOHNSON Upper/Lower Strings IMPORT 34 ^&,‰ {ãFRED JOHNSONããAfter noticing the compiler error, Arthur Choi said...ãã>How do I upcase a String, For use Withã>a ReadLn?ãAC>Simple as possible, please... thanxãã{More than you wanted, but very useful}ãUses String_h;ããVarã sData : String;ãbeginã sData := 'fred';ã Writeln('toupper ', toupper(@sData)^);ã Writeln('original ', sData);ã Writeln('strupr ', strupr(@sData)^);ã Writeln('original ', sData);ãã Writeln('tolower ', tolower(@sData)^);ã Writeln('original ', sData);ã Writeln('strlwr ', strlwr(@sData)^);ã Writeln('original ', sData);ãend.ãã{---- String_h.pas.tpu ---}ã{*******************************************************************!HDR**ã** Module Name: String_h.pasã** $LogFile:$ã** $Revision:$ã** $Author:$ã** System Module Purpose:ã** Public Functions Within this module:ã** Global usage:ã** Special notes:ã** $Log$ã** Initial revision.ã** Initial revision. 10/05/93 19:35ã********************************************************************!end*}ãUnit String_h;ããInterfaceãTypeã spStringPtr = ^String;ãã{-------------------------------------------------------------------!HDR--ã** Function Name: toupper();ã** Description : converts String to upper caseã** Returns : Pointer to an uppercase Stringã** Calls : length, upcaseã** Special considerations:ã** Modification history:ã** Created: 10/05/93 19:28}ãFunction toupper(String_or_Char : spStringPtr) : spStringPtr;ãã{-------------------------------------------------------------------!HDR--ã** Function Name: tolower();ã** Description : converts a String to lower caseã** Returns : Pointer to a lower Case Stringã** Calls : length, ord, lengthã** Special considerations:ã** Modification history:ã** Created: 10/05/93 19:28}ãFunction tolower(String_or_Char : spStringPtr) : spStringPtr;ãã{-------------------------------------------------------------------!HDR--ã** Function Name: struprã** Description : converts String and alters contents to uppercaseã** Returns : Pointer to uppercase Stringã** Calls : upcase, lengthã** Special considerations:ã** Modification history:ã** Created: 10/05/93 19:28}ãFunction strupr (String_or_Char : spStringPtr) : spStringPtr;ãã{-------------------------------------------------------------------!HDR--ã** Function Name: strlwrã** Description : converts String and alters contents to lower caseã** Returns : Pointer to lower Case Stringã** Calls : ord, Char, lengthã** Special considerations:ã** Modification history:ã** Created: 10/05/93 19:28}ãFunction strlwr (String_or_Char : spStringPtr) : spStringPtr;ããImplementationããFunction toupper(String_or_Char : spStringPtr) : spStringPtr;ãVarã byCounter : Byte;ãbeginã toupper^[0] := String_or_Char^[0];ã For byCounter := 1 to length(String_or_Char^) doã toupper^[byCounter] := upcase(String_or_Char^[byCounter]);ãend;ããFunction tolower(String_or_Char : spStringPtr) : spStringPtr;ãVarã byCounter : Byte;ãbeginã tolower^[0] := String_or_Char^[0];ã For byCounter := 1 to length(String_or_Char^) doã beginã if ord(String_or_Char^[byCounter]) in [65..90] thenã tolower^[byCounter] := Char(ord(String_or_Char^[byCounter])+32);ã elseã tolower^[byCounter] := String_or_Char^[byCounter];ã end;ãend;ããFunction strupr(String_or_Char : spStringPtr) : spStringPtr;ãVarã byCounter : Byte;ãbeginã strupr^[0] := String_or_Char^[0];ã For byCounter := 1 to length(String_or_Char^) doã beginã strupr^[byCounter] := upcase(String_or_Char^[byCounter]);ã String_or_Char^[byCounter] := upcase(String_or_Char^[byCounter]);ã end;ãend;ããFunction strlwr(String_or_Char : spStringPtr) : spStringPtr;ãVarã byCounter : Byte;ãbeginã strlwr^[0] := String_or_Char^[0];ã For byCounter := 1 to length(String_or_Char^) doã beginã if ord(String_or_Char^[byCounter]) in [65..90] thenã beginã strlwr^[byCounter] := Char(ord(String_or_Char^[byCounter])+32);ã String_or_Char^[byCounter] := Char(ord(String_or_Char^[byCounter])+32);ã endã elseã beginã strlwr^[byCounter] := String_or_Char^[byCounter];ã String_or_Char^[byCounter] := String_or_Char^[byCounter];ã end;ã end;ãend;ããend.ãã 64 11-21-9309:35ALL GREG ESTABROOKS HEX Strings IMPORT 9 ^&̂ {ãFrom: GREG ESTABROOKSãSubj: Writing hexesãIs there a quick and easy way to convert an integer to a hex number?ãexample, if I have an integer num1:=32; is there a way to print "20hãscreen?ã}ããCONSTã HexList :ARRAY[0..15] OF CHAR ='0123456789ABCDEF';ããFUNCTION HiWord( Long :LONGINT ) :WORD; ASSEMBLER;ã { Routine to return high word of a LongInt. }ãASMã Mov AX,Long.WORD[2] { Move High word into AX. }ãEND;ããFUNCTION LoWord( Long :LONGINT ) :WORD; ASSEMBLER;ã { Routine to return low word of a LongInt. }ãASMã Mov AX,Long.WORD[0] { Move low word into AX. }ãEND;ãããFUNCTION BHex( V :BYTE ) :STRING;ãBEGINã BHex := HexList[V Shr 4] + HexList[V Mod 16];ãEND;ããFUNCTION WHex( V :WORD ) :STRING;ãBEGINã WHex := Bhex(Hi(V)) + BHex(Lo(V));ãEND;ããFUNCTION LHex( Long :LONGINT ) :STRING;ãBEGINã LHex := WHex(HiWord(Long))+WHex(LoWord(Long));ãEND;ã 65 11-21-9309:35ALL SWAG SUPPORT TEAM HEXWRITE Strings IMPORT 35 ^&¹´ {$R-}ãUNIT HexWrite;ã(**) INTERFACE (**)ãTYPE HexString = String[9];ã BinString = String[32];ãã FUNCTION HexByte(B : Byte) : HexString;ã FUNCTION HexShortInt(S : ShortInt) : HexString;ã FUNCTION HexWord(W : Word) : HexString;ã FUNCTION HexInteger(I : Integer) : HexString;ã FUNCTION HexLongInt(L : LongInt) : HexString;ã FUNCTION HexPointer(VAR P) : HexString;ãã FUNCTION BinByte(B : Byte) : BinString;ã FUNCTION BinShortInt(S : ShortInt) : BinString;ã FUNCTION BinWord(W : Word) : BinString;ã FUNCTION BinInteger(I : Integer) : BinString;ã FUNCTION BinLongInt(L : LongInt) : BinString;ãã FUNCTION NumBin(B : BinString) : LongInt;ã FUNCTION ANumBin(B : BinString) : LongInt;ã(**) IMPLEMENTATION (**)ãCONSTã HexDigits : ARRAY[0..15] OF Char = '0123456789ABCDEF';ã BinNibbles : ARRAY[0..15] OF ARRAY[0..3] OF Char = (ã '0000', '0001', '0010', '0011',ã '0100', '0101', '0110', '0111',ã '1000', '1001', '1010', '1011',ã '1100', '1101', '1110', '1111');ãã FUNCTION HexByte(B : Byte) : HexString;ã VAR Temp : HexString;ã BEGINã Temp[0] := #2;ã Temp[1] := HexDigits[B SHR 4];ã Temp[2] := HexDigits[B AND $F];ã HexByte := Temp;ã END;ãã FUNCTION HexShortInt(S : ShortInt) : HexString;ã BEGIN HexShortInt := HexByte(Byte(S)); END;ãã FUNCTION HexWord(W : Word) : HexString;ã VAR Temp : HexString;ã BEGINã Temp[0] := #4;ã Temp[1] := HexDigits[W SHR 12];ã Temp[2] := HexDigits[(W SHR 8) AND $F];ã Temp[3] := HexDigits[(W SHR 4) AND $F];ã Temp[4] := HexDigits[W AND $F];ã HexWord := Temp;ã END;ãã FUNCTION HexInteger(I : Integer) : HexString;ã BEGIN HexInteger := HexWord(Word(I)); END;ãã FUNCTION HexLongInt(L : LongInt) : HexString;ã VAR Temp : HexString;ã BEGINã Temp[0] := #8;ã Temp[1] := HexDigits[L SHR 28];ã Temp[2] := HexDigits[(L SHR 24) AND $F];ã Temp[3] := HexDigits[(L SHR 20) AND $F];ã Temp[4] := HexDigits[(L SHR 16) AND $F];ã Temp[5] := HexDigits[(L SHR 12) AND $F];ã Temp[6] := HexDigits[(L SHR 8) AND $F];ã Temp[7] := HexDigits[(L SHR 4) AND $F];ã Temp[8] := HexDigits[L AND $F];ã HexLongInt := Temp;ã END;ãã FUNCTION HexPointer(VAR P) : HexString;ã VARã Temp : HexString;ã L : LongInt ABSOLUTE P;ã BEGINã Temp := HexLongInt(L);ã Move(Temp[5], Temp[6], 4);ã Temp[5] := ':';ã Inc(Temp[0]);ã HexPointer := Temp;ã END;ãã FUNCTION BinByte(B : Byte) : BinString;ã VAR Temp : BinString;ã BEGINã Temp[0] := #8;ã Move(BinNibbles[B SHR 4], Temp[1], 4);ã Move(BinNibbles[B AND $F], Temp[5], 4);ã BinByte := Temp;ã END;ãã FUNCTION BinShortInt(S : ShortInt) : BinString;ã BEGIN BinShortInt := BinByte(Byte(S)); END;ãã FUNCTION BinWord(W : Word) : BinString;ã VAR Temp : BinString;ã BEGINã Temp[0] := #16;ã Move(BinNibbles[W SHR 12], Temp[1], 4);ã Move(BinNibbles[(W SHR 8) AND $F], Temp[5], 4);ã Move(BinNibbles[(W SHR 4) AND $F], Temp[9], 4);ã Move(BinNibbles[W AND $F], Temp[13], 4);ã BinWord := Temp;ã END;ãã FUNCTION BinInteger(I : Integer) : BinString;ã BEGIN BinInteger := BinWord(Word(I)); END;ãã FUNCTION BinLongInt(L : LongInt) : BinString;ã VAR Temp : BinString;ã BEGINã Temp[0] := #32;ã Move(BinNibbles[L SHR 28], Temp[1], 4);ã Move(BinNibbles[(L SHR 24) AND $F], Temp[5], 4);ã Move(BinNibbles[(L SHR 20) AND $F], Temp[9], 4);ã Move(BinNibbles[(L SHR 16) AND $F], Temp[13], 4);ã Move(BinNibbles[(L SHR 12) AND $F], Temp[17], 4);ã Move(BinNibbles[(L SHR 8) AND $F], Temp[21], 4);ã Move(BinNibbles[(L SHR 4) AND $F], Temp[25], 4);ã Move(BinNibbles[L AND $F], Temp[29], 4);ã BinLongInt := Temp;ã END;ãã FUNCTION NumBin(B : BinString) : LongInt;ã VAR Accum, Power : LongInt;ã P : Byte;ã BEGINã Power := 1; Accum := 0;ã FOR P := length(B) DOWNTO 1 DOã BEGINã IF B[P] = '1' THEN Inc(Accum, Power);ã Power := PoweR SHL 1;ã END;ã NumBin := Accum;ã END;ãã FUNCTION ANumBin(B : BinString) : LongInt; Assembler;ã ASMã LES DI, Bã XOR CH, CHã MOV CL, ES:[DI]ã ADD DI, CXã MOV AX, 0ã MOV DX, 0ã MOV BX, 1ã MOV SI, 0ã @LOOP:ã CMP BYTE PTR ES:[DI],'1'ã JNE @NotOneã ADD AX, BX {add power to accum}ã ADC DX, SIã @NotOne:ã SHL SI, 1 {double power}ã SHL BX, 1ã ADC SI, 0ã DEC DIã LOOP @LOOPã END;ããEND.ã 66 11-21-9309:48ALL SWAG SUPPORT TEAM Good String Unit IMPORT 39 ^&Ýî {$O-}ãUNIT Strings;ãINTERFACEãã FUNCTION Dupe(C : Char; Len : Byte) : String;ã FUNCTION ADupe(C : Char; Len : Byte) : String;ã FUNCTION Pad(S : String; C : Char;ã Len : Byte) : String;ã FUNCTION APad(S : String; C : Char;ã Len : Byte) : String;ã FUNCTION LeftPad(S : String; C : Char;ã Len : Byte) : String;ã FUNCTION ALeftPad(S : String; C : Char;ã Len : Byte) : String;ã FUNCTION Chop(S : String; len: Byte): String;ã FUNCTION AChop(S : String; len: Byte): String;ã FUNCTION LeftChop(S : String; len: Byte): String;ã FUNCTION ALeftChop(S : String; len: Byte): String;ã PROCEDURE Trim(VAR S : String; C : Char);ã PROCEDURE TrimLead(VAR S : String; C : Char);ããIMPLEMENTATIONãã FUNCTION Dupe(C : Char; Len : Byte) : String;ã VAR Temp : String;ã BEGINã FillChar(Temp[1], Len, C);ã Temp[0] := Char(Len);ã Dupe := Temp;ã END;ãã FUNCTION ADupe(C : Char;ã Len : Byte) : String; Assembler;ã ASMã LES DI, @Resultã CLDã XOR CH, CHã MOV CL, Len {length in CX}ã MOV AX, CX {and in AX}ã STOSB {store length byte}ã MOV AL, Cã REP STOSB {fill string with char}ã END;ãã FUNCTION Pad(S : String; C : Char; Len : Byte) : String;ã BEGINã IF length(S) < len THENã FillChar(S[succ(length(S))], Len-length(S), C);ã S[0] := char(Len);ã Pad := S;ã END;ãã FUNCTION APad(S : String; C : Char;ã Len : Byte) : String; Assembler;ã ASMã PUSH DSã LDS SI, S {DS:SI points to S}ã LES DI, @Result {ES:DI points to result}ã LODSB {read existing length}ã XOR AH, AHã MOV CX, AXã MOV AL, Len {Set result to desired length}ã STOSB {Transfer length to result}ã MOV BX, CXã REP MOVSB {Now S is in @Result}ã XOR CH, CHã MOV CL, Len {Get desired length in CX}ã SUB CX, BX {Subtract current length}ã JLE @NoPad {If difference < 0, no pad}ã MOV AL, C {Put char in AL}ã REP STOSB {Fill rest of string}ã @NoPad:ã POP DSã END;ãã FUNCTION LeftPad(S : String; C : Char;ã Len : Byte) : String;ã BEGINã IF length(S) < Len THENã BEGINã MOVE(S[1], S[succ(Len - length(S))], length(S));ã FillChar(S[1], Len - length(S), C);ã END;ã S[0] := Char(Len);ã LeftPad := S;ã END;ãã FUNCTION ALeftPad(S : String; C : Char;ã Len : Byte) : String; Assembler;ã ASMã PUSH DSã CLDã LES DI, @Result {ES:DI points to result}ã MOV AL, Lenã XOR AH, AHã MOV CX, AX {Desired length in CX}ã STOSB {length byte of result}ã LDS SI, S {DS:SI points to S}ã LODSB {AL has length of S}ã MOV BL, AL {remember length of S}ã SUB CX, AX {subtract actual from desired}ã JLE @NoPad {if diff < 0, don't pad}ã MOV AL, C {fill at start of string}ã REP STOSBã @NoPad:ã MOV CL, BL {get back length of S}ã REP MOVSB {copy rest of S}ã POP DSã END;ãã FUNCTION Chop(S : String; len : Byte): String;ã BEGINã IF length(S) > len THENã S[0] := Char(Len);ã Chop := S;ã END;ãã FUNCTION AChop(S : String;ã len: Byte): String; Assembler;ã ASMã PUSH DSã LDS SI, Sã LES DI, @Resultã LODSBã XOR AH, AHã XCHG AX, CXã CMP CL, Len {if length > len,...}ã JB @NoChopã MOV CL, Len {... set length to len}ã @NoCHop:ã MOV AL, CL {store length}ã STOSBã REP MOVSB {copy Len chars to result}ã POP DSã END;ãã FUNCTION LeftChop(S : String; len: Byte): String;ã BEGINã IF length(S) > len THENã BEGINã MOVE(S[succ(length(S) - len)],ã S[1], Len);ã S[0] := Char(Len);ã END;ã LeftChop := S;ã END;ãã FUNCTION ALeftChop(S : String;ã len: Byte): String; Assembler;ã ASMã PUSH DSã LDS SI, Sã LES DI, @Resultã LODSBã XOR AH, AHã XCHG AX, CXã CMP CL, Len {if length > len,...}ã JB @NoChopã ADD SI, CX {point to end of string}ã MOV CL, Len {set length to len}ã SUB SI, CX {point to new start of string}ã @NoCHop:ã MOV AL, CL {store length}ã STOSBã REP MOVSB {copy Len chars to result}ã POP DSã END;ãã PROCEDURE Trim(VAR S : String; C : Char);ã BEGINã WHILE S[length(S)] = C DO Dec(S[0]);ã END;ãã PROCEDURE TrimLead(VAR S : String; C : Char);ã VAR P : Byte;ã BEGINã P := 1;ã WHILE (S[P] = C) AND (P <= length(S)) DO Inc(P);ã CASE P OFã 0 : S[0] := #0; {string was 255 of C!}ã 1 : ; {not found}ã ELSEã Move(S[P], S[1], succ(length(S) - P));ã Dec(S[0], pred(P));ã END;ã END;ããEND. 67 11-26-9317:47ALL SWAG SUPPORT TEAM TRANSLAT Upper/Lower CaseIMPORT 8 ^&ö {ãI am in need of a very fast LCASE or UCASE routine.ãA general translation utility could come in handy:ã}ããUSES CRT;ããtypeã t_table=array [char] of char;ããprocedure translate(var buffer; var table:t_table; len:word);ãassembler;ãasmã mov cx,[len]ã JCXZ @@endã les bx,[table]ã push dsã cldã lds si,[buffer]ã@@redo:ã lodsbã segesã xlatã mov [si-1],alã LOOP @@redoã pop dsã@@end:ã end;ããvarã uptable : t_table;ã lotable : t_table;ã s: string;ã c: char;ãbeginã ClrScr;ã (* convert every letter to its uppercase pendant *)ã for c:=#0 to #255 do uptable[c]:=upcase(c);ã (* convert every letter to its lowercase pendant *)ã for c:=#0 to #255 do lotable[c]:= CHR(ORD(c) OR $20);ã readln(s);ã translate(s[1],uptable,length(s));ã writeln(s);ã translate(s[1],lotable,length(s));ã writeln(s);ã end.ã 68 01-27-9411:52ALL BOB SWART Asm String Manipulation IMPORT 9 ^&Æ {ã > Really need an inline macro to add a character to the end of a string.ãHow 'bout this one (from my book, of course):ã}ããProcedure AddStr14(Var Str : String; C : Char);ãInLine(ã $58/ { POP AX ; get chr C in AX }ã $5F/ { POP DI ; pop offset Str }ã $07/ { POP ES ; pop segment Str }ã $26/ { ES: }ã $FE/$05/ { INC BYTE PTR [DI] ; inc length byte }ã $31/$DB/ { XOR BX,BX }ã $26/ { ES: }ã $8A/$1D/ { MOV BL,[DI] ; get length byte }ã $01/$DF/ { ADD DI,BX ; goto end of str }ã $AA); { STOSB ; add character C }ããVarã Str : String;ããbeginã Str := 'Bob';ã AddStr14(Str, ' ');ã AddStr14(Str, 'S');ã AddStr14(Str, 'w');ã AddStr14(Str, 'a');ã AddStr14(Str, 'r');ã AddStr14(Str, 't');ã WriteLn(Str)ãend.ãã 69 01-27-9412:09ALL GREG VIGNEAULT Getting Initials IMPORT 13 ^& {ã> 2: And with a string I want to read a specific string andã> get the first to letter of the 1st and last names.ã> So for example: Mike Enos ==> ME-DATA.DAT.ã>ã> Function GetDatName : String;ã[deleted]ãã To get the first letter of a surname, it might be better to scanã from the end of the string -- in case the person also uses theirã middle name or initial...ã}ããPROGRAM Monogram;ããVARã PersonName : STRING[64]; (* person's name(s) *)ã FileName : STRING[12]; (* file name *)ã Index : WORD; (* character pointer *)ããBEGINã FileName := '??-DATA.DAT'; (* common file name *)ãã PersonName := 'Jack B. Nimble'; (* example name *)ãã (* the person's name MUST contain at least one space... *)ãã IF (Length(PersonName)=0) OR (Pos(' ',PersonName)=0) THEN BEGINã WriteLn; WriteLn ('First AND Last names, please...');ã Halt(1);ã END;ãã (* assume there's no leading white spaces... *)ãã FileName[1] := UpCase (PersonName[1]); (* pick up 1st char *)ãã (* scan from the end of PersonName, looking for white space... *)ãã Index := Length (PersonName);ã WHILE (Index > 0) AND (PersonName[Index] > ' ') DO DEC (Index);ãã INC (Index); (* ... 'cause we went one too many *)ãã FileName[2] := PersonName[Index]; (* get 1st char of surname *)ãã WriteLn;ã WriteLn ('File name for "',PersonName,'" is ',FileName);ã WriteLn;ããEND.ã 70 01-27-9413:34ALL GREG ESTABROOKS String Conversions IMPORT 34 ^& {***********************************************************************}ãUNIT Strings; { String Conversion Routines, }ã { Last Updated Dec 07/93 }ã { Copyright (C) 1993, Greg Estabrooks }ã { NOTE: Requires TP 6.0+ to compile. }ãINTERFACEã(************************************************************************)ãCONSTã HexList :ARRAY[0..15] OF CHAR ='0123456789ABCDEF';ããFUNCTION BHex( V :BYTE ) :STRING;ãFUNCTION WHex( V :WORD ) :STRING;ãFUNCTION LHex( Long :LONGINT ) :STRING;ãPROCEDURE UpperCase( VAR UpStr :STRING );ãPROCEDURE LowerCase( VAR LoStr :STRING );ããIMPLEMENTATIONã(************************************************************************)ãFUNCTION HiWord( Long :LONGINT ) :WORD; ASSEMBLER;ã { Routine to return high word of a LongInt. }ãASMã Mov AX,Long.WORD[2] { Move High word into AX. }ãEND;ããFUNCTION LoWord( Long :LONGINT ) :WORD; ASSEMBLER;ã { Routine to return low word of a LongInt. }ãASMã Mov AX,Long.WORD[0] { Move low word into AX. }ãEND;ãããFUNCTION BHex( V :BYTE ) :STRING;ã { Routine to convert a byte to a Hex string. }ãBEGINã BHex := HexList[V Shr 4] + HexList[V Mod 16];ãEND;ããFUNCTION WHex( V :WORD ) :STRING;ã { Routine to convert a word to a Hex string. }ãBEGINã WHex := Bhex(Hi(V)) + BHex(Lo(V));ãEND;ããFUNCTION LHex( Long :LONGINT ) :STRING;ã { Routine to convert a longint to a Hex string. }ãBEGINã LHex := WHex(HiWord(Long))+WHex(LoWord(Long));ãEND;ããPROCEDURE UpperCase( VAR UpStr :STRING ); ASSEMBLER;ã { Routine to convert string to uppercase }ãASMã Push ES { Save Registers to be used }ã Push DIã Push CXã LES DI,UpStr { Point ES:DI to string to be converted}ã Sub CX,CX { Clear CX }ã Mov CL,ES:[DI] { Load Length of string for looping }ã Cmp CX,0 { Check for a clear string }ã JE @Exit { If it was then exit }ã@ReadStr:ã Inc DI { Point to next Character }ã Cmp BYTE PTR ES:[DI],'z' { If Character above 'z' jump to end of}ã Ja @LoopEnd { loop. }ã Cmp BYTE PTR ES:[DI],'a' { if below 'a' jump to end of loop. }ã Jb @LoopEndã Sub BYTE PTR ES:[DI],32 { If not make it upper case }ã@LoopEnd:ã Loop @ReadStr { Loop Until done }ã@Exit:ã Pop CX { Restore registers }ã Pop DIã Pop ESãEND;{UpperCase}ããPROCEDURE LowerCase( VAR LoStr :STRING ); ASSEMBLER;ã { Routine to convert a string to lower case }ãASMã Push ES { Save Registers to be used }ã Push DIã Push CXã LES DI,LoStr { Point ES:DI to string to be converted}ã Sub CX,CX { Clear CX }ã Mov CL,ES:[DI] { Load Length of string for looping }ã Cmp CX,0 { Check for a clear string }ã JE @Exit { If it was then exit }ã@ReadStr:ã Inc DI { Point to next Character }ã Cmp BYTE PTR ES:[DI],'Z' { If Character above 'Z' jump to end of}ã Ja @LoopEnd { loop. }ã Cmp BYTE PTR ES:[DI],'A' { if below 'A' jump to end of loop. }ã Jb @LoopEndã Add BYTE PTR ES:[DI],32 { If not make it Lower case }ã@LoopEnd:ã Loop @ReadStr { Loop Until done }ã@Exit:ã Pop CX { Restore registers }ã Pop DIã Pop ESãEND;{LowerCase}ããBEGINãEND.ã{***********************************************************************} 71 01-27-9417:41ALL J. TAL Misc. String Functions IMPORT 124 ^& Unit Funcs;ãã(* previously All_Func.Inc *)ãã(* 05/02/1988 J Talã Rollins Medical/Dental Systemsã ã Public Domainã*)ãããInterfaceã Uses Dos,Crt;ããã TYPEã st255 = string[255];ãã Function Word_Int(r: REAL) : INTEGER;ãã Function Word_Real(i: INTEGER) : REAL;ãã Function Real_Mod(a,b: REAL) : REAL;ã (* modulus for two real numbers ãã Real_Mod(15.0,2.0) = 1.0ãã *)ãã function lowcase(c : char) : char;ã (* opposite of upcase ãã lowcase('A') = 'a'ã lowcase('b') = 'b'ã ã *)ãã function f_buf_conv( x : st255) : st255;ã (* convert a file buffer into a string *)ãã procedure prog_chain(prog : st255); (* dummy *)ãã function spaces(num : integer) : st255;ã (* like basic space$ ãã spaces(10) = ' 'ãã *)ãã function bakfile( name : st255) : st255;ã (* takes filename and returns .BAK version of that name ãã bakfile('test.dat') = 'test.bak'ãã *)ãã function bool(x : boolean) : integer;ã (* True becomes -1, False becomes 0 ãã bool(true) = -1ã bool(false) = 0ãã *)ãã function center ( line : st255) : integer;ã (* returns x location to print the line/string at to center it ãã center('HELP') = 38ã gotoxy(center(message),y); write(message);ããã *) ãã function fill(n,char : integer) : st255;ã (* fill string to n characters with chr(char) ã like basic string$ ãã fill(10,65) = 'AAAAAAAAAA'ãã *)ãã function fnline( curline : st255) : st255;ã (* isolate leading number from a line ãã fnline('255 IF X = 255 THEN GOTO') = 255ãã *)ãã function fnmax(a,b : integer) : integer;ã (* max of two integers ãã fnmax(4,5) = 5ãã *)ãã function fnmin(a,b : integer) : integer;ã (* min of two integersãã fnmin(-9,5) = -9ãã *)ãã function lpad(ch : st255; num : integer) : st255;ã (* left pad the string ch with spaces to num length ããã lpad('HELP',10) = ' HELP'ãã *)ãã function ltrm ( curline : st255) : st255;ã (* remove leading spaces from curline ãã ltrm(' HELP') = 'HELP'ãã *)ãã function peek(seg,ofs : integer) : integer;ã (* like basic peek ãã x := peek(segment,offset);ã ã *)ãã procedure poke(seg,ofs,v : integer);ã (* like basic poke ãã poke(screen_seg,ofs,character)ãã *)ãã function power(x,n : integer) : integer;ã (* x^nãã power(2,4) = 16ãã *)ãã function rpad(ch : st255; num : integer) : st255;ã (* right pad ch to num length with spaces ãã rpad('THIS',10) = 'THIS 'ãã *)ãã function rpt(num,ch : integer) : st255;ã (* like basic string$ ãã rpt(10,67) = 'CCCCCCCCCC'ãã *)ãã function rtrm(ch : st255) : st255;ã (* remove trailing spaces from string ch ãã rtrm('ROYAL ') = 'ROYAL'ãã *)ãã function srep(ch,dh,eh : st255): st255;ã (* srep=string replaceã replace all occurances of string dh with eh in string ch ããã srep('THE CAT','CAT','FAT') = 'THE FAT'ãã *)ã ã procedure s_swap(var a1,a2 : st255);ã (* string swap, swap a1 & a2 ãã a1 = 'MAMA'ã a2 = 'DADDY'ãã s_swap(a1,a2)ãã a1 = 'DADDY'ã a2 = 'MAMA'ãã *)ãã function fnxtrm( s : st255) : st255;ã (* if string s is all blanks, then returns '' null string ãã fnxtrm(' g ') = ' 'ã fnxtrm(' ') = ''ãã *)ãã function fnval( curline : st255) : integer;ã (* converts string representation of number to integer ãã fnval('123 ') = 123ãã *)ãã function fns ( a1 : integer) : st255;ã (* converts integer to string representation ãã fns(1234) = '1234'ãã *)ãã function left_str( curline : st255; i : integer) : st255;ã (* take i characters from curline starting at the left ãã left_str('THE QUICK BROWN',9) = 'THE QUICK'ãã *)ãã function right_str( curline : st255; i : integer) : st255;ã (* take i characters from curline starting at the right ãã right_str('THE QUICK BROWN',9) = 'ICK BROWN'ã *)ãã procedure mid_str_assign( var modify_string : st255; s_start,s_len : integer; ins_string : st255);ã (* mid string assignmentã mid_str_assign('flemish',1,2,'bl') = 'blemish'; ã ^ starting a character 1ã ^ for a length of two ã ^ make those chars 'bl'ãã mid_str_assign('abcdefg',2,2,'BC') = 'aBCdefg'ã *)ã ã function hex_str(hex: INTEGER) : st255;ã (* hexadecimal string representation of decimal integer ãã hex_str(123) = '7B'ãã *)ãã function hex_val(hex: st255) : INTEGER;ã (* reverse of hex_str, integer representation of hexadecimal string ãã hex_val('7B') = 123ãã *)ãã function bin_str(bin: INTEGER) : st255;ã (* binary string representation of integer ãã bin_str(123) = '1111011';ã *)ãã FUNCTION InKey(VAR Special : BOOLEAN; VAR Keychar : CHAR) : BOOLEAN;ã (* checks for keypressed, returns type and character *)ãã function fnzero (num : st255 ; places : integer) : st255;ã (* left '0' pad a number into a string ãã fnzero('123',10) = '0000000123'ãã *)ãã function fns_z(n : integer) : st255;ã (* left '0' pad a number into a 2 digit string ãã fns_z(1) = '01'ã fns_z(45) = '45'ã *)ãã Function bit_blast(bit_stream: st255) : INTEGER;ã (* reverse of bin_str, integer representation of binary string ãã bit_blast('1110001') = 113ã *)ãã Function printusing (mask : st255; number : real) : st255;ã (*ãã printusing('###,###.##',19.95) = ' 19.95'ã printusing('###,###.##CR,-19.95) = ' 19.95CR'ãã *)ããã Procedure UpStr(VAR a: st255);ã (* Upcase a whole string ãã UpStr('The cat Mildred') = 'THE CAT MILDRED'ãã *)ããããImplementationãããããFunction Word_Int;ã(* (r: REAL) : INTEGER; *)ããBEGIN ã IF r > 32767.0 THENã Word_int := Trunc(r - 65536.0)ã ELSEã Word_int := Trunc(r);ãEND;ãããFunction Word_Real;ã(* (i: INTEGER) : REAL; *)ãBEGINã IF i < 0 THENã Word_Real := i + 32767.0ã ELSEã Word_Real := i;ãEND;ãããFunction Real_Mod;ã(* (a,b: REAL) : REAL; *)ãBEGINã WHILE a > b DO beginã a := a - b;ã END;ã Real_Mod := a;ãEND; (* Real_Mod *)ãããfunction lowcase;ã(* (c : char) : char; *)ãvarãc1 : integer;ãbeginãc1 := ord(c);ã if (c1 > 64) and (c1 < 91) {only change A-Z to a-z}ã thenã c1 := c1 + 32;ãlowcase := chr(c1);ãend;ãããfunction f_buf_conv;ã(* ( x : st255) : st255; *)ãvarã i : integer;ã temp : st255;ãbeginã temp := '';ã temp := x[0] + copy(x,1,length(x));ã f_buf_conv := temp;ãend;ãããprocedure prog_chain;ã(* (prog : st255); *) (* dummy *) ãbeginãhalt;ãend;ãããfunction spaces;ã(* (num : integer) : st255; *)ã varã sp1 : integer;ã space : st255;ã beginã space := '';ã for sp1 := 1 to num doã space := space + ' ';ã spaces := space;ã end;ãã { ------------------- }ããfunction bakfile;ã(* ( name : st255) : st255; *)ãvarã a1 : integer;ãbeginã a1 := pos('.',name);ã if a1 = 0 thenã bakfile := name + '.BAK'ã elseã bakfile := copy(name,1,a1) + 'BAK';ãend;ãã { ------------------- }ããfunction bool;ã(* (x : boolean) : integer; *)ãbeginã if x then bool := -1ã else bool := 0ãend;ãã { ------------------- }ããfunction center;ã(* ( line : st255) : integer; *)ãvarã a1 : integer;ãbeginã a1 := length(line);ã center := trunc(39-(a1 div 2));ãend;ãã { ------------------- }ããfunction fill;ã(* (n,char : integer) : st255; *)ãvar i : integer;ãbeginã for i := 1 to n doã fill[i] := chr(char)ãend;ãã { ------------------- }ããfunction fnline;ã(* ( curline : st255) : st255; *)ãvarãa1 : integer;ãa1s : st255;ãbeginã a1 := pos(' ',curline);ã a1s := copy(curline,1,a1);ã fnline := a1s;ãend;ãã { ------------------- }ããfunction fnmax;ã(* (a,b : integer) : integer; *)ãbeginã fnmax := a-bool(b>a)*(b-a)ãend;ãã { ------------------- }ããfunction fnmin;ã(* (a,b : integer) : integer; *)ãbeginã fnmin := a+bool(a>b)*(a-b)ãend;ãã { ------------------- }ããfunction lpad;ã(* (ch : st255; num : integer) : st255; *)ã varã sp1 : integer;ã sp2 : integer;ã beginã sp1 := length(ch);ã sp2 := num - sp1;ã lpad := spaces(sp2) + ch;ã end;ãã { ------------------- }ããfunction ltrm;ã(* ( curline : st255) : st255; *)ãbeginã while curline[1] = ' ' doã curline := copy(curline,2,255);ãltrm := curline;ãend;ãã { ------------------- }ããfunction peek;ã(* (seg,ofs : integer) : integer; *)ãbeginã peek := mem[seg:ofs];ãend;ãã { ------------------- }ããprocedure poke;ã(* (seg,ofs,v : integer); *)ãbeginã mem[seg:ofs] := v;ãend;ãã { ------------------- }ããfunction power;ã(* (x,n : integer) : integer; *)ãbeginã if n = 1ã then power := xã else power := x*power(x,n-1)ãend;ããã { ------------------- }ããfunction rpad;ã(* (ch : st255; num : integer) : st255; *)ã beginã rpad := copy(ch + spaces(num),1,num);ã end;ãã { ------------------- }ããfunction rpt;ã(* (num,ch : integer) : st255; *)ã varã sp1 : integer;ã space : st255;ã beginã space := '';ã for sp1 := 1 to num doã space := space + chr(ch);ã rpt := space;ã end;ãã { ------------------- }ããfunction rtrm;ã(* (ch : st255) : st255; *)ã varã sp1 : integer;ã sp2 : integer;ã beginã sp1 := length(ch);ã sp2 := sp1;ã while (ch[sp2] = ' ') and (sp2 <> 0) doã sp2 := sp2 - 1;ã rtrm := copy(ch,1,sp2);ã end;ãã { ------------------- }ãããfunction srep;ã(* (ch,dh,eh : st255): st255; *)ã varã sp1 : integer;ã sp2 : integer;ã sp3 : integer;ã sp4 : integer;ã sp5 : integer;ã atemp : st255;ã btemp : st255;ã ctemp : st255;ã beginã sp1 := length(ch);ã sp2 := length(dh);ã sp3 := length(eh);ã while pos(dh,ch) <> 0 doã beginã sp4 := pos(dh,ch);ã sp5 := sp1 - (sp4 + sp2) + 1;ã atemp := copy(ch,1,sp4-1);ã btemp := copy(ch,sp4+sp2,sp5);ã ctemp := atemp + eh + btemp;ã ch := ctemp;ã end;ãsrep := ch;ãend;ãã { ------------------- }ããprocedure s_swap;ã(* (var a1,a2 : st255); *)ãvarã temp : st255;ãbeginã temp := a1;ã a1 := a2;ã a2 := temp;ãend;ãã { ------------------- }ããfunction fnxtrm;ã(* ( s : st255) : st255; *)ã beginã fnxtrm := spaces(1+bool(s = spaces(length(s))))ã end;ãã { ------------------- }ããfunction fnval;ã(* ( curline : st255) : integer; *)ãvarã err,a1 : integer;ãbeginã while copy(curline,1,1) = '' doã curline := copy(curline,2,255);ã val(curline,a1,err);ã fnval := a1;ãend;ãã { ------------------- }ããfunction fns;ã(* ( a1 : integer) : st255; *)ãvarã a1s : st255;ãbeginã str(a1,a1s);ã fns := a1s;ãend;ããfunction left_str;ã(* ( curline : st255; i : integer) : st255; *)ãbeginã left_str := copy(curline,1,i);ãend;ãã { ------------------- }ããfunction right_str;ã(* ( curline : st255; i : integer) : st255; *)ãvarã l : integer;ãbeginã l := length(curline);ã right_str := copy(curline,l-i+1,i);ãend;ãã { ------------------- }ãã{ã format for mid_str_assignãã basic - mid$(s$,12,12) = mid$(f$,4,12)ãã pascal - mid_str_assign(s_str,12,12,copy(f_str,4,12));ã orã mid_str_assign(s_str,12,12,'123456789012');ã}ãã { ------------------- }ããprocedure mid_str_assign;ã(* ( var modify_string : st255; s_start,s_len : integer; ins_string : st255); *)ãbeginã delete(modify_string,s_start,s_len);ã insert(ins_string,modify_string,s_start);ãend;ãã { ------------------- }ããfunction hex_str(hex: INTEGER) : st255;ãVARã hex_out: st255;ã hex_temp: INTEGER;ã hex_mas: st255;ãBEGINã hex_mas := '0123456789ABCDEF';ã hex_out := '';ã WHILE hex > 0 DO beginã hex_temp := hex AND 15;ã hex_out := hex_mas[hex_temp+1] + hex_out;ã hex := hex DIV 16;ã END;ã FOR hex_temp := 1 to 2 DO beginã IF length(hex_out) < 2 then hex_out := '0' + hex_out;ã END;ã hex_str := hex_out;ãEND;ãã { ------------------- }ããfunction hex_val;ã(* (hex: st255) : INTEGER; *)ãVARã hex_out: INTEGER;ã hex_temp: INTEGER;ã hex_mas: st255;ãBEGINã hex_mas := '0123456789ABCDEF';ã hex_out := 0;ã WHILE length(hex) > 0 DO beginã hex_temp := Pos(hex[1],hex_mas);ã hex_out := hex_out * 16 + (hex_temp)-1;ã hex := copy(hex,2,255);ã END;ã hex_val := hex_out;ãEND;ãã { ----------------- }ããfunction bin_str;ã(* (bin: INTEGER) : st255; *)ãVARã bin_out: st255;ã bin_temp: INTEGER;ãBEGINã bin_out := '';ã WHILE bin <> 0 DO beginã bin_temp := bin AND 1;ã IF bin_temp = 1 THENã bin_out := '1' + bin_outã ELSEã bin_out := '0' + bin_out;ãã bin := bin shr 1;ã END;ã bin_str := bin_out;ãEND;ãã { ------------------- }ããFUNCTION InKey;ã(* (VAR Special : BOOLEAN; VAR Keychar : CHAR) : BOOLEAN; *)ãVARã Dosrec : Dos.Registers;ãBEGINã IF Crt.KeyPressed THEN beginã Dosrec.AX := $0800;ã MSDOS(DosRec);ã KEYCHAR := CHR(LO(DOSREC.AX));ã INKEY := TRUE;ã IF ORD(KEYCHAR) = 0ã THENã BEGINã SPECIAL := TRUE;ã DOSREC.AX := $0800;ã MSDOS(DosRec);ã KEYCHAR := CHR(LO(DOSREC.AX));ã ENDã ELSE SPECIAL := FALSE;ã ENDã ELSEã BEGINã INKEY := FALSE;ã SPECIAL := FALSE;ã END;ã END;ãã { ------------------- }ããfunction fnzero;ã(* (num : st255 ; places : integer) : st255; *)ãvarã a1s : st255;ã a1 : integer;ãbeginã a1 := length(num);ã a1s := rpt(places-a1,48) + num;ã fnzero := a1s;ãend;ãã { ------------------- }ãããfunction fns_z;ã(* (n : integer) : st255; *)ãvarã c : st255;ãbeginã c := fns(n);ã if length(c) = 1ã thenã c := '0' + c;ã fns_z := c;ãend;ãã { ------------------- }ããFunction bit_blast;ã(* (bit_stream: st255) : INTEGER; *)ã (* convert string representation of bits into integer: '1001' becomes 9 *)ãVARã i,bit_box : INTEGER;ãBEGINã bit_box := 0;ã FOR i := Length(bit_stream) DOwnTO 1 DO BEGINã IF bit_stream[i] = '1' THEN beginã bit_box := bit_box + (1 shl ((Length(bit_stream) - i)));ã END;ã END;ã bit_blast := bit_box;ãEND;ãã { ------------------- }ããFunction printusing;ã(* (mask : st255; number : real) : st255; *)ããconstã comma : char = ',';ã point : char = '.';ã minussign : char = '-';ããVARã fieldwidth, IntegerLength, i, j, places,pointposition : INTEGER;ã usingcommas, decimal, negative : boolean;ã outstring, IntegerString : string[80];ããBEGINã negative := number < 0;ã number := abs(number);ã places := 0;ã if pos('CR',mask) = 0ã thenã fieldwidth := length(mask)ã elseã fieldwidth := length(mask) - 2;ãã usingcommas := pos(comma,mask) > 0;ã decimal := pos(point,mask) > 0;ãã if decimal thenã BEGINã pointposition := pos(point,mask);ã places := fieldwidth - pointpositionã END;ã str( number : 0 : places, outstring);ãã if usingcommas thenã BEGINã j := 0;ã IntegerString := copy(outstring, 1, length( outstring ) - places );ã IntegerLength := length( IntegerString );ã if decimal thenã IntegerLength := IntegerLength -1;ã FOR i := IntegerLength DOwnto 2 DOã BEGINã j := j + 1;ã if j mod 3 = 0 thenã insert ( comma, outstring, i )ã endã END;ããã if length(outstring) < fieldwidthã thenã outstring := spaces(fieldwidth - length(outstring)) + outstring;ãã if (negative)ã thenã if (pos('CR',mask) <> 0)ã thenã outstring := outstring + 'CR'ã elseã outstring := minussign + outstring;ããã printusing := outstring;ãããEND; (* printusing *)ãããProcedure UpStr;ãVARã i : Integer;ãBEGINã For i := 1 TO Length(a) DOã a[i] := UpCase(a[i]);ããEND;ããEND.ãã 72 01-27-9417:47ALL GLENN CROUCH BASM Right Padded String IMPORT 20 ^& {ãFrom: GLENN CROUCHãSubj: BASM STRING ROUTINESã---------------------------------------------------------------------------ãThe following has been adjusted to do word aligned operations where possibleãfor speed:ã}ãã{$A+}ãconstã PadCh : CHAR = #32;ããfunction PadRightStr (const S : string; Len : Byte) : string; assembler;ãã { S is the String to Pad, Len is the length of the resultant Stringã Function adds Spaces to the Right of the String until Length isã Achieved. if Length (S) >= Len, then S is returned }ããasmã mov dx, ds { Save DS Register }ã cld { Clear Direction Flag }ã les di, @Result { ES:DI => OutGoing String }ã lds si, [S] { DS:SI => Incoming String }ã lodsb { Read Length }ã mov bh, al { Store Length in BH }ã sub ah, ah { Set AH to 0 }ã mov cx, ax { Load CX with Current Length }ã mov bl, [Len] { Load Length of Dest into BL }ã cmp al, blã jnb @2ã mov al, bl { Write Length }ã @2: stosbãã { Copy String }ãã jcxz @1 { Ensure that there is some string to Copy }ã movsb { Move first char so stay word aligned }ã dec cxã jcxz @1ã shr cx,1 { CX <- CX div 2 }ã rep movsw { move rest as words }ã jnc @1 { if carry then odd number }ã movsb { so move the odd one }ãã { Padding }ãã @1: sub bl, bh { Calculate how many spaces }ã jna @3 { if <= 0 then no padding needed }ã sub cx, cx { Load CX with No. of Spaces }ã mov cl, blã mov al, ' ' { place pad character into al }ã shr bh, 1 { if original length was even then not wordã aligned }ã jc @4ã stosb { Write first space to keep word aligned }ã dec cxã jcxz @3ã @4: mov ah, al { place ' ' also in Ah }ã shr cx, 1 { Move Words }ã rep stoswã jnc @3 { Check if even number }ã stosb { Move odd space if any }ã @3: mov ds, dx { Restore DS Register }ãend;ã 73 02-03-9409:57ALL GREG ESTABROOKS String Comparision IMPORT 18 ^& ã{*********************************************************************}ãPROGRAM StrCompare; { Jan 23/94, Greg Estabrooks. }ãUSES CRT; { IMPORT Clrscr,WriteLn. }ãVARã SubName :STRING; { Holds the Subject name entered. }ããFUNCTION StrCmp( Str1,Str2 :STRING ) :BOOLEAN;ã { Case InSensitive Routine to compare two }ã { strings. }ãVARã StrPos :BYTE; { Current position within Strings. }ã CmpResult:BOOLEAN; { Result of comparison. }ãBEGINã CmpResult := TRUE; { Initialize 'CmpResult' to TRUE. }ã IF Length(Str1) <> Length(Str2) THEN { If not same length then don't}ã CmpResult := FALSE { Bother converting case and }ã { compareing. }ã ELSEã BEGINã StrPos := 0; { Initialize 'StrPos' to 0. }ã REPEAT { Loop until every char checked. }ã INC(StrPos); { Point to next char. }ã IF UpCase(Str1[StrPos]) <> UpCase(Str2[StrPos]) THENã BEGINã CmpResult := False; { If there not the same then return }ã { a FALSE result. }ã StrPos := Length(Str2); { Now set loop exit condition. }ã END;ã UNTIL StrPos = Length(Str2);ã END;ã StrCmp := CmpResult;ãEND;{StrCmp}ããBEGINã Clrscr; { Clear away the screen. }ã Write(' Name of subject ? :');{ Prompt user for subject name. }ã Readln(SubName); { Now get users input. }ã IF StrCmp('English',SubName) THEN { If there the same then tell user}ã Writeln('You chose ENGLISH')ã ELSE { If not then .............. }ã Writeln('Unknown Subject!',^G);{Tell user its unknown. }ãEND.{StrCompare}ã{*********************************************************************}ã 74 02-03-9416:18ALL MAYNARD PHILBROOK BASM Right Pad IMPORT 4 ^& ãProcedure RightPas(Var S:String; MaxLen:Byte);ã Beginã ASmã LES BX, S;ã ESSegã Mov AL, [ES:BX];ã Xor AH, AH;ã Add BX, AX;ã@@Loop:ã Cmp AL, MaxLen;ã Jge @@Done;ã Mov Word Ptr [ES:BX],' ';ã Inc BX;ãã Inc AL;ã Jmp @@Loop;ã@@Done:ãEnd;ã 75 02-15-9408:41ALL GAYLE DAVIS Dec to Hex and Back IMPORT 12 ^& { Here is another set of routines to convert Decimal to Hex and vice versa}ããCONSTã HexString : array [0..15] of char = '0123456789ABCDEF';ããFUNCTION Dec2Hex (Num : word) : string;ã{ Returns decimal value as hex string }ãVARã Loop : Byte;ã S : string [10];ããBEGINã S := ''; { empty string } ã for Loop := 1 to 4 do begin { do 4 chars }ã S := HexString [Lo (Num) and $F] + S; { use 4 lowest bits } ã Num := Num shr 4; { shift bits right 4 } ã end;ã Dec2Hex := '$' + S; { return string } ãEND;ããFUNCTION Hex2Dec (S : string) : longint;ã{ returns hexadecimal string as decimal value }ãVARã Len : byte absolute S;ã Loop : byte;ã Li : longint;ã Num : longint;ããBEGINã if S [1] = '$' then delete (S, 1, 1);ã if upcase (S [Len]) = 'H' then dec (S [0]);ã Num := 0;ã for Loop := 1 to Len do beginã Li := 0;ã whileã (HexString [Li] <> S [Loop]) { compare letter }ã andã (Li < 16)ã doã inc (Li); { inc counter }ã if Li = 16 then beginã Num := -1; { -1 if invalid }ã exit;ã end;ã Num := Num + Li shl ((Len - Loop) * 4); { add to Num }ã end;ã Hex2Dec := Num; { return value }ãEND;ãã 76 05-25-9408:17ALL WIM VAN VOLLENHOVEN LONG String Arrays SWAG9405 33 ^& ã{ãGV> Hi Wim,ãHi Greg...ããGV> It wouldn't be difficult to write Pos, Copy, Assign, etc., whichãGV> operate on an ARRAY OF CHAR -- using the ASCIIZ scheme, or a lengthãGV> WORD (rather than length byte) at array elements [0] and [1].ããAs you can see in a other message has wim van der vegt written aãcomplete unit with these functions :-)ããit was a 'little' bit reprogramming to implement these new functions butãit was worth while ããGV> Greg_ãThanx for your answer, Wimããhere is the code :ã}ããUnit MyStr;ããINTERFACEãããConstã maxlength = 512;ã nul = #00;ã cr = #13;ã lf = #10;ã sp = #32;ããTypeã indexrange = 0..maxlength;ã stringtype = Recordã length : indexrange;ã chars : Array[1..maxlength] Of char;ã End;ãããFunction Long_Length(s : stringtype) : indexrange;ãProcedure Long_Readln(Var f : text;var l : stringtype);ãProcedure Long_Write(Var f : text;var l : stringtype);ãProcedure Long_Writeln(Var f : text;var l : stringtype);ãProcedure Long_Copy(s : stringtype;Var d : stringtype; index,count : indexrange);ãProcedure Long_Concat(Var d : stringtype;s : String);ããIMPLEMENTATIONã{---------------------------------------------------------}ã{ Author : Ir. G.W. van der Vegt }ã{ Project : Longer strings }ã{ Source : Pascal + Data Structures by Dale/Lilly }ã{ ISBN 0-669-07239-7 }ã{---------------------------------------------------------}ã{ Modified to give less errors and act more like TP's }ã{ functions. Can be made more efficient by using move, }ã{ moving the inc of length's out of the for loops and }ã{ not using the Length function to calc the length but }ã{ use the field in the record. etc. }ã{---------------------------------------------------------}ã{ Because Turbo Pascal's Functions won't return records }ã{ most of the Turbo Pascal String functions equivalents }ã{ can only be procedures. }ã{---------------------------------------------------------}ã{ The code hasn't been tested well yet so expect some }ã{ errors to be in it. All I have detected are fixed. }ã{ For testing set maxlength at 20 or 30. }ã{---------------------------------------------------------}ãããFunction Long_Length(s : stringtype) : indexrange;ããBeginã Long_Length:=s.length;ãEnd;ããProcedure Long_Readln(Var f : text;var l : stringtype);ããBeginã l.length:=0;ã Fillchar(l.chars,maxlength,sp);ã While NOT(Eoln(f) OR Eof(f)) AND (l.lengthCan anyone please help me speed up the following functions?ãã Aha! A challange! ããDJ>I wouldn't mind using built-in assembly either!ãã You can still achieve a large increase in speed without usingã assembly code. Here's my stab at rewriting your routines.ã (These could be written faster still, but I'll leave that upã to you.)ã}ãã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}ã{$M 4096,0,655360}ããprogram Test_New_Tab_Functions;ãã (***** Remove space-wasting chars from end of line. *)ã (* *)ã function TrimRight2({input }ã st_IN : string) :ã {output}ã string;ã varã by_Index : byte;ã beginã by_Index := length(st_IN);ã while st_IN[by_Index] IN [#0,#9,#32] doã beginã dec(by_Index);ã dec(st_IN[0])ã end;ã TrimRight2 := st_INã end; (* TrimRight2. *)ãã (***** Replace tabs with 8 spaces. *)ã (* *)ã function DeTab2({input }ã st_IN : string) :ã {output}ã string;ã varã by_Index1,ã by_Index2 : byte;ã st_Temp : string;ã beginã by_Index2 := 0;ã fillchar(st_Temp[1], 255, #32);ã for by_Index1 := 1 to length(st_IN) doã if (st_IN[by_Index1] <> #9) thenã beginã inc(by_Index2);ã st_Temp[by_Index2] := st_IN[by_Index1]ã endã elseã by_Index2 := succ(by_Index2 shr 3) shl 3;ã st_Temp[0] := chr(by_Index2);ã DeTab2 := st_Tempã end; (* DeTab2. *)ãã (***** Replace spaces with tabs to compress string. *)ã (* *)ã function EnTab2({input }ã st_IN : string) :ã {output}ã string;ã varã by_Count,ã by_IndexIN,ã by_IndexOUT : byte;ã st_Temp : string;ã beginã by_IndexIN := 0;ã by_IndexOUT := 0;ã by_Count := 0;ã st_Temp[0] := #0;ã fillchar(st_Temp[1], length(st_IN), #32);ã repeatã inc(by_IndexIN);ã if (st_IN[by_IndexIN] <> #32) thenã beginã inc(by_IndexOUT);ã st_Temp[by_IndexOUT] := st_IN[by_IndexIN]ã endã elseã beginã by_Count := 0;ã while ((by_IndexIN + by_Count) < length(st_IN))ã AND (st_IN[(by_IndexIN + by_Count)] = #32)ã AND (((by_IndexIN + by_Count) mod 8) <> 0) doã inc(by_Count);ãã if (by_Count > 0) thenã beginã if (((by_IndexIN + by_Count) mod 8) = 0) thenã beginã inc(by_IndexOUT);ã st_Temp[by_IndexOUT] := #9;ã inc(by_IndexIN, by_Count)ã endã elseã beginã inc(by_IndexOUT, by_Count);ã inc(by_IndexIN, pred(by_Count))ã endã endã elseã inc(by_IndexOUT)ã endã until (by_IndexIN = length(st_IN));ã st_Temp[0] := chr(by_IndexOut);ã EnTab2 := st_Tempã end; (* EnTab2. *)ããvarã by_Loop : byte;ã st_Temp1,ã st_Temp2 : string;ããBEGINã st_Temp1[0] := chr(245);ã fillchar(st_Temp1[1], 245, 'A');ã st_Temp1 := st_Temp1 + #9#0#32#32#9#9#9#0#32#0;ãã st_Temp2 := TrimRight2(st_Temp1);ãã st_Temp1 := '';ã for by_Loop := 1 to 17 doã st_Temp1 := st_Temp1 + 'ABCDEFG' + #9;ãã st_Temp2 := DeTab2(st_Temp1);ãã st_Temp1 := '';ã for by_Loop := 1 to 25 doã st_Temp1 := st_Temp1 + 'ABCDE ';ãã st_Temp2 := EnTab2(st_Temp1)ãEND.ãã Benchmarking my new routines against your old routines on myã 386DX-40 running Novell DOS 7.0, the results are:ãã Old TrimRight Time = 1.034 msã New TrimRight Time = 0.126 ms (820 percent faster)ãã Old DeTab Time = 2.514 msã New DeTab Time = 0.391 ms (640 percent faster)ãã Old EnTab Time = 8.450 msã New EnTab Time = 1.004 ms (840 percent faster)ãã ...Two things to keep in mind when trying to optimize a routineã are:ã Always try to reduce the number of loops your routineã has to make.ãã Copy/Move your data as little as possible.ãã 78 05-26-9406:13ALL JEFF FANJOY Complete String Unit IMPORT 37 ^& UNIT Strings;ããINTERFACEããUSESã CRT, {Import TextColor,TextBackGround}ã DOS; {Import FSplit,PathStr,NameStr,ExtStr,DirStr}ããTYPEã TDir = (L,R);ãããFUNCTION Str2Int(Str: String; (* Converts String to Integer *)ã VAR Code: Integer): Integer;ãFUNCTION Int2Str(I: Integer): String; (* Converts Integer to String *)ãFUNCTION StripSlash(Str: String): String; (* String trailing '\' *)ãFUNCTION AddSlash(Str: String): String; (* Add trailing '\' *)ãFUNCTION PadStr(Str: String; (* Pad String with characters *)ã Ch: Char; (* Character to pad with *)ã Num: Byte; (* Number of places to pad to *)ã Dir: TDir): String; (* Direction to pad in *)ãFUNCTION UpCaseStr(Str: String): String; (* Convert string to uppercase *)ãFUNCTION LowCaseStr(Str: String): String; (* Convert string to lowercase *)ãFUNCTION NameForm(Str: String): String; (* Convert string to Name format *)ãFUNCTION StripExt(Str: String): String; (* Strip Extension from filename *)ãFUNCTION AddExt(Str,Ext: String): String; (* Add Extension to filename *)ãFUNCTION ExtractFName(Str: String): String; (* Extract Filename *)ãFUNCTION ExtractFExt(Str: String): String; (* Extract file extension *)ãPROCEDURE Pipe(Str: String); (* Write string allowing for pipe codes *)ãããIMPLEMENTATIONãããFUNCTION Str2Int(Str: String;ã VAR Code: Integer): Integer;ãVAR I: Integer;ããBEGINã VAL(Str,I,Code);ã Str2Int := I;ãEND;ãããFUNCTION Int2Str(I: Integer): String;ãVAR S: String;ããBEGINã STR(I,S);ã Int2Str := S;ãEND;ãããFUNCTION StripSlash(Str: String): String;ããBEGINã IF Str[Length(Str)] = '\' THENã StripSlash := COPY(Str,1,Length(Str)-1);ãEND;ãããFUNCTION AddSlash(Str: String): String;ããBEGINã IF Str[Length(Str)] <> '\' THENã AddSlash := Str + '\';ãEND;ãããFUNCTION PadStr(Str: String;ã Ch: Char;ã Num: Byte;ã Dir: TDir): String;ãVARã TempStr: String;ã B: Byte;ããBEGINã TempStr := '';ã IF Length(Str) < Num THENã BEGINã FOR B := Length(Str) TO Num DO TempStr := TempStr + Ch;ã CASE Dir OFã L: PadStr := TempStr + Str;ã R: PadStr := Str + TempStr;ã END;ã ENDã ELSEã BEGINã FOR B := 1 TO Num DO TempStr := TempStr + Str[B];ã PadStr := TempStr;ã END;ãEND;ãããFUNCTION UpCaseStr(Str: String): String;ãVARã TempStr: String;ã B: Byte;ããBEGINã TempStr := Str;ã FOR B := 1 TO Length(Str) DO TempStr[B] := UpCase(TempStr[B]);ã UpCaseStr := TempStr;ãEND;ãããFUNCTION LowCaseStr(Str: String): String;ãVARã TempStr: String;ã B: Byte;ããBEGINã TempStr := Str;ã FOR B := 1 TO Length(Str) DO IF TempStr[B] IN ['A'..'Z'] THENã TempStr[B] := CHR(ORD(TempStr[B])+32);ã LowCaseStr := TempStr;ãEND;ãããFUNCTION NameForm(Str: String): String;ãVARã TempStr: String;ã Pos: Byte;ããBEGINã TempStr := Str;ã TempStr[1] := UpCase(TempStr[1]);ã FOR Pos := 2 TO Length(TempStr) DOã IF TempStr[Pos] = #32 THENã TempStr[Pos+1] := UpCase(TempStr[Pos+1])ã ELSEã IF TempStr[Pos] IN ['A'..'Z'] THENã TempStr[Pos] := CHR(ORD(TempStr[Pos])+32);ã NameForm := TempStr;ãEND;ãããFUNCTION StripExt(Str: String): String;ãVAR DotPos: Byte;ããBEGINã DotPos := POS('.',Str);ã IF DotPos > 1 THEN StripExt := COPY(Str,1,DotPos-1)ã ELSE StripExt := Str;ãEND;ãããFUNCTION AddExt(Str,Ext: String): String;ãVAR DotPos: Byte;ããBEGINã DotPos := POS('.',Str);ã IF (DotPos > 1) AND (DotPos < 10) THEN AddExt := COPY(Str,1,DotPos) + Extã ELSE IF DotPos = 0 THEN AddExt := Str + '.' + Ext;ãEND;ãããFUNCTION ExtractFName(Str: String): String;ãVARã Path: PathStr;ã Dir: DirStr;ã Name: NameStr;ã Ext: ExtStr;ããBEGINã Path := Str;ã FSplit(Path,Dir,Name,Ext);ã ExtractFName := Name+Ext;ãEND;ãããFUNCTION ExtractFExt(Str: String): String;ãVARã Path: PathStr;ã Dir: DirStr;ã Name: NameStr;ã Ext: ExtStr;ããBEGINã Path := Str;ã FSplit(Path,Dir,Name,Ext);ã ExtractFExt := Ext;ãEND;ãããPROCEDURE Pipe(Str: String);ãVARã StrPos, Err: Integer;ã Col: Byte;ããBEGINã StrPos := 1;ã IF Length(Str) < 1 THEN Exit;ã REPEATã IF (Str[StrPos] = '|') THENã BEGINã Val(Copy(Str,StrPos+1,2),Col,Err);ã IF (Err = 0) AND (Col IN [0..23]) THENã IF Col IN [0..15] THEN TextColor(Col)ã ELSE TextBackGround(Col-16);ã Inc(StrPos,3);ã ENDã ELSEã BEGINã Write(Str[StrPos]);ã Inc(StrPos);ã END;ã UNTIL (StrPos > Length(Str));ãEND;ãããBEGINãEND.ã 79 05-26-9406:21ALL KEN HENDERSON Word Strings-64K IMPORT 185 ^& {$S-,R-,V-,I-,B-,F+}ãã{$IFNDEF Ver40}ã {$I OPLUS.INC}ã{$ENDIF}ãã{*********************************************************}ã{* TPWRDSTR.PAS 1.0 *}ã{* Copyright (c) Ken Henderson 1990. *}ã{* *}ã{* *}ã{* All rights reserved. *}ã{*********************************************************}ããunit TPWrdStr;ã {-Routines to support strings which use a word in the place of Turbo Pascal'sã byte for holding the length of a string -- theoretically allowing stringsã as large as 64k.}ããinterfaceããusesã TpString;ããconstã MaxWrdStr = 1024; {Maximum length of WrdStr - increase up to 65519}ã NotFound = 0; {Returned by the Pos functions if substring not found}ããtypeã WrdStr = array[-1..MaxWrdStr] of Char;ã WrdStrPtr = ^WrdStr;ããfunction WrdStr2Str(var A : WrdStr) : string;ã {-Convert WrdStr to Turbo string, truncating if longer than 255 chars}ããprocedure Str2WrdStr(S : string; var A : WrdStr);ã {-Convert a Turbo string into an WrdStr}ããfunction LenWrdStr(A : WrdStr) : Word;ã {-Return the length of an WrdStr string}ããprocedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);ã {-Return a substring of a. Note start=1 for first char in a}ããprocedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);ã {-Delete len characters of a, starting at position start}ããprocedure ConcatWrdStr(var A, B, C : WrdStr);ã {-Concatenate two WrdStr strings, returning a third}ããprocedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);ã {-Concatenate a string to an WrdStr, returning a new WrdStr}ããprocedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);ã {-Insert WrdStr obj at position start of a}ããprocedure InsertStr(Obj : string; var A : WrdStr; Start : Word);ã {-Insert string obj at position start of a}ããfunction PosStr(Obj : string; var A : WrdStr) : Word;ã {-Return the position of the string obj in a, returning NotFound if not found}ããfunction PosWrdStr(var Obja, A : WrdStr) : Word;ã {-Return the position of obja in a, returning NotFound if not found}ããfunction WrdStrToHeap(var A : WrdStr) : WrdStrPtr;ã {-Put WrdStr on heap, returning a pointer, nil if insufficient memory}ããprocedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);ã {-Return an WrdStr from the heap, empty if pointer is nil}ããprocedure DisposeWrdStr(P : WrdStrPtr);ã {-Dispose of heap space pointed to by P}ããfunction ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;ã {-Read an WrdStr from text file, returning true if successful}ããfunction WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;ã {-Write an WrdStr to text file, returning true if successful}ããprocedure WrdStrUpcase(var A, B : WrdStr);ã {-Uppercase the WrdStr in a, returning b}ããprocedure WrdStrLocase(var A, B : WrdStr);ã {-Lowercase the WrdStr in a, returning b}ããprocedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);ã {-Return an WrdStr of length len filled with ch}ããprocedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);ã {-Right-pad the WrdStr in a to length len with ch, returning b}ããprocedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);ã {-Right-pad the WrdStr in a to length len with blanks, returning b}ããprocedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);ã {-Left-pad the WrdStr in a to length len with ch, returning b}ããprocedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);ã {-Left-pad the WrdStr in a to length len with blanks, returning b}ããprocedure WrdStrTrimLead(var A, B : WrdStr);ã {-Return an WrdStr with leading white space removed}ããprocedure WrdStrTrimTrail(var A, B : WrdStr);ã {-Return an WrdStr with trailing white space removed}ããprocedure WrdStrTrim(var A, B : WrdStr);ã {-Return an WrdStr with leading and trailing white space removed}ããprocedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);ã {-Return an WrdStr centered in an WrdStr of Ch with specified width}ããprocedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);ã {-Return an WrdStr centered in an WrdStr of blanks with specified width}ããfunction CompWrdStr(var a1, a2 : WrdStr) : Boolean;ã {-Return equivalence of a1 and a2}ãã {==========================================================================}ããimplementationãconstã Blank : char = #32;ãã function WrdStr2Str(var A : WrdStr) : string;ã {-Convert WrdStr to Turbo string, truncating if longer than 255 chars}ã varã S : string;ã Len : Word absolute A;ã Slen : byte Absolute S;ã beginã if Len > 255 then SLen := 255ã else Slen := Len;ã Move(A[1], S[1], SLen);ã WrdStr2Str := S;ã end;ãã procedure Str2WrdStr(S : string; var A : WrdStr);ã {-Convert a Turbo string into an WrdStr}ã varã slen : byte absolute S;ã alen : word absolute A;ã beginã Move(S[1], A[1], slen);ã alen := slen;ã end;ãã function LenWrdStr(A : WrdStr) : Word;ã {-Return the length of an WrdStr string}ã varã alen : Word absolute A;ã beginã LenWrdStr := alen;ã end;ãã procedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);ã {-Return a substring of a. Note start=1 for first char in a}ã varã alen : Word absolute A;ã olen : Word absolute O;ã beginã if Start > alen thenã Olen := 0ã else beginã {Don't copy more than exists}ã if Start+Len > alen thenã Len := Succ(alen-Start);ã Move(A[Start], O[1], Len);ã Olen := Len;ã end;ã end;ãã procedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);ã {-Delete len characters of a, starting at position start}ã varã alen : Word Absolute A;ã mid : Word;ã beginã if Start <= alen then beginã {Don't do anything if start position exceeds length of string}ã mid := Start+Len;ã if mid <= alen then beginã {Move right remainder of string left}ã Move(A[mid], A[Start], len);ã Dec(alen,len);ã end elseã {Entire end of string deleted}ã alen := Pred(Start);ã end;ã end;ãã procedure ConcatWrdStr(var A, B, C : WrdStr);ã {-Concatenate two WrdStr strings, returning a third}ã varã alen : Word absolute A;ã blen : Word absolute B;ã clen : Word absolute C;ã temp : Word;ã beginãã {Put a into the result}ã Move(A[1], C[1], alen);ãã {Store as much of b as fits into result}ã Temp := blen;ã if alen+blen > MaxWrdStr thenã Temp := MaxWrdStr-alen;ã Move(B[1], C[Succ(alen)], Temp);ãã {Terminate the result}ã clen := alen+blen;ã end;ãã procedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);ã {-Concatenate a string to an WrdStr, returning a new WrdStr}ã varã alen : Word absolute A;ã clen : Word absolute C;ã slen : Byte absolute S;ã beginãã {Put a into the result}ã Move(A[1], C[1], alen);ãã {Store as much of s as fits into result}ã if alen+slen > MaxWrdStr thenã slen := MaxWrdStr-alen;ã Move(S[1], C[succ(alen)], slen);ãã {Terminate the result}ã clen := alen+slen;ã end;ãã procedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);ã {-Insert WrdStr obj at position start of a}ã varã alen : Word absolute A;ã olen : Word absolute Obj;ã mid, temp : Word;ã beginãã if Start > alen thenã {Concatenate if start exceeds alen}ã Start := Succ(alen)ãã else beginã {Move right side characters right to make space for insert}ã mid := Start+olen;ã if mid <= MaxWrdStr thenã {Room for at least some of the right side characters}ã if alen+olen <= MaxWrdStr thenã {Room for all of the right side}ã Move(A[Start], A[mid], Succ(alen-Start))ã elseã {Room for part of the right side}ã Move(A[Start], A[mid], Succ(MaxWrdStr-mid));ã end;ãã {Insert the obj string}ã temp := Olen;ã if Start+olen > MaxWrdStr thenã temp := Succ(MaxWrdStr-Start);ã Move(Obj[1], A[Start], temp);ãã {Terminate the string}ã if alen+olen <= MaxWrdStr thenã Inc(alen,olen)ã elseã alen := MaxWrdStr;ã end;ãã procedure InsertStr(Obj : string; var A : WrdStr; Start : Word);ã {-Insert string obj at position start of a}ã varã alen : Word absolute A;ã olen : byte absolute Obj;ã mid,temp : Word;ã beginãã if Start > alen thenã {Concatenate if start exceeds alen}ã Start := succ(alen)ãã else beginã {Move right side characters right to make space for insert}ã mid := Start+olen;ã if mid <= MaxWrdStr thenã {Room for at least some of the right side characters}ã if alen+olen <= MaxWrdStr thenã {Room for all of the right side}ã Move(A[Start], A[mid], Succ(alen-Start))ã elseã {Room for part of the right side}ã Move(A[Start], A[mid], Succ(MaxWrdStr-mid));ã end;ãã {Insert the obj string}ã temp := olen;ã if Start+olen > MaxWrdStr thenã temp := Succ(MaxWrdStr-Start);ã Move(Obj[1], A[Start], temp);ãã {Terminate the string}ã if alen+olen <= MaxWrdStr thenã Inc(alen,olen)ã elseã alen := MaxWrdStr;ã end;ãã {$L TPWrdStr}ã function Search(var Buffer; BufLength : Word; var Match; MatLength : Word) : Word;ã external;ã procedure WrdStrUpcase(var A, B : WrdStr);ã {-Upper case WrdStr A, returning it in B}ã varã alen : Word absolute A;ã x : Word;ã beginã For x:=1 to alen do A[x]:=UpCase(A[x]);ã Move(A,B,alen+2);ã end;ã procedure WrdStrLocase(var A, B : WrdStr);ã {-Lower case WrdStr A, returning it in B}ã varã alen : Word absolute A;ã x : Word;ã beginã For x:=1 to alen do A[x]:=LoCase(A[x]);ã Move(A,B,alen+2);ã end;ãã function CompWrdStr(var a1, a2 : WrdStr) : Boolean;ã {-Compare WrdStr's a1 and a2 and return equivalence}ã varã alen1 : Word absolute A1;ã alen2 : Word absolute A2;ã x : Word;ã beginã CompWrdStr := false;ã If (alen1=alen2) then {possibly equal, let's check it out}ã beginã for x:=1 to alen1 do if (A1[x]<>A2[x]) then exit;ã CompWrdStr := true; {If we made it to here, they must be equal}ã end;ã end;ãã function PosStr(Obj : string; var A : WrdStr) : Word;ã {-Return the position of the string obj in a, returning NotFound if not found}ã varã alen : Word absolute A;ã olen : Byte absolute Obj;ã PosFound : Word;ã beginã PosFound := Search(A[1], alen, Obj[1], olen);ã If (PosFound = $FFFF) then {Search didn't find it}ã PosFound := 0;ã PosStr := Succ(PosFound);ã end;ãã function PosWrdStr(var Obja, A : WrdStr) : Word;ã {-Return the position of obja in a, returning NotFound if not found}ã varã alen : Word absolute A;ã olen : Word absolute Obja;ã PosFound : Word;ã beginã PosFound := Search(A[1], alen, Obja[1], olen);ã If (PosFound = $FFFF) then {Search didn't find it}ã PosFound := 0;ã PosWrdStr := Succ(PosFound);ã end;ãã function WrdStrToHeap(var A : WrdStr) : WrdStrPtr;ã {-Put WrdStr on heap, returning a pointer, nil if insufficient memory}ã varã alen : Word;ã P : WrdStrPtr;ã beginã alen := LenWrdStr(A)+2;ã if MaxAvail >= alen then beginã GetMem(P, alen);ã Move(A, P^, alen);ã WrdStrToHeap := P;ã end elseã WrdStrToHeap := nil;ã end;ãã procedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);ã {-Return an WrdStr from the heap, empty if pointer is nil}ã varã alen : Word absolute a;ã plen : Word absolute p;ã beginã if P = nil thenã Alen := 0ã elseã Move(P^, A, Plen+2);ã end;ãã procedure DisposeWrdStr(P : WrdStrPtr);ã {-Dispose of heap space pointed to by P}ã beginã if P <> nil thenã FreeMem(P, LenWrdStr(P^)+2);ã end;ãã procedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);ã {-Return an WrdStr of length len filled with ch}ã varã alen : Word absolute A;ã beginã if Len = 0 thenã Alen := 0ã else beginã if Len > MaxWrdStr thenã Len := MaxWrdStr;ã FillChar(A[1], Len, Ch);ã Alen := Len;ã end;ã end;ãã procedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);ã {-Right-pad the WrdStr to length len with ch, returning b}ã varã alen : Word Absolute A;ã blen : Word Absolute B;ã beginã if alen >= Len thenã {Return the input string}ã Move(A, B, alen+2)ã else beginã if Len > MaxWrdStr thenã Len := MaxWrdStr;ã Move(A[1], B[1], alen);ã FillChar(B[succ(alen)], Len-alen, Ch);ã Blen := len;ã end;ã end;ãã procedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);ã {-Right-pad the WrdStr to length len with blanks, returning b}ã beginã WrdStrPadCh(A, Blank, Len, B);ã end;ãã procedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);ã {-Left-pad the WrdStr in a to length len with ch, returning b}ã varã alen : Word absolute A;ã blen : Word absolute B;ã beginã if alen >= Len thenã {Return the input string}ã Move(A, B, alen+2)ã else beginã FillChar(B[1], Len-alen, Ch);ã Move(A[1], B[Succ(Len-alen)], alen);ã BLen := Len;ã end;ã end;ãã procedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);ã {-Left-pad the WrdStr in a to length len with blanks, returning b}ã beginã WrdStrLeftPadCh(A, Blank, Len, B);ã end;ãã procedure WrdStrTrimLead(var A, B : WrdStr);ã {-Return an WrdStr with leading white space removed}ã varã alen : Word absolute A;ã apos : Word;ã beginã apos := 1;ã while (apos < alen) and (A[apos] <= Blank) doã Inc(apos);ã Move(A[apos], B[1], Succ(alen-apos));ã end;ãã procedure WrdStrTrimTrail(var A, B : WrdStr);ã {-Return an WrdStr with trailing white space removed}ã varã alen : Word absolute A;ã blen : Word absolute B;ã beginã while (alen > 1) and (A[Pred(alen)] <= Blank) doã Dec(alen);ã Move(A, B, alen+2);ã end;ãã procedure WrdStrTrim(var A, B : WrdStr);ã {-Return an WrdStr with leading and trailing white space removed}ã varã blen : Word Absolute B;ã beginã WrdStrTrimLead(A, B);ã while (blen > 1) and (B[Pred(blen)] <= Blank) doã Dec(blen);ã end;ãã procedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);ã {-Return an WrdStr centered in an WrdStr of Ch with specified width}ã varã alen : Word absolute A;ã blen : Word absolute B;ã beginã if alen >= Width thenã {Return input}ã Move(A, B, alen+2)ã else beginã FillChar(B[1], Width, Ch);ã Move(A[1], B[Succ((Width-alen) shr 1)], alen);ã Blen := Width;ã end;ã end;ãã procedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);ã {-Return an WrdStr centered in an WrdStr of blanks with specified width}ã beginã WrdStrCenterCh(A, Blank, Width, B);ã end;ããtypeã {text buffer}ã TextBuffer = array[0..65520] of Byte;ãã {structure of a Turbo File Interface Block}ã FIB = recordã Handle : Word;ã Mode : Word;ã BufSize : Word;ã Private : Word;ã BufPos : Word;ã BufEnd : Word;ã BufPtr : ^TextBuffer;ã OpenProc : Pointer;ã InOutProc : Pointer;ã FlushProc : Pointer;ã CloseProc : Pointer;ã UserData : array[1..16] of Byte;ã Name : array[0..79] of Char;ã Buffer : array[0..127] of Char;ã end;ããconstã FMClosed = $D7B0;ã FMInput = $D7B1;ã FMOutput = $D7B2;ã FMInOut = $D7B3;ã CR : Char = ^M;ãã function ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;ã {-Read an WrdStr from text file, returning true if successful}ã varã CrPos : Word;ã alen : Word absolute A;ã blen : Word;ãã function RefillBuf(var F : Text) : Boolean;ã {-Refill buffer}ã varã Ch : Char;ã beginã with FIB(F) do beginã BufEnd := 0;ã BufPos := 0;ã Read(F, Ch);ã if IoResult <> 0 then beginã {Couldn't read from file}ã RefillBuf := False;ã Exit;ã end;ã {Reset the buffer again}ã BufPos := 0;ã RefillBuf := True;ã end;ã end;ããã beginã with FIB(F) do beginãã {Initialize the WrdStr length and function result}ã alen := 0;ã ReadLnWrdStr := False;ãã {Make sure file open for input}ã if Mode <> FMInput thenã Exit;ãã {Make sure something is in buffer}ã if BufPos >= BufEnd thenã if not(RefillBuf(F)) thenã Exit;ãã {Use the Turbo text file buffer to build the WrdStr}ã repeatãã {Search for the next carriage return in the file buffer}ã CrPos := Search(BufPtr^[BufPos], Succ(BufEnd-BufPos), CR, 1);ãã if CrPos = $FFFF then beginã {CR not found, save the portion of the buffer seen so far}ã blen := BufEnd-BufPos;ã if alen+blen > MaxWrdStr thenã blen := MaxWrdStr-alen;ãã Move(BufPtr^[BufPos], A[alen], blen);ã Inc(alen, blen);ãã {See if at end of file}ã if eof(F) then beginã {Force exit with this line}ã CrPos := 0;ã {Remove trailing ^Z}ã while (alen > 1) and (A[Pred(alen)] = ^Z) doã Dec(alen);ã end else if not(RefillBuf(F)) thenã Exit;ãã end else beginã {Save up to the CR}ã blen := CrPos;ã if alen+blen > MaxWrdStr thenã blen := MaxWrdStr-alen;ã Move(BufPtr^[BufPos], A[alen], blen);ã Inc(alen, blen);ãã {Inform Turbo we used the characters}ã Inc(BufPos, Succ(CrPos));ãã {Skip over following ^J}ã if BufPos < BufEnd then beginã {Next character is within current buffer}ã if BufPtr^[BufPos] = Ord(^J) thenã Inc(BufPos);ã end else beginã {Next character is not within current buffer}ã {Refill the buffer}ã if not(RefillBuf(F)) thenã Exit;ã if BufPos < BufEnd thenã if BufPtr^[BufPos] = Ord(^J) thenã Inc(BufPos);ã end;ãã end;ãã until (CrPos <> $FFFF) or (alen > MaxWrdStr);ãã {Return success and terminate the WrdStr}ã ReadLnWrdStr := True;ãã end;ã end;ãã function WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;ã {-Write an WrdStr to text file, returning true if successful}ã varã S : string;ã alen : Word absolute A;ã apos : Word;ã slen : Byte absolute S;ã beginã apos := 1;ã WriteWrdStr := False;ãã {Write the WrdStr as a series of strings}ã while apos < alen do beginã slen := alen-apos;ã if slen > 255 thenã slen := 255;ã Move(A[apos], S[1], slen);ã Write(F, S);ã if IoResult <> 0 thenã Exit;ã Inc(apos, slen);ã end;ãã WriteWrdStr := True;ã end;ããend.ããã{ ----------------- XX3402 Code for TPWRDSTR.OBJ ------------------}ã{ Cut HERE and save save to a files (TPWRDSTR.XX). From DOS execute:ã{ XX3402 D TPWRDSTR.XX to create TPWRDSTR.OBJ }ãã*XX3402-000257-280390--72--85-53814----TPWRDSTR.OBJ--1-OF--1ãU+s+13FEJp72IpFG9Y3HHQq66++++3FpQa7j623nQqJhMalZQW+UJaJmQqZjPW+l9X+lW6UIã+21dk9Bw3+lII3RGF3BIIWt-IoqHW-E+ECaU83gG13FEEoxBHIxC9Y3HHLu6+k-+uImK+U++ãO7M4++F1HoF3FNU5+0V0++6-+TCA4E+8JJ-1EJB3I377HE+8H2x1EJB3I377HE-TY+o+++24ãIoJ-IYB6++++dcU2+20W+N4UFU+-++-JWykSzAFy1cjTWosAWpM4VR7o7AJq08l88wdq4z8iãRFS3obEAIJRKWwfndZtTKLLgHsj58wDf+nD+G-y9tJr80U+VWU6++5E+ã***** END OF BLOCK 1 *****ãã{ ----------------------- CUT HERE ----------------------------------- }ãã{ ------------- ASSEMBLER CODE FOR TPWRDSTR.ASM ------------------- }ã{ USE TASM TO COMPILE }ã;******************************************************ã; TPWRDSTR.ASM 1.0ã; WrdStr string manipulationã; Copyright (c) TurboPower Software 1987.ã; Portions copyright (c) Sunny Hill Software 1985, 1986ã; and used under license to TurboPower Softwareã; All rights reserved.ã;******************************************************ãã INCLUDE TPCOMMON.ASMãã;****************************************************** CodeããCODE SEGMENT BYTE PUBLICãã ASSUME CS:CODEãã PUBLIC Searchãã EXTRN UpCasePrim : FARã EXTRN LoCasePrim : FARããUpcase MACRO ;UpCase character in ALã PUSH BXã CALL UpCasePrimã POP BXã ENDMããLocase MACRO ;LoCase character in ALã PUSH BXã CALL LoCasePrimã POP BXã ENDMãã;****************************************************** Searchãã; function Search(var Buffer; BufLength : Word;ã; var Match; MatLength : Word) : Word; external;ã;Search through Buffer for Match.ã;BufLength is length of range to search.ã;MatLength is length of string to matchã;Returns number of bytes searched to find St, FFFF if not foundãã;equates for parameters:ãMatLength EQU WORD PTR [BP+6]ãMatch EQU DWORD PTR [BP+8]ãBufLength EQU WORD PTR [BP+0Ch]ãBuffer EQU DWORD PTR [BP+0Eh]ããSearch PROC FARãã StackFrameBPã PUSH DS ;Save DSã CLD ;Go forwardãã LES DI,Buffer ;ES:DI => Bufferã MOV BX,DI ;BX = Ofs(Buffer)ãã MOV CX,BufLength ;CX = Length of range to scanã MOV DX,MatLength ;DX = Length of match stringãã TEST DX,DX ;Length(Match) = 0?ã JZ Error ;If so, we're doneãã LDS SI,Match ;DS:SI => Match bufferã LODSB ;AL = Match[1]; DS:SI => Match[2]ã DEC DX ;DX = MatLength-1ã SUB CX,DX ;CX = BufLength-(MatLength-1)ã JBE Error ;Error if BufLength is lessãã;Search for first character in StãNext: REPNE SCASB ;Search forward for Match[1]ã JNE Error ;Done if not foundã TEST DX,DX ;If Length = 1 (DX = 0) ...ã JZ Found ; the "string" was foundãã ;Search for remainder of Stãã PUSH CX ;Save CXã PUSH DI ;Save DIã PUSH SI ;Save SIãã MOV CX,DX ;CX = Length(St) - 1ã REPE CMPSB ;Does rest of string match?ãã POP SI ;Restore SIã POP DI ;Restore DIã POP CX ;Restore CXãã JNE Next ;Try again if no matchãã;Calculate number of bytes searched and return in StãFound: DEC DI ;DX = Offset where foundã MOV AX,DI ;AX = Offset where foundã SUB AX,BX ;Subtract starting offsetã JMP Short Done ;Doneãã;Match was not foundãError: XOR AX,AX ;Returnã DEC AX ;Return FFFFããDone: POP DS ;Restore DSã ExitCode 10ããSearch ENDPããCODE ENDSãã ENDã{ END OF TPWRDSTR.ASM }ã{------------------------------- CUT HERE ------------------------- }ã 80 05-26-9411:04ALL RICHARD MULLEN Format Strings IMPORT 43 ^& ã(******************************************************************************ã RealStr.PAS - Routine which formats a double, real or single number to aã requested number of significant digits.ã Author - Richard Mullen CIS 76566,1325ã Date - 7/5/90, Released to public domainã******************************************************************************)ã{$O+}ã{$F+}ã{$R+} { Range checking on }ã{$B-} { Boolean complete evaluation off }ã{$S-} { Stack checking off }ã{$I-} { I/O checking off }ã{$V-} { Relaxed variable checking }ã{$N+} { Numeric coprocessor }ã{$E+} { Numeric coprocessor emulation }ããUNIT RealStr;ããINTERFACEããfunction Real_To_Str (SigDigits : word; Number : double) : string;ãã { SigDigits should be between 2 and 15 for doubles }ã { 2 and 11 for reals }ã { 2 and 7 for singles }ããIMPLEMENTATIONãã(*****************************************************************************)ããfunction Real_To_Str (SigDigits : word; Number : double) : string;ãvarã i : integer;ã ErrorCode : integer;ã E_Value : integer;ã E_Position : word;ã Exponent : string[4];ã SDigits : word;ã TempString : string;ããbeginã(*ã if SigDigits > 15 then SigDigits := 15; { 15 for double, 11 for real, }ã if SigDigits < 2 then SigDigits := 2; { 7 for single }ã*)ã str (Number, TempString);ã delete (TempString, 3, 1); { Delete decimal point }ã E_Position := pos ('E', TempString);ã val (copy (TempString, E_Position + 1, 5), E_Value, ErrorCode);ã Real_To_Str := '';ã if ErrorCode <> 0 then exit; { E_Value = exponent }ã delete (TempString, E_Position, 6); { Delete exponent string }ã { from TempString }ã if SigDigits + 2 < E_Position thenã begin { Round TempString }ã insert ('0', TempString, 2); { Insert 0 for overflow } E_Position := pos ('E', TempString);ã if TempString[SigDigits + 3] >='5' then {}ã inc (TempString[SigDigits + 2]); {}ã for i := SigDigits + 2 downto 2 do {}ã if TempString [i] = chr (ord ('9') + 1) then {}ã begin {}ã TempString [i] := '0'; {}ã inc (TempString [i - 1]); {}ã end; {}ã if TempString[2] = '0' then delete (TempString, 2, 1) { <-- no overflow }ã else inc (E_Value); { <-- overflow }ã end; {}ã { Delete extra precision }ã delete (TempString, SigDigits + 2, length (TempString));ãã i := length (TempString); { Remove all trailing }ã while (TempString[i] = '0') AND (i > 2) do { zeros, leaving only }ã begin { significant digits }ã delete (TempString, i, 1); {}ã dec (i); {}ã end; {}ãã SDigits := length (TempString) - 1; { Number of significant digits }ãã if (E_Value >= SigDigits) OR (SDigits - E_Value - 1 > SigDigits) thenã begin { Scientific notation }ã if SDigits > 1 then insert ('.', TempString, 3); {}ã str (E_Value, Exponent); {}ã TempString := Tempstring + ' E' + Exponent; {}ã end {}ã elseã beginã if E_Value >= 0 then { Exponent is positive }ã begin { |Number|, >= 1, can }ã for i := 1 to E_Value - SDigits + 1 do { be displayed with }ã TempString := TempString + '0'; { no exponent }ã if E_Value < SDigits - 1 then insert ('.', TempString, E_Value + 3);ã endã elseã begin { Exponent is negative }ã for i := 1 to - E_Value - 1 do { |Number|, < 1, can }ã insert ('0', TempString, 2); { be displayed with }ã insert ('0.', TempString, 2); { no exponent }ã end; { Add '0.' to number }ã end;ãã Real_To_Str := TempString;ãend;ãã(************************ No initialization ******************************)ãend. 81 05-26-9411:04ALL SWAG SUPPORT TEAM General String Library IMPORT 179 ^& UNIT STR_STF;ã {**------------------------------------------------**}ã {** STRING Library OPERATIONS **}ã {** Version 1.2 **}ã {** Added Pos_Reverse **}ã {** Version 1.1 (sped-ups) **}ã {** (delete_duplicate_Chars_in_str) **}ã {** Added Int_To_Str_Zero_Fill **}ã {**------------------------------------------------**}ãã{$O-,F+}ããINTERFACEã{**************************************************************}ã{* Trim removes leading/trailing blanks. *}ã{* *}ã{**************************************************************}ãFUNCTION TRIM (Str : string) : string;ããFUNCTION TRIM_Leading_Only (Str : string) : string;ãFUNCTION TRIM_Trailing_Only (Str : string) : string;ãFUNCTION TRIM_Quotes (Str : string) : string;ãã{**************************************************************}ã{* Right_Justify adds leading blanks. *}ã{* NOTE: does not handle cases when *}ã{* Size_To_Be < ACTUAL NUMBER OF CHARACTERS *}ã{**************************************************************}ãFUNCTION Right_Justify (Str : string; Size_To_Be : integer) : string;ãã{***************************************************************}ã{* Center_Str centers the characters in the string based *}ã{* upon the size/midpoint specified. *}ã{***************************************************************}ãFUNCTION Center_Str (Str : string; Output_Size : integer) : string;ãã{**************************************************************}ã{* Change_Case changes the case of the string to UPPER. *}ã{* *}ã{**************************************************************}ãFUNCTION CHANGE_CASE (Str : string) : string;ãFUNCTION Lower_Case (Str : string) : string;ãã{**************************************************************}ã{* Int_To_Str returns the number converted into ascii chars. *}ã{* *}ã{**************************************************************}ãFUNCTION Int_To_Str (Num : LongInt) : string;ãFUNCTION Int_To_Str_Zero_Fill (Num : LongInt; Fill : byte) : string;ãFUNCTION Int_Num_Digits (Num : LongInt) : integer;ãã{**************************************************************}ã{* Pos_Reverse returns the last occurance of the string *}ã{* just before the specified start pos! *}ã{**************************************************************}ãFUNCTION Pos_Reverse (Str : string;ã Delimiter : string;ã Start_At : integer) : integer;ãã{**************************************************************}ã{* Find_Char returns the position of the char *}ã{* *}ã{**************************************************************}ãFUNCTION Find_Char (Str : string;ã Char_Is : char;ã Start_At : integer) : INTEGER;ãã{**************************************************************}ã{* Delete_The_Char delete all occurances of the char *}ã{* *}ã{**************************************************************}ãFUNCTION Delete_The_Charã (Str : string;ã Char_Is : char) : string;ãã{**************************************************************}ã{* Replace_Str_Into inserts the small string into the *}ã{* org_str at the position specified *}ã{**************************************************************}ãFUNCTION Replace_Str_Into (Org_Str : String;ã Small_Str : string;ã Start, Stop : integer) : string;ãã{**************************************************************}ã{* procedure Get_Word_Around_Position *}ã{* returns the word based AROUND the position specified *}ã{* Searches for blanks around the start_pos *}ã{* looking left then right. *}ã{**************************************************************}ãfunction Get_Word_Around_Positionã (Str : string;ã Start_Pos : integer;ã Leftmost_Char_Boundry : integer;ã Rightmost_Char_Boundry : integer;ã VAR Found_Left_Pos : integer;ã VAR Found_Word_Size : integer) : string;ãã{**************************************************************}ã{* returns a string with duplicate chars deleted. *}ã{**************************************************************}ãfunction Delete_Duplicate_Chars_In_Str (Str : string;ã Limit_In_A_Row : byte): string;ãã{**************************************************************}ã{* returns a string filled with the character specified *}ã{**************************************************************}ãfunction Fill_String(Len : Byte; Ch : Char) : String;ãã{**************************************************************}ã{* Truncates a string to a specified length *}ã{**************************************************************}ãfunction Trunc_Str(TString : String; Len : Byte) : String;ãã{**************************************************************}ã{* Pads a string to a specified length with a specified character }ã{**************************************************************}ãfunction Pad_Char(PString : String; Ch : Char; Len : Byte) : String;ããã{**************************************************************}ã{* Left-justify a string within a certain width *}ã{**************************************************************}ãfunction Left_Justify_Str (S : String; Width : Byte) : String;ããã{**************************************************************}ã{* Note that "Count" is the number of *WORDS* to fill. *}ã{* So e.g. you'd use *}ã{* "FillWord(My_Int_Array, SizeOf(My_Int_Array) DIV 2, 1);" *}ã{* by Neil Rubenking *}ã{**************************************************************}ãPROCEDURE FillWord (VAR Dest; Count, What : Word);ããã{**************************************************************}ã{**************************************************************}ã{**************************************************************}ãIMPLEMENTATIONãã{**************************************************************************}ãfunction Min(N1, N2 : Longint) : Longint;ã{ Returns the smaller of two numbers }ãbeginã if N1 <= N2 thenã Min := N1ã elseã Min := N2;ãend; { Min }ãã(*ã{**************************************************************************}ãfunction Max(N1, N2 : Longint) : Longint;ã{ Returns the larger of two numbers }ãbeginã if N1 >= N2 thenã Max := N1ã elseã Max := N2;ãend; { Max }ã*)ãã{**************************************************************}ã{* returns a string filled with the character specified *}ã{**************************************************************}ãfunction Fill_String(Len : Byte; Ch : Char) : String;ãvarã S : String;ãbeginã IF (Len > 0) THENã BEGINã S[0] := Chr(Len);ã FillChar(S[1], Len, Ch);ã Fill_String := S;ã ENDã ELSE Fill_String := '';ãend; { FillString }ãã{**************************************************************}ã{* Truncates a string to a specified length *}ã{**************************************************************}ãfunction Trunc_Str(TString : String; Len : Byte) : String;ãbeginã if (Length(TString) > Len) thenã beginã {Delete(TString, Succ(Len), Length(TString) - Len);}ã {Move(TString[Succ(Len)+(LENGTH(TString)-Len)], TString[Succ(Len)],ã Succ(Length(TString)) - Succ(Len) - Length(TString) - Len));}ã Move(TString[LENGTH(TString)+1], TString[Succ(Len)], 2*Len);ã Dec(TString[0], Length(TString) - Len);ã end;ã Str_Stf.Trunc_Str := TString;ãend; { TruncStr }ãã{**************************************************************}ã{* Pads a string to a specified length with a specified character }ã{**************************************************************}ãfunction Pad_Char(PString : String; Ch : Char; Len : Byte) : String;ãvarã CurrLen : Byte;ãbeginã CurrLen := Min(Length(PString), Len);ã PString[0] := Chr(Len);ã FillChar(PString[Succ(CurrLen)], Len - CurrLen, Ch);ã Pad_Char := PString;ãend; { PadChar }ãã{**************************************************************}ã{* Left-justify a string within a certain width *}ã{**************************************************************}ãfunction Left_Justify_Str(S : String; Width : Byte) : String;ãbeginã Left_Justify_Str := Str_Stf.Pad_Char(S, ' ', Width);ãend; { Left_Justify_Str }ãã{**************************************************************}ã{* Trim removes leading/trailing blanks. *}ã{* *}ã{**************************************************************}ãFUNCTION TRIM (Str : string) : string;ãVARã i : integer;ãBEGINã i := 1;ã WHILE ((i < LENGTH(Str)) and (Str[i] = ' '))ã DO INC(i);ãã IF (i > 1) THENã BEGINã {Str := COPY (Str, i, Length(Str));}ã Move (Str[i], Str[1], Succ(LENGTH(Str))-i);ã DEC (Str[0], pred(i));ã END;ãã WHILE (Str[LENGTH(str)] = ' ')ã DO DEC (Str[0]);ãã Trim := Str;ãEND; {trim}ãã{**************************************************************}ã{* Trim_Lead removes leading blanks. *}ã{* *}ã{**************************************************************}ãFUNCTION TRIM_Leading_Only (Str : string) : string;ãVARã i : integer;ãBEGINã i := 1;ã WHILE ((i < LENGTH(Str)) and (Str[i] = ' '))ã DO INC(i);ãã IF (i > 1) THENã BEGINã {Str := COPY (Str, i, Length(Str));}ã Move (Str[i], Str[1], Succ(LENGTH(Str))-i);ã DEC (Str[0], pred(i));ã END;ãã Trim_Leading_Only := Str;ãEND; {trim_leading_Only}ãã{***************************************************************}ãFUNCTION TRIM_Trailing_Only (Str : string) : string;ãBEGINã WHILE (Str[LENGTH(str)] = ' ')ã DO DEC (Str[0]);ãã Trim_Trailing_Only := Str;ãEND; {trim}ãã{***************************************************************}ã{*------------------------------------------------------*}ã{* Trim off any lead/trail quotes! *}ã{*------------------------------------------------------*}ãFUNCTION TRIM_Quotes (Str : string) : string;ãbeginã IF ((LENGTH(Str) > 0) and (Str[1] = '"')) THENã BEGINã Move (Str[2], Str[1], pred(LENGTH(Str)));ã DEC (Str[0]);ã IF (Str[LENGTH(Str)] = '"')ã THEN DEC(Str[0]);ã END; {if}ãTrim_Quotes := Str;ãend; {Trim_Quotes}ãã{***************************************************************}ã{* Right_Justify adds leading blanks. *}ã{* NOTE: does not handle cases when *}ã{* Size_To_Be < ACTUAL NUMBER OF CHARACTERS *}ã{***************************************************************}ãFUNCTION Right_Justify (Str : string; Size_To_Be : integer) : string;ãVARã Temp_Str : string;ãBEGINã Temp_Str := TRIM (Str); {to assure proper length--and NON-BLANK}ã Right_Justify := Str_Stf.Left_Justify_Strã ('', Size_To_Be - Length(Str)) + Str;ãã{ WHILE ((LENGTH(Temp_Str) > 0) ANDã ( (Size_To_Be > LENGTH (Temp_Str)) ORã (Temp_Str[Size_To_Be] = ' ') ) )ã DO Temp_Str := ' '+ COPY (Temp_Str, 1, Size_To_Be-1);ã Right_Justify := Temp_Str;}ããEND; {right_justify}ãã{***************************************************************}ã{* Center_Str centers the characters in the string based *}ã{* upon the size/midpoint specified. *}ã{***************************************************************}ãFUNCTION Center_Str (Str : string; Output_Size : integer) : string;ãVARã Ret_Str : string;ã Size : integer;ãBEGINã { blank out returning string}ã Ret_Str := Str_Stf.Fill_String(Output_Size, ' ');ã {FillChar (Ret_Str, output_size, ' ');ã Ret_Str[0] := chr(Output_Size);}ãã Str := TRIM (Str);ã Size := LENGTH (Str);ã IF (Output_Size <= Size)ã THEN Ret_Str := Strã ELSEã BEGINã Insert (Str, Ret_Str, (((Output_Size - Size) div 2)+1));ã Ret_Str := COPY (Ret_Str, 1, OutPut_Size);ã END;ã Center_Str := Ret_Str;ãEND; {center_str}ãã{**************************************************************}ã{* Change_Case changes the case of the string to UPPER. *}ã{* *}ã{**************************************************************}ãFUNCTION Change_Case (Str : string) : string;ãvarã i : integer;ãBEGINã for i := 1 to LENGTH (Str)ã do Str[i] := UpCase(Str[i]);ã Change_Case := Str;ãEND; {change_case}ãã{**************************************************************}ãFUNCTION Lower_Case (Str : string) : string;ãvarã i : integer;ãBEGINã for i := 1 to LENGTH (Str)ã do IF ((ORD (Str[i]) >= 65) and (ORD(Str[i]) <= 90))ã THEN Str[i] := CHR(ORD(Str[i])+32);ã Lower_Case := Str;ãEND; {lower_case}ãã{**************************************************************}ã{* Int_To_Str returns the number converted into ascii chars. *}ã{* *}ã{**************************************************************}ãFUNCTION Int_To_Str (Num : LongInt) : string;ãvarã Temp_Str : string;ãBEGINã STR(Num, Temp_Str);ã Int_To_Str := Temp_Str;ãEND; {int_to_str}ããFUNCTION Int_To_Str_Zero_Fill (Num : LongInt; Fill : byte) : string;ãvarã Temp_Str : string;ã Len : byte;ãBEGINã STR(Num, Temp_Str);ã Len := LENGTH(Temp_Str);ã IF (Len < Fill)ã THEN Temp_Str := Fill_String(Fill-Len, '0')+Temp_Str;ã Int_To_Str_Zero_Fill := Temp_Str;ãEND; {int_to_str_zero_fill}ããFUNCTION Int_Num_Digits (Num : LongInt) : integer;ãvarã Tens, Digits : Integer;ãBEGINã IF (Num = 0)ã THEN Int_Num_Digits := 1ã ELSEã BEGINã Tens := 1;ã Digits := 1;ã WHILE ((Num DIV Tens) <> 0) DOã BEGINã INC (Digits);ã Tens := Tens * 10;ã END; {while}ãã IF (Digits > 1)ã THEN DEC (Digits);ã Int_Num_Digits := Digits;ã END; {if}ããEND; {int_num_digits}ãã{**************************************************************}ã{* Pos_Reverse returns the last occurance of the string *}ã{* just before the specified start pos! *}ã{**************************************************************}ãFUNCTION Pos_Reverse (Str : string;ã Delimiter : string;ã Start_At : integer) : integer;ãVARã Temp_Str : string;ã Found_Pos, Found_Pos_0 : integer;ãBEGINã Temp_Str := COPY(Str, 1, Start_At); {dont use move since ?start_at 0) THENã BEGINã Found_Pos_0 := Found_Pos_0+Found_Pos;ã {Temp_Str := COPY(Temp_Str, Found_Pos+1, LENGTH(Temp_Str));}ã Move (Temp_Str[Found_Pos+1], Temp_Str[1], LENGTH(Str)-Found_Pos+2);ã DEC (Temp_Str[0], Found_Pos);ã END;ã UNTIL (Found_Pos = 0);ã Pos_Reverse := Found_Pos_0;ãEND; {pos_reverse}ãã{**************************************************************}ã{* Find_Char returns the position of the char *}ã{* *}ã{**************************************************************}ãFUNCTION Find_Char (Str : string;ã Char_Is : char;ã Start_At : integer) : INTEGER;ãVARã Loc : integer;ãBEGINã Loc := POS (Char_Is, COPY(Str, Start_At, LENGTH(STR)));ã IF (Loc <> 0)ã THEN Loc := Loc + Start_At -1;ã Find_Char := Loc;ãEND; {function Find_Char}ãã{**************************************************************}ã{* Delete_The_Char delete all occurances of the char *}ã{* *}ã{**************************************************************}ãFUNCTION Delete_The_Char (Str : string;ã Char_Is : char) : string;ãVARã Loc : integer;ãBEGINã Loc := 0;ã REPEATã Loc := POS (Char_Is, Str);ã IF (Loc <> 0) THENã BEGINã {DELETE (Str, Loc, 1);}ã Move(Str[Succ(Loc)], Str[Loc], Length(Str)-Loc);ã Dec(Str[0]);ã END;ã UNTIL (Loc = 0);ãã Delete_The_Char := STR;ãEND; {function Delete_The_Char}ãã{**************************************************************}ã{* Replace_Str_Into inserts the small string into the *}ã{* org_str at the position specified *}ã{**************************************************************}ãFUNCTION Replace_Str_Into (Org_Str : String;ã Small_Str : string;ã Start, Stop : integer) : string;ãvarã Temp_Small_Str : string;ãbeginã IF (Start = 0)ã THEN Start := 1;ãã IF (LENGTH(Small_Str) >= (Stop-Start+1))ã THEN Temp_Small_Str := Small_Strã ELSE Temp_Small_Str := Small_Str +ã Fill_String ( (Stop-Start+1-LENGTH(Small_Str)), ' ');ã IF (Start > 1)ã THEN Replace_Str_Into := Copy (Org_Str, 1, (Start -1)) +ã Copy (Temp_Small_Str, 1, (Stop-Start+1))+ã Copy (Org_Str, (Stop+1) , LENGTH(Org_Str))ã ELSE Replace_Str_Into := Copy (Temp_Small_Str, 1, (Stop-Start+1)) +ã Copy (Org_Str, Stop+1, LENGTH(Org_Str));ãend; {Replace_Str_into}ãã{**************************************************************}ã{* procedure Get_Word_Around_Position *}ã{* returns the word based AROUND the position specified *}ã{* Searches for blanks around the start_pos *}ã{* looking left then right. *}ã{**************************************************************}ãfunction Get_Word_Around_Positionã (Str : string;ã Start_Pos : integer;ã Leftmost_Char_Boundry : integer;ã Rightmost_Char_Boundry : integer;ã VAR Found_Left_Pos : integer;ã VAR Found_Word_Size : integer) : string;ãvarã adjust : integer;ããbeginã IF ((Start_Pos <= LENGTH(Str))) THENã BEGINã Get_Word_Around_Position := Str[Start_Pos];ã Found_Left_Pos := Start_Pos;ã Found_Word_Size := 1;ã ENDãã ELSE {* Bad Params! *}ã BEGINã Get_Word_Around_Position := ' ';ã Found_Left_Pos := 0;ã Found_Word_Size := 0;ã Exit;ã END;ãã if (Str[Start_Pos] <> ' ') thenã beginã {************************************************}ã {* FIRST: find left-most position *}ã {************************************************}ã adjust := Start_Pos -1;ã while ((adjust >= leftmost_char_boundry) andã (Str[adjust] <> ' '))ã do adjust := adjust - 1;ã if ((adjust = leftmost_char_boundry) and (Str[adjust] <> ' '))ã then Found_Left_Pos := adjustã else Found_Left_Pos := adjust +1;ãã {************************************************}ã {* find right-most position *}ã {************************************************}ã adjust := Start_Pos +1;ã while ((adjust <= Rightmost_Char_Boundry) andã (Str[adjust] <> ' '))ã do adjust := adjust + 1;ãã if ((adjust = Rightmost_char_boundry) and (Str[adjust] <> ' '))ã then Found_Word_Size := adjust - Found_Left_Pos +1ã else Found_Word_Size := adjust - Found_Left_Pos;ãã Get_Word_Around_Position := Copy (Str, Found_Left_Pos, Found_Word_Size);ãã end; {if}ããend; {get_word_around_position}ãã{**************************************************************}ã{* returns a string with duplicate chars deleted. *}ã{**************************************************************}ãfunction Delete_Duplicate_Chars_In_Str (Str : string;ã Limit_In_A_Row : byte) : string;ãvarã Curr_Pos : integer;ã i : integer;ã Same_Chars : boolean;ãbeginãã IF (Limit_In_A_Row = 1) THEN {* must catch or infinite loop *}ã BEGINã Delete_Duplicate_Chars_In_Str := '';ã exit;ã END;ãã Curr_Pos := 1;ã WHILE ((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) DOã BEGINãã {*---------------------------------------*}ã {* Quickly look for at least 2 in a row! *}ã {*---------------------------------------*}ã WHILE (((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) ANDã (Str[Curr_Pos] <> Str[Succ(Curr_Pos)]))ã DO INC(Curr_Pos);ãã IF ((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) THENã BEGINã i := Curr_Pos+1;ã Same_Chars := TRUE;ã WHILE ((Same_Chars) and (i <= (Curr_Pos+Limit_In_A_Row-1)))ã DO IF (Str[Curr_Pos] <> Str[i])ã THEN Same_Chars := FALSEã ELSE INC(i);ãã IF (Same_Chars) THENã BEGINã Move(Str[Curr_Pos+Limit_In_A_Row-1], Str[Curr_Pos],ã Length(Str)-(Curr_Pos+Limit_In_A_Row-2));ã Dec(Str[0],Pred(Limit_In_A_Row));ã ENDã ELSE Inc(Curr_Pos);ã END; {if}ã END; {while}ãã Delete_Duplicate_Chars_In_Str := Str;ãend; {delete_duplicate_chars_in_str}ãã{*ã Note that "Count" is the number of *WORDS* to fill. So e.g. you'dãuse "FillWord(My_Int_Array, SizeOf(My_Int_Array) DIV 2, 1);"ã by Neil Rubenking *}ã{**************************************************************}ãPROCEDURE FillWord(VAR Dest; Count, What : Word); Assembler;ã ASMã LES DI, Dest {ES:DI points to destination}ã MOV CX, Count {count in CX}ã MOV AX, What {word to fill with in AX}ã CLD {forward direction}ã REP STOSW {perform the fill}ã END; {fillWord}ããEND. {unit str_stf}}