home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
basic
/
library
/
tb
/
tbsuplow
/
tbsuplow.bas
< prev
next >
Wrap
BASIC Source File
|
1988-12-18
|
10KB
|
297 lines
'PROGRAM TBSUPLOW.EXE (C) 1988 J. CODY
'TURBO BASIC SOURCE UPPER/LOWER CASE CONVERSION
'───────────────────────────────────────────────────────────────────────
$STACK 1536
$COM1 0
$COM2 0
$SOUND 0
CLEAR
DEFINT a-z
KEY OFF
ON ERROR GOTO Errtrap
%False=0
%True=1
$DYNAMIC
DIM Vrw2$(50),Vrw3$(100),Vrw4$(200),Vrw5$(200),Vrw6$(200)
DIM Vrw7$(200),Vrw8$(100),Vrw9$(100),Vrw10$(50),Vrw11$(50)
DIM Vrw12$(50)
$STATIC
Vrw2$(0)=" ": Vrw3$(0)=" ": Vrw4$(0)=" ": Vrw5$(0)=" ": Vrw6$(0)=" "
Vrw7$(0)=" ": Vrw8$(0)=" ": Vrw9$(0)=" ": Vrw10$(0)=" "
Vrw11$(0)=" ": Vrw12$(0)=" "
Wchar$="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
Wsfxc$="%!$"
R2prfx$(1)="FN"
R2prfx$(2)="&B"
R2prfx$(3)="&H"
R2prfx$(4)="&O"
R2prfx$(5)="&Q"
Dq$=CHR$(34)
Tbasspec$="TBRWORDS.DAT"
Ipbaspec$=FNGETCMD$
Opbaspec$=FNGETCMD$
IF CSRLIN>24 THEN PRINT
PRINT "Turbo Basic Source Upper/Lower Case Conversion, (C) 1988 J. Cody"
PRINT "Turbo Basic is registered trademark of Borland International Inc"
PRINT "Input: ";Ipbaspec$;" Output: ";Opbaspec$
IF LEN(Ipbaspec$)<2 OR LEN(Opbaspec$)<2 THEN
PRINT "RUN COMMAND MISSING IN AND/OR OUT FILESPECS (2 CHAR MIN EACH)"
END
ELSEIF Ipbaspec$=Opbaspec$ THEN
PRINT "IN AND OUT FILESPECS ARE IDENTICAL - MUST DIFFER"
END
ELSEIF NOT FNEXIST%(Ipbaspec$) THEN
PRINT "INPUT FILE ";Ipbaspec$;" NOT FOUND"
END
ELSEIF NOT FNEXIST%(Tbasspec$) THEN
Tbasspec$="\"+Tbasspec$
IF NOT FNEXIST%(Tbasspec$) THEN
Tbasspec$=RIGHT$(Tbasspec$,LEN(Tbasspec$)-1)
PRINT "RESERVED WORD FILE ";Tbasspec$;" NOT IN CURRENT OR ROOT DIRECTORY"
END
END IF
ELSEIF FNEXIST%(Opbaspec$) THEN
KILL Opbaspec$
PRINT "Output File ";Opbaspec$;" Replaces Existing File"
END IF
OPEN Tbasspec$ FOR INPUT AS #1
PRINT "Reserved Words Loaded: ";
WHILE NOT EOF(1)
LINE INPUT #1,Tl$
Tl$=UCASE$(Tl$)
Tleng=LEN(Tl$)
IF Tleng>12 OR Tleng<2 THEN
PRINT
PRINT "INVALID RECORD SIZE FOUND IN ";Tbasspec$
PRINT "INVALID RECORD = ";Tl$
END
END IF
SELECT CASE Tleng
CASE 2
INCR Rw2:Vrw2$(Rw2)=Tl$
CASE 3
INCR Rw3:Vrw3$(Rw3)=Tl$
CASE 4
INCR Rw4:Vrw4$(Rw4)=Tl$
CASE 5
INCR Rw5:Vrw5$(Rw5)=Tl$
CASE 6
INCR Rw6:Vrw6$(Rw6)=Tl$
CASE 7
INCR Rw7:Vrw7$(Rw7)=Tl$
CASE 8
INCR Rw8:Vrw8$(Rw8)=Tl$
CASE 9
INCR Rw9:Vrw9$(Rw9)=Tl$
CASE 10
INCR Rw10:Vrw10$(Rw10)=Tl$
CASE 11
INCR Rw11:Vrw11$(Rw11)=Tl$
CASE 12
INCR Rw12:Vrw12$(Rw12)=Tl$
END SELECT
LOCATE CSRLIN,24,0
INCR Rscount
PRINT Rscount;
WEND
PRINT
CLOSE #1
'───────────────────────────────────────────────────────────────────────
OPEN Ipbaspec$ FOR INPUT AS #1
ON ERROR GOTO Outspecerr
OPEN Opbaspec$ FOR OUTPUT AS #2
ON ERROR GOTO Errtrap
PRINT "Input Data Characters Read: ";
WHILE NOT EOF(1)
LINE INPUT #1,Tl$
Xl$="": Z1=0: Wstr$="": Wlen=0 :Prfx=%False: Cmnt=%False: Quot=%False
Tleng=LEN(Tl$)
Inpcount&=Inpcount&+Tleng+2
LOCATE CSRLIN,29,0
PRINT Inpcount&;
WHILE Z1<Tleng
INCR Z1
c$=MID$(Tl$,Z1,1)
IF c$="'" AND Quot=%False THEN Cmnt=%True: GOSUB Atdelim
IF c$=Dq$ AND Cmnt=%False THEN Quot=Quot XOR 1: GOSUB Atdelim
IF Cmnt=%False AND Quot=%False THEN
IF (c$="$" OR c$="&" OR UCASE$(c$)="F") AND Wlen=0 THEN
GOSUB Wordadder
Prfx=%True
ELSEIF INSTR(1,Wchar$,UCASE$(c$))>0 THEN
GOSUB Wordadder
ELSEIF (c$="$" OR c$="#") AND Wlen>0 THEN
GOSUB Wordadder
ELSE
GOSUB Atdelim
END IF
END IF
Xl$=Xl$+c$
WEND
c$=" "
GOSUB Atdelim
Outcount&=Outcount&+LEN(Xl$)+2
IF Inpcount&<>Outcount& THEN
PRINT
PRINT "INPUT/OUTPUT COUNTS UNEQUAL"
END
END IF
PRINT #2,Xl$
WEND
CLOSE #1
CLOSE #2
PRINT
PRINT "Output Data Characters Written: ";Outcount&
END
'───────────────────────────────────────────────────────────────────────
Wordadder:
Wstr$=Wstr$+UCASE$(c$)
Wlen=LEN(Wstr$)
RETURN
Atdelim:
Wdone=%False
IF Cmnt=%True THEN
GOSUB Resetword
ELSEIF c$=Dq$ AND Quot=%False THEN
GOSUB Resetword
ELSEIF Wlen<2 THEN
IF Wlen=1 THEN
Xl$=LEFT$(Xl$,LEN(Xl$)-1)+LCASE$(RIGHT$(Xl$,1))
GOSUB Resetword
ELSE
GOSUB Resetword
RETURN
END IF
ELSEIF Prfx=%True AND LEFT$(Wstr$,1)="$" THEN
GOSUB Istbword
ELSEIF Prfx=%True AND (LEFT$(Wstr$,1)="&" OR LEFT$(Wstr$,1)="F") THEN
FOR v=1 TO 5
IF R2prfx$(v)=LEFT$(Wstr$,2) THEN
GOSUB Istbword
END IF
NEXT v
END IF
IF Wdone=%False AND Wlen<13 AND Wlen>1 THEN
SELECT CASE Wlen
CASE 2
FOR v=0 TO Rw2:IF Wstr$=Vrw2$(v) THEN GOSUB Istbword
NEXT v
CASE 3
FOR v=0 TO Rw3:IF Wstr$=Vrw3$(v) THEN GOSUB Istbword
NEXT v
CASE 4
FOR v=0 TO Rw4:IF Wstr$=Vrw4$(v) THEN GOSUB Istbword
NEXT v
CASE 5
FOR v=0 TO Rw5:IF Wstr$=Vrw5$(v) THEN GOSUB Istbword
NEXT v
CASE 6
FOR v=0 TO Rw6:IF Wstr$=Vrw6$(v) THEN GOSUB Istbword
NEXT v
CASE 7
FOR v=0 TO Rw7:IF Wstr$=Vrw7$(v) THEN GOSUB Istbword
NEXT v
CASE 8
FOR v=0 TO Rw8:IF Wstr$=Vrw8$(v) THEN GOSUB Istbword
NEXT v
CASE 9
FOR v=0 TO Rw9:IF Wstr$=Vrw9$(v) THEN GOSUB Istbword
NEXT v
CASE 10
FOR v=0 TO Rw10:IF Wstr$=Vrw10$(v) THEN GOSUB Istbword
NEXT v
CASE 11
FOR v=0 TO Rw11:IF Wstr$=Vrw11$(v) THEN GOSUB Istbword
NEXT v
CASE 12
FOR v=0 TO Rw12:IF Wstr$=Vrw12$(v) THEN GOSUB Istbword
NEXT v
END SELECT
END IF
IF Wdone=%False THEN
IF Wlen=2 AND INSTR(1,Wsfxc$,RIGHT$(Xl$,1)) THEN
Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+LCASE$(RIGHT$(Xl$,Wlen))
ELSEIF Wlen>0 THEN
Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+UCASE$(RIGHT$(Xl$,Wlen))
IF Wlen>1 THEN DECR Wlen
Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+LCASE$(RIGHT$(Xl$,Wlen))
END IF
END IF
GOSUB Resetword
RETURN
Resetword:
Wdone=%True: Wlen=0: Wstr$="": Prfx=%False
RETURN
Istbword:
Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+UCASE$(RIGHT$(Xl$,Wlen))
GOSUB Resetword
RETURN
'───────────────────────────────────────────────────────────────────────
'TEST FOR FILE EXISTENCE
DEF FNEXIST%(Filename$)
'usage:
' IF FNEXIST(filename$) THEN ...
'description:
' returns logical true[-1]/false[0]
' requires NO error handling with TurboBasic
LOCAL Test$,Result%
Test$=Filename$+CHR$(0) ' make it an ASCIIZ string
CALL Exist(Result%,Test$)
FNEXIST%=Result%
END DEF
SUB Exist INLINE
$INLINE &H55 ' PUSH BP ;save bp
$INLINE &H89,&HE5 ' MOV BP,SP ;
$INLINE &H06 ' PUSH ES ;save es because we'll use it
$INLINE &H1E ' PUSH DS ;ditto
$INLINE &HC4,&H7E,&H06 ' LES DI,[BP + 6H] ;load pointer to string descriptor
$INLINE &H3E ' SEG DS ;
$INLINE &H8B,&H16,&H00,&H00 ' MOV DX,[0] ;get the beginning of the strinng
$INLINE &H52 ' PUSH DX ;
$INLINE &H1F ' POP DS ;make ds point to string segment
$INLINE &H26 ' SEG ES ;
$INLINE &H8B,&H55,&H02 ' MOV DX,[DI + 2] ;get offset into string segment
$INLINE &H31,&HC9 ' XOR CX,CX ;zero cx
$INLINE &H49 ' DEC CX ;set result% flag to true=-1/0ffffH
$INLINE &HB8,&H00,&H3D ' MOV AX,3D00H ;open file - read only
$INLINE &HCD,&H21 ' INT 21H ;execute
$INLINE &H72,&H08 ' JC NO ;jump if error
$INLINE &H89,&HC3 ' MOV BX,AX ;move file handle to BX
$INLINE &HB4,&H3E ' MOV AH,3EH ;close file
$INLINE &HCD,&H21 ' INT 21H ;execute
$INLINE &HEB,&H01 ' JMPS EXIT ;jump to exit point
' NO ; ;
$INLINE &H41 ' INC CX ;set result% flag to false=0
' EXIT ; ;
$INLINE &HC5,&H7E,&H0A ' LDS DI,[BP+0AH] ;get the address of the integer
$INLINE &H3E ' SEG DS ;
$INLINE &H89,&H0D ' MOV [DI],CX ;move the result% to integer
$INLINE &H1F ' POP DS ;pop and
$INLINE &H07 ' POP ES ; restore all
$INLINE &H5D ' POP BP ; the registers saved
END SUB
'───────────────────────────────────────────────────────────────────────
DEF FNGETCMD$
'Get the command line parameter
STATIC Cmdi%
LOCAL Cmdline$,Cmdchar$,Cmdword%
Cmdline$="" : Cmdword%=0
IF Cmdi%=0 THEN INCR Cmdi%
DO
Cmdchar$=MID$(COMMAND$,Cmdi%,1)
IF Cmdchar$<>" " THEN
Cmdline$=Cmdline$+Cmdchar$ : Cmdword%=1
END IF
INCR Cmdi%
LOOP UNTIL Cmdchar$="" OR (Cmdword%=1 AND Cmdchar$=" ")
FNGETCMD$=Cmdline$
END DEF
'───────────────────────────────────────────────────────────────────────
Outspecerr:
PRINT "ERROR OPENING OUTPUT FILESPEC ";Opbaspec$
END
Errtrap:
PRINT
PRINT "ERROR CODE ";ERR;" AT ADDRESS ";ERADR
END