home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug080.ark / CONV-ASC.STB < prev    next >
Encoding:
Text File  |  1984-04-29  |  7.6 KB  |  232 lines
  1.  
  2.    20   Gosub Screen'erase
  3.    30   @"Basic File Converter"
  4.    40   @"By David E. Trachtenbarg"
  5.    50   @"Copyright 1981"
  6.    60   Integer I,J,K,L,L1,L2,Line
  7.    70   Long Line'no,Number
  8.    80   Line=132
  9.    90   Dim Input'file$(13),Output'file$(13),Tab$(0),Weird$(1)
  10.   100   Dim String1$(100),String2$(100),String$(100),Yn$(3)
  11.   110   Dim New'line$(Line),Old'line$(Line),Temp'line$(Line),Quote'line$(Line)
  12.   120   Weird$=" ;" : Weird$(0,0)=""""
  13.   130   Tab$=Chr$(9)
  14.   140   Set 0,-1
  15.   150   Set 3,0
  16.   155   Esc
  17.   160   Line'no=0
  18.   170   Call .Enter'file (Input'file$)
  19.   180   Call .New'file (Output'file$)
  20.   190   Create Output'file$
  21.   200   Open\1\Input'file$
  22.   210   Open\2\Output'file$
  23.   220   Print\2\""
  24.   240   On Esc Goto Ending
  25.   250     Repeat
  26.   260     Gosub Get'line
  27.   270     Gosub Convert'line
  28.   280     Gosub Put'line
  29.   290     If New'line$<>"" Then @ New'line$
  30.   300     Until Sys(3)>0
  31.   305 *Ending
  32.   306   On Error Stop
  33.   310   Close
  34.   320   @ : @"Done!!!!"
  35.   330   Esc
  36.   350   End
  37.   360 *Screen'erase
  38.   370   Out 1,126 : Out 1,28 : Return
  39.   380 Procedure .Enter'file (Text'file$)
  40.   390     Repeat
  41.   400     Set 3,0
  42.   410     Input"Enter the name of the input file. ",Text'file$
  43.   420     On Error Goto 450
  44.   430     Open\1\Text'file$
  45.   440     Close\1\
  46.   450     On Error Stop
  47.   460     If Sys(3)>0 Then  Do
  48.   470       @ : @"Error ";Sys(3);" has occured."
  49.   480       If Sys(3)=128 Or Sys(3)=134 Then @"File does not exist on disk."
  50.   490       If Sys(3)=129 Then @"Please enter a filename."
  51.   500       If Sys(3)=131 Then Close\1\ : @"File not ready.  Please try again."
  52.   510       Enddo
  53.   520     Until Sys(3)=0
  54.   530   Endproc 
  55.   540 Procedure .New'file (Text'file$)
  56.   550   Set 3,0
  57.   560     Repeat
  58.   570     Input"Enter the name of a NEW file. ",Text'file$
  59.   580     On Error Goto 620
  60.   590     Open\1\Text'file$
  61.   600     Close\1\
  62.   610     @"File already exists.  Please enter a NEW filename."
  63.   620     On Error Stop
  64.   630     Until Sys(3)>0
  65.   640   Endproc 
  66.   650 *Get'line
  67.   660   On Error Goto 700
  68.   670   Input\1\Old'line$(-1)
  69.   690   On Error Stop
  70.   700   Return
  71.   710 *Put'line
  72.   720   If New'line$="" Then Return
  73.   730   Print\2\New'line$
  74.   740   Return
  75.   750 Procedure .Capitalize (New'line$)
  76.   760   Local I
  77.   780     For I=0 To Len(New'line$)
  78.   786     If J=0 Then J=1
  79.   790     If New'line$(I,I)>="a" And New'line$(I,I)<="z" Then  Do
  80.   800       New'line$(I,I)=Chr$(Asc(New'line$(I,I))-32)
  81.   810       Enddo
  82.   815     Next I
  83.   820   Endproc 
  84.   830 *Convert'line
  85.   840   Local I
  86.   850   New'line$(-1)=""
  87.   860   If Len(Old'line$)=0 Then Return
  88.   870   New'line$=Old'line$
  89.   880     For I=1 To 16
  90.   890     On I Gosub 980,990,1000,1010,1020,1030,1040,1050,1060,1070,1080,1090,1091,1092,1093,1094
  91.   900     Call .Replace'all (New'line$,String1$,String2$)
  92.   910     Next I
  93.   930   Gosub Fix'input
  94.   940   Gosub Fix'char'arrays
  95.   950   Gosub Change'left
  96.   960   Gosub Fix'if'then'else
  97.   970   Return
  98.   980   String1$="IF" : String2$=" IF " : Return
  99.   990   String1$="INPUT" : String2$=" INPUT " : Return
  100.  1000   String1$="GOTO" : String2$=" Goto " : Return
  101.  1010   String1$="THEN" : String2$=" THEN " : Return
  102.  1020   String1$="GOSUB" : String2$=" GOSUB " : Return
  103.  1030   String1$="NEXT" : String2$=" NEXT " : Return
  104.  1040   String1$="ELSE" : String2$=" ELSE " : Return
  105.  1050   String1$="STOP" : String2$=" Stop " : Return
  106.  1060   String1$="STEP" : String2$=" STEP " : Return
  107.  1070   String1$="FOR" : String2$=" FOR " : Return
  108.  1080   String1$="PRINT" : String2$=" PRINT " : Return
  109.  1090   String1$="READ" : String2$=" READ " : Return
  110.  1091   String1$="TO" : String2$=" TO " : Return
  111.  1092   String1$="REMARK" : String2$=" REM  " : Return
  112.  1093   String1$="DATA" : String2$=" DATA " : Return
  113.  1094   String1$="DIM" : String2$=" DIM " : Return
  114.  1100 *Change'left
  115.  1110   Local I,J,L
  116.  1120   I=Pos(New'line$,"LEFT$(",0)
  117.  1130   If I>-1 Then  Do
  118.  1140     J=Pos(New'line$,"$",I+5)
  119.  1150     L=Pos(New'line$,")",0)
  120.  1160     String$(-1)=New'line$(I+6,J)+"(0,"+New'line$(J+2,L-1)+"-1)"
  121.  1170     New'line$(I,L)=String$(-1)
  122.  1180     Enddo
  123.  1190   Return
  124.  1200 *Fix'input
  125.  1210   Local I
  126.  1220   If Pos(New'line$,"INPUT",0)>-1 Then  Do
  127.  1230       Repeat
  128.  1240       I=Pos(New'line$,Weird$,0)
  129.  1250       If I>-1 Then  Do
  130.  1260         Expand New'line$(I),1
  131.  1270         New'line$(I,I+2)=" "","
  132.  1280         Enddo
  133.  1290       Until I=-1
  134.  1300     Enddo
  135.  1310   Return
  136.  1370 Procedure .Replace'string (New'line$,String1$,String2$,Start)
  137.  1380   Local I,J
  138.  1390   I=Len(String1$)-1
  139.  1400   J=Len(String2$)-1
  140.  1410   Start=Pos(New'line$,String1$,Start)
  141.  1420   If Start>-1 Then  Do
  142.  1430     If J>I Then  Do
  143.  1440       Expand New'line$(Start),J-I
  144.  1450       New'line$(Start,Start+J)=String2$(0,J)
  145.  1460       Else
  146.  1470       New'line$(Start,Start+I)=String2$(0,I)
  147.  1480       @"CONTRACTED NEW LINE = ";New'line$(Start,Start+I)
  148.  1490       Enddo
  149.  1500     Enddo
  150.  1510   Endproc 
  151.  1520 Procedure .Last'paren (New'line$,I)
  152.  1530   Local J,K,L
  153.  1540   J=Pos(New'line$,"(",I)
  154.  1550   K=J : L=J
  155.  1560     Repeat
  156.  1570     K=Pos(New'line$,")",K+1)
  157.  1580     L=Pos(New'line$,"(",L+1)
  158.  1590     Until L>K Or L=-1
  159.  1600   Endproc (J,K)
  160.  1610 *Fix'char'arrays
  161.  1620   Local I,J,K,L
  162.  1630   I=-1
  163.  1640     Repeat
  164.  1650     I=Pos(New'line$,"$(",I+1)
  165.  1660     If New'line$(I-3,I-1)="MID" Then Goto 1650
  166.  1670     If New'line$(I-4,I-1)="LEFT" Then Goto 1650
  167.  1680     If New'line$(I-5,I-1)="RIGHT" Then Goto 1650
  168.  1690     If New'line$(I-3,I-1)="CHR" Then Goto 1650
  169.  1700     If New'line$(I-3,I-1)="STR" Then Goto 1650
  170.  1710     If I>-1 Then  Do
  171.  1720       @ : @ New'line$
  172.  1730       @ Tab(I);"$"
  173.  1740       Print"Change to CROMEMCO character array (Y/N)?";
  174.  1750       Call .Yes'no (Yn$)
  175.  1760       If Yn$(0,0)="Y" Then  Do
  176.  1770         Call .Last'paren (New'line$,I;J,K)
  177.  1780         String2$="$(("+New'line$(J+1,K-1)+"-1)*40,"+New'line$(J+1,K-1)+"*40-1)"
  178.  1790         String1$=New'line$(I,K)
  179.  1800         Call .Replace'string (New'line$,String1$,String2$,I)
  180.  1810         @ New'line$ : @ : @
  181.  1820         Enddo
  182.  1830       Enddo
  183.  1840     Until I=-1
  184.  1850   Return
  185.  1860 *Fix'if'then'else
  186.  1870   Local I,J
  187.  1880   I=Pos(New'line$,"ELSE",0)
  188.  1890   If I>-1 Then  Do
  189.  1900     @ : @ New'line$
  190.  1910     @ Tab(I);"$"
  191.  1920     Print"Change ELSE to two lines (Y/N)?";
  192.  1926     Call .Yes'no (Yn$)
  193.  1930     If Yn$(0,0)="Y" Then  Do
  194.  1940       Temp'line$=New'line$(I)
  195.  1950       J=Val(New'line$)
  196.  1960       New'line$(I)=" "
  197.  1970       Gosub Put'line
  198.  1980       @ : Input"Enter the conditional part of the statment. ",String$
  199.  1990       New'line$(-1)=Str$(J+1)+"  IF "+String$+" THEN "+Temp'line$(4)
  200.  2000       Enddo
  201.  2010     Enddo
  202.  2020   Return
  203.  2030 Procedure .Replace'all (New'line$,String1$,String2$)
  204.  2040   Local I,K
  205.  2050   I=-1
  206.  2060     Repeat
  207.  2070     I=Pos(New'line$,String1$,I+2)
  208.  2080     If I>-1 Then  Do
  209.  2085       Call .Count'quotes (New'line$,I;K)
  210.  2090       If Fra((1.0*K)/2.0)=0 Then Call .Replace'string (New'line$,String1$,String2$,I)
  211.  2100       Enddo
  212.  2110     Until I=-1
  213.  2120   Endproc 
  214.  2200 Procedure .Yes'no (Yn$)
  215.  2210     Repeat
  216.  2211     Input Yn$
  217.  2222     Call .Capitalize (Yn$)
  218.  2223     If Yn$(0,0)="E" Then Goto Ending
  219.  2230     Until Yn$="Y" Or Yn$="N"
  220.  2240   Endproc 
  221.  2250 Procedure .Count'quotes (New'line$,I)
  222.  2260   Local J,K
  223.  2265   J=-1
  224.  2270     Repeat
  225.  2280     J=Pos(New'line$,Chr$(34),J+1)
  226.  2285     If J>-1 Then  Do
  227.  2287       If J<I Then K=K+1
  228.  2288       Enddo
  229.  2289     Until J=-1 Or J>I
  230.  2290   Endproc (K)
  231.