PCjs Machines
Home of the original IBM PC emulator for browsers.
PC-SIG Diskette Library (Disk #167)
[PCjs Machine "ibm5150"]
Waiting for machine "ibm5150" to load....
Information about “BASIC AIDS NO 1”
This disk contains many useful routines for the BASIC programmer.
Routines include a BASIC to FORTRAN converter, a BASIC program
squisher, and a REMark remover.
Special Requirements: A version of BASIC.
How to Start: Type GO (press enter).
Suggested Registration: None.
File Descriptions:
ADVANCED BAS Checks to see if a program requires BASICA or not.
ADVANCED DOC Documentation.
ANIMATE BAS Demonstrates how to use several BASICA graphics commands.
BASKEYS BAS Sets up BASIC programming function keys.
BASTODOS BAS Several callable Assembler routines for BASIC programs.
BASTOFOR BAS Converts BASIC to Fortran.
BASTOFOR DOC Documentation.
CHARDISP BAS Displays ASCII character set.
PSQUISH BAS BASIC program squisher.
REMREM BAS Removes REMarks from BASIC programs.
STOPGAP BAS Screen text editor for BASIC programming.
TRANDUMP BAS HEX file display program.
TRS2PC BAS Converts TRS80 BASIC partways to IBM PC BASIC.
ADVANCED.BAS
7 ON ERROR GOTO 8 :PLAY"mf" :ON ERROR GOTO 0 :GOTO 10
8 PRINT "Sorry, but you must use BASICA to run this program.":RESUME 9
9 ON ERROR GOTO 0 :END
ADVANCED.DOC
Documentation Maintained by PC Professional Users Group
P.O. Box 2350 Wilmington DE. 19899
FILENAME: ADVANCED.BAS
PROGRAM NAME: Code to check for Advanced BASIC
VERSION NUMBER: 1.0
VERSION DATE: 00-00-00
AUTHOR (ORIGINAL): David Bennett (302) 571-0314
" ADDRESS/PHONE: 201 Snuff Mill Road, Wilmington DE. 19807
LATEST REVISOR: .
" ADDRESS/PHONE: .
OBTAINED FROM: Author
PROGRAM TYPE: Utility
********************** EQUIPMENT REQUIRED **********************
(Consider printer, modem, memory, graphics board, special equip., etc.)
********************* PURPOSE; DESCRIPTION *********************
This is some code that you can add to a program that requires
Advanced Basic. If the user tries to use disk or cassette,
this code will warn him and stop the program.
************************* INSTRUCTIONS *************************
-Add this code in an appropriate location to any of your programs
which require the use of ADVANCED BASIC
************************* PECULIARITIES ************************
Make sure line 10 exists or change the GOTO number at the end of
line 7
*********************** GENERAL COMMENTS ***********************
-This is a nice sort of finishing touch which should be added to
any program which will not run without ADVANCED BASIC.
-The complete code listing is:
7 ON ERROR GOTO 8 :PLAY"mf" :ON ERROR GOTO 0 :GOTO 10
8 PRINT "Sorry, but you must use BASICA to run this program.":RESUME 9
9 ON ERROR GOTO 0 :END
-An improvement would be :
ANIMATE.BAS
1 REM This is a sample program that illustrates how to use several of
2 REM the BASICA graphics commands. Specifically, animation of objects
3 REM is presented ... along with how to display lines, boxes, and circles.
4 REM
5 REM
6 REM The following statement defines the Graphics Array where objects will
7 REM be saved.
8 REM
10 DIM OBJ$(1000)
11 REM
12 REM The following statement sets up error handling.
13 REM
15 ON ERROR GOTO 20000
16 REM
17 REM The following few statements check to see if the color monitor
18 REM is being used. If it is, control is transferred to stmt 140.
19 REM If not, BASIC statements are executed that cause the color
20 REM monitor to be activated.
21 REM
25 DEF SEG=0
30 IF (PEEK(&H410) AND &H30) <> &H30 THEN DEF SEG: GOTO 140
40 KEY OFF
50 CLS
60 WIDTH 80: DEF SEG=0: A=PEEK(&H410): POKE &H410,(A AND &HCF) OR &H20
70 WIDTH 40 :SCREEN 1: SCREEN 0: LOCATE ,,1,6,7
80 KEY OFF
90 SCREEN 0,1
100 COLOR 15,9,4
110 WIDTH 40
140 REM
141 REM The following statements set the appropriate color for the
142 REM program and screen width. COLOR 0,0 means that background
143 REM is going to be black, with color palette 0 chosen. This palette
144 REM allows us to use the colors black, green, red, and brown.
145 REM
150 WIDTH 40:COLOR 0,0:SCREEN 1,0:CLS:LOCATE 2,1
160 REM
161 REM Now we begin doing some real graphics processing. We will begin
162 REM by drawing the object we wish to animate. Then we will store it
163 REM into our array (obj$) for use later in the program.
164 REM
170 LINE (1,1)-(31,31),3,B ' draw a box
180 CIRCLE (16,16),14,2 ' draw a circle within the box
185 PAINT (16,16),2
190 GET (1,1)-(31,31),OBJ$ ' save object into array
200 CLS
260 REM
261 REM Now we get down to business. We begin by drawing some lines on the
262 REM screen that will be used as a background. These lines need not be
263 REM here, but are used for visual effect.
264 REM
270 FOR X%=1 TO 319 STEP 15
280 LINE (X%,1)-(X%,199),1
290 NEXT
300 FOR Y%=1 TO 199 STEP 15
310 LINE (1,Y%)-(319,Y%),1
320 NEXT
400 REM
401 REM Now we begin doing the animation process. This particular program
402 REM allows the object to randomly move about the screen until it "hits"
403 REM the edge of the screen. Once this occurs, the direction changes
404 REM and movement continues. To stop the program requires the ESC key
405 REM to be pressed.
406 REM
410 X%=100:Y%=100:PUT (X%,Y%),OBJ$,XOR
420 DIREC%=1:YDIREC%=0:QUITIT=0:SPEED%=1
430 WHILE QUITIT=0
440 NEWX%=X%+DIREC%*SPEED%:IF NEWX%>287 THEN DIREC%=-1:GOTO 440 ELSE IF NEWX%<1 THEN DIREC%=1:GOTO 440 ' compute new x coordinate
450 NEWY%=Y%+YDIREC%*SPEED%:IF NEWY%>167 THEN YDIREC%=-1:GOTO 450 ELSE IF NEWY%<1 THEN YDIREC%=1:GOTO 450 ' compute new y coordinate
455 REM Check for arrow keys or carrots (<,>). Arrows control direction.
456 REM Carrots control speed (<=slow down, >=speed up)
460 K$=INKEY$:IF K$="" THEN 540
470 IF K$=CHR$(0)+CHR$(77) THEN DIREC%=1
480 IF K$=CHR$(0)+CHR$(75) THEN DIREC%=-1
490 IF K$=CHR$(0)+CHR$(72) THEN YDIREC%=-1
500 IF K$=CHR$(0)+CHR$(80) THEN YDIREC%=1
510 IF K$=CHR$(62) THEN SPEED%=SPEED%+1
520 IF K$=CHR$(60) THEN SPEED%=SPEED%-1:IF SPEED%<0 THEN SPEED%=0
530 IF K$=CHR$(27) THEN QUITIT=1
531 REM
532 REM Display graphics image at new location
533 REM
540 PUT (NEWX%,NEWY%),OBJ$,XOR
541 REM
542 REM Erase graphics image at old location
543 REM
550 PUT (X%,Y%),OBJ$,XOR
560 X%=NEWX%:Y%=NEWY%
570 WEND
580 LOCATE 23,1
590 CLS:RUN "MENU.PGM"
20000 PRINT "error encountered";ERL;"=error line";:RESUME
BASKEYS.BAS
10 ' Utility to set up function keys.
20 KEY OFF
30 KEY 1, "LIST "
40 KEY 2, "RUN"+CHR$(13)
50 KEY 3, "LOAD"+CHR$(34)
60 KEY 4, "SAVE"+CHR$(34)
70 KEY 5, ".BAS"+CHR$(34)+",A"+CHR$(13)
80 KEY 6, "EDIT "
90 KEY 7, "SYSTEM"+CHR$(13)
100 KEY 8, "FILES"+CHR$(13)
110 KEY 9, "KEY ON"+CHR$(13)
120 KEY 10, "SCREEN 0,0,0,0"+CHR$(13)
130 KEY ON
140 NEW
BASTODOS.BAS
10 '*
15 '*************************************************************************
20 '*
25 '* BASIC WORKSHOP SERIES
30 '*
35 '* NUMBER 1
40 '*
45 '* BY
50 '*
55 '* JAMES P. MORGAN
60 '* 1749 AMERICANA BLVD APT 23-G
65 '* ORLANDO FLA, 32809
70 '*
75 '* WORK PH:(305) 826-7297
80 '*
85 '* I HAVE PUT TOGETHER, FOR YOU, A SET OF CALLABLE ASSEMBLER SUBROUTINES
90 '* FROM BASIC, TO ALLOW YOU MORE CONTROL OVER YOUR SYSTEM. THESE ROUTINES
95 '* ENABLE YOU TO ACCESS DOS FUNCTIONS NOT SUPPORTED BY THE INTERPRETER OR
100 '* THE BASIC COMPILER, FOR MOST OF THE NEW EXTENDED DOS 2.0 FUNCTIONS.
105 '*
110 '* I HAVE DEBUGGED THE ROUTINES AS MUCH AS MY LIMITED TIME WOULD PERMIT.
115 '* PLEASE EXCUSE THE TYPING ERROR, I COME FROM THE HUNT AND PEEK SCHOOL
120 '* OF TYPING. ALSO I SCRATCHED MY MASTER FILE AND HAD TO REKEY ALL OF THIS.
125 '* THE LESSON LEARNED , ALWAYS KEEP A BACK UP OF LARGE FILES, EVEN IF
130 '* NOT A TOTAL CURRENT ONE.
135 '*
140 '* A NOTE OF WARNING, THESE SUBROUTINES DO LITTLE OR NO VALIDITY CHECKING
145 '* AS TO THE FORMAT, TYPE AND RANGE OF VARIABLES PASSED, SO BE WARNED IF
150 '* YOU DO NOT FOLLOW THE RULES AND YOUR MACHINE LOCKS UP TIGHT.
155 '*
160 '* THERE ARE MORE SUBROUTINES FORTHCOMING, SO LOOK FOR THEM, SUCH AS
165 '* GETTING/SETTING THE INTERRUPT VECTORS, PARSEING A FILENAME, PASSING
170 '* RETURN CODES FROM A PROGRAM TO BATCH JOBS, AND MORE.
175 '*
180 '* DOS 2.0 DEFINITIONS
185 '* -----------------------
190 '*
195 '* ASCIIZ STRING - NORMAL TEXT STRING, USUALLY CONSISTING OF A DRIVE,
200 '* PATH , AND/OR FILENAME (EXP:"A:\COBOL\COBPGM.COB")
205 '* TERMINATED BY A HEX 00/(CHR$(0)).
210 '*
215 '* THERE ARE MORE RETURN CODES OUTPUT BY THE NEW DOS 2.0 FUNCTION CALLS.
220 '*
225 '* 1 - INVALID FUNCTION NUMBER
230 '* 2 - FILE NOT FOUND
235 '* 3 - PATH NOT FOUND
240 '* 4 - TOO MANY OPEN FILES
245 '* 5 - ACCESS DENIED
250 '* 6 - INVALID HANDLE
255 '* 7 - MEMORY CONTROL BLOCKS DESTROYED
260 '* 8 - INSUFFICIENT MEMORY
265 '* 9 - INVALID MEMORY BLOCK ADDRESS
270 '* 10 - INVALID ENVIRONMENT
275 '* 11 - INVALID FORMAT
280 '* 12 - INVALID ACCESS CODE
285 '* 15 - INVALID DRIVE WAS SPECIFIED
290 '* 16 - ATTEMPTED TO REMOVE THE CURRENT DIRECTORY
295 '* 17 - NOT SAME DEVICE
300 '* 18 - MO MORE FILES
305 '*
310 '* SOME SUBROUTINES STILL DO CALLS TO THE DOS 1.1 FUNCTION CALLS
315 '* AND THEY RETURN THEIR OWN PARTICULAR RESULT CODES.
320 '*
325 '* AS ALWAYS, IF IN DOUBT, CONSULT THE TECHNICAL GUIDE AND THE TECHNICAL
330 '* SECTION OF THE DOS MANUAL AS TO THE FORMAT AND OBJECTIVE OF ANY OF THE
335 '* FUNCTION CALLS.
340 '*
345 '* NOTE:
350 '* THE PROGRAMS WILL CREATE A .COM TYPE FILE, IF YOU TEST RUN EACH
360 '* ONE SEPARATELY. THESE .COM TYPE FILES MAY THEN BE READ BY OTHER
370 '* PROGRAMS AND POKED INTO A VARIABLE ARRAY IN THE NEW PROGRAM, AS WAS
380 '* DONE IN THE TEST PROGRAMS.
390 '* BOTH THE INTERPERTER AND BASIC COMPILER ARE SUPPORTED IN THE DATA
400 '* STATEMENTS IN THE PROGRAMS. YOU MUST, I REPEAT, YOU MUST COMMENT OUT
405 '* THE DATA STATEMENTS FLAGGED THAT DO NOT APPLY TO THE MODE YOU ARE
410 '* RUNNING IN. YOU CANNOT RUN THE BASIC COMPILER DATA STATEMENTS WHILE
415 '* RUNNING THE INTERPERTER. YOU MAY HOWEVER CREATE THE .COM TYPE FILES
420 '* FOR USE BY COMPILED PROGRAMS. BY CHANGING THE DATA STATEMENTS AS
425 '* ADVISED AND PUTTING AN "END' STATEMENT JUST AFTER THE 'GOSUB' THAT
430 '* CREATES THE DISK .COM FILE.
435 '*
440 '* 'KEEP ON COMPUTING AND SHARING'
500 '**********************************************************************
501 '*
502 '* SUBROUTINE FUNCTION : CNTL-BREAK CHECK
503 '*
504 '* VERSION : 1.0
505 '*
506 '* DATE LAST UPDATED : SEPT 25, 1983
507 '*
508 '* AUTHOR : JAMES P MORGAN
509 '*
510 '* CALL FORMAT :
511 '* ---------------------
512 '* CALL OFFSET%(CNTL.BREAK.STATE%,RETURN.CODE%)
513 '*
514 '* PARAMETERS PASSED : CNTL.BREAK.STATE% (00=REQUEST CURRENT STATE
515 '* 01=FLIP/FLOP CURRENT STATE
516 '*
517 '* RETURN.CODE%=0
518 '*
519 '* PARAMETERS RETURNED : CNTL.CREAK.STATE%
520 '*
521 '* RETURN.CODE% (00=CNTL-BREAK ON
522 '* 01=CNTL-BREAK OFF)
523 '*
524 '* COMMENTS :
525 '*
526 '* THIS SUBROUTINE WILL FLIP/FLOP THE CNTL-BREAK
527 '* SWITCH FROM ON/OFF OR OFF/ON AND RETURN THE CURRENT
528 '* STATE OR JUST RETURN THE CURRENT STATE OF THE
529 '* CNTL-BREAK SWITCH.
530 '*
531 '**************************************************************************
537 CLS
538 CLOSE
539 DEF SEG
540 DEFINT A-Z
541 DIM SUBRT%(40)
542 OFFSET%=0
543 CNTL.BREAK.STATE%=0
544 CURRENT.STATE%=0
545 RETURN.CODE%=0
546 GOSUB 576
547 GOSUB 555
548 OFFSET%=VARPTR(SUBRT%(0))
549 CALL OFFSET%(CNTL.BREAK.STATE%,RETURN.CODE%)
550 CURRENT.STATE%=RETURN.CODE%
551 PRINT "CNTL BREAK REQUEST= ";CNTL.BREAK.STATE%
552 PRINT "CURRENT STATE = ";CURRENT.STATE%
553 PRINT "RETURN CODE = ";RETURN.CODE%
554 END
555 FOR I=0 TO 31
556 READ J
557 POKE (VARPTR(SUBRT%(0))+I),J
558 NEXT
559 RETURN
560 DATA &H55
561 DATA &H89,&HE5
562 DATA &HB0,&H00
563 DATA &HB2,&H00
564 DATA &HB4,&H33
565 DATA &HCD,&H21
566 DATA &H8B,&H76,&H08
567 DATA &H8A,&H04
568 DATA &H80,&HF2,&H01
569 DATA &HB4,&H33
570 DATA &HCD,&H21
571 DATA &H8B,&H76,&H06
572 DATA &H88,&H14
573 DATA &H5D
574 DATA &HCA,&H04,&H00
575 END
576 RESTORE
577 FILENAME$="A:"+"CNTLBRK.EMU"
578 PGM.LEN=31
579 OPEN FILENAME$ AS #1 LEN=1
580 FIELD #1, 1 AS PGM.BYTE$
581 FOR I=0 TO PGM.LEN
582 READ J
583 LSET PGM.BYTE$=CHR$(J)
584 PUT #1
585 NEXT
586 CLOSE
587 RESTORE
588 RETURN
1000 '**********************************************************************
1001 '*
1002 '* SUBROUTINE FUNCTION : GET DRIVE TYPE
1003 '*
1004 '* VERSION : 1.0
1005 '*
1006 '* DATE LAST UPDATED : SEPT 25, 1983
1007 '*
1008 '* AUTHOR : JAMES P MORGAN
1009 '*
1010 '* CALL FORMAT :
1011 '* ---------------------
1012 '* CALL OFFSET%(DRIVE%,RETURN.CODE%)
1013 '*
1014 '* PARAMETERS PASSED : DRIVE% (00=DEFAULT,1=A,2=B..ECT)
1015 '*
1016 '* RETURN.CODE%=0
1017 '*
1018 '* PARAMETERS RETURNED : DRIVE%
1019 '*
1020 '* RETURN.CODE% (255=INVALID DRIVE)
1021 '*
1022 '* COMMENTS :
1023 '*
1024 '* THIS ROUTINE RETURNS THE DRIVE TYPE. THE DOS
1025 '* FUNCTION CALL '1CH' ID USED. THIS DOS FUNCTION CALL
1026 '* DOES NOT FUNCTION UNDER 2.0 AS IT DID UNDER 1.1.
1027 '* UNDER 1.1 THE FATS (FILE ALLOCATION TABLES) WERE
1028 '* MAINTAINED IN MEMORY AND THIS CALL WOULD POINT YOU
1029 '* TO THE FAT IN MEMORY.
1030 '* UNDER 2.0 THIS CALL NOW ONLY POINTS YOU TO THE
1031 '* DRIVE TYPE CODE IN MEMORY.
1032 '**************************************************************************
1033 CLS
1034 CLOSE
1035 DEF SEG
1036 DEFINT A-Z
1037 DIM SUBRT%(40)
1038 OFFSET%=0
1039 DRIVE%=0
1040 DUAL.8.SECTORS=255 'FF
1041 SINGLE.8.SECTORS=254 'FE
1042 DUAL.9.SECTORS=253 'FD
1043 SINGLE.9.SECTORS=252 'FC
1044 FIXED.DISK=248 'F8
1045 RETURN.CODE%=0
1046 GOSUB 1086
1047 GOSUB 1062
1048 REQUESTED.DRIVE%=DRIVE%
1049 OFFSET%=VARPTR(SUBRT%(0))
1050 CALL OFFSET%(DRIVE%,RETURN.CODE%)
1051 PRINT "DRIVE REQUESTED = ";REQUESTED.DRIVE%
1052 PRINT "DRIVE TYPE CODE = ";DRIVE%
1053 IF RETURN.CODE%=255 THEN DRIVE.TYPE$="INVALID DRIVE SPECIFIED":GOTO 1059
1054 IF DRIVE%=255 THEN DRIVE.TYPE$="DUAL.SIDED, 8 SECTORS PER TRACK"
1055 IF DRIVE%=254 THEN DRIVE.TYPE$="SINGLE SIDED, 8 SECTORS PER TRACK"
1056 IF DRIVE%=253 THEN DRIVE.TYPE$="DUAL SIDED, 9 SECTORS PER TRACK"
1057 IF DRIVE%=252 THEN DRIVE.TYPE$="SINGLE SIDED, 9 SECTORS PER TRACK"
1058 IF DRIVE%=248 THEN DRIVE.TYPE$="FIXED DISK"
1059 PRINT "DRIVE TYPE = ";DRIVE.TYPE$
1060 PRINT "RETURN CODE = ";RETURN.CODE%
1061 END
1062 FOR I=0 TO 37
1063 READ J
1064 POKE (VARPTR(SUBRT%(0))+I),J
1065 NEXT
1066 RETURN
1067 DATA &H55
1068 DATA &H89,&HE5
1069 DATA &H31,&HC0
1070 DATA &H31,&HDB
1071 DATA &H31,&HC9
1072 DATA &H31,&HD2
1073 DATA &H8B,&H76,&H08
1074 DATA &H8A,&H14
1075 DATA &HB4,&H1C
1076 DATA &H1E
1077 DATA &HCD,&H21
1078 DATA &H8A,&H27
1079 DATA &H1F
1080 DATA &H8B,&H76,&H08
1081 DATA &H88,&H24
1082 DATA &H8B,&H76,&H06
1083 DATA &H88,&H04
1084 DATA &H5D
1085 DATA &HCA,&H04,&H00
1086 RESTORE
1087 FILENAME$="A:"+"DRIVETYP.EMU"
1088 PGM.LEN=37
1089 OPEN FILENAME$ AS #1 LEN=1
1090 FIELD #1, 1 AS PGM.BYTE$
1091 FOR I=0 TO PGM.LEN
1092 PGM.LEN=37
1093 PUT #1
1094 NEXT
1095 CLOSE
1096 RESTORE
1097 RETURN
1500 '**********************************************************************
1501 '*
1502 '* SUBROUTINE FUNCTION : GET FIRST/NEXT MATCHING FILE
1503 '*
1504 '* VERSION : 1.0
1505 '*
1506 '* DATE LAST UPDATED : SEPT 25, 1983
1507 '*
1508 '* AUTHOR : JAMES P MORGAN
1509 '*
1510 '* CALL FORMAT :
1511 '* ---------------------
1512 '* CALL OFFSET%(FUNCTION.CODE%,ATTRIBUTE%,ASCIIZ.STRING$,DTA%(0),RETURN.CODE%)
1513 '*
1514 '* PARAMETERS PASSED : FUNCTION.CODE% (&H4E=FIND FIRST MATCHING FILE
1515 '* &H4F=FIND NEXT MATCHING FILE)
1516 '*
1517 '* ATTRIBUTE% (ATTRIBUTE TO BE USED IN
1518 '* SEARCHING FOR THE FILE)
1519 '*
1520 '* ASCIIZ.STRING$ (DRIVE,PATH, AND FILENAME)
1521 '*
1522 '* DTA%(0) (PSEUDO DTA TO HOLD MATCHING
1523 '* FILE INFORMATION)
1524 '*
1525 '* RETURN.CODE%=0
1526 '*
1527 '* PARAMETERS RETURNED : FUNCTION.CODE%
1528 '*
1529 '* ATTRIBUTE%
1530 '*
1531 '* ASCIIZ.STRING$
1532 '*
1533 '* DTA%(0) (FILLED WITH MATCHING DTA INFO)
1534 '*
1535 '* RETURN.CODE%
1536 '*
1537 '* COMMENTS :
1538 '*
1539 '* THIS SUBROUTINE SEARCHS A DIRECTORY FOR A
1540 '* FILE WITH MATCHING FILE ATTRIBUTE AND CHARACTERS.
1541 '* THE ASCIIZ STRING CONSISTS OF A DRIVE , PATH ,
1542 '* AND FILENAME. GLOBAL FILENAME CHARACTERS ARE ALLOWED
1543 '* IN THE FILENAME PORTION OF THE STRING.
1544 '* IF A FILE IS FOUND THAT MATCHES THE SPECIFIED
1545 '* DRIVE, PATH, AND FILENAME AND ATTRIBUTE, THE DTA
1546 '* IS FILLED IN AS FOLLOWS:
1547 '*
1548 '* 21 BYTES - RESERVED FOR DOS USE ON SUBSEQUENT
1549 '* FIND NEXT CALLS
1550 '*
1551 '* 2 BYTES - FILES CREATE/UPDATE TIME
1552 '*
1553 '* 2 BYTES - FILES CREATE/UPDATE DATE
1554 '*
1555 '* 2 BYTES - LOW WORD OF FILE SIZE
1556 '*
1557 '* 2 BYTES - HIGH WORD OF FILE SIZE
1558 '*
1559 '* 13 BYTES - NAME AND EXTENTION OF FILE FOUND
1560 '* FOLLOWED BY A BYTE OF HEX 00.
1561 '*
1562 '* ALL BLANKS ARE REMOVED FROM THE NAME
1563 '* AND EXTENTION, AND IF AN EXTENTION IS
1564 '* PRESENT, IT IS PRECEEDED BY A PERIOD.
1565 '* THE NAME WOULD BE RETURNED JUST AS YOU
1566 '* HAD ENTERED IT AS A COMMAND PARAMETER,
1567 '* SUCH AS 'TREE.COM'.
1568 '* IF YOU ASK FOR ALL FILES IN A SUB-DIREC-
1569 '* TORY, THIS ROUTINE WILL RETURN THE '.'
1570 '* THE '..' THAT YOU SEE WHEN YOU DO A 'DIR'
1571 '* ON A SUB-DIRECTORY.
1572 '* YOU CAN USE THE GET FIRST OPTION TO
1573 '* RETURN THE VOLUMN LABEL, SINCE IT IS
1574 '* BASICALLY AN EMPTY FILE WITH A SPECIAL
1575 '* ATTRIBUTE IN THE DIRECTORY.
1576 '*
1577 '**************************************************************************
1578 CLS
1579 CLOSE
1580 DEF SEG
1581 DEFINT A-Z
1582 DIM SUBRT%(40)
1583 OFFSET%=0
1584 DIM DTA%(40)
1585 FOR I=0 TO 40:DTA%(I)=-1:NEXT
1586 FUNCTION.CODE%=&H4E
1587 PATH$="A:*.*"
1588 ASCIIZ.STRING$=PATH$+CHR$(0)
1589 ATTRIBUTE%=255
1590 RETURN.CODE%=0
1591 GOSUB 1652
1592 GOSUB 1608
1593 GOSUB 1598
1594 FUNCTION.CODE%=&H4F
1595 GOSUB 1598
1596 IF RETURN.CODE%=0 GOTO 1595
1597 END
1598 OFFSET%=VARPTR(SUBRT%(0))
1599 CALL OFFSET%(FUNCTION.CODE%,ATTRIBUTE%,ASCIIZ.STRING$,DTA%(0),RETURN.CODE%)
1600 PRINT "RETURN CODE = ";RETURN.CODE%
1601 IF RETURN.CODE%=18 THEN PRINT :RETURN
1602 FOR I=30 TO 43
1603 PRINT CHR$(PEEK(VARPTR(DTA%(0))+I));
1604 NEXT
1605 PRINT
1606 RETURN
1607 END
1608 FOR I=0 TO 65
1609 READ J
1610 POKE (VARPTR(SUBRT%(0))+I),J
1611 NEXT
1612 RETURN
1613 DATA &H55
1614 DATA &H89,&HE5
1615 DATA &H31,&HC0
1616 DATA &H31,&HC9
1617 DATA &H31,&HD2
1618 DATA &H8B,&H76,&H0E
1619 DATA &H8A,&H24
1620 DATA &H8B,&H76,&H0C
1621 DATA &H8B,&H0C
1622 DATA &H8B,&H76,&H0A
1623 '********COMMENT OUT THE NEXT DATA STATEMENT IF USED WITH THE BASIC COMPILER
1624 DATA &H8B,&H54,&H01
1625 '********COMMENT OUT THE NEXT DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
1626 'DATA &H8B,&H54,&H02
1627 DATA &HCD,&H21
1628 DATA &H8B,&H76,&H06
1629 DATA &H88,&H04
1630 DATA &H8B,&H76,&H08
1631 DATA &H89,&HF7
1632 DATA &H06
1633 DATA &H31,&HDB
1634 DATA &HB4,&H2F
1635 DATA &HCD,&H21
1636 DATA &HFC
1637 DATA &HB9,&H2C,&H00
1638 DATA &H89,&HDE
1639 DATA &H90,&H90,&H90
1640 DATA &H1E
1641 DATA &H06
1642 DATA &H1F
1643 DATA &H07
1644 DATA &HF3
1645 DATA &HA4
1646 DATA &H06
1647 DATA &H1F
1648 DATA &H07
1649 DATA &H5D
1650 DATA &HCA,&H0A,&H00
1651 END
1652 RESTORE
1653 FILENAME$="A:"+"FRSTNEXT.EMU"
1654 PGM.LEN=65
1655 OPEN FILENAME$ AS #1 LEN=1
1656 FIELD #1,1 AS PGM.BYTE$
1657 FOR I=0 TO PGM.LEN
1658 READ J
1659 LSET PGM.BYTE$=CHR$(J)
1660 PUT #1
1661 NEXT
1662 CLOSE
1663 RESTORE
1664 RETURN
2000 '**********************************************************************
2001 '*
2002 '* SUBROUTINE FUNCTION : GET VERIFY STATE
2003 '*
2004 '* VERSION : 1.0
2005 '*
2006 '* DATE LAST UPDATED : SEPT 25, 1983
2007 '*
2008 '* AUTHOR : JAMES P MORGAN
2009 '*
2010 '* CALL FORMAT :
2011 '* ---------------------
2012 '* CALL OFFSET%(RETURN.CODE%)
2013 '*
2014 '* PARAMETERS PASSED : RETURN.CODE%=0
2015 '*
2016 '* PARAMETERS RETURNED : RETURN.CODE% (00=VERIFY OFF,01=VERIFY ON)
2017 '*
2018 '**************************************************************************
2019 CLS
2020 CLOSE
2021 DEF SEG
2022 DEFINT A-Z
2023 DIM SUBRT%(40)
2024 OFFSET%=0
2025 VERIFY.STATE%=0
2026 RETURN.CODE%=0
2027 GOSUB 2051
2028 GOSUB 2035
2029 OFFSET%=VARPTR(SUBRT%(0))
2030 CALL OFFSET%(RETURN.CODE%)
2031 VERIFY.STATE%=RETURN.CODE%
2032 PRINT "VERIFY STATE = ";VERIFY.STATE%
2033 PRINT "RETURN CODE = ";RETURN.CODE%
2034 END
2035 RESTORE
2036 FOR I=0 TO 17
2037 READ J
2038 POKE (VARPTR(SUBRT%(0))+I),J
2039 NEXT
2040 RETURN
2041 DATA &H55
2042 DATA &H89,&HE5
2043 DATA &H30,&HC0
2044 DATA &HB4,&H54
2045 DATA &HCD,&H21
2046 DATA &H8B,&H76,&H06
2047 DATA &H88,&H04
2048 DATA &H5D
2049 DATA &HCA,&H02,&H00
2050 END
2051 RESTORE
2052 FILENAME$="A:"+"VERSTATE.EMU"
2053 PGM.LEN=17
2054 OPEN FILENAME$ AS #1 LEN=1
2055 FIELD #1, 1 AS PGM.BYTE$
2056 FOR I=0 TO PGM.LEN
2057 READ J
2058 LSET PGM.BYTE$=CHR$(J)
2059 PUT #1
2060 NEXT
2061 CLOSE
2062 RESTORE
2063 RETURN
2500 '**********************************************************************
2501 '*
2502 '* SUBROUTINE FUNCTION : SET/RESET VERIFY SWITCH
2503 '*
2504 '* VERSION : 1.0
2505 '*
2506 '* DATE LAST UPDATED : SEPT 25, 1983
2507 '*
2508 '* AUTHOR : JAMES P MORGAN
2509 '*
2510 '* CALL FORMAT :
2511 '* ---------------------
2512 '* CALL OFFSET%(RETURN.CODE%)
2513 '*
2514 '* PARAMETERS PASSED : RETURN.CODE%=0
2515 '*
2516 '* PARAMETERS RETURNED : RETURN.CODE% (00=VERIFY OFF,01=VERIFY ON)
2517 '*
2518 '* COMMENTS :
2519 '* THIS ROUTINE WILL FLIP/FLOP THE VERIFY STATE
2520 '* SWITCH FROM ON/OFF OR OFF/ON AND RETURN THE CURRENT
2521 '* STATE.
2522 '* WHEN ON,DOS WILL PERFORM A VERIFY OPERATION EACH
2523 '* TIME IT PERFORMS A DISKETTE WRITE TO ASSURE PROPER
2524 '* DATA RECORDING. ALTHOUGH RECORDING ERRORS ARE VERY
2525 '* RARE, THIS FUNCTION IS PROVIDED FOR THOSE USER
2526 '* APPLICATIONS IN WHICH YOU MAY WISH TO VERIFY THE
2527 '* PROPER RECORDING OF CRITICAL DATA.
2528 '**************************************************************************
2529 CLS
2530 CLOSE
2531 DEF SEG
2532 DEFINT A-Z
2533 DIM SUBRT%(40)
2534 OFFSET%=0
2535 VERIFY.STATE%=0
2536 RETURN.CODE%=0
2537 GOSUB 2566
2538 GOSUB 2545
2539 OFFSET%=VARPTR(SUBRT%(0))
2540 CALL OFFSET%(RETURN.CODE%)
2541 VERIFY.STATE%=RETURN.CODE%
2542 PRINT "VERIFY STATE = ";VERIFY.STATE%
2543 PRINT "RETURN CODE = ";RETURN.CODE%
2544 END
2545 RESTORE
2546 FOR I=0 TO 27
2547 READ J
2548 POKE (VARPTR(SUBRT%(0))+I),J
2549 NEXT
2550 RETURN
2551 DATA &H55
2552 DATA &H89,&HE5
2553 DATA &HB4,&H54
2554 DATA &HCD,&H21
2555 DATA &H34,&H01
2556 DATA &HB2,&H00
2557 DATA &HB4,&H2E
2558 DATA &HCD,&H21
2559 DATA &HB4,&H54
2560 DATA &HCD,&H21
2561 DATA &H8B,&H76,&H06
2562 DATA &H88,&H04
2563 DATA &H5D
2564 DATA &HCA,&H02,&H00
2565 END
2566 RESTORE
2567 FILENAME$="A:"+"VERRESET.EMU"
2568 PGM.LEN=17
2569 OPEN FILENAME$ AS #1 LEN=1
2570 FIELD #1, 1 AS PGM.BYTE$
2571 FOR I=0 TO PGM.LEN
2572 READ J
2573 LSET PGM.BYTE$=CHR$(J)
2574 PUT #1
2575 NEXT
2576 CLOSE
2577 RESTORE
2578 RETURN
3000 '**********************************************************************
3001 '*
3002 '* SUBROUTINE FUNCTION : GET SYSTEM TIME
3003 '*
3004 '* VERSION : 1.0
3005 '*
3006 '* DATE LAST UPDATED : SEPT 25, 1983
3007 '*
3008 '* AUTHOR : JAMES P MORGAN
3009 '*
3010 '* CALL FORMAT :
3011 '* ---------------------
3012 '* CALL OFFSET%(HOURS%,MINUTES%,SECONDS%,HUNDREDS.SECONDS%,RETURN.CODE%)
3013 '*
3014 '* PARAMETERS PASSED : HOURS%=0
3015 '* MINUTES%=0
3016 '* SECONDS%-0
3017 '* HUNDREDS.SECONDS%=0
3018 '* RETURN.CODE%=0
3019 '*
3020 '* PARAMETERS RETURNED : HOURS% (0-23)
3021 '* MINUTES% (0-59)
3022 '* SECONDS% (0-59)
3023 '* HUNDREDS.SECONDS% (0-99)
3024 '* RETURN.CODE%
3025 '*
3026 '* COMMENTS :
3027 '* THIS FORMAT IS READILY CONVERTED TO A PRINTABLE
3028 '* FORM YET CAN BE USED FOR CALCULATIONS , SUCH AS
3029 '* SUBTRACTING ONE TIME VALUE FROM ANOTHER.
3030 '*
3031 '**************************************************************************
3032 CLS
3033 CLOSE
3034 DEF SEG
3035 DEFINT A-Z
3036 DIM SUBRT%(40)
3037 OFFSET%=0
3038 HOURS%=0
3039 MINUTES%=0
3040 SECONDS%=0
3041 HUNDREDS.SECONDS%=0
3042 RETURN.CODE%=0
3043 GOSUB 3080
3044 GOSUB 3054
3045 OFFSET%=VARPTR(SUBRT%(0))
3046 CALL OFFSET%(HOURS%,MINUTES%,SECONDS%,HUNDREDS.SECONDS%,RETURN.CODE%)
3047 PRINT "HOURS = ";HOURS%
3048 PRINT "MINUTES = ";MINUTES%
3049 PRINT "SECONDS = ";SECONDS%
3050 PRINT "1/100 SECONDS = ";HUNDREDS.SECONDS%
3051 PRINT "RETURN CODE = ";RETURN.CODE%
3052 PRINT "CURRENT TIME = ";TIME$
3053 END
3054 RESTORE
3055 FOR I=0 TO 41
3056 READ J
3057 POKE (VARPTR(SUBRT%(0))+I),J
3058 NEXT
3059 RETURN
3060 DATA &H55
3061 DATA &H89,&HE5
3062 DATA &H31,&HC9
3063 DATA &H31,&HD2
3064 DATA &HB4,&H2C
3065 DATA &HCD,&H21
3066 DATA &H8B,&H76,&H0E
3067 DATA &H88,&H2C
3068 DATA &H8B,&H76,&H0C
3069 DATA &H88,&H0C
3070 DATA &H8B,&H76,&H0A
3071 DATA &H88,&H34
3072 DATA &H8B,&H76,&H08
3073 DATA &H88,&H14
3074 DATA &H30,&HD2
3075 DATA &H8B,&H76,&H06
3076 DATA &H88,&H14
3077 DATA &H5D
3078 DATA &HCA,&H0A,&H00
3079 END
3080 RESTORE
3081 FILENAME$="A:"+"GETTIME.EMU"
3082 PGM.LEN=41
3083 OPEN FILENAME$ AS #1 LEN=1
3084 FIELD #1, 1 AS PGM.BYTE$
3085 FOR I=0 TO PGM.LEN
3086 READ J
3087 LSET PGM.BYTE$=CHR$(J)
3088 PUT #1
3089 NEXT
3090 CLOSE
3091 RESTORE
3092 RETURN
3500 '**********************************************************************
3501 '*
3502 '* SUBROUTINE FUNCTION : GET SYSTEM DATE
3503 '*
3504 '* VERSION : 1.0
3505 '*
3506 '* DATE LAST UPDATED : SEPT 25, 1983
3507 '*
3508 '* AUTHOR : JAMES P MORGAN
3509 '*
3510 '* CALL FORMAT :
3511 '* ---------------------
3512 '* CALL OFFSET%(CENTURY%,YEAR%,MONTH%,DAY%,RETURN.CODE%)
3513 '*
3514 '* PARAMETERS PASSED : CENTURY%=0
3515 '* YEAR%=0
3516 '* MONTH%=0
3517 '* DAY%=0
3518 '* RETURN.CODE%=0
3519 '*
3520 '* PARAMETERS RETURNED : CENTURY%
3521 '* YEAR%
3522 '* MONTH%
3523 '* DAY%
3524 '* RETUURN.CODE%
3525 '*
3526 '* COMMENTS :
3527 '* IF THE TIME-OF-DAY CLOCK ROLLS OVER TO THE NEXT
3528 '* DAY, THE DATA IS ADJUSTED ACCORDINGLY, TAKING
3529 '* INTO ACCOUNT THE NUMBER OF DAYS IN EACH MONTH AND
3530 '* LEAP YEARS.
3531 '**************************************************************************
3532 CLS
3533 CLOSE
3534 DEF SEG
3535 DEFINT A-Z
3536 DIM SUBRT%(40)
3537 OFFSET%=0
3538 CENTURY%=0
3539 YEAR%=0
3540 MONTH%=0
3541 DAY%=0
3542 RETURN.CODE%=0
3543 GOSUB 3581
3544 GOSUB 3555
3545 OFFSET%=VARPTR(SUBRT%(0))
3546 CALL OFFSET%(CENTURY%,YEAR%,MONTH%,DAY%,RETURN.CODE%)
3547 PRINT "CENTURY = ";CENTURY%
3548 PRINT "YEAR = ";YEAR%
3549 PRINT "CENTURY + YEAR = ";CENTURY%+YEAR%
3550 PRINT "MONTH = ";MONTH%
3551 PRINT "DAY = ";DAY%
3552 PRINT "RETURN CODE = ";RETURN.CODE%
3553 PRINT "CURRENT DATE = ";DATE$
3554 END
3555 RESTORE
3556 FOR I=0 TO 42
3557 READ J
3558 POKE (VARPTR(SUBRT%(0))+I),J
3559 NEXT
3560 RETURN
3561 DATA &H55
3562 DATA &H89,&HE5
3563 DATA &H31,&HC9
3564 DATA &H31,&HD2
3565 DATA &HB4,&H2A
3566 DATA &HCD,&H21
3567 DATA &H8B,&H76,&H0E
3568 DATA &H88,&H6C,&H01
3569 DATA &H8B,&H76,&H0C
3570 DATA &H88,&H0C
3571 DATA &H8B,&H76,&H0A
3572 DATA &H88,&H34
3573 DATA &H8B,&H76,&H08
3574 DATA &H88,&H14
3575 DATA &H8B,&H76,&H06
3576 DATA &H31,&HD2
3577 DATA &H89,&H14
3578 DATA &H5D
3579 DATA &HCA,&H0A,&H00
3580 END
3581 RESTORE
3582 FILENAME$="A:"+"GETDATE.EMU"
3583 PGM.LEN=42
3584 OPEN FILENAME$ AS #1 LEN=1
3585 FIELD #1, 1 AS PGM.BYTE$
3586 FOR I=0 TO PGM.LEN
3587 READ J
3588 LSET PGM.BYTE$=CHR$(J)
3589 PUT #1
3590 NEXT
3591 CLOSE
3592 RESTORE
3593 RETURN
4000 '**********************************************************************
4001 '*
4002 '* SUBROUTINE FUNCTION : GET DOS VERSION NUMBER
4003 '*
4004 '* VERSION : 1.0
4005 '*
4006 '* DATE LAST UPDATED : SEPT 25, 1983
4007 '*
4008 '* AUTHOR : JAMES P MORGAN
4009 '*
4010 '* CALL FORMAT :
4011 '* ---------------------
4012 '* CALL OFFSET%(MAJOR.VERSION%,MINOR.VERSION%,RETURN.CODE%)
4013 '*
4014 '* PARAMETERS PASSED : MAJOR.VERSION%=0
4015 '* MINOR.VERSION%=0
4016 '* RETURN.CODE%=0
4017 '*
4018 '* PARAMETERS RETURNED : MAJOR.VERSION% (MAJOR DOS VERSION NUMBER)
4019 '* MINOR.VERSION% (MINOR DOS VERSION NUMBER)
4020 '* RETURN.CODE%
4021 '*
4022 '* COMMENTS :
4023 '* IF THE MAJOR.VERSION% RETURNS ZERO(0), IT IS
4024 '* ASSUMED THAT THIS IS A PRE-DOS 2.0 SYSTEM.
4025 '*
4026 '**************************************************************************
4027 CLS
4028 CLOSE
4029 DEF SEG
4030 DEFINT A-Z
4031 DIM SUBRT%(40)
4032 OFFSET%=0
4033 MAJOR.VERSION%=0
4034 MINOR.VERSION%=0
4035 RETURN.CODE%=0
4036 GOSUB 4064
4037 GOSUB 4044
4038 OFFSET%=VARPTR(SUBRT%(0))
4039 CALL OFFSET%(MAJOR.VERSION%,MINOR.VERSION%,RETURN.CODE%)
4040 PRINT "MAJOR.VERSION = ";MAJOR.VERSION%
4041 PRINT "MINOR VERSION = ";MINOR.VERSION%
4042 PRINT "RETURN CODE = ";RETURN.CODE%
4043 END
4044 RESTORE
4045 FOR I=0 TO 27
4046 READ J
4047 POKE (VARPTR(SUBRT%(0))+I),J
4048 NEXT
4049 RETURN
4050 DATA &H55
4051 DATA &H89,&HE5
4052 DATA &HB4,&H30
4053 DATA &HCD,&H21
4054 DATA &H8B,&H76,&H0A
4055 DATA &H88,&H04
4056 DATA &H8B,&H76,&H08
4057 DATA &H88,&H24
4058 DATA &H8B,&H76,&H06
4059 DATA &H31,&HDB
4060 DATA &H89,&H1C
4061 DATA &H5D
4062 DATA &HCA,&H06,&H00
4063 END
4064 RESTORE
4065 FILENAME$="A:"+"DOSVER.EMU"
4066 PGM.LEN=27
4067 OPEN FILENAME$ AS #1 LEN=1
4068 FIELD #1, 1 AS PGM.BYTE$
4069 FOR I=0 TO PGM.LEN
4070 READ J
4071 LSET PGM.BYTE$=CHR$(J)
4072 PUT #1
4073 NEXT
4074 CLOSE
4075 RESTORE
4076 RETURN
4500 '**********************************************************************
4501 '*
4502 '* SUBROUTINE FUNCTION : GET DISK FREE SPACE
4503 '*
4504 '* VERSION : 1.0
4505 '*
4506 '* DATE LAST UPDATED : SEPT 25, 1983
4507 '*
4508 '* AUTHOR : JAMES P MORGAN
4509 '*
4510 '* CALL FORMAT :
4511 '* ---------------------
4512 '* CALL OFFSET%(DRIVE%,NUM.ALLOC.UNITS%,NUM.SEC.PER.UNIT%,SECTOR.SIZE%,AVAIL.CLUSTERS%,RETURN.CODE%)
4513 '*
4514 '* PARAMETERS PASSED : DRIVE% (0=DEFAULT,1=A,2=B..ECT)
4515 '* NUM.ALLOC.UNITS%=0
4516 '* NUM.SEC.PER.UNIT%=0
4517 '* SECTOR.SIZE%=0
4518 '* AVAIL.CLUSTERS%=0
4519 '* RETURN.CODE%=0
4520 '*
4521 '* PARAMETERS RETURNED : DRIVE%
4522 '* NUM.ALLOC.UNITS% (TOTAL CLUSTERS ON THE
4523 '* DRIVE)
4524 '*
4525 '* NUM.SEC.PER.UNIT% (NUMBER OF SECTORS PER
4526 '* CLUSTER)
4527 '*
4528 '* SECTOR.SIZE% (BYTES PER SECTOR)
4529 '*
4530 '* AVAIL.CLUSTERS% (NUMBER OF AVAILABLE CLUSTERS)
4531 '*
4532 '* RETURN.CODE% (255=INVALID DRIVE)
4533 '*
4534 '*
4535 '* COMMENTS :
4536 '* THIS DOS FUNCTION CALL RETURNS THE SANE INFO
4537 '* (EXCEPT FOR THE FAT POINTER) AS THE GET FAT POINTER
4538 '* CALL (1BH) DID UNDER PREVIOUS VERSIONS OF DOS.
4539 '**************************************************************************
4540 CLS
4541 CLOSE
4542 DEF SEG
4543 DEFINT A-Z
4544 DIM SUBRT%(40)
4545 OFFSET%=0
4546 DRIVE%=1
4547 NUM.ALLOC.UNITS%=0
4548 NUM.SEC.PER.UNIT%=0
4549 SECTOR.SIZE%=0
4550 AVAIL.CLUSTERS%=0
4551 RETURN.CODE%=0
4552 GOSUB 4596
4553 GOSUB 4564
4554 OFFSET%=VARPTR(SUBRT%(0))
4555 CALL OFFSET%(DRIVE%,NUM.ALLOC.UNITS%,NUM.SEC.PER.UNIT%,SECTOR.SIZE%,AVAIL.CLUSTERS%,RETURN.CODE%)
4556 PRINT "DRIVE REQUESTED = ";DRIVE%
4557 PRINT "ALLOC CLUSTERS = ";NUM.ALLOC.UNITS%
4558 PRINT "SECTORS PER CLUSTE= ";NUM.SEC.PER.UNIT%
4559 PRINT "BYTES PER SECTOR = ";SECTOR.SIZE%
4560 PRINT "AVAIL. CLUSTERS = ";AVAIL.CLUSTERS%
4561 PRINT "FREE SPACE = ";SECTOR.SIZE%*NUM.SEC.PER.UNIT%*AVAIL.CLUSTERS%
4562 PRINT "RETURN CODE = ";RETURN.CODE%
4563 END
4564 RESTORE
4565 FOR I=0 TO 60
4566 READ J
4567 POKE (VARPTR(SUBRT%(0))+I),J
4568 NEXT
4569 RETURN
4570 DATA &H55
4571 DATA &H89,&HE5
4572 DATA &H31,&HC0
4573 DATA &H31,&HDB
4574 DATA &H31,&HC9
4575 DATA &H31,&HD2
4576 DATA &H8B,&H76,&H10
4577 DATA &H8A,&H14
4578 DATA &HB4,&H36
4579 DATA &HCD,&H21
4580 DATA &H8B,&H76,&H0E
4581 DATA &H88,&H14
4582 DATA &H88,&H74,&H01
4583 DATA &H8B,&H76,&H0C
4584 DATA &H88,&H04
4585 DATA &H88,&H64,&H01
4586 DATA &H8B,&H76,&H0A
4587 DATA &H88,&H0C
4588 DATA &H88,&H6C,&H01
4589 DATA &H8B,&H76,&H08
4590 DATA &H88,&H1C
4591 DATA &H88,&H7C,&H01
4592 DATA &H8B,&H76,&H06
4593 DATA &H89,&H04
4594 DATA &H5D
4595 DATA &HCA,&H0C,&H00
4596 RESTORE
4597 FILENAME$="A:"+"FREESPAC.EMU"
4598 PGM.LEN=60
4599 OPEN FILENAME$ AS #1 LEN=1
4600 FIELD #1, 1 AS PGM.BYTE$
4601 FOR I=0 TO PGM.LEN
4602 READ J
4603 LSET PGM.BYTE$=CHR$(J)
4604 PUT #1
4605 NEXT
4606 CLOSE
4607 RESTORE
4608 RETURN
5000 '**********************************************************************
5001 '*
5002 '* SUBROUTINE FUNCTION : CHANGE/CREATE/REMOVE A DIRECTORY
5003 '*
5004 '* VERSION : 1.0
5005 '*
5006 '* DATE LAST UPDATED : SEPT 25, 1983
5007 '*
5008 '* AUTHOR : JAMES P MORGAN
5009 '*
5010 '* CALL FORMAT :
5011 '* ---------------------
5012 '* CALL OFFSET%(FUNCTION.CALL%,ASCIIZ.STRING$,RETURN.CODE%)
5013 '*
5014 '* PARAMETERS PASSED : FUNCTION.CALL% (&H39 - MKDIR
5015 '* &H3A - RMDIR
5016 '* &H3B - CHDIR)
5017 '*
5018 '* ASCIIZ.STRING$ (THE ASCII STRING OF THE
5019 '* DIRECTORY TO BE USED)
5020 '*
5021 '* RETURN.CODE%=0
5022 '*
5023 '* PARAMETERS RETURNED : FUNCTION.CALL%
5024 '* ASCIIZ.STRING$
5025 '* RETURN.CODE% (SEE ERROR CODE LIST)
5026 '*
5027 '*
5028 '* COMMENTS :
5029 '*
5030 '* EACH OF THE DIRECTORY MAINTENANCE FUNCTIONS ARE DISCUSSED SEPARATELY
5031 '*
5032 '* MKDIR ------------- CREATE A DIRECTORY
5033 '*
5034 '* THE ASCIIZ STRING CONTAINS THE DRIVE AND DIRECTORY
5035 '* PATH NAMES. IF ANY MEMBER OF THE DIRECTORY PATH DOES NOT
5036 '* EXIST THEN THE DIRECTORY PATH IS NOT CHANGED. ON RETURN
5037 '* A NEW DIRECTORY IS CREATED AT THE END OF THE SPECIFIED
5038 '* PATH.
5039 '*
5040 '* RMDIR ------------- REMOVE A SUB-DIRECTORY
5041 '*
5042 '* THE ASCIIZ STRING CONTAINS THE DRIVE AND DIRECTORY
5043 '* PATH NAMES. THE SPECIFIED DIRECTORY IS REMOVED FROM THE
5044 '* STRUCTURE. THE CURRENT DIRECTORY CANNOT BE REMOVED.
5045 '*
5046 '* CHDIR ------------- CHANGE THE CURRENT DIRECTORY
5047 '*
5048 '* THE ASCIIZ STRING CONTAINS THE DRIVE AND DIRECTORY
5049 '* PATH NAMES. IF ANY MEMBER OF THE DIRECTORY DOES NOT EXIST
5050 '* THEN THE DIRECTORY PATH IS NOT CHANGED.
5051 '*
5052 '*************************************************************************
5053 CLS
5054 CLOSE
5055 DEF SEG
5056 DEFINT A-Z
5057 DIM SUBRT%(40)
5058 OFFSET%=0
5059 FUNCTION.CALL%=&H3B
5060 FUNCTION.TYPE$=""
5061 PATH.NAME$="C:\EMULATOR"
5062 ASCIIZ.STRING$=PATH.NAME$+CHR$(0)
5063 RETURN.CODE%=0
5064 GOSUB 5099
5065 GOSUB 5076
5066 OFFSET%=VARPTR(SUBRT%(0))
5067 CALL OFFSET%(FUNCTION.CALL%,ASCIIZ.STRING$,RETURN.CODE%)
5068 IF FUNCTION.CALL%=&H39 THEN FUNCTION.TYPE$="CREATE A SUB-DIRECTORY"
5069 IF FUNCTION.CALL%=&H3A THEN FUNCTION.TYPE$="REMOVE A DIRECTORY"
5070 IF FUNCTION.CALL%=&H3B THEN FUNCTION.TYPE$="CHANGE THE CURRENT DIRECTORY"
5071 PRINT "FUNCTION CALL CODE= ";FUNCTION.CALL%
5072 PRINT "FUNCTION TYPE = ";FUNCTION.TYPE$
5073 PRINT "PATH IS = ";PATH.NAME$
5074 PRINT "RETURN CODE = ";RETURN.CODE%
5075 END
5076 RESTORE
5077 FOR I=0 TO 30
5078 READ J
5079 POKE (VARPTR(SUBRT%(0))+I),J
5080 NEXT
5081 RETURN
5082 DATA &H55
5083 DATA &H89,&HE5
5084 DATA &H31,&HC0
5085 DATA &H8B,&H76,&H0A
5086 DATA &H8A,&H24
5087 DATA &H8B,&H76,&H08
5088 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC COMPILER
5089 DATA &H8B,&H54,&H01
5090 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
5091 'DATA &H8B,&H54,&H02
5092 DATA &HCD,&H21
5093 DATA &H72,&H02
5094 DATA &H30,&HC0
5095 DATA &H8B,&H76,&H06
5096 DATA &H88,&H04
5097 DATA &H5D
5098 DATA &HCA,&H06,&H00
5099 RESTORE
5100 FILENAME$="A:"+"DIRMAINT.EMU"
5101 PGM.LEN=30
5102 OPEN FILENAME$ AS #1 LEN=1
5103 FIELD #1, 1 AS PGM.BYTE$
5104 FOR I=0 TO PGM.LEN
5105 READ J
5106 LSET PGM.BYTE$=CHR$(J)
5107 PUT #1
5108 NEXT
5109 CLOSE
5110 RESTORE
5111 RETURN
5500 '**********************************************************************
5501 '*
5502 '* SUBROUTINE FUNCTION : GET/SET CURRENT DEFAULT DISK DRIVE
5503 '*
5504 '* VERSION : 1.0
5505 '*
5506 '* DATE LAST UPDATED : SEPT 25, 1983
5507 '*
5508 '* AUTHOR : JAMES P MORGAN
5509 '*
5510 '* CALL FORMAT :
5511 '* ---------------------
5512 '* CALL OFFSET%(DRIVE%,LOGICAL.DRIVES%,RETURN.CODE%)
5513 '*
5514 '* PARAMETERS PASSED : DRIVE% (0=A,2=B..ECT)
5515 '* LOGICAL.DRIVES%=0
5516 '* RETURN.CODE%=0
5517 '*
5518 '* PARAMETERS RETURNED : DRIVE%
5519 '* LOGICAL.DRIVES% (0-MAX LOGICAL DRIVES)
5520 '* RETURN.CODE% (CURRENT DEFAULT DRIVE)
5521 '*
5522 '*
5523 '* COMMENTS :
5524 '* THIS SUBROUTINE WILL ASSIGN, DRIVE%, AS THE
5525 '* DEFAULT DRIVE (IF VALID). THE NUMBER OF LOGICAL
5526 '* DRIVES (TOTAL DISKETTE AND FIXED) ARE RETURNED.
5527 '* IF THE SYSTEM HAS ONLY ONE DISKETTE DRIVE, IT WILL
5528 '* BE COUNTED AS TWO TO BE CONSISTANT WITH THE
5529 '* PHILOSOPHY OF THINKING OF THE SYSTEM AS HAVING
5530 '* LOGICAL DRIVES "A" AND "B".
5531 '* AS A SIDE EFFECT, IF YOU GIVE THIS SUBROUTINE
5532 '* AN INVALID DRIVE (255), IT WILL ONLY RETURN THE
5533 '* CURRENT DEFAULT DRIVE SO YOU DO NOT NEED TO DO
5534 '* A DOS FUNCTION CALL &H19, CURRENT DISK.
5535 '*
5536 '* BIOS EQUIPMENT CHECK DETERMINATION (INT 11H)
5537 '* CAN BE USED TO DETERMINE THE NUMBER OF ACTUAL
5538 '* PHYSICAL DRIVES.
5539 '*
5540 '*************************************************************************
5541 CLS
5542 CLOSE
5543 DEF SEG
5544 DEFINT A-Z
5545 DIM SUBRT%(40)
5546 OFFSET%=0
5547 DRIVE%=0
5548 LOGICAL.DRIVES%=0
5549 RETURN.CODE%=0
5550 GOSUB 5578
5551 GOSUB 5558
5552 OFFSET%=VARPTR(SUBRT%(0))
5553 CALL OFFSET%(DRIVE%,LOGICAL.DRIVES%,RETURN.CODE%)
5554 PRINT "DEFAULT REQUESTED = ";DRIVE%
5555 PRINT "LOGICAL DRIVES = ";LOGICAL.DRIVES%
5556 PRINT "NEW DEFAULT DRIVE = ";RETURN.CODE%
5557 END
5558 RESTORE
5559 FOR I=0 TO 29
5560 READ J
5561 POKE (VARPTR(SUBRT%(0))+I),J
5562 NEXT
5563 RETURN
5564 DATA &H55
5565 DATA &H89,&HE5
5566 DATA &H8B,&H76,&H0A
5567 DATA &H8A,&H14
5568 DATA &HB4,&H0E
5569 DATA &HCD,&H21
5570 DATA &H8B,&H76,&H08
5571 DATA &H88,&H04
5572 DATA &HB4,&H19
5573 DATA &HCD,&H21
5574 DATA &H8B,&H76,&H06
5575 DATA &H88,&H04
5576 DATA &H5D
5577 DATA &HCA,&H06,&H00
5578 RESTORE
5579 FILENAME$="A:"+"DRIVEDEF.EMU"
5580 PGM.LEN=29
5581 OPEN FILENAME$ AS #1 LEN=1
5582 FIELD #1, 1 AS PGM.BYTE$
5583 FOR I=0 TO PGM.LEN
5584 READ J
5585 LSET PGM.BYTE$=CHR$(J)
5586 PUT #1
5587 NEXT
5588 CLOSE
5589 RESTORE
5590 RETURN
6000 '**********************************************************************
6001 '*
6002 '* SUBROUTINE FUNCTION : GET CURRENT DIRECTORY
6003 '*
6004 '* VERSION : 1.0
6005 '*
6006 '* DATE LAST UPDATED : SEPT 25, 1983
6007 '*
6008 '* AUTHOR : JAMES P MORGAN
6009 '*
6010 '* CALL FORMAT :
6011 '* ---------------------
6012 '* CALL OFFSET%(DRIVE%,ASCIIZ.STRING$,RETURN.CODE%)
6013 '*
6014 '* PARAMETERS PASSED : DRIVE% (0=DEFAULT,1=A,2=B..ECT)
6015 '* ASCIIZ.STRING$ (AT LEAST A 64 BYTE
6016 '* CHARACTER STRING RETURN
6017 '* AREA)
6018 '*
6019 '* RETURN.CODE%=0
6020 '*
6021 '* PARAMETERS RETURNED : DRIVE%
6022 '* ASCIIZ.STRING$ (CURRENT DIRECTORY)
6023 '* RETURN.CODE% (SEE ERROR CODE LIST)
6024 '*
6025 '*
6026 '* COMMENTS :
6027 '* THIS SUBROUTINE WILL RETURN THE CURRENT DIRECTORY
6028 '* FOR THE SPECIFIED DRIVE. THE FULL PATH NAME ,
6029 '* STARTING WITH THE ROOT DIRECTORY IS RETURNED.
6030 '* THE DRIVE LETTER WILL NOT BE PART OF THE RETURNED
6031 '* STRING. THE STRING WILL NOT BEGIN WITH THE "\" AND
6032 '* WILL BE TERMINATED WITH A BYTE CONTAINING A HEX 00.
6033 '*
6034 '*************************************************************************
6035 CLS
6036 CLOSE
6037 DEF SEG
6038 DEFINT A-Z
6039 DIM SUBRT%(40)
6040 OFFSET%=0
6041 DRIVE%=0
6042 ASCIIZ.STRING$=STRING$(80,0)
6043 CURRENT.DIRECTORY$=""
6044 RETURN.CODE%=0
6045 GOSUB 6079
6046 GOSUB 6057
6047 OFFSET%=VARPTR(SUBRT%(0))
6048 CALL OFFSET%(DRIVE%,ASCIIZ.STRING$,RETURN.CODE%)
6049 IF RETURN.CODE%<>0 THEN CURRENT.DIRECTORY$="INVALID DRIVE SPECIFIED":GOTO 6053
6050 INSTR.LOC=INSTR(ASCIIZ.STRING$,CHR$(0))
6051 IF INSTR.LOC<2 THEN CURRENT.DIRECTORY$="\":GOTO 6053
6052 CURRENT.DIRECTORY$="\"+LEFT$(ASCIIZ.STRING$,INSTR.LOC-1)
6053 PRINT "DRIVE REQUESTED = ";DRIVE%
6054 PRINT "CURRENT DIRECTORY = ";CURRENT.DIRECTORY$
6055 PRINT "RETURN CODE = ";RETURN.CODE%
6056 END
6057 RESTORE
6058 FOR I=0 TO 28
6059 READ J
6060 POKE (VARPTR(SUBRT%(0))+I),J
6061 NEXT
6062 RETURN
6063 DATA &H55
6064 DATA &H89,&HE5
6065 DATA &H8B,&H76,&H0A
6066 DATA &H8A,&H14
6067 DATA &H8B,&H5E,&H08
6068 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC COMPILER
6069 DATA &H8B,&H77,&H01
6070 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
6071 'DATA &H8B,&H77,&H02
6072 DATA &H31,&HC0
6073 DATA &HB4,&H47
6074 DATA &HCD,&H21
6075 DATA &H8B,&H76,&H06
6076 DATA &H88,&H04
6077 DATA &H5D
6078 DATA &HCA,&H06,&H00
6079 RESTORE
6080 FILENAME$="A:"+"DIRCURR.EMU"
6081 PGM.LEN=28
6082 OPEN FILENAME$ AS #1 LEN=1
6083 FIELD #1, 1 AS PGM.BYTE$
6084 FOR I=0 TO PGM.LEN
6085 READ J
6086 LSET PGM.BYTE$=CHR$(J)
6087 PUT #1
6088 NEXT
6089 CLOSE
6090 RESTORE
6091 RETURN
6500 '**********************************************************************
6501 '*
6502 '* SUBROUTINE FUNCTION : RENAME A FILE
6503 '*
6504 '* VERSION : 1.0
6505 '*
6506 '* DATE LAST UPDATED : SEPT 25, 1983
6507 '*
6508 '* AUTHOR : JAMES P MORGAN
6509 '*
6510 '* CALL FORMAT :
6511 '* ---------------------
6512 '* CALL OFFSET%(ASCIIZ.STRING1$,ASCIIZ.STRING2$,RETURN.CODE%)
6513 '*
6514 '* PARAMETERS PASSED : ASCIIZ.STRING1$ (THE ASCII STRING OF THE
6515 '* CURRENT FILE NAME)
6516 '*
6517 '* ASCIIZ.STRING2$ (THE ASCII STRING OF THE
6518 '* NEW FILE NAME)
6519 '*
6520 '* RETURN.CODE%=0
6521 '*
6522 '* PARAMETERS RETURNED : ASCIIZ.STRING1$
6523 '* ASCIIZ.STRING2$
6524 '* RETURN.CODE% (SEE ERROR CODE LIST)
6525 '*
6526 '*
6527 '* COMMENTS :
6528 '* THIS SUBROUTINE WILL RENAME A DIRECTORY ENTRY
6529 '* ASSOCIATED WITH A FILE NAME.
6530 '* THE ASCIIZ.STRING CONSISTS OF A DRIVE, PATH AND
6531 '* FILE NAME .GLOBAL FILE NAME CHARACTERS ARE NOT
6532 '* ALLOWED IN ANY PART OF THE STRING.
6533 '* IF A DRIVE IS SPECIFIED IN THE SECOND STRING, IT
6534 '* MUST BE THE SAME AS THE DRIVE SPECIFIED OR IMPLIED
6535 '* IN THE FIRST STRING. THE DIRECTORY PATHS NEED NOT BE
6536 '* THE SAME, ALLOWING A FILE TO BE MOVED TO ANOTHER
6537 '* DIRECTORY AND RENAMED IN THE PROCESS.
6538 '*
6539 '*
6540 '*************************************************************************
6541 CLS
6542 CLOSE
6543 DEF SEG
6544 DEFINT A-Z
6545 DIM SUBRT%(40)
6546 OFFSET%=0
6547 ASCIIZ.STRING2$="A:\CNTLBRK.EMU"+CHR$(0)
6548 ASCIIZ.STRING1$="A:\CNTLBRAK.EMU"+CHR$(0)
6549 RETURN.CODE%=0
6550 GOSUB 6587
6551 GOSUB 6558
6552 OFFSET%=VARPTR(SUBRT%(0))
6553 CALL OFFSET%(ASCIIZ.STRING1$,ASCIIZ.STRING2$,RETURN.CODE%)
6554 PRINT "OLD FILE NAME = ";LEFT$(ASCIIZ.STRING1$,LEN(ASCIIZ.STRING1$)-1)
6555 PRINT "NEW FILE NAME = ";LEFT$(ASCIIZ.STRING2$,LEN(ASCIIZ.STRING2$)-1)
6556 PRINT "RETURN CODE = ";RETURN.CODE%
6557 END
6558 RESTORE
6559 FOR I=0 TO 37
6560 READ J
6561 POKE (VARPTR(SUBRT%(0))+I),J
6562 NEXT
6563 RETURN
6564 DATA &H55
6565 DATA &H89,&HE5
6566 DATA &H31,&HC0
6567 DATA &H31,&HD2
6568 DATA &H31,&HFF
6569 DATA &H8B,&H76,&H0A
6570 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC COMPILER
6571 DATA &H8B,&H54,&H01
6572 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
6573 'DATA &H8B,&H54,&H02
6574 DATA &H8B,&H76,&H08
6575 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC COMPILER
6576 DATA &H8B,&H7C,&H01
6577 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
6578 'DATA &H8B,&H7C,&H02
6579 DATA &HB4,&H56
6580 DATA &HCD,&H21
6581 DATA &H72,&H02
6582 DATA &H30,&HC0
6583 DATA &H8B,&H76,&H06
6584 DATA &H88,&H04
6585 DATA &H5D
6586 DATA &HCA,&H06,&H00
6587 RESTORE
6588 FILENAME$="A:"+"RENFILE.EMU"
6589 PGM.LEN=37
6590 OPEN FILENAME$ AS #1 LEN=1
6591 FIELD #1, 1 AS PGM.BYTE$
6592 FOR I=0 TO PGM.LEN
6593 READ J
6594 LSET PGM.BYTE$=CHR$(J)
6595 PUT #1
6596 NEXT
6597 CLOSE
6598 RESTORE
6599 RETURN
7000 '**********************************************************************
7001 '*
7002 '* SUBROUTINE FUNCTION : DELETE A FILE FROM A SPECIFIC DIRECTORY (UNLINK)
7003 '*
7004 '* VERSION : 1.0
7005 '*
7006 '* DATE LAST UPDATED : SEPT 25, 1983
7007 '*
7008 '* AUTHOR : JAMES P MORGAN
7009 '*
7010 '* CALL FORMAT :
7011 '* ---------------------
7012 '* CALL OFFSET%(ASCIIZ.STRING$,RETURN.CODE%)
7013 '*
7014 '* PARAMETERS PASSED : ASCIIZ.STRING$ (THE ASCII STRING OF THE
7015 '* FILE TO BE DELETED)
7016 '*
7017 '* RETURN.CODE%=0
7018 '*
7019 '* PARAMETERS RETURNED : ASCIIZ.STRING$
7020 '* RETURN.CODE% (SEE ERROR CODE LIST)
7021 '*
7022 '*
7023 '* COMMENTS :
7024 '* THIS SUBROUTINE WILL REMOVE A DIRECTORY ENTRY
7025 '* ASSOCIATED WITH A FILE NAME.
7026 '* THE ASCIIZ.STRING CONSISTS OF A DRIVE, PATH AND
7027 '* FILE NAME .GLOBAL FILE NAME CHARACTERS ARE NOT
7028 '* ALLOWED IN ANY PART OF THE STRING.
7029 '* READ-ONLY FILES CANNOT BE DELETED WITH THIS CALL.
7030 '* TO DELETE ONE OF THESE FILES, FIRST USE AN INT 43H
7031 '* CALL (OR THE CHANGE MODE SUBROUTINE INCLUDED WITH
7032 '* THIS SERIES OF SUBROUTINES) TO CHANGE THE FILES
7033 '* ATTRIBUTE TO ZERO(0) , THEN DELETE THE FILE.
7034 '*************************************************************************
7035 CLS
7036 CLOSE
7037 DEF SEG
7038 DEFINT A-Z
7039 DIM SUBRT%(40)
7040 OFFSET%=0
7041 ASCIIZ.STRING$="C:\CNTLBRK.EMU"+CHR$(0)
7042 RETURN.CODE%=0
7043 GOSUB 7073
7044 GOSUB 7050
7045 OFFSET%=VARPTR(SUBRT%(0))
7046 CALL OFFSET%(ASCIIZ.STRING$,RETURN.CODE%)
7047 PRINT "DELETED FILE NAME = ";LEFT$(ASCIIZ.STRING$,LEN(ASCIIZ.STRING$)-1)
7048 PRINT "RETURN CODE = ";RETURN.CODE%
7049 END
7050 RESTORE
7051 FOR I=0 TO 29
7052 READ J
7053 POKE (VARPTR(SUBRT%(0))+I),J
7054 NEXT
7055 RETURN
7056 DATA &H55
7057 DATA &H89,&HE5
7058 DATA &H31,&HC0
7059 DATA &H31,&HD2
7060 DATA &H8B,&H76,&H08
7061 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC COMPILER
7062 DATA &H8B,&H54,&H01
7063 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
7064 'DATA &H8B,&H54,&H02
7065 DATA &HB4,&H41
7066 DATA &HCD,&H21
7067 DATA &H72,&H02
7068 DATA &H30,&HC0
7069 DATA &H8B,&H76,&H06
7070 DATA &H88,&H04
7071 DATA &H5D
7072 DATA &HCA,&H04,&H00
7073 RESTORE
7074 FILENAME$="A:"+"DELFILE.EMU"
7075 PGM.LEN=29
7076 OPEN FILENAME$ AS #1 LEN=1
7077 FIELD #1, 1 AS PGM.BYTE$
7078 FOR I=0 TO PGM.LEN
7079 READ J
7080 LSET PGM.BYTE$=CHR$(J)
7081 PUT #1
7082 NEXT
7083 CLOSE
7084 RESTORE
7085 RETURN
7500 '**********************************************************************
7501 '*
7502 '* SUBROUTINE FUNCTION : CHANGE A FILE'S MODE (ATTRIBUTE)
7503 '*
7504 '* VERSION : 1.0
7505 '*
7506 '* DATE LAST UPDATED : SEPT 25, 1983
7507 '*
7508 '* AUTHOR : JAMES P MORGAN
7509 '*
7510 '* CALL FORMAT :
7511 '* ---------------------
7512 '* CALL OFFSET%(FUNCTION.CODE%,ATTRIBUTE%,ASCIIZ.STRING$,RETURN.CODE%)
7513 '*
7514 '* PARAMETERS PASSED : FUNCTION.CODE% (00=RETURN ATTRIBUTE
7515 '* 01=CHANGE ATTRIBUTE
7517 '*
7518 '* ATTRIBUTE% (FILE ATTRIBUTE)
7519 '*
7520 '* ASCIIZ.STRING$ (THE ASCII STRING OF THE
7521 '* FILE)
7522 '*
7523 '* RETURN.CODE%=0
7524 '*
7525 '* PARAMETERS RETURNED : FUNCTION.CODE%
7526 '* ATTRIBUTE% (FILE ATTRIBUTE)
7527 '* ASCIIZ.STRING$
7528 '* RETURN.CODE% (SEE ERROR CODE LIST)
7529 '*
7530 '*
7531 '* COMMENTS :
7532 '* IF THE FUNCTION.CODE% IS SET TO 00 THEN THE FILES
7533 '* CURRENT ATTRIBUTE WILL BE RETURNED, ELSE IF THE
7534 '* FUNCTION.CODE% IS SET TO 01, THE FILE'S ATTRIBUTE
7535 '* WILL BE CHANGED TO THE ATTRIBUTE% PASSED TO THE
7536 '* SUBROUTINE.
7537 '* THE ASCIIZ STRING CONSISTS OF THE DRIVE, PATH, AND
7538 '* FILENAME.
7539 '* SEEMS THAT THIS DOS FUNCTION CALL WILL NOT LET YOU
7540 '* CHANGE A FILES MODE TO THAT OF A VOLUME LABEL (&H8).
7541 '*
7542 '*
7543 '*************************************************************************
7544 '*
7545 '*************** FILE ATTRIBUTE BYTES - VALUES IN HEXADECIMAL ***********
7546 '*
7547 '* 01H - FILE IS READ ONLY (CAN BE USED WITH OTHERS)
7548 '* 02H - HIDDEN FILE
7549 '* 04H - SYSTEM FILE
7550 '* 08H - VOLUME LABEL (ONLY FIRST 11 CHARACTERS)
7551 '* 10H - SUB-DIRECTORY ENTRY
7552 '* 20H - ARCHIVE BIT (CAN BE USED WITH OTHERS
7553 '* SET WHEN FILE WRITTEN TO AND CLOSED)
7554 CLS
7555 CLOSE
7556 DEF SEG
7557 DEFINT A-Z
7558 DIM SUBRT%(40)
7559 OFFSET%=0
7560 FUNCTION.CODE%=1
7561 ATTRIBUTE%=0
7562 ATTRIBUTE.SENT%=ATTRIBUTE%
7563 PATH.NAME$="C:DOSVER.EMU"
7564 ASCIIZ.STRING$=PATH.NAME$+CHR$(0)
7565 RETURN.CODE%=0
7566 GOSUB 7606
7567 GOSUB 7576
7568 OFFSET%=VARPTR(SUBRT%(0))
7569 CALL OFFSET%(FUNCTION.CODE%,ATTRIBUTE%,ASCIIZ.STRING$,RETURN.CODE%)
7570 PRINT "FUNCTION REQUESTED= ";FUNCTION.CODE%
7571 PRINT "FILE PATH = ";PATH.NAME$
7572 PRINT "ATTRIBUTE SENT = ";ATTRIBUTE.SENT%
7573 PRINT "ATTRIBUTE RETURNED= ";ATTRIBUTE%
7574 PRINT "RETURN CODE = ";RETURN.CODE%
7575 END
7576 RESTORE
7577 FOR I=0 TO 46
7578 READ J
7579 POKE (VARPTR(SUBRT%(0))+I),J
7580 NEXT
7581 RETURN
7582 DATA &H55
7583 DATA &H89,&HE5
7584 DATA &H31,&HC0
7585 DATA &H31,&HC9
7586 DATA &H31,&HD2
7587 DATA &H8B,&H76,&H0C
7588 DATA &H8A,&H04
7589 DATA &H8B,&H76,&H08
7590 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC COMPILER
7591 DATA &H8B,&H54,&H01
7592 '********COMMENT OUT THE FOLLOWING DATA STATEMENT IF USED WITH THE BASIC INTERPRETER
7593 'DATA &H8B,&H54,&H02
7594 DATA &H8B,&H76,&H0A
7595 DATA &H8B,&H0C
7596 DATA &HB4,&H43
7597 DATA &HCD,&H21
7598 DATA &H72,&H02
7599 DATA &H30,&HC0
7600 DATA &H8B,&H76,&H06
7601 DATA &H88,&H04
7602 DATA &H8B,&H76,&H0A
7603 DATA &H89,&H0C
7604 DATA &H5D
7605 DATA &HCA,&H08,&H00
7606 RESTORE
7607 FILENAME$="A:"+"CHNGMODE.EMU"
7608 PGM.LEN=46
7609 OPEN FILENAME$ AS #1 LEN=1
7610 FIELD #1, 1 AS PGM.BYTE$
7611 FOR I=0 TO PGM.LEN
7612 READ J
7613 LSET PGM.BYTE$=CHR$(J)
7614 PUT #1
7615 NEXT
7616 CLOSE
7617 RESTORE
7618 RETURN
BASTOFOR.BAS
10 REM IBM-PC BASIC-TO-FORTRAN CONVERTER V. 1.0
20 REM COPYRIGHT (C) JIM GLASS, MAY 1983
30 REM * NOT FOR SALE * THIS SOFTWARE IS
40 REM IN THE PUBLIC DOMAIN AND IS FREE
50 REM FOR USE, MODIFICATION, AND DISTRIBUTION
60 REM
1000 DEFINT A-Z
1050 DEF FNUM(Q$)=ASC(LEFT$(Q$,1))>47 AND ASC(LEFT$(Q$,1))<58
1100 DEF FNTOGGLE(X$,Y$,FLG)=FLG XOR X$=Y$
1150 DEF FNREP$(X$,Y$,A,B)=LEFT$(X$,A-1)+Y$+MID$(X$,B)
1200 DEF FNINS$(X$,Y$,A,B)=LEFT$(X$,A)+Y$+MID$(X$,B)
1250 TST$(1)="$":TST$(2)="%":TST$(3)="#":TST$(4)="!"
1300 DIM REFLIN!(500),VALPH$(200),VINT$(200),VDBL$(200),VSNGL$(200)
1350 DIM POINT4!(200,2),STACK4(25),CSTK$(25),TOKLST$(20),PTLST(20),AA(20),BB(20)
1400 DATA " ","(",")","^","*","-","+","=","<",">"
1450 RESTORE 1400:FOR I=1 TO 10:READ DELIM$(I):NEXT
1550 NEXTLIN!=0
1600 NN=71
1601 KEY OFF
1650 IREF=0:JREF=0:IINT=0:IALPH=0:IDBL=0:ISNGL=0
1700 TRUE=-1:FALSE=0:PT4=0
1750 IMPFLG=FALSE:XORFLG=FALSE:EQVFLG=FALSE
1800 REM
1850 DIM KFOR$(80),PNTR(1150)
1900 DIM KBAS$(80),TWOS(6)
1950 DIM BUF$(10),CP(10)
2000 DATA ABS,AND,ASC,ATN,BEEP,CDBL,CHR$,CINT,CLOSE,CLS,COMMON
2050 DATA COS,CSNG,DATA,DEF,DEFSNG,DEFDBL,DEFINT,DEFSTR,DIM,ELSE,END
2100 DATA EOF,EQV,EXP,FIX,FN,FOR,GOSUB,GOTO,IF,IMP,INKEY$,INPUT
2150 DATA INPUT#,INPUT$,INT,LET,LOG,LPRINT,MOD,NEXT,NOT,ON,OPEN,OPTION
2200 DATA OR,PRINT,PRINT#,READ,REM,RESTORE,RETURN,SGN,SIN,SPACE$
2250 DATA SPC(,SQR,STEP,STOP,SWAP,TAN,THEN,then,TO,USING,WEND,WHILE,WRITE
2300 DATA WRITE#,XOR
2350 REM unhandled:data,gosub,inkey$,input$,option,read,restore,space$,spc(
2400 REM
2450 DATA 1,2,4,8,16,32
2500 REM
2550 REM
2600 DATA ABS,.AND.,ICHAR,ATAN,*,DBLE,CHAR,ANINT,CLOSE(,*,COMMON
2650 DATA COS,SNGL,DATA,*,IMPLICIT REAL (,IMPLICIT REAL*8 ( ,IMPLICIT INTEGER ( ,CHARACTER*127,DIMENSION,ELSE,END
2700 DATA EOF,*,EXP,IFIX,*,DO,CALL,GOTO,IF(,*,*,"READ(*,*)"
2750 DATA "READ(*,*)",READ,INT,*,ALOG,"WRITE(6,*)",MOD,CONTINUE,.NOT.,ON,OPEN,*
2800 DATA .OR.,"WRITE(*,*)",WRITE,*,C,*,RETURN,SIGN,SIN,*
2850 DATA *,SQRT,",",STOP,*,TAN,],] THEN,",",",",*,CONTINUE,"WRITE(*,*)",WRITE,*
2900 REM
2950 RESTORE 2000
3000 FOR I=1 TO NN:READ X$:KBAS$(I)=SPACE$(8):LSET KBAS$(I)=X$:NEXT
3050 RESTORE 2450:FOR I=1 TO 6:READ TWOS(I):NEXT
3100 RESTORE 2600:FOR I=1 TO NN:READ X$:KFOR$(I)=X$:NEXT
3150 FOR I=1 TO NN
3200 TOKEN$=KBAS$(I)
3250 GOSUB 6900
3350 IF PNTR(S)=0 THEN PNTR(S)=I
3400 NEXT I
3450 PRINT"Enter name of BASIC Program ";:INPUT F$
3500 OPEN F$ FOR INPUT AS #1
3550 PRINT "Enter name of FORTRAN Program ";:INPUT G$
3600 OPEN G$ FOR OUTPUT AS #2
3650 PRINT "Do you wish to have source displayed? ";:INPUT X$
3700 PRINT
3750 IF LEFT$(X$,1)="Y" OR LEFT$(X$,1)="y" THEN SHOW=TRUE ELSE SHOW=FALSE
3800 IF SHOW THEN CLS
3850 ON ERROR GOTO 6850
3900 H$="c:WORK":OPEN H$ FOR OUTPUT AS #3: GOTO 4000
3950 H$="b:WORK":OPEN H$ FOR OUTPUT AS #3
4000 ON ERROR GOTO 0
4001 OLIN=0
4002 LOCATE 2,50:COLOR 5,0:PRINT"PASS 1: PARSING"
4050 FOR Z!=1 TO 1000000!
4100 IF EOF(1) THEN 6101
4150 IF INSTR(BUF$(0),"XOR")<>0 THEN XORFLG=TRUE
4200 IF INSTR(BUF$(0),"IMP")<>0 THEN IMPFLG=TRUE
4250 IF INSTR(BUF$(0),"EQV")<>0 THEN EQVFLG=TRUE
4300 LINE INPUT#1,BUF$(0)
4350 FC=INSTR(1,BUF$(0)," ")+1
4400 I=1:LLINES=1:OLIN=OLIN+1:QUOTFLG=FALSE
4450 CM=0
4500 REM
4550 REM fix ELSEs
4600 REM
4650 GOSUB 7800:L=LEN(BUF$(0))
4700 P=0:FOR J=I TO L:X$=MID$(BUF$(0),J,1):QUOTFLG=FNTOGGLE(X$,CHR$(34),QUOTFLG) :IF (NOT QUOTFLG) AND X$=":" THEN P=J:GOTO 4800
4750 NEXT J
4800 IF P=0 THEN P=(INSTR(FC,BUF$(0),"'"))-FC:IF P>0 THEN CM=LLINES
4850 IF P>0 THEN CP(LLINES)=P:LLINES=LLINES+1:OLIN=OLIN+1:I=P+1-(CM<>0):GOTO 4700 ELSE GOTO 4900
4900 CP(LLINES)=L+1:CP(0)=0
4950 REM
5000 FOR M=LLINES TO 1 STEP-1
5050 BUF$(M)=MID$(BUF$(0),CP(M-1)+1,CP(M)-CP(M-1)-1-(CM=M))
5100 NEXT
5150 LINEO!=VAL(BUF$(1)):IF LINEO!<=NEXTLIN! THEN PRINT"ERROR":BEEP:STOP
5200 IF LLINES<2 THEN 5300
5250 FOR K=2 TO LLINES:NEXTLIN!=LINEO!-1+K:L$=STRING$(5," "):BUF$(K)=L$+" " +BUF$(K):NEXT
5300 IF FC=7 THEN 5400
5350 BUF$(1)=LEFT$(BUF$(1),FC-1)+" "+MID$(BUF$(1),FC):FC=FC+1:GOTO 5300
5400 RMFLG=FALSE
5450 FOR I=1 TO LLINES 'for each logical line...
5500 IF MID$(BUF$(1),FC,3)="REM" OR MID$(BUF$(1),FC,1)="'" THEN RMFLG=TRUE
5550 IF (NOT RMFLG) AND MID$(BUF$(I),FC,1)="'" THEN BUF$(I)="C"+BUF$(I)
5600 IF RMFLG THEN BUF$(I)="C"+BUF$(I)
5650 NEXT
5700 IF RMFLG THEN 5950
5750 ON ERROR GOTO 13000
5800 GOSUB 8300 'BUILD TABLE OF REFERENCED LINES
5850 GOSUB 9500 'BUILD TABLE OF CHAR, INT, AND DBL VARS [SINGLE NOT DETECTABLE]
5900 GOSUB 11950 'BUILD FOR/NEXT REF TABLE
5950 FOR I=1 TO LLINES:PRINT#3,BUF$(I)
6000 IF SHOW THEN COLOR 3,1:PRINT BUF$(I):COLOR 7,0
6050 BUF$(I)="":NEXT I
6100 NEXT Z!
6101 GOSUB 30000
6150 CLOSE 1:CLOSE 3:OPEN H$ FOR INPUT AS #1
6200 IF SP<>0 THEN ERROR 82
6250 IF SHOW THEN PRINT
6300 LOCATE 2,50:COLOR 3,0:PRINT"PASS 2: EDITING "
6350 GOSUB 13200 'VAR DEFS
6351 LOUT=0
6400 WHILE NOT EOF(1)
6450 LINE INPUT#1,BUF$(0)
6451 LOUT=LOUT+1
6452 IF OLIN>20 AND (LOUT MOD 20)=0 OR LOUT=1 THEN CLS:GOSUB 30000:LOCATE 2,50: COLOR 3,0:PRINT "PASS 2: EDITING "
6500 FS=INSTR(BUF$(0)," "):LINEO!=VAL(LEFT$(BUF$(0),FS)):L$=MID$(STR$(LINEO!),2)
6550 X$=STRING$(6," "):IF LEFT$(BUF$(0),1)<>"C" THEN MID$(BUF$(0),1,6)=X$
6600 GOSUB 14350:GOSUB 21150:PRINT#2,BUF$(0)
6650 IF SHOW THEN COLOR 1,3:PRINT BUF$(0):COLOR 7,0
6700 WEND
6750 REM
6800 END
6850 RESUME 3950
6900 S=0
6950 FOR J=8 TO 1 STEP -1
7000 ZL=J
7050 X$=MID$(TOKEN$,J,1):IF X$<>" " THEN 7150
7100 NEXT J
7150 IF ZL>6 THEN ZL=6
7200 FOR J=1 TO ZL
7250 X$=MID$(TOKEN$,J,1):X=ASC(X$)-64
7300 S=S+X*TWOS(ZL-J+1)
7350 NEXT J
7400 S=S-23:IF S<0 OR S>1134 THEN S=0
7450 REM RESOLVE COLLISIONS
7500 IF TOKEN$="EOF " THEN S=78:RETURN
7550 IF TOKEN$="SIN " THEN S=79:RETURN
7600 IF TOKEN$="TO " THEN S=80:RETURN
7650 IF TOKEN$="IMP " THEN S=77:RETURN
7700 IF TOKEN$="INT " THEN S=76:RETURN
7750 RETURN
7800 PE=FC:ELSC=0:IF INSTR(BUF$(0),"ELSE")=0 THEN RETURN
7850 ELSP=INSTR(PE,BUF$(0),"ELSE"):IF ELSP=0 THEN 8150
7900 ELSC=ELSC+1:ND=ELSP+4
7950 IF FNUM(MID$(BUF$(0),ND+1,1)) THEN BUF$(0)=FNINS$(BUF$(0),"GOTO ",ND,ND+1)
8000 BUF$(0)=FNINS$(BUF$(0),":",ELSP-1,ELSP):BUF$(0)=FNINS$(BUF$(0),":",ND,ND+1)
8050 IF INSTR(MID$(BUF$(0),PE,ELSP-PE),":")<>0 THEN BUF$(0)=FNINS$(BUF$(0), ":ENDIF",ELSP-2,ELSP-1):ELSP=ELSP+6
8100 PE=ELSP+2:GOTO 7850
8150 FOR K=1 TO ELSC:BUF$(0)=BUF$(0)+":ENDIF":NEXT
8200 IT=INSTR(BUF$(0),"THEN"):BUF$(0)=FNREP$(BUF$(0),"then",IT,IT+4):RETURN
8250 REM
8300 T=1:FOR I=1 TO LLINES
8350 T=1
8400 IF INSTR(MID$(BUF$(I),1),"ON ERROR")=0 THEN 8500
8450 BUF$(I)="C"+BUF$(I):GOTO 9400
8500 Q=INSTR(T,BUF$(I),"GOTO "):IF Q=0 THEN Q=INSTR(T,BUF$(I),"GOSUB ")
8550 IF Q=0 THEN Q=INSTR(T,BUF$(I),"then ")
8600 IF Q<>0 THEN 9050
8650 T0=T:T=INSTR(T,BUF$(I),"THEN ")+5 'IF T=5 THEN T=INSTR(T0,BUF$(I),"then")+5 :IF T>5 THEN IFE=TRUE
8700 IF T=5 THEN T=LEN(BUF$(I))
8750 IF T=LEN(BUF$(I)) THEN 8950
8800 IF NOT FNUM(MID$(BUF$(I),T)) THEN 8950
8900 BUF$(I)=LEFT$(BUF$(I),T-1)+"GOTO "+MID$(BUF$(I),T):Q=T
8950 E=INSTR(T,BUF$(I),"ELSE ")+5:IF T=LEN(BUF$(I)) AND E=5 THEN 9400
9000 IF Q=0 THEN 9400
9050 N=INSTR(Q,BUF$(I)," ")+1
9100 M!=VAL(MID$(BUF$(I),N)):IF M!=0 THEN 9400
9150 FOR K=1 TO IREF:IF REFLIN!(K)=M! THEN 9300:NEXT
9200 IREF=IREF+1:REFLIN!(IREF)=M!
9250 JREF=JREF+1
9300 NN=INSTR(N,BUF$(I),",")+1:IF NN>N+1 THEN N=NN:GOTO 9100
9350 IF E>5 THEN T=E:GOTO 8750
9400 NEXT I
9450 RETURN
9500 FOR K=1 TO 4
9550 FOR I=1 TO LLINES
9600 P=1
9650 P=INSTR(P+1,BUF$(I),TST$(K)):IF P=0 THEN 10950
9700 T$="":FOR J=P-1 TO 1 STEP -1:X$=MID$(BUF$(I),J,1)
9750 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 9900
9800 T$=X$+T$
9850 NEXT J
9900 TOKEN$=T$+TST$(K):IF LEN(TOKEN$)=1 THEN 9650
9950 IF LEN(TOKEN$)>=8 THEN 10000 ELSE TOKEN$=TOKEN$+" ":GOTO 9950
10000 GOSUB 6900:IF S<>0 AND TOKEN$=KBAS$(PNTR(S)) THEN P=P+1:GOTO 9650
10050 P=P+1
10100 ON K GOTO 10150,10350,10500,10700
10150 REM ALPHA
10200 FOR N=1 TO IALPH:IF T$=VALPH$(N) THEN 10650
10250 NEXT
10300 IALPH=IALPH+1:VALPH$(IALPH)=T$:GOTO 10650
10350 FOR N=1 TO IINT:IF T$=VINT$(N) THEN 10650
10400 NEXT
10450 IINT=IINT+1:VINT$(IINT)=T$:GOTO 10650
10500 FOR N=1 TO IDBL:IF T$=VDBL$(N) THEN 10650
10550 NEXT
10600 IDBL=IDBL+1:VDBL$(IDBL)=T$:GOTO 10650
10650 GOTO 9650
10700 REM single
10750 FOR N=1 TO ISNGL:IF T$=VSNGL$(N) THEN 10900
10800 NEXT
10850 ISNGL=ISNGL+1:VSNGL$(ISNGL)=T$:GOTO 10900
10900 GOTO 9650
10950 NEXT I
11000 NEXT K
11050 RETURN
11100 TP=0
11150 FOR K=1 TO 10
11200 P=1
11250 P=INSTR(P,BUF$(0),DELIM$(K)):IF P=0 THEN P=LEN(BUF$(0))+1
11300 T$="":FOR J=P-1 TO 1 STEP -1:X$=MID$(BUF$(0),J,1)
11350 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 11500
11400 T$=X$+T$
11450 NEXT J
11500 TOKEN$=T$ 'TOKEN$=T$+TST$(K)
11550 IF LEN(TOKEN$)>=8 THEN 11600 ELSE TOKEN$=TOKEN$+" ":GOTO 11550
11600 GOSUB 6900:IF S=0 OR TOKEN$<>KBAS$(PNTR(S)) THEN P=P+1:IF P<=LEN(BUF$(0)) THEN 11250 ELSE 11700
11650 TP=TP+1:TOKLST$(TP)=TOKEN$:AA(TP)=P-(J-1):BB(TP)=P:PTLST(TP)=PNTR(S):P=P+1 :IF P<=LEN(BUF$(0)) THEN 11250 ELSE 11750
11700 NEXT K
11750 FOR K=1 TO TP-1:FOR J=K+1 TO TP
11800 IF AA(J)>AA(K) THEN SWAP AA(J),AA(K):SWAP BB(J),BB(K):SWAP TOKLST$(J), TOKLST$(K):SWAP PTLST(J),PTLST(K)
11850 NEXT J:NEXT K
11900 RETURN
11950 FOR I=1 TO LLINES
12000 LNO!=LINEO!+I-1:L2=LEN(BUF$(I))
12050 IF MID$(BUF$(I),FC,4)<>"FOR " THEN 12300
12100 PT4=PT4+1:POINT4!(PT4,1)=LNO!:POINT4!(PT4,2)=-PT4:SP=SP+1:STACK4(SP)=PT4
12150 IF SP<0 THEN ERROR 80 ELSE IF SP>25 THEN ERROR 81
12200 IF I=1 THEN 12300 ELSE L$=MID$(STR$(LNO!),2)
12250 GOSUB 20850:GOTO 12450
12300 IF MID$(BUF$(I),FC,5)="NEXT " OR (L2=FC+3 AND MID$(BUF$(I),FC,4)="NEXT") THEN POINT4!(STACK4(SP),2)=LNO!:SP=SP-1 ELSE 12450
12350 IF I=1 THEN 12450 ELSE L$=MID$(STR$(LNO!),2)
12400 GOSUB 20850
12450 REM WHILE/WEND
12500 IF MID$(BUF$(I),FC,6)<>"WHILE " THEN 12750
12550 PT4=PT4+1:POINT4!(PT4,1)=LNO!:POINT4!(PT4,2)=-PT4:SP=SP+1:STACK4(SP)=PT4: CSTK$(SP)=MID$(BUF$(I),FC+6)
12600 IF SP<0 THEN ERROR 80 ELSE IF SP>25 THEN ERROR 81
12650 IF I=1 THEN 12750 ELSE L$=MID$(STR$(LNO!),2)
12700 GOSUB 20850:GOTO 12900
12750 IF MID$(BUF$(I),FC,5)="WEND " OR (L2=FC+3 AND MID$(BUF$(I),FC,4)="WEND") THEN POINT4!(STACK4(SP),2)=LNO!:BUF$(I)=BUF$(I)+" "+CSTK$(SP):SP=SP-1 ELSE 12900
12800 IF I=1 THEN 12900 ELSE L$=MID$(STR$(LNO!),2)
12850 GOSUB 20850
12900 NEXT I
12950 RETURN
13000 IF ERR=80 THEN PRINT"NEXT OR WEND WITHOUT FOR OR WHILE IN: ":PRINT BUF$(0) :STOP
13050 IF ERR=81 THEN PRINT"TOO MANY NESTED LOOPS AT: ":PRINT BUF$(0):STOP
13100 IF ERR=82 THEN PRINT"FOR WITHOUT NEXT SOMEWHERE IN PROGRAM...":STOP
13150 PRINT ERR,ERL:STOP
13200 IF IALPH>0 THEN PRINT#2," CHARACTER*127 ";
13250 QL=7:CON=FALSE:FOR I=1 TO IALPH-1:QL=QL+LEN(VALPH$(I))+2
13300 IF QL<66 THEN PRINT#2,VALPH$(I)+"$"+","; ELSE QL=7:CON=TRUE:PRINT#2, VALPH$(I)+"$"
13350 IF CON THEN PRINT#2," &";:CON=FALSE
13400 NEXT I:IF IALPH>0 THEN PRINT#2,VALPH$(IALPH)+"$"
13450 IF IINT>0 THEN PRINT#2," INTEGER ";
13500 QL=7:CON=FALSE:FOR I=1 TO IINT-1:QL=QL+LEN(VINT$(I))+2
13550 IF QL<66 THEN PRINT#2,VINT$(I)+"%"+","; ELSE QL=7:CON=TRUE:PRINT#2, VINT$(I)+"%"
13600 NEXT I:IF IINT>0 THEN PRINT#2,VINT$(IINT)+"%"
13650 IF IDBL>0 THEN PRINT#2," REAL*8 ";
13700 QL=7:CON=FALSE:FOR I=1 TO IDBL-1:QL=QL+LEN(VDBL$(I))+2
13750 IF QL<66 THEN PRINT#2,VDBL$(I)+"#"+","; ELSE QL=7:CON=TRUE:PRINT#2, VDBL$(I)+"#"
13800 NEXT I:IF IDBL>0 THEN PRINT#2,VDBL$(IDBL)+"#"
13850 IF ISNGL>0 THEN PRINT#2," REAL ";
13900 QL=7:CON=FALSE:FOR I=1 TO ISNGL-1:QL=QL+LEN(VSNGL$(I))+2
13950 IF QL<66 THEN PRINT#2,VSNGL$(I)+"#"+","; ELSE QL=7:CON=TRUE:PRINT#2, VSNGL$(I)+"!"
14000 NEXT I:IF ISNGL>0 THEN PRINT#2,VSNGL$(ISNGL)+"!"
14050 IF EQVFLG THEN PRINT#2," LOGICAL FEQV"
14100 IF XORFLG THEN PRINT#2," LOGICAL FXOR"
14150 IF IMPFLG THEN PRINT#2," LOGICAL FIMP":PRINT#2," FIMP(X,Y)=((X .AND. Y) .OR. ((.NOT. X) .AND. Y))"
14200 IF XORFLG THEN PRINT#2," FXOR(X,Y)=((X .OR Y) .AND. (.NOT. (X .AND. Y)))"
14250 IF EQVFLG THEN PRINT#2," FEQV(X,Y)=((X .AND. Y) .OR. (.NOT. X) .AND. (.NOT. Y))
14300 RETURN
14350 L=LEN(BUF$(0))
14400 GOSUB 11100
14450 FOR IT=1 TO TP
14451 RW=CSRLIN:CL=POS(0)
14452 LOCATE 25,1:PRINT SPACE$(78);
14453 LOCATE 25,1:COLOR 6,0:PRINT MID$(BUF$(0),7);:LOCATE 25,70:COLOR 2,0:PRINT TIME$;
14454 LOCATE RW,CL
14500 A=AA(IT):B=BB(IT):TOKEN$=TOKLST$(IT):P=PTLST(IT)
14550 IF TOKEN$<>KBAS$(P) THEN S=0:GOTO 18200
14600 IF P>23 THEN 14800
14650 REM 1 TO 23
14700 ON P GOSUB 21800,15250,15250,15250,15300,15250,15250,15250,19000, 15350,15200,15200,15250,15250,15150,17750,17750,17750,15250,15250,15250, 15200,15200
14750 GOTO 15650
14800 IF P>57 THEN 15000
14850 REM 24 TO 57
14900 ON P-23 GOSUB 21800,15200,15250,15150,15950,15200,17250,19200,21600, 15200,15250,15400,15200,15200,15150,15250,15200,21750,19050,15250,17350, 16350,15200,15250,15250,17850,15200,15200,15200,15200,15250,15200,15200, 15200
14950 GOTO 15650
15000 IF P>71 THEN ERROR 89
15050 ON P-57 GOSUB 15250,15250,15200,18300,15200,15250,15800,15250,15200, 18600,19050,15250,17850,21700
15100 GOTO 15650
15150 BUF$(0)=FNREP$(BUF$(0),"",A,B):RETURN
15200 RETURN
15250 BUF$(0)=FNREP$(BUF$(0),KFOR$(P),A,B):RETURN
15300 BUF$(0)=LEFT$(BUF$(0),6)+"WRITE(*,*) CHAR(7)":RETURN
15350 REM CLS:RETURN
15400 REM INPUT#
15450 Q$=MID$(BUF$(0),B):X=VAL(MID$(BUF$(0),B)):BUF$(0)=MID$(BUF$(0),A,B-1)+ "READ("
15500 X$=STR$(X):BUF$(0)=BUF$(0)+X$+")"+Q$:RETURN
15550 REM WRITE#
15600 RETURN
15650 NEXT IT
15700 GOSUB 20900
15750 RETURN
15800 X$=KFOR$(P)+CHR$(13)+CHR$(10)+" "
15850 IF FNUM(MID$(BUF$(0),B+1)) THEN X$=X$+"GOTO "
15900 BUF$(0)=FNREP$(BUF$(0),X$,A,B):RETURN
15950 REM FOR
16000 IF MID$(BUF$(0),FC,4)="OPEN" THEN RETURN
16050 FOR J=1 TO PT4:K=J:IF POINT4!(J,1)=LINEO! THEN 16200
16100 NEXT J
16150 PRINT"error":STOP
16200 X$=STR$(POINT4!(K,2)):X$="DO"+X$
16250 BUF$(0)=FNREP$(BUF$(0),X$,A,B)
16300 RETURN
16350 ACC$=",ACCESS="+CHR$(34)+"SEQUENTIAL"+CHR$(34):RL$=""
16400 IF INSTR(BUF$(0),",")<>0 THEN 16850
16450 FS=INSTR(FC,BUF$(0)," "):X=INSTR(FS+1,BUF$(0)," ")
16500 X$=MID$(BUF$(0),FS+1,X-FS-1)
16550 P3=INSTR(BUF$(0),"#"):IF P3=0 THEN P3=INSTR(BUF$(0)," AS ")+3
16600 FIL=VAL(MID$(BUF$(0),P3+1))
16650 P4=INSTR(BUF$(0),"="):IF P4=0 THEN 16750
16700 RL$=",RECL="+STR$(VAL(MID$(BUF$(0),P4+1))):ACC$=",ACCESS="+CHR$(34)+ "DIRECT"+CHR$(34)
16750 BUF$(0)=" OPEN("+STR$(FIL)+",FILE="+X$+",STATUS="+CHR$(34)+"OLD"+ CHR$(34)+ACC$+RL$+")"
16800 RETURN
16850 P1=INSTR(FC,BUF$(0),","):P2=INSTR(P1+1,BUF$(0),",")
16900 P3=INSTR(P2+1,BUF$(0),","):IF P3=0 THEN P3=LEN(BUF$(0))
16950 X$=MID$(BUF$(0),P2+1,P3-P2-1)
17000 P4=INSTR(BUF$(0),"#"):IF P4=0 THEN P4=P1
17050 FIL=VAL(MID$(BUF$(0),P4+1))
17100 IF P3<LEN(BUF$(0)) THEN RL$=",RECL="+STR$(VAL(MID$(BUF$(0),P3+1))):ACC$= ",ACCESS="+CHR$(34)+"DIRECT"+CHR$(34)
17150 GOTO 16750
17200 RETURN
17250 REM GOTO
17300 RETURN
17350 REM ON
17400 BL(1)=INSTR(FC,BUF$(0)," ")
17450 FOR M=2 TO 3:BL(M)=INSTR(BL(M-1)+1,BUF$(0)," "):NEXT
17500 IF MID$(BUF$(0),BL(2)+1,BL(3)-BL(2)-1)<>"GOTO" THEN RETURN
17550 X$=MID$(BUF$(0),BL(1)+1,BL(2)-BL(1)-1)
17600 Y$="("+MID$(BUF$(0),BL(3)+1)+") "
17650 BUF$(0)=" GOTO "+Y$+X$:RETURN
17700 RETURN
17750 REM DEF---
17800 GOSUB 15250:BUF$(0)=BUF$(0)+")":RETURN
17850 REM PRINT#
17900 P2=INSTR(BUF$(0),","):P1=INSTR(BUF$(0),"#"):FIL$=STR$(VAL(MID$(BUF$(0), P1+1,P2-P1-1)))
17950 FIL$=MID$(FIL$,2)
18000 BUF$(0)=FNREP$(BUF$(0),"WRITE("+FIL$+",*)",FC,P2+1)
18050 RETURN
18100 REM
18150 RETURN
18200 REM SPECIAL ACTION
18250 GOTO 15650
18300 P1=INSTR(FC,BUF$(0)," "):P2=INSTR(BUF$(0),",")
18350 X$=MID$(BUF$(0),P1+1,P2-P1-1):Y$=MID$(BUF$(0),P2+1)
18400 Z$="TEMP$$="+X$+CHR$(13)+CHR$(10)+" "+X$+"="+Y$
18450 Z$=Z$+CHR$(13)+CHR$(10)+" "+Y$+"="+"TEMP$$"
18500 BUF$(0)=LEFT$(BUF$(0),6)+Z$:RETURN
18550 RETURN
18600 REM WEND
18650 BUF$(0)=FNREP$(BUF$(0),"IF(",A,B):GOSUB 19300
18700 FOR J=1 TO PT4:K=J:IF POINT4!(J,2)=LINEO! THEN 18850
18750 NEXT J
18800 PRINT"ERROR":STOP
18850 X$=STR$(POINT4!(K,1))
18900 BUF$(0)=BUF$(0)+")"+" GOTO "+X$
18950 RETURN
19000 GOSUB 15250:BUF$(0)=BUF$(0)+")":RETURN
19050 BUF$(0)=LEFT$(BUF$(0),6)+"CONTINUE"
19150 I=0:GOSUB 20850:RETURN
19200 REM
19250 GOSUB 15250:IFFLG=TRUE
19300 M=0:X=INSTR(BUF$(0),"ELSE"):IF X=0 THEN X=LEN(BUF$(0))
19350 M=M+1:IF M>X THEN 20750
19400 IF MID$(BUF$(0),M,1)="]" THEN IFFLG=FALSE:MID$(BUF$(0),M,1)=")"
19450 P=INSTR("<>=",MID$(BUF$(0),M,1))
19500 IF MID$(BUF$(0),M,3)="IF(" THEN IFFLG=TRUE
19550 IF P=0 OR NOT IFFLG THEN 19350
19600 MM=M+1
19650 Q=INSTR("<>=",MID$(BUF$(0),MM,1)):IF Q=0 THEN MM=M
19700 R=4*Q+P:ON R+1 GOTO 20650,19750,19900,20050,20650,20650,20200,20350,20650, 20200,20650,20500,20650,20350,20500,20650
19750 REM <
19800 BUF$(0)=FNREP$(BUF$(0),".LT.",M,MM+1)
19850 M=MM+2:GOTO 19400
19900 REM >
19950 BUF$(0)=FNREP$(BUF$(0),".GT.",M,MM+1)
20000 M=MM+2:GOTO 19400
20050 REM =
20100 BUF$(0)=FNREP$(BUF$(0),".EQ.",M,MM+1)
20150 M=MM+2:GOTO 19400
20200 REM <>
20250 BUF$(0)=FNREP$(BUF$(0),".NE.",M,MM+1)
20300 M=MM+2:GOTO 19400
20350 REM <=
20400 BUF$(0)=FNREP$(BUF$(0),".LE.",M,MM+1)
20450 M=MM+2:GOTO 19400
20500 REM >=
20550 BUF$(0)=FNREP$(BUF$(0),".GE.",M,MM+1)
20600 M=MM+2:GOTO 19400
20650 REM IMPOSSIBLE...?
20700 GOTO 19400
20750 RETURN
20800 RETURN
20850 FOR NN=1 TO LEN(L$):MID$(BUF$(I),NN,1)=MID$(L$,NN,1):NEXT NN:RETURN
20900 REM SEARCH
20950 FOR J=1 TO IREF:K=J:IF REFLIN!(J)=LINEO! THEN 21100
21000 NEXT J
21050 RETURN
21100 I=0:GOSUB 20850:RETURN
21150 REM FINAL SCAN
21200 L=LEN(BUF$(0))
21250 I=0
21300 I=I+1:IF I>L THEN 21550
21350 X$=MID$(BUF$(0),I,1)
21400 IF X$=CHR$(34) THEN MID$(BUF$(0),I,1)="'" ELSE IF X$="^" THEN BUF$(0)= FNREP$(BUF$(0),"**",I,I+1)
21450 L=LEN(BUF$(0))
21500 GOTO 21300
21550 RETURN
21600 REM IMP
21650 FUN$=" IMP":FUN2$="FIMP(":GOSUB 21850:RETURN
21700 FUN$=" XOR":FUN2$="FXOR(":GOSUB 21850:RETURN
21750 FUN$=" MOD":FUN2$="AMOD(":GOSUB 21850:RETURN
21800 FUN$=" EQV":FUN2$="FEQV(":GOSUB 21850:RETURN
21850 REM general
21900 P=INSTR(BUF$(0),FUN$)
21950 Y$="":FOR I=P-1 TO 1 STEP -1:X$=MID$(BUF$(0),I,1)
22000 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 22100
22050 Y$=X$+Y$:NEXT I
22100 R=P+5:FOR Q=R TO LEN(BUF$(0)):X$=MID$(BUF$(0),Q,1)
22150 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 22250
22200 NEXT Q
22250 X$=")":Z$=MID$(BUF$(0),R,Q-R+1):IF Z$="(" THEN Z$="":X$=""
22300 BUF$(0)=FNREP$(BUF$(0),FUN2$+Y$+","+Z$+X$,I+1,Q):RETURN
30000 LOCATE 3,50:COLOR 4,0:PRINT"SOURCE LINES:";Z!
30001 LOCATE 4,50:COLOR 6,0:PRINT"OUTPUT LINES:";OLIN
30002 RETURN
BASTOFOR.DOC
BASCONV--A FORTRAN-TO-BASIC CONVERSION AID
BY JIM GLASS
BASCONV is a program for converting IBM-PC Basic programs into
Microsoft or IBM Fortran. It will not perform every detail of the
conversion for you, but will perform the bulk of the drudgery.
Careful inspection and editing of the resulting output file are
vital if you wish to obtain a working Fortran program.
BASCONV is easy to use. It asks you for the name of the source
(Basic) file, the target (Fortran) file, and if you wish to have
the source displayed as it is being converted. All file names
must be supplied complete with drive identifier and extension, if
any. In addition to these files, BASCONV also builds a working
file, called WORK, on the current default drive. It DOES NOT
delete the WORK file when the conversion is complete.
BASCONV is fairly smart. Among the things it can do are:
Change FOR/NEXT loops into DO loops.
BASCONV supplies target line numbers for
the terminating CONTINUE if necessary.
Change WHILE/WEND loops into IF..CONTINUE
loops.
Change ON n GOTO statements into GOTO
(...) n type statements. ON...GOSUB and
GOSUBS in general are NOT converted.
Fully parse IF..THEN..ELSE statements and
convert into equivalent Fortran logical
IF statements or IF blocks. An IF without
an ELSE becomes a pure logical IF.
Handle OPEN..FOR..AS and OPEN
mode,file,... statements, converting them
into Fortran OPEN statements.
Detect ALL implicit declarations of
variables, and provide explicit
declarations at the beginning of the
Fortran source.
Convert all keywords, such as ATN, to
equivalents, such as ATAN. Also parse
statements such as x MOD y and convert
into statements such as AMOD(x,y).
Remove all Basic line numbers, except
where lines are explicitly referenced.
These line numbers become Fortran
statement labels.
Break all mulit-statement Basic lines
into single statements and move all
source code into column seven as required
by Fortran.
Convert all double-quotes (") into single
quotes (').
Convert Basic exponentiation (^) into
Fortran exponentiation (**).
Provide Fortran statement functions for
the Basic logical functions IMP, XOR, and
EQV.
Converts PRINT and LPRINT as well as
PRINT# and WRITE# statements into Fortran
equivalents.
Inserts appropriate code to convert the
Basic SWAP keyword into Fortran
statements.
Converts all Basic relational operators
such as <,>,=,NOT,AND,OR into equivalent
Fortran such as
.LE.,.GT.,.EQ.,.NOT.,.AND.,.OR.
Some things BASCONV (at least version 1.0) CANNOT do are:
Convert Basic graphics commands such as
LINE, PSET, PRESET.
Convert GOSUBS into CALLS
Convert PRINT USING into WRITE with
FORMAT.
Handle DATA/RESTORE/READ statements.
Handle CHAIN, LSET, MKI$, CVI,
statements.
Handle sceen positioning statements like
POS(0), CSRLIN.
Here is a list of the Basic keywords which ARE NOT converted by
BASCONV:
AUTO BLOAD BSAVE CALL CHAIN CIRCLE CLEAR CLS
COLOR COM COMMON CONT CSRLIN CVD CVI DATA
DATE$ DELETE DRAW EDIT ERASE ERL ERR ERROR
FIELD FILES FRE GET GOSUB HEX$ INKEY$ INP
INPUT$ INSTR KEY KEY$ KILL LEFT$ LEN LINE
LIST LLIST LOAD LOC LOCATE LOF LPOS LSET
MERGE MID$ MKD$ MKI$ MKS$ MOTOR NAME NEW
OCT$ OFF OPTION OUT PAINT PEEK PEN PLAY
POINT POS PRESET PSET PUT RANDOMIZE RENUM
RESTORE RESUME RIGHT$ RND RESET RUN SAVE SCREEN
SOUND SPACE$ SPC( STICK STRIG STRING$ SYSTEM TAB(
TIME$ TROFF TRON USING USR VAL VARPTR VARPTR$
WAIT WIDTH
Finally, here is a list of the Basic keywords which ARE handled
by BASCONV:
ABS AND ASC ATN CDBL CHR$ CINT CLOSE
COS CSNG DEF DEFDBL DEFINT DEFSNG DEFSTR DIM
ELSE END EQV EXP FIX FNxxxx FOR GOTO
IF IMP INPUT INPUT# INT LET LOG LPRINT
MOD NEXT NOT ON..GOTO OPEN OR PRINT PRINT#
REM RETURN SGN SIN SQR STEP STOP STR$
SWAP TAN THEN TO WEND WHILE WRITE WRITE#
XOR
Although the list of keywords recognized by BASCONV is shorter
than those not recognized, the most important are there. Many of
the unrecognized words are those with no Fortran equivalents,
such as LINE or PAINT. A few are not handled due to the
difficulty of programming the conversion, such as
DATA/READ/RESTORE. Perhaps in Version 1.1...
FILES167.TXT
Disk No: 167
Program Title: BASIC AIDS No 1
PC-SIG version: 1.1
This disk contains many useful routines for the BASIC programmer.
Routines include a BASIC to FORTRAN converter, a BASIC program squisher,
and a REMark remover.
Usage: BASIC programmers.
Special Requirements: A version of BASIC.
How to Start: Type GO (press enter).
Suggested Registration: None.
File Descriptions:
ADVANCED BAS Checks to see if a program requires BASICA or not.
ADVANCED DOC Documentation.
ANIMATE BAS Demonstrates how to use several BASICA graphics commands.
BASKEYS BAS Sets up BASIC programming function keys.
BASTODOS BAS Several callable Assembler routines for BASIC programs.
BASTOFOR BAS Converts BASIC to Fortran.
BASTOFOR DOC Documentation.
CHARDISP BAS Displays ASCII character set.
PSQUISH BAS BASIC program squisher.
REMREM BAS Removes REMarks from BASIC programs.
STOPGAP BAS Screen text editor for BASIC programming.
TRANDUMP BAS HEX file display program.
TRS2PC BAS Converts TRS80 BASIC partways to IBM PC BASIC.
PC-SIG
1030D East Duane Avenue
Sunnyvale Ca. 94086
(408) 730-9291
(c) Copyright 1986,87,88,89 PC-SIG, Inc.
GO.TXT
╔═════════════════════════════════════════════════════════════════════════╗
║ <<<< Disk No: 167 Basic Aids No 1 >>>> ║
╠═════════════════════════════════════════════════════════════════════════╣
║ ║
║ How to Start: From BASIC, type in LOAD"filename, then run. To ║
║ read the files with the DOC extensions, enter TYPE filename.DOC ║
║ and press <ENTER>. ║
║ ║
╚═════════════════════════════════════════════════════════════════════════╝
PSQUISH.BAS
10 DEF FNI$(A$)=CHR$(ASC(LEFT$(A$,1))+32*(LEFT$(A$,1)>"Z")):DEFINT B-K,S-Z:A=0:AZ=0:A$="":C$="":D=0:DS=100:DT=0:G1=0:G2=0:G3=0:G4=0:G5=0:G6=0:HH=0:I$="":IP$="":J$="":LN=0:L$="":L1$="":N$="":P=0:PJ=0:PP=0:PV=0:Q$="":R=0:RD=0:RE=0:S=0:S1=0
20 SD=0:SQ$="":SV$="":T=0:T1=0:T2=0:V$="":X=0:XC$="":XS$="":XP$="":ZC=0:DIM REF(DS*2),PRO(DS):SCREEN 0,0,0:WIDTH 80:COLOR 11,0:KEY OFF:CLS:LINE INPUT"ENTER THE NAME OF THE PROGRAM TO BE SQUISHED: ";SQ$
30 XS$="N":IP$="N":XC$="N":XP$="N":PRINT:LINE INPUT"ENTER THE NAME FOR THE FINAL SQUISHED PROGRAM: ";SV$:PRINT:LINE INPUT"WOULD YOU LIKE EXTRA SPACES DELETED? (Y/N) ";XS$:IF XS$="" THEN XS$="N"
35 IF XS$="y" THEN XS$="Y"
40 PRINT:LINE INPUT"WOULD YOU LIKE REM STATEMENTS DELETED? (Y/N) ";IP$:IF IP$="" THEN IP$="N"
45 IF IP$="y" THEN IP$="Y"
50 PRINT:LINE INPUT"WOULD YOU LIKE TO COMBINE LINES? (Y/N) ";XC$:IF XC$="" THEN XC$="N"
55 IF XC$="y" THEN XC$="Y"
60 PRINT:LINE INPUT"WOULD YOU LIKE TO PROTECT ANY LINES? (Y/N) ";XP$:IF XP$="" THEN XP$="N"
65 IF XP$ = "y" THEN XP$ = "Y"
70 ON ERROR GOTO 560:XS$=FNI$(XS$):IP$=FNI$(IP$):XC$=FNI$(XC$):XP$=FNI$(XP$)
80 IF XS$="N" AND IP$="N" AND XC$="N" AND XP$="N" THEN RUN
90 IF XP$="Y" THEN INPUT"ENTER LINE NUMBER TO PROTECT (0 TO EXIT) ";PRO(PV):IF PRO(PV)>0 AND PV<DS THEN PV=PV+1:GOTO 90
100 OPEN SQ$ FOR INPUT AS #1
110 IF EOF(1) THEN 240
120 LINE INPUT #1,A$:IF ASC(A$)>58 THEN COLOR 12,0:PRINT:PRINT"**** '";SQ$;"' IS NOT AN ASCII FILE ****":PRINT:COLOR 11,0:END
130 G1=1:G2=1:G3=1:G4=1:G5=1:G6=1
140 D=4:T=INSTR(G1,A$,"THEN"):IF T THEN G1=T+D:GOTO 210
150 T=INSTR(G2,A$,"GOTO"):IF T THEN G2=T+D:GOTO 210
160 T=INSTR(G3,A$,"ELSE"):IF T THEN G3=T+D:GOTO 210
170 T=INSTR(G4,A$,"GOSUB"):IF T THEN D=5:G4=T+D:GOTO 210
180 T=INSTR(G5,A$,"RESUME"):IF T THEN D=6:G5=T+D:GOTO 210
190 T=INSTR(G6,A$,"RUN"):IF T THEN D=3:G6=T+D:GOTO 210
200 GOTO 110
210 A=VAL(MID$(A$,T+D)):IF A THEN FOR HH=1 TO R:IF REF(HH)<>A THEN NEXT:R=R+1:REF(R)=A
220 IF A>0 THEN T=T+D:D=1:T1=INSTR(T,A$,","):T2=INSTR(T,A$,":"):IF T1>0 AND (T2=0 OR T1<T2) THEN T=T1:GOTO 210
230 GOTO 140
240 CLOSE:FOR S=1 TO R:FOR S1=S TO R:IF REF(S)<REF(S1) THEN SWAP REF(S),REF(S1)
250 NEXT S1,S:FOR S=0 TO PV:FOR S1=S TO PV:IF PRO(S)>PRO(S1) THEN SWAP PRO(S),PRO(S1)
260 NEXT S1,S:OPEN SQ$ FOR INPUT AS #1:OPEN SV$ FOR OUTPUT AS #2:CLS
270 IF EOF(1) THEN 380
280 LINE INPUT #1,A$:FOR HH=INSTR(A$," ") TO LEN(A$)-1:IF MID$(A$,HH+1,1)=" " THEN NEXT
290 PP=HH:X=PP:LN=VAL(A$):LOCATE 1,1:COLOR 11,0:PRINT"SCANNING LINE:";:COLOR 12,0:PRINT LN:PRINT:PRINT STRING$(255,32):LOCATE 3,1:COLOR 14,0:PRINT A$:LOCATE 8,1:COLOR 11,0:PRINT"SCANNING POSITION: ":PRINT
300 PRINT"NUMBER OF LINES COMBINED:";:COLOR 12,0:PRINT RE:COLOR 11,0:PRINT:PRINT"NUMBER OF SPACES DELETED:";:COLOR 12,0:PRINT SD:COLOR 11,0:PRINT:PRINT"NUMBER OF REM STATEMENTS DELETED:";:COLOR 12,0:PRINT RD:COLOR 11,0:GOTO 410
310 IF XC$<>"Y" THEN PRINT #2,A$:GOTO 270
320 IF C$="" THEN C$=A$:GOTO 270
330 IF R>0 THEN IF LN=REF(R) THEN R=R-1:GOTO 370 ELSE IF LN>REF(R) THEN R=R-1:GOTO 330
340 IF INSTR(C$,"IF") OR INSTR(C$,"RETURN") THEN 370
350 V$=RIGHT$(A$,LEN(A$)-X):IF LEN(C$)+LEN(V$)<240 THEN C$=C$+":"+V$:RE=RE+1 ELSE 370
360 GOTO 270
370 PRINT #2,C$:C$=A$:GOTO 270
380 PRINT #2,C$:CLOSE:COLOR 12,0:LOCATE 8,19:PRINT T:LOCATE 10,26:PRINT RE:LOCATE 12,26:PRINT SD:LOCATE 14,34:PRINT RD
390 LOCATE 3,1:PRINT STRING$(255,32):LOCATE 3,1:COLOR 14,0:PRINT"PRESS 'L' TO LOAD THE SQUISHED PROGRAM":SOUND 1000,6:SOUND 660,5:COLOR 11,0
400 Q$=INKEY$:IF Q$="" THEN 400 ELSE CLS:IF Q$="L" OR Q$ = "l" THEN LOAD SV$ ELSE END
410 N$=LEFT$(A$,PP):ZC=160+PP:PP=PP+1:P=0:J$="":DT=0:FOR T=PP TO LEN(A$):L$=MID$(A$,T,1):AZ=INT(ZC/80):LOCATE AZ+1,ZC-AZ*80+1:COLOR 10,0:PRINT MID$(A$,T,1);:ZC=ZC+1:COLOR 12,0:LOCATE 8,19:PRINT T
420 COLOR 11,0:IF L$=CHR$(34) THEN IF P THEN P=0 ELSE P=1
430 IF P THEN 520
440 IF MID$(A$,T,4)="DATA" THEN DT=1 ELSE IF L$=":" THEN DT=0
450 IF DT THEN 520
460 IF L$<>" " OR XS$<>"Y" THEN 500 ELSE IF J$>"" THEN L1$=RIGHT$(J$,1):IF L1$="^" OR (L1$>")" AND L1$<"0") OR (L1$>"9" AND L1$<"A") THEN L$=""
470 L1$="X":IF T<LEN(A$) THEN L1$=MID$(A$,T+1,1)
480 IF L1$="^" OR L1$=CHR$(34) OR L1$=" " OR (L1$>")" AND L1$<"0") OR (L1$>"9" AND L1$<"A") THEN L$=""
490 IF L$="" THEN SD=SD+1
500 IF PV>PJ THEN IF LN=PRO(PJ) THEN PJ=PJ+1:GOTO 540 ELSE IF LN>PRO(PJ) THEN PJ=PJ+1
510 IF MID$(A$,T-1,5)=" REM " OR L$="'" THEN IF IP$<>"Y" THEN A$=N$+J$+MID$(A$,T,255):GOTO 540 ELSE RD=RD+1:IF LN=REF(R) THEN R=R-1:A$=N$+J$+"'":GOTO 540 ELSE IF J$="" THEN 270 ELSE 530
520 J$=J$+L$:NEXT:IF P THEN J$=J$+CHR$(34)
530 A$=N$+J$:GOTO 310
540 IF C$<>"" THEN PRINT #2,C$:C$=""
550 PRINT #2,A$:GOTO 270
560 IF ERR=53 THEN RUN ELSE ON ERROR GOTO 0
REMREM.BAS
10 INPUT "Enter file to remove remarks from-",I$:OPEN I$ FOR INPUT AS 1
20 INPUT "Enter output filename-",O$:OPEN O$ FOR OUTPUT AS 2
30 WHILE NOT EOF(1)
40 LINE INPUT#1,X$:C=0
50 C=C+1:X=INSTR(C,X$,"'"):IF X=0 THEN 200
60 Y=INSTR(C,X$,CHR$(34)):IF Y=0 OR Y>X THEN 170
70 C=INSTR(Y+1,X$,CHR$(34)):IF C>0 AND C<LEN(X$) THEN 50 ELSE 200
80 STOP
170 Y=INSTR(X$," "):IF MID$(X$,Y,X-Y)=SPACE$(X-Y) THEN X$=MID$(X$,1,Y)+"'":GOTO 200
180 IF X>Y+1 THEN X=X-1
190 X$=MID$(X$,1,X)
200 PRINT#2,X$:PRINT X$
210 WEND
STOPGAP.BAS
100 '************** THE STOPGAP EDITOR IN IBM BASIC **************
110 ' ***** by D.E. Cortesi
120 DEFINT A-Z : MAXL = 300 : MAXW = 79 :' MAXW=40 FOR COLOR TV
130 GOTO 1490
140 ' ::: right-arrow key: move cursor right
150 IF SCOL=MAXW THEN RETURN
160 SCOL=SCOL+1 : INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
170 ' ::: left-arrow key: move cursor left
180 IF SCOL=1 THEN RETURN
190 SCOL=SCOL-1 : INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
200 ' ::: tab key: jump right from one to eight columns
210 S=((SCOL+8) AND (-8))+1 : IF S<=MAXW THEN SCOL=S
220 INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
230 ' ::: end key: go to right end of the current line
240 SCOL=MAXW : INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
250 ' ::: printable character, action depends on INSCHAR
260 IF NOT LMOD THEN L$=LT$(LCUR) : LMOD=TRUE
270 IF NOT INSCHAR THEN MID$(L$,SCOL,1)=CIN$ : GOTO 300
280 CIN$=CIN$+MID$(L$,SCOL,MAXW-SCOL)
290 L$=LEFT$(L$,SCOL-1)+CIN$
300 PRINT CIN$; : IF SCOL<MAXW THEN SCOL=SCOL+1
310 LOCATE SROW,SCOL,1 : RETURN
320 ' ::: backspace: blank current character, move left
330 IF NOT LMOD THEN L$=LT$(LCUR) : LMOD=TRUE
340 MID$(L$,SCOL,1)=" " : PRINT " ";
350 IF SCOL>1 THEN SCOL=SCOL-1
360 INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
370 ' ::: del key: kill current char, pull rest left
380 IF NOT LMOD THEN L$=LT$(LCUR) : LMOD=TRUE
390 CIN$=RIGHT$(L$,MAXW-SCOL)+" " : PRINT CIN$;
400 L$=LEFT$(L$,SCOL-1)+CIN$
410 INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
420 ' ::: if current line has changed, update the file
430 INSCHAR=FALSE : LOCATE ,,1,CSL : IF NOT LMOD THEN RETURN
440 FMOD=LMOD : LT$(LCUR)=L$ : LMOD=FALSE : RETURN
450 ' ::: return the index of the next free line in L
460 IF LFREE=0 THEN L=FALSE : RETURN : 'NO FREE LINES LEFT
470 L=LFREE : LFREE=LF(L) : LF(L)=0 : LT$(L)=LMT$ : RETURN
480 ' ::: free the line whose index is in L
490 LF(L)=LFREE : LFREE=L : LT$(L)="" : RETURN
500 ' ::: forward one line in the file image
510 GOSUB 430 : L=LF(LCUR) : ' L=0 IF LCUR IS BOTTOM LINE
520 IF L=0 THEN GOSUB 460 : IF L THEN LF(LCUR)=L : LB(L)=LCUR
530 IF L THEN LCUR=L :' FALSE IF BOTTOM AND NO FREE LINES
540 RETURN
550 ' ::: backward one line in the file image
560 GOSUB 430: L=LB(LCUR)
570 IF L THEN LCUR=L :' FALSE IF TOP LINE
580 RETURN
590 ' ::: enter key: cursor to left margin, then down
600 SCOL=1
610 ' ::: down-arrow: cursor down (data up, on line 24)
620 Q=LCUR : GOSUB 510 : IF Q=LCUR THEN RETURN
630 SROW=SROW+1 : IF SROW<25 THEN LOCATE SROW,SCOL,1 : RETURN
640 SROW =24 : PRINT :' FORCE BLANK LINE, RETURN CURSOR
650 PRINT LT$(LCUR); : LOCATE SROW,SCOL,1 : RETURN
660 ' ::: up-arrow: cursor up (data down 23 lines, on line 1)
670 IF SROW= 1 THEN 710
680 Q=LCUR : GOSUB 560 : IF Q=LCUR THEN RETURN
690 SROW=SROW-1 : LOCATE SROW,SCOL,1 : RETURN
700 ' ::: up-arrow on line 1: slide current line down 23
710 GOSUB 960 : S=0
720 WHILE (S<22) AND LB(T) : T=LB(T) : B=LB(B) : S=S+1 : WEND
730 SROW=SROW+S : GOTO 1020
740 ' ::: PgUp key: back up 23 lines, hold cursor still
750 GOSUB 430 : GOSUB 960 : S=0
760 WHILE (S<23) AND LB(T) : GOSUB 560 : T=LB(T) : B=LB(B) : S=S+1 : WEND
770 GOTO 1020
780 ' ::: PgDn key: ahead 23 line, hold cursor still
790 GOSUB 430 : GOSUB 960 : S=0
800 WHILE (S<23) AND LF(B) : GOSUB 510 : T=LF(T) : B=LF(B) : S=S+1 : WEND
810 GOTO 1020
820 ' ::: Home key: go to left, then to top, then to bottom
830 IF SCOL>1 THEN SCOL=1 : INSCHAR=FALSE : LOCATE SROW,SCOL,1,CSL : RETURN
840 GOSUB 430 : GOSUB 960 : S=SROW
850 IF SROW=1 THEN WHILE LCUR<>B : GOSUB 510 : S=S+1 : WEND
860 IF SROW>1 THEN WHILE LCUR<>T : GOSUB 560 : S=S-1 : WEND
870 SROW=S : LOCATE SROW,SCOL,1 : RETURN
880 ' ::: control-a: go to top of the file
890 GOSUB 430 : GOSUB 2240 : LCUR=A
900 SROW=1 : SCOL=1 : GOSUB 960 : GOTO 1020
910 ' ::: control-z: go to the end of the file
920 GOSUB 430 : GOSUB 2240 : LCUR=Z : T=Z : B=Z : S=1
930 WHILE LB(T) AND S<24 : T=LB(T) : S=S+1 : WEND
940 SROW=S : SCOL=1 : GOTO 1020
950 ' ::: find the lines now at the top(T) and bottom(B) of the screen
960 S=SROW : T=LCUR
970 WHILE (S>1) AND LB(T) : S=S-1 : T=LB(T) : WEND
980 S=SROW : B=LCUR
990 WHILE (S<24) AND LF(B) : S=S+1 : B=LF(B) : WEND
1000 RETURN
1010 ' ::: redraw the screen using lines from T to B
1020 CLS : L=T
1030 WHILE L<>B : PRINT LT$(L) : L=LF(L) : WEND
1040 PRINT LT$(B);
1050 LOCATE SROW,SCOL,1 : RETURN
1060 ' ::: Ins key: toggle insert-character mode
1070 INSCHAR=NOT INSCHAR
1080 IF INSCHAR THEN LOCATE ,,1,CSL,1 ELSE LOCATE ,,1,CSL
1090 RETURN
1100 ' ::: control-o: split the file for bulk insertion
1110 IF INSLINE OR LF(LCUR)=0 OR LFREE=0 THEN RETURN
1120 GOSUB 430 : LINS=LCUR : LCUR=LB(LCUR)
1130 IF LCUR THEN LF(LCUR)=0 : GOSUB 510
1140 IF LCUR=0 THEN GOSUB 460 : LB(L)=0 : LCUR=L
1150 INSLINE=TRUE : GOSUB 960 : GOTO 1020
1160 ' ::: control-c: splice the file after bulk insert
1170 IF NOT INSLINE THEN RETURN
1180 GOSUB 430 : WHILE LF(LCUR) : LCUR=LF(LCUR) : WEND
1190 LF(LCUR)=LINS : LB(LINS)=LCUR
1200 IF LT$(LCUR)<>LMT$ THEN 1240
1210 L=LCUR : LCUR=LF(LCUR) : LB(LCUR)=LB(L)
1220 IF LB(L) THEN LF(LB(L))=LCUR
1230 GOSUB 490
1240 INSLINE=FALSE : GOSUB 960 : GOTO 1020
1250 ' ::: control-d: delete the current line
1260 IF LF(LCUR)+LB(LCUR)=0 THEN RETURN :'CAN'T DELETE ONLY LINE
1270 IF LB(LCUR) THEN LF(LB(LCUR))=LF(LCUR)
1280 IF LF(LCUR) THEN LB(LF(LCUR))=LB(LCUR)
1290 L=LCUR : IF LF(L)>0 THEN LCUR=LF(L)
1300 IF LF(L)=0 THEN LCUR=LB(L) : IF SROW>0 THEN SROW=SROW-1
1310 GOSUB 490 : GOSUB 960 : GOTO 1020
1320 ' **************** THE MAIN LOOP ******************************
1330 CIN$=INKEY$ : ON 1+LEN(CIN$) GOTO 1330,1390,1350
1340 'handle a special key (numeric pad, Ins, Del)
1350 S=ASC(RIGHT$(CIN$,1)) : IF S<71 OR S>83 THEN 1330
1360 ON S-70 GOSUB 830,670,750,1330,180,1330,150,1330,240,620,790,1070,380
1370 GOTO 1330
1380 'handle regular control or character key
1390 S=ASC(CIN$) : IF S>31 THEN GOSUB 260 : GOTO 1330
1400 IF S=>8 AND S<=13 THEN ON S-7 GOSUB 330,210,620,830,1330,600 : GOTO 1330
1410 IF S=1 THEN GOSUB 890 : GOTO 1330
1420 IF S=3 THEN GOSUB 1170 : GOTO 1330
1430 IF S=4 THEN GOSUB 1260 : GOTO 1330
1440 IF S=15 THEN GOSUB 1110 : GOTO 1330
1450 IF S=26 THEN GOSUB 920 : GOTO 1330
1460 IF S=27 THEN GOSUB 1630 : GOTO 1330
1470 GOTO 1330
1480 ' ************** INITIALIZATION ****************************
1490 GOSUB 1520 : FSPEC$="" :'CLEAR ALL DATA AND SET UP
1500 CLS : LOCATE SROW,SCOL,1 : GOTO 1330
1510 ' ::: clear all variables, set up a null data array
1520 DIM LF(MAXL),LB(MAXL),LT$(MAXL)
1530 LMT$=SPACE$(MAXW)
1540 FALSE=(1=2) : TRUE=NOT FALSE
1550 LMOD=FALSE : FMOD=FALSE
1560 CSL=12 :' CURSOR SCAN LINE -- MAKE 7 FOR COLOR TV
1570 INSCHAR=FALSE : LOCATE ,,1,CSL : INSLINE=FALSE
1580 FOR I=2 TO MAXL-1 : LF(I)=I+1 : NEXT I : LF(MAXL)=0 : LFREE=2
1590 LCUR=1 : LF(LCUR)=0 : LB(LCUR) = 0 : LT$(LCUR)=LMT$
1600 SROW=1 : SCOL=1 : LCUR=1 : T=1 : B = 1
1610 RETURN
1620 ' ************* GLOBAL COMMANDS ****************************
1630 GOSUB 1170 : GOSUB 430 : GOSUB 960
1640 CLS : LOCATE 10,1
1650 PRINT "Command choices are..." : PRINT
1660 PRINT " 1. SAVE the present file"
1670 PRINT " 2. LOAD another file"
1680 PRINT " 3. CLEAR the data buffer of all data"
1690 PRINT " 4. QUIT and return to DOS
1700 PRINT
1710 INPUT "Your choice of 1,2,3,4 ";CIN$
1720 IF CIN$ = "" THEN GOSUB 1020 : GOTO 1330
1730 CIN$=LEFT$(CIN$,1)
1740 IF CIN$="1" THEN GOSUB 1800 : GOTO 1640
1750 IF CIN$="2" THEN GOSUB 1930 : GOTO 1640
1760 IF CIN$="3" THEN GOSUB 2070 : GOTO 1640
1770 IF CIN$="4" THEN GOSUB 2100 : GOTO 1640
1780 GOTO 1640
1790 ' ::: the command is: SAVE
1800 GOSUB 2180 : OPEN FSPEC$ FOR OUTPUT AS #1
1810 GOSUB 2240 :'find the top and bottom of the data
1820 'write all lines, deleting trailing blanks
1830 WHILE A<>Z
1840 L$=LT$(A)
1850 I=MAXW
1860 WHILE I>1 AND MID$(L$,I,1)=" " : I=I-1 : WEND
1870 L$=LEFT$(L$,I)
1880 PRINT#1,L$
1890 A=LF(A)
1900 WEND
1910 CLOSE#1 : FMOD=FALSE : RETURN
1920 ' ::: the command is: LOAD
1930 GOSUB 2070 : IF NOT Q THEN RETURN
1940 GOSUB 2180 : OPEN FSPEC$ FOR INPUT AS #1
1950 'read up to MAXL lines, force all to MAXW bytes
1960 WHILE (LFREE>0) AND NOT (EOF(1))
1970 LINE INPUT#1,CIN$
1980 L$=LMT$ : LSET L$ = LEFT$(CIN$,MAXW)
1990 LMOD=TRUE
2000 GOSUB 510
2010 WEND
2020 CLOSE#1
2030 LMOD=FALSE : FMOD=FALSE
2040 LCUR=1 : SROW=1 : SCOL=1 : GOSUB 960
2050 RETURN
2060 ' ::: the command is: CLEAR (or clear prior to LOAD)
2070 GOSUB 2120 : IF NOT Q THEN RETURN
2080 ERASE LT$,LF,LB : GOSUB 1520 : RETURN
2090 ' ::: the command is QUIT
2100 GOSUB 2120 : IF Q THEN SYSTEM ELSE RETURN
2110 ' ::: if the file has been changed, get confirmation
2120 IF NOT FMOD THEN Q=TRUE : RETURN
2130 PRINT : PRINT "The file has been MODIFIED...!"
2140 INPUT "... are you SURE you want to do this (Y/N) ";CIN$
2150 CIN$=LEFT$(CIN$,1)
2160 Q=(CIN$="y") OR (CIN$="Y") : RETURN
2170 ' ::: get a filespec for load or save
2180 PRINT : PRINT "Give me a filespec";
2190 IF FSPEC$<>"" THEN PRINT " (";FSPEC$;")";
2200 INPUT CIN$ : IF (CIN$+FSPEC$)="" THEN PRINT : GOTO 2180
2210 IF CIN$<>"" THEN FSPEC$=CIN$
2220 RETURN
2230 ' ::: find the top(A) and bottom(Z) lines of data
2240 A=LCUR : WHILE LB(A) : A=LB(A) : WEND
2250 Z=LCUR : WHILE LF(Z) : Z=LF(Z) : WEND
2260 '..minus trailing, empty lines, if any
2270 WHILE LT$(Z)="" AND Z<>A : Z=LB(Z) : WEND
2280 RETURN
TRANDUMP.BAS
100 DEFINT A-Z
110 CLS : CLOSE
120 PRINT "Hex File Display Program"
130 INPUT "Enter file name: ", FILENAME$
140 OPEN "R",#1,FILENAME$,128
150 FIELD #1,128 AS RECORD$
160 PRINT "Dumping "+FILENAME$+" . . ."
170 OPEN "lpt1:" FOR OUTPUT AS #2
180 PRINT #2, "Dumping "+FILENAME$+" . . ."
190 PRINT #2,""
200 OFFSET = 0
210 RECORDOUT$ = ""
220 RECORDOUT1$ = ""
230 '
240 GET #1
250 PRINT #2, ""
260 IF EOF(1) THEN 410
270 FOR I=1 TO LEN(RECORD$)
280 CHAR = ASC(MID$(RECORD$,I,1))
290 CHAR$ = HEX$(CHAR)
300 IF LEN(CHAR$)=1 THEN CHAR$="0"+CHAR$
310 RECORDOUT$=RECORDOUT$+CHAR$
320 CHARPRT$ = "."
330 IF CHAR < 32 THEN 360
340 IF CHAR >= 127 THEN 360
350 CHARPRT$ = CHR$(CHAR)
360 RECORDOUT1$ = RECORDOUT1$ + CHARPRT$
370 IF LEN(RECORDOUT$) >= 32 THEN GOSUB 460
380 NEXT I
390 GOTO 240
400 '
410 GOSUB 460
420 CLOSE
430 PRINT "File Display Program Ended"
440 STOP
450 '
460 RECLEN = LEN(RECORDOUT$)
470 IF RECLEN = 0 THEN 600
480 OFFSET$=" "+HEX$(OFFSET)
490 OFFSET$=MID$(OFFSET$,LEN(OFFSET$)-4,5)
500 PRINT #2,OFFSET$+": ";
510 J=1
520 IF RECLEN-J < 8 THEN 560
530 PRINT #2,MID$(RECORDOUT$,J,8)+" ";
540 J = J + 8
550 GOTO 520
560 PRINT #2,MID$(RECORDOUT$,J) + " *" + RECORDOUT1$ + "*"
570 OFFSET = OFFSET + RECLEN/2
580 RECORDOUT$ = ""
590 RECORDOUT1$ = ""
600 RETURN
610 '
620 END
TRS2PC.BAS
100 'TRS TO IBM PC CONVERSION AID 12/31/82 REV. 1/23/83
120 'DAVE MCCOY 70040,1131
130 CLS:PRINT "TRS-80 to IBM-PC Conversion Program":PRINT"Version 2.0 - Dave McCoy - 70040,1131":PRINT
140 GOTO 510
200 '*******************************************************
210 '* ADDSPACE SUBROUTINES *
220 '*******************************************************
230 IF P=N THEN 3250 ELSE X$=MID$(B$,P+1,1) 'LOOK AT NEXT CHAR.
240 IF X$=" " OR X$=":" THEN 3250 ELSE N$=N$+" ":GOTO 3250 'ADD SPACE
250 X$=MID$(B$,P+1,1)
260 IF X$="@" OR X$=CHR$(34) OR X$=":" OR X$=" "THEN 3250 ELSE N$=N$+" ":GOTO 3250
270 X$=MID$(N$,LEN(N$)-L,1)
280 IF X$=" " OR X$=":" THEN 230 ELSE T2$=LEFT$(N$,LEN(N$)-L):T3$=RIGHT$(N$,L)
290 N$=T2$+" "+T3$:GOTO 230
300 X$=MID$(B$,P+1,3)
310 IF X$="INT" OR X$="SGN" OR X$="DBL" OR X$="STR" THEN 3250 ELSE 230
320 X$=MID$(B$,P-2,3)
330 IF X$="XOR" THEN L=3:GOTO 270 ELSE GOTO 270
340 X$=MID$(B$,P-3,4)
350 IF X$="GOTO" THEN L=4:GOTO 270 ELSE GOTO 270 'CHECK FOR SPACE
360 X$=MID$(B$,P+1,1)
370 IF X$="C" OR X$="$" THEN 3250 ELSE 270
380 X$=MID$(N$,LEN(N$)-L,1)
390 IF X$=" " OR X$=":" THEN 3250 ELSE T2$=LEFT$(N$,LEN(N$)-L):T3$=RIGHT$(N$,L)
400 N$=T2$+" "+T3$:GOTO 3250
410 ' LOCATE ABORT SUBROUTINE
420 IF LEN(B$)=>245 THEN LPRINT "Line";VAL(B$);"Locate aborted ..potential line too long":LPRINT B$:GOTO 3030
430 RETURN
500 '*******************************************************
510 '* INITIALIZE *
520 '*******************************************************
530 CLEAR 28000
540 DEFINT A-Z
550 ON ERROR GOTO 7010
560 DEF FNRW%(A1$,A2$,A3%)=(INSTR(A1$,LEFT$(A2$+STRING$(A3%," "),A3%))-1)/A3%+1
570 R6$="RETURN RESUME DEFINT DEFSNG DEFDBL DEFSTR "
580 R5$="PRINT INPUT GOSUB FIELD CLOSE ERROR CLEAR USING "
590 R4$="THEN ELSE READ DATA RSET LSET SWAP NEXT STEP KILL OPEN POKE LINE "
600 R3$="FOR AND NOT PUT GET DIM DEF LET "
610 R2$="IF OR TO ON AS "
620 DIM B1$(20) 'CONVERSION REPORT EXCEPTIONS
630 I=1
640 READ B1$(I):IF B1$(I)<>"*END*" THEN I=I+1:GOTO 640
650 MAX=I-1
660 DATA TIME$,PEEK,"POKE","CLEAR",USR,MEM,FRE(,"RANDOM"," %",CMD,"ERR/2+1","S TO P",CHR$(,ASC(,"RES TO RE",*END*
665 '------------------------------------------------------
670 C1$="N" '*** CHANGE TO Y FOR BATCH FILE PROCESSING
675 '------------------------------------------------------
680 IF C1$="Y" THEN 930
690 INPUT"Print@ converted to LOCATE r,c - IBM only (Y/N)";C2$
700 IF C2$<>"Y" AND C2$<>"N" THEN 690
710 INPUT"ADD SPACE between keywords (Y/N)";C3$
720 IF C3$<>"Y" AND C3$<>"N" THEN 710
730 INPUT"REPLACE commands for PC - IBM only (Y/N)";C4$
740 IF C4$<>"Y" AND C4$<>"N" THEN 730
750 INPUT"UPPER CASE converted to LOWER CASE (Y/N)";C5$
760 IF C5$<>"Y" AND C5$<>"N" THEN 750
770 INPUT"Conversion REPORT to printer - IBM only (Y/N)";C6$
780 IF C6$<>"Y" AND C6$<>"N" THEN 770
790 PRINT:INPUT"Edited lines to SCREEN (Y/N)";C7$
800 IF C7$<>"Y" AND C7$<>"N" THEN 790
810 GOTO 1730
900 '*******************************************************
910 '* BATCH PROCESSING *
920 '*******************************************************
930 PRINT"Batch file processing..":ON ERROR GOTO 950
940 OPEN"I",1,"COUNTER/DAT":INPUT#1,YF:CLOSE:GOTO 960
950 YF=1:OPEN"O",1,"COUNTER/DAT":PRINT#1,YF:CLOSE:GOTO 940
960 ON ERROR GOTO 7010
970 DIM FF$(20) 'BATCH PROCESSING FILENAME ARRAY
980 '------------------------------------------------------
990 'C1$=BATCH FLAG C2$=PRINT@-LOCATE C3$=ADDSPACE TO KEY
1000 'WORDS C4$=REPLACE COMMANDS C5$=UPPER TO LOWER CASE
1010 'C6$=REPORT EXCEPTIONS C7$=NEW FILE TO SCREEN
1020 '------------------------------------------------------
1030 J=1:C2$="Y":C3$="Y":C4$="Y":C5$="Y":C6$="Y":C7$="Y"
1040 READ FF$(J):IF FF$(J)="END" THEN 1100 ELSE J=J+1:GOTO 1040
1050 'ENTER 8 CHARACTER FILESPECS IN DATA STATEMENT BELOW
1060 'EXTENSION OF /ASC ASSUMED ON BATCH FILES - END DATA WITH WORD END
1070 '================= BATCH FILES =========================
1080 DATA DIRDUPS,DIRDUMP,END
1090 '======================================================
1100 IF FF$(YF)="END" THEN 1550
1110 FS$=FF$(YF) 'CURRENT FILE TO PROCESS
1120 F1$=FS$+"/ASC" 'ASSUMES /ASC INPUT FILE EXTENSION
1130 F2$=FS$+"/IBM" 'ASSIGNS /IBM OUTPUT FILE EXTENSION
1140 GOTO 1760
1500 '******************************************************
1510 '* END *
1520 '******************************************************
1530 PRINT:IF C6$="Y" THEN LPRINT STRING$(79,"="):LPRINT:LPRINT
1540 PRINT "Close ";F1$;" and ";F2$
1550 CLOSE:IF FF$(YF)="END" THEN PRINT "Done":KILL"COUNTER/DAT":CLEAR 50:END
1560 IF C1$="Y" THEN OPEN"O",1,"COUNTER/DAT":PRINT#1,YF+1:CLOSE
1570 RUN
1580 END
1700 '******************************************************
1710 '* KEYBOARD ENTRY OF FILESPEC *
1720 '******************************************************
1730 PRINT:LINE INPUT "Enter source ASCII filespec : ";F1$
1740 LINE INPUT "Enter output ASCII filespec : ";F2$
1750 '******************************************************
1760 OPEN "I",1,F1$
1770 OPEN "O",2,F2$
1780 CLS:PRINT"Source "F1$;" --> Target "F2$
1790 IF C6$="Y" THEN LPRINT "TRS-80 ";F1$;" CONVERSION TO IBM/PC ";F2$;" ";TIME$:LPRINT
1800 IF EOF(1) THEN 1530
1810 LINE INPUT #1,B$: IF B$="" THEN 1800
1820 PRINT:PRINT "Line";VAL(B$),
2000 '******************************************************
2010 '* CHANGE PRINT@ TO LOCATE R,C *
2020 '******************************************************
2030 IF C2$<>"Y" THEN 3030
2040 PRINT "Locate..";
2050 D=INSTR(B$,"PRINT@")
2060 IF D=0 THEN 2120
2070 PL=6
2080 C=INSTR(D,B$,",")
2090 IF C=0 THEN 2120
2100 A=VAL(MID$(B$,D+PL,(C-D+PL-1)))
2110 L=INT(A/64):B=A-(L*64):GOTO 2140
2120 D=INSTR(B$,"PRINT @")
2130 IF D=0 THEN 3030 ELSE PL=7:GOTO 2080
2140 C$=LEFT$(B$,D-1)
2150 GOSUB 410 :C$=C$+"LOCATE "+RIGHT$(STR$(L),LEN(STR$(L))-1)+","+RIGHT$(STR$(B),LEN(STR$(B))-1)
2160 C$=C$+":PRINT"+RIGHT$(B$,LEN(B$)-C)
2170 B$=C$
2180 GOTO 2050
3000 '******************************************************
3010 '* ADDSPACE TO KEY WORDS *
3020 '******************************************************
3030 IF C3$<>"Y" THEN N$=B$:GOTO 4030
3040 PRINT "Add Space..";
3050 D=INSTR(B$,"DATA"):IF D THEN 4030 'DON'T ADD SPACE TO DATA
3060 N=LEN(B$):N$="":F4=0:F1=0
3070 FOR P=1 TO N 'STRIP B$
3080 IF LEN(N$)=>255 THEN LPRINT "ADDSPACE ABORTED LINE TOO LONG":LPRINT N$:GOTO 4030
3090 D$=MID$(B$,P,1)
3100 N$=N$+D$
3110 IF D$=CHR$(34) AND F4=1 THEN F4=0: GOTO 3130
3120 IF D$=CHR$(34) AND F4=0 THEN F4=1
3130 IF D$="'" AND F4=0 THEN F1=1 'REMARK
3140 IF F4=1 OR F1=1 THEN 3250
3150 L=6: R%=FNRW%(R6$,RIGHT$(N$,L),L+1)
3160 ON R% GOTO 230 ,230 ,230 ,230 ,230 ,230 ,230
3170 L=L-1: R%=FNRW%(R5$,RIGHT$(N$,L),L+1)
3180 ON R% GOTO 250 ,250 ,270 ,230 ,230 ,230 ,230 ,250
3190 L=L-1: R%=FNRW%(R4$,RIGHT$(N$,L),L+1)
3200 ON R% GOTO 270 ,270 ,230 ,250 ,230 ,230 ,230 ,270 ,270 ,250 ,250 ,230 ,230
3210 L=L-1: R%=FNRW%(R3$,RIGHT$(N$,L),L+1)
3220 ON R% GOTO 230 ,270 ,270 ,230 ,230 ,230 ,300 ,230
3230 L=L-1: R%=FNRW%(R2$,RIGHT$(N$,L),L+1)
3240 ON R% GOTO 230 ,320 ,340 ,230 ,360
3250 NEXT
4000 '******************************************************
4010 '* REPLACEMENT COMMANDS *
4020 '******************************************************
4030 IF C4$<>"Y" THEN 5030
4040 PRINT "Replace..";
4050 D=INSTR(N$,"ERR/2+1")
4060 IF D=0 THEN 4080
4070 MID$(N$,D,7)=" ERR "
4080 D=INSTR(N$,"[")
4090 IF D=0 THEN 4110
4100 MID$(N$,D,1)=CHR$(94):GOTO 4080
4110 D=INSTR(N$,"STRING$(64,")
4120 IF D=0 THEN 4140
4130 MID$(N$,D+8,2)="80"
4140 D=INSTR(N$,"STRING$(63,")
4150 IF D=0 THEN 5030
4160 MID$(N$,D+8,2)="79"
5000 '******************************************************
5010 '* CONVERT UPPER TO LOWER CASE *
5020 '******************************************************
5030 IF C5$<>"Y" THEN 6030
5040 W=1:PRINT"UC to LC..";
5050 Y=INSTR(W,N$,CHR$(34)):IF Y<1 THEN 6030
5060 Z=INSTR(Y+1,N$,CHR$(34)):IF Z<1 THEN Z=LEN(N$)
5070 FOR I=Y+2 TO Z
5080 X$=MID$(N$,I,1):IF X$="" THEN 5120
5090 IF ASC(X$)<65 OR ASC(X$)>90 THEN 5120
5100 X$=CHR$(ASC(X$)+32)
5110 MID$(N$,I,1)=X$
5120 NEXTI
5130 W=I:GOTO 5050
6000 '******************************************************
6010 '* CONVERT AID REPORTER *
6020 '******************************************************
6030 IF C6$<>"Y" THEN 6140
6040 PRINT"Report..";
6050 FOR I=1 TO MAX
6060 C%=INSTR(N$,B1$(I)):CM=INSTR(N$,"'"):RM=INSTR(N$,"REM")
6070 IF C%=0 THEN 6120
6080 IF CM THEN IF CM<=C% THEN 6120
6090 IF RM THEN IF RM<=C% THEN 6120
6100 LPRINT N$
6110 LPRINT TAB(C%-1)"*"
6120 NEXT
6130 '******************************************************
6140 PRINT#2,N$:IF C7$="Y" THEN PRINT:PRINT N$ 'WRITE FILE
6150 '******************************************************
6160 GOTO 1800
7000 '******************************************************
7010 '* ERROR ROUTINE *
7020 '******************************************************
7030 PRINT "Error"ERR/2+1"in line"ERL
7040 CLOSE:STOP
7050 END
9000 '**************** SAVE PROGRAM ************************
Directory of PC-SIG Library Disk #0167
Volume in drive A has no label
Directory of A:\
ADVANCED BAS 256 2-21-84 3:24a
ADVANCED DOC 1664 2-21-84 3:25a
ANIMATE BAS 3712 1-01-80 12:48a
BASKEYS BAS 359 8-20-83 3:36p
BASTODOS BAS 46592 1-07-84 5:51a
BASTOFOR BAS 18884 6-18-83 1:36p
BASTOFOR DOC 5464 6-18-83 1:38p
CHARDISP BAS 3584 7-13-83 9:56p
FILES167 TXT 1192 12-16-88 3:02p
GO BAT 38 10-19-87 3:56p
GO TXT 694 12-02-88 8:42a
PSQUISH BAS 4736 11-23-83 3:03a
REMREM BAS 517 12-13-83 5:57p
STOPGAP BAS 8064 4-03-83 6:08p
TRANDUMP BAS 1408 8-20-83 2:59p
TRS2PC BAS 9728 11-27-83 6:13p
16 file(s) 106892 bytes
49664 bytes free