home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
SIMTEL
/
CPMUG
/
CPMUG080.ARK
/
CONV-ASC.STB
< prev
next >
Wrap
Text File
|
1984-04-29
|
8KB
|
232 lines
20 Gosub Screen'erase
30 @"Basic File Converter"
40 @"By David E. Trachtenbarg"
50 @"Copyright 1981"
60 Integer I,J,K,L,L1,L2,Line
70 Long Line'no,Number
80 Line=132
90 Dim Input'file$(13),Output'file$(13),Tab$(0),Weird$(1)
100 Dim String1$(100),String2$(100),String$(100),Yn$(3)
110 Dim New'line$(Line),Old'line$(Line),Temp'line$(Line),Quote'line$(Line)
120 Weird$=" ;" : Weird$(0,0)=""""
130 Tab$=Chr$(9)
140 Set 0,-1
150 Set 3,0
155 Esc
160 Line'no=0
170 Call .Enter'file (Input'file$)
180 Call .New'file (Output'file$)
190 Create Output'file$
200 Open\1\Input'file$
210 Open\2\Output'file$
220 Print\2\""
240 On Esc Goto Ending
250 Repeat
260 Gosub Get'line
270 Gosub Convert'line
280 Gosub Put'line
290 If New'line$<>"" Then @ New'line$
300 Until Sys(3)>0
305 *Ending
306 On Error Stop
310 Close
320 @ : @"Done!!!!"
330 Esc
350 End
360 *Screen'erase
370 Out 1,126 : Out 1,28 : Return
380 Procedure .Enter'file (Text'file$)
390 Repeat
400 Set 3,0
410 Input"Enter the name of the input file. ",Text'file$
420 On Error Goto 450
430 Open\1\Text'file$
440 Close\1\
450 On Error Stop
460 If Sys(3)>0 Then Do
470 @ : @"Error ";Sys(3);" has occured."
480 If Sys(3)=128 Or Sys(3)=134 Then @"File does not exist on disk."
490 If Sys(3)=129 Then @"Please enter a filename."
500 If Sys(3)=131 Then Close\1\ : @"File not ready. Please try again."
510 Enddo
520 Until Sys(3)=0
530 Endproc
540 Procedure .New'file (Text'file$)
550 Set 3,0
560 Repeat
570 Input"Enter the name of a NEW file. ",Text'file$
580 On Error Goto 620
590 Open\1\Text'file$
600 Close\1\
610 @"File already exists. Please enter a NEW filename."
620 On Error Stop
630 Until Sys(3)>0
640 Endproc
650 *Get'line
660 On Error Goto 700
670 Input\1\Old'line$(-1)
690 On Error Stop
700 Return
710 *Put'line
720 If New'line$="" Then Return
730 Print\2\New'line$
740 Return
750 Procedure .Capitalize (New'line$)
760 Local I
780 For I=0 To Len(New'line$)
786 If J=0 Then J=1
790 If New'line$(I,I)>="a" And New'line$(I,I)<="z" Then Do
800 New'line$(I,I)=Chr$(Asc(New'line$(I,I))-32)
810 Enddo
815 Next I
820 Endproc
830 *Convert'line
840 Local I
850 New'line$(-1)=""
860 If Len(Old'line$)=0 Then Return
870 New'line$=Old'line$
880 For I=1 To 16
890 On I Gosub 980,990,1000,1010,1020,1030,1040,1050,1060,1070,1080,1090,1091,1092,1093,1094
900 Call .Replace'all (New'line$,String1$,String2$)
910 Next I
930 Gosub Fix'input
940 Gosub Fix'char'arrays
950 Gosub Change'left
960 Gosub Fix'if'then'else
970 Return
980 String1$="IF" : String2$=" IF " : Return
990 String1$="INPUT" : String2$=" INPUT " : Return
1000 String1$="GOTO" : String2$=" Goto " : Return
1010 String1$="THEN" : String2$=" THEN " : Return
1020 String1$="GOSUB" : String2$=" GOSUB " : Return
1030 String1$="NEXT" : String2$=" NEXT " : Return
1040 String1$="ELSE" : String2$=" ELSE " : Return
1050 String1$="STOP" : String2$=" Stop " : Return
1060 String1$="STEP" : String2$=" STEP " : Return
1070 String1$="FOR" : String2$=" FOR " : Return
1080 String1$="PRINT" : String2$=" PRINT " : Return
1090 String1$="READ" : String2$=" READ " : Return
1091 String1$="TO" : String2$=" TO " : Return
1092 String1$="REMARK" : String2$=" REM " : Return
1093 String1$="DATA" : String2$=" DATA " : Return
1094 String1$="DIM" : String2$=" DIM " : Return
1100 *Change'left
1110 Local I,J,L
1120 I=Pos(New'line$,"LEFT$(",0)
1130 If I>-1 Then Do
1140 J=Pos(New'line$,"$",I+5)
1150 L=Pos(New'line$,")",0)
1160 String$(-1)=New'line$(I+6,J)+"(0,"+New'line$(J+2,L-1)+"-1)"
1170 New'line$(I,L)=String$(-1)
1180 Enddo
1190 Return
1200 *Fix'input
1210 Local I
1220 If Pos(New'line$,"INPUT",0)>-1 Then Do
1230 Repeat
1240 I=Pos(New'line$,Weird$,0)
1250 If I>-1 Then Do
1260 Expand New'line$(I),1
1270 New'line$(I,I+2)=" "","
1280 Enddo
1290 Until I=-1
1300 Enddo
1310 Return
1370 Procedure .Replace'string (New'line$,String1$,String2$,Start)
1380 Local I,J
1390 I=Len(String1$)-1
1400 J=Len(String2$)-1
1410 Start=Pos(New'line$,String1$,Start)
1420 If Start>-1 Then Do
1430 If J>I Then Do
1440 Expand New'line$(Start),J-I
1450 New'line$(Start,Start+J)=String2$(0,J)
1460 Else
1470 New'line$(Start,Start+I)=String2$(0,I)
1480 @"CONTRACTED NEW LINE = ";New'line$(Start,Start+I)
1490 Enddo
1500 Enddo
1510 Endproc
1520 Procedure .Last'paren (New'line$,I)
1530 Local J,K,L
1540 J=Pos(New'line$,"(",I)
1550 K=J : L=J
1560 Repeat
1570 K=Pos(New'line$,")",K+1)
1580 L=Pos(New'line$,"(",L+1)
1590 Until L>K Or L=-1
1600 Endproc (J,K)
1610 *Fix'char'arrays
1620 Local I,J,K,L
1630 I=-1
1640 Repeat
1650 I=Pos(New'line$,"$(",I+1)
1660 If New'line$(I-3,I-1)="MID" Then Goto 1650
1670 If New'line$(I-4,I-1)="LEFT" Then Goto 1650
1680 If New'line$(I-5,I-1)="RIGHT" Then Goto 1650
1690 If New'line$(I-3,I-1)="CHR" Then Goto 1650
1700 If New'line$(I-3,I-1)="STR" Then Goto 1650
1710 If I>-1 Then Do
1720 @ : @ New'line$
1730 @ Tab(I);"$"
1740 Print"Change to CROMEMCO character array (Y/N)?";
1750 Call .Yes'no (Yn$)
1760 If Yn$(0,0)="Y" Then Do
1770 Call .Last'paren (New'line$,I;J,K)
1780 String2$="$(("+New'line$(J+1,K-1)+"-1)*40,"+New'line$(J+1,K-1)+"*40-1)"
1790 String1$=New'line$(I,K)
1800 Call .Replace'string (New'line$,String1$,String2$,I)
1810 @ New'line$ : @ : @
1820 Enddo
1830 Enddo
1840 Until I=-1
1850 Return
1860 *Fix'if'then'else
1870 Local I,J
1880 I=Pos(New'line$,"ELSE",0)
1890 If I>-1 Then Do
1900 @ : @ New'line$
1910 @ Tab(I);"$"
1920 Print"Change ELSE to two lines (Y/N)?";
1926 Call .Yes'no (Yn$)
1930 If Yn$(0,0)="Y" Then Do
1940 Temp'line$=New'line$(I)
1950 J=Val(New'line$)
1960 New'line$(I)=" "
1970 Gosub Put'line
1980 @ : Input"Enter the conditional part of the statment. ",String$
1990 New'line$(-1)=Str$(J+1)+" IF "+String$+" THEN "+Temp'line$(4)
2000 Enddo
2010 Enddo
2020 Return
2030 Procedure .Replace'all (New'line$,String1$,String2$)
2040 Local I,K
2050 I=-1
2060 Repeat
2070 I=Pos(New'line$,String1$,I+2)
2080 If I>-1 Then Do
2085 Call .Count'quotes (New'line$,I;K)
2090 If Fra((1.0*K)/2.0)=0 Then Call .Replace'string (New'line$,String1$,String2$,I)
2100 Enddo
2110 Until I=-1
2120 Endproc
2200 Procedure .Yes'no (Yn$)
2210 Repeat
2211 Input Yn$
2222 Call .Capitalize (Yn$)
2223 If Yn$(0,0)="E" Then Goto Ending
2230 Until Yn$="Y" Or Yn$="N"
2240 Endproc
2250 Procedure .Count'quotes (New'line$,I)
2260 Local J,K
2265 J=-1
2270 Repeat
2280 J=Pos(New'line$,Chr$(34),J+1)
2285 If J>-1 Then Do
2287 If J<I Then K=K+1
2288 Enddo
2289 Until J=-1 Or J>I
2290 Endproc (K)