home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / tb / tbsuplow / tbsuplow.bas < prev    next >
Encoding:
BASIC Source File  |  1988-12-18  |  9.4 KB  |  297 lines
  1. 'PROGRAM TBSUPLOW.EXE (C) 1988 J. CODY
  2. 'TURBO BASIC SOURCE UPPER/LOWER CASE CONVERSION
  3. '───────────────────────────────────────────────────────────────────────
  4.  $STACK 1536
  5.  $COM1 0
  6.  $COM2 0
  7.  $SOUND 0
  8.  CLEAR
  9.  DEFINT a-z
  10.  KEY OFF
  11.  ON ERROR GOTO Errtrap
  12.  %False=0
  13.  %True=1
  14.  $DYNAMIC
  15.  DIM Vrw2$(50),Vrw3$(100),Vrw4$(200),Vrw5$(200),Vrw6$(200)
  16.  DIM Vrw7$(200),Vrw8$(100),Vrw9$(100),Vrw10$(50),Vrw11$(50)
  17.  DIM Vrw12$(50)
  18.  $STATIC
  19.  Vrw2$(0)=" ": Vrw3$(0)=" ": Vrw4$(0)=" ": Vrw5$(0)=" ": Vrw6$(0)=" "
  20.  Vrw7$(0)=" ": Vrw8$(0)=" ": Vrw9$(0)=" ": Vrw10$(0)=" "
  21.  Vrw11$(0)=" ": Vrw12$(0)=" "
  22.  Wchar$="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
  23.  Wsfxc$="%&#!$"
  24.  R2prfx$(1)="FN"
  25.  R2prfx$(2)="&B"
  26.  R2prfx$(3)="&H"
  27.  R2prfx$(4)="&O"
  28.  R2prfx$(5)="&Q"
  29.  Dq$=CHR$(34)
  30.  Tbasspec$="TBRWORDS.DAT"
  31.  Ipbaspec$=FNGETCMD$
  32.  Opbaspec$=FNGETCMD$
  33.  IF CSRLIN>24 THEN PRINT
  34.  PRINT "Turbo Basic Source Upper/Lower Case Conversion, (C) 1988 J. Cody"
  35.  PRINT "Turbo Basic is registered trademark of Borland International Inc"
  36.  PRINT "Input:  ";Ipbaspec$;"    Output:  ";Opbaspec$
  37.  IF LEN(Ipbaspec$)<2 OR LEN(Opbaspec$)<2 THEN
  38.     PRINT "RUN COMMAND MISSING IN AND/OR OUT FILESPECS (2 CHAR MIN EACH)"
  39.     END
  40.  ELSEIF Ipbaspec$=Opbaspec$ THEN
  41.     PRINT "IN AND OUT FILESPECS ARE IDENTICAL - MUST DIFFER"
  42.     END
  43.  ELSEIF NOT FNEXIST%(Ipbaspec$) THEN
  44.     PRINT "INPUT FILE ";Ipbaspec$;" NOT FOUND"
  45.     END
  46.  ELSEIF NOT FNEXIST%(Tbasspec$) THEN
  47.     Tbasspec$="\"+Tbasspec$
  48.     IF NOT FNEXIST%(Tbasspec$) THEN
  49.        Tbasspec$=RIGHT$(Tbasspec$,LEN(Tbasspec$)-1)
  50.        PRINT "RESERVED WORD FILE ";Tbasspec$;" NOT IN CURRENT OR ROOT DIRECTORY"
  51.        END
  52.     END IF
  53.   ELSEIF FNEXIST%(Opbaspec$) THEN
  54.     KILL Opbaspec$
  55.     PRINT "Output File ";Opbaspec$;" Replaces Existing File"
  56.  END IF
  57.  OPEN Tbasspec$ FOR INPUT AS #1
  58.     PRINT "Reserved Words Loaded: ";
  59.  WHILE NOT EOF(1)
  60.     LINE INPUT #1,Tl$
  61.     Tl$=UCASE$(Tl$)
  62.     Tleng=LEN(Tl$)
  63.     IF Tleng>12 OR Tleng<2 THEN
  64.        PRINT
  65.        PRINT "INVALID RECORD SIZE FOUND IN ";Tbasspec$
  66.        PRINT "INVALID RECORD = ";Tl$
  67.        END
  68.     END IF
  69.      SELECT CASE Tleng
  70.       CASE 2
  71.         INCR Rw2:Vrw2$(Rw2)=Tl$
  72.       CASE 3
  73.         INCR Rw3:Vrw3$(Rw3)=Tl$
  74.       CASE 4
  75.         INCR Rw4:Vrw4$(Rw4)=Tl$
  76.       CASE 5
  77.         INCR Rw5:Vrw5$(Rw5)=Tl$
  78.       CASE 6
  79.         INCR Rw6:Vrw6$(Rw6)=Tl$
  80.       CASE 7
  81.         INCR Rw7:Vrw7$(Rw7)=Tl$
  82.       CASE 8
  83.         INCR Rw8:Vrw8$(Rw8)=Tl$
  84.       CASE 9
  85.         INCR Rw9:Vrw9$(Rw9)=Tl$
  86.       CASE 10
  87.         INCR Rw10:Vrw10$(Rw10)=Tl$
  88.       CASE 11
  89.         INCR Rw11:Vrw11$(Rw11)=Tl$
  90.       CASE 12
  91.         INCR Rw12:Vrw12$(Rw12)=Tl$
  92.     END SELECT
  93.     LOCATE CSRLIN,24,0
  94.     INCR Rscount
  95.     PRINT Rscount;
  96.  WEND
  97.  PRINT
  98.  CLOSE #1
  99. '───────────────────────────────────────────────────────────────────────
  100.  OPEN Ipbaspec$ FOR INPUT AS #1
  101.  ON ERROR GOTO Outspecerr
  102.  OPEN Opbaspec$ FOR OUTPUT AS #2
  103.  ON ERROR GOTO Errtrap
  104.  PRINT "Input Data Characters Read: ";
  105.  WHILE NOT EOF(1)
  106.     LINE INPUT #1,Tl$
  107.     Xl$="": Z1=0: Wstr$="": Wlen=0 :Prfx=%False: Cmnt=%False: Quot=%False
  108.     Tleng=LEN(Tl$)
  109.     Inpcount&=Inpcount&+Tleng+2
  110.     LOCATE CSRLIN,29,0
  111.     PRINT Inpcount&;
  112.     WHILE Z1<Tleng
  113.        INCR Z1
  114.        c$=MID$(Tl$,Z1,1)
  115.        IF c$="'" AND Quot=%False THEN Cmnt=%True: GOSUB Atdelim
  116.        IF c$=Dq$ AND Cmnt=%False THEN Quot=Quot XOR 1: GOSUB Atdelim
  117.        IF Cmnt=%False AND Quot=%False THEN
  118.           IF (c$="$" OR c$="&" OR UCASE$(c$)="F") AND Wlen=0 THEN
  119.              GOSUB Wordadder
  120.              Prfx=%True
  121.           ELSEIF INSTR(1,Wchar$,UCASE$(c$))>0 THEN
  122.              GOSUB Wordadder
  123.           ELSEIF (c$="$" OR c$="#") AND Wlen>0 THEN
  124.              GOSUB Wordadder
  125.           ELSE
  126.              GOSUB Atdelim
  127.           END IF
  128.        END IF
  129.        Xl$=Xl$+c$
  130.     WEND
  131.     c$=" "
  132.     GOSUB Atdelim
  133.     Outcount&=Outcount&+LEN(Xl$)+2
  134.     IF Inpcount&<>Outcount& THEN
  135.        PRINT
  136.        PRINT "INPUT/OUTPUT COUNTS UNEQUAL"
  137.        END
  138.     END IF
  139.     PRINT #2,Xl$
  140.  WEND
  141.  CLOSE #1
  142.  CLOSE #2
  143.  PRINT
  144.  PRINT "Output Data Characters Written: ";Outcount&
  145.  END
  146. '───────────────────────────────────────────────────────────────────────
  147. Wordadder:
  148.  Wstr$=Wstr$+UCASE$(c$)
  149.  Wlen=LEN(Wstr$)  
  150.  RETURN
  151. Atdelim:
  152.  Wdone=%False
  153.  IF Cmnt=%True THEN
  154.     GOSUB Resetword
  155.  ELSEIF c$=Dq$ AND Quot=%False THEN
  156.     GOSUB Resetword
  157.  ELSEIF Wlen<2 THEN 
  158.     IF Wlen=1 THEN
  159.        Xl$=LEFT$(Xl$,LEN(Xl$)-1)+LCASE$(RIGHT$(Xl$,1))
  160.        GOSUB Resetword
  161.     ELSE
  162.        GOSUB Resetword
  163.        RETURN
  164.     END IF
  165.  ELSEIF Prfx=%True AND LEFT$(Wstr$,1)="$" THEN
  166.     GOSUB Istbword
  167.  ELSEIF Prfx=%True AND (LEFT$(Wstr$,1)="&" OR LEFT$(Wstr$,1)="F") THEN
  168.     FOR v=1 TO 5
  169.       IF R2prfx$(v)=LEFT$(Wstr$,2) THEN
  170.          GOSUB Istbword
  171.       END IF
  172.     NEXT v
  173.  END IF
  174.  IF Wdone=%False AND Wlen<13 AND Wlen>1 THEN
  175.     SELECT CASE Wlen
  176.       CASE 2
  177.         FOR v=0 TO Rw2:IF Wstr$=Vrw2$(v) THEN GOSUB Istbword
  178.           NEXT v
  179.       CASE 3
  180.         FOR v=0 TO Rw3:IF Wstr$=Vrw3$(v) THEN GOSUB Istbword
  181.           NEXT v
  182.       CASE 4
  183.         FOR v=0 TO Rw4:IF Wstr$=Vrw4$(v) THEN GOSUB Istbword
  184.           NEXT v
  185.       CASE 5
  186.         FOR v=0 TO Rw5:IF Wstr$=Vrw5$(v) THEN GOSUB Istbword
  187.           NEXT v
  188.       CASE 6
  189.         FOR v=0 TO Rw6:IF Wstr$=Vrw6$(v) THEN GOSUB Istbword
  190.           NEXT v
  191.       CASE 7
  192.         FOR v=0 TO Rw7:IF Wstr$=Vrw7$(v) THEN GOSUB Istbword
  193.           NEXT v
  194.       CASE 8
  195.         FOR v=0 TO Rw8:IF Wstr$=Vrw8$(v) THEN GOSUB Istbword
  196.           NEXT v
  197.       CASE 9
  198.         FOR v=0 TO Rw9:IF Wstr$=Vrw9$(v) THEN GOSUB Istbword
  199.           NEXT v
  200.       CASE 10
  201.         FOR v=0 TO Rw10:IF Wstr$=Vrw10$(v) THEN GOSUB Istbword
  202.           NEXT v
  203.       CASE 11
  204.         FOR v=0 TO Rw11:IF Wstr$=Vrw11$(v) THEN GOSUB Istbword
  205.           NEXT v
  206.       CASE 12
  207.         FOR v=0 TO Rw12:IF Wstr$=Vrw12$(v) THEN GOSUB Istbword
  208.           NEXT v
  209.     END SELECT
  210.  END IF
  211.  IF Wdone=%False THEN
  212.     IF Wlen=2 AND INSTR(1,Wsfxc$,RIGHT$(Xl$,1)) THEN
  213.        Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+LCASE$(RIGHT$(Xl$,Wlen))
  214.     ELSEIF Wlen>0 THEN
  215.        Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+UCASE$(RIGHT$(Xl$,Wlen))
  216.        IF Wlen>1 THEN DECR Wlen
  217.        Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+LCASE$(RIGHT$(Xl$,Wlen))
  218.     END IF
  219.  END IF
  220.  GOSUB Resetword
  221.  RETURN
  222. Resetword:
  223.  Wdone=%True: Wlen=0: Wstr$="": Prfx=%False
  224.  RETURN
  225. Istbword:
  226.  Xl$=LEFT$(Xl$,LEN(Xl$)-Wlen)+UCASE$(RIGHT$(Xl$,Wlen))
  227.  GOSUB Resetword
  228.  RETURN
  229. '───────────────────────────────────────────────────────────────────────
  230. 'TEST FOR FILE EXISTENCE
  231. DEF FNEXIST%(Filename$)
  232. 'usage:
  233. '      IF FNEXIST(filename$) THEN ...
  234. 'description:
  235. '      returns logical true[-1]/false[0]
  236. '      requires NO error handling with TurboBasic
  237. LOCAL Test$,Result%
  238.  Test$=Filename$+CHR$(0) ' make it an ASCIIZ string
  239.  CALL Exist(Result%,Test$)
  240.  FNEXIST%=Result%
  241. END DEF
  242. SUB Exist INLINE
  243. $INLINE &H55                '   PUSH  BP           ;save bp
  244. $INLINE &H89,&HE5           '   MOV   BP,SP        ;
  245. $INLINE &H06                '   PUSH  ES           ;save es because we'll use it
  246. $INLINE &H1E                '   PUSH  DS           ;ditto
  247. $INLINE &HC4,&H7E,&H06      '   LES   DI,[BP + 6H] ;load pointer to string descriptor
  248. $INLINE &H3E                '   SEG   DS           ;
  249. $INLINE &H8B,&H16,&H00,&H00 '   MOV   DX,[0]       ;get the beginning of the strinng
  250. $INLINE &H52                '   PUSH  DX           ;
  251. $INLINE &H1F                '   POP   DS           ;make ds point to string segment
  252. $INLINE &H26                '   SEG   ES           ;
  253. $INLINE &H8B,&H55,&H02      '   MOV   DX,[DI + 2]  ;get offset into string segment
  254. $INLINE &H31,&HC9           '   XOR   CX,CX        ;zero cx
  255. $INLINE &H49                '   DEC   CX           ;set result% flag to true=-1/0ffffH
  256. $INLINE &HB8,&H00,&H3D      '   MOV   AX,3D00H     ;open file - read only
  257. $INLINE &HCD,&H21           '   INT   21H          ;execute
  258. $INLINE &H72,&H08           '   JC    NO           ;jump if error
  259. $INLINE &H89,&HC3           '   MOV   BX,AX        ;move file handle to BX
  260. $INLINE &HB4,&H3E           '   MOV   AH,3EH       ;close file
  261. $INLINE &HCD,&H21           '   INT   21H          ;execute
  262. $INLINE &HEB,&H01           '   JMPS  EXIT         ;jump to exit point
  263.                             ' NO      ;            ;
  264. $INLINE &H41                '   INC   CX           ;set result% flag to false=0
  265.                             ' EXIT    ;            ;
  266. $INLINE &HC5,&H7E,&H0A      '   LDS   DI,[BP+0AH]  ;get the address of the integer
  267. $INLINE &H3E                '   SEG   DS           ;
  268. $INLINE &H89,&H0D           '   MOV   [DI],CX      ;move the result% to integer
  269. $INLINE &H1F                '   POP   DS           ;pop and
  270. $INLINE &H07                '   POP   ES           ; restore all
  271. $INLINE &H5D                '   POP   BP           ;  the registers saved
  272. END SUB
  273. '───────────────────────────────────────────────────────────────────────
  274. DEF FNGETCMD$
  275. 'Get the command line parameter
  276.     STATIC Cmdi%
  277.     LOCAL  Cmdline$,Cmdchar$,Cmdword%
  278.     Cmdline$="" : Cmdword%=0
  279.     IF Cmdi%=0 THEN INCR Cmdi%
  280.    DO
  281.       Cmdchar$=MID$(COMMAND$,Cmdi%,1)
  282.       IF Cmdchar$<>" " THEN
  283.           Cmdline$=Cmdline$+Cmdchar$ : Cmdword%=1
  284.       END IF
  285.       INCR Cmdi%
  286.    LOOP UNTIL Cmdchar$="" OR (Cmdword%=1 AND Cmdchar$=" ")
  287.    FNGETCMD$=Cmdline$
  288. END DEF
  289. '───────────────────────────────────────────────────────────────────────
  290. Outspecerr:
  291.  PRINT "ERROR OPENING OUTPUT FILESPEC ";Opbaspec$
  292.  END
  293. Errtrap:
  294.  PRINT
  295.  PRINT "ERROR CODE ";ERR;" AT ADDRESS ";ERADR
  296.  END
  297.