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-BAS.STB
< prev
next >
Wrap
Text File
|
1984-04-29
|
6KB
|
201 lines
30 Gosub Screen'erase
40 @"Basic File Converter"
50 @"By David E. Trachtenbarg"
60 @"Copyright 1981"
70 Integer I,J,K,L,L1,L2,L'length
80 Long Line'no,Number
90 L'length=132
100 Dim Input'file$(13),Output'file$(13),Tab$(0),Weird$(1),String$(50)
110 Dim New'line$(L'length),Old'line$(L'length),Temp'line$(L'length)
120 Weird$=" ;" : Weird$(0,0)=""""
130 Tab$=Chr$(9)
140 Set 0,-1
150 Set 3,0
155 Line'no=0
160 Call .Enter'file (Input'file$)
170 Call .New'file (Output'file$)
180 Create Output'file$
190 Open\1\Input'file$
200 Open\2\Output'file$
210 Print\2\""
220 Noesc
230 Repeat
240 Gosub Get'line
250 Gosub Convert'line
260 Gosub Put'line
270 If New'line$<>"" Then @ New'line$
280 Until Sys(3)>0
290 Close
300 @ : @"Done!!!!"
310 Esc
315 Goto 150
320 End
330 *Screen'erase
340 Out 1,126 : Out 1,28 : Return
350 Procedure .Enter'file (Text'file$)
360 Repeat
370 Set 3,0
380 Input"Enter the name of the input file. ",Text'file$
390 On Error Goto 420
400 Open\1\Text'file$
410 Close\1\
420 On Error Stop
430 If Sys(3)>0 Then Do
440 @ : @"Error ";Sys(3);" has occured."
450 If Sys(3)=128 Or Sys(3)=134 Then @"File does not exist on disk."
460 If Sys(3)=129 Then @"Please enter a filename."
470 If Sys(3)=131 Then Close\1\ : @"File not ready. Please try again."
480 Enddo
490 Until Sys(3)=0
500 Endproc
510 Procedure .New'file (Text'file$)
520 Set 3,0
530 Repeat
540 Input"Enter the name of a NEW file. ",Text'file$
550 On Error Goto 590
560 Open\1\Text'file$
570 Close\1\
580 @"File already exists. Please enter a NEW filename."
590 On Error Stop
600 Until Sys(3)>0
610 Endproc
620 *Get'line
630 On Error Goto 660
640 Input\1\Old'line$(-1)
650 On Error Stop
660 Return
670 *Put'line
680 If New'line$="" Then Return
690 Print\2\New'line$
700 Return
710 *Convert'line
720 New'line$(-1)=""
730 If Len(Old'line$)=0 Then Return
740 Number=Val(Old'line$)
750 If Number=0 Then Do
760 Line'no=Line'no+1
770 New'line$=Str$(Line'no)+Old'line$
780 Else
790 If Number<Line'no Then Call .Errors (2)
800 Line'no=Number
810 New'line$=Old'line$
820 Enddo
830 Gosub Changes
840 Return
850 *Changes
860 Gosub Delete'tabs
870 Gosub Change'rnd
880 Gosub Change'go'to
900 Gosub Change'left
910 Gosub Fix'input
920 Gosub Truncate'remarks
930 Gosub Variable'fix
940 Gosub Combine'lines
950 Return
960 *Delete'tabs
965 Local I
970 Repeat
980 I=Pos(New'line$,Tab$,0)
990 If I>-1 Then New'line$(I,I)=" "
1000 Until I=-1
1010 Return
1020 *Change'rnd
1025 Local I
1030 Repeat
1040 I=Pos(New'line$,"RND",0)
1050 If I>-1 Then Do
1060 Expand New'line$(I),3
1070 New'line$(I,I+5)="Rnd(0)"
1080 Enddo
1090 Until I=-1
1100 Return
1110 *Change'go'to
1115 Local I
1120 Repeat
1130 I=Pos(New'line$,"GO TO",0)
1140 If I>-1 Then New'line$(I,I+4)="Goto "
1150 Until I=-1
1160 Return
1170 *Change'left
1175 Local I,J,L
1190 I=Pos(New'line$,"LEFT$(",0)
1200 If I>-1 Then Do
1210 J=Pos(New'line$,"$",I+5)
1230 L=Pos(New'line$,")",0)
1240 String$(-1)=New'line$(I+6,J)+"(0,"+New'line$(J+2,L-1)+"-1)"
1250 New'line$(I,L)=String$(-1)
1260 Gosub Change'to'zero
1270 Enddo
1300 Return
1470 *Fix'input
1475 Local I
1480 If Pos(New'line$,"INPUT",0)>-1 Then Do
1490 Repeat
1500 I=Pos(New'line$,Weird$,0)
1510 If I>-1 Then Do
1520 Expand New'line$(I),1
1530 New'line$(I,I+2)=" "","
1540 Enddo
1550 Until I=-1
1560 Enddo
1570 Return
1580 *Truncate'remarks
1585 Local I
1590 I=Pos(New'line$,"REMARK",0)
1600 If I>-1 Then New'line$(I,I+5)="REM "
1610 Return
1620 *Combine'lines
1625 Local I,J
1640 I=Pos(New'line$,"\",0)
1650 J=Len(New'line$)
1660 If I>-1 And I>(J-2) Then Do
1690 New'line$(I,I)=":"
1710 Gosub Get'line
1720 Temp'line$=New'line$
1730 New'line$=Temp'line$+Old'line$
1740 I=Pos(New'line$,"::",0)
1750 If I>-1 Then New'line$(I,I+1)=": "
1760 Gosub Changes
1790 Enddo
1800 Return
1810 *Variable'fix
1815 Local I,J
1820 J=0
1830 Repeat
1840 I=Pos(New'line$,".",J)
1850 If I>-1 Then Do
1860 J=I+1
1870 If New'line$(I-1,I-1)>="A" And New'line$(I-1,I-1)<="Z" Then Do
1880 If New'line$(I+1,I+1)>="0" And New'line$(I+1,I+1)<="Z" Then Do
1890 New'line$(I,I)="'"
1900 Enddo
1910 Enddo
1920 Enddo
1930 Until I=-1
1940 Return
1950 *Change'to'zero
1960 Local I
1985 I=Pos(New'line$,"1-1",0)
1986 If I>-1 Then New'line$(I,I+2)=" 0 "
1990 Return
2240 Procedure .Errors (Err)
2250 @ : @"*******" : @
2280 Esc
2290 Close
2300 Erase Output'file$
2310 I=Pos(Input'file$,".",0)
2320 Output'file$=Input'file$
2330 Input'file$(I+1)="BD"
2340 Rename Output'file$,Input'file$
2350 @"There is an error in the program."
2360 If Err=1 Then @"Unmatched parentheses"
2370 If Err=2 Then @"Non consecutive line numbers"
2380 @ : @"Original line:"
2390 @ Old'line$
2400 @"Changed line:"
2410 @ : @ New'line$
2420 Stop
2430 Endproc