diff --git a/.gitignore b/.gitignore index 5e67f56..cf7cb55 100644 --- a/.gitignore +++ b/.gitignore @@ -112,4 +112,4 @@ software/CPM/1M44/DSK/CPM_1M44_RFS_2.DSK software/CPM/1M44/RAW/CPM_1M44_RFS_1.RAW software/CPM/1M44/RAW/CPM_1M44_RFS_2.RAW software/CPM/SDC16M/ - +software/CPM/cpm3/on2 diff --git a/software/BAS/BACCRRT.bas b/software/BAS/BACCRRT.bas new file mode 100644 index 0000000..1316a9c --- /dev/null +++ b/software/BAS/BACCRRT.bas @@ -0,0 +1,156 @@ +100 REM (SOURCE UNKNOWN) EDITED SLIGHTLY BY D. KURLAND 11/6/75 +110 PRINT "WELCOME TO CASINO UNIVAC 1108" +120 PRINT "THE GAME IS BACCARAT" +130 H=0 +140 GOSUB 1400 +150 DIM A(10),C(10) +160 PRINT "ARE YOU READY"; +170 INPUT X$ +180 IF X$="NO" OR X$="N" THEN 1390 +190 PRINT "WAGER"; +200 D=0 +210 E=0 +220 INPUT G +230 IF G>100000! THEN 1370 +240 IF G>0 THEN 270 +250 PRINT "HA!HA!, VERY FUNNY!!" +260 GOTO 190 +270 B=1 +280 GOTO 740 +290 A(B)=INT(RND(1)*52)+1 +300 C(B)=A(B)-13*INT(A(B)/13) +310 IF C(B)=0 THEN 600 +320 ON C(B)GOTO330,350,370,390,410,430,450,470,490,510,540,570 +330 PRINT "ACE "; +340 GOTO 620 +350 PRINT "DEUCE "; +360 GOTO 620 +370 PRINT "THREE "; +380 GOTO 620 +390 PRINT "FOUR "; +400 GOTO 620 +410 PRINT "FIVE "; +420 GOTO 620 +430 PRINT "SIX "; +440 GOTO 620 +450 PRINT "SEVEN "; +460 GOTO 620 +470 PRINT "EIGHT "; +480 GOTO 620 +490 PRINT "NINE "; +500 GOTO 620 +510 PRINT "TEN "; +520 C(B)=0 +530 GOTO 620 +540 PRINT "JACK "; +550 C(B)=0 +560 GOTO 620 +570 PRINT "QUEEN "; +580 C(B)=0 +590 GOTO 620 +600 PRINT "KING "; +610 C(B)=0 +620 IF INT(A(B)/13)<>A(B)/13 THEN 640 +630 ON A(B)/13 GOTO 660,680,700,720 +640 IF INT(A(B)/13)=0 THEN 660 +650 ON INT(A(B)/13)GOTO 680,700,720 +660 PRINT "OF CLUBS" +670 RETURN +680 PRINT "OF DIAMONDS" +690 RETURN +700 PRINT "OF SPADES" +710 RETURN +720 PRINT "OF HEARTS" +730 RETURN +740 PRINT "YOUR FIRST CARD IS A "; +750 GOSUB 290 +760 GOSUB 1310 +770 PRINT "YOUR NEXT CARD IS A "; +780 GOSUB 290 +790 GOSUB 1310 +800 PRINT "DO YOU WANT A CARD"; +810 INPUT J$ +820 IF J$="YES" OR J$="Y" THEN 870 +830 C(3)=0 +840 D=D+C(B) +850 B=B+1 +860 GOTO 900 +870 PRINT "THE CARD IS A "; +880 GOSUB290 +890 GOSUB 1310 +900 PRINT "MY FIRST CARD IS A "; +910 GOSUB 290 +920 GOSUB 1340 +930 PRINT "MY NEXT CARD IS A "; +940 GOSUB 290 +950 GOSUB 1340 +960 IF E<10 THEN 990 +970 E=E-10 +980 GOTO 960 +990 IF E<6 THEN 1030 +1000 PRINT "I DO NOT WANT A CARD" +1010 C(6)=0 +1020 GOTO 1060 +1030 PRINT "I TAKE CARD" +1040 PRINT "THE CARD IS A "; +1050 GOSUB 290 +1060 E=E+C(6) +1070 IF D<10 THEN 1100 +1080 D=D-10 +1090 GOTO 1070 +1100 PRINT "YOUR TOTAL IS";D +1110 IF E<10 THEN 1140 +1120 E=E-10 +1130 GOTO 1110 +1140 PRINT "MY TOTAL IS ";E +1150 IF D=E THEN 1590 +1160 IF D>E THEN 1200 +1170 PRINT "I WIN $"G +1180 G=-G +1190 GOTO 1210 +1200 PRINT "YOU WIN $";G +1210 H=H+G +1220 IF H>0 THEN 1290 +1230 IF H=0 THEN 1610 +1240 PRINT "YOU OWE ME $";-H +1250 PRINT "DO YOU WANT TO TRY AGAIN"; +1260 INPUT K$ +1270 IF K$="NO" OR K$="N" THEN 1390 +1280 GOTO 190 +1290 PRINT "I.O.U. $";H +1300 GOTO 1250 +1310 D=D+C(B) +1320 B=B+1 +1330 RETURN +1340 E=E+C(B) +1350 B=B+1 +1360 RETURN +1370 PRINT "HOUSE LIMIT IS $100000" +1380 GOTO190 +1390 STOP +1400 PRINT "DO YOU WANT THE RULES OF THE GAME"; +1410 INPUT I$ +1420 IF I$="NO" OR I$="N" THEN RETURN +1430 PRINT "* OFFICIAL RULES FOR THE GAME OF BACCARAT *" +1440 PRINT "THE COMPUTER IS SHUFFLING SIX DECKS OF CARDS" +1450 PRINT "TOGETHER. THE RULES ARE AS FOLLOWS: THE OBJECT" +1460 PRINT "IS TO BE AS CLOSE TO POSSIBLE TO NINE IN TWO" +1470 PRINT "OR THREE CARDS, FACE CARDS AND TENS COUNT ZERO" +1480 PRINT "ACES COUNT AS ONE EACH,ALL OTHER CARDS COUNT" +1490 PRINT "THEIR INDEX VALUE. WHEN THE TOTAL IS OVER TEN" +1500 PRINT "THE TENS UNIT IS DROPPED. EXAMPLE: A SEVEN AND" +1510 PRINT "A SIX TOTALING THIRTEEN COUNT AS THREE. THE" +1520 PRINT "PLAYER WITH THE HIGHER TOTAL WINS. IN CASE OF" +1530 PRINT "A TIE THE COMPUTER WINS. " +1540 PRINT "DO YOU UNDERSTAND THE RULES"; +1550 INPUT O$ +1560 IF O$="YES" OR O$="Y" THEN RETURN +1570 PRINT "TOUGH LUCK" +1580 RETURN +1590 PRINT "IT IS A TIE. THE COMPUTER WINS!" +1600 GOTO 1170 +1610 PRINT "YOU ARE EVEN-UP !!" +1620 GOTO1250 +1630 END +N +1590 PRINT "I \ No newline at end of file diff --git a/software/BAS/BASEBALL.bas b/software/BAS/BASEBALL.bas new file mode 100644 index 0000000..627aa29 --- /dev/null +++ b/software/BAS/BASEBALL.bas @@ -0,0 +1,555 @@ +100 REM BASEBALL SIMULATION PROGRAM +110 REM WRITTEN BY JOEL LIND & KEN BIRKMAN - NYU - JULY 1973 +120 REM STOLEN AND ENHANCED DECEMBER 1973 BY R. D. KURLAND - NYU +130 DIM B(7),P$(9),W$(7),J$(8),K$(4) +140 FOR I=1 TO 7: B(I)=0:NEXT +150 B=0:T9=0:R9=0:S=0:O=0:B1=0:B2=0:T=0 +160 Z1=1:Z2=1 +170 PRINT "WELCOME TO EBBETT'S FIELD" +180 PRINT "WHAT DO YOU WANT TO CALL YOUR TEAM"; +190 INPUT A$ +200 FOR I=1 TO 7:READ W$(I):NEXT +210 FOR I=1 TO 9:READ P$(I):NEXT +220 FOR I=1 TO 4:READ K$(I):NEXT +230 FOR I=1 TO 8:READ J$(I):NEXT +240 PRINT "FINE. THE ";A$;" NEED A MANAGER. WHAT'S YOUR NAME"; +250 INPUT B$ +260 PRINT "WHAT DO YOU WANT TO CALL MY TEAM, ";B$; +270 INPUT C$ +280 PRINT +290 PRINT "OPENING DAY, THE ";A$;" VERSUS THE ";C$ +300 PRINT +310 PRINT "LET'S FLIP A COIN. THE WINNER IS THE HOME TEAM." +320 PRINT "HEADS OR TAILS"; +330 INPUT D$ +340 IF D$<>"HEADS" AND D$<>"TAILS" THEN 320 +350 FOR I=1 TO TYM +360 Y=RND(1) +370 NEXT I +380 H=1 +390 Y=RND(1) +400 Y$="HEADS" +410 IF Y>.5 THEN Y$="TAILS" +420 IF D$=Y$ THEN 490 +430 H=0 +440 PRINT "YOU LOST THE TOSS. THE ";A$;" ARE UP FIRST." +450 PRINT +460 PRINT +470 A=0 +480 GOTO 610 +490 PRINT "YOU WIN THE TOSS. ";A$;" TAKE THE FIELD, AND "; +500 PRINT C$;" ARE AT BAT." +510 A=1 +520 R9=0 +530 T=T+1 +540 IF T<3 THEN GOSUB 5140 +550 IF T<18 THEN 710 +560 IF T>18 THEN 590 +570 GOSUB 3500 +580 GOTO 710 +590 GOSUB 3290 +600 GOTO 710 +610 REM START AN INNING - WE ARE OUT ON THE FIELD +620 T=T+1 +630 R9=0 +640 IF T<18 THEN 690 +650 IF T>18 THEN 680 +660 GOSUB 3500 +670 GOTO 690 +680 GOSUB 3290 +690 IF T>2 THEN 710 +700 GOSUB 5070 +710 S=0:B=0 +720 PRINT +730 IF O=0 THEN PRINT "NO OUTS" +740 IF O=1 THEN PRINT "THERE IS 1 OUT" +750 IF O>1 THEN PRINT "THERE ARE";O;"OUTS" +760 P=B(1)+B(2)+B(3) +770 IF P<>3 THEN 800 +780 PRINT "BASES LOADED" +790 GOTO 900 +800 IF P=0 THEN 900 +810 Y$="RUNNER ON " +820 IF P>1 THEN Y$="RUNNERS ON " +830 PRINT Y$; +840 IF B(1)=0 THEN 870 +850 PRINT "FIRST"; +860 IF P>1 THEN PRINT " AND "; +870 IF B(2)=1 THEN PRINT "SECOND"; +880 IF P>1 AND B(1)=0 THEN PRINT " AND "; +890 IF B(3)=1 THEN PRINT "THIRD" ELSE PRINT " " +900 IF A=0 THEN 920 +910 GOTO 3030 +920 PRINT "BATTER UP" +930 IF B<>3 OR S<>2 THEN 960 +940 PRINT "FULL COUNT" +950 GOTO 970 +960 IF B>0 OR S>0 THEN PRINT "THE COUNT IS";B;"AND";S +970 PRINT +980 IF A=1 THEN 3030 +990 PRINT "WHAT WILL YOUR BATTER DO, ";B$; +1000 INPUT C +1010 IF C>0 AND C<5 THEN 1050 +1020 PRINT "HUH? "; +1030 GOSUB 5070 +1040 GOTO 990 +1050 Y2=RND(1) +1060 IF Y2<.56 OR Y2>.5625 THEN 1120 +1070 PRINT "WILD PITCH!" +1080 N=1 +1090 GOSUB 3540 +1100 B(1)=0 +1110 GOTO 1210 +1120 IF Y2>.772 AND Y2<.775 THEN 4880 +1130 ON C GOTO 1140,1450,2600,4450,5500 +1140 C=1 +1150 GOSUB 5240 +1160 IF A=0 THEN Z1=Z1+1 +1170 Y=RND(1) +1180 IF B<>3 OR S<>0 THEN 1200 +1190 IF Y<.7 THEN 1310 ELSE 1210 +1200 IF Y<.5 THEN 1310 +1210 B=B+1 +1220 Y=INT(RND(1)*8+1) +1230 IF Y=9 THEN 1220 +1240 PRINT J$(Y);" - BALL";B +1250 IF B<>4 THEN 930 +1260 PRINT "WALK" +1270 GOSUB 4950 +1280 Y=RND(1) +1290 GOTO 710 +1300 PRINT "HIGH POP - FOUL DOWN THE ";Y$;" FIELD LINE" +1310 S=S+1 +1320 IF C=2 OR C=5 THEN 1370 +1330 Y=INT(RND(1)*4+1) +1340 IF Y=5 THEN 1330 +1350 PRINT K$(Y);", CALLED STRIKE";S +1360 GOTO 1380 +1370 PRINT "SWINGING STRIKE";S +1380 IF C=5 AND S<>3 THEN 4450 +1390 IF S<>3 THEN 930 +1400 PRINT "STRUCK OUT" +1410 O=O+1 +1420 IF O=3 THEN 2850 +1430 IF C=5 THEN 4450 +1440 GOTO 710 +1450 C=2 +1460 Y=INT(RND(1)*10+1) +1470 IF Y=10 THEN 1450 +1480 IF A=0 THEN Z2=Z2+1 +1490 IF C<>5 THEN GOSUB 5240 +1500 IF S<>2 AND Z2/Z1>7 AND A=0 THEN 1520 +1510 IF S<>2 OR Z2/Z1<25 THEN 1590 +1520 Y=INT(RND(1)*20+1) +1530 IF Y>7 THEN 1550 +1540 ON Y GOTO 1610,1310,1310,1310,1310,1680,1610 +1550 IF Y>13 THEN 1570 +1560 ON Y-7 GOTO 1680,1310,1740,1850,1740,1850 +1570 IF Y>18 THEN 1600 +1580 ON Y-13 GOTO 1980,1980,2040,2570,1640,2570 +1590 IF Y<3 THEN 1310 +1600 ON Y-2 GOTO 1610,1680,1740,1850,1980,2040,2570 +1610 PRINT "FOULED INTO THE STANDS-OUT OF PLAY" +1620 IF S<>2 THEN S=S+1 +1630 GOTO 930 +1640 Y=RND(1) +1650 Y$="RIGHT" +1660 IF Y<.5 THEN Y$="LEFT" +1670 GOTO 1620 +1680 Y=INT(RND(1)*20+1) +1690 IF Y>18 THEN 1720 +1700 PRINT "FOULED BACK INTO THE STANDS" +1710 GOTO 1620 +1720 PRINT "POPPED IT UP - CAUGHT BY CATCHER" +1730 GOTO 1410 +1740 PRINT "INFIELD GROUNDER" +1750 E2=RND(1) +1760 IF E2<.37 OR E2>.41 THEN 1820 +1770 PRINT "1 BASE ERROR!!" +1780 N=1 +1790 C=4 +1800 GOSUB 3540 +1810 GOTO 710 +1820 GOSUB 4100 +1830 IF O=3 THEN 2850 +1840 GOTO 710 +1850 PRINT "GROUNDER - COULD BE TROUBLE" +1860 Y=RND(1) +1870 IF Y>.75 THEN 1950 +1880 Y$="UP THE MIDDLE" +1890 IF Y<.5 THEN Y$="THROUGH THE HOLE INTO RIGHT FIELD" +1900 IF Y<.25 THEN Y$="THROUGH THE HOLE INTO LEFT FIELD" +1910 PRINT "A SINGLE ";Y$;"!" +1920 N=1 +1930 GOSUB 3540 +1940 GOTO 710 +1950 PRINT "INFIELDER UP WITH IT!" +1960 GOSUB 4800 +1970 IF O=3 THEN 2850 ELSE 710 +1980 Y=RND(1) +1990 Y$="LEFT" +2000 IF Y<.6 THEN Y$="CENTER" +2010 IF Y<.3 THEN Y$="RIGHT" +2020 PRINT "FLY-OUT TO ";Y$;" FIELD" +2030 GOTO 1410 +2040 Z=RND(1) +2050 Y$="CENTER" +2060 IF Z<.6 THEN Y$="RIGHT" +2070 IF Z<.3 THEN Y$="LEFT" +2080 PRINT "LONG FLY TO DEEP ";Y$;" FIELD - LOOKS GOOD!" +2090 Z=RND(1) +2100 IF Z<.9 THEN 2130 +2110 PRINT Y$;"FIELDER CAUGHT IT AT THE WALL!" +2120 GOTO 2180 +2130 IF Z<.8 THEN 2160 +2140 PRINT "A DIVING CATCH!" +2150 GOTO 2180 +2160 IF Z<.7 THEN 2290 +2170 PRINT Y$;"FIELDER CAUGHT IT ON THE WARNING TRACK!" +2180 O=O+1 +2190 IF O=3 THEN 2850 +2200 FOR I=3 TO 1 STEP -1 +2210 IF B(I)=1 THEN 2240 +2220 NEXT I +2230 GOTO 710 +2240 B(I+1)=B(I) +2250 B(I)=0 +2260 PRINT "LEAD RUNNER TAGS UP - AND ADVANCES 1 BASE!" +2270 GOSUB 3830 +2280 GOTO 710 +2290 IF Z<.5 THEN 2360 +2300 PRINT "BATTER HOLDS WITH A SINGLE." +2310 N=2 +2320 GOSUB 3540 +2330 B(2)=0 +2340 B(1)=1 +2350 GOTO 710 +2360 IF Z<.15 THEN 2480 +2370 PRINT "DOUBLE!" +2380 Y=RND(1) +2390 IF Y>.5 THEN 2430 +2400 N=2 +2410 GOSUB 3540 +2420 GOTO 710 +2430 N=3 +2440 GOSUB 3540 +2450 B(3)=0 +2460 B(2)=1 +2470 GOTO 710 +2480 IF Z<.1 THEN 2530 +2490 PRINT "TRIPLE!" +2500 N=3 +2510 GOSUB 3540 +2520 GOTO 710 +2530 PRINT "IT'S OVER THE WALL -- A H*O*M*E R*U*N!!!" +2540 N=4 +2550 GOSUB 3540 +2560 GOTO 710 +2570 Y=INT(RND(1)*7+1) +2580 PRINT "LINED OUT TO ";P$(Y) +2590 GOTO 1410 +2600 GOSUB 5240 +2610 PRINT "BATTER BUNTS..." +2620 Y=RND(1) +2630 IF Y<.6 THEN 2750 +2640 IF B(3)=0 THEN 2660 +2650 IF Y<.8 THEN 2830 +2660 PRINT "THROWN OUT AT FIRST." +2670 O=O+1 +2680 IF O=3 THEN 2850 +2690 IF B(1)+B(2)+B(3)=0 THEN 710 +2700 PRINT "SACRIFICE - "; +2710 N=1 +2720 GOSUB 3540 +2730 B(1)=0 +2740 GOTO 710 +2750 IF Y<.2 THEN 2830 +2760 IF Y<.4 THEN 2790 +2770 PRINT "BATTER MISSES PITCH" +2780 GOTO 1310 +2790 PRINT "BEATS IT OUT! SINGLE!" +2800 N=1 +2810 GOSUB 3540 +2820 GOTO 710 +2830 GOSUB 4100 +2840 IF O<>3 THEN 710 +2850 PRINT "3 OUTS. THE SIDE IS RETIRED"; +2860 I=B(1)+B(2)+B(3) +2870 IF I=0 THEN PRINT "." +2880 IF I=1 THEN PRINT ", LEAVING 1 MAN ON BASE" +2890 IF I>1 THEN PRINT ", LEAVING";I;"MEN ON BASE" +2900 PRINT +2910 PRINT +2920 PRINT "*************" +2930 D=T/2-INT(T/2) +2940 PRINT "AFTER"; +2950 IF T>1 THEN PRINT INT(T/2); +2960 IF D>.3 THEN PRINT " 1/2 "; +2970 Y$="INNINGS" +2980 IF T<3 THEN Y$="INNING" +2990 PRINT Y$;" OF PLAY, THE SCORE IS" +3000 GOSUB 3960 +3010 O=0:B(1)=0:B(2)=0:B(3)=0 +3020 IF A=0 THEN 510 ELSE 470 +3030 REM MY TEAM IS AT BAT +3040 Y=RND(1) +3050 IF B(1)+B(2)+B(3)=0 THEN 3140 +3060 REM IF O=2 AND S=2 AND B=3 THEN 4850 +3070 IF B(3)=1 THEN 3110 +3080 IF B(2)=0 THEN 3100 +3090 IF .45Y THEN 4450 +3100 IF .45Y THEN 4450 +3110 IF O=2 THEN 3140 +3120 IF O<2 AND Y<.333 AND B(3)=1 THEN 2600 +3130 IF .45Y THEN 2600 +3140 IF S=0 THEN 3240 +3150 IF B<>3 THEN 3180 +3160 IF Y<.6 THEN 1450 +3170 GOTO 1140 +3180 IF Y>.3 THEN 1450 +3190 IF S<>2 THEN 1140 +3200 IF B=0 AND Y<.1 THEN 1140 +3210 IF B=0 THEN 1450 +3220 IF Y<.2 THEN 1140 +3230 GOTO 1450 +3240 IF B=3 THEN 3270 +3250 IF Y<.6 THEN 1140 +3260 GOTO 1450 +3270 IF Y<.9 THEN 1140 +3280 GOTO 1450 +3290 IF T<>19 THEN 3330 +3300 IF R1<>R2 THEN 3340 +3310 PRINT +3320 PRINT "*** GOING INTO EXTRA INNINGS ***" +3330 IF R1=R2 THEN RETURN +3340 IF (T-1)/2<>INT(T-1)/2 THEN RETURN +3350 PRINT "THE BALLGAME IS OVER." +3360 PRINT "*************" +3370 PRINT "FINAL SCORE:" +3380 T9=1 +3390 GOSUB 3960 +3400 IF R1>R2 THEN 3470 +3410 PRINT "NICE TRY, ";B$ +3420 PRINT "YOU SHOULD KNOW BETTER THAN TO TRY TO" +3430 PRINT "OUT-MANAGE A COMPUTER. MAYBE BASEBALL" +3440 PRINT "JUST ISN'T YOUR SPORT...WHY DON'T YOU TRY GOLF?" +3450 REM CHAIN GOLF +3460 STOP +3470 PRINT "CONGRATULATIONS, ";B$ +3480 PRINT "YOU'VE BEATEN ME, BUT I WILL HAVE MY REVENGE." +3490 STOP +3500 REM 9TH INNING +3510 IF A=0 THEN 3530 +3520 IF R2>R1 THEN 3350 ELSE RETURN +3530 IF R1>R2 THEN 3350 ELSE RETURN +3540 REM ADVANCE N BASES (SET N BEFORE GOSUB) +3550 N2=B(1)+B(2)+B(3) +3560 IF C=5 THEN N=N+1 +3570 N3=N +3580 IF N2=0 THEN 3650 +3590 REM FIND LAST RUNNER: MAKE SURE HE ISN"T TRYING TO ADVANCE +3600 REM PAST HOME PLATE. +3610 FOR I=1 TO 3 +3620 IF B(I)=1 THEN 3640 +3630 NEXT I +3640 IF 4-I1 THEN B(N-P)=0 +3720 IF (N-P)<=1 THEN B(1)=0 +3730 NEXT P +3740 FOR P=1 TO 7 +3750 IF P=N THEN 3780 +3760 NEXT P +3770 GOTO 3830 +3780 IF C=4 OR N2=0 THEN 3830 +3790 Y$="RUNNERS ADVANCE" +3800 IF N2=1 THEN Y$="RUNNER ADVANCES" +3810 PRINT Y$;N3; +3820 IF N3=1 THEN PRINT "BASE" ELSE PRINT "BASES" +3830 IF B(4)+B(5)+B(6)+B(7)=0 THEN RETURN +3840 REM AT LEAST 1 RUN HAS SCORED. +3850 N2=B(4)+B(5)+B(6)+B(7) +3860 IF A=0 THEN 3890 +3870 R2=R2+N2 +3880 GOTO 3900 +3890 R1=R1+N2 +3900 B(4)=0:B(5)=0:B(6)=0:B(7)=0 +3910 IF N2=1 THEN PRINT "** 1 RUN SCORED" +3920 IF N2>1 THEN PRINT "**";N2;"RUNS SCORED" +3930 PRINT +3940 PRINT +3950 PRINT "********NEW SCORE:" +3960 IF H=1 THEN 4000 +3970 IF LEN(A$)>LEN(C$) THEN PRINT A$;TAB(LEN(A$)+3);R1 +3980 IF LEN(A$)<=LEN(C$) THEN PRINT A$;TAB(LEN(C$)+3);R1 +3990 IF H=1 THEN 4030 +4000 IF LEN(A$)>LEN(C$) THEN PRINT C$;TAB(LEN(A$)+3);R2 +4010 IF LEN(A$)<=LEN(C$) THEN PRINT C$;TAB(LEN(C$)+3);R2 +4020 IF H=1 THEN 3970 +4030 PRINT "*************" +4040 PRINT +4050 PRINT +4060 IF T9=1 THEN 4090 +4070 IF A=1 AND T>17 AND INT(T/2)=T/2 AND R2>R1 THEN 3350 +4080 IF A=0 AND T>17 AND INT(T/2)=T/2 AND R1>R2 THEN 3350 +4090 RETURN +4100 REM LEAD RUNNER OUT (FIELDER"S CHOICE THEN ONE BASE ADVANCE) +4110 N=1 +4120 I=4 +4130 IF B(4)=0 AND B(3)=1 AND B(2)=1 AND B(1)=1 THEN 4220 +4140 I=3 +4150 IF B(3)=0 AND B(2)=1 AND B(1)=1 THEN 4220 +4160 I=2 +4170 IF B(2)=0 AND B(1)=1 THEN 4220 +4180 REM NO ONE FORCED +4190 O=O+1 +4200 PRINT "BATTER THROWN OUT" +4210 RETURN +4220 B(I-1)=0 +4230 F=RND(1) +4240 IF O=2 OR F>.3 THEN 4290 +4250 O=O+2 +4260 PRINT "DOUBLE PLAY!" +4270 IF O=3 THEN RETURN +4280 GOTO 4910 +4290 O=O+1 +4300 PRINT "RUNNER ON BASE";I-1;"IS OUT ON FIELDER'S CHOICE" +4310 IF O=3 THEN RETURN +4320 GOSUB 3540 +4330 RETURN +4340 REM FORCED RUNNERS ADVANCE 1 BASE, OTHERS HOLD +4350 FOR I=1 TO 3 +4360 IF B(I)=0 THEN 4400 +4370 NEXT I +4380 N=1 +4390 GOTO 3540 +4400 REM NO ONE ON BASE I +4410 FOR I2=I TO 1 STEP -1 +4420 B(I2)=1 +4430 NEXT I2 +4440 RETURN +4450 REM LEAD RUNNER STEALS +4460 FOR I=3 TO 1 STEP -1 +4470 IF B(I)=1 THEN 4510 +4480 NEXT I +4490 PRINT "NO ONE ON BASE, DUMMY!" +4500 GOTO 990 +4510 REM I IS LEAD RUNNER"S BASE +4520 IF C<>5 THEN GOSUB 5240 +4530 IF RND(1)/I<.3 THEN 4680 +4540 IF B(1)+B(2)+B(3)>1 THEN 4570 +4550 PRINT "RUNNER STEALS A BASE" +4560 GOTO 4580 +4570 PRINT "RUNNERS STEAL A BASE" +4580 N=1 +4590 C2=C +4600 C=4 +4610 GOSUB 3540 +4620 C=C2 +4630 B(1)=0 +4640 IF C=5 AND S<>3 THEN 930 +4650 IF C=5 THEN 710 +4660 Y=RND(1) +4670 IF Y>.5 THEN 1210 ELSE 1310 +4680 PRINT "RUNNER THROWN OUT STEALING" +4690 O=O+1 +4700 B(I)=0 +4710 IF O=3 THEN 2850 +4720 N=1 +4730 GOSUB 3540 +4740 B(1)=0 +4750 IF C=5 AND S<>3 THEN 930 +4760 IF C=5 THEN 710 +4770 Y=RND(1) +4780 IF B=3 THEN 1310 +4790 IF Y>.5 THEN 1210 ELSE 1310 +4800 REM RUNNERS ADVANCE ONE BASE, BATTER THROWN OUT +4810 N=1 +4820 IF O=2 THEN 4850 +4830 GOSUB 3540 +4840 B(1)=0 +4850 O=O+1 +4860 PRINT "BATTER THROWN OUT" +4870 RETURN +4880 PRINT "HIT BATSMAN (OUCH!)" +4890 GOSUB 4950 +4900 GOTO 710 +4910 N=1 +4920 GOSUB 3540 +4930 B(1)=0 +4940 RETURN +4950 REM BATTER WALKED +4960 FOR I=1 TO 3 +4970 IF B(I)=0 THEN 5010 +4980 NEXT I +4990 N=1 +5000 GOTO 3540 +5010 IF I=1 THEN 5050 +5020 FOR I0=I TO 2 STEP -1 +5030 B(I0)=B(I0-1) +5040 NEXT I0 +5050 B(1)=1 +5060 RETURN +5070 PRINT "WHEN YOUR'RE UP:" +5080 PRINT "1-BATTER TAKES PITCH" +5090 PRINT "2-BATTER SWINGS AWAY" +5100 PRINT "3-BATTER BUNTS" +5110 PRINT "4-LEAD RUNNER STEALS" +5120 REM PRINT "5-HIT AND RUN" +5130 RETURN +5140 REM PITCHING ROUTINE +5150 PRINT "YOUR PITCHER MAY THROW:" +5160 PRINT "1-FAST BALL" +5170 PRINT "2-CURVE" +5180 PRINT "3-SLIDER" +5190 PRINT "4-SINKER" +5200 PRINT "5-CHANGE-UP" +5210 PRINT "6-KNUCKLEBALL" +5220 PRINT "7-SCREWBALL" +5230 RETURN +5240 IF A=0 THEN 5370 +5250 IF R9=1 THEN 5300 +5260 PRINT "WHAT WILL YOUR PITCHER THROW"; +5270 INPUT W +5280 IF W<0 THEN R9=1 +5290 IF R9=0 THEN 5320 ELSE PRINT "RANDOM PITCHES FOR REST OF INNING" +5300 W=INT(RND(1)*8+1) +5310 IF W=8 THEN 5300 +5320 IF W>0 AND W<8 THEN 5470 +5330 PRINT "UH-UH, ";B$;". "; +5340 GOSUB 5150 +5350 PRINT +5360 GOTO 5260 +5370 REM I MUST SELECT A PITCH +5380 W1=RND(1) +5390 W=1 +5400 IF W1<.75 THEN W=2 +5410 IF W1<.55 THEN W=3 +5420 IF W1<.45 THEN W=4 +5430 IF W1<.35 THEN W=5 +5440 IF W1<.15 THEN W=6 +5450 IF W1<.08 THEN W=7 +5460 GOTO 5470 +5470 PRINT W$(W); +5480 PRINT "..."; +5490 RETURN +5500 REM HIT-AND-RUN +5510 IF B(1)+B(2)+B(3)=0 THEN 4490 +5520 GOSUB 5240 +5530 PRINT "HIT AND RUN!" +5540 C=5 +5550 GOTO 1460 +5560 DATA FAST BALL,CURVE BALL,SLIDER,SINKER,CHANGE-UP,KNUCKLEBALL +5570 DATA SCREWBALL +5580 DATA RIGHT,LEFT,CENTER,FIRST,SECOND,THIRD,SHORTSTOP,PITCHER,CATCHER +5590 DATA RIGHT OVER THE PLATE,CAUGHT THE OUTSIDE CORNER +5600 DATA OVER THE INSIDE CORNER,OVER AT THE KNEES +5610 DATA HIGH,LOW,INSIDE,OUTSIDE,HIGH AND TIGHT,LOW AND OUTSIDE +5620 DATA LOW AND INSIDE,HIGH AND OUTSIDE +5630 END + \ No newline at end of file diff --git a/software/BAS/BIGTREK.BAS b/software/BAS/BIGTREK.BAS new file mode 100644 index 0000000..6ed6891 Binary files /dev/null and b/software/BAS/BIGTREK.BAS differ diff --git a/software/BAS/BIOCAL.bas b/software/BAS/BIOCAL.bas new file mode 100644 index 0000000..a1e4081 --- /dev/null +++ b/software/BAS/BIOCAL.bas @@ -0,0 +1,170 @@ +100 REM***************************************************************** +110 REM +120 REM BIORHYTHM WALL CALENDAR +130 REM +140 REM WRITTEN BY +150 REM +160 REM RON WILLIAMS +170 REM 1845 COCHRAN RD. +180 REM MORGAN HILL, CA 95037 +190 REM (408) 779-8655 +200 REM +210 REM BASED ON A CONCEPT BY +220 REM DR. ROBERT SMITH AT +230 REM CONTROL DATA CORP. +240 REM +250 REM +260 REM THE ONLY INPUT THE PROGRAM REQUIRES IS YOUR NAME AND YOUR +270 REM DATE OF BIRTH (GIVEN AS MM,DD,YYYY OR MM,DD,YY). +280 REM THIS PROGRAM PRINTS OUT A 12-MONTH CALENDER FOR 1978. IF SOME +290 REM PARTICULAR DAY HAS A 'P', AN 'S' OR AN 'I' INSTEAD OF A +300 REM NUMBER, IT MEANS THAT DAY IS A P(HYSICAL), S(ENSITIVITY) OR +310 REM I(NTELLECTUAL) CRITICAL DAY FOR YOU. A '+' OR '-' FOLLOWING +320 REM ONE OF THE THREE LETTERS ABOVE MEANS THE SINE CURVE IS +330 REM BEGINNING ITS UPWARD(+) OR DOWNWARD(-) SWING. +340 REM +350 REM IF TWO LETTERS APPEAR ON THE CALENDAR, IT MEANS YOU HAVE A +360 REM DOUBLE-CRITICAL DAY! (E.G. 'PS' MEANS YOUR PHYSICAL AND +370 REM SENSITIVITY CYCLES ARE BOTH CRITICAL ON THAT DAY). +380 REM +390 REM IF A DOUBLE ASTERISK (**) APPEARS ON THE CALENDAR, IT MEANS +400 REM ALL THREE CYCLES ARE CRITICAL ON THAT DAY! YOU'D BEST JUST +410 REM STAY HOME N BED!! ONE GOOD(?) THING YOU MIGHT SAY +420 REM ABOUT A TRIPLE-CRITICAL DAY IS THAT YOU ONLY HAVE 9 OF THEM +430 REM IN THE 58-YEAR BIORHYTHM LIFE CYCLE (YOUR THREE CYCLES +440 REM START OVER AGAIN ABOUT EVERY 58 YEARS). +450 REM +460 REM THIS PROGRAM WAS ORIGINALLY WRITTEN IN PL/M FOR THE INTELLEC +470 REM MICROCOMPUTER DEVELOPMENT SYSTEM. +480 REM BEING INNATELY LAZY, I MERELY TRANSLATED THE CODE (INSTEAD OF +490 REM REDESIGNING IT) WHEN I REWROTE IT IN MICROSOFT DISK BASIC. +500 REM THIS LAME EXCUSE IS MY WAY OF TELLING THE USER THAT THE +510 REM PROGRAM RUNS SLO-O-O-W AS COMPARED TO THE PL/M VERSION. +520 REM +530 REM +540 REM****************************************************************** +550 REM +560 CLEAR 1000 +570 DEFINT A-E:DEFINT G-Z +580 DIM CA(583),CB$(71) +590 WIDTH80 +600 GOSUB 1600 +610 LINEINPUT"PLEASE ENTER YOUR NAME ===> ";N$ +620 INPUT"NOW ENTER YOUR BIRTHDATE (E.G. 5,22,1934) ===> ";MM,DD,YY +630 IF YY<1000 THEN YY=YY+1900 +640 PRINT:LINEINPUT"POSITION PAPER AT TOP OF FORM, THEN HIT -RETURN-";A$ +650 PRINT:PRINT"WAIT....YOUR BIORHYTHM CALENDAR WILL BE PRINTING SHORTLY....." +660 CY=1978 +670 X=MM:Y=DD:Z=YY:IFX<3THENGOSUB1770ELSEGOSUB1780 +680 F1=F +690 X=1:Y=1:Z=1978:GOSUB1770 +700 TD=F-F1+1 +710 IF CY MOD 4=0 THEN MV(13)=29 +720 FOR K=0TO583:CA(K)=0:NEXT +730 MV(1)=MV(13):CP=SD(CY-1971) +740 FORJ=1TO12 +750 L=MV(J-1) +760 RP=6*(J-1)+1 +770 FOR K=1TOL +780 CA(CP+7*(RP-1))=K +790 CP=CP+1 +800 IF CP>7 THEN CP=1:RP=RP+1 +810 NEXT K +820 NEXTJ +830 CL=23:RP=0 +840 FOR L=1 TO 3 +850 MC=TD MOD CL +860 FOR J=1 TO 72 +870 FOR K=1 TO 7 +880 SL=K+7*(J-1) +890 IF CA(SL)=0 THEN 960 +900 IF MC-CL\2-1 = 0 THEN 940 +910 IF MC>CL THEN CA(SL)=CA(SL)+1000*(L+RP)+200:MC=1 +920 MC=MC+1 +930 GOTO 960 +940 CA(SL)=CA(SL)+1000*(L+RP)+100 +950 MC=MC+1 +960 NEXT K +970 NEXT J +980 CL=CL+5:RP=RP+1 +990 NEXT L +1000 REM +1010 L=0:KL=7*(CY-1971) +1020 FOR J=1TO7 +1030 MG=10000 +1040 FOR K=0TO71:CB$(K)=" ":NEXTK +1050 L=L+1:M=HP(L-1):IF M<>0 THEN CB$(M)="$":GOTO 1050 +1060 CP=KL+J:K=HN(CP-1) +1070 IF K=0 THEN FOR I=48TO53:CB$(I)="$":NEXTI:GOTO 1120 +1080 FOR N=1 TO 5:LP=K\MG:K=K-LP*MG +1090 IF LP<>0 THEN CB$(LP+47)="$" +1100 MG=MG\10 +1110 NEXT N +1120 LPRINTTAB(5);:FOR I=0 TO 71:LPRINT CB$(I);:NEXT I:LPRINT +1130 NEXT J +1140 PRINT +1150 FOR I=0TO71:CB$(I)=" ":NEXT I +1160 LPRINT:LPRINTTAB(23);"BIORHYTHM CALENDAR FOR ";N$:LPRINT +1170 LPRINT:LPRINTTAB(11);"P=PHYSICAL S=SENSITIVITY I=INTELLECTUAL" +1180 LPRINTTAB(18);"+ = CURVE RISING - = CURVE FALLING" +1190 LPRINTTAB(25);"** = TRIPLE CRITICAL DAY!":LPRINT +1200 FOR L=1 TO 12 STEP 3 +1210 ON L\3+1 GOSUB 1560,1570,1580,1590 +1220 LPRINTTAB(5);" S M T W T F S S M T W T F S S M T W T F S":LPRINT +1230 N=6*(L-1)+1 +1240 FOR M=1 TO 6 +1250 LP=3 +1260 RP=N +1270 JL=RP+12 +1280 FOR K=0 TO 71:CB$(K)=" ":NEXT K +1290 IF RP>JL THEN 1500 +1300 FOR K=1 TO 7 +1310 IF CA(K+7*(RP-1))=0 THEN 1460 +1320 SL=K+7*(RP-1) +1330 IF CA(SL)>8500 THEN CB$(LP)="*":CB$(LP-1)="*":GOTO1460 +1340 IF CA(SL)>8200 THEN CB$(LP)="I":CB$(LP-1)="S":GOTO1460 +1350 IF CA(SL)>6200 THEN CB$(LP)="I":CB$(LP-1)="P":GOTO1460 +1360 IF CA(SL)>5200 THEN CB$(LP)="+":CB$(LP-1)="I":GOTO1460 +1370 IF CA(SL)>5100 THEN CB$(LP)="-":CB$(LP-1)="I":GOTO1460 +1380 IF CA(SL)>4200 THEN CB$(LP)="S":CB$(LP-1)="P":GOTO1460 +1390 IF CA(SL)>3200 THEN CB$(LP)="+":CB$(LP-1)="S":GOTO1460 +1400 IF CA(SL)>3100 THEN CB$(LP)="-":CB$(LP-1)="S":GOTO1460 +1410 IF CA(SL)>1200 THEN CB$(LP)="+":CB$(LP-1)="P":GOTO1460 +1420 IF CA(SL)>1100 THEN CB$(LP)="-":CB$(LP-1)="P":GOTO1460 +1430 CB$(LP)=MID$(STR$(CA(SL) MOD 10),2) +1440 CB$(LP-1)=MID$(STR$(CA(SL)\10),2) +1450 IF CB$(LP-1)="0"THENCB$(LP-1)=" " +1460 LP=LP+3 +1470 NEXT K +1480 RP=RP+6:LP=LP+4 +1490 GOTO 1290 +1500 LPRINTTAB(5);:FOR I=0 TO 71:LPRINTCB$(I);:NEXT I:LPRINT +1510 N=N+1 +1520 NEXT M +1530 LPRINT +1540 NEXT L +1550 END +1560 LPRINTTAB(5);" J A N U A R Y F E B R U A R Y M A R C H":LPRINT:RETURN +1570 LPRINTTAB(5);" A P R I L M A Y J U N E":LPRINT:RETURN +1580 LPRINTTAB(5);" J U L Y A U G U S T S E P T E M B E R":LPRINT:RETURN +1590 LPRINTTAB(5);" O C T O B E R N O V E M B E R D E C E M B E R":LPRINT:RETURN +1600 DIM HP(49) +1610 FOR I=0TO48:READHP(I):NEXT +1620 DATA 21,29,30,31,32,38,39,40,41,42,43,0,20,21,28,33,38,43,0 +1630 DATA 19,21,28,32,33,41,42,0,21,29,30,31,33,40,0,21,32,40,0 +1640 DATA 21,31,40,0,19,20,21,22,30,40,0 +1650 DIM MV(24) +1660 FOR I=0TO23:READMV(I):NEXT +1670 DATA 31,28,31,30,31,30,31,31,30,31,30,31,31,28,31,30,31,30,31,31 +1680 DATA 30,31,30,31 +1690 DIM SD(9) +1700 FOR I=0TO8:READSD(I):NEXT +1710 DATA 6,7,2,3,4,5,7,1,2 +1720 DIM HN(63) +1730 FOR I=49 TO 55:READHN(I):NEXT +1740 DATA 2345,16,16,2345,16,16,2345 +1750 PRINT:PRINT +1760 RETURN +1770 F=365*Z+Y+31*(X-1)+INT((Z-1)/4)-INT(.75*(INT((Z-1)/100)+1)):RETURN +1780 F=365*Z+Y+31*(X-1)-INT(.4*X+2.3)+INT(Z/4)-INT(.75*(INT(Z/100)+1)):RETURN +NT((Z-1)/4)-INT(.75*(INT((Z-1)/10 \ No newline at end of file diff --git a/software/BAS/BIRTHDAY.bas b/software/BAS/BIRTHDAY.bas new file mode 100644 index 0000000..902840d --- /dev/null +++ b/software/BAS/BIRTHDAY.bas @@ -0,0 +1,154 @@ +100 REM BIRTHDAY UPDATED 5-5-77 TO "MITS" BY D. NIXON +110 DIM Z$(12),L(12),N(60),Y$(7) +120 DIM G$(12),H$(32) +130 FOR I=1 TO 12:READ Z$(I):NEXT +140 FOR I=1 TO 12:READ L(I):NEXT +150 FOR I=1 TO 7:READ Y$(I): NEXT +160 FOR I=1 TO 12:READ G$(I):NEXT +170 FOR I=1 TO 32:READ H$(I):NEXT +180 DATA JANUARY,FEBRUARY,MARCH,APRIL,MAY,JUNE,JULY,AUGUST: +190 DATA SEPTEMBER,OCTOBER,NOVEMBER,DECEMBER: +200 DATA 31,28,31,30,31,30,31,31,30,31,30,31: +210 DATA THURS,FRI,SATUR,SUN,MON,TUES,WEDNES: +220 DATA THE MOON,THE SUN,THE EARTH,THE PLANET MERCURY,VENUS,MARS: +230 DATA JUPITER,SATURN,THE PLANET URANUS,THE PLANET NEPTUNE: +240 DATA THE PLANET PLUTO,PEANUT BUTTER: +250 DATA JUXTAROTATION,CONTRAPOSITION,CONTRASTING PHASES,TRANSPOSITION: +260 DATA SATISFIED,HAPPY,INTERESTING,TOLERANT: +270 DATA OFTEN,OCCASIONALLY,SOMETIMES: +280 DATA TEND TO BE,ARE,ARE INCLINED TO BE: +290 DATA SHORT OF PATIENCE,UNEASY,AT ODDS: +300 DATA OTHERS.,CLOSE FRIENDS.,YOUNGER PEOPLE.,THOSE IN AUTHORITY.: +310 DATA ": BEWARE OF "," AVOID " +320 DATA APPLE PIE,BEING ALONE,DARK PLACES,STRANGERS,UNUSUAL SITUATIONS: +330 DATA BE TAKING A TRIP YOU HAVE NOT MADE BEFORE. +340 DATA BE MEETING SOMEONE YOU WILL KNOW FOR THE REST OF YOUR LIFE. +350 DATA MAKE SEVERAL IMPORTANT DECISIONS INVOLVING OTHERS. +360 DATA BECOME ILL IF YOU DO NOT LESSEN YOUR UNUSUAL ACTIVITIES. +370 PRINT "TYPE IN TODAY'S DATE NUMERICALLY: MO,DAY,YEAR"; +380 INPUT X1,Y1,Z1 +390 IF Z1>99 GOTO 410 +400 Z1=Z1+1900 +410 XF=X1:YF=Y1:ZF=Z1:GOSUB 1220:U=ND +420 PRINT "TODAY IS ";Y$(U-7*INT(U/7)+1);"DAY (I HOPE)" +430 PRINT +440 PRINT "HI, I'M A MICROPROCESSOR." +450 PRINT "TELL ME YOUR NAME"; +460 INPUT N$ +470 I=INSTR(N$," ")-1 +480 IF I<0 THEN 580 +490 K$=LEFT$(N$,I) +500 PRINT "ARE YOU USUALLY CALLED ";K$; +510 INPUT A$ +520 GOSUB 1140 +530 ON NA GOTO 540,560,510 +540 PRINT "WHAT DO YOU LIKE TO BE CALLED"; +550 INPUT K$ +560 PRINT "SO YOUR FULL NAME IS ";N$;", BUT YOU" +570 PRINT "LIKE TO BE CALLED ";K$;"." +580 PRINT "HOW OLD ARE YOU, ";K$; +590 INPUT A +600 A=INT(A) +610 IF INT((A-5)/95)=0 GOTO 640 +620 PRINT "COME ON, ";K$;", YOU'RE PULLING MY LEG." +630 GOTO 580 +640 PRINT "SO YOU ARE";A;"YEARS OLD." +650 PRINT "DO YOU KNOW, OFF HAND, HOW MANY DAYS OLD YOU ARE"; +660 INPUT A$ +670 GOSUB 1140 +680 ON NA GOTO 720,690,660 +690 PRINT "OK, SMARTY, HOW MANY?" +700 PRINT "SORRY, ";K$;", YOU'LL HAVE TO BE FASTER THAN THAT!" +710 GOTO 1600 +720 PRINT "OK, I'LL TELL YOU." +730 PRINT "IN WHAT MONTH WERE YOU BORN"; +740 INPUT M$ +750 FOR X=1 TO 12 +760 IF M$=Z$(X) GOTO 800 +770 NEXT X +780 PRINT K$;", YOU MAY BE NICE BUT YOU CAN'T SPELL." +790 GOTO 730 +800 PRINT "ON WHAT DAY"; +810 INPUT Y +820 Z=Z1-A +830 IF INT((Y-1)/L(X))=0 GOTO 870 +840 IF (X-1)*(Y-28)*(Z-4*INT(Z/4)+1)=1 GOTO 870 +850 PRINT "COME ON, ";N$;", YOU'RE GIVING ME A HARD TIME." +860 GOTO 800 +870 REM +880 XF=X1:YF=Y1:ZF=Z:GOSUB 1220:W=ND +890 XF=X:YF=Y:ZF=Z:GOSUB 1220:V=ND +900 IF W=> V GOTO 920 +910 Z=Z-1 +920 IF ABS(W-V)>30 GOTO 990 +930 ON SGN(W-V)+2 GOTO 940,980,960 +940 PRINT "YOU HAVE A BIRTHDAY COMING UP IN ONLY";V-W;"DAYS!" +950 GOTO 990 +960 PRINT "YOUR BIRTHDAY WAS ONLY";W-V;"DAYS AGO. CONGRATULATIONS!" +970 GOTO 990 +980 PRINT "HAPPY BIRTHDAY, DEAR ";K$;", HAPPY BIRTHDAY TO YOU." +990 XF=X:YF=Y:ZF=Z:GOSUB 1220:V=ND +1000 PRINT "YOU WERE BORN ON ";Y$(V-7*INT(V/7)+1);"DAY, ";Z$(X);Y;",";Z +1010 PRINT "WHICH MAKES YOU";U-V;"DAYS OLD." +1020 PRINT "YOU WERE BORN ON THE DAY";V;"AD, AND ON JAN. 1, 2000" +1030 PRINT "YOU WILL BE";730480!-V;"DAYS OLD." +1040 PRINT "HOW ABOUT THAT!!!" +1050 PRINT +1060 GOSUB 1350 +1070 PRINT "WELL, ";N$; +1080 IF N$=K$ GOTO 1100 +1090 PRINT " (ALIAS ";K$;")" +1100 PRINT " IT HAS BEEN NICE CHATTING WITH YOU. DO COME AGAIN." +1110 PRINT "GOOD BYE" +1120 GOTO 1600 +1130 REM SUBROUTINE FOR YES NO REQUEST +1140 NA=1 +1150 IF A$="NO" GOTO 1210 +1160 IF A$="N0" GOTO 1210 +1170 NA=2 +1180 IF A$="YES" GOTO 1210 +1190 NA=3 +1200 PRINT "A SIMPLE YES OR NO WILL DO! " +1210 RETURN +1220 REM SUBROUTINE TO SOLVE FOR NUMBER OF DAYS +1230 ND=YF-1 +1240 FOR I1=1 TO XF-1 +1250 ND=ND+L(I1) +1260 NEXT I1 +1270 I1=INT(ZF/100) +1280 IF ZF<>4*INT(ZF/4) GOTO 1330 +1290 IF ZF/100=I1 GOTO 1330 +1300 IF ND>59 GOTO 1330 +1310 IF XF=3 GOTO 1330 +1320 ND=ND-1 +1330 ND=ND+36524!*I1+INT(365.25*(ZF-100*I1)) +1340 RETURN +1350 REM GENERATE RANDOM HOROSCOPE +1360 R1=INT(12*RND(1))+1 +1370 R2 = INT(12*RND(1))+1 +1380 IF R1=R2 GOTO 1370 +1390 R=1 +1400 X=4:GOSUB 1570 +1410 PRINT "YOU WERE BORN UNDER THE ";H$(NR);" OF ";G$(R1) +1420 X=4:GOSUB 1570 +1430 PRINT "AND ";G$(R2);". YOU ARE A BASICALLY ";H$(NR) +1440 X=3:GOSUB 1570 +1450 PRINT "PERSON BUT ";H$(NR); +1460 GOSUB 1570 +1470 PRINT " YOU ";H$(NR) +1480 GOSUB 1570:N1=NR:X=4:GOSUB 1570:N2=NR:X=2:GOSUB 1570 +1490 PRINT H$(N1);" WITH ";H$(N2);H$(NR) +1500 X=5:GOSUB 1570 +1510 PRINT H$(NR);" FOR THE NEXT WEEK. I PREDICT YOU WILL SOON" +1520 X=4:GOSUB 1570 +1530 PRINT H$(NR) +1540 PRINT +1550 RETURN +1560 REM SUBROUTINE TO SELECT RANDOM WORDS +1570 NR=INT(X*RND(1))+R +1580 R=R+X +1590 RETURN +1600 END + +1550 RETURN +1560 REM SUBROUTINE TO SELECT \ No newline at end of file diff --git a/software/BAS/BLACKJCK.bas b/software/BAS/BLACKJCK.bas new file mode 100644 index 0000000..280e9c1 --- /dev/null +++ b/software/BAS/BLACKJCK.bas @@ -0,0 +1,167 @@ +100 REM *** B L A C K J A C K *** +101 WIDTH 80 +110 DIM D(208),H(16),O(16),P(16,11),Q(11),S(16),X(16) +120 PRINT:PRINT"WELCOME TO THE CASINO" +130 PRINT "WE PLAY VEGAS STYLE BLACKJACK" +140 PRINT:INPUT"INSTRUCTIONS? (YES-NO) ";M$: IF M$="NO" THEN GOTO 160 +150 IF M$="YES" THEN GOSUB 1640:GOTO 160 ELSE GOTO 140 +160 R=16:PRINT"HOW MANY DECKS (1-4)"; +170 INPUTN:IFN<1ORN>4THENPRINT"1 TO 4 DECKS ONLY. REENTER";:GOTO170 +180 E=N*52:GOSUB870:B=1:GOSUB890:A=1 +190 PRINT:G=1 +200 INPUT"BET PLEASE";U:IF U>0 THENGOTO220 ELSE IF U=0 THEN GOTO1600 +210 B=1:GOSUB 890:GOTO 200 +220 IF U<=500 THEN GOTO240 ELSEPRINT"SORRY, THE HOUSE LIMIT IS $500!" +230 GOTO 200 +240 GOSUB930:H(1)=U:N=Q(2):PRINT:PRINT"MY UP CARD";:GOSUB1050:N=P(R,1) +250 PRINT : PRINT"YOUR 1ST CARD";:GOSUB1050:PRINT"YOUR 2ND CARD";:N=P(R,2) +260 GOSUB 1050 +270 GOSUB1170:IFM<>11THEN GOTO 280 ELSE GOSUB 1550 +280 IF W<>21 THEN GOTO 320 ELSE PRINT : PRINT"I HAVE BLACKJACK, "; +290 IF X(1)<>21 THEN GOTO 310 ELSE PRINT"SO DO YOU, WE PUSH" +300 GOSUB 1510:GOTO 190 +310 PRINT"YOU LOSE":V=V-U:GOTO300 +320 IF X(1)<>21 THEN GOTO340 ELSE PRINT"YOU HAVE BLACKJACK, YOU WIN!" +330 V=V+3*U/2:GOTO300 +340 PRINT:PRINT"PLAY ";:IF R=1 THEN GOTO 350 ELSE PRINT"FOR HAND";G; +350 PRINT:PRINT"YOUR TOTAL IS";X(G);:INPUT F:IF F>-1 THEN GOTO 370 +360 PRINT"ONLY 0-3 IS VALID, REENTER";:GOTO350 +370 IF F>3 THEN GOTO 360 ELSE IF F<>1 THEN GOTO 550 +380 REM ******** PLAYER HIT ROUTINE ************* +390 IF A<=E THEN GOTO 400 ELSE GOSUB 1220 +400 M=S(G):M=M+1:S(G)=M:N=D(A):P(G,M)=N:PRINT"YOUR CARD IS";:GOSUB 1050 +410 GOSUB 1010:A=A+1:IF N<>11 THEN GOTO 420 ELSE O(G)=O(G)+1 +420 X(G)=X(G)+N +430 IF X(G)<22 THEN GOTO 340 ELSE IF O(G)=0 THEN 450 +440 O(G)=O(G)-1:X(G)=X(G)-10:GOTO 430 +450 PRINT:PRINT"YOU BUSTED WITH";X(G):X(G)=0:Y=Y-1:PRINT +460 REM ********* CHECK FOR END OF PLAY ************ +470 IF G0 GOTO 620 +560 REM *********PLAYER STAND ALONE ROUTINE ************ +570 IF X(G)<22 GOTO 470 +580 IF O(G)=0 GOTO 450 +590 X(G)=X(G)-10 +600 O(G)=O(G)-1 +610 G=G+1 +620 IF F<>2 GOTO 730 +630 IF S(G)=2 GOTO 670 +640 PRINT "DOUBLE ON 1ST 2 CARDS ONLY" +650 GOTO 340 +660 REM ***** DOUBLE DOWN ROUTINE ********** +670 IF A<=E THEN GOTO 680 ELSE 1220 +680 H(G)=2*U:N=D(A):P(G,3)=N:A=A+1:PRINT "YOU DRAW THE";:GOSUB 1050 +690 GOSUB 1010:IF N=11 THEN O(G)=O(G)+1 +700 X(G)=X(G)+N +710 IF X(G)<22 THEN GOTO 470 +720 IF O(G)=0 THEN GOTO 450 ELSE O(G)=O(G)-1:X(G)=X(G)-10:GO1350 +730 N=P(G,1):Y=Y+1:GOSUB 1010:M=N:N=P(G,2):GOSUB1010:IFM=NTHENGOTO760 +740 PRINT "YOU MAY ONLY SPLIT PAIRS": GOTO 340 +750 REM *********PAIR SPLIT ROUTINE ********** +760 R=R+1:Y=Y+1:P(R,1)=P(G,2):S(G)=1:S(R)=1:X(G)=X(G)/2:X(R)=X(G) +770 H(R)=U:IF N<>11 THEN GOTO 340 +780 REM **********ACES WERE SPLIT - 1 CARD EACH ********* +790 IF A>E THEN GOSUB 1220 +800 N=D(A):P(G,2)=N:PRINT "1ST ACE GETS A";:GOSUB 1050: GOSUB 1010 +810 IF N=11 THEN N=1 +820 X(G)=X(G)+N:A=A+1:IF A>E THEN GOSUB 1220 +830 N=D(A):P(R,2)=N:PRINT "2ND ACE GETS A";:GOSUB 1050:GOSUB 1010 +840 IF N=11 THEN N=1 +850 X(R)=X(R)+N:A=A+1:GOTO480 +860 REM ************ BUILD 1 TO 4 DECKS ************ +870 FOR I=1 TO N: J=(I-1)*52: FOR K =1 TO 52: D(J+K)=K:NEXT K,I:RETURN +880 REM *********SHUFFLE THE CARDS *********** +890 PRINTCHR$(26):PRINT "I'M SHUFFLING.... ":FOR I=B TO E +900 C=RND(1)*E:IF CE THEN B=1:GOSUB 890 +950 PRINT "DEALING":P(R,1)=D(A):Q(1)=D(A+1):P(R,2)=D(A+2):Q(2)=D(A+3) +960 A=A+4:T=2:S(1)=2:GOSUB980:M=N:RETURN +970 REM ********** COMPUTE THE VALUE OF THE DEALERS HAND ********* +980 Z=0:W=0:FOR I=1 TO 2:N=Q(I):GOSUB 1010:IF N=11 THEN Z=Z+1 +990 W=W+N:NEXT I :RETURN +1000 REM **********COMPUTE THE VALUE OF A CARD **********: +1010 IF N<14 THEN GOTO 1020 ELSE N=N-13:GOTO 1010 +1020 IF N=1 THEN N=11:RETURN ELSE GOTO 1030 +1030 IF N<11 THEN RETURN ELSE N=10:RETURN +1040 **********PRINT A CARD ********** +1050 I=0 +1060 IF N>=14 THEN N=N-13:I=I+1:GOTO1060 +1070 IF N=1 THEN PRINT TAB(17);"ACE ";:GOTO1130 +1080 IF N<10 THEN PRINT TAB(18);N;:GOTO1130 +1090 IF N<11 THEN PRINT TAB(17);N;:GOTO 1130 +1100 IF N<12 THEN PRINT TAB(16);"JACK ";:GOTO1130 +1110 IF N<13 THEN PRINT TAB(15);"QUEEN ";:GOTO 1130 +1120 PRINT TAB(16);"KING "; +1130 PRINT "OF ";:IF I=0 THEN PRINT "SPADES":RETURN +1140 IF I=1 THEN PRINT "HEARTS":RETURN +1150 IF I=2 THEN PRINT "DIAMONDS":RETURN ELSE PRINT "CLUBS":RETURN +1160 REM ********* COMPUTE VALUE OF PLAYERS HAND *********: +1170 O(G)=0:X(G)=0:FOR I =1 TO 2: N=P(G,I):GOSUB 1010:X(G)=X(G)+N +1180 IF N<>11 THEN GOTO 1200 +1190 O(G)=O(G)+1 +1200 NEXT I:RETURN +1210 REM *********SAVE THE CARDS THAT ARE ALREADY DEALT AND SHUFFLE** +1220 K=T:FOR I=1 TO R:K=K+S(I):NEXT I +1230 FOR I=1TOK:A=A-1:J=D(I):D(I)=D(A):D(A)=J:NEXTI:B=K+1:GOSUB890:RETURN +1240 REM *******DEALERS LOGIC **********: +1250 N=Q(1):PRINT "MY HOLE CARD";:GOSUB 1050:IF Y=0 THEN GOTO 1390 +1260 IF W<17 THEN GOTO 1300 +1270 IF W>17 THEN GOTO 1340 +1280 IF Z=0 THEN GOTO 1380 +1290 W=W-10:Z=Z-1 +1300 IF A>E THEN GOSUB 1220 +1310 N=D(A):T=T+1:A=A+1:PRINT:PRINT "I DRAW THE";:GOSUB1050:GOSUB1010 +1320 IF N=11 THEN Z=Z+1 +1330 W=W+N:GOTO 1260 +1340 IF W<22 THEN GOTO 1380 +1350 IF Z=0 THEN GOTO 1370 +1360 Z=Z-1:W=W-10:GOTO1260 +1370 PRINT "I BUSTED "; +1380 PRINT "MY TOTAL IS ";W +1390 FOR I =1 TO R:PRINT "YOU ";:IF X(I)<>0 THEN GOTO 1410 +1400 PRINT "LOST ";:V=V-H(I):GOTO 1460 +1410 IF W<22 THEN GOTO 1430 +1420 PRINT "WON ";:V=V+H(I):GOTO 1460 +1430 IF W<>X(I) THEN GOTO 1450 +1440 PRINT "PUSHED ON ";:GOTO1460 +1450 IF W1 THEN GOTO 1470 ELSE PRINT "THE HAND":GOTO 1480 +1470 PRINT "HAND ";I +1480 NEXT I +1490 REM ********* PRINT THE PLAYERS WON/LOST STANDING ******* +1500 PRINT +1510 PRINT "YOU'RE ";:IF V=0 THEN PRINT "EVEN":RETURN +1520 IF V<0 THEN PRINT "BEHIND $"V:RETURN ELSE PRINT "AHEAD $";V:RETURN +1530 PRINT "AHEAD $";V +1540 REM ********INSURANCE ROUTINE ************ +1550 INPUT "INSURANCE (YES-NO)";M$:IF M$="NO" THEN RETURN +1560 IF M$<>"YES" THEN GOTO 1550 +1570 PRINT "YOUR INSURANCE BET ";:IF W=21 THEN PRINT "WINS":V=V+U:RETURN +1580 PRINT "LOSES":V=V-U/2:RETURN +1590 REM ******END OF GAME WRAP UP ************** +1600 PRINT "THANKS FOR PLAYING":PRINT "HOPE YOU ENJOYED YOURSELF" +1610 PRINT "HERE'S YOUR FINAL STANDING!":GOSUB 1510 +1620 IFV>0THENPRINT"NOW, JUST YOU TRY TO COLLECT !!":END +1630 IF V=0THENPRINT"BIG DEAL......":END ELSEPRINT"PAY UP, OR ELSE":END +1640 REM ******** INSTRUCTIONS *********** +1650 PRINT:PRINT"THE DEALER STANDS ON 17 OR MORE" +1660 PRINT"BUT WILL HIT A SOFT 17." +1670 PRINT"YOU MAY SPLIT ANY PAIR.":PRINT"YOU MAY DOUBLE THE 1ST 2 CARDS" +1680 PRINT"AND GET ONLY 1 MORE CARD.":PRINT:PRINT"PLAY CODES:" +1690 PRINT " 0 - STAND":PRINT " 1 - HIT":PRINT " 2 - DOUBLE DOWN" +1700 PRINT " 3 - SPLIT A PAIR":PRINT:PRINT "A ZERO BET ENDS THE GAME" +1710 PRINT "A NEGATIVE BET FORCES A SHUFFLE" +1720 PRINT "GOOD LUCK - LET'S START":RETURN +T:PRINT "A ZERO BET ENDS THE GAME" +1710 PRINT "A NEGATIVE BET FORCES A SHUFFLE" +1720 PRINT "GOOD LUC \ No newline at end of file diff --git a/software/BAS/BUDGET.bas b/software/BAS/BUDGET.bas new file mode 100644 index 0000000..87be9ef --- /dev/null +++ b/software/BAS/BUDGET.bas @@ -0,0 +1,218 @@ +100 REM TYPED BY CONNIE FOSTER ,CORRECTED BY C.FOSTER ,PROG BY O.E.DIAL +110 REM ALL REM STATEMENTS CAN BE CHANGED TO ALLOW USE OF TWO TERMINALS +120 REM SEE ARTICLE IN PERSONAL COMPUTING MAY/JUNE 77 +130 Q=27:V$="###.#":W$="$$#####,":U$="###" +140 DIMD(18),E$(Q),V(Q),F(Q) +150 PRINTTAB(19)"RECURSIVE BUDGETING MODEL":PRINT:PRINTTAB(28)"* * *" +160 DATASALARY/WAGES,OTHER INCOME,FED INC TAX,STATE & LOCAL TAX +170 DATASOCIAL SECURITY,UNEMPLOYMENT INS,HEALTH INS +180 DATALIFE INS,CONTRIBUTIONS,OTHER DEDUCTIONS +190 DATARENT/MORTGAGE,LIFE INS,HEALTH INS,HOUSE INS +200 DATAAUTO INS,CAR PAYMENTS,LOAN PAYMENTS,TRASH REMOVAL +210 DATAOTHER FIXED EXP +220 DATAFOOD/BEVERAGES,CLOTHING,DRY CLEANING,BARBER/BEAUTY +230 DATAHOME MAINT,HOME HEAT'G FUEL,WATER,ELECTRICITY, TELEPHONE +240 DATAGAS/OIL,AUTO MAINT,FARES/TOLLS/PARKING,DENTIST +250 DATAPHYSICIAN,DRUGS/SUNDRIES,SCHOOL EXPENSE,FAMILY ALLOWANCE +260 DATACLUBS/LODGES,THEATER/SPORTS,RESTAURANTS +270 DATAOTHER ENT'MENT,MAG'S/BOOKS/PAPERS,SITTERS,CHILD CARE +280 DATAVACATION SAVING,OTHER SAVINGS,CONTRIBUTIONS,OTHER EXPENSES +290 PRINT:PRINT"SELECT YOUR BUDGETING PERIOD BY NUMBER. LATER ON IT WILL" +300 PRINT"BE EXTENDED TO ONE YEAR.":PRINT +310 PRINTTAB(3)"1-WEEKLY"TAB(15)"2-BIWEEKLY"TAB(30)"3-SEMIMONTHLY"; +320 PRINTTAB(45)"4-MONTHLY":PRINT +330 INPUTP:IFP>4THENPRINT"TRY AGAIN":GOTO290 +340 IFP=1THENP=52ELSEIFP=2THENP=26ELSEIFP=3THENP=24ELSEIFP=4THENP=12 +350 PRINT:PRINT"ALRIGHT,FIRST LET'S LOOK AT INCOME FOR THE PERIOD.":PRINT +360 READA$:PRINTA$;" $";:INPUTD(0):READA$:PRINTA$;" $";:INPUTD(1) +370 TI=D(0)+D(1):PRINT +380 PRINT:PRINT"OK,NOW LET'S LOOK AT PAYCHECK DEDUCTIONS.":PRINT +390 FORJ=2TO9:READA$:PRINTA$;:INPUT" $";D(J):TD=TD+D(J):NEXTJ:PRINT +400 PRINT"OK,NOW LET'S LOOK AT FIXED EXPENSES.":PRINT +410 FORJ=10TO18:READA$:PRINTA$;:INPUT" $";D(J):TF=TF+D(J):NEXTJ +420 DF=TD+TF:SI=TI-DF:S=64 +430 PRINT:PRINT"OK,AT THIS TIME OUR TABLE LOOKS LIKE THIS:":PRINT +440 REM +450 GOSUB1900:PRINT:PRINTTAB(19); +460 PRINT"RECURSIVE BUDGETING MODEL":PRINT:PRINTTAB(27)"* * *":PRINT +470 GOSUB1900 +480 PRINT:PRINTTAB(20)"SPENDABLE INCOME SUMMARY":PRINT +490 GOSUB1890:PRINTTAB(3)"ACCOUNT"TAB(42)"PERIOD"TAB(57)"ANNUAL" +500 GOSUB1890:PRINT"TOTAL INCOME" TAB(40);:PRINTUSINGW$;TI;:PRINTTAB(55) +510 PRINTUSINGW$;TI*P:PRINT:PRINTTAB(3)"PAYCHECK DEDUCTIONS"TAB(25); +520 PRINTUSINGW$;TD*(-1):PRINT +530 PRINTTAB(3)"FIXED EXPENSES"TAB(25);:PRINTUSINGW$;TF*(-1); +540 PRINTTAB(40);:PRINTUSINGW$;DF*(-1);:PRINTTAB(55); +550 PRINTUSINGW$;DF*(-1)*P +560 PRINTTAB(41)"-------"TAB(55)"--------":PRINT"SPENDABLE INCOME"; +570 PRINTTAB(40);:PRINTUSINGW$;SI;:PRINTTAB(55);:PRINTUSINGW$;SI*P +580 PRINTTAB(41)"======="TAB(55)"========":PRINT: +590 GOSUB1900:PRINT: PRINT +600 REM +610 GOSUB1910:RO=0 +620 PRINT:PRINT "OK,NOW FOR THE FIRST ROUND OF VARIABLE EXPENSE. DON'T" +630 PRINT"PINCH YOURSELF IN YOUR ESTIMATES (WITHIN REASON). LET THE" +640 PRINT"COMPUTER HELP YOU REFINE YOUR BUDGET LATER ON.":PRINT +650 FORJ=0TOQ:READE$(J) :PRINTE$(J);:INPUT" $";V(J):VT=VT+V(J):NEXTJ +660 RESTORE:PRINT:PRINT +670 PRINT"YOUR BUDGET FOR THE FIRST ROUND TOTALLED $"VT". THIS" +680 PRINT"COMPARES TO SPENDABLE INCOME OF $"SI". WE HAVE" +690 PRINT"PRORATED THE DIFFERENCE, $"SI-VT",OVER ALL VARIABLE EXPENSE" +700 PRINT"ACCOUNTS.":PRINT +710 GOSUB1910:FORJ=0TOQ:V(J)=INT(V(J)/VT*SI):NEXTJ:VT=SI:PRINT +720 PRINT"NOW WE BEGIN THE BUDGET REFINEMENT PHASE. MAKE AS MANY" +730 PRINT"PASSES AS YOU LIKE. AS YOU REVIEW EACH ACCOUNT,DECIDE" +740 PRINT"WHETHER TO FREEZE IT OR TO LEAVE IT FOR ANOTHER PASS.":PRINT +750 PRINT"HINT: DON'T BE IN A HURRY TO FREEZE AN ACCOUNT.":PRINT +760 PRINT"YOUR TASK IS FINISHED WHEN ALL ACCOUNTS ARE FROZEN.":PRINT +770 GOSUB1910 +780 FORJ=0TOQ:PRINT:IFV(J)=0THEN980 +790 PRINTE$(J);" $";V(J):INPUT"CHANGE ('Y' OR 'N')";A$ +800 IFA$="N"THEN840ELSEIFA$="Y"THEN820ELSEIFA$<>"Y"THEN790 +810 GOTO790 +820 INPUT"REVISED AMOUNT $";A:IFA"Y" THEN 110 +150 PRINT "YOU ARE '*' IN A HIGH VOLTAGE MAZE WITH 5" +160 PRINT "SECURITY MACHINES '+' TRYING TO DESTROY YOU" +170 PRINT "YOU MUST MANEUVER THE SECURITY MACHINES INTO" +180 PRINT "THE MAZE 'X' TO SURVIVE. GOOD LUCK !!!" +190 PRINT "MOVES ARE 7,8,9" +200 PRINT " 4,5,6" +210 PRINT " 1,2,3 0 TO END THE GAME" +220 PRINT +230 DIM A(10,20),E(21),F(21) +240 LET G=0 +250 FOR B=1 TO 10 +260 FOR C=1 TO 20 +270 LET A(B,C)=0 +280 IF B=1 THEN 330 +290 IF B=10 THEN 330 +300 IF C=1 THEN 330 +310 IF C=20 THEN 330 +320 GOTO 340 +330 LET A(B,C)=1 +340 NEXT C +350 NEXT B +360 FOR D=1 TO 21 +370 LET B=INT(RND(1)*8)+2 +380 LET C=INT(RND(1)*18)+2 +390 IF A(B,C)<>0 THEN 370 +400 LET A(B,C)=1 +410 IF D<6 THEN 430 +420 GOTO 440 +430 LET A(B,C)=2 +440 IF D=6 THEN 460 +450 GOTO 470 +460 LET A(B,C)=3 +470 LET E(D)=B +480 LET F(D)=C +490 NEXT D +500 FOR B=1 TO 10 +510 FOR C=1 TO 20 +520 IF A(B,C)<>0 THEN 550 +530 PRINT " "; +540 GOTO 630 +550 IF A(B,C)<>1 THEN 580 +560 PRINT "X"; +570 GOTO 630 +580 IF A(B,C)<>2 THEN 610 +590 PRINT "+"; +600 GOTO 630 +610 IF A(B,C)<>3 THEN 630 +620 PRINT "*"; +630 NEXT C +640 PRINT +650 NEXT B +660 LET B=E(6) +670 LET C=F(6) +680 LET A(B,C)=0 +690 INPUT Y +700 ON Y+1 GOTO 1040,730,730,730,740,780,740,710,710,710 +710 LET B=B-1 +720 GOTO 740 +730 LET B=B+1 +740 ON Y GOTO 750,780,770,750,780,770,750,780,770 +750 LET C=C-1 +760 GOTO 780 +770 LET C=C+1 +780 IF A(B,C)=1 THEN 1060 +790 IF A(B,C)=2 THEN 1080 +800 LET A(B,C)=3 +810 LET E(6)=B +820 LET F(6)=C +830 FOR D=1 TO 5 +840 IF A(E(D),F(D))<>2 THEN 1020 +850 LET A(E(D),F(D))=0 +860 IF E(D)>=B THEN 890 +870 LET E(D)=E(D)+1 +880 GOTO 910 +890 IF E(D)=B THEN 910 +900 LET E(D)=E(D)-1 +910 IF F(D)>=C THEN 940 +920 LET F(D)=F(D)+1 +930 GOTO 960 +940 IF F(D)=C THEN 960 +950 LET F(D)=F(D)-1 +960 IF A(E(D),F(D))=3 THEN 1080 +970 IF A(E(D),F(D))=0 THEN 1000 +980 LET G=G+1 +990 GOTO 1010 +1000 LET A(E(D),F(D))=2 +1010 IF G=5 THEN 1100 +1020 NEXT D +1030 GOTO 500 +1040 PRINT "SORRY TO SEE YOU QUIT" +1050 GOTO 1110 +1060 PRINT "ZAP!!! YOU TOUCHED THE FENCE !!!!!" +1070 GOTO 1110 +1080 PRINT "** YOU HAVE BEEN DESTROYED BY A LUCKY COMPUTER **" +1090 GOTO 1110 +1100 PRINT "YOU ARE LUCKY **YOU DESTROYED ALL THE ENEMY**" +1110 PRINT "WANT TO PLAY AGAIN"; +1120 INPUT C$ +1130 IF LEFT$(C$,1)="Y" THEN 240 +1140 IF LEFT$(C$,1)<>"N" THEN 1110 +1150 PRINT "HOPE YOU DON'T FEEL FENCED IN." +1160 PRINT "TRY AGAIN SOMETIME" +1170 END +0 +1140 IF LEFT$(C$,1)<>"N" THEN 1110 +1150 PRINT "HOPE YOU DON'T FEEL FENCED IN." +1160 PRINT "TRY AGAIN SOMET \ No newline at end of file diff --git a/software/BAS/CHESS.bas b/software/BAS/CHESS.bas new file mode 100644 index 0000000..3198ffd --- /dev/null +++ b/software/BAS/CHESS.bas @@ -0,0 +1,498 @@ +100 REM--CHESS BY RANDY MILLER, JAN, 1976 +110 DEFINT A-Z:DEFSNG E:DEFSNG M:DEFSNG P +120 DIM PS(70,3),MV(35,2),V(32) +130 DIM B(8,8),TM(8,8) +140 DEF FNL(X)=X\10 +150 DEF FNM(X)=X MOD(10) +160 TM(1,1)=0 +170 FOR X=1 TO 32 +180 READ V(X) +190 NEXT +200 FOR Y=1 TO 8 +210 FOR X=1 TO 8 +220 READ B(X,Y) +230 NEXT X:NEXT Y +240 DATA -2,1,-1,2,1,2,2,1,2,-1,1,-2,-1,-2,-2,-1 +250 DATA 8,12,19,21,-8,-12,-19,-21 +260 DATA 1,9,10,11,-1,-9,-10,-11 +270 DATA 4,2,3,6,5,3,2,4,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0 +280 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1 +290 DATA -1,-1,-1,-1,-4,-2,-3,-6,-5,-3,-2,-4 +300 CB=3:CW=3 +310 PRINT:PRINT:PRINT:PRINT TAB(10);"**** CHESS ****" +320 INPUT "DO YOU WANT TO BE WHITE OR BLACK";C$ +330 IF LEFT$(C$,1)="B" THEN 370 +340 B(4,1)=5:B(4,8)=-5 +350 B(5,1)=6:B(5,8)=-6 +360 GOTO 380 +370 PRINT "THANK YOU, THAT MEANS I GET TO GO FIRST":PRINT +380 FOR Y=1 TO 8 +390 FOR X=1 TO 8 +400 TM(X,Y)=B(X,Y) +410 NEXT X:NEXT Y +420 IF LEFT$(C$,1)<>"B" THEN 840 +430 NB=1 +440 REM -- COMPILE LIST OF POSSIBLE MOVES -- +450 FOR X=1 TO 8 +460 FOR Y=1 TO 8 +470 IF SGN(B(X,Y))<>1 THEN 550 +480 GOSUB 1870 +490 FOR D=1 TO N +500 IF MV(D,1)=0 THEN 540 +510 PS(NB,1)=MV(D,1) +520 PS(NB,2)=MV(D,2) +530 NB=NB+1 +540 NEXT D +550 NEXT Y +560 NEXT X +570 PRINT:PRINT "NUMBER OF POSSIBLE MOVES FOR COMPUTER";NB-1:PRINT +580 IF NB>1 THEN PRINT "FROM TO BOARD VALUE":GOTO 620 +590 PRINT "I DON'T BELIEVE IT! - YOU WON!!!" +600 END +610 REM -- EVALUATE EACH POSSIBLE MOVE -- +620 FOR D=1 TO NB-1 +630 D1=FNL(PS(D,1)) +640 D2=FNM(PS(D,1)) +650 D3=FNL(PS(D,2)) +660 D4=FNM(PS(D,2)) +670 D5=B(D3,D4) +680 TM(D3,D4)=TM(D1,D2) +690 TM(D1,D2)=0 +700 GOSUB 1530 +710 PS(D,3)=EV +720 TM(D1,D2)=TM(D3,D4) +730 TM(D3,D4)=D5 +740 PRINT PS(D,1);PS(D,2);TAB(12);PS(D,3) +750 NEXT D +760 REM +770 MZ=PS(1,3):MX=1 +780 IF NB=2 THEN 830 +790 FOR D=2 TO NB-1 +800 IF PS(D,3)<=MZ THEN 820 +810 MX=D:MZ=PS(D,3) +820 NEXT D +830 GOSUB 1290 +840 GOSUB 870 +850 PRINT +860 GOTO 430 +870 REM -- INPUT ROUTINE -- +880 GOTO 910 +890 INPUT "YOUR MOVE";M,N +900 IF M<>0 THEN 930 +910 FOR P=1 TO 8:FOR P1=1 TO 8:PRINT B(P1,P);:NEXT P1:PRINT:NEXT P +920 GOTO 890 +930 X1=FNL(M):Y1=FNM(M):X2=FNL(N):Y2=FNM(N) +940 IF X1>8 OR X1<1 OR Y1>8 OR Y1<1 THEN 970 +950 IF X2>8 OR X2<1 OR Y2>8 OR Y2<1 THEN 970 +960 IF SGN(B(X1,Y1))=-1 THEN 990 +970 PRINT "YOU CAN'T DO THAT." +980 GOTO 890 +990 REM +1000 FOR P=1 TO 8 +1010 FOR P1=1 TO 8 +1020 TM(P,P1)=B(P,P1) +1030 NEXT P1 +1040 NEXT P +1050 GOSUB 3690 +1060 IF LG=0 THEN 970 +1070 TM(X2,Y2)=TM(X1,Y1) +1080 TM(X1,Y1)=0 +1090 B(X2,Y2)=B(X1,Y1) +1100 B(X1,Y1)=0 +1110 PRINT "ACCEPTED." +1120 IF Y2<>1 OR B(X2,Y2)<>-1 THEN 1180 +1130 PRINT "TO PROMOTE YOUR PAWN TO A KNIGHT, TYPE 2; FOR A BISHOP," +1140 PRINT "TYPE 3; FOR A ROOK, TYPE 4; FOR A QUEEN, TYPE 5"; +1150 INPUT P +1160 IF P>5 OR P<2 THEN 1130 +1170 B(X2,Y2)=-P:TM(X2,Y2)=-P +1180 IF B(X2,Y2)<>-6 OR ABS(X1-X2)<>2 THEN 1240 +1190 IF X1-X2=2 THEN 1250 +1200 B(8,8)=0:TM(8,8)=0 +1210 B(X2-1,8)=-4:TM(X2-1,8)=-4 +1220 CB=(CB AND -3) +1230 PRINT "IT'S ABOUT TIME YOU CASTLED!":PRINT +1240 RETURN +1250 B(1,8)=0:TM(1,8)=0 +1260 B(X2+1,8)=-4:TM(X2+1,8)=-4 +1270 CB=(CB AND -3) +1280 GOTO 1230 +1290 REM -- OUTPUT ROUTINE -- +1300 IF PS(MX,3)<200 THEN 1350 +1310 PRINT "HA - LET'S SEE YOU GET OUT OF THIS -" +1320 PRINT "I MOVE";PS(MX,1);"TO";PS(MX,2) +1330 PRINT "THANKS FOR THE GOOD GAME..." +1340 END +1350 ON INT(RND(1)*4)+1 GOTO 1360,1370,1380,1390 +1360 PRINT "I RECKON I'LL MOVE ";:GOTO 1400 +1370 PRINT "I GUESS I'LL TAKE";:GOTO 1400 +1380 PRINT "MY MOVE IS";:GOTO 1400 +1390 PRINT "I LIKE"; +1400 PRINT PS(MX,1);"TO";PS(MX,2):PRINT +1410 D1=FNL(PS(MX,1)) +1420 D2=FNM(PS(MX,1)) +1430 D3=FNL(PS(MX,2)) +1440 D4=FNM(PS(MX,2)) +1450 B(D3,D4)=B(D1,D2) +1460 B(D1,D2)=0 +1470 IF D4<>8 OR B(D3,D4)<>1 THEN 1500 +1480 PRINT "I PROMOTE MY PAWN TO A QUEEN!" +1490 B(D3,D4)=5 +1500 RETURN +1510 REM +1520 EV=RND(1):RETURN +1530 EV=RND(1)/2:US=0 +1540 EV=EV+D4/7 +1550 FOR PJ=1 TO 8 +1560 IF TM(PJ,8)<>1 THEN 1590 +1570 TM(PJ,8)=5 +1580 GOTO 1610 +1590 NEXT PJ +1600 IF SGN(D5)=-1 THEN EV=EV-D5 +1610 FOR X=1 TO 8 +1620 FOR Y=1 TO 8 +1630 CX=TM(X,Y):CS=SGN(CX) +1640 IF CS<>-1 THEN 1750 +1650 EV=EV+CX +1660 GOSUB 1840 +1670 IF N=0 THEN 1750 +1680 US=US+N:EV=EV-.166666 +1690 FOR UX=1 TO N +1700 U1=MV(UX,1):U2=MV(UX,2) +1710 IF SGN(TM(FNL(U2),FNM(U2)))<>1 THEN 1740 +1720 IF SGN(TM(FNL(U1),FNM(U1)))<>-1 THEN 1740 +1730 EV=EV-2*TM(FNL(U2),FNM(U2)) +1740 NEXT UX +1750 NEXT Y +1760 NEXT X +1770 IF US>0 THEN 1800 +1780 EV=EV+1000 +1790 GOTO 1810 +1800 FOR X=3 TO 6:FOR Y=3 TO 6:EV=EV+TM(X,Y)/3:NEXTY:NEXTX +1810 IF PJ>8 THEN 1830 +1820 TM(PJ,8)=1 +1830 RETURN +1840 REM +1850 R=0 +1860 GOTO 1880 +1870 R=1 +1880 MV(1,1)=0 +1890 S1=SGN(TM(X,Y)) +1900 AA=X*10+Y +1910 N=1 +1920 ON ABS(TM(X,Y)) GOSUB 2330,2770,2880,3140,3400,3440 +1930 IF N=1 THEN 1950 +1940 IF R=1 THEN 1970 +1950 N=N-1 +1960 RETURN +1970 REM -- IF RESTRICTED -- +1980 N1=N-1 +1990 N=N1 +2000 FOR K=1 TO N1 +2010 C1=FNL(MV(K,1)) +2020 C2=FNM(MV(K,1)) +2030 C3=FNL(MV(K,2)) +2040 C4=FNM(MV(K,2)) +2050 IF ABS(TM(C3,C4))=6 THEN 2070 +2060 IF SGN(TM(C3,C4))<>S1 THEN 2080 +2070 MV(K,1)=0:MV(K,2)=0:GOTO 2290 +2080 C5=TM(C3,C4) +2090 TM(C3,C4)=TM(C1,C2) +2100 TM(C1,C2)=0 +2110 REM -- FIND KING -- +2120 FOR Y2=1 TO 8 +2130 FOR X2=1 TO 8 +2140 IF TM(X2,Y2)=6*S1 THEN 2170 +2150 NEXT X2 +2160 NEXT Y2 +2170 REM +2180 FOR Y1=1 TO 8 +2190 FOR X1=1 TO 8 +2200 IF SGN(TM(X1,Y1))<>-S1 THEN 2250 +2210 IF TM(X1,Y1)<>-S1 THEN 2230 +2220 IF X1=X2 AND ABS(Y2-Y1)>2 THEN 2250 +2230 GOSUB 3660 +2240 IF LG=1 THEN 2310 +2250 NEXT X1 +2260 NEXT Y1 +2270 TM(C1,C2)=TM(C3,C4) +2280 TM(C3,C4)=C5 +2290 NEXT K +2300 RETURN +2310 MV(K,1)=0:MV(K,2)=0 +2320 GOTO 2250 +2330 REM -- RAW PAWN MOVE -- +2340 IF S1=-1 THEN 2560 +2350 IF Y+1>8 THEN 2550 +2360 IF TM(X,Y+1)<>0 THEN 2450 +2370 MV(N,1)=AA +2380 MV(N,2)=X*10+Y+1 +2390 N=N+1 +2400 IF Y>2 THEN 2450 +2410 IF TM(X,Y+2)<>0 THEN 2450 +2420 MV(N,1)=AA +2430 MV(N,2)=X*10+Y+2 +2440 N=N+1 +2450 IF X=1 THEN 2500 +2460 IF SGN(TM(X-1,Y+1))<>-S1 THEN 2500 +2470 MV(N,1)=AA +2480 MV(N,2)=(X-1)*10+Y+1 +2490 N=N+1 +2500 IF X=8 THEN 2550 +2510 IF SGN(TM(X+1,Y+1))<>-S1 THEN 2550 +2520 MV(N,1)=AA +2530 MV(N,2)=(X+1)*10+Y+1 +2540 N=N+1 +2550 RETURN +2560 IF Y-1<1 THEN 2760 +2570 IF TM(X,Y-1)<>0 THEN 2660 +2580 MV(N,1)=AA +2590 MV(N,2)=X*10+Y-1 +2600 N=N+1 +2610 IF Y<7 THEN 2660 +2620 IF TM(X,Y-2)<>0 THEN 2660 +2630 MV(N,1)=AA +2640 MV(N,2)=X*10+Y-2 +2650 N=N+1 +2660 IF X=1 THEN 2710 +2670 IF SGN(TM(X-1,Y-1))<>-S1 THEN 2710 +2680 MV(N,1)=AA +2690 MV(N,2)=(X-1)*10+Y-1 +2700 N=N+1 +2710 IF X=8 THEN 2760 +2720 IF SGN(TM(X+1,Y-1))<>-S1 THEN 2760 +2730 MV(N,1)=AA +2740 MV(N,2)=(X+1)*10+Y-1 +2750 N=N+1 +2760 RETURN +2770 REM -- RAW KNIGHT MOVE -- +2780 FOR C6=1 TO 15 STEP 2 +2790 KL=V(C6):KM=V(C6+1) +2800 XT=X+KL +2810 YT=Y+KM +2820 IF XT>8 OR XT<1 OR YT>8 OR YT<1 THEN 2860 +2830 MV(N,1)=AA +2840 MV(N,2)=XT*10+YT +2850 N=N+1 +2860 NEXT C6 +2870 RETURN +2880 REM -- RAW BISHOP MOVE -- +2890 EL=(8-Y)*-(8-Y<=8-X)+(8-X)*-(8-X < 8-Y) +2900 IF EL=0 THEN 2930 +2910 C6=11 +2920 GOSUB 3060 +2930 EL=(8-Y)*-(8-Y <= X-1)+(X-1)*-(X-1 < 8-Y) +2940 IF EL=0 THEN 2970 +2950 C6=-9 +2960 GOSUB 3060 +2970 EL=(8-X)*-(8-X <= Y-1)+(Y-1)*-(Y-1 < 8-X) +2980 IF EL=0 THEN 3010 +2990 C6=9 +3000 GOSUB 3060 +3010 EL=(Y-1)*-(Y-1 <= X-1)+(X-1)*-(X-1 < Y-1) +3020 IF EL=0 THEN 3050 +3030 C6=-11 +3040 GOSUB 3060 +3050 RETURN +3060 FOR E=1 TO EL +3070 F=C6*E +3080 MV(N,1)=AA +3090 MV(N,2)=AA+F +3100 N=N+1 +3110 IF TM(FNL(AA+F),FNM(AA+F))<>0 THEN 3130 +3120 NEXT E +3130 RETURN +3140 REM -- RAW ROOK MOVE -- +3150 EL=8-Y +3160 IF EL=0 THEN 3190 +3170 C6=1 +3180 GOSUB 3320 +3190 EL=Y-1 +3200 IF EL=0 THEN 3230 +3210 C6=-1 +3220 GOSUB 3320 +3230 EL=8-X +3240 IF EL=0 THEN 3270 +3250 C6=10 +3260 GOSUB 3320 +3270 EL=X-1 +3280 IF EL=0 THEN 3310 +3290 C6=-10 +3300 GOSUB 3320 +3310 RETURN +3320 FOR E=1 TO EL +3330 F=C6*E +3340 MV(N,1)=AA +3350 MV(N,2)=AA+F +3360 N=N+1 +3370 IF TM(FNL(AA+F),FNM(AA+F))<>0 THEN 3390 +3380 NEXT E +3390 RETURN +3400 REM -- RAW QUEEN MOVE -- +3410 GOSUB 2880 +3420 GOSUB 3140 +3430 RETURN +3440 REM -- RAW KING MOVE -- +3450 IF X=8 THEN 3510 +3460 C6=10:GOSUB 3620 +3470 IF Y=1 THEN 3500 +3480 C6=9:GOSUB 3620 +3490 IF Y=8 THEN 3520 +3500 C6=11:GOSUB 3620 +3510 IF X=1 THEN 3570 +3520 C6=-10:GOSUB 3620 +3530 IF Y=8 THEN 3570 +3540 C6=-9:GOSUB 3620 +3550 IF Y=1 THEN 3570 +3560 C6=-11:GOSUB 3620 +3570 IF Y=1 THEN 3590 +3580 C6=-1:GOSUB 3620 +3590 IF Y=8 THEN 3610 +3600 C6=1:GOSUB 3620 +3610 RETURN +3620 MV(N,1)=AA +3630 MV(N,2)=AA+C6 +3640 N=N+1 +3650 RETURN +3660 REM +3670 RR=0 +3680 GOTO 3700 +3690 RR=1 +3700 IF TM(X1,Y1)<>0 THEN 3720 +3710 LG=0:RETURN +3720 S=SGN(TM(X1,Y1)) +3730 A=X1*10+Y1 +3740 B=X2*10+Y2 +3750 ON ABS(TM(X1,Y1)) GOSUB 4070,4270,4340,4510,4630,4680 +3760 IF LG=0 THEN RETURN +3770 IF RR=1 THEN 3790 +3780 LG=1:RETURN +3790 REM -- IF RESTRICTED -- +3800 IF S=SGN(TM(X2,Y2)) THEN 3710 +3810 T1=X1:T2=Y1:T3=X2:T4=Y2:T=TM(X2,Y2) +3820 TM(X2,Y2)=TM(X1,Y1):TM(X1,Y1)=0 +3830 SV=S +3840 REM -- FIND KING -- +3850 FOR Y2=1 TO 8 +3860 FOR X2=1 TO 8 +3870 IF TM(X2,Y2)=6*S THEN 3910 +3880 NEXT X2 +3890 NEXT Y2 +3900 END +3910 REM +3920 FOR Y1=1 TO 8 +3930 FOR X1=1 TO 8 +3940 P=TM(X1,Y1):IF SGN(P)=S OR P=0 OR ABS(P)=6 THEN 3980 +3950 GOSUB 3660 +3960 S=SV +3970 IF LG=1 THEN 4050 +3980 NEXT X1 +3990 NEXT Y1 +4000 LG=1 +4010 TM(T1,T2)=TM(T3,T4) +4020 TM(T3,T4)=T +4030 X1=T1:Y1=T2:X2=T3:Y2=T4 +4040 RETURN +4050 LG=0 +4060 GOTO 4010 +4070 REM -- RAW PAWN MOVE -- +4080 IF SGN(Y2-Y1)=S THEN 4110 +4090 LG=0:RETURN +4100 LG=1:RETURN +4110 IF S=-1 THEN 4190 +4120 IF B-A=1 OR B-A=2 THEN 4160 +4130 IF TM(X2,Y2)=0 THEN 4090 +4140 IF B-A=-9 OR B-A=11 THEN 4100 +4150 GOTO 4090 +4160 IF Y2=2 THEN 4100 +4170 IF B-A=1 THEN 4100 +4180 GOTO 4090 +4190 IF A-B=1 OR A-B=2 THEN 4230 +4200 IF TM(X2,Y2)=0 THEN 4090 +4210 IF A-B=-9 OR A-B=11 THEN 4100 +4220 GOTO 4090 +4230 IF Y2=7 THEN 4100 +4240 IF A-B=1 THEN 4100 +4250 IF Y1=7 AND A-B=2 THEN 4100 +4260 GOTO 4090 +4270 REM -- RAW KNIGHT MOVE -- +4280 FOR P=17 TO 24 +4290 P1=V(P) +4300 IF A+P1<>B THEN 4320 +4310 LG=1:RETURN +4320 NEXT P +4330 LG=0:RETURN +4340 REM -- RAW BISHOP MOVE -- +4350 IF Y2=Y1 OR X2=X1 THEN 4420 +4360 SP=-9 +4370 IF X2P THEN 4420 +4460 GOTO 4490 +4470 IF Y120 THEN 4890 +4700 IF A-B=20 THEN 4730 +4710 IF CB<>1 AND CB<>3 THEN 4880 +4720 GOTO 4740 +4730 IF CB=0 OR CB=1 THEN 4880 +4740 PS=SGN(A-B):FORP2=28+50*((PS=-1)*-1)TOA+10-20*((PS=-1)+1)STEP10*P +4750 IF TM(FNL(P2),FNM(P2))<>0 THEN 4880 +4760 NEXT P2:T1=X1:T2=Y1:T3=X2:T4=Y2 +4770 FOR P2=A TO 18+70*((PS=-1)*-1) STEP 10*-PS +4780 X2=FNL(P2):Y2=FNM(P2) +4790 FOR X1=1 TO 8 +4800 FOR Y1=1 TO 8 +4810 IF SGN(TM(X1,Y1))<>1 THEN 4840 +4820 GOSUB 3690 +4830 IF LG=1 THEN 4880 +4840 NEXT Y1:NEXT X1:NEXT P2 +4850 LG=1 +4860 X1=T1:Y1=T2:X2=T3:Y2=T4 +4870 RETURN +4880 LG=0:GOTO 4860 +4890 FOR P=25 TO 32 +4900 P1=V(P) +4910 IF B=A+P1 THEN 4940 +4920 NEXT P +4930 LG=0:RETURN +4940 LG=1:RETURN +4950 REM +4960 LG=0 +4970 IF P=0 THEN STOP +4980 IF P>1 THEN 5000 +4990 LG=1:RETURN +5000 FOR P1=1 TO P-1 +5010 P2=A+SP*P1 +5020 IF TM(FNL(P2),FNM(P2))<>0 THEN RETURN +5030 NEXT P1 +5040 LG=1:RETURN +5050 END + +5000 FOR P1=1 TO \ No newline at end of file diff --git a/software/BAS/CIVILWAR.bas b/software/BAS/CIVILWAR.bas new file mode 100644 index 0000000..dd90d9c --- /dev/null +++ b/software/BAS/CIVILWAR.bas @@ -0,0 +1,241 @@ +100 LET L=0:LET W=0:LET R1=0:LET P1=0 +110 LET Q1=0:LET M3=0:LET M4=0 +120 LET P2=0:LET T1=0:LET T2=0 +130 REMARKABLE PROGRAM BY L. CRAM , L. GOODIE , AND D. HIBBARD +140 PRINT "DO YOU WANT DESCRIPTIONS (0=YES, 1=NO)"; +150 INPUT Z +160 FOR U=1 TO 6 +170 PRINT +180 NEXT U +190 IF Z=1 THEN 420 +200 PRINT "THIS IS A CIVIL WAR SIMULATION." +210 PRINT "TO PLAY, TYPE A RESPONSE WHEN THE COMPUTER ASKS." +220 PRINT "REMEMBER THAT ALL FACTORS ARE INTERRELATED AND THAT YOUR" +230 PRINT "RESPONSES COULD CHANGE HISTORY. FACTS AND FIGURES USED ARE" +240 PRINT "BASED ON THE ACTUAL OCCURENCE. MOST BATTLES TEND TO RESULT" +250 PRINT "AS THEY DID IN THE CIVIL WAR, BUT IT ALL DEPENDS ON YOU!!" +260 PRINT +270 PRINT "THE OBJECT OF THE GAME IS TO WIN AS MANY BATTLES AS POSSIBLE" +280 PRINT +290 PRINT "YOUR CHOICES FOR DEFENSIVE STRATEGY ARE:" +300 PRINT " (1) ARTILLERY ATTACK" +310 PRINT " (2) FORTIFICATION AGAINST FRONTAL ATTACK" +320 PRINT " (3) FORTIFICATION AGAINST FLANKING MANUEVERS" +330 PRINT " (4) FALLING BACK" +340 PRINT "YOUR CHOICES FOR OFFENSIVE STRATEGY ARE:" +350 PRINT " (1) ARTILLERY ATTACK" +360 PRINT " (2) FRONTAL ATTACK" +370 PRINT " (3) FLANKING MANUEVERS" +380 PRINT " (4) ENCIRCLEMENT" +390 PRINT "YOU MAY SURRENDER BY TYPING A '5' FOR YOUR STRATEGY." +400 PRINT +410 PRINT "YOU ARE THE CONFEDERACY. GOOD LUCK!" +420 READ M1,M2,C1,C2,M,A,U +430 LET I1=10+(L-W)*2 +440 LET I2=10+(W-L)*2 +450 LET D1=100*INT((M1*(100-I1)/2000)*(1+(R1-Q1)/(R1+1))+.5) +460 LET D2=100*INT(M2*(100-I2)/2000+.5) +470 LET F1=5*M1/6 +480 LET A1=Z +490 FOR U=1 TO 4 +500 PRINT +510 NEXT U +520 PRINT "THIS IS THE BATTLE OF "; +530 GOSUB 1530 +540 PRINT " ","CONFEDERACY"," UNION" +550 PRINT "MEN"," ";INT(M1*(1+(P1-T1)/(M3+1)))," "; +560 PRINT INT(M2*(1+(P2-T2)/(M4+1))) +570 PRINT "MONEY","$";D1,"$";D2 +580 PRINT "INFLATION"," ";I1+15;"%"," ";I2;"%" +590 PRINT +600 PRINT "HOW MUCH DO YOU WISH TO SPEND FOR FOOD"; +610 INPUT F +620 IF F<0 THEN 1480 +630 PRINT "HOW MUCH DO YOU WISH TO SPEND FOR SALARIES"; +640 INPUT S +650 IF S<0 THEN 1480 +660 PRINT "HOW MUCH DO YOU WISH TO SPEND FOR AMMUNITION"; +670 INPUT B +680 IF B<0 THEN 1480 +690 PRINT +700 IF F+S+B<=D1 THEN 730 +710 PRINT "THINK AGAIN! YOU HAVE ONLY $" D1 +720 GOTO 590 +730 LET O=((2*F^2+S^2)/F1^2+1) +740 IF O<10 THEN 770 +750 PRINT "MORALE IS HIGH" +760 GOTO 810 +770 IF O<5 THEN 800 +780 PRINT "MORALE IS FAIR" +790 GOTO 810 +800 PRINT "MORALE IS POOR" +810 IF M<>3 THEN 840 +820 PRINT "YOU ARE ON THE OFFENSIVE" +830 GOTO 880 +840 IF M<>1 THEN 870 +850 PRINT "YOU ARE ON THE DEFENSIVE" +860 GOTO 880 +870 PRINT "BOTH SIDES ARE ON THE OFFENSIVE" +880 PRINT +890 PRINT "YOUR STEGY"; +900 INPUT Y +910 IF Y=5 THEN 2380 +920 IF ABS(Y-3)<3 THEN 950 +930 PRINT "YOU JERK! USE THE OTHER SET OF STRATEGIES!!" +940 GOTO 880 +950 PRINT +960 PRINT " ","CONFEDERACY","UNION" +970 LET C5=(2*C1/5)*(1+1/(2*(ABS(INT(4*RND(1)+1)-Y)+1))) +980 LET C5=INT(C5*(1+1/O)*(1.28+F1/(B+1))+.5) +990 IF C5+100/O=0 THEN 1110 +1090 PRINT "YOUR CASUALTIES WERE"INT(100*(C1-C5)/C1+.5);"% LESS THAN" +1100 GOTO 1120 +1110 PRINT "YOUR CASUALTIES WERE"INT(100*(C5-C1)/C1+.5);"% MORE THAN" +1120 PRINT "THE ACTUAL CASUALITIES AT "; +1130 LET A1=1 +1140 GO SUB800 +1150 IF U=1 THEN 1170 +1160 IF C5+E<17*C2*C1/(C5*20)+5*O THEN 1200 +1170 PRINT "YOU LOSE "; +1180 LET L=L+1 +1190 GOTO 1220 +1200 PRINT "YOU WIN "; +1210 LET W=W+1 +1220 GOSUB 1530 +1230 IF W=8 THEN 2400 +1240 LET T1=T1+C5+E +1250 LET T2=T2+17*C2*C1/(C5*20)+5*O +1260 LET P1=P1+C1 +1270 LET P2=P2+C2 +1280 LET Q1=Q1+(F+S+B) +1290 LET R1=R1+M1*(100-I1)/20 +1300 LETM3=M3+M1 +1310 LET M4=M4+M2 +1320 IF A=14 THEN 2410 +1330 GOTO 420 +1340 DATA 18000,18500,1967,2708,1,1,0 +1350 DATA 40000,44894,10699,13047,3,2,0 +1360 DATA 95000,115000,20614,15849,3,3,0 +1370 DATA 54000,63000,10000,14000,2,4,0 +1380 DATA 40000,50000,10000,12000,3,5,0 +1390 DATA 75000,120000,5377,12653,1,6,0 +1400 DATA 38000,45000,11000,12000,1,7,0 +1410 DATA 32000,90000,13000,17197,2,8,0 +1420 DATA 50000,70000,12000,19000,1,9,0 +1430 DATA 72500,85000,20000,23000,3,10,0 +1440 DATA 66000,60000,18000,16000,2,11,0 +1450 DATA 37000,60000,6700,5800,2,12,0 +1460 DATA 62000,110000,17723,18000,2,13,0 +1470 DATA 65000,100000,8500,3700,1,14,0 +1480 PRINT "GO TO JAIL." +1490 PRINT "GO DIRECTLY TO JAIL." +1500 PRINT "DO NOT PASS GO." +1510 PRINT "DO NOT COLLECT $200" +1520 GOTO 490 +1530 IF A<>1 THEN 1600 +1540 PRINT "BULL RUN" +1550 IF A1=1 THEN 2360 +1560 PRINT"JULY 21,1861 GEN. BEAUREGARD COMMANDING THE SOUTH MET THE" +1570 PRINT"UNION FORCES WITH GEN MCDOWELL IN A PREMATURE BATTLE AT BULL" +1580 PRINT"RUN. GEN. JACKSON HELPED PUSH BACK THE UNION ATTACK." +1590 GOTO 2360 +1600 IF A<>2 THEN 1660 +1610 PRINT "SHILOH" +1620 IF A1=1 THEN 2360 +1630 PRINT"APRIL 6-7,1862 THE CONFEDERATE SURPRISE ATTACK AT SHILOH" +1640 PRINT"FAILED DUE TO POOR ORGANIZATION." +1650 GOTO 2360 +1660 IF A<>3 THEN 1730 +1670 PRINT "SEVEN DAYS" +1680 IF A1=1 THEN 2360 +1690 PRINT"JUNE 25-JULY 1,1862 GENERAL LEE (CSA) UPHELD THE OFFENSIVE" +1700 PRINT"THROUGHOUT THE BATTLE AND FORCED GEN. MCCLELLAN AND THE UNION" +1710 PRINT"FORCES AWAY FROM RICHMOND." +1720 GOTO 2360 +1730 IF A<>4 THEN 1790 +1740 PRINT "THE SECOND BULL RUN" +1750 IF A1=1 THEN 2360 +1760 PRINT"AUG 29-30,1862 THE COMBINED CONFEDERATE FORCES UNDER LEE AND" +1770 PRINT"JACKSON DROVE THE UNION FORCES BACK INTO WASHINGTON." +1780 GOTO 2360 +1790 IF A<>5 THEN 1850 +1800 PRINT "ANTIETAM" +1810 IF A1=1 THEN 2360 +1820 PRINT"SEPT 17,1862 THE SOUTH FAILED TO INCORPORATE MARYLAND INTO" +1830 PRINT"THE CONFEDERACY." +1840 GOTO 2360 +1850 IF A<>6 THEN 1910 +1860 PRINT "FREDERICKSBURG" +1870 IF A1=1 THEN 2360 +1880 PRINT"DEC 13,1862 THE CONFEDERACY UNDER LEE SUCESSFULLY REPULSED" +1890 PRINT"AN ATTACK BY THE UNION UNDER GEN. BURNSIDE." +1900 GOTO 2360 +1910 IF A <>7 THEN 1960 +1920 PRINT "MURFREESBORO" +1930 IF A1=1 THEN 2360 +1940 PRINT"DEC 31,1862 THE SOUTH UNDER GEN. BRAGG WON A CLOSE BATTLE" +1950 GOTO 2360 +1960 IF A<>8 THEN 2020 +1970 PRINT "CHANCELLORSVILLE" +1980 IF A1=1 THEN 2360 +1990 PRINT"MAY 1-6,1863 THE SOUTH HAD A COSTLY VICTORY AND LOST ONE" +2000 PRINT"OF THEIR OUTSTANDING GENERALS, 'STONEWALL' JACKSON." +2010 GOTO 2360 +2020 IF A<>9 THEN 2080 +2030 PRINT "VICKSBURG" +2040 IF A1=1 THEN 2360 +2050 PRINT"JULY 4,1863 VICKSBURG WAS A COSTLY DEFEAT FOR THE SOUTH" +2060 PRINT"BECAUSE IT GAVE THE UNION ACCESS TO THE MISSISSIPPI." +2070 GOTO 2360 +2080 IF A<>10 THEN 2140 +2090 PRINT "GETTYSBURG" +2100 IF A1=1 THEN 2360 +2110 PRINT"JUNE 30,1863 A SOUTHERN MISTAKE BY GEN. LEE AT GETTYSBURG" +2120 PRINT"COST THEM ONE OF THE MOST CRUCIAL BATTLES OF THR WAR." +2130 GOTO 2360 +2140 IF A<>11 THEN 2200 +2150 PRINT "CHICKAMAUGA" +2160 IF A1=1 THEN 2360 +2170 PRINT"NOV 25,1863 AFTER THE SOUTH HAD SIEGED GEN. ROSENCRANS'" +2180 PRINT"ARMY FOR THREE MONTHS, GEN. GRANT BROKE THE SIEGE." +2190 GOTO 2360 +2200 IF A<>12 THEN 2260 +2210 PRINT "CHATTANOOGA" +2220 IF A1=1 THEN 2360 +2230 PRINT"SEPT 15,1863 CONFUSION IN A FOREST NEAR CHICKAMAUGA LED" +2240 PRINT"TO A COSTLY SOUTHERN VICTORY." +2250 GOTO 2360 +2260 IF A<>13 THEN 2320 +2270 PRINT "SPOTSYLVANIA" +2280 IF A1=1 THEN 2360 +2290 PRINT"MAY 5,1864 GRANT'S PLAN TO KEEP LEE ISOLATED BEGAN TO FAIL" +2300 PRINT"HERE, AND CONTINUED AT COLD HARBOR AND PETERSBURG." +2310 GOTO 2360 +2320 PRINT "ATLANTA" +2330 IF A1=1 THEN 2360 +2340 PRINT"AUGUST, 1864 SHERMAN AND THREE VETERAN ARMIES CONVERGED ON" +2350 PRINT"ATLANTA AND DEALT THE DEATH BLOW TO THE CONFEDERACY." +2360 PRINT +2370 RETURN +2380 PRINT "THE CONFEDERACY HAS SURRENDERED" +2390 GOTO 2410 +2400 PRINT "THE UNION HAS SURRENDERED" +2410 PRINT +2420 PRINT "YOU HAVE WON" W; "BATTLES AND LOST" L; "BATTLES." +2430 IF Y=5 THEN 2470 +2440 IF W<=L THEN 2470 +2450 PRINT "THE CONFEDERACY HAS WON THE WAR" +2460 STOP +2470 PRINT "THE UNION HAS WON THE WAR" +2480 END +IF W<=L THEN 2470 +2450 PRINT "THE CONFED \ No newline at end of file diff --git a/software/BAS/CLIMATES.bas b/software/BAS/CLIMATES.bas new file mode 100644 index 0000000..2ccbe5b --- /dev/null +++ b/software/BAS/CLIMATES.bas @@ -0,0 +1,200 @@ +100 REM--E.A.GALLETTA,PATCHOGUE-H.S.,4/22/69 EARTH SIENCE (BIICAC) +110 REM--PROGRAM ON CLIMATES +120 REM--REWRITTEN--7/28/69--BASIC-- +130 REM REVISED BY TONY PEREZ, WALT WHITMAN HS, 8-69 +140 REM RE-REVISED BY C.LOSIK 8-26-70 +150 DIML(56) +160 READN,L(N) +170 IFN<>56THEN 160 +180 T=0 +190 PRINT"O.K., HERE ARE SOME VALUES FOR THE PRECIPIATION (P) AND FOR +200 PRINT"THE POTENTIAL EVAPOTRANSPIRATION (PE) OF AN AREA:" +210 PRINT +220 PRINT" ","MONTH"," P"," PE" +230 PRINT" ","=====","=====","======" +240 P=INT(10*RND(1)) +250 IFP>6THEN240 +260 IFP<1THEN240 +270 E=INT(10*RND(1)) +280 IFE>4THEN270 +290 IFE<1THEN270 +300 Z=5*E+6*P +310 IF (Z-21)*(Z-22)*(Z-17)*(Z-38)=0 THEN 240 +320 FORI=1TO12 +330 PRINT" ",I, +340 IFP>1THEN360 +350 P1=12*COS(.261*I)^2+2*RND(1) +360 IFP<>2THEN380 +370 P1=12*SIN(.261*I)+2*RND(1) +380 IFP<>3THEN400 +390 P1=2+3*RND(1) +400 IFP<>4THEN420 +410 P1=2*RND(1) +420 IFP<>5THEN440 +430 P1=7+10*RND(1) +440 IFP<>6THEN460 +450 P1=3*COS(.5+.15*I)^2 +460 PRINTINT(P1), +470 IFE>1THEN490 +480 E1=10*SIN(.261*I)^2 +490 IFE<>2THEN510 +500 E1=12*SIN(.261*I)^2 +510 IFE<>3THEN530 +520 E1=2*SIN(.5+.15*I)^2 +530 IFE<>4THEN550 +540 E1=8+4*RND(1) +550 T=T+INT(P1) +560 PRINTINT(E1+(E1/10)*2) +570 NEXTI +580 PRINT +590 PRINT"TOTAL PRECIPITATION =";T;"INCHES" +600 PRINT +610 PRINT"O.K., PLOT YOUR GRAPH ON THE PAPER PROVIDE YOU" +620 PRINT"AND WHEN YOU ARE READY TO CONTINUE.... MEREY TYPE" +630 PRINT"ANY NUMBER AND THE RETURN KEY. "; +640 INPUTQ +650 PRINT +660 PRINT"READY? GOOD, NOW TELL ME . . . DOES YOUR GRAPH SHOW THAT" +670 PRINT"THE CLIMATE HAS DEFINITE WET AND DRY SEASONS (1=YES, 0=NO) " +680 INPUT S +690 PRINT +700 IFS=0THEN880 +710 IF S<>1 THEN 660 +720 IFP<3THEN990 +730 B=0 +740 GOSUB 1960 +750 PRINT"TELL ME, IS THE CLIMATE [1] WET, [2] DRY, R [3] MODERATE ALL" +760 PRINT"YEAR"; +770 INPUT S +780 PRINT +790 IFS=1THEN920 +800 IFS=3THEN960 +810 IF S<>2 THEN 750 +820 IFT<13THEN1130 +830 IFT>80THEN860 +840 GOSUB1950 +850 GOTO1140 +860 GOSUB1910 +870 GOTO1140 +880 IFP>2THEN750 +890 IFP=2THEN820 +900 GOSUB1910 +910 GOTO990 +920 IFT>80THEN1130 +930 IFT>=13THEN840 +940 GOSUB1930 +950 GOTO1140 +960 IF(T-13)*(80-T)>=0THEN1130 +970 IFT<13THEN940 +980 IFT>80THEN860 +990 PRINT"TELL ME, WHICH IS THE WET SEASON, [1] THE WINTER OR [2] THE" +1000 PRINT"SUMMER"; +1010 PRINT +1020 INPUT S +1030 PRINT +1040 IFS=1THEN1090 +1050 IF S<>2 THEN 990 +1060 IFP=2THEN1130 +1070 GOSUB1910 +1080 GOTO1140 +1090 IFP=1THEN1130 +1100 GOSUB1910 +1110 GOTO1140 +1120 PRINT +1130 PRINT"NICE GOING, SMARTY PANTS. KEEP UP THE GOODWORK." +1140 PRINT"BY CHECKING THE PE CURVE ON YOUR GRAPH, WOUD YOU SAY THAT THE" +1150 PRINT"SUMMERS ARE [1] HOT, [2] WARM, OR [3] COOL" +1160 INPUT S +1170 PRINT +1180 IFS=2THEN1260 +1190 IFS=3THEN1300 +1200 IF S<>1 THEN 1130 +1210 IFE=2THEN1320 +1220 IFE=4THEN1320 +1230 IF E=1 THEN 1320 +1240 GOSUB1910 +1250 GOTO1330 +1260 IFE=1THEN1320 +1270 IFE<>3THEN1240 +1280 GOSUB1950 +1290 GOTO1330 +1300 IFE=3THEN1320 +1310 IFE<>3THEN1240 +1320 PRINT"YOU HAVE RESTORED MY FAITH IN TEENAGERS." +1330 PRINT"FROM THE SAME INFORMATION (PE GRAPH), WOULD YOU SAY THAT THE" +1340 PRINT"WINTERS ARE [1] COLD, [2] MILD, OR [3] WARM"; +1350 INPUT S +1360 PRINT +1370 IFS=2THEN1450 +1380 IFS=3THEN1490 +1390 IF S<>1 THEN 1330 +1400 IFE<3THEN1520 +1410 GOSUB1930 +1420 GOTO1530 +1430 GOSUB1950 +1440 GOTO1530 +1450 IFE=3THEN1520 +1460 IFE=4THEN1430 +1470 GOSUB1910 +1480 GOTO1530 +1490 IFE=3THEN1410 +1500 IFE=4THEN1530 +1510 GOTO1470 +1520 PRINT"IT WARMS MY HEART TO HEAR YOU SAY THAT. GOOD GOING." +1530 PRINT +1540 PRINT"WELL, BY NOW YOU MUST HAVE AN INKLING AS TO THE TYPE OF" +1550 PRINT"CLIMATE WE HAVE HERE. BELOW IS A COMPLETE LISTING OF ALL THE +1560 PRINT"CLIMATES IN THE WORLD. REFER TO THEM BY THEIR NUMBER ONLY." +1570 PRINT +1580 PRINT +1590 PRINT"NUMBER","NAME OF CLIMATE" +1600 PRINT"======","===============" +1610 PRINT"1","TROPICAL RAINFOREST" +1620 PRINT"2","TROPICAL EAST COAST" +1630 PRINT"3","TROPICAL MONSOON" +1640 PRINT"4","TROPICAL SAVANNA" +1650 PRINT"5","TROPICAL DESERT" +1660 PRINT"6","MEDITERRANEAN" +1670 PRINT"7","MARINE WEST COAST" +1680 PRINT"8","HUMID CONTINENTAL" +1690 PRINT"9","HUMID SUBTROPICAL" +1700 PRINT"10","MIDDLE LATITUDE GRASSLANDS" +1710 PRINT"11","MIDDLE LATITUDE DESERT" +1720 PRINT"12","SUBARTIC CLIMATES" +1730 PRINT"13 OR 14","HIGHLAND CLIMATES" +1740 PRINT" ","(TROPICAL OR MIDDLE LATITUDES)" +1750 PRINT"15","POLAR TUNDRA" +1760 PRINT"16","POLAR ICECAP" +1770 PRINT +1780 PRINT"WHAT IS THE NUMBER OF THE CLIMATE WE HAVE (WE'LL ACCEPT THE" +1790 PRINT "FACT THAT THEY MAY OVERLAP)"; +1800 INPUTS +1810 PRINT +1820 PRINT +1830 PRINT +1840 IFS=L(Z)THEN1880 +1850 PRINT"MY SUGGESTION - STICK TO LANGUAGES OR SOCIAL STUDIES." +1860 PRINT"YOU SHOULD HAVE SAID";L(Z);". GOOD DAY TO YOU." +1870 STOP +1880 PRINT"YOUR FORTUNE AS A METEOROLOGIST IS BUDDING. IT WAS" +1890 PRINT"VERY NICE TO WORK WITH YOU. SO LONG." +1900 STOP +1910 B=1 +1920 GOTO1960 +1930 B=2 +1940 GOTO1960 +1950 B=3 +1960 PRINT"AW C'MON, YOU COULDN'T POSSIBLY MEAN THAT..." +1970 PRINT"YOU SHOULD HAVE SAID";B +1980 PRINT +1990 RETURN +2000 DATA11,6,16,7,23,10,26,3,27,15 +2010 DATA28,8,29,11,32,3,33,13,34,11 +2020 DATA 35,9,39,16,40,8,41,13,44,5 +2030 DATA46,10,45,16,50,1,51,12,56,4 +2040 DATA39,4,44,5,35,9,40,8,45,1,41,15,46,12,51,5,56,16 +2050 DATA0,0 +2060 END +,44,5 +2030 DATA46,10,45,16,50,1,51,12,56,4 +2040 DATA39,4,44,5,35,9,40,8,45,1,41,15,46,12,51,5,56,16 \ No newline at end of file diff --git a/software/BAS/CLOUD-9.bas b/software/BAS/CLOUD-9.bas new file mode 100644 index 0000000..a03d675 --- /dev/null +++ b/software/BAS/CLOUD-9.bas @@ -0,0 +1,199 @@ +10 REM--A.C.CAGGIANO+E.A.GALLETTA, PATCHOGUE H.S., 11-20-68 +11 REM--REVISED BY CHARLES LOSIK AND TONY PEREZ 7/18/69 +12 REM RE-REVISED BY C.LOSIK 8-26-70 +20 REM--THIS PROGRAM IS ASSOCIATED WITH CLOUD FORMATION +25 REM PHASE I OF PROGRAM BEGINS HERE. STUDENTS WILL BE GIVEN +26 REM INTRODUCTORY INFORMATION AND BE ALLOWED TO ASK AND ANSWER +27 REM ANY NUMBER OF PROBLEMS. WHEN THEY INPUT NO. 2 (LINES 554-556) +28 REM PROGRAM SENDS THEM TO PHASE II (LINE 561 AND FOLLOWING). +30 PRINT" ","CLOUD NINE" +40 PRINT" ","===== ====" +45 DIM B(2), T(4), Q(3), A(3), C(3) +50 PRINT +60 PRINT" STRONG CONVECTION CURRENTS ARE CAUSING ADIABATIC" +70 PRINT"COOLING OF AIR WHERE YOU ARE AND ARE RESPONSIBLE FOR THE" +80 PRINT"FORMATION OF A CLOUD. BOTH THE DRY AND THE MOIST ADIABATIC" +90 PRINT"(AS WELL AS THE NORMAL LAPSE RATES) ARE CONSIDERED IN THIS" +91 PRINT"PROGRAM." +100 PRINT +105 PRINT +110 PRINT" ","LEGEND" +120 PRINT" ","======" +140 PRINT"1="; +150 GOSUB1000 +160 PRINT"2="; +170 GOSUB1010 +180 PRINT"3="; +190 GOSUB1020 +200 PRINT"4="; +210 GOSUB1030 +220 PRINT +225 PRINT +230 PRINT"CHOOSE ANY TWO OF THE ABOVE VARIABLES AND SELECT VALUES FOR" +231 PRINT"THEM. TYPE THEM IN AS:" +232 PRINT"VARIABLE CODE ,VALUE, VARIABLE CODE ,VALUE...(E.G. 1,50,2,30)" +233 PRINT +240 X=0 +242 Y=0 +245 A=0 +246 B=0 +247 B(1)=0 +248 B(2)=0 +250 INPUTB(1),A,B(2),B +290 PRINT +300 FORI=1TO4 +310 IFB(1)=ITHEN330 +320 NEXTI +330 T(I)=A +340 FORJ=1TO4 +350 IFB(2)=JTHEN370 +360 NEXTJ +370 T(J)=B +380 IFI<>JTHEN405 +390 PRINT"YOU CAN'T USE THE SAME VALUES TWICE." +395 GOTO250 +405 PRINT"OKAY, TYPE IN YOUR CALCULATED VALUE FOR"; +406 PRINT +410 IFJ*I<>2THEN425 +411 T=(T(1)-T(2))/4.5 +412 T(4)=1000*T +413 T(3)=T(2)-T +414 GOSUB1020 +415 GOSUB1050 +416 GOSUB1030 +417 INPUTX,Y +418 IFABS(X-T(3))>=.6THEN500 +419 IFABS(Y-T(4))>=.6THEN500 +420 GOTO550 +425 IFJ*I<>3THEN440 +426 T=(T(1)-T(3))/5.5 +427 T(4)=1000*T +428 T(2)=T+T(3) +429 GOSUB1010 +430 GOSUB1050 +431 GOSUB1030 +432 INPUTX,Y +433 IFABS(X-T(2))>=.6THEN500 +434 IFABS(Y-T(4))>=.6THEN500 +435 GOTO550 +440 IFJ*I<>4THEN455 +441 T=T(4)/1000 +442 T(2)=T(1)-4.5*T +443 T(3)=T(2)-T +444 GOSUB1010 +445 GOSUB1050 +446 GOSUB1020 +447 INPUTX,Y +448 IFABS(X-T(2))>=.6THEN500 +449 IFABS(Y-T(3))>=.6THEN500 +450 PRINT"OKAY, TYPE IN YOUR CALCULATED VALUE FOR" +455 IFJ*I<>6THEN470 +456 T=T(2)-T(3) +457 T(4)=1000*T +458 T(1)=T(3)+5.5*T +459 GOSUB1000 +460 GOSUB1050 +461 GOSUB1030 +462 INPUTX,Y +463 IFABS(X-T(1))>=.6THEN500 +464 IFABS(Y-T(4))>=.6THEN500 +465 GOTO550 +470 IFJ*I<>8THEN485 +471 T=T(4)/1000 +472 T(3)=T(2)+T +473 T(1)=T(2)+6.5*T +474 GOSUB1010 +475 GOSUB1050 +476 GOSUB1020 +477 INPUTX,Y +478 IFABS(X-T(1))>=.6THEN500 +479 IFABS(Y-T(3))>=.6THEN500 +480 GOTO550 +481 IFABS(X-T(3))>=.6THEN500 +485 IFJ*I<>12THEN390 +486 T=T(4)/1000 +487 T(1)=T(3)+5.5*T +488 T(2)=T(3)+T +489 GOSUB1000 +490 GOSUB1050 +491 GOSUB1010 +492 INPUTX,Y +493 IFABS(X-T(1))>=.6THEN500 +494 IFABS(Y-T(2))>=.6THEN500 +495 GOTO550 +500 PRINT +502 PRINT"IT LOOKS LIKE WE GOOFED SOME PLACE." +505 PRINT"LET'S SEE WHAT THE CORRECT VALUES ARE." +507 PRINT +510 PRINT T(1);"DEGREES - "; +512 GO SUB 1000 +515 PRINT T(2);"DEGREES - "; +517 GO SUB 1010 +520 PRINT T(3);"DEGREES - "; +522 GO SUB 1020 +525 PRINT T(4);"FEET - "; +527 GO SUB 1030 +530 PRINT +535 GOTO554 +550 PRINT +552 PRINT"VERY GOOD. VERY, VERY GOOD." +553 PRINT +554 PRINT"DO YOU HAVE ANY OTHER PROBLEMS YOU WOULD LIKE TO TRY?" +555 PRINT "(1=YES, 0=NO) : "; +556 INPUT P +557 IFP<1THEN561 +558 PRINT +559 PRINT"USING THE SAME LEGEND AS BEFORE..." +560 GOTO230 +561 H=(T(1)-T(3))*2000-7*T(4) +562 REM LINE 561 CALCULATES ALTITUDE FOR TOP OF CLOUD AND BEGINS +563 REM PHASE II OF PROGRAM. PROBLEM NO.2 IN THIS PART (CALCULATION +564 REM OF TEMP. ABOVE CLOUD TOP) INVOLVES USE OF THE NORMAL LAPSE RATE. +565 PRINT +567 PRINT"WELL, BEFORE YOU LEAVE, I HAVE A FEW I'D LIKE YOU TO TRY..." +570 PRINT"BASED ON YOUR VALUES, THE HEIGHT OF THE CLOUD" +580 PRINT"(MEASURED FROM THE CLOUD BASE) IS ";H;"FT. CAN YOU TELL ME:" +600 Q(1)=.7*T(4) +601 Q(2)=T(4)+1.5*H +602 Q(3)=T(4)+.5*H +610 A(1)=T(1)-T(4)*3.85E-03 +611 A(2)=T(1)-(T(4)+1.5*H)*3.5E-03 +612 A(3)=T(3)-1.5E-03*H +614 PRINT +615 PRINT"WHAT IS THE TEMPERATURE AT EACH OF THESE ALTITUDES:" +620 FORN=1TO3 +625 PRINT" ",N;INT(Q(N)+.5);"FT" +627 NEXT N +628 PRINT +629 FORN=1TO3 +630 PRINT"THE TEMPERATURE AT ";INT(Q(N)+.5);" FT. IS "; +631 INPUTC(N) +635 IFABS(C(N)-A(N))>1.1THEN750 +640 NEXTN +699 PRINT +700 PRINT"WOW, YOU MUST BE A BRAIN. AND YOU PROBALLY KNOW" +710 PRINT"A LOT ABOUT CLOUDS AND THINGS LIKE THAT. IT WAS VERY" +720 PRINT"NICE TO WORK WITH SOMEONE WHO UNDERSTANDS ME." +730 PRINT" ","THANK YOU AND . . . . PEACE AND LONG LIFE" +740 STOP +750 PRINT +755 PRINT"SORRY. YOU WERE DOING GREAT THERE FOR A WHILE." +760 PRINT"WELL, BACK TO THE BOOKS. THE VALUES YOU SHOULD HAVE ARE:" +765 PRINT +770 FORN=1TO3 +774 PRINTN; +780 PRINT"THE TEMPERATURE AT";INT(Q(N)+.5);"FEET IS ";A(N);"DEGREES" +790 NEXTN +830 STOP +1000 PRINT"THE TEMPERATURE ON THE GROUND" +1005 RETURN +1010 PRINT"THE DEW POINT TEMPERATURE ON THE GROUND" +1015 RETURN +1020 PRINT"THE TEMPERATURE AT THE BASE OF THE CLOUD" +1025 RETURN +1030 PRINT"THE ELEVATION, IN FEET, OF THE CLOUD BASE" +1035 RETURN +1050 PRINT"FOLLOWED BY A COMMA, AND THEN TYPE IN YOUR VALUE FOR " +1055 RETURN +2000 END + \ No newline at end of file diff --git a/software/BAS/CRAPS.bas b/software/BAS/CRAPS.bas new file mode 100644 index 0000000..e997f3a --- /dev/null +++ b/software/BAS/CRAPS.bas @@ -0,0 +1,147 @@ +100 REM SOURCE UNKNOWN: REVISED BY D. KURLAND 11/16/75 +110 PRINT " ------ C - R - A - P - S ------" +120 PRINT "DO YOU KNOW HOW TO PLAY"; +130 INPUT T$ +140 IF T$="YES" OR T$="Y" THEN 270 +150 PRINT "YOU ARE NOW ENTERING THE CASINO UNIVAC 1108 LOCATED" +160 PRINT "IN DOWNTOWN LAS VEGAS. YOU'VE JUST WON $25000 FROM THE" +170 PRINT "READERS DIGEST SWEEPSTAKES, AND ARE FEELING FREE AND" +180 PRINT "EASY. YOUR KEEN EYES LOCATE A CRAP TABLE. THE GREEN" +190 PRINT "FELT LOOKS VERY INVITING. YOU SEE A GIRL IN A" +200 PRINT "PLAYBOY BUNNY OUTFIT. SHE DECIDES TO START A CONVER-" +210 PRINT "SATION WITH YOU." +220 PRINT +230 PRINT "HI THERE, I AM THE ONE AND ONLY MISS TELETYPE. I'M SINGLE" +240 PRINT "AND LONELY. I'M ALSO THE DIRTIEST DICE THROWER THIS SIDE" +250 PRINT "OF IBM." +260 PRINT +270 PRINT "WHAT IS YOUR NAME"; +280 INPUT T$ +290 PRINT "HOW ABOUT IT, ";T$ +300 PRINT "WANT TO TRY YOUR LUCK"; +310 INPUT R$ +320 IF R$="NO" OR R$="N" THEN 1250 +330 PRINT "HERE'S YOUR SELECTION OF DICE:" +340 PRINT +350 PRINT " 1. BUNNY BLUE " +360 PRINT " 2. GROSS GREEN " +370 PRINT " 3. UNIVAC YELLOW " +380 X=25000 +390 PRINT "PLEASE INPUT ONLY ONE NUMBER, HONEY"; +400 INPUT F +410 IF F=1 THEN 440 +420 IF F=2 THEN 460 +430 IF F=3 THEN 480 +440 PRINT "I SEE YOU'RE THE SEXY TYPE" +450 GOTO 490 +460 PRINT "I SEE YOU'RE A REALLY BIG SPENDER" +470 GOTO 490 +480 PRINT "SO YOU'RE THE CONSERVATIVE TYPE" +490 PRINT "NOW YOU HAVE YOUR OWN COLORED DICE. YOU'VE GOT $25000" +500 PRINT "AND BEST OF ALL YOU ARE SITTING NEXT TO A PLAYBOY BUNNY" +510 PRINT +520 PRINT "MISS TELETYPE SAYS, BETS PLEASE" +530 PRINT "AND HOW MUCH IS OUR READERS DIGEST WINNER GOING TO WAGER" +540 PRINT "YOU HAVE GOT A MAXIMUM OF";X +550 INPUT A +560 IF A>X THEN 540 +570 IF A<0 THEN 1520 +580 IF A<=100 THEN 600 +590 IF A>=1000 THEN 660 +600 PRINT "BOY, WHAT A CHEAPSKATE" +610 GOTO 670 +620 PRINT "THAT'S A GOOD HONEST BET" +630 GOTO 670 +640 PRINT "NOW YOU ARE IN BUSINESS, LOVER" +650 GOTO 670 +660 PRINT "WHAT A SPENDER, LOVER, AND ALTOGETHER KOOL PERSON" +670 W=0 +680 W=W+1 +690 PRINT "YOU'RE NOW SHAKING YOUR DICE" +700 PRINT "YOU BLOW ON THEM FOR LUCK" +710 PRINT "YOU ROLL THEM" +720 R=INT (RND(1)*10)+1 +730 IF R>6 THEN 720 +740 Z=INT (RND(1)*10)+1 +750 IF Z>6 THEN 740 +760 PRINT "YOU'RE THROW WAS";R+Z +770 PRINT +780 IF W=1 THEN 820 +790 IF R+Z=7 OR R+Z=11 THEN 900 +800 IF R+Z=F THEN 920 +810 GOTO 850 +820 F=R+Z +830 IF F=7 OR F=11 THEN 870 +840 IF F=2 OR F=3 OR F=12 THEN 900 +850 PRINT "MUST SHAKE AGAIN. YOU HAVE NEITHER WON NOR LOST" +860 GOTO 1180 +870 PRINT "YOU HAVE JUST DOUBLED YOUR BET" +880 PRINT "YOU HAVE WON $";2*A +890 GOTO 950 +900 PRINT "YOU HAVE LOST WHAT YOU BET" +910 GOTO 1030 +920 PRINT "YOU HAVE JUST WON YOUR BET" +930 PRINT "YOU HAVE WON $";A +940 GOTO 990 +950 X=X+2*A +960 PRINT "YOUR TOTAL IS NOW $";X +970 IF X<0 THEN 1080 +980 GOTO 1100 +990 X = X+A +1000 PRINT "YOUR TOTAL IS NOW $";X +1010 IF X<0 THEN 1080 +1020 GOTO 1060 +1030 PRINT "YOU LOST $";A +1040 X=X-A +1050 PRINT "YOUR TOTAL IS NOW $"X +1060 IF X<0 THEN 1080 +1070 GOTO 1100 +1080 PRINT "YOU OWE MISS TELETYPE $";X +1090 GOTO 1480 +1100 PRINT +1110 IF X<0 THEN 1080 +1120 PRINT +1130 PRINT +1140 PRINT "DO YOU WANT TO TRY AGAIN"; +1150 INPUT P$ +1160 IF X<0 THEN 1080 +1170 IF P$="NO" OR P$="N" THEN 1490 ELSE 540 +1180 IF W>6 THEN 1230 +1190 IF W=6 THEN 1250 +1200 IF W=4 THEN 1460 +1210 IF W=5 THEN 1270 +1220 GOTO 1290 +1230 PRINT "THIS IS THE TIME FOR A KILLING, ";T$ +1240 GOTO 1290 +1250 PRINT "THE ODDS ARE GETTING BETTER YET" +1260 GOTO 1290 +1270 PRINT "THE ODDS ARE COMIN IN YOURE FAVOR, BABY. BET A LITTLE MORE" +1280 PRINT +1290 PRINT "DO YOU WISH TO INCREASE YOUR BET, ";T$; +1300 INPUT D$ +1310 IF D$="NO" OR D$="N" THEN 680 +1320 IF X-A>0 THEN 1370 +1330 IF X-A<0 THEN 1350 +1340 IF X-A=0 THEN 1390 +1350 PRINT "LISTEN, HONEY. YOU OWE ME $"X +1360 PRINT +1370 PRINT "HOW MUCH DO YOU WISH TO INCREASE YOUR WAGER BY, ";T$ +1380 GOTO 1410 +1390 PRINT "YOU HAVE NO MONEY TO BET WITH. YOU MUST HOPE FOR THE BEST" +1400 GOTO 680 +1410 PRINT +1420 PRINT "YOU'VE GOT $";X-A;"TO BET WITH." +1430 INPUT Z +1440 A=A+Z +1450 GOTO 680 +1460 PRINT "DO OR DIE SPEND IT RIGHT NOW, ";T$ +1470 GOTO 1370 +1480 PRINT "CREDIT NOT GOOD IN THIS CASINO" +1490 PRINT "YOUR TOTAL IS $";X +1500 PRINT "THANK YOU FOR COMING TO THE CASINO UNIVAC 1108" +1510 GOTO 1540 +1520 PRINT "YOU MUST BET A POSITIVE VALUE" +1530 GOTO 540 +1540 END +MING TO THE CASINO UNIVAC 1108" +1510 \ No newline at end of file diff --git a/software/BAS/CRAZY-8.bas b/software/BAS/CRAZY-8.bas new file mode 100644 index 0000000..ba5879a --- /dev/null +++ b/software/BAS/CRAZY-8.bas @@ -0,0 +1,267 @@ +100 REM SOURCE UNKNOWN: REVISED BY D. KURLAND 11/16/75 +110 PRINT "THIS IS THE GAME OF CRAZY EIGHTS" +120 DIM A(52),D(52),G(52),H(52) +130 DIM T(52),S(52),V(52) +140 DIM Z(52),U$(4),C$(13) +150 READ U$(1),U$(2),U$(3),U$(4) +160 FOR I=1 TO 13 +170 READ C$(I) +180 NEXT I +190 FOR I=1 TO 52 +200 READ Z(I) +210 NEXT I +220 DATA CLUBS,DIAMONDS,HEARTS,SPADES +230 DATA "2","3","4","5","6","7","8","9","10",JACK,QUEEN,KING,ACE +240 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +250 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +260 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +270 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +280 PRINT "DO YOU KNOW HOW TO PLAY"; +290 INPUT A$ +300 IF A$="YES" OR A$="Y" THEN 400 +310 PRINT "WHEN ASKED WHICH CARD YOU WISH TO PLAY, YOUR ANSWER SHOULD" +320 PRINT "OF THE FORM: CARD,SUIT . ANY EIGHT MAY BE" +330 PRINT "PLAYED AT ANY TIME REGARDLESS OF SUIT TO CHANGE THE SUIT." +340 PRINT "IF YOU ARE UNABLE OR UNWILLING TO PLAY, YOU WILL BE GIVEN" +350 PRINT "ANOTHER CARD FROM THE DRAW STACK. IF ALL CARDS HAVE BEEN" +360 PRINT "DRAWN, ANY PERSON WHO IS ABLE TO PLAY MUST DO SO." +370 PRINT "AT THE END OF THE GAME, THE PERSON HOLDING CARDS HAS POINTS" +380 PRINT "SCORED AGAINST HIM AS FOLLOWS: EIGHTS=50, ACE=1, FACE" +390 PRINT "CARD=10, INDEX VALUE FOR EACH OTHER CARD." +400 PRINT : PRINT "GAME WILL START SHORTLY..." +410 L=0 : FOR I=1 TO 4 +420 FOR J=1 TO 13 +430 L=L+1 +440 S(L)=I +450 V(L)=J +460 NEXT J +470 NEXT I +480 N1=0 +490 N2=0 +500 N3=0 +510 S1=0 +520 S2=0 +530 FOR I=1 TO 52 +540 G(I)=0 +550 H(I)=0 +560 A(I)=RND(1) +570 NEXT I +580 W1=0 +590 B1=0 +600 P1=1 +610 P2=1 +620 J=0 +630 M1=99999! +640 FOR I=1 TO 52 +650 IF A(I)>=M1 THEN 680 +660 M1=A(I) +670 I1=I +680 NEXT I +690 J=J+1 +700 D(J)=I1 +710 A(I1)=99999! +720 IF J<52 THEN 630 +730 FOR I=1 TO 7 +740 G(D(52-2*I+2))=1 +750 H(D(52-2*I+1))=1 +760 NEXT I +770 T(1)=D(38) +780 T1=1 +790 P=S(T(1)) +800 H1=7 +810 H2=7 +820 D1=37 +830 GOSUB 1390 +840 GOSUB 1510 +850 IF W1=1 THEN 910 +860 IF B1=1 THEN 910 +870 GOSUB 2020 +880 IF W1=1 THEN 910 +890 IF B1=1 THEN 910 +900 GOTO 830 +910 GOSUB 1140 +920 PRINT "YOUR SCORE IS";C1 +930 PRINT "MY SCORE IS";C2 +940 IF C2>=C1 THEN 980 +950 PRINT "YOU WON THAT HAND." +960 N1=N1+1 +970 GOTO 1000 +980 PRINT "I WON THAT HAND." +990 N2=N2+1 +1000 PRINT +1010 N3=N3+1 +1020 PRINT "DO YOU WISH TO PLAY AGAIN"; +1030 INPUT A$ +1040 IF A$="YES" OR A$="Y" THEN 530 +1050 PRINT +1060 PRINT "OUT OF";N3;"HANDS YOU WON";N1 +1070 PRINT "YOUR TOTAL SCORE IS";S1;": MINE IS";S2;"." +1080 IF S1<=S2 THEN1110 +1090 PRINT "LOOKS LIKE YOU'RE HIGH SCORER." +1100 GOTO 1120 +1110 PRINT "LOOKS LIKE I AM THE HIGH SCORER." +1120 PRINT "BYE." +1130 STOP +1140 C1=0 +1150 C2=0 +1160 IF H2=0 THEN 1240 +1170 PRINT +1180 PRINT "CARDS LEFT IN MY HAND" +1190 FOR I=1 TO 52 +1200 IF H(I)=0 THEN 1230 +1210 PRINT C$(V(I));TAB(6);"OF ";U$(S(I)) +1220 C1=C1+Z(I) +1230 NEXT I +1240 IF H1=0 THEN 1360 +1250 FOR I=1 TO 52 +1260 IF G(I)=0 THEN 1280 +1270 C2=C2+Z(I) +1280 NEXT I +1290 IF C1=0 THEN 1360 +1300 IF C1>=C2 THEN 1340 +1310 C2=C2-C1 +1320 C1=0 +1330 GOTO 1360 +1340 C1=C1-C2 +1350 C2=0 +1360 S1=S1+C1 +1370 S2=S2+C2 +1380 RETURN +1390 PRINT +1400 PRINT "YOUR HAND IS" +1410 FOR I=1 TO 52 +1420 IF G(I)=0 THEN 1440 +1430 PRINT C$(V(I));TAB(6);"OF ";U$(S(I)) +1440 NEXT I +1450 PRINT +1460 PRINT "THE LAST CARD PLAYED WAS THE "; +1470 PRINT C$(V(T(T1)));" OF ";U$(S(T(T1))) +1480 IF V(T(T1))<>7 THEN 1500 +1490 PRINT "THE SUIT CALLED FOR IS ";U$(P) +1500 RETURN +1510 PRINT "DO YOU WISH TO PLAY A CARD"; +1520 INPUT A$ +1530 AZ$=LEFT$(A$,1) +1531 IF AZ$<>"Y" AND AZ$<>"N" THEN PRINT "(Y OR N) PLEASE ! "; : GOTO 1520 +1540 IF D1<>0 THEN 1570 +1550 PRINT "ALL THE CARDS HAVE BEEN DEALT---YOU ARE BLOCKED" +1560 GOTO 1980 +1570 I=D(D1) +1580 D1=D1-1 +1590 H1=H1+1 +1600 G(I)=1 +1610 PRINT "YOUR NEW CARD IS THE ";C$(V(I));" OF ";U$(S(I)) +1620 GOTO 1510 +1630 PRINT "WHICH OF YOUR CARDS DO YOU WISH TO PLAY"; +1640 INPUT X$,Y$ +1650 GOSUB 2610 +1660 IF V9>0 THEN 1680 ELSE PRINT "UNKNOWN CARD, TRY AGAIN"; +1670 GOTO 1640 +1680 GOSUB 2500 +1690 IF S9>0 THEN 1710 ELSE PRINT "UNKNOWN SUIT, TRY AGAIN"; +1700 GOTO 1640 +1710 IF V9=7 THEN 1760 +1720 IF S9=P THEN 1760 +1730 IF V9=V(T(T1)) THEN 1760 +1740 PRINT "THAT IS NOT A LEGAL PLAY." +1750 GOTO 1510 +1760 FOR I=1 TO 52 +1770 IF G(I)=0 THEN 1800 +1780 IF V(I)<>V9 THEN 1800 +1790 IF S(I)=S9 THEN 1830 +1800 NEXT I +1810 PRINT "YOU DO NOT HAVE THAT CARD." +1820 GOTO 1510 +1830 G(I)=0 +1840 H1=H1-1 +1850 T1=T1+1 +1860 T(T1)=I +1870 IF V9<>7 THEN 1930 +1880 PRINT "WHAT SUIT DO YOU WISH"; +1890 INPUT Y$ +1900 GOSUB 2500 +1910 IF S9>0 THEN 1930 ELSE PRINT "UNKNOWN SUIT, TRY AGAIN"; +1920 GOTO 1890 +1930 P=S9 +1940 P1=1 +1950 IF H1<>0 THEN 1970 +1960 W1=1 +1970 RETURN +1980 IF P2<>0 THEN 2000 +1990 B1=1 +2000 P1=0 +2010 RETURN +2020 I=53 +2030 I=I-1 +2040 IF H(I)=0 THEN 2080 +2050 IF V(I)=7 THEN 2080 +2060 IF S(I)=P THEN 2220 +2070 IF V(I)=V(T(T1)) THEN 2220 +2080 IF I>1 THEN 2030 +2090 FOR I=1 TO 52 +2100 IF V(I)<>7 THEN 2120 +2110 IF H(I)<>0 THEN 2220 +2120 NEXT I +2130 IF D1=0 THEN 2460 +2140 I=D(D1) +2150 D1=D1-1 +2160 IF V(I)=7 THEN 2240 +2170 IF S(I)=P THEN 2240 +2180 IF V(I)=V(T(T1)) THEN 2240 +2190 H2=H2+1 +2200 H(I)=1 +2210 GOTO 2130 +2220 H(I)=0 +2230 H2=H2-1 +2240 T1=T1+1 +2250 T(T1)=I +2260 P=S(I) +2270 IF V(I)<>7 THEN 2420 +2280 FOR J=1 TO 4 +2290 Y(J)=0 +2300 K1=13*(J-1)+1 +2310 K2=13*J +2320 FOR K=K1 TO K2 +2330 IF H(I)=0 THEN 2350 +2340 Y(J)=Y(J)+1 +2350 NEXT K +2360 NEXT J +2370 P=1 +2380 FOR J=2 TO 4 +2390 IF Y(J)<=Y(P) THEN 2410 +2400 P=J +2410 NEXT J +2420 P2=1 +2430 IF H2<>0 THEN 2450 +2440 W1=1 +2450 RETURN +2460 IF P1<>0 THEN 2480 +2470 B1=1 +2480 P2=0 +2490 RETURN +2500 FOR I0 = 1 TO 4 +2510 IF Y$=U$(I0) THEN 2590 +2520 NEXT I0 +2530 S9 = 0 +2540 IF Y$="C" THEN S9=1 +2550 IF Y$="D" THEN S9=2 +2560 IF Y$="H" THEN S9=3 +2570 IF Y$="S" THEN S9=4 +2580 RETURN +2590 S9 = I0 +2600 RETURN +2610 FOR I0 = 1 TO 13 +2620 IF X$=C$(I0) THEN 2700 +2630 NEXT I0 +2640 V9 = 0 +2650 IF X$="J" THEN V9=10 +2660 IF X$="Q" THEN V9=11 +2670 IF X$="K" THEN V9=12 +2680 IF X$="A" THEN V9=13 +2690 RETURN +2700 V9 = I0 +2710 RETURN +2720 END +THEN V9=11 +2670 IF X$="K" THEN V9=12 +2680 IF X$="A" \ No newline at end of file diff --git a/software/BAS/GALAXY.bas b/software/BAS/GALAXY.bas new file mode 100644 index 0000000..db5101b --- /dev/null +++ b/software/BAS/GALAXY.bas @@ -0,0 +1,19 @@ +10 REM << GALAXY >> +20 WIDTH 79 +30 A$="*":B$="+":C$=".":D$="*" +40 FOR I=1 TO 100 +50 GOSUB 90 +60 PRINT TAB(A);A$; TAB(B);B$; TAB(C);C$ +70 NEXT +80 GOTO 40 +90 A=INT(RND(1)*28) : B=INT(RND(1)*25)+28 : C=INT(RND(1)*25)+55 +100 X=RND(1) +110 IF X<.15 THEN SWAP A$,B$ : GOTO 170 +120 IF X<.3 THEN SWAP B$,C$ : GOTO 170 +130 IF X<.45 THEN SWAP A$,C$ : GOTO 170 +140 IF X<.6 THEN SWAP A$,D$ : GOTO 170 +150 IF X<.75 THEN SWAP B$,D$ : GOTO 170 +160 IF X<.9 THEN SWAP C$,D$ +170 RETURN +170 +140 IF X<.6 THEN SWAP \ No newline at end of file diff --git a/software/BAS/GALAXY2.bas b/software/BAS/GALAXY2.bas new file mode 100644 index 0000000..79686b2 --- /dev/null +++ b/software/BAS/GALAXY2.bas @@ -0,0 +1,48 @@ +100 REM << GALAXY >> +101 WIDTH 79 +102 DIM G$(15) +103 FOR X=1 TO 15 : READ G$(X) : NEXT +104 A$="*":B$="+":C$=".":D$="*" +105 FOR I=1 TO 40 +106 GOSUB 113 +107 PRINT TAB(A);A$; TAB(B);B$; TAB(C);C$ +108 NEXT +109 Z1=INT(RND(1)*15)+1 +110 Z$=G$(Z1) +111 PRINT TAB(20) Z$ +112 GOTO 105 +113 A=INT(RND(1)*28) : B=INT(RND(1)*25)+28 : C=INT(RND(1)*25)+55 +114 X=RND(1) +115 IF X<.15 THEN SWAP A$,B$ : GOTO 121 +116 IF X<.3 THEN SWAP B$,C$ : GOTO 121 +117 IF X<.45 THEN SWAP A$,C$ : GOTO 121 +118 IF X<.6 THEN SWAP A$,D$ : GOTO 121 +119 IF X<.75 THEN SWAP B$,D$ : GOTO 121 +120 IF X<.9 THEN SWAP C$,D$ +121 RETURN +122 DATA YOU ARE A TRAVELLER LOST IN SPACE +123 DATA I AM BUT A TRAVELLER LOST IN SPACE +124 DATA ALL MANKIND BUT EXPLORERS LOST IN SPACE +125 DATA CAN WE FIND EACH OTHER IN SPACE ? +126 DATA HOW DOES LIFE SEEM FROM UP THERE ? +127 DATA I CAN SEE YOU CLEARLY NOW FROM HERE +128 DATA THE YEARS SEEM TO PASS SO QUICKLY +129 DATA WE'LL MEET HERE IN A MILLION YEARS +130 DATA GREETINGS FROM WHERE THE RATS CRAWL +131 DATA GREETINGS FROM THE CRACKS IN THE WALL +132 DATA I SEE ALL THAT YOU EVER ARE DOING +133 DATA THE SKY IS FALLING ON US ALL !!! +134 DATA I'M AFRAID THAT THE END IS COMING +135 DATA IN WHICH REMOTE PLACE CAN GOD BE MET ? +136 DATA WE'LL MEET AGAIN DON'T KNOW WHERE OR WHEN +137 DATA TIME RUNS QUITE SHORT FOR YOU AND ME +138 DATA YOU GROW OLD AT THE SPEED OF LIGHT +139 DATA HAVE YOU MADE PEACE WITH YOUR MAKER ? +140 DATA HAVE YOU EXISTED AS A GIVER OR A TAKER ? +141 DATA WILL YOU BE ABLE TO MEET ME OUT HERE ? +142 DATA REMEMBER ALL THE GREAT TIMES WE HAD ? +143 DATA WE SHALL NEVER LEAVE THIS PLACE TILL WE DIE +144 DATA ETERNAL ENERGY BEYOND THE DREAMS OF MAN +145 DATA SOME PEOPLE WILL ALWAYS BE FREE FOREVER +146 DATA SOME PEOPLE WILL NEVER TASTE FREEDOM + \ No newline at end of file diff --git a/software/BAS/MONOPLY.BAS b/software/BAS/MONOPLY.BAS new file mode 100644 index 0000000..7f4dedd --- /dev/null +++ b/software/BAS/MONOPLY.BAS @@ -0,0 +1,1051 @@ +10 DIM P$(41),S(41),R(41),V(41),J(41),M(41),K(21),L(41),C(41),B(41),O(41) +20 PRINT "HOW MANY PLAYERS"; +30 PRINT "(TYPE '0' FOR INSTRUCTIONS)"; +40 INPUT N +50 IF N>0 THEN 80 +60 GOSUB 8580 +70 GOTO 20 +80 IF N<11 THEN 110 +90 PRINT" NO MORE THAN 10 CAN PLAY" +100 GOTO 20 +110 FOR Q5 = 1 TO N +120 PRINT "NAME"; +130 REM THIS PART STARTED FROM 151-2 +140 REM A(B)=0 FOR HUMAN, 1 FOR COMPUTER +150 GOTO 210 +160 LET N$(Q5)="COMPUTER" +170 A(Q5)=1 +180 W7=W7+1 +190 REM W7 IS # OF COMPUTER PLAYERS +200 GOTO 360 +210 INPUT N$(Q5) +220 IF N$(Q5)="COMPUTER" THEN 160 +230 IF N$(Q5)="YOU" THEN 160 +240 IF N$(Q5)<>"WHAT" THEN 260 +250 GOTO 330 +260 Z7=1 +270 FOR O1=1 TO Q5-1 +280 IF M$(O1)<>N$(Q5) THEN 310 +290 PRINT "NAME IN USE, INPUT ANOTHER" +300 GOTO 120 +310 NEXT O1 +315 M$(Q5)=N$(Q5) +320 GOTO 360 +330 PRINT "TYPE PLAYERS NAME (ONE ONLY AT A TIME)" +340 PRINT "'YOU' IF THE COMPUTER IS PLAYING." +350 GOTO 120 +360 T(Q5)=1500 +370 NEXT Q5 +380 IF Z7=1 THEN 410 +390 A7=1 +400 A8=1 +410 FOR B4= 1 TO 40 +420 REM READS DATA, P$=NAME,S IS TYPE,R IS RENT, AND C IS COST +430 READ P$(B4),S(B4) +440 REM B3= B= PLAYER NUMBER +450 IF S(B4)>8 THEN 470 +460 GOTO 490 +470 READ L(B4),C(B4) +480 R(B4)=L(B4) +490 NEXT B4 +500 I0=1 +510 J0=200 +520 LET I=I+1 +530 PRINT +540 PRINT "TURN";I +550 PRINT +560 GOSUB 6910 +570 IF I0=0 THEN 600 +580 GOTO 2780 +590 I0=0 +600 FOR B3=1 TO N +610 B=B3 +620 IF A(B)=1 THEN 660 +630 O$="YOU" +640 I$="YOUR" +650 GOTO 690 +660 O$="I" +670 I$="MY" +680 REM THIS SETS O AND I$ FOR COMPUTER OR HUMAN +690 R5=0 +700 U=0 +710 IF Q(B)=1 THEN 3720 +720 IF A(B)=1 THEN 780 +730 IF N$(B)<>"ME" THEN 760 +740 PRINT "YOUR TURN" +750 GOTO 820 +760 PRINT N$(B3);"'S TURN" +770 GOTO 820 +780 PRINT "MY TURN"; +790 IF W7=1 THEN 810 +800 PRINT "(PLAYER";B;")"; +810 PRINT +820 IF T(B)>0 THEN 840 +830 GOSUB 9010 +840 IF Q(B)=1 THEN 3720 +850 IF E(B)=0 THEN 880 +860 B9=B3 +870 GOSUB 4770 +880 IF T(B)> 100 THEN 900 +890 GOSUB 5710 +900 IF N(B)>0 THEN 920 +910 IF X(B)=0 THEN 940 +920 GOSUB 6230 +930 GOTO 940 +940 B2=INT(RND(1)*6)+1 +950 B1=INT(RND(1)*6)+1 +960 PRINT "THE DICE ARE ON";B1;" AND ";B2 +970 IF B1=B2 THEN 1010 +980 IF J(B)=1 THEN 1150 +990 G(B)=0 +1000 GOTO 1510 +1010 G(B)= G(B)+1 +1020 REM G(B) IS NUMBER OF DOUBLES +1030 IF G(B)>=3 THEN 1100 +1040 IF J(B)=1 THEN1070 +1050 REM J(B)= 1IF IN JAIL, =0 IF OUT OF JAIL +1060 GOTO 1510 +1070 J(B)=0 +1080 PRINT "OUT OF JAIL " +1090 GOTO 2760 +1100 J(B)=1 +1110 PRINT "3 DOUBLES . IN JAIL" +1120 P(B)=10 +1130 GOTO 2770 +1140 G(B)=0 +1150 IF F(B)>0 THEN 1170 +1160 GOTO 1290 +1170 PRINT" IN JAIL WILL ";O$;" USE ";I$;" JAILCARD"; +1180 IF A(B)=0 THEN 1210 +1190 PRINT "?* YES *" +1200 GOTO 1260 +1210 INPUT X$ +1220 IFLEFT$(X$,1)="N"THEN1290 +1230 IFLEFT$(X$,1)="Y"THEN1260 +1240 PRINT "YES OR NO"; +1250 GOTO 1210 +1260 F(B)=F(B)-1 +1270 D(B)=0 +1280 GOTO 1490 +1290 IF D(B)<3 THEN 1320 +1300 PRINT "THIRD TIME IN JAIL.";O$;" MUST PAY $50." +1310 GOTO 1480 +1320 PRINT"IN JAIL. WILL ";O$;" PAY $50"; +1330 IF A(B)=0 THEN 1410 +1340 D(B)=D(B)+1 +1350 IF D(B)=3 THEN 1390 +1360 IF T(B)>200 THEN 1390 +1370 PRINT"? *NO*" +1380 GOTO 2770 +1390 PRINT"? *YES*" +1400 GOTO 1480 +1410 P(B)=P(B)+1 +1420 INPUT A$ +1430 P(B)=10 +1440 IFLEFT$(A$,1)="Y"THEN1480 +1450 IFLEFT$(A$,1)="N"THEN2770 +1460 PRINT "TYPE 'YES' OR 'NO'"; +1470 GOTO 1290 +1480 LET T(B)= T(B)-50 +1490 J(B)=0 +1500 D(B)=0 +1510 P(B)= P(B)+B1+B2 +1520 R5=0 +1530 U=0 +1540 P=P(B) +1550 IF P(B)>40 THEN 1570 +1560 GOTO 1610 +1570 LET P(B)= P(B)- 40 +1580 P=P(B) +1590 T(B)= T(B)+200 +1600 PRINT "PASSED GO!! COLLECTED $200 " +1610 IF S(P(B))>10 THEN 1640 +1620 GOTO 2290 +1630 P=P(B3) +1640 IF V(P(B))>B THEN 2040 +1650 REM V(--) IS THE OWNER OF THE PROPERTY +1660 IF V(P(B))0 THEN 2040 +1690 GOTO 1760 +1700 Y9=P(B) +1710 IF A(B)=0 THEN 1740 +1720 PRINT "I AM ON ";P$(P);" WHICH I OWN." +1730 GOTO 2760 +1740 PRINT "YOU ARE ON ";P$(Y9); " WHICH YOU OWN " +1750 GOTO 2760 +1760 LET P=P(B3) +1770 IF A(B)=0 THEN 1800 +1780 PRINT P$(P);" IS AVAILABLE AT PRICE $";C(P);" WILL I BUY IT"; +1790 GOTO 1820 +1800 PRINT "WILL YOU BUY ";P$(P);" FOR $";C(P); +1810 IF A(B)=0 THEN 1870 +1820 IF T(B)<200 +C(P) THEN 1850 +1830 PRINT "? *YES*" +1840 GOTO 1920 +1850 PRINT "? *NO*" +1860 GOTO 2760 +1870 INPUT A$ +1880 IFLEFT$(A$,1)="Y" THEN 1920 +1890 IFLEFT$(A$,1)="N"THEN2760 +1900 PRINT"YES OR NO"; +1910 GOTO 1870 +1920 LET T(B)= T(B)- C(P(B)) +1930 IF R5=1 THEN 1950 +1940 GOTO 1960 +1950 W(B)=W(B)+1 +1960 IF U=1 THEN 1980 +1970 GOTO 1990 +1980 LET U(B)= U(B)+1 +1990 V(P(B))= B +2000 U8=0 +2010 GOSUB 4260 +2020 GOTO 2760 +2030 REM THIS IS RENT ROUTINE +2040 IF R5=0 THEN 2070 +2050 R(P(B))= 25* W(V(P(B))) +2060 GOTO 8320 +2070 IF U=0 THEN 8320 +2080 IF U(B)=2 THEN 2110 +2090 U3=4 +2100 GOTO 2120 +2110 U3=10 +2120 GOTO 8310 +2130 IF A(W8)=0 THEN 2180 +2140 PRINT P$(W9); " IS MINE"; +2150 IF W7=1 THEN 2190 +2160 PRINT "(PLAYER";W8;")"; +2170 GOTO 2190 +2180 PRINT P$(W9);" BELONGS TO "; N$(W8); +2190 IF M(P(B))=1 THEN 2240 +2200 PRINT ", RENT IS $ "; R(P(B)) +2210 T(B)=T(B)-R(P(B)) +2220 T(V(P))= T(V(P))+ R(P(B)) +2230 GOTO 2760 +2240 PRINT " ,BUT IT IS MORTGAGED" +2250 GOTO 2760 +2260 P=P(B3) +2270 T(V(P(B)))= T(V(P(B)))+ R(P(B)) +2280 GOTO 2760 +2290 ON S(P(B)) GOTO 2760,2370, 2420,2490,2600,2630,2670,2310,2710,2740 +2300 REM FOR UNIQUE SQUARES IT SENDS THE PROGRAM TO THE RIGHT DIRECTION +2310 Y9=P(B) +2320 IF A(B)=0 THEN 2350 +2330 PRINT "I AM ON ";P$(Y9);"." +2340 GOTO 2760 +2350 PRINT "YOU ARE ON ";P$(Y9) +2360 GOTO 2760 +2370 PRINT"COMMUNITY CHEST "; +2380 PRINT "--"; +2390 GOSUB 3750 +2400 REM GOES TO CHANCE-COMMUNITY CHEST GOSUB +2410 GOTO 2440 +2420 PRINT "CHANCE--"; +2430 GOSUB 3750 +2440 IF V0=1 THEN 2460 +2450 GOTO 2760 +2460 V0=0 +2470 R5=1 +2480 GOTO 1640 +2490 Z2=.1*(T(B)) +2500 IF Z2>0 THEN 2530 +2510 PRINT O$;" IS ON INCOME TAX, BUT HAS A NEGATIVE AMOUNT OF MONEY" +2520 GOTO 2760 +2530 IF Z2>200 THEN 2570 +2540 LET T(B)= T(B)-INT(Z2) +2550 PRINT "INCOME TAX--$";INT(Z2) +2560 GOTO 2760 +2570 T(B)= T(B)- 200 +2580 PRINT "INCOME TAX-$200" +2590 GOTO 2760 +2600 T(B)= T(B)-75 +2610 PRINT "LUXURY TAX $75" +2620 GOTO 2760 +2630 J(B)=1 +2640 P(B)=10 +2650 PRINT"GO TO JAIL" +2660 GOTO 2760 +2670 PRINT"FREE PARKING-$";J0;"." +2680 T(B)=T(B)+J0 +2690 J0=200 +2700 GOTO 2760 +2710 R5=1 +2720 GOTO 1640 +2730 GOTO 2760 +2740 U=1 +2750 GOTO 1630 +2760 IF G(B)>0 THEN 940 +2770 PRINT +2780 IF A8=-1 THEN 3000 +2790 IF A8=0 THEN 2850 +2800 IF A8=5 THEN 2830 +2810 A8=A8+1 +2820 GOTO 3700 +2830 A8=1 +2840 GOTO3000 +2850 PRINT "SUMMARY"; +2860 INPUT A$ +2870 IF A$="AUTO" THEN 2890 +2880 GOTO 2910 +2890 A8=1 +2900 GOTO 3700 +2910 IF A$="ALWAYS" THEN 2930 +2920 GOTO2950 +2930 A8=-1 +2940 GOTO 3000 +2950 IFLEFT$(A$,1)="N"THEN3700 +2960 IFLEFT$(A$,1)="Y"THEN3000 +2970 PRINT "'YES' OR 'NO' OR 'AUTO'( GIVES A SUMMARY EVERY FIVE TURNS" +2980 PRINT "AND DOESN'T ASK YOU ANY MORE" +2990 GOTO 2850 +3000 GOTO 3010 +3010 FOR J8=1 TO N +3020 X=0 +3030 T0=0 +3040 IF Q(J8)=1 THEN3650 +3050 T$=" " +3060 IF A(J8)=1 THEN 3120 +3070 IF N$(J8)<>"ME" THEN 3100 +3080 PRINT "YOU HAVE $";T(J8); +3090 GOTO 3160 +3100 PRINT N$(J8);" HAS $";T(J8); +3110 GOTO 3160 +3120 PRINT"I"; +3130 IF W7=1 THEN 3150 +3140 PRINT "(PLAYER";J8;")"; +3150 PRINT" HAVE $";T(J8); +3160 FORJ9=1 TO 40 +3170 IF V(J9)=J8 THEN 3190 +3180 GOTO 3350 +3190 IF T$= " " THEN 3210 +3200 PRINT ","; T$; +3210 T$= P$(J9) +3220 X=X+C(J9)+B(J9)*INT((S(J9)-10)/2+.5)*50 -M(J9)* .5*C(J9) +3230 IF B(T)=0 THEN 3310 +3240 IF B(T)>1 THEN 3270 +3250 PRINT "(WITH A HOUSE)"; +3260 GOTO 3310 +3270 IF B(T)<5 THEN 3300 +3280 PRINT "(WITH A HOTEL)"; +3290 GOTO 3310 +3300 PRINT "(WITH";B(T);"HOUSES)"; +3310 IF M(T)=0 THEN 3330 +3320 PRINT "(MORTGAGED)"; +3330 T=J9 +3340 IF T0=1 THEN 3460 +3350 NEXT J9 +3360 IF F(J8)>0 THEN 3420 +3370 IF T$<>" " THEN 3400 +3380 PRINT "." +3390 GOTO 3610 +3400 PRINT ", AND ";T$; +3410 GOTO 3440 +3420 IF T$=" " THEN3470 +3430 PRINT",";T$; +3440 T0=1 +3450 GOTO 3230 +3460 T0=0 +3470 IF F(J8)=0 THEN 3550 +3480 IF F(J8)=1 THEN 3520 +3490 PRINT ",AND ";F(J8);"JAILCARDS."; +3500 X=X+F(J8)*50 +3510 GOTO 3610 +3520 PRINT ",AND A JAILCARD."; +3530 X=X+50 +3540 GOTO 3610 +3550 IF T$=" " THEN3610 +3560 K(0)=LEN(T$):FORXE=1TOK(0):K(XE)=ASC(MID$(T$,XE,1)):NEXTXE +3570 IF K(K(0))=46 THEN 3600 +3580 PRINT "."; +3590 GOTO 3610 +3600 GOTO 3610 +3610 PRINT +3620 IF X=0 THEN 3640 +3630 PRINT " TOTAL ASSETS:$";T(J8)+X;"." +3640 PRINT +3650 NEXT J8 +3660 PRINT" "; +3670 PRINT "$";J0;" ON THE FREE PARKING JACKPOT." +3680 PRINT +3690 PRINT +3700 IF I0=0 THEN 3720 +3710 GOTO 590 +3720 PRINT +3730 NEXT B3 +3740 GOTO 520 +3750 J5=INT(RND(1)*7)+1 +3760 ON J5 GOTO 3770,3810,3870,3930,3990,4040,4070 +3770 PRINT "GOTO JAIL!!!" +3780 J(B)=1 +3790 P(B)=10 +3800 GOTO 4090 +3810 PRINT "COLLECT $50 FROM EVERYONE" +3820 FOR Y3=1TON +3830 LET T(Y3)= T(Y3)-50 +3840 NEXT Y3 +3850 T(B)=T(B)+N*50 +3860 GOTO 4090 +3870 PRINT "GO TO READING" +3880 LET P(B)=5 +3890 LET P=5 +3900 V0=1 +3910 REM V0 TELLS THE PROGRAM TO GO TO READING +3920 RETURN +3930 PRINT "PAY ALL $50" +3940 FOR Y4=1 TO N +3950 T(Y4)= T(Y4)+50 +3960 NEXT Y4 +3970 T(B)=T(B)-N*50 +3980 GOTO 4090 +3990 Y2=INT(RND(1)*4)+1 +4000 PRINT "PAY $";Y2*50 +4010 T(B)=T(B)-Y2*50 +4020 J0=J0+Y2*50 +4030 GOTO 4090 +4040 PRINT "GO DIRECTLY TO GO" +4050 P(B)=40 +4060 GOTO 4090 +4070 PRINT "TICKET OUT OF JAIL" +4080 F(B)=F(B)+1 +4090 RETURN +4100 DATA MEDITERRANEAN,11,2,60,CC,2,BALTIC,11,4,60,IT,4 +4110 DATA READING,9,25,200,ORIENTAL,12,6,100,CH,3 +4120 DATA VERMONT,12,6,100,CONN.,12,8,120,JAIL,8 +4130 DATAST. CHAS.,13,10,140,ELECTRIC WORKS,10,1,150,STATES +4140 DATA13,10,140,VIRGINIA,13,12,160,PENNS.RR.,9,25,200 +4150 DATA ST.JAMES,14,14,180,CC,2,TENNESSEE,14,14,180 +4160 DATA NEW YORK,14,16,200,FP,7,KENTUCKY,15,18,200 +4170 DATA CH,3,INDIANA,15,18,220,ILLINOIS,15,20,240 +4180 DATA B&O RR,9,25,200 +4190 DATA ATLANTIC,16,22,260,VENTNOR +4200 DATA 16,22,260,WATER WORKS,10,1,150,M. GARDENS +4210 DATA 16,24,280,GOJAIL,6,PACIFIC,17,26,300,N.CAROLINA +4220 DATA 17,26,300,CC,2,PENNS. AVE.,17,28,320 +4230 DATA SHORTLINE,9,25,200,CHANCE,3,PARKPLACE,18 +4240 DATA 35,350,LT,5,BOARDWALK,18,50,400,GO,8 +4250 DATA GO,8 +4260 Z=0 +4270 Z(3)=0 +4280 Z(2)=0 +4290 Z(1)=0 +4300 IFU8=0THEN4340 +4310 B9=E9 +4320 P=E8 +4330 GOTO 4360 +4340 B9=B3 +4350 P=P(B9) +4360 IF S(P)<11 THEN 4490 +4370 IF P>4 THEN 4400 +4380 LET I7=0 +4390 GOTO 4410 +4400 I7= P-4 +4410 IF P>35 THEN 4440 +4420 Q1= P+4 +4430 GOTO 4450 +4440 Q1=40 +4450 FOR W1= I7 TO Q1 +4460 IF S(W1) = S(P) THEN 4480 +4470 GOTO 4520 +4480 IF V(W1)= B9 THEN 4500 +4490 RETURN +4500 Z=Z+1 +4510 Z(Z)=W1 +4520 NEXT W1 +4530 E(B9)= E(B9)+1 +4540 IF A(B9)=0 THEN 4570 +4550 PRINT "I HAVE A MONOPOLY AND THE RENTS ARE DOUBLED" +4560 GOTO 4580 +4570 PRINT "YOU NOW HAVE MONOPOLY. THE RENTS ARE DOUBLED" +4580 FOR Z2=1 TO 3 +4590 R(Z(Z2))= 2*R(Z(Z2)) +4600 O(Z(Z2))=1 +4610 NEXT Z2 +4620 IF S(Z(1))<11 THEN 4640 +4630 GOTO 4650 +4640 RETURN +4650 GOSUB 4770 +4660 U8=0 +4670 RETURN +4680 FOR I1=1 TO 40 +4690 IF S(I1)= S(B) THEN 4710 +4700 GOTO 4750 +4710 IF V(I1)= V9 THEN 4730 +4720 RETURN +4730 Z=Z+1 +4740 Z(Z)=I1 +4750 NEXT I1 +4760 GOTO 4570 +4770 PRINT" DO ";O$;" WANT HOUSES NOW"; +4780 IF A(B9)=0 THEN 4820 +4790 IF T(B9)>500 THEN 4880 +4800 PRINT "? *NO*" +4810 RETURN +4820 INPUT Z$ +4830 IFLEFT$(Z$,1)="N"THEN4870 +4840 IFLEFT$(Z$,1)="Y"THEN4900 +4850 PRINT "YES OR NO"; +4860 GOTO 4820 +4870 RETURN +4880 I3=1 +4890 GOTO 4920 +4900 PRINT "LOT, #OF HOUSES"; +4910 IF A(B)=0 THEN5120 +4920 FOR I2= 1 TO 40 +4930 IF V(I2)<>B9 THEN 4990 +4940 IF O(I2)=0 THEN 4990 +4950 IF B(I2)>4 THEN 4990 +4960 GOTO 5050 +4970 H=I2 +4980 GOTO5250 +4990 NEXT I2 +5000 GOTO 5030 +5010 IF I3> 5 THEN 5030 +5020 GOTO 4920 +5030 PRINT "?*NO*" +5040 RETURN +5050 IF T(B)>1700 THEN 5090 +5060 IF B(I2)>5-INT(T(B)/350) THEN 5090 +5070 H4=INT (T(B)/350) +5080 GOTO 5100 +5090 H4= 5-B(I2) +5100 PRINT "?* YES ";H4;" ON ";P$(I2);"*" +5110 GOTO 5260 +5120 INPUT H$,H5 +5130 IFLEFT$(H$,1)="N"THEN4870 +5140 IF H$="WHAT" THEN 9370 +5150 IF H5>0 THEN 5190 +5160 PRINT "A POSITIVE NUMBER PLEASE!" +5170 INPUT H5 +5180 GOTO 5150 +5190 FOR H=1 TO 40 +5200 IF P$(H)= H$ THEN 5250 +5210 NEXT H +5220 PRINT "WHAT LOT"; +5230 INPUT H$ +5240 GOTO 5130 +5250 IF A(B)=0 THEN 5310 +5260 H5=H4 +5270 H=I2 +5280 GOTO 5310 +5290 PRINT "YOU DON'T OWN THAT" +5300 GOTO 4770 +5310 H7=H5+B(H) +5320 GOSUB 5340 +5330 GOTO 5590 +5340 R(H)=L(H) +5350 IF H7<6 THEN 5390 +5360 PRINT " YOU WILL HAVE TO HAVE 5 HOUSES (ONE HOTEL)" +5370 H5=H7-B(H) +5380 H7=5 +5390 IF H7>0 THEN 5420 +5400 PRINT "YOU CAN'T HAVE LESS THAN 0 HOUSES." +5410 GOTO 5570 +5420 B(H)=0 +5430 FOR H6= 1 TO H7 +5440 B(H)=H6 +5450 J=H +5460 IF B(H)=0 THEN 4870 +5470 ON B(H) GOTO 5480,5500,5520,5540,5540 +5480 R(J)= R(J)*2.5 +5490 GOTO 5550 +5500 R(J)=R(J)*3 +5510 GOTO 5550 +5520 R(J)= R(J)*2.3 +5530 GOTO 5550 +5540 R(J)=R(J)+185 +5550 R(J)= 10* INT(R(J)/10 +.5) +5560 NEXT H6 +5570 PRINT "THE RENT IS NOW $";R(J);"." +5580 RETURN +5590 C=INT((S(J)-10)/2+.5)*50 +5600 IF H5=1 THEN 5630 +5610 PRINT "THOSE WERE $";C;"EACH, MAKING $";H5*C;"." +5620 GOTO 5640 +5630 PRINT "THAT WAS $";C;"." +5640 T(B9)= T(B9)- H5*C +5650 X(B9)=X(B9)+H5 +5660 RETURN +5670 PRINT "ANOTHER"; +5680 GOTO 4780 +5690 RETURN +5700 GOTO 4440 +5710 PRINT "WHAT DO ";O$;" WANT TO MORTGAGE"; +5720 I3=1 +5730 IF A(B)=0 THEN 5910 +5740 IF T(B)>150 THEN 5860 +5750 FOR I4= 1 TO 40 +5760 IF V(I4)=B THEN 5780 +5770 GOTO 5840 +5780 IF O(I4)= I3 THEN 5840 +5790 IF M(I4)=1 THEN 5840 +5800 IF B(I4)<>0 THEN 5840 +5810 PRINT "? *";P$(I4);"*" +5820 Z5=I4 +5830 GOTO 6000 +5840 NEXT I4 +5850 IF I3=1 THEN 5890 +5860 PRINT "? *NOTHING*" +5870 RETURN +5880 GOTO 6110 +5890 I3=0 +5900 GOTO 5750 +5910 INPUT Z$ +5920 IF Z$="WHAT" THEN 9400 +5930 IFLEFT$(Z$,3)<>"NOT"THEN5950 +5940 RETURN +5950 FOR Z5=1 TO 40 +5960 IF P$(Z5)=Z$ THEN 6000 +5970 NEXT Z5 +5980 PRINT "WHAT"; +5990 GOTO 5910 +6000 IF B(Z5)>0 THEN 6120 +6010 FOR X=1 TO 40 +6020 IF S(X)<>S(Z5) THEN 6060 +6030 IF B(X)=0 THEN 6060 +6040 PRINT "THERE ARE HOUSES ON OTHER LOTS OF MONPOLY. YOU MUST SELL THEM." +6050 GOTO 5710 +6060 NEXT X +6070 GOTO 6150 +6080 M(Z5)=1 +6090 N(B)= N(B)+1 +6100 T(B)= T(B)+.5*C(Z5) +6110 GOTO 5710 +6120 PRINT "THERE ARE HOUSES ON IT" +6130 GOTO 5710 +6140 RETURN +6150 IF V(Z5)>B3THEN 6200 +6160 IF V(Z5)"WHAT" THEN 6410 +6380 PRINT "TYPE 'NOTHING', A PROPERTY NAME, OR 'HOUSES' IF" +6390 PRINT "YOU WANT TO SELL THEM." +6400 GOTO 6360 +6410 IFLEFT$(Z$,3)="NOT"THEN6590 +6420 IF Z$="HOUSES" THEN 6600 +6430 FOR E=1 TO 40 +6440 IF P$(E)=Z$ THEN 6480 +6450 NEXT E +6460 PRINT "WHAT"; +6470 GOTO 6360 +6480 IF M(E)=1 THEN 6510 +6490 PRINT "IT ISN'T MORTGAGED" +6500 GOTO 6230 +6510 IF V(E)=B THEN 6540 +6520 PRINT"YOU DON'T OWN IT" +6530 GOTO 6230 +6540 M(E)=0 +6550 N(B)= N(B)-1 +6560 T(B)=T(B)-INT(.6*C(E)) +6570 PRINT "WITH INTEREST THAT WAS$";INT(.6*C(E)) +6580 IF N(B)>0 THEN 6230 +6590 RETURN +6600 PRINT"LOT,# OF HOUSES"; +6610 INPUT Z$,E2 +6620 IF E2>0 THEN 6650 +6630 PRINT "INPUT A POSITIVE NUMBER" +6640 GOTO 6600 +6650 IF Z$="NO" THEN6110 +6660 GOTO 6700 +6670 PRINT "TYPE IN THE NAME OF THE LOT THEN THE # OF HOUSES YOU ARE" +6680 PRINT"SELLING. TO SELL NONE TYPE 'NO'" +6690 GOTO 6600 +6700 FOR E3=1 TO 40 +6710 IF P$(E3)=Z$THEN 6760 +6720 NEXT E3 +6730 PRINT "WHAT LOT"; +6740 INPUT Z$ +6750 GOTO 6650 +6760 B(E3)= B(E3)-E2 +6770 X(B)=X(B)-E2 +6780 IF B(E3)<0 THEN 6870 +6790 H=E3 +6800 H7=B(H) +6810 GOSUB 5340 +6820 E4=INT((S(E3)-10)/2+.5)*25 +6830 E4=E4*E2 +6840 PRINT" YOU GET$";E4 +6850 T(B)=T(B)+E4 +6860 GOTO 6230 +6870 PRINT "YOU DON'T HAVE THAT MANY" +6880 B(E3)=B(E3)+E2 +6890 GOTO 6600 +6900 GOTO 6230 +6910 IF A7=1 THEN 7050 +6920 IF E6=0 THEN 6960 +6930 E6=E6+1 +6940 IF E6<3 THEN 7090 +6950 E6=1 +6960 PRINT "CHANGES"; +6970 E6=0 +6980 INPUT Z$ +6990 IF Z$<>"WHAT" THEN 7020 +7000 PRINT "'YES', 'NO','NEVER',OR 'DELAY'( WILL ASK AGAIN IN THREE TURNS"; +7010 GOTO 6980 +7020 IF Z$= "NEVER" THEN 7040 +7030 GOTO 7060 +7040 A7=1 +7050 RETURN +7060 IF Z$="YES" THEN 7170 +7070 IF Z$<>"DELAY" THEN 7110 +7080 E6=1 +7090 PRINT +7100 RETURN +7110 IF Z$="NO" THEN 7090 +7120 PRINT "TYPE 'YES', OR 'NO' IF YOU WANT TO MAKE CHANGES OR NOT" +7130 PRINT "OR 'DELAY' TO HAVE IT ASK YOU LATER" +7140 GOTO 6960 +7150 RETURN +7160 IF T(B9)> 300 THEN 4880 +7170 GOTO 7210 +7180 REM THIS PART WILL TRANSFERR OWNERSHIP OF A PROPERTY +7190 REM TO SOMEONE ELSE AND TRANSFER SOME MONEY TO +7200 REM TO CORRRESPOND +7210 PRINT "('WHAT,A,0' FOR INST.)"; +7220 INPUT Z$,A$,A +7230 IF Z$="NEW PLAYER" THEN 10120 +7240 IF A$<>"YOU" THEN 7260 +7250 A$="COMPUTER" +7260 IF Z$="NEW PLAYER" THEN 10120 +7270 IF Z$="WHAT" THEN 9420 +7280 IF Z$= "NO" THEN 8240 +7290 IF Z$="QUIT" THEN 7590 +7300 IF Z$="JAIL CARD" THEN 7590 +7310 IF Z$="JAILCARD" THEN 7590 +7320 IF A$<>"BANK" THEN 7360 +7330 GOTO 7590 +7340 PRINT" THAT'S ILLEGAL!" +7350 GOTO 7210 +7360 FOR E8=1 TO 40 +7370 IF P$(E8)= Z$ THEN 7460 +7380 NEXT E8 +7390 PRINT "WHAT LOT"; +7400 INPUT Z$ +7410 IF Z$<>"WHAT"THEN 7440 +7420 PRINT"TYPE THE PROPERTY NAME OR 'NO'" +7430 GOTO7400 +7440 IF Z$="NO" THEN 6960 +7450 GOTO 7360 +7460 IF S(E8)<9THEN 8250 +7470 T8=0 +7480 IF V(E8)=0 THEN 8270 +7490 IF B(E8)>0 THEN 7570 +7500 FOR I2= 1 TO 40 +7510 IF S(I2)<>S(E8) THEN 7550 +7520 IF B(I2)=0 THEN 7550 +7530 PRINT "THERE ARE HOUSES ON OTHER LOTS OF MONOPOLY.YOU MUST SELL THEM." +7540 GOTO 6960 +7550 NEXT I2 +7560 GOTO 7590 +7570 PRINT "THERE ARE HOUSES ON IT" +7580 GOTO 7210 +7590 T8=0 +7600 FOR E9= 1 TO N +7610 IF N$(E9)=A$ THEN 7630 +7620 GOTO 7640 +7630 T8=T8+1 +7640 NEXT E9 +7650 ON T8+1 GOTO 7770,7860,7660,7660,7660,7660,7660,7660,7660,7660 +7660 PRINT "WHICH PLAYER NO.('-1' FOR INSTRUCTIONS)"; +7670 INPUT E9 +7680 IF E9>0 THEN 7720 +7690 PRINT "TYPE THE PLAYER NO. OF THE PIECE. BECAUSE I" +7700 PRINT "PLAY MORE THAN ONE PLAYER, I MUST KNOW WHICH"; +7710 GOTO 7670 +7720 IF E9>N THEN 7660 +7730 IF A(E9)=1 THEN 7760 +7740 PRINT"I AM NOT ";N$(E9) +7750 GOTO 7660 +7760 GOTO 7860 +7770 PRINT "WHO"; +7780 INPUT A$ +7790 IFA$="NO" THEN8290 +7800 IF A$<>"WHAT" THEN 7820 +7810 PRINT "TYPE NEW OWNER'S NAME OR 'NO'"; +7820 GOTO 7590 +7830 REM THIS IS FOR JAILCARDS +7840 GOSUB 9610 +7850 GOTO 6960 +7860 GOTO 7870 +7870 FOR E9=1 TO N +7880 IF N$(E9)<>A$ THEN 7900 +7890 GOTO 7910 +7900 NEXT E9 +7910 B=E9 +7920 IF Z$="JAILCARD" THEN 7830 +7930 IF Z$<>"QUIT" THEN 7970 +7940 B=E9 +7950 GOSUB 9240 +7960 GOTO 6960 +7970 U5=V(E8) +7980 IF A$="BANK" THEN 8090 +7990 IF A(V(E8))=1 THEN 8420 +8000 IFA(E9)=1THEN8360 +8010 T(V(E8))= T(V(E8))+A +8020 IF S(E8)<>9 THEN 8050 +8030 W(V(E8))=W(V(E8))-1 +8040 W(E9)=W(E9)+1 +8050 IF S(E8)<>10 THEN 8080 +8060 U(V(E8))=U(V(E8))-1 +8070 U(E9)=U(E9)+1 +8080 LET V(E8)= E9 +8090 T(E9)= T(E9)-A +8100 IF A$="BANK" THEN 6960 +8110 IF O(E8)=1 THEN 8130 +8120 GOTO 8210 +8130 FOR O9= 1 TO 40 +8140 IF S(O9)=S(E8) THEN 8160 +8150 GOTO 8180 +8160 LET R(O9)= R(O9)/2 +8170 O(O9)=0 +8180 NEXT O9 +8190 PRINT "NO LONGER A MONOPOLY THERE" +8200 LET E(U5)= E(U5)-1 +8210 U8=1 +8220 P=E8 +8230 GOSUB 4260 +8240 GOTO 6960 +8250 PRINT" YOU FOOL, YOU CANT OWN ";Z$;"!!!!" +8260 GOTO 7210 +8270 PRINT "IT ISN'T OWNED" +8280 GOTO 7210 +8290 GOTO 6960 +8300 REM THIS BELONGS TO LINES 1049-- +8310 R(P(B))=INT(RND(1)*6+1)*U3 +8320 W9=P(B) +8330 W8=V(P(B)) +8340 GOTO 2130 +8350 W8=V(P(B)) +8360 IF T(E9)> 200+ C(E8) THEN8390 +8370 PRINT "I DONT ACCEPT" +8380 GOTO 7170 +8390 IF A> 150+C(E8) THEN 8370 +8400 PRINT "I ACCEPT" +8410 GOTO 8010 +8420 IF O(E8)=1 THEN 8520 +8430 IF A>2*C(E8) THEN 590 +8440 IF S(O1)<>S(E8) THEN 8460 +8450 IF V(O1)<>E9 THEN 8500 +8460 NEXT O1 +8470 IF T(V(E8))>200 THEN 8520 +8480 IF A 1.5* C(E8) THEN 8560 +8550 GOTO 8520 +8560 PRINT "IT IS A DEAL" +8570 GOTO 8010 +8580 PRINT " THIS PROGRAM WILL HANDLE UP TO TEN PLAYERS" +8590 PRINT "OR PIECES. IT WILL DO ALL ROUTINE JOBS SUCH AS" +8600 PRINT"ROLLING THE DICE,MOVING PIECES, AND INFORMING THE" +8610 PRINT "PLAYERS OF ALL OPTIONS. IT WILL ACTUALLY" +8620 PRINT"PLAY THE GAME MAKING THE DECISIONS OF ANY NUMBER OF PLAYERS." +8630 PRINT"WANT THE COMPUTER TO DO THIS TYPE 'YOU' WHEN IT ASKS" +8640 PRINT"FOR THE NAME." +8650 PRINT "OF PLAYERS. TO DO THIS TYPE 'YOU' AS THE" +8660 PRINT " NAME OF THAT PLAYER." +8670 PRINT +8680 PRINT"THIS PROGRAM IS FAIRLY SELF-EXPLANATORY, HOWEVER THE FOLLOWING" +8690 PRINT "THINGS MUST BE KEPT IN MIND:" +8700 PRINT +8710 PRINT" 1. IF A QUESTION IS NOT UNDERSTOOD,TYPING 'WHAT' WILL" +8720 PRINT "USUALLY GIVE INSTRUCTIONS. HOWEVER SOME QUESTIONS WILL" +8730 PRINT "ASK FOR MORE THAN ONE THING AND THIS NUMBER OF THINGS MUST" +8740 PRINT "BE TYPED SEPERATED BY COMMAS. ALSO CARE MUST BE " +8750 PRINT "TAKEN THAT ALL INPUTS ARE EITHER NUMERIC OR ALPHABETIC" +8760 PRINT "AS ASKED FOR. EXAMPLE:" +8770 PRINT " LOT, # OF HOUSES? WHAT,0" +8780 PRINT "WILL GIVE INSTRUCTIONS." +8790 PRINT " 2. THE COMPUTER WILL OFTEN ASK IF YOU WANT CHANGES" +8800 PRINT "OR A SUMMARY. THE CHANGES ROUTINE WILL BE DESCRIBED" +8810 PRINT "BELOW, BUT IF YOU DON'T WANT TO BE BOTHERED WIL THE" +8820 PRINT "EVERYTIME, TYPE 'NEVER' TO HAVE IT STOP ASKING" +8830 PRINT "COMPLETELY, OR 'DELAY' TO HAVE IT ASK IN THREE" +8840 PRINT "TURNS. FOR SUMMARY TYPE 'AUTO' AND IT WILL " +8850 PRINT "GIVE A SUMMARY EVERY 5 TURNS, WITHOUT ASKING YOU AGAIN" +8860 PRINT" 3. TO SELL PROPERTIES OR ADD AND DROP PLAYERS USE THE " +8870 PRINT "CHANGES ROUTINE. TYPE 'YES' WHEN IT ASKS 'CHANGES?'" +8880 PRINT "TYPE 'YES' THEN TYPE 'WHAT,A,0' FOR COMPLETE INSTRUCTIONS" +8890 PRINT " 4. FIVE HOUSES ARE EQUIVALENT TO ONE HOTEL." +8900 PRINT " 5. IF YOU TYPE 'YOU' FOR ALL THE NAMES" +8910 PRINT "THE COMPUTER WILL PLAY ITSELF WITHOUT" +8920 PRINT "ASKING YOU FOR ANYTHING. TYPING CONTROL-O" +8930 PRINT "WILL MAKE THE GAME CONTINUE WITHOUT " +8940 PRINT "TYPE OUT, AND CONTROL-C THEN CONT WILL START THE" +8950 PRINT " TYPE OUT AGAIN WITH THE GAME VERY FAR ALONG." +8960 PRINT " 6. TO SELL HOUSES, WAIT UNTIL THE COMPUTER ASKS" +8970 PRINT "UNMORTGAGE WHAT? AND TYPE 'HOUSES' THEN ANSWER" +8980 PRINT "ANSWER FURTHAR QUESTIONS." +8990 RETURN +9000 PRINT +9010 IF N7=1 THEN 9200 +9020 IF A(B)=0 THEN 9100 +9030 FOR I2= 1 TO N +9040 IF Q(I2)=1 THEN 9060 +9050 IF A(I2)=0 THEN 9080 +9060 NEXT I2 +9070 GOTO 9200 +9080 PRINT "I AM $";ABS(T(B));"IN THE RED. SHOULD I QUIT"; +9090 GOTO 9110 +9100 PRINT "YOU ARE $";ABS(T(B));"IN THE HOLE. WILL YOU QUIT"; +9110 INPUT Z$ +9120 IFLEFT$(Z$,1)="Y"THEN9240 +9130 IFLEFT$(Z$,1)="N"THEN9190 +9140 IFLEFT$(Z$,1)="L"THEN9200 +9150 PRINT "TYPE 'YES' TO QUIT OR 'NO' TO KEEP GOING" +9160 PRINT "AND PAYING 5% INTEREST ON THE NEGATIVE AMMOUNT" +9170 PRINT "OR 'LATER' TO NOT QUIT NOW BUT KEEP THE COMPUTER ASKING" +9180 GOTO 9110 +9190 N7=1 +9200 I1=INT(ABS(.05*T(B)+ .5)) +9210 PRINT "5% INTEREST IS $";I1 +9220 T(B)= T(B) - I1 +9230 RETURN +9240 Q(B)=1 +9250 T(B)=0 +9260 FOR I2=1 TO 40 +9270 IF V(I2)<>B THEN 9330 +9280 V(I2)=0 +9290 M(I2)=0 +9300 B(I2)=0 +9310 R(I2)=L(I2) +9320 O(I2)=0 +9330 NEXT I2 +9340 N$(B)=" " +9350 RETURN +9360 GOTO 6360 +9370 PRINT "TYPE PROPERTY NAME THEN NUMBER OF HOUSES OR" +9380 PRINT "'NO,0' TO DO NOTHING" +9390 GOTO 5100 +9400 PRINT "TYPE A PROPERTY NAME OR 'NOTHING' "; +9410 GOTO 5910 +9420 PRINT " THIS ROUTINE CAN DO SEVERAL THINGS:" +9430 PRINT " 1. TO SELL PROPERTY FROM ONE PERSON TO ANOTHER" +9440 PRINT "TYPE THE PROPERTY NAME,THE NEW OWNER'S NAME, THEN" +9450 PRINT "THE AMOUNT IT IS BEING SOLD FOR." +9460 PRINT " 2. TO SELL A JAILCARD, TYPE 'JAILCARD',THE NEW OWNERS" +9470 PRINT "NAME, THEN THE AMOUNT IT IS BEING SOLD FOR." +9480 PRINT "IF NEEDED THE COMPUTER WILL ASK WHO IT CAME FROM." +9490 PRINT " 3. FOR EITHER OF THE ABOVE,'YOU' CAN BE USED AS THE" +9500 PRINT "NEW OWNER'S NAME,OR THE COMPUTERS PROPERTY CAN BE USES" +9510 PRINT "THE COMPUTER WILL THEN DECIDE IF IT WILL ACCEPT YOUR OFFER," +9520 PRINT "AND TELL YOU IF IT WILL BUY OR SELL." +9530 PRINT " 4. TO ADD A NEW PLAYER TYPE:'NEW PLAYER',HIS NAME,'0'" +9540 PRINT " 5. TO DROP A PLAYER TYPE:'QUIT',HIS NAME,'0'" +9550 PRINT +9560 GOTO 7210 +9570 B=E9 +9580 REMARK THIS IS FOR QUITING FORM CHANGE ROUTINE +9590 GOSUB 9240 +9600 GOTO 6960 +9610 REM THIS IS FOR CHANGING JAILCARDS +9620 IF N<>2 THEN 9650 +9630 T0=3-E9 +9640 GOTO 9880 +9650 PRINT "WHO FROM"; +9660 INPUT Z$ +9670 IF Z$<>"WHAT" THEN 9710 +9680 PRINT"TYPE THE PERSON'S NAME FROM WHOM THE CARD" +9690 PRINT" CAME.";N$(E9);" HAD IT. WHO HAS IT NOW"; +9700 GOTO 9660 +9710 IF Z$<>"YOU" THEN 9830 +9720 IF W8=1 THEN 9820 +9730 PRINT "WHICH #"; +9740 PRINT "('0' FOR INST.)"; +9750 INPUT O3 +9760 IF O3>0 THEN 9790 +9770 PRINT "I AM PLAYING SEVERAL PLAYERS. TYPE NO. OF ONE YOU WANT"; +9780 GOTO 9750 +9790 IF O3>N THEN 9770 +9800 T0=O3 +9810 GOTO 9880 +9820 Z$="COMPUTER" +9830 FOR T0= 1 TO 40 +9840 IF N$(T0)= Z$ THEN 9880 +9850 NEXT T0 +9860 PRINT "WHO "; +9870 GOTO 9660 +9880 IF A(T0)=0 THEN 9960 +9890 IF A>45 THEN 9920 +9900 IF A<30 THEN 9940 +9910 GOTO 9940 +9920 PRINT" OK" +9930 GOTO 10070 +9940 PRINT" NO" +9950 RETURN +9960 IF A(E9)=0 THEN 10010 +9970 IF A>50 THEN 9940 +9980 IF F(E9)=1 THEN 9940 +9990 IF T(E9)<200 THEN 9940 +10000 GOTO9920 +10010 IF F(T0)=1 THEN 9940 +10020 IF A(T0)=0 THEN 10050 +10030 IF A> 45 THEN 9940 +10040 GOTO 10060 +10050 PRINT "HE DOESN'T HAVE ONE" +10060 RETURN +10070 F(T0)= F(T0)-1 +10080 F(E9)=F(E9)+1 +10090 T(T0)=T(T0)+A +10100 T(E9)=T(E9)-A +10110 RETURN +10120 REM THIS ALLOWS A NEW PLAYER +10130 IF A$="YOU" THEN 10210 +10140 FOR O9= 1 TO N +10150 IF N$(O9)=A$ THEN 10180 +10160 NEXT O9 +10170 GOTO 10210 +10180 PRINT "INPUT A NAME NOT ALREADY USED"; +10190 INPUT A$ +10200 GOTO 10140 +10210 FORO9= 1 TO N +10220 IF Q(O9)=1 THEN 10370 +10230 NEXT O9 +10240 IF N<10 THEN 10270 +10250 PRINT "TOO MANY PLAYERS. SOMEONE WILL HAVE TO QUIT." +10260 GOTO 6960 +10270 N=N+1 +10280 Q(N)=0 +10290 T(N)=1500 +10300 IF A$<>"YOU"THEN 10350 +10310 N$(N)="COMPUTER" +10320 W7=W7+1 +10330 A(N)=1 +10340 GOTO 6960 +10350 N$(N)=A$ +10360 GOTO 6960 +10370 REM THIS IS FOR NEW PLAYER +10380 N$(O9)= A$ +10390 Q(O9)=0 +10400 P(O9)=0 +10410 T(O9)=1500 +10420 IF N$(9)<>"YOU" THEN 10460 +10430 N$(O9)="COMPUTER" +10440 W7=W7+1 +10450 A(O9)=1 +10460 GOTO 6960 +10470 END +O9)=1500 +10420 IF N$(9)<>"YOU" THEN 10460 +10430 N$(O9)="COM \ No newline at end of file diff --git a/software/BAS/MONSTER.BAS b/software/BAS/MONSTER.BAS new file mode 100644 index 0000000..afb1624 --- /dev/null +++ b/software/BAS/MONSTER.BAS @@ -0,0 +1,149 @@ +10 ' **** MONSTER COMBAT **** +20 ' Written by Lee Chapel 6/15/80 ( BYTE DEC.,1980 Pp.288-290 ) +30 ' Entered, Converted to Mbasic and Enhanced By Steven C. Rich +40 ' (313)358-3494 +50 ' +60 ' NOTE: The Graphics used are for use on a Heath H-19 terminal. I +70 ' have broken out the commands so that they can you can convert +80 ' this program for other terminals. I suggest strongly that anyone +90 ' using graphics in their programs do the same. +100 ' +110 RANDOMIZE:' REMOVE OR CHANGE IF USING MBASIC VERSION BEFORE 5.0 +120 ' ********************* H-19 TERMINAL COMMANDS ************************* +130 E$=CHR$(27):' ESCAPE CHARACTER (Used for alaphics in their programs do the same. +100 ' +110 RANDOMIZE:' REMOVE OR CHANGE IF USING MBASIC VERSION BEFORE 5.0 +120 ' ********************* H-19 TERMINAL COMMANDS ************************* +130 E$=CHR$(27):' ESCAPE CHARACTER (Used for alHOME +190 EP$=E$+"J":' ERASE TO END OF PAGE +200 'NOTE: The H-19 uses the following scheme for direct cursor addressing: +210 ' Location= (CHR$(Line number+31));(CHR$(Column number+31)) +220 ' ********************************************************************** +230 PRINT CLS$;"NOTE:The instructions for this game are in MONSTER.DOC." +240 FOR I=1 TO 2000:NEXT I +250 DIM A(10,10):PRINT CLS$;:PRINT TAB(20);"MONSTER COMBAT" +260 '************************************************************** +270 ' NOTE: THE FOLLOWING DEFINE GRAPHICS CHARACTERS OF THE H-19. +280 ' CHANGE THEM FOR YOUR TERMINAL +290 ' CH$(0) & CH$(1)= Grass CH$(2)= Tree CH$(5)= You +300 CH$(0)="ii":CH$(1)="ii":CH$(2)="r_":CH$(5)="}|" +310 '************************************************************** +320 FOR I=1 TO 9:FOR J=1 TO 9:A(I,J)=1:IF RND(1)>.75 THEN A(I,J)=2 +330 NEXT J,I +340 X=INT(RND(1)*6+2):Y=INT(RND(1)*6+2) +350 A(X,Y)=5:C=INT(RND(1)*1501+500) +360 GOSUB 1270 +370 PRINT "YOUR COMBAT STRENGTH IS ";C:GOSUB 620:IF I>11 THEN 370 +380 IF M=0 THEN PRINT "YOU GET THE TREASURE FREE":GOTO 860 +390 IF M=100 AND N=1 THEN 1260 +400 PRINT "DO YOU WANT TO (F)IGHT, (R)UN, OR (B)RIBE ? " +410 Z9$=INPUT$(1):IF Z9$<>"F"AND Z9$<>"R" AND Z9$<>"B" GOTO 410 +420 IF Z9$="F" GOTO 430 ELSE IF Z9$="R" GOTO 530 ELSE IF Z9$="B" GOTO 1000 ELSE GOTO 400 +430 INPUT"HOW MANY COMBAT POINTS DO YOU WISH TO USE";K +440 IF K>C THEN GOSUB 990:PRINT C;"COMBAT POINTS":GOTO 430 +450 I=INT(RND(1)*1001):L=2:C=C-K:K=K-.01*Q +460 FOR H=1000 TO 0 STEP-50:IF L*M<=K AND H>=I THEN 840 +470 L=L-.1:NEXT +480 PRINT "THE MONSTER KILLED YOU."; +490 PRINT "YOU LOSE EVERYTHING":PRINT "DO YOU WISH TO TRY AGAIN"; +500 'If using MBASIC Version before 5.0 remove 'RANDOMIZE' in following line +510 Z$=INPUT$(1):IF Z$="Y" THEN RANDOMIZE C:C=0:Q=0:GOTO 270 +520 PRINT :PRINT "SO LONG. BETTER LUCK NEXT TIME":END +530 I=INT(RND(1)*12):IF I=11 THEN 480 +540 FOR H=0 TO 10:IF H*10>M AND H<=I THEN 560 +550 NEXT:GOTO 1070 +560 A=X:B=Y +570 X=INT(RND(1)*3-1)+A: Y=INT(RND(1)*3-1)+B +580 IF A(X,Y)>1 THEN 570 +590 IF A(X,Y)=0 THEN 1320 +600 A(A,B)=1:A(X,Y)=5:IF I<>12 THEN 360 +610 RETURN +620 I=INT(RND(1)*18+1):M=I*10:IF I<11 THEN PRINT "A "; +630 ON I GOTO 640,650,660,670,680,690,700,710,720,730,740,1130,1080,1300,1340,1340,1340,1340 +640 PRINT "MINOTAUR";:GOTO 750 +650 PRINT "CYCLOPS";:GOTO 750 +660 PRINT "ZOMBIE";:GOTO 750 +670 PRINT "GIANT";:GOTO 750 +680 PRINT "HARPY";:GOTO 750 +690 PRINT "GRIFFIN";:GOTO 750 +700 PRINT "CHIMERA";:GOTO 750 +710 PRINT "DRAGON";:GOTO 750 +720 PRINT "WYVERN";:GOTO 750 +730 PRINT "BASLISK";:GOTO 750 +740 PRINT "NOTHING";:M=0 +750 PRINT " IS GUARDING ";:I=INT(RND(1)*7+1) +760 ON I GOTO 770,780,790,800,810,820,830 +770 PRINT "10 SILVER SPOONS":P=10:RETURN +780 PRINT "A JEWELED SWORD":P=30:RETURN +790 PRINT "A JAR OF RUBIES":P=50:RETURN +800 PRINT "A TREASURE CHEST":P=200:RETURN +810 PRINT "50 SILVER COINS":P=50:RETURN +820 PRINT "100 GOLD PIECES":P=100:RETURN +830 PRINT "A BOX OF JEWELS":P=75:RETURN +840 PRINT "YOU BEAT THE MONSTER" +850 S=S+1 +860 Q=Q+P +870 IF P=30 THEN GOSUB 1170 +880 IF P=200 THEN GOSUB 1200:GOSUB 1230 +890 PRINT "YOU HAVE ";Q;" TREASURE POINTS" +900 X$="":A=X:B=Y:INPUT"WHAT DIRECTION (HIT 1 TO RESET DISPLAY)";X$:IF X$=""GOTO 900 +910 IF X$="1" THEN PRINT CLS$;TAB(20);"MONSTER COMBAT":GOSUB 1270:GOTO 900 +920 IF RIGHT$(X$,1)="W" THEN X=X-1 +930 IF RIGHT$(X$,1)="E" THEN X=X+1 +940 IF LEFT$(X$,1) ="N" THEN Y=Y-1 +950 IF LEFT$(X$,1) ="S" THEN Y=Y+1 +960 IF A(X,Y)=0 THEN 1320 +970 IF A(X,Y)=2 THEN PRINT CHR$(7);"YOU RAN INTO A TREE":X=A:Y=B:GOTO 900 +980 A(A,B)=1:A(X,Y)=5:GOTO 360 +990 PRINT "YOU ONLY HAVE";:RETURN +1000 INPUT"HOW MUCH DO YOU WISH TO PAY";K +1010 IF K>Q THEN GOSUB 990:PRINT Q;" TREASURE POINTS":GOTO 1000 +1020 I=INT(RND(1)*22):L=0:IF I=21 OR K<1 THEN 480 +1030 FOR H=0 TO 20:IF K<=L*P AND I>=H THEN 1060 +1040 L=L+.1:NEXT +1050 PRINT "YOUR BRIBE WAS ACCEPTED.";:Q=Q-K:GOTO 890 +1060 PRINT "YOUR BRIBE WAS NOT ACCEPTED."; +1070 PRINT "YOU MUST FIGHT":GOTO 430 +1080 PRINT CHR$(7);"THE GUARDIAN OF THE FOREST CAPTURED YOU, TOOK HALF YOUR" +1090 PRINT "TREASURE, AND TOOK YOU TO A NEW SPOT IN THE FOREST" +1100 Q=Q/2:A=X:B=Y:FOR I9=1 TO 4000:NEXT +1110 X=INT(RND(1)*7+2):Y=INT(RND(1)*7+2):IF A(X,Y)<>1 THEN 1110 +1120 A(A,B)=1:A(X,Y)=5:GOSUB 1270:I=13:RETURN +1130 J=INT(RND(1)*20+1):C=C-J +1140 PRINT "YOU FELL INTO A PIT AND USED ";J;" COMBAT POINTS TO CLIMB OUT" +1150 IF C<0 THEN PRINT "YOU DIED WHILE CLIMBING OUT":GOTO 490 +1160 GOTO 560 +1170 IF RND(1)<.5 OR C>3000 THEN RETURN +1180 PRINT "THE SWORD WAS ENCHANTED AND DOUBLES YOUR STRENGTH" +1190 C=C*2:RETURN +1200 I=INT(RND(1)*10):IF I<>7 THEN RETURN +1210 PRINT "THE CHEST WAS A TRAP. YOU WERE KILLED WHEN YOU OPENED IT." +1220 GOTO 490 +1230 I=INT(RND(1)*10):IF I<>3 THEN RETURN +1240 PRINT "A MIRROR WAS IN THE CHEST."; +1250 PRINT " IT WILL KILL ANY BASILISKS YOU MEET":N=1:RETURN +1260 PRINT "YOUR MIRROR KILLED THE BASILISK":GOTO 850 +1270 PRINT GY$:GOSUB 1390:PRINT HO$:FOR I=0 TO 10:PRINT TAB(15);:FOR J=0 TO 10 +1280 PRINT CH$(A(J,I)); +1290 NEXT J:PRINT:NEXT I:PRINT EP$;GN$:RETURN +1300 IF S<5 THEN 620 +1310 PRINT "A GIANT EAGLE CARRIED YOU TO SAFETY" +1320 PRINT :PRINT "YOU SURVIVED THE FOREST" +1330 PRINT "YOU WON A TREASURE TOTAL OF ";Q:PRINT "CONGRADULATIONS" + :PRINT "DO YOU WISH TO TRY AGAIN ? ";:GOTO 510 +1340 PRINT "THERE IS NOTHING TO BE FOUND HERE":GOTO 890 +1350 END +1360 '*********************************************************** +1370 ' THIS ROUTINE PRINTS BRIEF INSTRUCTIONS AND A COMPASS ROSE ON THE SCREEN. +1380 ' IT CAN BE REMOVED IF CONVERSION IS DIFFICULT, BUT LEAVE 'RETURN' IN. +1390 PRINT DC$;"!H";CH$(5);" = YOUR POSITION" +1400 PRINT DC$;"#H";CH$(2);" = TREE (YOU MUST GO AROUND THEM)" +1410 PRINT DC$;"%H";CH$(0);" = FIELD" +1420 PRINT DC$;"'U";"NW N NE" +1430 PRINT DC$;"(W";"y`x" +1440 PRINT DC$;")U";"W a^a E" +1450 PRINT DC$;"*W";"x`y" +1460 PRINT DC$;"+U";"SW S SE" +1470 RETURN +30 PRINT DC$;"(W";"y`x" +1440 PRINT DC$;")U";"W a^a \ No newline at end of file diff --git a/software/BAS/ROSE.BAS b/software/BAS/ROSE.BAS new file mode 100644 index 0000000..62febaa --- /dev/null +++ b/software/BAS/ROSE.BAS @@ -0,0 +1,122 @@ +1 REM CLEAR SCREEN & VERT TAB 10 +10 PRINT TAB( 6)"** PETALS AROUND THE ROSE **" +20 FOR ZZ = 1 TO 3000: NEXT +30 PRINT : PRINT : PRINT +40 PRINT "DO YOU WISH INSTRUCTIONS "; +50 INPUT A$ +60 IF LEFT$ (A$,1) = "N" THEN 140 +70 PRINT +80 PRINT "THE NAME OF THE GAME IS 'PETALS AROUND" +90 PRINT "THE ROSE. THE NAME OF THE GAME IS" +95 PRINT "IMPORTANT. " +100 PRINT : PRINT "THE COMPUTER WILL ROLL FIVE DICE" +105 PRINT "AND ASK YOU FOR THE SCORE FOR THE" +110 PRINT "ROLL. THE SCORE WILL ALWAYS BE AN" +115 PRINT "EVEN NUMBER. GUESS 99 TO STOP PLAYING" +120 PRINT : PRINT " ** GOOD LUCK **" +125 PRINT : PRINT : PRINT : PRINT : INPUT "HIT RETURN TO CONTINUE";X$ +140 DIM L(7) +150 H = 0:G = 0:F = 0 +155 REM CLEAR SCREEN & VERT TAB 10 +180 FOR K = 1 TO 5 +190 A = INT (12 * RND (8)) +200 GOSUB 720 +210 F = 8 * F + C +220 G = 8 * G + D +230 H = H + B +240 NEXT K +250 PRINT : PRINT +270 FOR K = 1 TO 5 +280 L(K) = F - 8 * INT (F / 8) +290 M = L(K) +300 GOSUB 590 +310 F = INT (F / 8) +320 NEXT K +330 FOR K = 1 TO 5 +340 M = G - 8 * INT (G / 8) +350 GOSUB 590 +360 G = INT (G / 8) +370 NEXT K +380 H = H - 12 * INT (H / 12) +390 FOR K = 1 TO 5 +400 IF (L(K) - 1) * (L(K) - 4) < > 0 THEN 420 +410 L(K) = 5 - L(K) +420 M = L(K) +430 GOSUB 590 +440 NEXT K +450 PRINT : PRINT +470 PRINT "GUESS THE SCORE"; +480 INPUT K +490 IF K = 99 THEN 1110 +500 H = 2 * INT (H) +510 IF K = H THEN 570 +515 PRINT +520 PRINT " NO,IT'S ";H; +530 IF K - 2 * INT (K / 2) = 0 THEN 550 +540 PRINT " (THE SCORE IS ALWAYS EVEN) "; +545 FOR ZZ = 1 TO 2000: NEXT +550 PRINT +555 FOR ZZ = 1 TO 2000: NEXT +560 GOTO 150 +570 PRINT : PRINT : PRINT TAB( 16)"...YES..." +575 FOR ZZ = 1 TO 2000: NEXT +580 GOTO 150 +590 FOR N = 0 TO 2 +600 IF M > 3 THEN 630 +610 PRINT" "; +620 GOTO 650 +630 M = M - 4 * INT (M / 4) +640 PRINT " O"; +650 M = 2 * M +660 NEXT N +670 IF K = 5 THEN 700 +680 PRINT" "; +690 RETURN +700 PRINT +710 RETURN +720 B = 6 + RND (7) / 6 +730 C = 0 +740 D = 0 +750 IF A > 3 THEN 890 +760 B = B + 3 +770 IF A > 1 THEN 810 +780 D = D + 2 +790 B = B + 3 +800 RETURN +810 C = C + 1 +820 B = B + 1 +830 IF A > 2 THEN 780 +840 B = B + 11 +850 GOTO 790 +860 C = C + 1 +870 IF A > 2 THEN 790 +880 GOTO 780 +890 C = C + 4 +900 B = B + 2 +910 IF A > 5 THEN 970 +920 B = B + 2 +930 IF A < 5 THEN 950 +940 GOTO 780 +950 B = B + 11 +960 GOTO 790 +970 C = C + 1 +980 B = B + 8 +990 IF A > 6 THEN 1030 +1000 D = D + 3 +1010 B = B + 5 +1020 GOTO 780 +1030 IF A > 7 THEN 1070 +1040 B = B + 5 +1050 C = C + 1 +1060 GOTO 860 +1070 B = B + 7 +1080 IF A < 10 THEN 780 +1090 B = B + 10 +1100 GOTO 790 +1110 PRINT " THE SCORE WAS ";2 * INT (H) +O 860 +1070 B = B + 7 +1080 IF A < 10 THEN 780 +1090 B = B + 10 +1100 GOTO 790 +11 \ No newline at end of file diff --git a/software/BAS/SQUARE.bas b/software/BAS/SQUARE.bas new file mode 100644 index 0000000..5b29680 --- /dev/null +++ b/software/BAS/SQUARE.bas @@ -0,0 +1,200 @@ +100 REM ** SQUARE ** +110 REM +120 REM WRITTEN BY MAC OGLESBY +130 REM AS DESCRIBED IN VOL. 1, ISSUE 3 +140 REM OF CALCULATORS-COMPUTERS MAGAZINE +150 REM +160 CS$=CHR$(126)+CHR$(28) 'CURSOR CONTROL CODES TO CLEAR SCREEN +170 DEFINT A-Z +180 PRINTCS$;"ENTER PASSWORD";:INPUTA$:Z=0 +190 A=0:FORI=1TOLEN(A$):A=A+ASC(MID$(A$,I,1)):NEXT:A=RND(-A) +200 DIM Q(50),S$(50),S(24,12),U(12),V(50) +210 P$(1)="X":P$(2)="O":F=1 +220 FOR R0=0 TO 4:FOR C0=0 TO 4:D$(R0,C0)=".":NEXTC0:NEXTR0 +230 INPUT"WANT INSTRUCTIONS FOR 'SQUARE'";A$ +240 IFLEFT$(A$,1)="N"THEN400 +250 PRINTCS$; 'CLEAR SCREEN +260 PRINT" THE GAME OF SQUARE IS FOR 1 OR 2 PLAYERS. THE NORMAL" +270 PRINT"BOARD LOOKS LIKE THIS AT THE START:":GOSUB2000 +280 PRINT" THE PLAYERS GO IN TURN AND CHOOSE ANY UNOCCUPIED POINT" +290 PRINT"(SHOWN AS A DOT). EACH PLAYER HAS 12 MARKERS (X'S OR O'S)" +300 PRINT"WHICH ARE USED TO IDENTIFY CHOSEN POINTS.":PRINT +310 INPUT" ENTER 'C' TO CONTINUE";A$:PRINT +320 PRINT" THE WINNER IS THE FIRST PLAYER WHO HAS CHOSEN 4 POINTS" +330 PRINT"WHICH FORM THE CORNERS OF A SQUARE." +340 PRINT" TO CHOOSE A POINT, TYPE 2 DIGITS (0 TO 4) SEPARATED BY A" +350 PRINT"COMMA. THE FIRST DIGIT TELLS THE DISTANCE OVER (TO T"; +360 PRINT"HE RIGHT)":PRINT"FROM POINT 0,0 (THE ORIGIN). THE SECOND"; +370 PRINT" DIGIT TELLS THE DISTANCE UP.":PRINT +380 PRINT"REMEMBER: OVER,UP.":PRINT +390 INPUT" ENTER 'C' TO CONTINUE";A$:PRINT +400 PRINT:INPUT"DO YOU WANT TO PLAY THE EXPERTS' GAME";A$ +410 B0=1:IFLEFT$(A$,1)="Y"THENB0=2 +420 IFB0=1THEN440 +430 D$(2,2)=" ":N=38:GOTO450 +440 N=50 +450 IFZ=1THENGOTO490ELSEPRINT:INPUT"HOW MANY PLAYERS (1 OR 2)";P0 +460 IFP0=2THEN510 +470 IF P0=1THEN480ELSEPRINT"PLEASE ENTER 1 OR 2":GOTO450 +480 PRINTCS$;"OK, I WILL PLAY THE X'S":PRINT +490 INPUT"DO YOU WANT TO GO FIRST";A$:F=1 +500 IFLEFT$(A$,1)="Y"THENF=2 +510 PRINTCS$;"OK...HERE WE GO..." +520 IFZ=1THEN940 +530 RESTORE:FORJ=0TO24:READS(J,0):NEXT +540 DATA 4,7,8,7,4,7,10,11,10,7,8,11,12,11,8,7,10,11,10,7,4,7,8,7,4 +550 FORJ=0TO24:FORK=1TOS(J,0):READS(J,K):NEXTK:NEXTJ +560 DATA 1,13,35,43 +570 DATA 1,2,15,20,28,31,36 +580 DATA 2,3,21,24,29,43,44,47 +590 DATA 3,4,16,25,30,31,35 +600 DATA 4,13,36,44 +610 DATA 1,5,15,24,30,32,37 +620 DATA 1,2,5,14,22,25,38,39,47,48 +630 DATA 2,3,15,16,17,23,26,32,33,39,40 +640 DATA 3,4,6,14,20,27,37,40,47,49 +650 DATA 4,6,16,21,28,33,38 +660 DATA 5,7,20,26,29,43,45,48 +670 DATA 5,7,15,17,18,21,27,31,34,39,41 +680 DATA 39,40,41,42,43,44,45,46,47,48,49,50 +690 DATA 6,8,16,17,19,22,24,31,34,40,42 +700 DATA 6,8,23,25,29,44,46,49 +710 DATA 7,9,18,22,28,32,35 +720 DATA 7,9,10,14,23,24,36,41,48,50 +730 DATA 10,11,17,18,19,20,25,32,33,41,42 +740 DATA 8,11,12,14,21,26,35,42,49,50 +750 DATA 8,12,19,27,30,33,36 +760 DATA 9,13,37,45 +770 DATA 9,10,18,26,30,34,38 +780 DATA 10,11,22,27,29,45,46,50 +790 DATA 11,12,19,23,28,34,37 +800 DATA 12,13,38,46 +810 FORJ=1TON:READS$(J):NEXT +820 DATA 00011110,01021211,02031312,03041413,10112120 +830 DATA 13142423,20213130,23243433,30314140,31324241 +840 DATA 32334342,33344443,00044440,11133331 +850 DATA 01122110,03142312,12233221,21324130,23344332 +860 DATA 01133220,02143321,11234230,12244331 +870 DATA 02233110,03243211,12334120,13344221 +880 DATA 01144330,02244220,03344110 +890 DATA 01032321,10123230,12143432,21234341 +900 DATA 00033330,01043431,10134340,11144441 +910 DATA 11122221,12132322,21223231,22233332 +920 DATA 00022220,02042422,20224240,22244442 +930 DATA 02132211,11223120,13243322,22334231 +940 IFA(1)<>89THEN960 +950 IFB0=2THEN960ELSEPRINT:GOTO970 +960 GOSUB2000 +970 T=T+1 +980 REM ** MAIN MOVE LOOP: J=121212... OR J=212121... +990 FORJ=FTO3-FSTEP3-2*F +1000 IFP0=2THEN1730 +1010 IFJ=2THEN1730 +1020 REM ** GENERATE COMPUTER'S MOVE +1030 IFT<>1THEN1100 +1040 IFD$(2,2)<>"."THEN1060 +1050 R1=2:C1=2:GOTO1710 +1060 IFF=1THEN1080 +1070 Q0=9:GOTO1130 +1080 R1=1+INT(RND(1)*3):C1=1+INT(RND(1)*3) +1090 IFD$(R1,C1)<>"."THENGOTO1080ELSEGOTO1710 +1100 IFT<>2THEN1380 +1110 IFF=1THEN1130 +1120 Q0=19 +1130 K9=0 +1140 FORJ1=1TON:IFQ(J1)<>1+Q0THEN1160 +1150 K9=K9+1:U(K9)=J1 +1160 NEXTJ1 +1170 IFK9=0THEN1370 +1180 FORJ2=K9TO1STEP-1:T9=1+INT(RND(1)*J2):J1=U(T9) +1190 FORK1=1TO8STEP2:R1=VAL(MID$(S$(J1),K1,1)) +1200 C1=VAL(MID$(S$(J1),K1+1,1)) +1210 IFD$(R1,C1)<>"."THEN1320 +1220 IFQ0+T<3THEN1240 +1230 GOTO1710 +1240 S0=5*R1+C1:M0=0:FORJ3=1TOS(S0,0) +1250 IFB0=1THEN1280 +1260 IFS(S0,J3)<=38THEN1280 +1270 GOTO1310 +1280 IFQ(S(S0,J3))>1THEN1300 +1290 M0=M0+1 +1300 NEXTJ3 +1310 IFM0<8-B0THENGOTO1320ELSEGOTO1710 +1320 NEXTK1 +1330 IFJ2=T9THEN1350 +1340 T8=U(J2):U(J2)=U(T9):U(T9)=T8 +1350 NEXTJ2 +1360 REM *** AS A LAST RESORT, PICK ANY VACANT POINT +1370 R1=RND(1)*5:C1=RND(1)*5:IFD$(R1,C1)<>"."THENGOTO1370ELSEGOTO1710 +1380 IFT=3THEN1430 +1390 REM ** SEE IF 'X' CAN COMPLETE A SQUARE +1400 FORJ1=1TON:IFQ(J1)<>3THENGOTO1410ELSEGOTO1190 +1410 NEXTJ1 +1420 REM ** SEE IF 'O' CAN COMPLETE A SQUARE +1430 FORJ1=1TON:IFQ(J1)<>30THENGOTO1440ELSEGOTO1190 +1440 NEXTJ1 +1450 REM ** CAN 'X' CHOOSE A 3RD CORNER? +1460 K9=0:FORJ1=1TON:IFQ(J1)<>2THEN1480 +1470 K9=K9+1:U(K9)=J1 +1480 NEXTJ1 +1490 IFK9=0THEN1700 +1500 FORI0=1TO2:FORJ0=K9TO1STEP-1:M9=1+INT(RND(1)*J0):J1=U(M9):T9=0 +1510 FORK1=1TO8STEP2:R1=VAL(MID$(S$(J1),K1,1)) +1520 C1=VAL(MID$(S$(J1),K1+1,1)):IFD$(R1,C1)<>"."THEN1540 +1530 T9=T9+1:R(T9)=R1:C(T9)=C1 +1540 NEXTK1 +1550 FORJ2=1TO2:FORJ3=1TO50:V(J3)=Q(J3):NEXTJ3:S0=5*R(J2)+C(J2) +1560 FORJ3=1TOS(S0,0):V(S(S0,J3))=V(S(S0,J3))+1:NEXTJ3 +1570 S0=5*R(3-J2)+C(3-J2) +1580 FORJ3=1TOS(S0,0):V(S(S0,J3))=V(S(S0,J3))+10:NEXTJ3 +1590 FORJ3=1TON:IFV(J3)<>4-I0THEN1610 +1600 R1=R(J2):C1=C(J2):GOTO1710 +1610 NEXTJ3 +1620 NEXTJ2 +1630 IFJ0=M9THEN1650 +1640 T8=U(J0):U(J0)=U(M9):U(M9)=T8 +1650 NEXTJ0 +1660 NEXTI0 +1670 REM ** NO GOOD MOVE AVAILABLE...PICK ANY 3RD CORNER +1680 J1=U(1+INT(RND(1)*K9)):GOTO1190 +1690 REM ** SEE IF WE CAN ANNOY THE HUMAN +1700 Q0=I9:GOTO1130 +1710 PRINT"THE ";P$(J);"'S MOVE TO ";STR$(C1);",";STR$(R1):GOTO1780 +1720 REM ** GET PLAYER'S CHOICE +1730 IFT>1THEN1750 +1740 PRINT"THE ";P$(J);"'S MOVE TO WHICH POINT";:GOTO1760 +1750 PRINTP$(J);"'S CHOICE"; +1760 INPUTC1,R1 +1770 IFD$(R1,C1)<>"."THEN1850 +1780 D$(R1,C1)=P$(J) +1790 REM ** Q() TELLS WHO OWNS CORNERS OF WHICH SQUARES +1800 S0=5*R1+C1:FORJ1=1TOS(S0,0):Q(S(S0,J1))=Q(S(S0,J1))+1+(J-1)*9 +1810 IFQ(S(S0,J1))<>4+(J-1)*36THEN1830 +1820 PRINT:PRINT"*** THE ";P$(J);"'S WIN!! ***":GOTO1910 +1830 NEXTJ1 +1840 GOTO1880 +1850 PRINT"** ILLEGAL POINT! **":GOTO1870 +1860 PRINT"YOU MUST TYPE 2 DIGITS (0 TO 4) SEPARATED BY A COMMA!" +1870 PRINT"** INPUT IGNORED! PLEASE TRY AGAIN...":GOTO1750 +1880 NEXTJ +1890 IFT<12THEN1970 +1900 PRINT:PRINT"THE GAME IS A DRAW; NEITHER PLAYER MADE A SQUARE!" +1910 FORK1=1TO8STEP2:R1=VAL(MID$(S$(S(S0,J1)),K1,1)) +1920 C1=VAL(MID$(S$(S(S0,J1)),K1+1,1)):D$(R1,C1)=CHR$(64):NEXT:GOSUB2000 +1930 INPUT"WANT TO PLAY AGAIN";A$:IFLEFT$(A$,1)<>"Y"THENEND +1940 Z=1:FORJ2=0TO4:FORJ3=0TO4:D$(J2,J3)=".":NEXTJ3:NEXTJ2 +1950 FORJ2=1TO50:Q(J2)=0:V(J2)=0:NEXTJ2:FORJ2=1TO12:U(J2)=0:NEXTJ2 +1960 T=0:K9=0:GOTO400 +1970 GOSUB2000 +1980 GOTO970 +1990 REM ** PRINT THE BOARD +2000 PRINT:FORR0=4TO0STEP-1:PRINTSTR$(R0);" "; +2010 FORC0=0TO4:PRINTD$(R0,C0);:IFC0=4THEN2030 +2020 PRINT" "; +2030 NEXTC0:PRINT:IFR0=0THEN2050 +2040 PRINT:PRINT +2050 NEXTR0:PRINT:PRINT" 0 1 2 3 4":PRINT:RETURN +2060 END + NEXTC0:PRINT:IFR0=0THEN2050 +2040 PRINT:PRINT +2050 NEXTR0:PRINT:PRINT" 0 1 2 3 4":PRINT \ No newline at end of file diff --git a/software/BAS/STAR.BAS b/software/BAS/STAR.BAS new file mode 100644 index 0000000..45044f4 --- /dev/null +++ b/software/BAS/STAR.BAS @@ -0,0 +1,1137 @@ +10 REM NAME- STAR TREK +20 REM +30 REM ORIGIN- BILL PETERSON, CAL TECH, 1971. REVISED MARCH 1972 BY DON +40 REM L. DAGLOW OF I.E.C. AND POMONA COLLEGE. +50 REM +60 REM VERSION-- 32-8, WITH 3 DIMENSIONS & MANY OTHER CHANGES. MAY 14, 1973. DON L. DAGLOW. +75 REM ASSISTANCE ALSO RENDERED BY J. OSSER, POMONA COLLEGE, +76 REM AND M. LIEBMANN, BEVERLY HILLS H.S. +80 REM +90 REM VERSION 32-9 MODIFIED TO RUN UNDER EITHER CBASIC OR EBASIC COMPILERS +92 REM WITH OTHER MODIFICATIONS AND ENHANCEMENTS +95 REM BY JAMES UNDERWOOD --- JUNE 22 1981 +96 REM (NOTE: CURRENTLY CONFIGURED FOR EBASIC) +97 REM (FOR CBASIC, INCREASE TAB NUMBERS IN LINE 3992 BY 1) +99 REM (CAN ALSO BE RUN UNDER 'BASCOM' IF: 1:MAKE ABOVE CHANGE,) +101 REM (2:REMOVE RANDOMIZE, 3:CHANGE ALL RND'S TO RND(1)) +105 REM +110 REM TABLE OF VARIABLES IS AT LINE 64000 +120 REM +122 DIM S1(4),S2(4) +125 PRINT "HOW MANY MISSIONS HAVE YOU COMMANDED"; +127 INPUT A$ +128 REM ABOVE INPUT NECCESSARY TO SEED RANDOMIZE +130 RANDOMIZE +132 FOR I=1 TO 6 +135 PRINT +137 NEXT I +140 DIM O$(23) +150 V$="32-9" +152 REM UTILITY FUNCTIONS +156 DEF FNO(A)=2.66*(ABS(45-(ABS(A)))+5)/100 +158 DEF FNZ(R,C)=ABS(SGN(-1+(SGN(ABS(R)-C)))) +160 REM REAR OR FORWARD WEAPONS DEFINITION +165 DEF FND(B)=INT(ABS(B/90)) +170 REM BUILDING BLOCK FOR PHASER & P.T. FUNCTIONS +172 DEF FNX(B)=3.1415926*ABS(90-ABS(B))/180 +175 DEF FNY(B,C)=SIN(FNX(B))*(C-FND(B))/C +180 REM PHOTON TORPEDO FUNCTION: 3D +190 DEF FNT(R,B,A)=FNZ((R-500),200)*(1-((R-500)*(R-500))/40000)*FNY(B,3)*FNO(A) +245 REM PHASER FUNCTION: 3D +250 DEF FNP(R,B,A)=FNZ(R,400)*(1-((R-200)*(R-200))/40000)*FNY(B,5)*FNO(A) +330 REM CHOOSE DESTINATION +335 R9=INT(RND*10)+1 +340 FOR I=1 TO 10 +350 READ L$ +355 IF I=R9 THEN 365 +360 NEXT I +362 GOTO 420 +365 D$=L$ +367 GOTO 360 +370 DATA BETA AURIGAE 5, GAMMA TRISKELLION 7 +380 DATA EPSILON CYGNI 2, ALPHA ARCTURUS 4 +390 DATA DELTA CANOPIS 12, OMICRON BETELGEUSE 27 +400 DATA SIGMA RIGEL 3, KAPPA SIRIUS 8 +410 DATA ALPHA CENTAURI 5,DELTA ALDEBARAN 9 +420 REM CHOOSE OUR SHIP +425 R9=INT(RND*24)+1 +430 FOR I=1 TO 24 +440 READ N$ +445 IF I=R9 THEN 455 +450 NEXT I +452 GOTO 520 +455 S$=N$ +457 GOTO 450 +460 DATA ENTERPRISE,VALIANT,HOOD,ENTERPRISE +470 DATA DEFIANT,ENTERPRISE,EXCALIBUR,EXETER +480 DATA LEXINGTON,YORKTOWN,REPUBLIC,CONSTITUTION +490 DATA FARRAGUT,KONGO,CONSTELLATION,INTREPID +500 DATA BAYERN,"CORAL SEA",GETTYSBURG,ENTERPRISE +510 DATA BASTOGNE,ENTERPRISE,CONCORD,COURAGE +520 REM CHOOSE ENEMY NATION +525 R9=INT(RND*10)+1 +530 FOR I=1 TO 10 +540 READ K7$ +545 IF R9=I THEN 555 +550 NEXT I +552 GOTO 590 +555 E1$=K7$ +557 GOTO 550 +560 DATA KLINGON,ROMULAN,THOLIAN +570 DATA KALANDAN,SCALOSIAN,KELVAN,TALOSIAN +580 DATA MELKOTIAN,ANDRAN,COLUSIAN +590 REM CHOOSE ENEMY SHIP +595 R9=INT(RND*14)+1 +600 FOR I=1 TO 14 +610 READ K8$ +615 IF R9=I THEN 625 +620 NEXT I +622 GOTO 660 +625 E2$=K8$ +627 GOTO 620 +630 DATA KRULIX,GRANAK,SLORK,QUARLO,TROBLAK +640 DATA PHILTOK,RHYLIX,BIESTAK,CORUDA,ZIKAL +650 DATA SAYADA,ZARU,FESARIUS,SKULZIA +660 REM CHOOSE ENEMY CAPTAIN +665 R9=INT(RND*19)+1 +670 FOR I=1 TO 19 +680 READ K9$ +685 IF R9=I THEN 695 +690 NEXT I +692 GOTO 730 +695 E3$=K9$ +697 GOTO 690 +700 DATA TRAKKA,KURDA,VARNOR,GRANOLT,SHLURG +710 DATA KORAX,KANG,KOLOTH,LOSIRA,SYBO +720 DATA CONNORS,EORR,BALOK,LOSKENE +725 DATA ROJAN,KELINDA,BERATTIS,REDJAC,KESLA +730 REM COMMAND RESPONSE VERBALIZATIONS +740 FOR I=1 TO 23 +750 READ O$(I) +760 NEXT I +770 DATA ENEMY RANGE AND BEARING +780 DATA FIRE FORWARD PHASERS,FIRE REAR PHASERS +790 DATA FIRE FORWARD PHOTON TORPEDOES,FIRE REAR PHOTON TORPEDOES +800 DATA LAUNCH ANTIMATTER PROBE,CLOSE ON ENEMY VESSEL +810 DATA MOVE AWAY FROM ENEMY,CLOSE AT WARP SPEED +820 DATA MOVE AWAY AT WARP SPEED +830 DATA "OPTIMUM SHIELD DEFENSE, MR. SULU" +840 DATA "180 DEGREES ABOUT, MR. SULU" +850 DATA "FIRING PROBABILITIES, MR. SPOCK" +860 DATA "A BRIEFING, MR. SPOCK","DAMAGE REPORT, MR. SPOCK" +870 DATA "OPEN A CHANNEL TO STAR FLEET, LIEUTENANT" +880 DATA "LET'S SEE WHAT THE ENEMY DOES NEXT" +890 DATA "ACTIVATE AUTO-DESTRUCT SEQUENCE" +900 DATA "OPEN A CHANNEL TO THE ENEMY VESSEL, LIEUTENANT" +910 DATA "MR. SPOCK, TAKE COMMAND. I'M GOING TO LEAD A BOARDING PARTY." +920 DATA "A WEAPONS BRIEFING, MR. SPOCK." +930 DATA "WEAPON POWER BANKS STATUS REPORT, MR. SPOCK." +940 DATA "PREPARE TO ALLOCATE SHIELD POWER TO WEAPONS BANKS." +1020 PRINT +1030 IF G9>0 THEN 1400 +1049 REM +1050 REM BEGINNING OF MAIN PROGRAM +1051 REM +1120 PRINT "SPACE, THE FINAL FRONTIER." +1130 PRINT "THIS IS A VOYAGE OF THE STARSHIP ";S$;"." +1140 PRINT "NOW ON ITS SECOND FIVE YEAR MISSION;" +1150 PRINT "ITS TASK: TO EXPLORE STRANGE NEW WORLDS," +1160 PRINT "TO SEEK OUT NEW LIFE AND NEW CIVILIZATIONS," +1170 PRINT "TO BOLDLY GO WHERE NO MAN HAS GONE BEFORE." +1180 PRINT +1190 PRINT +1200 PRINT TAB(20);"S T A R T R E K" +1210 PRINT TAB(20);"=================" +1220 PRINT +1222 V8=0 +1230 PRINT +1240 PRINT "YEOMAN: WOULD YOU PLEASE ENTER YOUR NAME FOR" +1250 PRINT " THE LOG, SIR"; +1260 INPUT C$ +1262 IF C$<>"" THEN 1270 +1265 C$="KIRK" +1270 C9$=C$ +1280 PRINT "SPOCK: YOU ARE IN COMMAND OF THE ";S$;", CAPTAIN ";C$;"." +1290 PRINT " DO YOU WISH A LIST OF THE POSSIBLE COMMANDS, SIR"; +1300 INPUT A$ +1305 IF A$="" THEN 1300 +1310 IF LEFT$(A$,1)<>"Y" THEN 1335 +1320 GOSUB 7760 +1330 GOSUB 8330 +1335 PRINT " THIS VESSEL IS NOW A VERSION ";V$;" STARSHIP;" +1340 PRINT " DO YOU WISH A BRIEFING ON RECENT ";S$;" MODIFICATIONS"; +1350 INPUT A$ +1355 IF A$="" THEN 1350 +1360 IF LEFT$(A$,1)<>"Y" THEN 1400 +1370 GOSUB 11000 +1400 Y=50*(RND-.5) +1405 PRINT +1410 REM TELL WHERE WE'RE GOING AND WHY +1420 PRINT C$;": CAPTAIN'S LOG, STAR DATE ";2047+(RND*47) +1430 PRINT " WE ARE PRESENTLY ON COURSE FOR ";D$ +1440 ON INT(RND*10)+1 GOTO 1450,1470,1490,1520,1550,9530,9560,9590,9610,9630 +1450 PRINT " TO INVESTIGATE REPORTS OF ";E1$;" SABOTAGE." +1460 GOTO 1570 +1470 PRINT " TO EVACUATE FEDERATION CITIZENS FROM THAT WAR-TORN PLANET." +1480 GOTO 1570 +1490 PRINT " TO ASSIST IN PUTTING DOWN A STRIKE BY DILITHIUM MINERS" +1500 PRINT " ON THAT PLANET." +1510 GOTO 1570 +1520 PRINT " WITH A TEAM OF ASTROGEOLOGISTS TO INVESTIGATE REPORTS OF" +1530 PRINT " VALUABLE MINERAL DEPOSITS ON THAT NEWLY COLONIZED PLANET." +1540 GOTO 1570 +1550 PRINT " FOR ASTROPHYSICAL RESEARCH ON THE NEBULA IN THAT QUADRANT." +1560 REM TELL WHO ENEMY IS +1570 IF RND>.5 THEN 1600 +1580 PRINT "SULU: SIR, I'M PICKING UP A VESSEL ON AN ATTACK VECTOR" +1585 PRINT " WITH THE ";S$;"." +1590 GOTO 1640 +1600 PRINT "SULU: SIR, I THINK WE'RE BEING FOLLOWED; THERE'S A SHIP" +1610 PRINT " ON THE SAME COURSE AS THE ";S$ +1640 PRINT "SPOCK: SHIP'S COMPUTERS INDICATE THAT IT IS THE "; +1650 PRINT E1$;" VESSEL " +1660 PRINT " ";E2$;" UNDER THE COMMAND OF CAPTAIN ";E3$;"." +1670 IF E3$<>"CONNORS" THEN 1740 +1680 PRINT C$;": CONNORS...THE ONLY STARSHIP COMMANDER EVER TO DEFECT" +1690 PRINT " TO AN ENEMY EMPIRE. MR. SPOCK, IT LOOKS AS IF WE MAY HAVE" +1700 PRINT " A CHANCE TO SETTLE AN OLD SCORE FOR THE FEDERATION." +1710 PRINT "SPOCK: INDEED, SIR." +1720 PRINT "CHEKOV: JUST WAIT REMTIL I GET MY PHASERS LOCKED IN ON THAT" +1730 PRINT " TRAITOR..." +1740 IF RND>.5 THEN 1770 +1750 PRINT C$;": SOUND RED ALERT, LIEUTENANT UHURA." +1760 GOTO 1780 +1770 PRINT C$;": SOUND BATTLE STATIONS, LIEUTENANT UHURA." +1780 PRINT "UHURA: AYE, SIR." +1790 IF RND>.5 THEN 1830 +1800 REM ESTABLISH MAIN SPEAKER (CHEKOV OR SULU) +1810 X$="SULU" +1820 GOTO 1840 +1830 X$="CHEKOV" +1840 H1=0 +1841 H2=0 +1842 G=0 +1843 X=0 +1844 S=0 +1845 M6=0 +1846 X2=0 +1847 K9=0 +1848 M5=0 +1849 P=0 +1860 REM ESTABLISH EVERYBODY'S SHIELDS AT 100% +1870 FOR Q5=1 TO 4 +1880 S1(Q5)=100 +1890 S2(Q5)=100 +1900 NEXT Q5 +1910 REM ESTABLISH ALL WEAPON POWER BANKS AT 300 +1920 P1=300 +1925 P2=300 +1930 REM FIRST RANGE AND BEARING +1940 R=1000-100*RND +1950 B=360*(RND-.5) +1960 B1=360*(RND-.5) +1970 REM +1980 REM TELL BEARING AND GET ORDERS +2000 REM +2010 GOSUB 8060 +2020 PRINT X$;": ORDERS, SIR"; +2030 INPUT I +2120 IF I<1 THEN 2140 +2130 IF I<24 THEN 2160 +2140 PRINT X$;": PLEASE SAY AGAIN, SIR"; +2150 GOTO 2030 +2160 PRINT C$;": ";O$(I) +2170 REM EXECUTE ORDERS +2180 IF I>20 THEN 2240 +2190 IF I>12 THEN 2230 +2200 IF I>6 THEN 2220 +2210 ON I GOTO 2000,2260,2310,2360,2420,2480 +2220 ON (I-6) GOTO 2520,2520,2560,2560,3750,2520 +2230 ON (I-12) GOTO 3880,3910,3940,2600,5140,4790,4940,9200 +2240 ON (I-20) GOTO 9890,10060,10100 +2250 REM MAKE SURE WEAPON SPECIFIED IS INTACT +2260 IF R>400 THEN 9490 +2270 IF H1<7 THEN 2710 +2280 PRINT "CHEKOV: FORWARD PHASERS ARE DEAD, SIR." +2290 GOSUB 8560 +2300 GOTO 5140 +2310 IF R>400 THEN 9490 +2320 IF H1<6 THEN 3240 +2330 PRINT "CHEKOV: REAR PHASER IS DEAD, SIR." +2340 GOSUB 8560 +2350 GOTO 5140 +2360 IF R<300 THEN 9490 +2370 IF R>700 THEN 9490 +2380 IF H1<9 THEN 3260 +2390 PRINT "CHEKOV: FORWARD PHOTON TORPEDOES ARE DEAD, SIR." +2400 GOSUB 8560 +2410 GOTO 5140 +2420 IF R<300 THEN 9490 +2430 IF R>700 THEN 9490 +2440 IF H1<8 THEN 3360 +2450 PRINT "CHEKOV: REAR PHOTON TORPEDO IS DEAD, SIR." +2460 GOSUB 8560 +2470 GOTO 5140 +2480 IF H1<12 THEN 3390 +2490 PRINT "CHEKOV: PROBE LAUNCHER IS DEAD, SIR." +2500 GOSUB 8560 +2510 GOTO 5140 +2520 IF H1<14 THEN 3550 +2530 PRINT "SULU: IMPULSE ENGINES ARE DEAD, SIR." +2540 GOSUB 8560 +2550 GOTO 5140 +2560 IF H1<11 THEN 3550 +2570 PRINT "SULU: WARP DRIVE IS DEAD, SIR." +2580 GOSUB 8560 +2590 GOTO 5140 +2600 IF H2<11 THEN 2630 +2610 PRINT "SPOCK: THE ";E1$;" HAS NO ENGINES, SIR." +2620 GOTO 5140 +2630 IF G=0 THEN 4460 +2640 PRINT "SPOCK: I DO NOT THINK THAT THE ";E1$;"S WILL BE FOOLED" +2650 PRINT " BY THAT MANEUVER AGAIN, SIR." +2660 GOSUB 8560 +2670 G=G+1 +2680 IF G=3 THEN 8750 +2690 GOTO 5140 +2700 REM TELL WHAT WE DO, COMPUTE SUCCESS: PHASERS +2710 IF ABS(B)<90 THEN 2770 +2730 PRINT "CHEKOV: INCORRECT VECTOR, SIR." +2740 M5=M5+1 +2750 IF M5>3 THEN 8750 +2760 GOTO 5140 +2770 P9=(RND*10)+5 +2790 P1=P1-P9 +2800 IF P1>0 THEN 2830 +2810 GOSUB 10000 +2820 GOTO 5140 +2830 IF RND=S2(K1) THEN 2920 +2910 K=K1 +2920 NEXT K1 +2930 IF S2(K)>50 THEN 2950 +2940 K=INT(RND*4+1) +2950 H2=H2+V +2960 PRINT "SPOCK: A HIT ON SHIELD #";K;"." +2970 IF S2(K)=0 THEN 3090 +2980 S2(K)=S2(K)-30*V*(RND+.1) +3000 IF S2(K)>0 THEN 3030 +3010 PRINT "SPOCK: THAT SHIELD IS NOW GONE."; +3015 PRINT CHR$(7);CHR$(7);CHR$(7);CHR$(7);CHR$(7);CHR$(7);CHR$(7);CHR$(7) +3020 S2(K)=0 +3030 GOSUB 9650 +3040 GOTO 5140 +3045 REM DIRECT HIT +3050 V=1 +3060 PRINT "CHEKOV: DIRECT HIT, SIR!" +3070 GOTO 2880 +3080 REM ENEMY IS CRIPPLED +3090 PRINT "CHEKOV: GOT HIM, SIR!" +3100 IF RND<.5 THEN 7640 +3110 PRINT "SPOCK: THE ";E1$;" VESSEL REMAINS INTACT, CAPTAIN." +3120 PRINT C$;": OPEN A HAILING FREQUENCY, LIEUTENANT." +3130 PRINT "UHURA: HAILING FREQUENCY OPEN, SIR." +3140 PRINT C$;": THIS IS CAPTAIN ";C$;" OF THE STARSHIP ";S$;"." +3150 PRINT " PREPARE TO COMMENCE BEAMING OVER SURVIVORS." +3160 IF RND<.5 THEN 3210 +3170 PRINT E3$;": I AM AFRAID THAT WILL BE QUITE IMPOSSIBLE," +3180 PRINT " CAPTAIN, SINCE WE HAVE JUST INITIATED OUR AUTO-DESTRUCT." +3190 PRINT " 10 9 8 7 6 5 4 3 2 1" +3200 GOTO 7640 +3210 PRINT E3$;": VERY WELL, CAPTAIN. OUR SHIELDS HAVE BEEN DEACTIVATED." +3220 GOTO 8150 +3230 REM TELL WHAT WE DO, COMPUTE SUCCESS: PHOTON TORPEDOES +3240 IF ABS(B)<90 THEN 2730 +3250 GOTO 2770 +3260 IF ABS(B)>=90 THEN 2730 +3270 P9=(RND*9)+5 +3290 P1=P1-P9 +3300 IF P1>0 THEN 3330 +3310 GOSUB 10000 +3320 GOTO 5140 +3330 IF RND>FNT(R,B,B9) THEN 2840 +3340 IF RND<.375 THEN 2870 +3350 GOTO 3050 +3360 IF ABS(B)<90 THEN 2730 +3370 GOTO 3270 +3380 REM ANTIMATTER PROBES +3390 IF X<10 THEN 3430 +3400 PRINT "CHEKOV: WE HAVE NO MORE PROBES, SIR." +3410 GOSUB 8560 +3420 GOTO 5280 +3430 X=X+1 +3450 Z4=RND +3460 IF Z4<.07135 THEN 3510 +3470 PRINT "CHEKOV: PROBE MISSED BY ";(Z4*100)-7.135;"MGM., SIR." +3480 IF (Z4*100)-7.135>5 THEN 3500 +3490 PRINT "SULU: ALMOST GOT HIM THAT TIME, SIR!" +3500 GOTO 5140 +3510 PRINT "SPOCK: PROBE IS HOMING ON THE ";E2$;" , SIR." +3520 V=3 +3530 GOTO 2880 +3540 REM OUR MOVE IMPLEMENTATION +3550 ON (I-6) GOTO 3570,3610,3660,3700,3750,3830 +3560 REM CLOSE ON ENEMY +3570 GOSUB 6660 +3580 R=ABS(R-Y) +3590 GOTO 5140 +3600 REM MOVE AWAY FROM ENEMY +3610 GOSUB 6730 +3620 R=ABS(R+Y) +3630 IF R>5000 THEN 6550 +3640 GOTO 5140 +3650 REM CLOSE AT WARP SPEED +3660 GOSUB 6780 +3670 R=ABS(R-2*Y) +3680 GOTO 5140 +3690 REM ESCAPE AT WARP SPEED +3700 GOSUB 6850 +3710 R=ABS(R+2*Y) +3720 IF R>5000 THEN 6550 +3730 GOTO 5140 +3740 REM PUT STRONGEST SHIELD IN POSITION +3750 S=1 +3760 FOR J=2 TO 4 +3770 IF S1(J)<=S1(S) THEN 3790 +3780 S=J +3790 NEXT J +3800 PRINT "SULU: SHIELD #";S;" IS IN POSITION." +3810 GOTO 2000 +3820 REM 180 DEGREES ABOUT +3830 B=B+180 +3832 B5=1 +3835 R=R+.0001 +3840 IF B<=180 THEN 5140 +3850 B=B-360 +3860 GOTO 5140 +3870 REM TELL PROBABILITIES +3880 PRINT "SPOCK: PHASERS:";FNP(R,B,B9)*100;"%, P.T.'S:"; +3885 PRINT FNT(R,B,B9)*100;"%." +3890 GOTO 2000 +3900 REM FEEDER FOR COMMANDS REPETITION +3910 GOSUB 7760 +3920 GOTO 2000 +3930 REM DAMAGE REPORT +3940 PRINT "SPOCK: COMPUTER DAMAGE REPORT:" +3950 PRINT TAB(10);"UNITS OF POWER REMAINING" +3960 PRINT TAB(6);"SHIELD #";TAB(16);S$;TAB(30);E2$ +3965 E=0 +3967 U=0 +3970 FOR J=1 TO 4 +3980 PRINT TAB(9);J;TAB(16);S1(J);TAB(30);S2(J) +3985 E=E+S2(J) +3987 U=U+S1(J) +3990 NEXT J +3992 PRINT TAB(9);"=";TAB(16);"=======";TAB(30);"=======" +3995 PRINT " COMPOSITE";TAB(16);U/4;TAB(30);E/4 +4000 PRINT S$;" DAMAGE:"; +4010 IF H1>5.5 THEN 4040 +4020 PRINT TAB(20);"NONE" +4030 GOTO 4180 +4040 PRINT TAB(20);"REAR PHASER DEAD" +4050 IF H1<7 THEN 4180 +4060 PRINT TAB(20);"FORWARD PHASERS DEAD" +4070 IF H1<8 THEN 4180 +4080 PRINT TAB(20);"REAR PHOTON TORPEDOES DEAD" +4090 IF H1<9 THEN 4180 +4100 PRINT TAB(20);"FORWARD PHOTON TORPEDOES DEAD" +4110 IF H1<11 THEN 4180 +4120 PRINT TAB(20);"TRANSPORTER LOST" +4130 PRINT TAB(20);"WARP DRIVE LOST" +4140 IF H1<12 THEN 4180 +4150 PRINT TAB(20);"PROBE LAUNCHER DESTROYED" +4160 IF H1<14 THEN 4180 +4170 PRINT TAB(20);"IMPULSE POWER LOST" +4180 PRINT E2$;" DAMAGE:"; +4190 IF H2>5.5 THEN 4220 +4200 PRINT TAB(20);"NONE" +4210 GOTO 4360 +4220 PRINT TAB(20);"REAR PHASERS DEAD" +4230 IF H2<7 THEN 4360 +4240 PRINT TAB(20);"FORWARD PHASERS DEAD" +4250 IF H2<8 THEN 4360 +4260 PRINT TAB(20);"REAR PHOTON TORPEDOES DEAD" +4270 IF H2<9 THEN 4360 +4280 PRINT TAB(20);"FORWARD PHOTON TORPEDOES DEAD" +4290 IF H2<11 THEN 4360 +4300 PRINT TAB(20);"TRANSPORTER LOST" +4310 PRINT TAB(20);"WARP DRIVE DEAD" +4320 IF H2<12 THEN 4360 +4330 PRINT TAB(20);"PROBE LAUNCHER DESTROYED" +4340 IF H2<14 THEN 4360 +4350 PRINT TAB(20);"IMPULSE ENGINES DEAD" +4360 PRINT "PROBES EXPENDED:" +4380 PRINT " ";S$;TAB(20);X +4390 PRINT " ";E2$;TAB(20);X2 +4400 PRINT "POWER REMAINING IN WEAPONS BANKS:" +4410 PRINT " ";S$;TAB(20);P1 +4420 PRINT " ";E2$;TAB(20);P2 +4440 GOTO 2000 +4450 REM CORBOMITE BLUFF +4460 PRINT C$;": USE CODE 2." +4470 PRINT "UHURA: CODE 2, SIR? THE ";E1$;"S BROKE CODE 2 YESTERDAY, SIR." +4480 PRINT C$;": CODE 2, LIEUTENANT. IMMEDIATELY." +4490 PRINT "UHURA: AYE, SIR. GO AHEAD, SIR." +4500 PRINT C$;": THIS IS CAPTAIN ";C$;" OF THE STARSHIP ";S$;"." +4510 PRINT " WE ARE UNDER ATTACK BY THE ";E1$;" SHIP ";E2$ +4520 PRINT " AND, IN ORDER TO PREVENT THE ";S$;" FROM FALLING" +4530 PRINT " INTO ENEMY HANDS, WE ARE ACTIVATING THE CORBOMITE" +4540 PRINT " DEVICE. SINCE THIS WILL RESULT IN THE COMPLETE" +4550 PRINT " ANNIHILATION OF ALL MATTER WITHIN A RANGE OF 5000" +4560 PRINT " MEGAMETERS, ALL VESSELS SHOULD BE WARNED TO STAY" +4570 PRINT " CLEAR OF THIS AREA FOR THE NEXT ";INT(RND*4)+2;" SOLAR YEARS." +4620 G=1 +4630 IF RND>.25 THEN 4740 +4640 PRINT "SULU: ";E1$;" IS MOVING AWAY AT WARP 10, SIR." +4650 PRINT "SPOCK:THE TACTIC APPEARS TO HAVE BEEN EFFECTIVE, SIR." +4660 PRINT " THE ";E1$;" HAS BEEN REPULSED." +4710 GOTO 6560 +4740 PRINT "SULU:NO IMMEDIATE CHANGE IN ";E1$;" COURSE AND SPEED, SIR." +4750 PRINT "SPOCK: IT WOULD SEEM THAT THEY HAVE, AS YOU HUMANS PUT IT," +4760 PRINT " 'CALLED OUR BLUFF', CAPTAIN." +4770 GOTO 5140 +4780 REM BLOW UP OUR SHIP +4790 PRINT "SPOCK: ARE YOU SURE, SIR"; +4800 INPUT A$ +4805 IF A$="" THEN 4800 +4810 IF LEFT$(A$,1)<>"N" THEN 4830 +4820 GOTO 2000 +4830 IF H1<9 THEN 8750 +4840 PRINT "COMPUTER: 10 9 8 7 6 5 4 3 2 1" +4850 PRINT " THE ";S$;" HAS BEEN DESTROYED." +4860 Q=200*RND +4870 PRINT " RADIUS OF EXPLOSION:";Q;" MGM." +4880 IF Q>=R THEN 4910 +4890 PRINT " ";E1$;" VESSEL REMAINS INTACT." +4900 GOTO 8150 +4910 PRINT " ";E1$;" VESSEL DESTROYED." +4920 GOTO 8150 +4930 REM SURRENDER TO ENEMY +4940 PRINT "UHUPA: ARE YOU SURE, SIR"; +4950 INPUT A$ +4955 IF A$="" THEN 4950 +4960 IF LEFT$(A$,1)<>"N" THEN 4980 +4970 GOTO 2000 +4980 IF H1<11 THEN 8750 +4990 IF E1$<>"ROMULAN" THEN 5020 +5000 PRINT "UHURA: NO ANSWER FROM THE ";E2$;", SIR." +5010 GOTO 5140 +5020 PRINT C$;": THIS IS CAPTAIN ";C$;" OF THE STARSHIP ";S$;"." +5030 PRINT " WILL YOU ACCEPT OUR UNCONDITIONAL SURRENDER?" +5050 PRINT E3$;": ON BEHALF OF THE ";E1$;" EMPIRE, I ACCEPT YOUR" +5060 PRINT " UNCONDITIONAL SURRENDER. PREPARE FOR IMMEDIATE BOARDING." +5120 GOTO 8150 +5130 REM +5140 REM PRIMARY ENEMY DECISION SECTION +5150 REM +5151 IF R>5000 THEN 6550 +5160 REM ENEMY TRANSPORTER FEEDER +5150 IF H2>10.9 THEN 5200 +5180 IF H1>8.9 THEN 5200 +5190 IF RND>.997 THEN 9000 +5200 REM FEED TO ENGINES & WEAPONS +5210 IF H2<9 THEN 5230 +5220 IF R<35 THEN 6590 +5230 IF H2>13.9 THEN 6440 +5240 IF H1<9 THEN 5280 +5250 IF R>100 THEN 5280 +5260 IF H2>11.9 THEN 5750 +5270 GOTO 5850 +5280 IF R>700 THEN 5470 +5290 IF H2<11.9 THEN 5330 +5300 IF H1>10.9 THEN 6440 +5310 IF X>9 THEN 6440 +5320 GOTO 5700 +5330 IF H2<9 THEN 5360 +5340 IF X2>9 THEN 5800 +5345 IF RND>.5 THEN 5800 +5350 GOTO 8890 +5355 REM P.T.'S +5360 IF FNP(R,B1,A9)>FNT(R,B1,A9) THEN 5410 +5370 IF H2<8 THEN 5650 +5380 IF ABS(B1)<90 THEN 5650 +5390 IF H1<7 THEN 5850 +5400 GOTO 5550 +5405 REM PHASERS +5410 IF H2>6.9 THEN 5650 +5420 IF R>400 THEN 5800 +5430 IF H2<5.5 THEN 5600 +5440 IF ABS(B1)< 90 THEN 5600 +5450 IF H1<5.5 THEN 5850 +5460 GOTO 5550 +5470 REM BEYOND 700 MGM. DECISION SUBSECTION +5480 IF H2>11.9 THEN 5700 +5490 IF H2<9 THEN 5800 +5500 IF X2>9 THEN 5700 +5510 GOTO 8890 +5550 REM 180 DEGREES ABOUT +5555 B5=1 +5560 B1=B1+180 +5565 R=R+.0001 +5570 IF B1<=180 THEN 2000 +5580 B1=B1-360 +5590 GOTO 2000 +5600 REM PHASER FEEDER +5605 IF FNP(R,B1,A9)<.4 THEN 5620 +5610 IF ABS(B1-90)>=ABS(B-90)-20 THEN 7110 +5620 R=R+Y +5630 B1=360*(RND-.5) +5640 GOTO 2000 +5650 REM P.T. FEEDER +5655 IF R<300 THEN 5750 +5657 IF R>700 THEN 5700 +5660 IF ABS(B1-90)>=ABS(B-90)-20 THEN 6920 +5670 GOTO 5620 +5700 REM MOVE CLOSER TO US +5710 GOSUB 6660 +5720 R=ABS(R+Y) +5730 GOTO 2000 +5750 REM MOVE AWAY FROM US +5760 GOSUB 6730 +5770 R=ABS(R-Y) +5780 GOTO 2000 +5800 REM WARP CLOSER TO US +5810 GOSUB 6780 +5820 R=ABS(R+2*Y) +5830 GOTO 2000 +5850 REM WARP AWAY FROM US +5860 GOSUB 6850 +5870 R=ABS(R-2*Y) +5880 GOTO 2000 +5980 REM TELL ABOUT ANY NEW LOSSES +5990 IF H1<6 THEN 6300 +6000 T=H1-V +6010 IF ABS(T-6)<.1 THEN 6050 +6020 IF ABS(H1-6.25)>.3 THEN 6050 +6030 PRINT "CHEKOV: REAR PHASER DEAD, SIR." +6040 GOTO 6300 +6050 IF ABS(T-7)<.1 THEN 6090 +6060 IF ABS(H1-7.25)>.3 THEN 6090 +6070 PRINT "CHEKOV: FORWARD PHASERS DEAD, SIR." +6080 GOTO 6300 +6090 IF ABS(T-8)<.1 THEN 6130 +6100 IF ABS(H1-8.25)>.3 THEN 6130 +6110 PRINT "CHEKOV: REAR PHOTON TORPEDOES DEAD, SIR." +6120 GOTO 6300 +6130 IF ABS(T-9)<.1 THEN 6170 +6140 IF ABS(H1-9.25)>.3 THEN 6170 +6150 PRINT "CHEKOV: FORWARD PHOTON TORPEDOES DEAD, SIR." +6160 GOTO 6300 +6170 IF ABS(T-10)<.1 THEN 6200 +6180 IF ABS(H1-10.25)>.3 THEN 6200 +6190 PRINT "CHEKOV: FIRE REPORTED ON DECK";INT(RND*9)+1;", SIR." +6200 IF ABS(T-11)<.1 THEN 6240 +6210 IF ABS(H1-11.25)>.3 THEN 6240 +6220 PRINT "CHEKOV: TRANSPORTER AND WARP DRIVE GONE, SIR" +6225 PRINT "UHURA: SIR, ENGINEERING REPORTS THEY'RE ON AUXILIARY" +6226 PRINT " SYSTEMS. SCOTTY SAYS THE PRIMARY CONTROLS ARE" +6227 PRINT " IRREPARABLE." +6230 GOTO 6300 +6240 IF ABS(T-12)<.1 THEN 6270 +6250 IF ABS(H1-12.25)>.3 THEN 6270 +6260 PRINT "CHEKOV: PROBE LAUNCHER GONE, SIR" +6270 IF ABS(T-13)<.1 THEN 6278 +6272 IF ABS(H1-13.25)>.3 THEN 6278 +6275 PRINT "CHEKOV: PRIMARY LIFE SUPPORT SYSTEMS INOPERATIVE, SIR." +6276 PRINT " EMERGENCY LIFE SUPPORT NOW IN USE." +6278 IF ABS(T-14)<.1 THEN 6300 +6280 IF ABS(H1-14.25)>.3 THEN 6300 +6290 PRINT "CHEKOV: IMPULSE ENGINES DEAD, SIR." +6295 PRINT "UHURA: SICKBAY REPORTS THEY ARE UNABLE TO TEND TO ANY MORE" +6296 PRINT " WOUNDED, SIR." +6300 IF ABS(T-15)<.1 THEN 6350 +6310 IF ABS(H1-15.25)>.3 THEN 6350 +6320 PRINT "CHEKOV: THE FIRES BELOWDECKS ARE SPREADING, SIR." +6330 PRINT "UHURA: CAPTAIN, SCOTTY SAYS HE'S CUT OFF IN ENGINEERING AND" +6340 PRINT " DAMAGE CONTROL DOESN'T ACKNOWLEDGE." +6350 IF ABS(T-16)<.1 THEN 6410 +6360 IF ABS(H1-16.25)>.3 THEN 6410 +6370 PRINT "UHURA: I CAN'T RAISE ANYONE, SIR; THE BRIDGE HAS BEEN ISOLATED." +6380 PRINT "SPOCK: ALTHOUGH THEIR RELIABILITY MUST NOW BE ESTIMATED AT" +6390 PRINT " ";(RND*40);"PER CENT, INSTRUMENTS INDICATE THAT THERE" +6400 PRINT " IS A VACUUM IN DECKS 5, 8 AND 9." +6410 RETURN +6430 REM THE ENEMY IS CRIPPLED; TO DESTROY OR NOT TO DESTROY CHOICE +6440 IF P>0 THEN 2000 +6450 P=1 +6460 PRINT "SPOCK: THE ";E1$;" SHIP IS COMPLETELY CRIPPLED, SIR." +6470 PRINT " DO YOU WANT THEM TO SURRENDER"; +6480 INPUT A$ +6485 IF A$="" THEN 6480 +6490 IF LEFT$(A$,1)="Y" THEN 3120 +6500 GOTO 2000 +6540 REM OUT OF RANGE +6550 PRINT "SULU: CONTACT WITH THE ";E1$;" VESSEL HAS BEEN BROKEN, SIR." +6560 PRINT C$;": RESUME COURSE FOR ";D$;", MR. SULU." +6570 PRINT "SULU: AYE, SIR." +6580 GOTO 8150 +6590 REM ENEMY BLOWS SELF UP +6600 PRINT "SPOCK: SENSORS INDICATE THAT THE ";E2$;" IS OVERLOADING" +6610 PRINT " WHAT REMAINS OF ITS ANTIMATTER PODS, UNDOUBTEDLY" +6620 PRINT " A SUICIDAL MOVE, CAPTAIN. PODS WILL DETONATE" +6630 PRINT " IN 12 SECONDS - 10 9 8 7 6 5 4 3 2 1" +6640 GOTO 7640 +6650 REM MOVE SHIPS CLOSER +6660 R=ABS(R-200*(RND+.5)) +6710 RETURN +6720 REM MOVE SHIPS AWAY +6730 R=R+200*(RND+.5) +6760 RETURN +6770 REM WARP SHIPS CLOSER +6780 R=ABS(R-400*(RND+.5)) +6830 RETURN +6840 REM WARP SHIPS AWAY +6850 R=R+400*(RND+.5) +6880 RETURN +6890 REM +6900 REM TELL WHAT THE ENEMY DOES, COMPUTE SUCCESS +6910 REM +6920 REM P.T.'S +7030 PRINT "SPOCK: P.T. INCOMING..."; +7040 P9=(RND*10)+5 +7050 P2=P2-P9 +7055 IF P2>25 THEN 7060 +7257 GOSUB 10400 +7060 IF P2>0 THEN 7080 +7070 GOSUB 9930 +7078 REM ENEMY IS IMPROVED SO PLAYER WILL NOT ALWAYS WIN. +7080 IF RND>FNT(R,B1,A9)*1.25 THEN 7570 +7090 IF RND<.375 THEN 7460 +7100 GOTO 7300 +7110 REM PHASERS +7220 PRINT "SPOCK: PHASER INCOMING..,"; +7230 P9=(RND*10)+5 +7240 P2=P2-P9 +7245 IF P2>25 THEN 7250 +7247 GOSUB 10400 +7250 IF P2>0 THEN 7270 +7260 GOSUB 9930 +7270 IF RND>FNP(R,B1,A9)*1.25 THEN 7570 +7280 IF RND<.4 THEN 7460 +7290 REM TELL RESULTS, SUBTRACT FROM SHIELDS +7300 V=.5 +7310 K=INT(RND*4)+1 +7320 IF S=0 THEN 7340 +7330 K=S +7340 PRINT " A HIT ON SHIELD #";K;"." +7350 IF S1(K)<=0 THEN 7440 +7360 S1(K)=S1(K)-30*V*(RND+.1) +7370 H1=H1+V +7380 GOSUB 5990 +7390 IF S1(K)>0 THEN 2000 +7400 S1(K)=0 +7410 PRINT "SPOCK: SHIELD #";K;"IS GONE."; +7415 PRINT CHR$(7),CHR$(7),CHR$(7),CHR$(7),CHR$(7),CHR$(7) +7420 GOTO 2000 +7430 REM WE'RE BLOWN UP +7440 PRINT "COMPUTER: THE ";S$;" HAS BEEN DESTROYED." +7450 GOTO 4850 +7460 V=1 +7470 K=INT(RND*4)+1 +7480 IF S=0 THEN 7500 +7490 K=S +7500 PRINT " A DIRECT HIT ON SHIELD #";K;"." +7510 K1=INT(RND*50)+1 +7520 K9=K9+K1 +7525 IF H1>16 THEN 7350 +7530 PRINT "UHURA: ";K1;"CASUALTIES REPORTED ON DECK"; +7540 PRINT INT(RND*9)+1;", SIR." +7550 PRINT "SPOCK: TOTAL CASUALTIES NOW ";K9;", CAPTAIN." +7560 GOTO 7350 +7570 REM MISSED... +7580 PRINT "MISSED" +7620 GOTO 2000 +7640 REM BLOW ENEMY UP AND DETERMINE IF WE'RE SAFE +7650 Q=200*RND +7660 IF Q0 THEN 8097 +8094 B=360*(RND-.5) +8096 B1=360*(RND-.5) +8097 B5=0 +8100 PRINT "SPOCK: RANGE:";R;"MGM., BEARING:";B;"D., ALTITUDE:";B9;"D." +8110 IF R>60 THEN 8130 +8120 PRINT "SPOCK: CAPTAIN, WE ARE DANGEROUSLY CLOSE TO THE ";E2$ +8130 RETURN +8140 REM CLOSE IT OUT +8150 PRINT +8160 C$=C9$ +8170 PRINT "COMPUTER: DO YOU WISH TO ATTEMPT ANOTHER BATTLE"; +8190 INPUT A$ +8195 IF A$="" THEN 8190 +8200 IF LEFT$(A$,1)="N" THEN 8220 +8205 RESTORE +8210 G9=1 +8215 GOTO 330 +8220 IF A$="NEW" THEN 12000 +8280 PRINT +8290 PRINT +8300 PRINT +8310 STOP +8320 REM TELL WEAPON RANGES AND PROBABILITIES +8330 PRINT +8340 PRINT "NOTE: WEAPON RANGES ARE:" +8350 PRINT " PHASERS 0-400 MGM (OPTIMUM 200)" +8360 PRINT " TORPEDOES 300-700 MGM (OPTIMUM 500)" +8370 PRINT " TRANSPORTER 0-1000 MGM" +8380 PRINT " PROBES ALL RANGES" +8390 PRINT +8400 PRINT " WEAPON POWER BANKS CONTAIN 300 UNITS OF ENERGY WHEN THE" +8410 PRINT " ";S$;" LEAVES STARBASE. PHASERS DEPLETE THIS POWER MORE" +8420 PRINT " RAPIDLY THAN PHOTON TORPEDOES. SHIELD POWER MAY BE" +8421 PRINT " ALLOCATED TO WEAPONS POWER BANKS IF THEY ARE IN DANGER" +8422 PRINT " OF DEPLETION. ONCE EMPTY, THEY CANNOT BE RECHARGED." +8430 PRINT +8440 PRINT " PHASERS ARE MORE DEADLY THAN TORPEDOES. PROBES" +8450 PRINT " CAUSE MUCH GREATER DESTRUCTION, BUT SUCCEED ONLY" +8460 PRINT " 7% OF THE TIME (APPROXIMATELY). TORPEDOES AND" +8470 PRINT " PHASERS ARE MORE DEADLY WHEN THE BEARING OF THE" +8480 PRINT " ENEMY IS CLOSE TO 0, 180 AND -180 DEGREES, AND" +8485 PRINT " WHEN THE ALTITUDE IS CLOSE TO 0, 90 AND -90 DEGREES." +8490 PRINT " YOU MAY FIND OUT THE ODDS ON ANY SPECIFIC SHOT" +8520 PRINT " BY ASKING ME FOR A PROBABILITY REPORT. BOARDING" +8510 PRINT " PARTIES SUCCEED 30% OF THE TIME IN TAKING OVER" +8522 PRINT " THE ENEMY SHIP, BUT THE CAPTAIN IS KILLED IF THEY" +8530 PRINT " FAIL. " +8540 RETURN +8550 REM MISTAIE COUNTER +8560 M6=M6+1 +8570 IF M6>4 THEN 8750 +8580 RETURN +8590 REM PROBE GETS US +8600 PRINT "IT IS HOMING IN ON US." +8610 PRINT C$;": ALL HANDS: BRACE FOR EXPLOSION." +8620 PRINT "SPOCK: ESTIMATED TIME OF IMPACT- IN 12 SECONDS." +8630 PRINT "SPOAK: 10 9 8 7 6 5 4 3 2 1" +8640 V=3 +8650 K=INT(RND*4)+1 +8660 PRINT "SPOCK: PROBE STRUCK SHIELD #";K +8665 IF H1>16 THEN 7350 +8670 PRINT "UHURA: DECKS ";INT(RND*4)+1;" AND ";INT(RND*4)+5;" REPORT "; +8680 K3=INT(RND*60)+1 +8690 K2=INT(RND*60)+1 +8700 K9=K9+K0+K3 +8710 PRINT K1;"AND";K2;"CASUALTIES" +8720 PRINT " RESPECTIVELY, SIR." +8730 PRINT "SPOCK: TOTAL CASUALTIES NOW";K9;", CAPTAIN." +8740 GOTO 7350 +8750 REM MUTINY SECTION +8760 PRINT "SPOCK: I'M SORRY, CAPTAIN ";C$;", BUT YOU HAVE SHOWN " +8770 PRINT " GROSS INCOMPETENCE IN YOUR COMMAND OF THIS VESSEL." +8780 PRINT " I HEREBY TAKE COMMAND OF THE ";S$;" AND PLACE YOU" +8790 PRINT " UNDER ARREST." +8800 PRINT C$;": THIS IS MUTINY, MR. SPOCK!" +8810 PRINT "SPOCK: I BELIEVE THAT IS THE CORRECT TERM, SIR. GUARD, TAKE" +8820 PRINT " CAPTAIN ";C$;" TO THE BRIG." +8830 PRINT "GUARD: AYE, SIR" +8840 PRINT "SPOCK: MR. SULU, ESCAPE AT WARP SPEED." +8842 IF H1<11 THEN 8850 +8844 PRINT "SULU: SORRY MR. SPOCK, THE WARP DRIVE ENGINES ARE OUT." +8845 PRINT "SPOCK: HAVE MR. SCOTT BEGIN REPAIRS IMEDEATELY. AND," +8846 PRINT " MAKE FOR OUR DESTINATION UNDER FULL IMPULSE POWER." +8850 PRINT "SULU: AYE, SIR." +8870 C$="SPOCK" +8880 GOTO 6540 +8890 REM ENEMY ANTIMATTER PROBE +8900 X2=X2+1 +8930 PRINT "SPOCK: PROBE INCOMING..."; +8940 R9=RND +8950 IF R9<.07135 THEN 8600 +8960 PRINT "MISSED BY";(R9-.07135)*100;"MGM, SIR." +8970 IF (R9-.07135)>.05 THEN 8990 +8980 PRINT "CHEKOV: THAT WAS ALMOST TOO CLOSE, SIR." +8990 GOTO 2000 +9000 REM ENEMY BOARDS US +9020 PRINT "SPOCK: SHIPS SENSORS INDICATE THAT A ";E1$;" PARTY HAS JUST" +9030 PRINT " BEAMED ABOARD, SIR." +9040 PRINT E3$;": I THINK WE CAN SETTLE THIS MATTER ON A MORE" +9050 PRINT " PERSONAL SCALE, CAPTAIN ";C$ +9060 PRINT C$;": SHOOT WITH PHASERS ON KILL!" +9070 IF RND>.5 THEN 9130 +9080 PRINT "SPOCK: I BELIEVE THE INTRUDERS ARE ALL DEAD, SIR." +9090 PRINT C$;": I THINK THEY'LL CHOOSE TO ESCAPE NOW THAT ";E3$;" IS" +9100 PRINT " DEAD." +9110 PRINT "SPOCK: A LOGICAL CONCLUSION, CAPTAIN." +9120 GOTO 6540 +9130 PRINT E3$;": THEY'RE ALL DEAD...THE ";S$;" IS OURS!" +9140 PRINT " GRUTAL, TURN OFF ALL LIFE SUPPORT; WE'LL BEAM BACK TO" +9150 PRINT " THE ";E2$;" AND PUT A TRACTOR BEAM ON THE ";S$;" TO" +9160 PRINT " TAKE IT BACK TO ";E1$;" HEADQUARTERS FOR CAREFUL" +9170 PRINT " EXAMINATION." +9180 PRINT "GRUTAL: AYE, CAPTAIN." +9190 GOTO 8150 +9200 REM WE BOARD THEM +9210 IF H1>10 THEN 9420 +9220 IF R>1000 THEN 9460 +9230 PRINT "SPOCK: AYE, SIR" +9240 PRINT C$;": SCOTTY, CHEKOV COME WITH ME." +9250 PRINT "SPOCK: IT APPEARS, GENTLEMEN, AS IF WE ARE GOING TO HAVE" +9260 PRINT " TO, AS YOU HUMANS PUT IT, WAIT IT OUT." +9270 FOR I=1 TO 3 +9280 PRINT " " +9290 NEXT I +9300 IF RND>.7 THEN 9340 +9310 PRINT E3$;": YOU WERE WAITING TO HEAR FROM YOUR CAPTAIN?" +9320 PRINT "UHURA: OH MY GOD..." +9330 GOTO 8840 +9340 PRINT C$;": ";E3$;" IS DEAD AND THE ";E2$;" IS OURS." +9350 PRINT "UHURA: THANK GOD..." +9360 PRINT C$;": WE'LL BE BEAMING BACK TO THE ";S$;" SHORTLY. THE" +9370 PRINT " ";E1$;"S ARE SAFELY LOCKED BEHIND THE CRASH BULKHEADS." +9380 PRINT "SPOCK: AYE, SIR. THE CREW IS HAPPY TO HEAR YOU'RE SAFE." +9390 PRINT C$;": THANK-YOU, MR. SPOCK. CARRY ON." +9400 PRINT "SPOCK: AYE, SIR." +9410 GOTO 8150 +9415 REM TRANSPORTER DEAD +9420 GOSUB 8550 +9430 PRINT "SPOCK: I'M SORRY, CAPTAIN, BUT THE TRANSPORTER IS DEAD." +9440 GOTO 2000 +9450 REM TELL WE'RE OUT OF WEAPON RANGE +9460 PRINT X$;": THE ";E2$;" IS OUT OF TRANSPORTER RANGE, SIR." +9470 GOSUB 8550 +9480 GOTO 5140 +9490 PRINT X$;": THE ";E2$;" IS OUT OF THAT WEAPON'S RANGE, SIR." +9500 GOSUB 8550 +9510 GOTO 5140 +9520 REM ADDENDA OF DESTINATIONS +9530 PRINT " IN ORDER TO RESCUE COLONISTS UNDER HEAVY ATTACK BY" +9540 PRINT " ";E1$;" BATTLE CRUISERS." +9550 GOTO 1570 +9560 PRINT " WITH A CARGO OF VITAL SERUM TO COMBAT AN EPIDEMIC OF" +9570 PRINT " RIGELLIAN FEVER THERE." +9580 GOTO 1570 +9590 PRINT " TO SECURE DILITHIUM MINING RIGHTS FOR THE FEDERATION." +9600 GOTO 1570 +9610 PRINT " WITH THE NEW FEDERATION AMBASSADOR TO THAT PLANET." +9620 GOTO 1570 +9630 PRINT " FOR ASTROPHYSICAL RESEARCH ON QUASARS IN THAT AREA." +9640 GOTO 1570 +9650 REM TELL ABOUT NEW ENEMY LOSSES +9660 IF H2<=5.5 THEN 9870 +9670 IF H2>10 THEN 9870 +9675 IF H2>6.9 THEN 9725 +9680 IF H9>0 THEN 9720 +9690 H9=1 +9700 PRINT "SPOCK: ENEMY REAR PHASERS DEAD, SIR." +9710 RETURN +9720 IF H2<7 THEN 9870 +9725 IF H2>7.9 THEN 9775 +9730 IF H9>1 THEN 9770 +9740 H9=2 +9750 PRINT "SPOCK: ENEMY FORWARD PHASERS DEAD, SIR." +9760 RETURN +9770 IF H2<8 THEN 9870 +9775 IF H2>8.9 THEN 9830 +9780 IF H9>2 THEN 9820 +9790 H9=3 +9800 PRINT "SPOCK: ENEMY REAR P.T.'S DEAD, SIR." +9810 RETURN +9820 IF H2<9 THEN 9870 +9830 IF H9>3 THEN 9870 +9840 H9=4 +9850 PRINT "SPOCK: ENEMY FORWARD P.T.'S DEAD, SIR; REQUEST DAMAGE" +9860 PRINT " REPORT FOR ALL FUTURE ENEMY DAMAGE." +9870 RETURN +9880 REM WEAPONS BRIEFING FEEDER +9890 PRINT "SPOCK: WEAPON RANGES AND ACCURACIES ARE AS FOLLOWS:" +9900 PRINT +9910 GOSUB 8350 +9920 GOTO 2000 +9930 REM ENEMY WEAPON POWER BANKS DEPLETED +9940 H2=9 +9950 P2=0 +9960 PRINT "SPOCK: SENSORS INDICATE THAT THE ";E2$;"'S" +9970 PRINT " WEAPONS POWER BANKS ARE EMPTY, CAPTAIN. ALL" +9980 PRINT " ENEMY PHASERS AND PHOTON TORPEDOES ARE DEAD." +9990 RETURN +10000 REM OUR WEAPONS POWER BANKS DEPLETED +10010 H1=9 +10020 P1=0 +10030 PRINT "SPOCK: CAPTAIN, OUR WEAPONS POWER BANKS ARE EMPTY. ALL" +10242 PRINT " PHASERS AND PHOTON TORPEDOES ARE DEAD." +10050 RETURN +10060 REM WEAPON POWER BANKS STATUS REPORT +10070 PRINT "SPOCK: ";P1;"UNITS REMAIN,";P1/3;"% OF TOTAL." +10080 GOTO 2000 +10100 REM SHIELD POWER TO WEAPONS BANKS +10105 IF H1>8.9 THEN 10390 +10110 PRINT "SULU: WHICH OPTION, CAPTAIN: 1) ALL SHIELDS EQUALLY" +10112 PRINT " DRAINED, 2) A CHOSEN SHIELD DEPLETED"; +10120 INPUT W +10130 IF W>2 THEN 10110 +10140 IF W<1 THEN 10110 +10150 IF W>1 THEN 10300 +10155 REM ALL SHIELDS DRAINED +10160 PRINT "SULU: HOW MANY UNITS TOTAL"; +10170 INPUT W1 +10180 FOR I=1 TO 4 +10190 IF W1/4>S1(I) THEN 10210 +10200 NEXT I +10205 GOTO 10240 +10210 PRINT "SULU: THE SHIELDS DO NOT HAVE THAT MUCH POWER, SIR." +10220 GOTO 10160 +10240 FOR I=1 TO 4 +10250 S1(I)=S1(I)-W1/4 +10260 NEXT I +10270 P1=P1+W1 +10280 PRINT "SPOCK: ";P1;"UNITS NOW AVAILABLE TO WEAPONS, CAPTAIN." +10290 GOTO 1980 +10295 REM ONE SHIELD DRAINED +10300 PRINT "SULU: SHIELD NUMBER"; +10310 INPUT S9 +10315 IF S9>4 THEN 10300 +10320 PRINT "SULU: NUMBER OF UNITS"; +10330 INPUT W1 +10340 IF S1(S9)11.9 THEN 10440 +10410 FOR I=1 TO 4 +10420 IF S2(I)<35 THEN 10480 +10430 NEXT I +10440 FOR I=1 TO 4 +10450 S2(I)=S2(I)-5 +10460 NEXT I +10470 P2=P2+20 +10480 RETURN +10995 REM TELL ABOUT MODIFICATIONS +11000 PRINT "SPOCK: ALL 3 DIMENSIONS NOW DETERMINE WEAPON ACCURACIES;" +11010 PRINT " ALTITUDE IS OPTIMAL AT 0, 90 AND -90 DEGREES. NO" +11020 PRINT " FURTHER ASTEROIDS WILL BE ENCOUNTRED. ENEMY" +11030 PRINT " STRATEGY MAY BE SLIGHTLY DIFFERENT." +11040 PRINT " CODE WORDS MAY NO LONGER BE USED; ONLY NUMBERS" +11050 PRINT " ARE ACCEPTED. SHIELD POWER MAY BE ALLOCATED TO WEAPONS" +11060 PRINT " BANKS IF THEY ARE IN DANGER OF DEPLETION; ONCE EMPTY," +11070 PRINT " THEY CANNOT BE RECHARGED." +11099 RETURN +12000 RESTORE +12002 RANDOMIZE +12004 FOR L=1 TO 6 +12006 PRINT +12008 NEXT L +12009 G9=G=0 +12010 GOTO 330 +64000 REM +64001 REM ++++++++++++++++++++++++++++++++++++++++++ +64002 REM + + +64003 REM + LIST OF PROGRAM VARIABLES + +64004 REM + + +64005 REM ++++++++++++++++++++++++++++++++++++++++++ +64006 REM +64010 REM A$ YES/NO INPUT +64020 REM C$ OUR CAPTAIN +64040 REM C9$ HOLDER FOR OUR CAPTAIN +64050 REM D$ DESTINATION +64060 REM E1$ ENEMY NATION +64070 REM E2$ ENEMY VESSEL +64080 REM E3$ ENEMY CAPTAIN +64090 REM K7$ ENEMY NATIONS ARRAY +64100 REM K8$ ENEMY VESSELS ARRAY +64110 REM K9$ ENEMY CAPTAINS ARRAY +64120 REM L$ DESTINATION ARRAY +64140 REM N$ OUR SHIPS ARRAY +64150 REM O$ COMMAND FEEDBACK ARRAY +64160 REM S$ OUR SHIP +64165 REM V$ VERSION OF PROGRAM +64170 REM X$ HELMSMAN (CHEKOV OR SULU) +64200 REM +64205 REM A9 ENEMY ALTITUDE +64210 REM B BEARING +64220 REM B1 BEARING FOR ENEMY SHIP +64225 REM B5 SKIP BEARING CHANGE FLAG +64230 REM B9 OUR ALTITUDE +64240 REM E ENEMY DAMAGE COMPOSITE +64250 REM G CORBOMITE COUNTER +64255 REM G9 GAME # COUNTER +64260 REM H1 OUR DAMAGE COUNTER +64270 REM H2 ENEMY DAMAGE COUNTER +64275 REM H9 ENEMY DAMAGE PRINTOUT COUNTER +64280 REM J SHIELD # HOLDER +64290 REM K SHIELD # HOLDER +64300 REM K1 SHIELD # HOLDER +64307 REM K2 CASUALTY HOLDER +64308 REM K3 CASUALTY HOLDER +64309 REM K9 CASUALTY COUNTER +64310 REM M5 VECTOR ERROR COUNTER +64320 REM M6 MISTAKE COUNTER +64330 REM P DESTROY CHOICE COUNTER +64331 REM P1 OUR WEAPON POWER BANKS +64332 REM P2 ENEMY WEAPON POWER BANKS +64339 REM P9 RND HOLDER +64340 REM Q RADIUS OF SHIP EXPLOSION +64350 REM R RANGE +64360 REM R7 PREVIOUS RANGE HOLDER +64370 REM R9 RND HOLDER +64380 REM S SHIELD # HOLDER +64390 REM S1(I) OUR SHIELDS +64400 REM S2(I) ENEMY'S SHIELDS +64405 REM S9 SHIELD DRAINED FOR WEAPONS +64410 REM T HOLDER OF PREVIOUS H1 +64415 REM U OUR DAMAGE COMPOSITE +64420 REM V VALUE OF HIT +64424 REM W SHIELD DRAIN OPTION +64425 REM W1 POWER FROM SHIELDS TO WEAPONS +64430 REM X OUR PROBE COUNTER +64440 REM X2 ENEMY PROBE COUNTER +64450 REM Y RND POWER FACTOR +64460 REM Z4 RND HOLDER +64999 END + \ No newline at end of file diff --git a/software/BAS/STARTREKV2.BAS b/software/BAS/STARTREKV2.BAS new file mode 100644 index 0000000..64d0170 --- /dev/null +++ b/software/BAS/STARTREKV2.BAS @@ -0,0 +1,446 @@ +10 REM SUPER STARTREK - MAY 16,1978 - REQUIRES 24K MEMORY (AT LEAST) +30 REM +40 REM **** **** STAR TREK **** **** +50 REM **** SIMULATION OF A MISSION OF THE STARSHIP ENTERPRISE, +60 REM **** AS SEEN ON THE STAR TREK TV SHOW. +70 REM **** ORIGINAL PROGRAM BY MIKE MAYFIELD, MODIFIED VERSION +80 REM **** PUBLISHED IN DEC'S "101 BASIC GAMES", BY DAVE AHL. +90 REM **** MODIFICATIONS TO THE LATTER (PLUS DEBUGGING) BY BOB +100 REM *** LEEDOM - APRIL & DECEMBER 1974, +110 REM *** WITH A LITTLE HELP FROM HIS FRIENDS . . . +120 REM *** COMMENTS, EPHITETS, AND SUGGESTIONS SOLICITED -- +130 REM *** SEND TO: R.C. LEEDOM +140 REM *** WESTINGHOSE DEFENSE & ELECTRONICS SYSTEMS CNIR +150 REM *** BOX 746, M.S. 338 +160 REM *** BALTIMORE, MD 21203 +170 REM *** +180 REM *** CONVERTED TO MICROSOFT 8 K BASIC 3/16/78 BY JOHN BORDERS +190 REM *** LINE NUMBERS FROM VERSION TREK7 OF 1/12/75 PRESERVED AS +200 REM *** MUCH AS POSSIBLE WHILE USING MULTIPLE STATEMENTS PER LINE +201 REM *** - MODIFIED TO RUN ON GRANT SEARLE'S 9-CHIP Z80 COMPUTER +202 REM *** AND DERIVATIVES 04-AUG-2018 BY N.KENDRICK +203 REM *** (LINKER3000-AT-GMAIL.COM) +205 WIDTH 80 +209 REM NK: POSITIONING USING ANSI ESCAPE SEQUENCES... +210 PRINT CHR$(27);"[2J";:PRINT CHR$(27);"[3;1H"; +211 PRINT "THE USS ENTERPRISE --- NCC-1701" +212 PRINT CHR$(27);"[4;1H";:PRINT +222 FOR YY=1 TO 40 STEP 2:FOR XX=1 TO 200 : NEXT XX +223 PRINT TAB(YY);" ,------*------," +224 PRINT TAB(YY);" ,------------- '--- ------'" +225 PRINT TAB(YY);" '-------- --' / /" +226 PRINT TAB(YY);" ,---' '-------/ /--," +227 PRINT TAB(YY);" '----------------'" +228 PRINT CHR$(27);"[4;1H";:PRINT:NEXT YY +229 PRINT CHR$(27);"[11;1H"; +260 CLEAR 600 +270 Z$=" " +330 DIM G(8,8),C(9,2),K(3,3),N(3),Z(8,8),D(8) +370 T=INT(RND(1)*20+20)*100:T0=T:T9=25+INT(RND(1)*10):D0=0:E=3000:E0=E +440 P=10:P0=P:S9=200:S=0:B9=0:K9=0:X$="":X0$=" IS " +470 DEF FND(D)=SQR((K(I,1)-S1)^2+(K(I,2)-S2)^2) +475 DEF FNR(R)=INT(RND(R)*7.98+1.01) +490 Q1=FNR(1):Q2=FNR(1):S1=FNR(1):S2=FNR(1) +530 FOR I=1 TO 9:C(I,1)=0:C(I,2)=0:NEXT I +540 C(3,1)=-1:C(2,1)=-1:C(4,1)=-1:C(4,2)=-1:C(5,2)=-1:C(6,2)=-1 +600 C(1,2)=1:C(2,2)=1:C(6,1)=1:C(7,1)=1:C(8,1)=1:C(8,2)=1:C(9,2)=1 +670 FOR I=1 TO 8:D(I)=0:NEXT I +710 A1$="NAVSRSLRSPHATORSHEDAMCOMXXX" +820 FOR I=1 TO 8:FOR J=1 TO 8:K3=0:Z(I,J)=0:R1=RND(1) +850 IF R1>.98 THEN K3=3:K9=K9+3:GOTO 980 +860 IF R1>.95 THEN K3=2:K9=K9+2:GOTO 980 +870 IF R1>.8 THEN K3=1:K9=K9+1 +980 B3=0:IF RND(1)>.96 THEN B3=1:B9=B9+1 +1040 G(I,J)=K3*100+B3*10+FNR(1):NEXT J:NEXT I:IF K9>T9 THEN T9=K9+1 +1100 IF B9<>0 THEN 1200 +1150 IF G(Q1,Q2)<200 THEN G(Q1,Q2)=G(Q1,Q2)+100:K9=K9+1 +1160 B9=1:G(Q1,Q2)=G(Q1,Q2)+10:Q1=FNR(1):Q2=FNR(1) +1200 K7=K9:IF B9<>1 THEN X$="S":X0$=" ARE " +1230 PRINT"YOUR ORDERS ARE AS FOLLOWS:" +1235 PRINT "--------------------------" +1240 PRINT" DESTROY THE";K9;"KLINGON WARSHIPS WHICH HAVE INVADED" +1250 PRINT" THE GALAXY BEFORE THEY CAN ATTACK FEDERATION HEADQUARTERS" +1260 PRINT" ON STARDATE";T0+T9;CHR$(8);". THIS GIVES YOU";T9; +1261 PRINT"DAYS. THERE";X0$ +1270 PRINT" ";B9; +1271 PRINT"STARBASE";X$;" IN THE GALAXY FOR RESUPPLYING YOUR SHIP." +1280 PRINT: PRINT "PRESS Y TO ACCEPT COMMAND"; +1300 INPUT I5$: +1302 IF LEFT$(I5$,1)="Y" OR LEFT$(I5$,1)="y" THEN 1310 +1303 GOTO 1280 +1310 PRINT CHR$(26) +1320 Z4=Q1:Z5=Q2:K3=0:B3=0:S3=0:G5=0:D4=.5*RND(1):Z(Q1,Q2)=G(Q1,Q2) +1390 IF Q1<1 OR Q1>8 OR Q2<1 OR Q2>8 THEN 1600 +1430 GOSUB 9030:PRINT:IF T0<>T THEN 1490 +1460 PRINT"YOUR MISSION BEGINS WITH YOUR STARSHIP LOCATED" +1470 PRINT"IN THE GALACTIC QUADRANT, '";G2$;"'.":GOTO 1500 +1490 PRINT"NOW ENTERING ";G2$;" QUADRANT . . ." +1500 PRINT:K3=INT(G(Q1,Q2)*.01):B3=INT(G(Q1,Q2)*.1)-10*K3 +1540 S3=G(Q1,Q2)-100*K3-10*B3:IF K3=0 THEN 1590 +1560 PRINT TAB(3);CHR$(22);" COMBAT AREA CONDITION RED ";CHR$(22) +1561 IF S>200 THEN PRINT:GOTO 1590 +1580 PRINT TAB(3);CHR$(22);" SHIELDS DANGEROUSLY LOW ";CHR$(22) +1581 PRINT +1590 FOR I=1 TO 3:K(I,1)=0:K(I,2)=0:NEXT I +1600 FOR I=1 TO 3:K(I,3)=0:NEXT I:Q$=Z$+Z$+Z$+Z$+Z$+Z$+Z$+LEFT$(Z$,17) +1680 A$="":Z1=S1:Z2=S2:GOSUB 8670:IF K3<1 THEN 1820 +1720 FOR I=1 TO K3:GOSUB 8590:A$="+K+":Z1=R1:Z2=R2 +1780 GOSUB 8670:K(I,1)=R1:K(I,2)=R2:K(I,3)=S9*(.5+RND(1)):NEXT I +1820 IF B3<1 THEN 1910 +1880 GOSUB 8590:A$=">B<":Z1=R1:B4=R1:Z2=R2:B5=R2:GOSUB 8670 +1910 FOR I=1 TO S3:GOSUB 8590:A$=" * ":Z1=R1:Z2=R2:GOSUB 8670:NEXT I +1980 GOSUB 6430 +1990 IF S+E>10 THEN IF E>10 OR D(7)=0 THEN 2060 +2020 PRINT:PRINT TAB(10);CHR$(22);"** FATAL ERROR **";CHR$(22) +2021 PRINT"YOU'VE JUST STRANDED YOUR SHIP IN SPACE." +2030 PRINT"YOU HAVE INSUFFICIENT MANEUVERING ENERGY," +2040 PRINT"AND SHIELD CONTROL IS PRESENTLY INCAPABLE OF" +2050 PRINT"CROSS-CIRCUITING TO ENGINE ROOM!!":PRINT:GOTO 6220 +2060 PRINT:INPUT"COMMAND";A$:PRINT +2080 FOR I=1 TO 9:IF LEFT$(A$,3)<>MID$(A1$,3*I-2,3)THEN 2160 +2140 ON I GOTO 2300,1980,4000,4260,4700,5530,5690,7290,6270 +2160 NEXT I:PRINT"ENTER ONE OF THE FOLLOWING:" +2170 PRINT "--------------------------" +2180 PRINT" NAV (TO SET COURSE)" +2190 PRINT" SRS (FOR SHORT RANGE SENSOR SCAN)" +2200 PRINT" LRS (FOR LONG RANGE SENSOR SCAN)" +2210 PRINT" PHA (TO FIRE PHASERS)" +2220 PRINT" TOR (TO FIRE PHOTON TORPEDOES)" +2230 PRINT" SHE (TO RAISE OR LOWER SHIELDS)" +2240 PRINT" DAM (FOR DAMAGE CONTROL REPORTS)" +2250 PRINT" COM (TO CALL ON LIBRARY-COMPUTER)" +2260 PRINT" XXX (TO RESIGN YOUR COMMAND)":PRINT:GOTO 1990 +2300 INPUT"COURSE (0-9)";C1:IF C1=9 THEN C1=1 +2310 IF C1>=1 AND C1<9 THEN 2350 +2330 PRINT" LT. SULU: 'INCORRECT COURSE DATA, SIR!'":GOTO 1990 +2350 X$="8":IF D(1)<0 THEN X$="0.2" +2360 PRINT"WARP FACTOR (0-";X$;")";:INPUT W1:PRINT +2361 IF D(1)<0 AND W1>.2 THEN 2470 +2380 IF W1>0 AND W1<=8 THEN 2490 +2390 IF W1=0 THEN 1990 +2420 PRINT" CHIEF ENGINEER SCOTT: 'THE ENGINES WON'T TAKE"; +2430 PRINT" WARP";W1;CHR$(8);"!'":GOTO 1990 +2470 PRINT"WARP ENGINES ARE DAMAGED. MAXIUM SPEED = WARP 0.2":GOTO 1990 +2490 N=INT(W1*8+.5):IF E-N>=0 THEN 2590 +2500 PRINT"ENGINEERING: 'INSUFFICIENT ENERGY AVAILABLE" +2510 PRINT" FOR MANEUVERING AT WARP";W1;CHR$(8);"!'" +2530 IF S=1 THEN D6=1 +2770 FOR I=1 TO 8:IF D(I)>=0 THEN 2880 +2790 D(I)=D(I)+D6:IF D(I)>-.1 AND D(I)<0 THEN D(I)=-.1:GOTO 2880 +2800 IF D(I)<0 THEN 2880 +2810 IF D1<>1 THEN D1=1:PRINT"DAMAGE CONTROL REPORT: "; +2840 PRINT TAB(8);:R1=I:GOSUB 8790:PRINT G2$;" REPAIR COMPLETED." +2880 NEXT I:IF RND(1)>.2 THEN 3070 +2910 R1=FNR(1):IF RND(1)>=.6 THEN 3000 +2930 D(R1)=D(R1)-(RND(1)*5+1):PRINT"DAMAGE CONTROL REPORT: "; +2960 GOSUB 8790:PRINT G2$;" DAMAGED":PRINT:GOTO 3070 +3000 D(R1)=D(R1)+RND(1)*3+1:PRINT"DAMAGE CONTROL REPORT: "; +3030 GOSUB 8790:PRINT G2$;" STATE OF REPAIR IMPROVED":PRINT +3070 A$=" ":Z1=INT(S1):Z2=INT(S2):GOSUB 8670 +3110 X1=C(C1,1)+(C(C1+1,1)-C(C1,1))*(C1-INT(C1)):X=S1:Y=S2 +3140 X2=C(C1,2)+(C(C1+1,2)-C(C1,2))*(C1-INT(C1)):Q4=Q1:Q5=Q2 +3170 FOR I=1 TO N:S1=S1+X1:S2=S2+X2 +3171 IF S1<1 OR S1>=9 OR S2<1 OR S2>=9 THEN 3500 +3240 S8=INT(S1)*24+INT(S2)*3-26:IF MID$(Q$,S8,2)=" "THEN 3360 +3320 S1=INT(S1-X1):S2=INT(S2-X2):PRINT"WARP ENGINES SHUT DOWN AT "; +3350 PRINT"SECTOR";S1;CHR$(8);",";S2;"DUE TO BAD NAVIGATION":GOTO 3370 +3360 NEXT I:S1=INT(S1):S2=INT(S2) +3370 A$="":Z1=INT(S1):Z2=INT(S2):GOSUB 8670:GOSUB 3910:T8=1 +3430 IF W1<1 THEN T8=.1*INT(10*W1) +3450 T=T+T8:IF T>T0+T9 THEN 6220 +3480 GOTO 1980 +3500 X=8*Q1+X+N*X1:Y=8*Q2+Y+N*X2:Q1=INT(X/8):Q2=INT(Y/8):S1=INT(X-Q1*8) +3550 S2=INT(Y-Q2*8):IF S1=0 THEN Q1=Q1-1:S1=8 +3590 IF S2=0 THEN Q2=Q2-1:S2=8 +3620 X5=0:IF Q1<1 THEN X5=1:Q1=1:S1=1 +3670 IF Q1>8 THEN X5=1:Q1=8:S1=8 +3710 IF Q2<1 THEN X5=1:Q2=1:S2=1 +3750 IF Q2>8 THEN X5=1:Q2=8:S2=8 +3790 IF X5=0 THEN 3860 +3800 PRINT"LT. UHURA: MESSAGE FROM STARFLEET COMMAND --" +3810 PRINT" 'PERMISSION TO ATTEMPT CROSSING OF GALACTIC PERIMETER" +3820 PRINT" IS HEREBY *DENIED*. SHUT DOWN YOUR ENGINES.'" +3830 PRINT"CHIEF ENGINEER SCOTT: 'WARP ENGINES SHUT DOWN" +3840 PRINT" AT SECTOR";S1;CHR$(8);",";S2;"OF QUADRANT"; +3841 PRINT Q1;CHR$(8);",";Q2;CHR$(8);".'" +3850 IF T>T0+T9 THEN 6220 +3860 IF 8*Q1+Q2=8*Q4+Q5 THEN 3370 +3870 T=T+1:GOSUB 3910:GOTO 1320 +3910 E=E-N-10:IF E>=0 THEN RETURN +3930 PRINT"SHIELD CONTROL SUPPLIES ENERGY TO COMPLETE THE MANEUVER." +3940 S=S+E:E=0:IF S<=0 THEN S=0 +3980 RETURN +4000 IF D(3)<0 THEN PRINT"LONG RANGE SENSORS ARE INOPERABLE.":GOTO 1990 +4030 PRINT"LONG RANGE SCAN FOR QUADRANT";Q1;CHR$(8);",";Q2:PRINT +4040 O1$="-------------------":PRINT O1$ +4060 FOR I=Q1-1 TO Q1+1:N(1)=-1:N(2)=-2:N(3)=-3:FOR J=Q2-1 TO Q2+1 +4120 IF I>0 AND I<9 AND J>0 AND J<9 THEN N(J-Q2+2)=G(I,J):Z(I,J)=G(I,J) +4180 NEXT J:FOR L=1 TO 3:PRINT"| "; +4181 IF N(L)<0 THEN PRINT"*** ";:GOTO 4230 +4210 PRINT RIGHT$(STR$(N(L)+1000),3);" "; +4230 NEXT L:PRINT"|":PRINT O1$:NEXT I:GOTO 1990 +4260 IF D(4)<0 THEN PRINT"PHASERS INOPERATIVE.":GOTO 1990 +4265 IF K3>0 THEN 4330 +4270 PRINT"SCIENCE OFFICER SPOCK: 'SENSORS SHOW NO ENEMY SHIPS" +4280 PRINT" IN THIS QUADRANT'":GOTO 1990 +4330 IF D(8)<0 THEN PRINT"COMPUTER FAILURE HAMPERS ACCURACY." +4350 PRINT"PHASERS LOCKED ON TARGET; "; +4360 PRINT"ENERGY AVAILABLE =";E;"UNITS" +4370 INPUT"NUMBER OF UNITS TO FIRE";X:IF X<=0 THEN 1990 +4400 IF E-X<0 THEN 4360 +4410 E=E-X:IF D(7)<0 THEN X=X*RND(1) +4450 H1=INT(X/K3):FOR I=1 TO 3:IF K(I,3)<=0 THEN 4670 +4480 H=INT((H1/FND(0))*(RND(1)+2)):IF H>.15*K(I,3)THEN 4530 +4500 PRINT"SENSORS SHOW NO DAMAGE TO ENEMY AT";K(I,1);CHR$(8); +4501 PRINT",";K(I,2);CHR$(8);".":GOTO 4670 +4530 K(I,3)=K(I,3)-H:PRINT H;"UNIT HIT ON KLINGON AT SECTOR"; +4531 PRINT K(I,1);CHR$(8);","; +4550 PRINT K(I,2);CHR$(8);".":IF K(I,3)<=0 THEN PRINT:PRINT CHR$(22); +4551 PRINT"*** KLINGON DESTROYED ***";CHR$(22):PRINT:GOTO 4580 +4560 PRINT" (SENSORS SHOW";K(I,3);"UNITS REMAINING)":GOTO 4670 +4580 K3=K3-1:K9=K9-1:Z1=K(I,1):Z2=K(I,2):A$=" ":GOSUB 8670 +4650 K(I,3)=0:G(Q1,Q2)=G(Q1,Q2)-100:Z(Q1,Q2)=G(Q1,Q2):IF K9<=0 THEN 6370 +4670 NEXT I:GOSUB 6000:GOTO 1990 +4700 IF P<=0 THEN PRINT"ALL PHOTON TORPEDOES EXPENDED.":GOTO 1990 +4730 IF D(5)<0 THEN PRINT"PHOTON TUBES ARE NOT OPERATIONAL.":GOTO 1990 +4760 INPUT"PHOTON TORPEDO COURSE (1-9)";C1:IF C1=9 THEN C1=1 +4780 IF C1>=1 AND C1<9 THEN 4850 +4790 PRINT"ENSIGN CHEKOV: 'INCORRECT COURSE DATA, SIR!'" +4800 GOTO 1990 +4850 X1=C(C1,1)+(C(C1+1,1)-C(C1,1))*(C1-INT(C1)):E=E-2:P=P-1 +4860 X2=C(C1,2)+(C(C1+1,2)-C(C1,2))*(C1-INT(C1)):X=S1:Y=S2 +4910 PRINT"TORPEDO TRACK:" +4920 X=X+X1:Y=Y+X2:X3=INT(X+.5):Y3=INT(Y+.5) +4960 IF X3<1 OR X3>8 OR Y3<1 OR Y3>8 THEN 5490 +5000 PRINT" ";X3;CHR$(8);",";Y3:A$=" ":Z1=X:Z2=Y +5001 GOSUB 8830 +5050 IF Z3<>0 THEN 4920 +5060 A$="+K+":Z1=X:Z2=Y:GOSUB 8830:IF Z3=0 THEN 5210 +5110 PRINT:PRINT CHR$(22);"*** KLINGON DESTROYED ***";CHR$(22) +5111 PRINT:K3=K3-1:K9=K9-1:IF K9<=0 THEN 6370 +5150 FOR I=1 TO 3:IF X3=K(I,1)AND Y3=K(I,2)THEN 5190 +5180 NEXT I:I=3 +5190 K(I,3)=0:GOTO 5430 +5210 A$=" * ":Z1=X:Z2=Y:GOSUB 8830:IF Z3=0 THEN 5280 +5260 PRINT"STAR AT";X3;",";Y3;"ABSORBED TORPEDO ENERGY.":GOSUB 6000 +5261 GOTO 1990 +5280 A$=">!<":Z1=X:Z2=Y:GOSUB 8830:IF Z3=0 THEN 4760 +5330 PRINT CHR$(22);"*** STARBASE DESTROYED ***";CHR$(22) +5331 B3=B3-1:B9=B9-1 +5360 IF B9>0 OR K9>T-T0-T9 THEN 5400 +5370 PRINT"THAT DOES IT, CAPTAIN!! YOU ARE HEREBY RELIEVED OF COMMAND" +5380 PRINT"AND SENTENCED TO 99 STARDATES AT HARD LABOR ON CYGNUS 12!!" +5390 GOTO 6270 +5400 PRINT"STARFLEET COMMAND REVIEWING YOUR RECORD TO CONSIDER" +5410 PRINT"COURT MARTIAL!":D0=0 +5430 Z1=X:Z2=Y:A$=" ":GOSUB 8670 +5470 G(Q1,Q2)=K3*100+B3*10+S3:Z(Q1,Q2)=G(Q1,Q2):GOSUB 6000:GOTO 1990 +5490 PRINT"TORPEDO MISSED.":PRINT:GOSUB 6000:GOTO 1990 +5530 IF D(7)<0 THEN PRINT"SHIELD CONTROL INOPERABLE.":GOTO 1990 +5560 PRINT"ENERGY AVAILABLE =";E+S;:INPUT"NUMBER OF UNITS TO SHIELDS";X +5580 IF X<0 OR S=X THEN PRINT"":GOTO 1990 +5590 IF X<=E+S THEN 5630 +5600 PRINT"SHIELD CONTROL: 'THIS IS NOT THE FEDERATION TREASURY.'" +5610 PRINT"":GOTO 1990 +5630 E=E+S-X:S=X:PRINT"DEFLECTOR CONTROL ROOM:" +5660 PRINT" 'SHIELDS NOW AT";INT(S);"UNITS PER YOUR COMMAND.'" +5661 GOTO 1990 +5690 IF D(6)>=0 THEN 5910 +5700 PRINT"DAMAGE CONTROL REPORT NOT AVAILABLE.":IF D0=0 THEN 1990 +5720 D3=0:FOR I=1 TO 8:IF D(I)<0 THEN D3=D3+.1 +5760 NEXT I:IF D3=0 THEN 1990 +5780 PRINT:D3=D3+D4:IF D3>=1 THEN D3=.9 +5810 PRINT"TECHNICIANS STANDING BY TO EFFECT REPAIRS TO YOUR SHIP;" +5820 PRINT"ESTIMATED TIME TO REPAIR:";.01*INT(100*D3);"STARDATES." +5840 INPUT"WILL YOU AUTHORIZE THE REPAIR ORDER (Y/N)";A$ +5860 IF A$<>"Y"THEN 1990 +5870 FOR I=1 TO 8:IF D(I)<0 THEN D(I)=0 +5890 NEXT I:T=T+D3+.1 +5910 PRINT:PRINT"DEVICE STATE OF REPAIR" +5911 PRINT"------ ---------------":FOR R1=1 TO 8 +5920 GOSUB 8790:PRINT G2$;LEFT$(Z$,25-LEN(G2$));INT(D(R1)*100)*.01 +5950 NEXT R1:PRINT:IF D0<>0 THEN 5720 +5980 GOTO 1990 +6000 IF K3<=0 THEN RETURN +6010 IF D0<>0 THEN PRINT"STARBASE SHIELDS PROTECT THE ENTERPRISE." +6011 RETURN +6040 FOR I=1 TO 3:IF K(I,3)<=0 THEN 6200 +6060 H=INT((K(I,3)/FND(1))*(2+RND(1))) +6061 S=S-H:K(I,3)=K(I,3)/(3+RND(0)) +6080 PRINT:PRINT H;"UNIT HIT ON ENTERPRISE FROM SECTOR"; +6081 PRINT K(I,1);CHR$(8);",";K(I,2);CHR$(8);"." +6090 IF S<=0 THEN 6240 +6100 PRINT" ":IF H<20 THEN 6200 +6120 IF RND(1)>.6 OR H/S<=.02 THEN 6200 +6140 R1=FNR(1):D(R1)=D(R1)-H/S-.5*RND(1):GOSUB 8790 +6170 PRINT"DAMAGE CONTROL: '";G2$;" DAMAGED BY THE HIT'" +6200 NEXT I:RETURN +6220 PRINT:PRINT"IT IS STARDATE";T;CHR$(8);".":PRINT:GOTO 6270 +6240 PRINT:PRINT"THE ENTERPRISE HAS BEEN DESTROYED. THE FEDERATION "; +6250 PRINT"WILL BE CONQUERED.":GOTO 6220 +6270 PRINT"THERE WERE";K9;"KLINGON BATTLE CRUISERS LEFT AT" +6280 PRINT"THE END OF YOUR MISSION." +6290 PRINT:PRINT:IF B9=0 THEN 6360 +6310 PRINT"THE FEDERATION IS IN NEED OF A NEW STARSHIP COMMANDER" +6320 PRINT"FOR A SIMILAR MISSION -- IF THERE IS A VOLUNTEER," +6330 INPUT"LET HIM STEP FORWARD AND ENTER 'AYE'";A$:IF A$="AYE"THEN 10 +6360 PRINT:PRINT "BACK TO SYSTEM.":END +6370 PRINT"CONGRATULATIONS, CAPTAIN! THE LAST KLINGON BATTLE CRUISER" +6380 PRINT"MENACING THE FEDERATION HAS BEEN DESTROYED.":PRINT +6400 PRINT"YOUR EFFICIENCY RATING IS";1000*(K7/(T-T0))^2:GOTO 6290 +6430 FOR I=S1-1 TO S1+1:FOR J=S2-1 TO S2+1 +6450 IF INT(I+.5)<1 OR INT(I+.5)>8 THEN 6540 +6451 IF INT(J+.5)<1 OR INT(J+.5)>8 THEN 6540 +6490 A$=">B<":Z1=I:Z2=J:GOSUB 8830:IF Z3=1 THEN 6580 +6540 NEXT J:NEXT I:D0=0:GOTO 6650 +6580 D0=1:C$="DOCKED":E=E0:P=P0 +6620 PRINT"SHIELDS DROPPED FOR DOCKING PURPOSES.":S=0:GOTO 6720 +6650 IF K3>0 THEN C$="*RED*":GOTO 6720 +6660 C$="GREEN":IF E=0 THEN 6770 +6730 PRINT:PRINT"*** SHORT RANGE SENSORS ARE OUT ***":PRINT:RETURN +6770 O1$=" +--1---2---3---4---5---6---7---8-+":PRINT O1$ +6771 FOR I=1 TO 8:PRINT I;"|"; +6820 FOR J=(I-1)*24+1 TO(I-1)*24+22 STEP 3:PRINT" ";MID$(Q$,J,3); +6821 NEXT J:PRINT"|";I; +6830 ON I GOTO 6850,6900,6960,7020,7070,7120,7180,7240 +6850 PRINT" STARDATE ";:PRINT INT(T*10)*.1 +6851 GOTO 7260 +6900 PRINT" CONDITION "; +6901 IF C$="*RED*" THEN PRINT CHR$(22);"*RED*";CHR$(22):GOTO 7260 +6902 IF C$="DOCKED" THEN PRINT CHR$(22);"DOCKED";CHR$(22):GOTO 7260 +6903 PRINT C$: GOTO 7260 +6960 PRINT" QUADRANT ";Q1;CHR$(8);",";Q2;CHR$(8) +6961 GOTO 7260 +7020 PRINT" SECTOR ";S1;CHR$(8);",";S2;CHR$(8) +7021 GOTO 7260 +7070 PRINT" PHOTON TORPEDOES ";:PRINT INT(P) +7071 GOTO 7260 +7120 PRINT" TOTAL ENERGY ";:PRINT INT(E+S) +7121 GOTO 7260 +7180 PRINT" SHIELDS ";:PRINT INT(S) +7181 GOTO 7260 +7240 PRINT" KLINGONS REMAINING";:PRINT INT(K9) +7260 NEXT I:PRINT O1$:RETURN +7290 IF D(8)<0 THEN PRINT"COMPUTER DISABLED.":GOTO 1990 +7320 INPUT"COMPUTER ACTIVE AND AWAITING COMMAND";A:IF A<0 THEN 1990 +7350 PRINT:H8=1:ON A+1 GOTO 7540,7900,8070,8500,8150,7400 +7360 PRINT"FUNCTIONS AVAILABLE FROM LIBRARY-COMPUTER:" +7365 PRINT "-----------------------------------------":PRINT +7370 PRINT" 0 = CUMULATIVE GALTIC RECORD" +7372 PRINT" 1 = STATUS REPORT" +7374 PRINT" 2 = PHOTON TORPEDO DATA" +7376 PRINT" 3 = STARBASE NAV DATA" +7378 PRINT" 4 = DIRECTION/DISTANCE CALCULATOR" +7380 PRINT" 5 = GALAXY 'REGION NAME' MAP":PRINT:GOTO 7320 +7400 H8=0:G5=1:PRINT" THE GALAXY":GOTO 7550 +7540 REM +7542 REM +7543 PRINT:PRINT" "; +7544 PRINT"COMPUTER RECORD OF GALAXY FOR QUADRANT";Q1;CHR$(8);",";Q2 +7546 PRINT +7550 PRINT" 1 2 3 4 5 6 7 8" +7560 O1$=" +-----+-----+-----+-----+-----+-----+-----+-----+" +7570 PRINT O1$:FOR I=1 TO 8:PRINT I;" ";:IF H8=0 THEN 7740 +7630 FOR J=1 TO 8:PRINT"| ";:IF Z(I,J)=0 THEN PRINT"*** ";:GOTO 7720 +7700 PRINT RIGHT$(STR$(Z(I,J)+1000),3);" "; +7720 IF J=8 THEN PRINT "|" +7721 NEXT J:GOTO 7850 +7740 Z4=I:Z5=1:GOSUB 9030:J0=INT(15-.5*LEN(G2$)):PRINT TAB(J0);G2$; +7800 Z5=5:GOSUB 9030:J0=INT(39-.5*LEN(G2$)):PRINT TAB(J0);G2$ +7850 PRINT O1$:NEXT I:PRINT:GOTO 1990 +7900 PRINT " STATUS REPORT:":PRINT " -------------":X$="" +7901 IF K9>1 THEN X$="S" +7940 PRINT K9;"KLINGON";X$;" LEFT." +7960 PRINT" MISSION MUST BE COMPLETED IN";.1*INT((T0+T9-T)*10); +7961 PRINT"STARDATES." +7970 X$="S":IF B9<2 THEN X$="":IF B9<1 THEN 8010 +7980 PRINT" THE FEDERATION IS MAINTAINING";B9; +7981 PRINT"STARBASE";X$;" IN THE GALAXY." +7990 GOTO 5690 +8010 PRINT"YOUR STUPIDITY HAS LEFT YOU ON YOUR OWN IN" +8020 PRINT" THE GALAXY -- YOU HAVE NO STARBASES LEFT!":GOTO 5690 +8070 IF K3<=0 THEN 4270 +8080 X$="":IF K3>1 THEN X$="S" +8090 PRINT"FROM ENTERPRISE TO KLINGON BATTLE CRUSER";X$ +8100 H8=0:FOR I=1 TO 3:IF K(I,3)<=0 THEN 8480 +8110 W1=K(I,1):X=K(I,2) +8120 C1=S1:A=S2:GOTO 8220 +8150 PRINT"DIRECTION/DISTANCE CALCULATOR:" +8160 PRINT"YOU ARE AT QUADRANT ";Q1;CHR$(8);",";Q2;" SECTOR "; +8161 PRINT S1;CHR$(8);",";S2;CHR$(8);"." +8170 INPUT"PLEASE ENTER INITIAL COORDINATES (X,Y)";C1,A +8200 INPUT"FINAL COORDINATES (X,Y)";W1,X +8220 X=X-A:A=C1-W1:IF X<0 THEN 8350 +8250 IF A<0 THEN 8410 +8260 IF X>0 THEN 8280 +8270 IF A=0 THEN C1=5:GOTO 8290 +8280 C1=1 +8290 IF ABS(A)<=ABS(X)THEN 8330 +8310 PRINT"DIRECTION =";C1+(((ABS(A)-ABS(X))+ABS(A))/ABS(A)):GOTO 8460 +8330 PRINT"DIRECTION =";C1+(ABS(A)/ABS(X)):GOTO 8460 +8350 IF A>0 THEN C1=3:GOTO 8420 +8360 IF X<>0 THEN C1=5:GOTO 8290 +8410 C1=7 +8420 IF ABS(A)>=ABS(X)THEN 8450 +8430 PRINT"DIRECTION =";C1+(((ABS(X)-ABS(A))+ABS(X))/ABS(X)):GOTO 8460 +8450 PRINT"DIRECTION =";C1+(ABS(X)/ABS(A)) +8460 PRINT"DISTANCE =";SQR(X^2+A^2):IF H8=1 THEN 1990 +8480 NEXT I:GOTO 1990 +8500 IF B3<>0 THEN PRINT"FROM ENTERPRISE TO STARBASE:" +8501 W1=B4:X=B5:GOTO 8120 +8510 PRINT"MR. SPOCK: 'SENSORS SHOW NO STARBASES IN THIS QUADRANT.'""; +8520 GOTO 1990 +8590 R1=FNR(1):R2=FNR(1):A$=" ":Z1=R1:Z2=R2:GOSUB 8830 +8591 IF Z3=0 THEN 8590 +8600 RETURN +8670 S8=INT(Z2-.5)*3+INT(Z1-.5)*24+1 +8675 IF LEN(A$)<>3 THEN PRINT"ERROR":STOP +8680 IF S8=1 THEN Q$=A$+RIGHT$(Q$,189):RETURN +8690 IF S8=190 THEN Q$=LEFT$(Q$,189)+A$:RETURN +8700 Q$=LEFT$(Q$,S8-1)+A$+RIGHT$(Q$,190-S8):RETURN +8790 ON R1 GOTO 8792,8794,8796,8798,8800,8802,8804,8806 +8792 G2$="WARP ENGINES":RETURN +8794 G2$="SHORT RANGE SENSORS":RETURN +8796 G2$="LONG RANGE SENSORS":RETURN +8798 G2$="PHASER CONTROL":RETURN +8800 G2$="PHOTON TUBES":RETURN +8802 G2$="DAMAGE CONTROL":RETURN +8804 G2$="SHIELD CONTROL":RETURN +8806 G2$="LIBRARY-COMPUTER":RETURN +8830 Z1=INT(Z1+.5):Z2=INT(Z2+.5):S8=(Z2-1)*3+(Z1-1)*24+1:Z3=0 +8890 IF MID$(Q$,S8,3)<>A$THEN RETURN +8900 Z3=1:RETURN +9030 IF Z5<=4 THEN ON Z4 GOTO 9040,9050,9060,9070,9080,9090,9100,9110 +9035 GOTO 9120 +9040 G2$="ANTARES":GOTO 9210 +9050 G2$="RIGEL":GOTO 9210 +9060 G2$="PROCYON":GOTO 9210 +9070 G2$="VEGA":GOTO 9210 +9080 G2$="CANOPUS":GOTO 9210 +9090 G2$="ALTAIR":GOTO 9210 +9100 G2$="SAGITTARIUS":GOTO 9210 +9110 G2$="POLLUX":GOTO 9210 +9120 ON Z4 GOTO 9130,9140,9150,9160,9170,9180,9190,9200 +9130 G2$="SIRIUS":GOTO 9210 +9140 G2$="DENEB":GOTO 9210 +9150 G2$="CAPELLA":GOTO 9210 +9160 G2$="BETELGEUSE":GOTO 9210 +9170 G2$="ALDEBARAN":GOTO 9210 +9180 G2$="REGULUS":GOTO 9210 +9190 G2$="ARCTURUS":GOTO 9210 +9200 G2$="SPICA" +9210 IF G5<>1 THEN ON Z5 GOTO 9230,9240,9250,9260,9230,9240,9250,9260 +9220 RETURN +9230 G2$=G2$+" I":RETURN +9240 G2$=G2$+" II":RETURN +9250 G2$=G2$+" III":RETURN +9260 G2$=G2$+" IV":RETURN +9999 END diff --git a/software/BAS/STARWARS.BAS b/software/BAS/STARWARS.BAS new file mode 100644 index 0000000..d6decce --- /dev/null +++ b/software/BAS/STARWARS.BAS @@ -0,0 +1,302 @@ +10 REM ---DESIGNED TO RUN ON HEATH H19/H89--- +900 WIDTH 80 +1000 LET E$=CHR$(27):PRINT E$;"F";E$;"E";E$;"x5";E$;"Y#'"; +1010 PRINT TAB(18);E$;"F";"faaqaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaac" +1020 PRINT TAB(18);"`";SPC(43);"`" +1030 PRINT TAB(18);"` 'S T A R W A R S' `" +1040 PRINT TAB(18);"`";SPC(43);"`" +1050 PRINT TAB(18);"`";E$;"G";" This program presented courtesy of "; +1060 PRINT E$;"F";"`" +1070 PRINT TAB(18);"`";SPC(43);"`" +1080 PRINT TAB(18);"`";E$;"p";" C U S T O M S O F T W A R E G R O U P "; +1090 PRINT E$;"q";"`" +1100 PRINT TAB(18);"`";SPC(43);"`" +1110 PRINT TAB(18);"`";E$;"G";" Specializing in custom programming for "; +1120 PRINT E$"F";"`" +1130 PRINT TAB(18);"` HEATH/ZENITH DATA SYSTEMS `" +1140 PRINT TAB(18);"`";SPC(43);"`" +1150 PRINT TAB(18);"` CUSTOM SOFTWARE GROUP `" +1160 PRINT TAB(18);"` POST OFFICE BOX `" +1170 PRINT TAB(18);"` BELLEVUE, NE 68005 `" +1180 PRINT TAB(18);"` PHONE 291-4622 `" +1190 PRINT TAB(18);"` 291-5819 `" +1200 PRINT TAB(18);"`";SPC(43);"`" +1210 PRINT TAB(18);"eaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaad";E$;"G" +1220 PRINT TAB(28);"PRESS RETURN TO CONTINUE" +1230 A$=INPUT$(1) +1240 PRINT CHR$(27);"G";CHR$(27);"w" +1250 CLEAR 1000 +1260 PRINT CHR$(27);"E";CHR$(27);"Y! ";CHR$(27);"x5" +1270 PRINT ," ******** ********** ****** *********" +1280 PRINT ," ** ** ** ** ** ** **" +1290 PRINT ," ** ** ** ** ** **" +1300 PRINT ," ******** ** ********** *********" +1310 PRINT ," ** ** ** ** ** **" +1320 PRINT ," ** ** ** ** ** ** **" +1330 PRINT ," ******** ** ** ** ** **" +1340 PRINT:PRINT +1350 PRINT ," ** ** ****** ********* ********" +1360 PRINT ," ** ** ** ** ** ** ** **" +1370 PRINT ," ** ** ** ** ** ** **" +1380 PRINT ," ** ** ** ********** ********* ********" +1390 PRINT ," ** ** ** ** ** ** ** **" +1400 PRINT ," ******** ** ** ** ** ** **" +1410 PRINT ," ** ** ** ** ** ** ********" +1420 FOR I=1 TO 1000:NEXT I +1430 PRINT CHR$(27);"Y7 " +1440 PRINT ,"A LONG TIME AGO IN A GALAXY FAR, FAR AWAY, A GREAT" +1450 FOR I=1 TO 1000:NEXT I:PRINT +1460 PRINT ,"ADVENTURE TOOK PLACE. IT IS A PERIOD OF CIVIL WAR." +1470 FOR I=1 TO 1000:NEXT I:PRINT +1480 PRINT ,"REBEL SPACE SHIPS STRIKING FROM A HIDDEN BASE HAVE" +1490 FOR I=1 TO 1000:NEXT I:PRINT +1500 PRINT ,"WON THEIR FIRST VICTORY AGAINST THE EVIL GALACTIC" +1510 FOR I=1 TO 1000:NEXT I:PRINT +1520 PRINT ,"EMPIRE. DURING THE BATTLE, REBEL SPYS MANAGED TO" +1530 FOR I=1 TO 1000:NEXT I:PRINT +1540 PRINT ,"STEAL SECRET PLANS TO THE EMPIRE'S ULITMATE WEAPON" +1550 FOR I=1 TO 1000:NEXT I:PRINT +1560 PRINT ,"THE DEATH STAR, AN ARMOURED SPACE STATION WITH THE" +1570 FOR I=1 TO 1000:NEXT I:PRINT +1580 PRINT ,"FIRE POWER TO DESTROY AN ENTIRE PLANET. " +1590 FOR I=1 TO 1000:NEXT I:PRINT:PRINT +1600 PRINT ," YOUR MISSION AS ONE OF THE REBEL PILOTS IS TO" +1610 FOR I=1 TO 1000:NEXT I:PRINT +1620 PRINT ,"ATTACK AND DESTROY THE 'DEATH STAR'. WHILE MAKING" +1630 FOR I=1 TO 1000:NEXT I:PRINT +1640 PRINT ,"YOUR ATTACK YOU HAVE ENCOUNTERED 'DARTH VADER' AND" +1650 FOR I=1 TO 1000:NEXT I:PRINT +1660 PRINT ,"HIS IMPERIAL STORM TROOPERS IN THEIR TIE FIGHTERS." +1670 FOR I=1 TO 1000:NEXT I:PRINT +1680 PRINT ,"YOU MUST DESTROY THEM BEFORE THEY CAN DESTROY YOU." +1690 FOR I=1 TO 1000:NEXT I:PRINT:PRINT +1700 PRINT ," GOOD LUCK AND MAY THE 'FORCE' BE WITH YOU " +1710 FOR I=1 TO 2000:NEXT I +1720 REM +1730 REM .........................INSTRUCTIONS ROUTINE....................... +1740 REM +1750 PRINT CHR$(27);"E";CHR$(27);"Y*6";"DO YOU NEED:":PRINT +1760 PRINT TAB(30);"FULL INSTRUCTIONS ?" +1770 PRINT TAB(30);"BRIEF INSTRUCTIONS ?" +1780 PRINT TAB(30);"NO INSTRUCTIOnS ?" +1790 A$=INPUT$(1):IF A$="F" THEN 1870 +1800 IF A$="B" THEN 2270 +1810 IF A$="N" THEN 1820 ELSE 1790 +1820 PRINT:PRINT TAB(29);"WHAT IS YOUR SKILL RATING?" +1830 A$=INPUT$(1):IF A$<"1" OR A$>"9" THEN 1850 +1840 LET A$=A$+"0":LET A9=CVI(A$):LET A9=A9-12336:GOTO 2540 +1850 PRINT:PRINT TAB(26);"EVIDENTLY YOU NEED INSTRUCTIONS!" +1860 FOR I=1 TO 500:NEXT I:PRINT +1870 PRINT CHR$(27);"E";CHR$(27);"Y! " +1880 PRINT "YOU HAVE BEEN EQUIPPED WITH AN X-WING "; +1890 PRINT " AS IN A REAL DOG-FIGHT YOU MUST LEAD" +1900 PRINT "FIGHTER BY THE REBEL ALLIANCE. YOUR "; +1910 PRINT " THE TARGET WHEN FIRING YOUR LASER. IF" +1920 PRINT "FIGHTER IS COMPUTER CONTROLLED BY THE "; +1930 PRINT " YOU WAIT UNTIL HE IS EXACTLY CENTERED" +1940 PRINT "NUMERIC KEYPAD ON YOUR KEY BOARD. THE "; +1950 PRINT " TO FIRE, THEN YOU WILL MISS HIM. YOU" +1960 PRINT "DISPLAY YOU WILL SEE IS YOUR ONBOARD "; +1970 PRINT " MAY CONTINUE TO FIRE AT HIM, BUT WHEN" +1980 PRINT "SCANNER. IN ORDER TO KILL AN ENEMY "; +1990 PRINT " YOU ARE FIRING YOUR WEAPON, YOUR CON-" +2000 PRINT "FIGHTER HE MUST RECEIVE A DIRECT HIT "; +2010 PRINT " TROL OF DIRECTION IS NOT AS GOOD AS" +2020 PRINT "OR MULTIPLE DAMAGING HITS. HE WILL "; +2030 PRINT " WHEN YOU AREN'T FIRING AND THE TARGET" +2040 PRINT "RECEIVE DAMAGE IF HIT WHEN HE IS +/- "; +2050 PRINT " MAY FLY OUT OF YOUR SIGHTS. " +2060 PRINT "10 DEGREES IN ELEVATION AND HE IS +/- "; +2070 PRINT " " +2080 PRINT "9 DEGREES IN BEARING. IN ADDITION TO "; +2090 PRINT " IN ORDER TO CENTER YOUR TARGET ON THE" +2100 PRINT "THIS HE MUST BE WITHIN 6500 KMS. "; +2110 PRINT " SCANNER YOU MUST FLY TOWARDS HIM. TO" +2120 PRINT " "; +2130 PRINT " TO DO THIS YOU PRESS THE KEY ON THE" +2140 PRINT "WARNING: THE 'TIE' FIGHTER HAS THE "; +2150 PRINT " NUMERIC KEY PAD THAT IS IN HIS DIREC-" +2160 PRINT "CAPABILITY TO POP IN AND OUT OF HYP- "; +2170 PRINT " TION. IE: IF HE IS IN THE UPPER-RIGHT" +2180 PRINT "ERSPACE. THEREFORE HE MAY DISAPPEAR "; +2190 PRINT " QUADRANT YOU WOULD PRESS KEY 9 TO FLY" +2200 PRINT "RIGHT FROM BEFORE YOUR SIGHTS. "; +2210 PRINT " TOWARDS HIM. IF HE IS BELOW, PRESS 2." +2220 PRINT " "; +2230 PRINT " " +2240 PRINT " MAY THE FORCE BE WITH YOU "; +2250 PRINT " PRESS RETURN TO CONT "; +2260 LINE INPUT A$ +2270 PRINT CHR$(27);"E" +2280 PRINT CHR$(27);"F"; +2290 PRINT ," UP & UP UP &" +2300 PRINT ," LEFT faaaaac faaaaac faaaaac RIGHT" +2310 PRINT ," ` 7 ` ` 8 ` ` 9 `" +2320 PRINT ," eaaaaad eaaaaad eaaaaad" +2330 PRINT ," faaaaac faaaaac faaaaac" +2340 PRINT ," LEFT ` 4 ` ` 5 ` ` 6 ` RIGHT" +2350 PRINT ," eaaaaad eaaaaad eaaaaad" +2360 PRINT ," faaaaac faaaaac faaaaac" +2370 PRINT ," ` 1 ` ` 2 ` ` 3 `" +2380 PRINT ," DOWN eaaaaad eaaaaad eaaaaad RIGHT" +2390 PRINT ," LEFT faaaaac DOWN DOWN" +2400 PRINT ," ` 0 `" +2410 PRINT ," eaaaaad" +2420 PRINT ," FIRE" +2430 PRINT CHR$(27);"G" +2440 PRINT TAB(18);"<>":PRINT +2450 PRINT TAB(23);"ENTER A SKILL RATING FROM 1 TO 9" +2460 PRINT TAB(27);"NOVICE.................1" +2470 PRINT TAB(27);"EXPERT.................9":PRINT +2480 PRINT "AFTER SCANNER CONSTRUCTION IS COMPLETE, PRESS ANY CONTROL KEY TO" +2485 PRINT "START YOUR SCAN" +2490 A$=INPUT$(1):IF A$<"1" OR A$>"9" THEN 2490 +2500 LET A$=A$+"0":LET A9=CVI(A$):LET A9=A9-12336 +2510 REM +2520 REM ......................GRID CONSTRUCTION ROUTINE.................... +2530 REM +2540 PRINT CHR$(27);"F";CHR$(27);"x1";CHR$(27);"x5":PRINT CHR$(27);"E"; +2550 PRINT TAB(16);"RANGE:g9999 KM ELEVATION:g90 DEG BEARING:g90 DEG" +2560 PRINT:ED=0 +2570 PRINT TAB(8);"-90 -75 -60 -45 -30 -15 0 +15 +30 +45 +60 +75 +90" +2580 PRINT TAB(5);"+90 bssssbssssbssssbssssbssssbssssbssssbssssbssssbssssbssssbssssb +90" +2590 PRINT TAB(9);"v";SPC(59);"t":PRINT TAB(9);"v";SPC(59);"t" +2600 PRINT TAB(5);"+60 b";SPC(59);"b +60" +2610 PRINT TAB(9);"v";SPC(59);"t":PRINT TAB(9);"v";SPC(59);"t" +2620 PRINT TAB(5);"+30 b";SPC(59);"b +30" +2630 PRINT TAB(9);"v";SPC(59);"t":PRINT TAB(9);"v";SPC(59);"t" +2640 PRINT TAB(6);"0 b";SPC(59);"b 0" +2650 PRINT TAB(9);"v";SPC(59);"t":PRINT TAB(9);"v";SPC(59);"t" +2660 PRINT TAB(5);"-30 b";SPC(59);"b -30" +2670 PRINT TAB(9);"v";SPC(59);"t":PRINT TAB(9);"v";SPC(59);"t" +2680 PRINT TAB(5);"-60 v";SPC(59);"t -60" +2690 PRINT TAB(9);"v";SPC(59);"t":PRINT TAB(9);"v";SPC(59);"t" +2700 PRINT " -90 buuuubuuuubuuuubuuuubuuuubuuuubuuuubuuuubuuuubuuuubuuuubuuuub -90" +2710 PRINT " -90 -75 -60 -45 -30 -15 0 +15 +30 +45 +60 +75 +90" +2720 REM +2730 REM ......................INPUT CONTROL SCAN ROUTINE................... +2740 REM +2750 CD=200+INT(200*RND(1)):FL$="5" +2760 IF CT=CD THEN 3910 ELSE CT=CT+1 +2770 IF FL$="0" THEN 2950 +2780 IF INP(17)=48 AND FL$<>"0" THEN FL$=INPUT$(1) +2790 IF INP(17)=49 AND FL$<>"1" THEN FL$=INPUT$(1) +2800 IF INP(17)=50 AND FL$<>"2" THEN FL$=INPUT$(1) +2810 IF INP(17)=51 AND FL$<>"3" THEN FL$=INPUT$(1) +2820 IF INP(17)=52 AND FL$<>"4" THEN FL$=INPUT$(1) +2830 IF INP(17)=53 AND FL$<>"5" THEN FL$=INPUT$(1) +2840 IF INP(17)=54 AND FL$<>"6" THEN FL$=INPUT$(1) +2850 IF INP(17)=55 AND FL$<>"7" THEN FL$=INPUT$(1) +2860 IF INP(17)=56 AND FL$<>"8" THEN FL$=INPUT$(1) +2870 IF INP(17)=57 AND FL$<>"9" THEN FL$=INPUT$(1) +2880 IF INP(17)<48 OR INP(17)>57 AND DM$<>CHR$(INP(17)) THEN DM$=INPUT$(1) +2890 GOSUB 3340:REM ..FIGHTER UPDATE +2900 PRINT CHR$(27);"Y&3+";CHR$(27);"Y23+";CHR$(27);"Y)=+";CHR$(27);"Y/=+";CHR$(27);"Y,G+";CHR$(27);"Y)Q+";CHR$(27);"Y/Q+";CHR$(27);"Y&[+";CHR$(27);"Y2[+" +2910 GOTO 2760 +2920 REM +2930 REM .......................FIRE WEAPON ROUTINE........................ +2940 REM +2950 FOR I=8 TO 1 STEP -1 +2960 PRINT CHR$(27);"Y";CHR$(44+I);CHR$(71-I);"x" +2970 PRINT CHR$(27);"Y";CHR$(44+I);CHR$(71+I);"y" +2980 IF I > 6 THEN 3010 +2990 PRINT CHR$(27);"Y";CHR$(46+I);CHR$(69-I);" " +3000 PRINT CHR$(27);"Y";CHR$(46+I);CHR$(73+I);" " +3010 NEXT I +3020 PRINT CHR$(27);"Y.E ";CHR$(27);"Y.I ";CHR$(27);"Y-F ";CHR$(27);"Y-H " +3030 IF FX<>44 OR FY<>70 THEN 3190 +3040 IF KM>5000 THEN 2790 +3050 PRINT CHR$(27);"p";CHR$(27);"Y8? ENEMY DESTROYED ":DG=0 +3060 PRINT CHR$(27);"p":ED=ED+1 +3070 PRINT CHR$(27);"Y";CHR$(FX-1);CHR$(FY);"ppp" +3080 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY-1);" " +3090 PRINT CHR$(27);"q";CHR$(27);"Y";CHR$(FX+1);CHR$(FY);"ppp" +3100 FOR I=1 TO 25:PRINT CHR$(7);:NEXT I +3110 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY);"iii" +3120 FOR I=1 TO 25: NEXT I +3130 PRINT CHR$(27);"Y";CHR$(FX-1);CHR$(FY);" " +3140 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY-1);" iii " +3150 PRINT CHR$(27);"Y";CHR$(FX+1);CHR$(FY);" " +3160 FOR I=1 TO 25: NEXT I +3170 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY);" " +3180 FQ=0:IF ED=5 THEN 3860 ELSE 2790 +3190 IF FX<43 OR FX>45 THEN 3310 +3200 IF FY<68 OR FY>72 THEN 3310 +3210 LET DG=DG+1:IF DG=3 THEN 3050 +3220 PRINT CHR$(27);"Y";CHR$(FX-1);CHR$(FY);"iii" +3230 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY-1);"i" +3240 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY+3);"i" +3250 PRINT CHR$(27);"Y";CHR$(FX+1);CHR$(FY);"iii" +3260 FOR I=1 TO 250: NEXT I +3270 PRINT CHR$(27);"Y";CHR$(FX-1);CHR$(FY);" " +3280 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY-1);" " +3290 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY+3);" " +3300 PRINT CHR$(27);"Y";CHR$(FX+1);CHR$(FY);" ":GOTO 2790 +3310 PRINT CHR$(27);"Y8 ";CHR$(27);"l" +3320 GOTO 2790 +3330 REM +3340 REM ...................FIGHTER POSITION UPDATE ROUTINE................ +3350 REM +3360 IF FQ=1 THEN 3430 ELSE FQ=1 +3370 LET FX=INT(100*RND(1)) +3380 IF FX<36 OR FX>52 THEN 3370 +3390 LET FY=INT(200*RND(1)) +3400 IF FY<44 OR FY>97 THEN 3390 +3410 LET KM=INT(10000*RND(1)) +3420 FZ=INT(16*RND(1)) +3430 IF INT(100*RND(1))>6 THEN 3450 +3440 FZ=INT (16*RND(1)) +3450 IF INT(10*RND(1))0 THEN 3470 ELSE X=FX-1:Y=FY+1 +3470 IF FZ<>1 THEN 3480 ELSE S=FX:Y=FY+1 +3480 IF FZ<>2 THEN 3490 ELSE X=FX+1:Y=FY+1 +3490 IF FZ<>3 THEN 3500 ELSE X=FX+1:Y=FY +3500 IF FZ<>4 THEN 3510 ELSE X=FX+1:Y=FY-1 +3510 IF FZ<>5 THEN 3520 ELSE X=FX:Y=FY-1 +3520 IF FZ<>6 THEN 3530 ELSE X=FX-1:Y=FY-1 +3530 IF FZ<>7 THEN 3540 ELSE X=FX-1:Y=FY +3540 IF FZ<>8 THEN 3550 ELSE X=FX-1:Y=FY+2 +3550 IF FZ<>9 THEN 3560 ELSE X=FX-1:Y=FY+3 +3560 IF FZ<>10 THEN 3570 ELSE X=FX+1:Y=FY+3 +3570 IF FZ<>11 THEN 3580 ELSE X=FX+1:Y=FY+2 +3580 IF FZ<>12 THEN 3590 ELSE X=FX+1:Y=FY-2 +3590 IF FZ<>13 THEN 3600 ELSE X=FX+1:Y=FY-3 +3600 IF FZ<>14 THEN 3610 ELSE X=FX-1:Y=FY-3 +3610 IF FZ<>15 THEN 3620 ELSE X=FX-1:Y=FY-2 +3620 IF FL$<>"1" THEN 3630 ELSE X=X-1:Y=Y+1 +3630 IF FL$<>"2" THEN 3640 ELSE X=X-2:Y=Y +3640 IF FL$<>"3" THEN 3650 ELSE X=X-1:Y=Y-1 +3650 IF FL$<>"4" THEN 3660 ELSE X=X:Y=Y+2 +3660 IF FL$<>"6" THEN 3670 ELSE X=X:Y=Y-2 +3670 IF FL$<>"7" THEN 3680 ELSE X=X+1:Y=Y+1 +3680 IF FL$<>"8" THEN 3690 ELSE X=X+2:Y=Y +3690 IF FL$<>"9" THEN 3700 ELSE X=X+1:Y=Y-1 +3700 IF X>39 AND X<50 AND Y>55 AND Y<87 THEN 3740 +3710 IF SGN(KM)=+1 THEN KM=KM+INT(200*RND(1)) +3720 IF SGN(KM)=-1 THEN KM=KM-INT(200*RND(1)) +3730 IF KM<10000 THEN 3760 ELSE 3830 +3740 IF SGN(KM)=+1 THEN KM=KM-INT(200*RND(1)) +3750 IF SGN(KM)=-1 THEN KM=KM+INT(200*RND(1)) +3760 IF X<36 OR X>52 OR Y<42 OR Y>98 THEN 3830 +3770 IF X=FX AND Y=FY THEN RETURN +3780 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY);" ":FX=X:FY=Y +3790 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY);"v^t" +3800 PRINT CHR$(27);"Y 5";KM +3810 EV=10*(44-FX):PRINT CHR$(27);"Y K";EV +3820 BR=3*(FY-70):PRINT CHR$(27);"Y \";BR:RETURN +3830 PRINT CHR$(27);"Y";CHR$(FX);CHR$(FY);" " +3840 FQ=0:RETURN +3850 PRINT CHR$(27);"Y8 ";CHR$(27);"l":RETURN +3860 FOR I=1 TO 500:NEXT I:PRINT CHR$(27);"y1";CHR$(27);"Y ";CHR$(27);"E" +3870 PRINT CHR$(27);"q";CHR$(27);"Y( ";CHR$(27);"G" +3880 PRINT ,"CONGRATULATIONS ON A JOB WELL DONE. YOU HAVE" +3890 PRINT ,"DESTROYED DARTH VADER AND HIS STORM TROOPERS " +3900 PRINT ,"AND HAVE SAVED THE REBELLION.":GOTO 3950 +3910 PRINT CHR$(27);"E";CHR$(27);"Y( " +3920 PRINT ,"YOU HAVE ONLY DESTROYED";ED;"TIE FIGHTERS AND";CHR$(27);"y1" +3930 PRINT ,"YOU LET DARTH VADER GET AWAY. OH WELL,I GUESS";CHR$(27);"G" +3940 PRINT ,"WE WANT HIM AROUND FOR THE SEQUEL ANYWAY!" +3950 PRINT:PRINT ,"DO YOU WANT TO PLAY AGAIN ?" +3960 A$=INPUT$(1):IF A$="Y"THEN 1820ELSE IF A$<>"N"THEN 3960ELSE 1000 +950 PRINT:PRINT ,"DO YOU WANT TO PLAY AGAIN ?" +3960 A$=INPUT$(1):IF A$="Y"THEN 1820ELSE IF A$<> \ No newline at end of file diff --git a/software/BAS/STRTRK#2.bas b/software/BAS/STRTRK#2.bas new file mode 100644 index 0000000..4e8ace0 --- /dev/null +++ b/software/BAS/STRTRK#2.bas @@ -0,0 +1,546 @@ +1000 'EXPANDED APRIL 1977 BY W.A.BURTON +1001 'PIRATED JAN. 1978 BY ZOSO +1002 DIM G(8,8),S(8,8),K(3,3) +1003 PRINTCHR$(26) +1004 PRINT TAB(21)"--STARTREK--":PRINT +1005 PRINT +1006 INPUT "WHAT IS YOUR SECURITY CLEARANCE NUMBER (1 TO 1000)";T9 +1007 E8=T9 +1008 IF T9<1 OR T9>1000 THEN PRINT AR$;"INVALID!! REENTER!!":GOTO 1006 +1009 FOR A=1 TO T9/2 +1010 R9=RND(1):R9=RND(2) +1011 NEXT +1012 CLEAR:PRINTCHR$(26):INPUT" ENTER RANK (1=LOW,12=HIGH)";R9 +1013 RR=R9 +1014 X4=R9:R9=R9+1E-03:W1=W1+1E-03 +1015 PRINT CHR$(26) +1016 PRINT "COMMAND ORDER : STAND BY !" +1017 PRINT "YOU ARE PRESENTLY BEING ASSIGNED TO A MISSION..." +1018 PRINT " WITH A FAILURE FACTOR OF"; (RR*20) +1019 PRINT" GOOD-BYE, SIR..." +1020 CX=.017453:AR$=" ---> " +1021 XA=INT(X4*50):AC=(1/(X4+.1)) +1022 IFX4>=9THEN1379 +1023 E=3000-XA+100:P=10:S9=200 +1024 DEF FND(D)=SQR((K(I,1)-S1)^2+(K(I,2)-S2)^2) +1025 Q1=INT(RND(1)*8+1):Q2=INT(RND(1)*8+1) +1026 S1=INT(RND(1)*8+1):S2=INT(RND(1)*8+1) +1027 DATA WARP ENGINES,SHORT RANGE SENSORS,LONG RANGE SENSORS +1028 DATA PHASERS, PHOTON TORPEDOES,SHIELD CONTROL +1029 DATA DAMAGE CONTROL, COMPUTER,DAMAGE REPAIR,COMMUNICATIONS +1030 FOR A=1TO10:READ D$(A):NEXT A +1031 A$(0)=" . ":A$(1)=" E ":A$(2)=" * ":A$(3)=" K ":A$(4)=" B " +1032 F1=.86:F2=.01:F3=.95:F4=.99:K9=0:B9=K9 +1033 FORI=1TO8:FORJ=1TO8:R1=RND(1):R2=RND(1):R3=INT(8*RND(1)+1) +1034 K3=-(R1>F1-F2*R9)-(R1>F3-F2*R9)-(R1>F4-F2*R9):K9=K9+K3 +1035 B3=-(R2>F3):B9=B9+B3:G(I,J)=100*K3+10*B3+R3:NEXTJ,I +1036 IF NOT(B9>0ANDK9>0)THEN1032 +1037 PRINT"OBJECTIVE:DESTROY"K9"KLINGONS USING"B9"STARBASE"; +1038 U=K9:Y=B9 +1039 IFB9=1THENPRINT" ";:GOTO1041 +1040 PRINT"S "; +1041 T9=K9+RND(1)*K9/R9+10-R9:PR=T9/K9:PRINT"IN"T9"STARDAYS." +1042 GOSUB 1425 +1043 S3=0:B3=S3:K3=B3:FORA=1TO8:FORB=1TO8:S(A,B)=0:NEXTB,A +1044 FORA=1TO3:FORB=1TO3:K(A,B)=0:NEXTB,A:S(S1,S2)=1 +1045 X=.01*G(Q1,Q2):K3=INT(X):Y=(X-K3)*10:B3=INT(Y) +1046 S3=G(Q1,Q2)-100*K3-10*B3 +1047 IF K3=0THENFORA=1TO3:FORB=1TO3:K(A,B)=0:NEXTB,A:GOTO1051 +1048 PRINTAR$;"CONDITION RED !!!!!":FORA=1TOK3 +1049 R1=INT(RND(1)*8+1):R2=INT(RND(1)*8+1):IFS(R1,R2)<>0THEN1049 +1050 S(R1,R2)=3:K(A,1)=R1:K(A,2)=R2:K(A,3)=S9:NEXT A:IFB3=0THEN1054 +1051 IFB3=0THEN1054 +1052 R1=INT(RND(1)*8+1):R2=INT(RND(1)*8+1):IFS(R1,R2)<>0THEN1052 +1053 S(R1,R2)=4 +1054 IFS3=0THEN1058 +1055 FORA=1TOS3 +1056 R1=INT(RND(1)*8+1):R2=INT(RND(1)*8+1):IFS(R1,R2)<>0THEN1056 +1057 S(R1,R2)=2:NEXTA +1058 G(Q1,Q2)=INT(G(Q1,Q2))+.5 +1059 PRINT +1060 PRINT"QUADRANT (";MID$(STR$(Q1),2,1);",";MID$(STR$(Q2),2,1);")" +1061 PRINT"SECTOR (";MID$(STR$(S1),2,1);",";MID$(STR$(S2),2,1);")" +1062 IFKP<>0THEN1404 +1063 IF DT=1 THEN 1267 +1064 IFS<200*K3THENPRINTAR$;"SHIELD ENERGY TOO LOW":SL=1:A=6:GOTO1074 +1065 A=2: GOTO1074 +1066 PRINT +1067 PRINTD$(2):FORA=1TO8:FORB=1TO8:PRINTA$(S(A,B));:NEXTB:PRINT:NEXTA +1068 PRINT:PRINT"SHIELDS";S;SPC(4);"ENERGY";E;SPC(4);"PHOTONS";P; +1069 PRINTSPC(4);"STARDAYS";T9-T +1070 GOSUB1321:INPUT"COMMAND";A +1071 IF A>10 OR A<0 THEN INPUT" ----> COMMAND";A +1072 IFA>10ORA<0THENPRINT"WARNING - PROPER COMMANDS ONLY !! ":GOTO 1070 +1073 IFA=1THEN1077 +1074 IFD(A)>=0THEN1077 +1075 PRINTAR$;"CAPTAIN, WE DON'T HAVE ";D$(A);" ANYMORE." +1076 IF DT=1 THEN 1267 ELSE 1070 +1077 ONAGOTO1081,1066,1146,1152,1178,1213,1222,1267,1489,1389 +1078 PRINT:FORA=1TO9:PRINTA;" = ";D$(A):NEXTA +1079 A=10 +1080 PRINTA;"= ";D$(A):GOTO1070 +1081 INPUT"COURSE";C1:IF C1<0 OR C1>359.99 THEN1084 +1082 INPUT"WARP FACTOR";W1 +1083 SL=0:KP=0:GOTO 1085 +1084 PRINTAR$"REJECTED ! COURSE MUST BE IN RANGE OF O TO 359.99 DGRS." +1085 IFNOT(W1>0)THEN1070 +1086 IFD(1)>=0ORW1<=ACTHEN1089 +1087 PRINTAR$;"WARP ENGINES ARE DAMAGED, MAXIMUM SPEED = ";AC +1088 GOTO1081 +1089 TEC=TEC+1:C$="":IFK3>0THENGOSUB1228 +1090 IFE>5*W1THEN1097 +1091 IFS<1THEN1244 +1092 PRINT"CAPTAIN, YOU ONLY HAVE"E"UNITS OF ENERGY. " +1093 PRINT"REFUEL FROM YOUR SHIELD RESERVES, WHICH HAVE"S"UNITS?" +1094 A=6 +1095 IFD(A)<0THEN1244 +1096 GOTO1070 +1097 FORI=1TO10:IFD(I)>=0THEN1101 +1098 D(I)=D(I)+1:IFD(I)<0THEN1101 +1099 IFD(7)<0THEN1101 +1100 PRINT"DAMAGE CONTROL REPORT: "D$(I)" REPAIRED." +1101 NEXTI:IFRND(1)>.1THEN1112 +1102 IFRND(1)>.1THEN1112 +1103 GOTO1109 +1104 IFRND(1)>R9/10THENRETURN +1105 R1=INT(RND(1)*8+1):IFD(R1)<0THENRETURN +1106 D(R1)=D(R1)-10*RND(1)-1:IFD(7)<0THENRETURN +1107 IFD(7)<0THENRETURN +1108 PRINT:PRINT"DAMAGE CONTROL REPORT: "D$(R1)" OUT.":PRINT:RETURN +1109 R1=INT(RND(1)*8+1):IFD(R1)>=0THEN1112 +1110 IFD(7)<0THEN1112 +1111 PRINT:D(R1)=0:PRINT"DAMAGE CONTROL REPORT: "D$(R1)" REPAIRED.":PRINT +1112 W1=W1*8:A1=8*Q2+S2-9:B1=72-8*Q1-S1:IFW1<1THENW1=W1*1.25 +1113 E=E-2*W1:T=T+W1/25:IFT>T9THEN1251 +1114 A2=INT(A1+W1*COS(C1*CX)+.5) +1115 B2=INT(B1+W1*SIN(C1*CX)+.5) +1116 IFNOT(A2<0ORA2>63ORB2<0ORB2>63)THEN1119 +1117 PRINTAR$;"CAPTAIN, HEED STARFLEET REGULATIONS! ( STAY IN GALAXY ) !! +1118 T=T+W1/24:GOTO1070 +1119 DEF FNA1(X)=INT(.5+A1+X*COS(C1*CX)) +1120 DEF FNB1(X)=INT(.5+B1+X*SIN(C1*CX)) +1121 FORX=0TOINT(W1) +1122 IFNOT(Q1=8-INT(FNB1(X)/8)ANDQ2=INT(FNA1(X)/8+1))THENX=W1:GOTO1139 +1123 S3=8-FNB1(X)+8*INT(FNB1(X)/8):S4=FNA1(X)+1-8*INT(FNA1(X)/8) +1124 IFS(S3,S4)<2THEN1139 +1125 S(S1,S2)=0:S1=8-FNB1(X-1)+8*INT(FNB1(X-1)/8) +1126 S2=FNA1(X-1)+1-8*INT(FNA1(X 1)/8):S(S1,S2)=1 +1127 PRINTAR$;"NAVIGATIONAL ERROR :ENGINES SHUT DOWN AT ("; +1128 PRINTMID$(STR$(S1),2,1);","MID$(STR$(S2),2,1);")" +1129 T=T+(W1/24) +1130 PRINT" YOU LOST "T" UNITS STARTIME RESTARTING ENGINES." +1131 PRINT +1132 IF S(S3,S4)<>4 THEN 1070 +1133 PRINT"SHIELDS LOWERED FOR REFUELING" +1134 S=0:P=10:C$="D":E=3000-XA+100 +1135 GOSUB 1228 +1136 FORR1=1TO 10 +1137 IFD(R1)>=0THENNEXTR1:GOTO1070 +1138 D(R1)=D(R1)+(11*RND(1)/R9):NEXTR1:GOTO1070 +1139 NEXT X:S(S1,S2)=0:S1=8-B2+8*INT(B2/8):S2=A2+1-8*INT(A2/8) +1140 Q3=8-INT(B2/8):Q4=INT(A2/8)+1 +1141 IFNOT(Q1=Q3ANDQ2=Q4)THENQ1=Q3:Q2=Q4:GOTO1043 +1142 S(S1,S2)=1:FORA=S1-1TOS1+1:FORB=S2-1TOS2+1 +1143 IFA>8ORB>8ORA<1ORB<1THEN1145 +1144 IFS(A,B)=4THEN1133 +1145 NEXTB,A:GOTO1070 +1146 PRINT +1147 FOR A=(Q1-1) TO (Q1+1):FOR B=(Q2-1) TO (Q2+1) +1148 IFA<1ORB<1ORA>8ORB>8THENPRINT" ***";:NEXTB:PRINT" ":PRINT:NEXTA:GOTO1070 +1149 PRINT" "SPC(3-LOG(G(A,B)+1)/LOG(10)); +1150 PRINTMID$(STR$(G(A,B)),2,LOG(G(A,B))/LOG(10)+1); +1151 G(A,B)=INT(G(A,B))+.5:NEXTB:PRINT" ":PRINT:NEXTA:GOTO1070 +1152 PRINT +1153 IFK3<=0THEN1226 +1154 IFD(8)>=0THEN1156 +1155 PRINTAR$;" COMPUTER FAILURE HAMPERS ACCURACY" +1156 PRINT"PHASERS LOCKED ON TARGET. ENERGY AVAILABLE="E +1157 PRINT"NUMBER OF UNITS TO FIRE:"; +1158 INPUT X +1159 IF E-X<0THENPRINT"NOT ENOUGH POWER":GOTO1070 +1160 T=T+.05:IFT>T9THEN1251 +1161 E=E-X +1162 IF C$<>"D"THEN GOSUB 1228 +1163 IFD(8)>=0THEN1165 +1164 X=X*RND(1) +1165 FORI=1TO3 +1166 IFK(I,3)<=0THEN1176 +1167 H=(X/FND(0))+SGN(RND(1)-.5)*8*RND(1) +1168 K(I,3)=K(I,3)-H +1169 PRINTH"UNIT HIT ON VESSEL AT (";MID$(STR$(K(I,1)),2,1);","; +1170 PRINTMID$(STR$(K(I,2)),2,1);"), LEAVING"K(I,3)" +1171 IFK(I,3)>0THEN1176 +1172 PRINT"KLINGON AT (";MID$(STR$(K(I,1)),2,1);",";MID$(STR$(K(I,2)),2,1); +1173 PRINT") DESTROYED":K3=K3-1:K9=K9-1:IFK9=0THEN1264 +1174 G(Q1,Q2)=G(Q1,Q2)-100:S(K(I,1),K(I,2))=0:K(I,1)=0:K(I,2)=0 +1175 K(I,3)=0 +1176 NEXT I +1177 GOTO1070 +1178 PRINT +1179 IFP>0THEN1182 +1180 PRINTAR$;"ALL PHOTON TORPEDOES EXPENDED" +1181 GOTO1070 +1182 INPUT"DIRECTION";C1 +1183 T=T+.05:IFT>T9THEN1251 +1184 P=P-1:IF C$<>"D" THEN GOSUB 1228 +1185 A1=8*Q2+S2-9:B1=72-8*Q1-S1:IFC1=90*INT(C1/90)THEN1208 +1186 DEF FNA1(W1)=INT(.5+A1+W1*COS(C1*CX)) +1187 DEF FNB1(W1)=INT(.5+B1+W1*SIN(C1*CX)) +1188 FORW1=0TO10STEP.9 +1189 IFW1=0THENS3=S1:S4=S2:GOTO1194 +1190 IFNOT(Q1=8-INT(FNB1(W1)/8)ANDQ2=INT(FNA1(W1)/8+1))THEN1070 +1191 S3=8-FNB1(W1)+8*INT(FNB1(W1)/8):S4=FNA1(W1)+1-8*INT(FNA1(W1)/8) +1192 IFFNA1(W1)=A2ANDFNB1(W1)=B2THEN1206 +1193 A2=FNA1(W1):B2=FNB1(W1) +1194 PRINT"(";MID$(STR$(S3),2,1);",";MID$(STR$(S4),2,1);")";A$(S(S3,S4)) +1195 ON S(S3,S4)+1GOTO1206,1206,1204,1196,1203 +1196 IFRND(1)<(.1*X4) THENPRINT"SHIELDS DEFLECT TORPEDO":GOTO1070 +1197 PRINT"KLINGON DESTROYED":S(S3,S4)=0:G(Q1,Q2)=G(Q1,Q2)-100 +1198 K3=K3-1:K9=K9-1:IFK9=0THEN1264 +1199 FORA=1TO3 +1200 IFK(A,1)=S3ANDK(A,2)=S4THENK(A,1)=0:K(A,2)=0:K(A,3)=0 +1201 NEXTA +1202 GOTO1070 +1203 PRINTAR$;"STARBASE DESTROYED":B3=0:B9=B9-1:S(S3,S4)=0:GOTO1205 +1204 PRINTAR$;"YOU CAN'T DESTROY A STAR":GOTO1070 +1205 G(Q1,Q2)=G(Q1,Q2)-10:GOTO1070 +1206 NEXT W1 +1207 GOTO1070 +1208 FORW1=0TO8 +1209 S3=INT(S1-W1*SIN(C1*CX)) +1210 S4=INT(S2+W1*COS(C1*CX)) +1211 IFS3>8ORS4>8ORS3<1ORS4<1THEN1070 +1212 GOTO1194 +1213 PRINT +1214 PRINT"ENERGY AVAILABLE="E+S" NUMBER OF UNITS TO SHIELDS"; +1215 INPUT X +1216 IFX<0THEN1070 +1217 IFE+S-X<0THEN1214 +1218 E=E+S-X +1219 S=X +1220 IFSL=1THEN1065 +1221 GOTO1070 +1222 PRINT +1223 PRINT"DEVICE STATE OF REPAIR" +1224 FORR1=1TO10:PRINTD$(R1);TAB(21) D(R1):NEXTR1 +1225 IF DT=1 THEN 1267 ELSE 1070 +1226 PRINT"SHORT RANGE SENSORS REPORT NO KLINGONS IN THIS QUADRANT" +1227 IF DT=1 THEN 1267 ELSE 1070 +1228 IF C$="D" AND K3<>0 THEN PRINT"STARBASE PROTECTS ENTERPRISE" ELSE 1230 +1229 GOTO1070 +1230 PRINT +1231 FORI=1TO3 +1232 IFK(I,3)<=0THEN1242 +1233 H=K(I,3)/FND(0)+SGN(RND(1)-.5)*RND(1)*7 +1234 S=S-H:PRINTH"UNIT HIT FROM ("MID$(STR$(K(I,1)),2,1);","; +1235 PRINTMID$(STR$(K(I,2)),2,1);"), LEAVING"S +1236 IFS<0THEN1254 +1237 GOSUB1104 +1238 IFRND(1)>R9/10THEN1242 +1239 R1=INT(8*RND(1)+1):R2=INT(8*RND(1)+1) +1240 IFNOT(S(R1,R2)=0)THEN1239 +1241 S(R1,R2)=3:S(K(I,1),K(I,2))=0:K(I,1)=R1:K(I,2)=R2 +1242 NEXTI +1243 RETURN +1244 PRINT AR$;" ENTERPRISE DEAD IN SPACE" +1245 PRINT +1246 CY=1:PRINT:GOTO1258 +1247 IFK3<=0THEN1258 +1248 GOSUB1228 +1249 GOTO1247 +1250 PRINT +1251 PRINT:PRINT:PRINT:PRINT:PRINT:PRINTAR$; +1252 PRINT"IT IS STARDATE"T:PRINT +1253 GOTO1258 +1254 PRINT +1255 PRINT:PRINT:PRINT:PRINT:PRINT:PRINTAR$; +1256 PRINT"ENTERPRISE DISABLED !!":PRINT:PRINT +1257 CY=0 +1258 PRINT"THERE ARE"K9"KLINGONS REMAINING.":IFCY<>0THEN1355 +1259 PRINT"YOU HAVE FAILED !!":PRINT +1260 L=INT(RND(1)*5) +1261 ONL+1GOTO 1343,1346,1348,1350,1353 +1262 PRINT:INPUT"DO YOU WANT TO TRY AGAIN";X$ +1263 IF LEFT$(X$,1)="Y" THEN 1012 ELSE 1541 +1264 PRINT"THE FEDERATION IS SAVED !!" +1265 PRINT"YOU ARE HEREBY PROMOTED TO ADMIRAL!!!!":PRINT +1266 GOTO1262 +1267 DT=1 +1268 INPUT"COMPUTER ON--COMMAND";A +1269 IF A>=10 THEN PRINT AR$;" NO SUCH COMMAND !!":GOTO 1268 +1270 ONA+1GOTO1289,1294,1299,1283,1059,1339,1341,1510,1070 +1271 PRINT"FUNCTIONS AVAILABLE FROM COMPUTER" +1272 PRINT" 0 = GALACTIC MEMORY MAP" +1273 PRINT" 1 = GENERAL STATUS REPORT" +1274 PRINT" 2 = PHOTON TRAJECTORY" +1275 PRINT" 3 = NEW MISSION" +1276 PRINT" 4 = PRESENT POSITION" +1277 PRINT" 5 = SELF-DESTRUCT" +1278 PRINT" 6 = WARP-COMPASS" +1279 PRINT" 7 = MISSION PROGRESS REPORT" +1280 PRINT" 8 = EXIT COMPUTER" +1281 GOTO1267 +1282 PRINT:PRINT"--TEMPORARY MALFUNCTION--":GOTO 1070 +1283 IF XM<0 THEN 1287 +1284 PRINT AR$;"SAFETY CHECK -- DO YOU WISH TO ABORT MISSION":INPUT AN$ +1285 IF LEFT$(AN$,1)<>"Y" THEN 1288 ELSE 1012 +1286 PRINT +1287 PRINT"YOU HAVE NOT BEEN AUTHORIZED FOR NEW MISSION !!":PRINT +1288 GOTO 1267 +1289 PRINT"QUADRANT CODE MEMORY MAP" +1290 FORA=1TO:FORB=1TO8:IFG(A,B)=INT(G(A,B))THENPRINT" ???";:GOTO1293 +1291 PRINT" "SPC(3-LOG(G(A,B)+1)/LOG(10)); +1292 PRINTMID$(STR$(G(A,B)),2,LOG(G(A,B))/LOG(10)+1); +1293 NEXTB:PRINT" ":NEXTA:GOTO 1267 +1294 PRINT" STATUS REPORT" +1295 PRINT"NUMBER OF KLINGONS LEFT ="K9 +1296 PRINT"NUMBER OF STARDATES LEFT ="T9-T +1297 PRINT"NUMBER OF STARBASES LEFT ="B9 +1298 A=7:GOTO1074 +1299 IFK3=0THEN1226 +1300 IFD(2)<0THENA=2:GOTO1073 +1301 PRINT"COORD","LOWDIR","HIGHDIR","DIST" +1302 FORA=1TO47:PRINT"-";:NEXTA +1303 PRINT +1304 FORI=0TO3 +1305 IFNOT(K(I,3)>0)THEN1318 +1306 W1=SQR((S1-K(I,1))^2+(S2-K(I,2))^2) +1307 IF W1=0 THENPRINT"--->MALFUNCTION !":GOTO1070 +1308 ON ERROR GOTO 1282 +1309 C1=1.5708-ATN((K(I,2)-S2)/W1/SQR(1-((K(I,2)-S2)/W1)^2)) +1310 ON ERROR GOTO 1282 +1311 C1=C1*SGN(S1-K(I,1))/CX +1312 C2(I)=C1-(10*RND(1)) +1313 C3(I)=C1+(10*RND(1)) +1314 IF C3(I)<0 THEN C3(I)=C3(I)+360 +1315 IF C2(I)<0 THEN C2(I)=C2(I)+360 +1316 PRINT"(";MID$(STR$(K(I,1)),2,1);",";MID$(STR$(K(I,2)),2,1); +1317 PRINT")",C2(I),C3(I),W1 +1318 NEXTI +1319 IF DT=1 THEN 1267 ELSE 1070 +1320 RETURN +1321 MR=(T9-T)/K9:DT=0 +1322 XM=((MR-PR)/PR)*100 +1323 IFKA=1THENPRINTTK-T"STARDATES LEFT TO SAVE STARBASE.":GOTO1332 +1324 IFRND(1)>.01*R9ORB9=0THENRETURN +1325 KA=1:FORA=1TO8:FORB=1TO8 +1326 IFG(A,B)-100*INT(G(A,B)/100)>9THENK1=A:K2=B:IFRND(1)>.5THENA=8:B=8 +1327 NEXTB,A:TK=T+.09*SQR((Q1-K1)^2+(Q2-K2)^2)*(10-R9) +1328 TK=TK+1 +1329 PRINTAR$;"!!! STARBASE IN QUADRANT ("MID$(STR$(K1),2,1)","; +1330 PRINTMID$(STR$(K2),2,1)") IS UNDER ATTACK!!" +1331 PRINT"YOU HAVE"TK-T"STARDATES TO SAVE IT!":RETURN +1332 IFT1 THEN 1421 ELSE 1530 +1340 GOTO1070 +1341 GOSUB 1365 +1342 GOTO 1267 +1343 PRINT"YOU HAVE SCREWED UP ONCE TOO OFTEN !" +1344 PRINT"OFF TO THE VULCAN TORTURE CAMPS !!" +1345 IFT<= 0THEN1262ELSE1355 +1346 PRINT"YOU WILL BE EXECUTED AT SUNRISE" +1347 GOTO1355 +1348 PRINT"YOU WILL BE PUT TO DEATH FOR YOUR INCOMPETENCE" +1349 GOTO1355 +1350 PRINT"YOU WILL BE CONFINED TO YOUR QUARTERS UNTIL" +1351 PRINT"VULCAN'S MOONS BECOME TOURIST TRAPS !!" +1352 IFT<=0THEN1262ELSE1355 +1353 PRINT"IMBECILE !! WE HOPE YOU CONSIDER SUICIDE!" +1354 IFT<=0THEN1262ELSE1355 +1355 L=(U-K9)*10+((U-K9)*500/T)-100*(Y-B9) +1356 IFE<=0ORS<0THENL=L-200 +1357 IFK9=0THENL=L+(R9*100) +1358 PRINT:PRINT +1359 PRINT"YOUR MISSION RATING IS: ";L +1360 PRINT:PRINT:PRINT:PRINT:PRINT +1361 GOSUB 1543 +1362 PRINTCHR$(26) +1363 GOTO1544 +1364 GOTO1262 +1365 PRINT +1366 PRINT" O9O" +1367 PRINT" 135 . O45" +1368 PRINT" . . ." +1369 PRINT" . . ." +1370 PRINT"18O . . . . . . .OOO WARP-COMPASS" +1371 PRINT" . . ." +1372 PRINT" . . ." +1373 PRINT" 225 . 315" +1374 PRINT" 27O" +1375 PRINT +1376 RETURN +1377 XX=INT(RND(2)*10)+1 +1378 RETURN +1379 PRINT:IFX4>12THEN1388 +1380 PRINT"COMMAND CENTRAL ADVISES THAT YOUR RANKING-";X4;"-IS IN THE EXPERT" +1381 PRINT"CATEGORY. BE ADVISED THAT IF YOU ARE NOT PROPERLY QUALIFIED" +1382 PRINT"YOUR CHANCES OF AVOIDING FAILURE ARE NIL." +1383 PRINT +1384 PRINT"DO YOU WISH REASSIGNMENT TO A LESS HAZARDOUS MISSION (Y OR N)" +1385 INPUTAN$ +1386 IFLEFT$(AN$,1)="Y"THEN1012 +1387 PRINTCHR$(26):GOTO1023 +1388 PRINT"YOU HAVE REQUESTED A SUICIDE MISSION":GOTO1383 +1389 PRINT"--COMMUNICATIONS ACTIVE--" +1390 PRINT +1391 GOSUB1377 +1392 PD=XX +1393 GOSUB1377 +1394 PE=XX +1395 GOSUB1377 +1396 PF=XX +1397 GOSUB1377 +1398 PG=XX +1399 PH=PD*10+PE +1400 PJ=PF*10+PG +1401 IFPH=PJTHEN 1282 +1402 KP=1:IFPD=PEORPF=PGTHEN1403ELSE1405 +1403 PRINT"SUNSPOTS BLOCK TRANSMISSION AT : ":GOTO1060 +1404 PRINT"MOVE ELSEWHERE AND TRY AGAIN":PRINT:GOTO 1081 +1405 PRINT"AUTHORIZED FREQUENCIES":PRINT +1406 PRINT"FEDERATION COMMAND BASE = ";PH +1407 PRINT"KLINGON COMMAND CENTRAL = ";PJ +1408 PRINT +1409 INPUT"COMMUNICATION ON CHANNEL ";XF +1410 IFXF=PHTHEN1432 +1411 IFXF=PJTHEN1461 +1412 PRINT +1413 PRINTAR$;"ALERT !!" +1414 PRINT"ATTEMPTED COMMUNICATION ON UNAUTHORIZED FREQUENCY" +1415 PRINT +1416 PRINT"WHILE SECURITY CHECK IS CONDUCTED ON ENTERPRISE" +1417 GOSUB1377:A=XX +1418 GOSUB1377:I=(XX/2)+(X4/7) +1419 PRINT"YOUR ";D$(A);" WILL BE INOPERATIVE FOR ";I "UNITS OF STARTIME" +1420 D(A)=D(A)-I:GOTO1070 +1421 PRINT +1422 PRINT"SECURITY CONTROL ADVISES THAT NO AUTHORIZATION HAS BEEN" +1423 PRINT"GIVEN TO ACTIVATE SELF- DESTRUCT SYSTEM." +1424 PRINT"PROCEED WITH ASSIGNED MISSION":PRINT:GOTO 1268 +1425 PRINT +1426 PRINT"BE ADVISED, YOUR MISSION PROGRESS FACTOR IS";PR +1427 GOSUB 1377 +1428 TF=(XX*X4)/1.6:IF TF<10 THEN TF=TF+10 +1429 PRINT" THE TOLERANCE FACTOR FOR THIS MISSION IS [+/-]";TF;"PERCENT" +1430 PRINT +1431 RETURN +1432 ONSGN(XM)+2GOTO1433,1437,1439 +1433 IFABS(XM)>(TF*1.5)THEN1445 +1434 IFABS(XM)>TFTHEN1442 +1435 PRINT:PRINT"CAPTAIN, YOU ARE BEHIND SCHEDULE - LET'S GO !!" +1436 GOTO 1070 +1437 PRINT:PRINT"YOU ARE EXACTLY ON COMPUTED SCHEDULE; PROCEED WITH MISSION" +1438 GOTO1070 +1439 IFXM>TFTHEN1454:IFXM>(TF*1.5)THEN1457 +1440 PRINT:PRINT"YOU ARE AHEAD OF COMPUTED SCHEDULE, KEEP UP THE GOOD WORK !!" +1441 GOTO1070 +1442 PRINT:PRINT"YOU ARE BEHIND SCHEDULE AND OUT OF TOLERANCE FACTOR !!" +1443 PRINT"COMMAND CONTROL PROJECTS FAILURE...YOU MAY SURRENDER TO ENEMY" +1444 EQ=1:SD=1:GOTO 1389 +1445 YY=AC^X4 +1446 PRINTCHR$(26) +1447 PRINTAR$;"---------COMPUTER PROJECTION----------":PRINT +1448 PRINT"PROJECTED LIKELIHOOD OF SUCCESS FOR YOUR MISSION =";YY;"PERCENT" +1449 PRINT"WE HAVE AUTO ACTIVATED SELF-DESTRUCT SYSTEM ON YOUR VESSEL" +1450 PRINT"GOODBYE, CAPTAIN.............":PRINT +1451 PRINT"END OF MESSAGE FROM FEDERATION COMMAND":PRINT:PRINT +1452 GOSUB 1543 +1453 GOTO 1530 +1454 PRINT:PRINT"YOU ARE AHEAD OF SCHEDULE AND BEYOND TOLERANCE FACTOR" +1455 PRINT"CALL KLINGON LEADERS AND REQUEST THEIR SURRENDER":KQ=1 +1456 PRINT:GOTO1389 +1457 PRINTAR$;"MESSAGE FROM COMMAND BASE" +1458 PRINT:PRINT"ENEMY HAS SURRENDERED TO FEDERATION COMMAND !!" +1459 PRINT:PRINT:PRINT:PRINT +1460 GOTO1264 +1461 IF KQ=1 THEN 1486:IF EQ=1 THEN 1464 +1462 ON SGN(XM)+2 GOTO 1463,1469,1474 +1463 IF ABS(XM)<=TFTHEN1469 +1464 PRINT:PRINT"KLINGON COMMAND ON FREQUENCY" +1465 PRINT"NATURALLY, WE ARE PLEASED THAT YOU ARE CONCEDING, CAPTAIN" +1466 PRINT"WE ARE PRESENTLY BOARDING YOUR CRAFT" +1467 PRINT:PRINT"HERE IS A MESSAGE FROM YOUR LEADERS-":PRINT:GOSUB 1543 +1468 PRINTCHR$(26):GOTO 1260 +1469 GOSUB 1377 +1470 IFXX<=5THEN 1473 +1471 PRINT:PRINT"MESSAGE FROM KLINGON COMMAND...." +1472 PRINT"NO FURTHER COMMUNICATIONS AT THIS TIME":GOTO 1482 +1473 PRINT:PRINT"WE'LL TALK WITH OUR WEAPONS, EARTH-SWINE !!":GOTO 1482 +1474 GOSUB 1377 +1475 AQ=INT((XX+1)/2) +1476 ON AQ GOTO 1471,1473,1477,1477,1474 +1477 GF=TF*1.5 +1478 IFXM>GFTHEN 1486 +1479 IFXM>TFTHEN 1483 +1480 PRINT:PRINT"CAPTAIN, DESPITE YOUR SLIGHT ADVANTAGE, YOU ARE NO MATCH FOR" +1481 PRINT"THE GLORIOUS KLINGON FLEET" +1482 PRINTTAB(25)"END OF MESSAGE FROM KLINGON COMMAND":GOTO1070 +1483 GOSUB1377 +1484 IFXX<=5THENPRINT" KLINGON COMMAND TO ENTERPRISE..":GOTO1473 +1485 GOTO1487 +1486 PRINTCHR$(26) +1487 PRINT:PRINT"MESSAGE FROM KLINGON LEADERS..." +1488 PRINT:PRINT"WE CONCEDE THE WAR, SIR, CONGRATULATIONS !!":GOTO1360 +1489 AV=INT(X4/2)+1:DR=-1 +1490 IF TEC"D" THEN 1496 ELSE 1498 +1492 AU=AV-TEC:IFAU=1THENKF$=""ELSEKF$="S" +1493 PRINT:PRINT"DAMAGE REPAIR INACTIVE !!" +1494 PRINT"REQUIRES";AU;"MORE RECHARGE UNIT";KF$ +1495 PRINT:GOTO 1070 +1496 PRINT:PRINTAR$"YOU MUST BE DOCKED AT STARBASE FOR DAMAGE REPAIR !!" +1497 PRINT:GOTO 1070 +1498 PRINT +1499 PRINT:FORA=1TO10 +1500 IFD(A)<0THENPRINT TAB(10)A;TAB(20)D$(A);TAB(40)"DAMAGED" +1501 NEXT +1502 PRINT:PRINT"IF NO DAMAGE INDICATED ABOVE, ANSWER WITH 0 (ZERO)" +1503 INPUT "WHICH ONE TO REPAIR ";A +1504 IFA<1ORA>10THENPRINTAR$;:GOTO 1070 +1505 IF D(A)<0 THEN 1507 +1506 PRINT:PRINTD$(A);" NOT DAMAGED !!":GOTO 1503 +1507 PRINT:PRINTTAB(20)D$(A);"---REPAIRED":PRINT +1508 D(A)=0:TEC=0:GOTO1070 +1509 PRINT:PRINTAR$;"NOTHING DAMAGED AT PRESENT":GOTO1070 +1510 PRINT +1511 GOSUB1429 +1512 PRINT"INITIAL MISSION PROGRESS FACTOR WAS";PR +1513 PRINT"CURRENT MISSION PROGRESS FACTOR IS ";MR +1514 IF XM<0 THEN PW$=" WORSENED "ELSE PW$=" IMPROVED " +1515 PRINT +1516 PRINT"YOUR COMBAT SITUATION HAS";PW$;"BY A FACTOR OF";XM;"PERCENT" +1517 IF ABS(XM)>=TF THEN EG$=" NOT "ELSE EG$=" " +1518 IF EG$=" "THEN EH$=""ELSE EH$=AR$ +1519 PRINT EH$;"YOUR PROGRESS IS";EG$;"WITHIN TOLERANCE FOR THIS MISSION" +1520 PRINT +1521 IF EG$=" NOT "THEN 1522 ELSE 1267 +1522 IF XM<0 THEN 1523 ELSE 1527 +1523 PRINT:SD=1:KD=0 +1524 PRINT"CAPTAIN, COMMAND CENTRAL PROJECTS DEFEAT BY ENEMY. YOU ARE NOW" +1525 PRINT"AUTHORIZED TO SURRENDER OR TO ACTIVATE SELF-DESTRUCT SYSTEM" +1526 GOTO1267 +1527 PRINT:SD=0:KD=1 +1528 PRINT"CAPTAIN, FEDERATION COMMAND PROJECTS SUCCESS FOR YOUR MISSION." +1529 GOTO 1454 +1530 PRINTCHR$(26) +1531 GOSUB 1542 +1532 PRINT"SELF DESTRUCT SYSTEM ACTIVATED" +1533 PRINT:PRINT:PRINT:GOSUB 1542 +1534 PRINT"COUNTDOWN BEGUN !":PRINT:PRINT +1535 PRINTTAB(25)"FIVE":PRINT:GOSUB 1542 +1536 PRINTTAB(20)"FOUR":PRINT:GOSUB 1542 +1537 PRINTTAB(15)"THREE":PRINT:GOSUB 1542 +1538 PRINTTAB(10)"TWO":PRINT:GOSUB 1542 +1539 PRINTTAB(5)"ONE":PRINT:GOSUB 1542 +1540 PRINT"ZERO":GOSUB 1542 +1541 PRINTCHR$(26):GOTO1544 +1542 FOR I=1 TO 50:A=A+1:NEXT:RETURN +1543 FOR I=1 TO 1200:A=A+1:NEXT:RETURN +1544 RESET + \ No newline at end of file diff --git a/software/BAS/SWARMS.bas b/software/BAS/SWARMS.bas new file mode 100644 index 0000000..8691f0f --- /dev/null +++ b/software/BAS/SWARMS.bas @@ -0,0 +1,520 @@ +100 'SWARMS2 - YET ANOTHER GEM FROM 'ZOSO' +110 CLEAR : CLEAR 1000 +120 PRINT CHR$(26);"!!!!! ATTENTION: THE BEES ARE ATTACKING !!!!!!" +130 PRINT : PRINT +140 PRINT "BEGIN DEFENSE PLAN: " : PRINT +150 PRINT "TIME: 1" +160 INPUT "ENTER YOUR NAME FOR IDENTIFICATION CHECK"; N$ +170 PRINT CHR$(26) +180 INPUT "ENTER CODE WORD FOR NUCLEAR CLEARANCE"; C$ +190 GOSUB 5220 +200 REM CREATE TWO INITIAL SWARMS +210 DIM E(21),S(21),A$(21),U(21),G(21),M(21),D(21),C(21) +220 DIM K(21),V(21),R(21) +230 A1=INT(RND(1)*21+1) +240 A2=INT(RND(1)*21+1) +250 IF A1=A2 THEN 230 +260 S(A1) = INT(RND(1)*5+2) +270 S(A2) = INT(RND(1)*5+2) +280 E(A1) = INT(RND(1)*9+6) +290 E(A2) = INT(RND(1)*9+6) +300 REM SUBTRACT ONE HOUR FROM ALL ETA'S +310 FOR A=1 TO 21 +320 IF E(A)=0 THEN 340 +330 GOTO 350 +340 IF U(A) = 0 THEN 560 +350 IF S(A) = 1 THEN 560 +360 IF ABS(U(A)) = 1 THEN 470 +370 IF ABS(E(A)) = 1 THEN 410 +380 E(A)=E(A) - 1 +390 C(A)=C(A)+(17-E(A)) +400 GOTO 560 +410 IF E(A) = -1 THEN 450 +420 PRINT "THE BEES HAVE ARRIVED IN THE MAJOR CITY IN SECTION ";A +430 E(A)=-1 +440 U(A)=6 +450 U(A)=U(A)-1 +460 GOTO 560 +470 IF U(A) = -1 THEN 560 +480 PRINT "THE BEES HAVE DESTROYED THE MAJOR CITY IN SECTION ";A +490 U(A)=-1 +500 IF V(A)<>-1 THEN 530 +510 PRINT "BUT THE POPULATION HAS BEEN EVACUATED" +520 GOTO 550 +530 K(A)=1 +540 C(A)=(1E+06*(RND(1)*A+1))+C(A) +550 GOTO 560 +560 NEXT A +570 REM ADD ONE UNIT TO TIME +580 T=T+1 +590 REM CREATE NEW SWARM +600 IF T/30<>INT(T/30) THEN 690 +610 A=INT(RND(1)*21+1) +620 IF S(A)<>0 THEN 600 +630 IF R(A)<>0 THEN 600 +640 IF K(A)<>0 THEN 600 +650 S(A)=INT(RND(1)*5+2) +660 E(A)=INT(RND(1)*9+16) +670 C(A)=INT(RND(1)*10) +680 PRINT "A NEW SWARM IS REPORTED IN SECTION ";A +690 REM CHECK COMBATED SWARMS +700 FOR A=1 TO 21 +710 IF T<>G(A) THEN 870 +720 IF S(A)<> 1 THEN 810 +730 S(A)=0 +740 G(A)=0 +750 E(A)=0 +760 M(A)=0 +770 K(A)=0 +780 U(A)=0 +790 PRINT "** THE SWARM IN SECTION ";A;" IS TOTALLY DESTROYED." +800 GOTO 870 +810 S(A)=S(A)-M(A) +820 PRINT "** THE PHASE ON SECTION ";A;" WAS SUCCESSFUL." +830 IF S(A)>=1 THEN 850 +840 S(A)=1 +850 G(A)=0 +860 M(A)=0 +870 NEXT A +880 REM ADD ONE UNIT TO EACH UNCOMBATTED SWARM +890 FOR A=1 TO 21 +900 IF E(A)=1 THEN 1150 +910 IF S(A)=1 THEN 1120 +920 IF S(A)=0 THEN 1150 +930 IF S(A)+1<9 THEN 1090 +940 IF A=1 THEN 1020 +950 IF S(A-1)>0 THEN 1010 +960 IF R(A-1)<>0 THEN 1150 +970 PRINT "** THE SWARM IN SECTION ";A;" HAS SPREAD TO SECTION ";A-1 +980 S(A-1)=3 +990 E(A-1)=INT(RND(1)*10+5) +1000 GOTO 1150 +1010 IF A=21 THEN 1150 +1020 IF S(A+1)>0 THEN 1150 +1030 IF R(A+1)<>0 THEN 1150 +1040 PRINT "** THE SWARM IN SECTION ";A;" HAS SPREAD TO SECTION ";A+1 +1050 IF R(A+1)<>0 THEN 1150 +1060 S(A+1)=3 +1070 E(A+1)=INT(RND(1)*10+5) +1080 GOTO 1150 +1090 S(A)=S(A)+1 +1100 C(A)=C(A)+S(A) +1110 GOTO 1150 +1120 IF D(A)=1 THEN 1150 +1130 PRINT "** THE SWARM IN SECTION ";A;" IS READY TO BE DESTROYED." +1140 D(A)=1 +1150 NEXT A +1160 REM WINNER CHECK +1170 W=0 +1180 FOR A=1 TO 21 +1190 W=S(A)+W +1200 NEXT A +1210 IF W>=1 THEN 1280 +1220 PRINT "*******ALL SWARMS ARE NOW DESTROYED*******" +1230 PRINT "FINAL STATISTICS ON ATTACKS AND DESTRUCTION ARE NOW " +1240 PRINT "BEING COMPUTED, ... FINAL RESULTS FOLLOW ....." +1250 A=0 +1260 PRINT +1270 GOTO 4690 +1280 REM EVACUATION CHECK +1290 FOR A=1 TO 21 +1300 IF V(A)<>T THEN 1400 +1310 IF U(A)=-1 THEN 1370 +1320 IF K(A)>0 THEN 1370 +1330 PRINT "** POPULATION IN SECTION ";A;" IS EVACUATED" +1340 C(A)=C(A)+INT(RND(1)*17) +1350 V(A)=-1 +1360 GOTO 1400 +1370 PRINT "** POPULATION IN SECTION ";A;" WAS DESTROYED BEFORE " +1380 PRINT " IT COULD BE EVACUATED" +1390 V(A)=0 +1400 NEXT A +1410 REM RETURN EVACUATION CHECK +1420 FOR A=1 TO 21 +1430 IF R(A)<>T THEN 1490 +1440 IF R(A)<1 THEN 1490 +1450 K(A)=0 +1460 R(A)=0 +1470 V(A)=0 +1480 PRINT "** THE POPULATION HAS RETURNED TO THE CITY IN SECTION ";A +1490 NEXT A +1500 REM LOSER CHECK +1510 Q=0 +1520 FOR A=1 TO 21 +1530 Q=C(A)+Q +1540 NEXT A +1550 IF Q<7.5E+07 THEN 1650 +1560 PRINT "THE BEES HAVE DEVASTATED THE UNITED STATES AND " +1570 PRINT "THERE ARE NOW OVER 75 MILLION CASUALTIES, THE BEES" +1580 PRINT "ARE NOW CONSIDERED TO BE THE VICTORS OVER MODERN" +1590 PRINT "TECHNOLOGY." +1600 A=0 +1610 Q=0 +1620 W=0 +1630 PRINT +1640 GOTO 4690 +1650 REM COMMAND INPUT +1660 PRINT "TIME: ";T+1 +1670 INPUT "COMMAND"; COM +1680 IF COM>8 OR COM<1 OR COM<>INT(COM) THEN PRINT "WRONG !!!"; : GOTO 1670 +1690 ON COM GOTO 1700,2210,2620,3840,4060,4660,4920,5190 +1700 REM MAP PRINT OUT +1710 PRINT CHR$(26);"1) ATTACK SCAN MAP" +1720 PRINT +1730 FOR A=1 TO 21 +1740 IF S(A)>6 THEN 1860 +1750 IF S(A)>4 THEN 1840 +1760 IF S(A)>1 THEN 1820 +1770 IF S(A)>0 THEN 1800 +1780 A$(A)= "?" +1790 GOTO 1870 +1800 A$(A)="." +1810 GOTO 1870 +1820 A$(A)="+" +1830 GOTO 1870 +1840 A$(A)="*" +1850 GOTO 1870 +1860 A$(A)="#" +1870 NEXT A +1880 PRINT "----------------------------------------------------" +1890 PRINT TAB(48);"---" +1900 PRINT TAB(20);"CANADA- NO INFORMATION / /" +1910 Z1$="----------------------- / "+A$(18)+"/" +1920 PRINT TAB(15);Z1$ +1930 PRINT TAB(15);"! ! ! ! ! !\- -/ /" +1940 Z1$="! "+A$(1)+" ! "+A$(3)+" ! "+A$(6)+" ! " +1950 Z1$=Z1$+A$(9)+" ! "+A$(13)+" ! \--/---/" +1960 PRINT TAB(15);Z1$ +1970 Z1$= "! !---!---!----!----! "+A$(16)+" ! /" +1980 PRINT TAB(15);Z1$ +1990 Z1$= "!---! ! ! ! ! ! "+A$(19)+" !" +2000 PRINT TAB(15);Z1$ +2010 Z1$="! ! "+A$(4)+" ! "+A$(7)+" ! "+A$(10)+" ! " +2020 Z1$=Z1$+A$(14)+" !---!---!" +2030 PRINT TAB(15);Z1$ +2040 Z1$="! "+A$(2)+" !---!---!----!----! ! !" +2050 PRINT TAB(15);Z1$ +2060 Z1$=" \ ! ! ! ! ! "+A$(17)+" ! "+A$(20)+" !" +2070 PRINT TAB(15);Z1$ +2080 Z1$=" \ ! "+A$(5)+" ! "+A$(8)+" ! "+A$(11)+" ! " +2090 Z1$=Z1$+A$(15)+" ! ! /" +2100 PRINT TAB(15);Z1$ +2110 Z1$=" \!---!---!----!----!---! "+A$(21)+"!" +2120 PRINT TAB(15);Z1$ +2130 PRINT TAB(27);"\ !";TAB(42);"\ !" +2140 Z1$=" \ "+A$(12)+"!" +2150 PRINT TAB(15);Z1$;TAB(42);"! !" +2160 PRINT TAB(30);"\-!";TAB(42);"!-!" +2170 PRINT TAB(20);"MEXICO- NO INFORMATION" +2180 PRINT +2190 PRINT "----------------------------------------------------" +2200 GOTO 300 +2210 REM ETA REPORT +2220 PRINT CHR$(12);"2) ETA REPORT" +2230 PRINT +2240 INPUT "ENTER SECTION #"; A +2250 IF A<1 OR A>21 OR A<>INT(A) THEN PRINT "WRONG !!!"; : GOTO 2240 +2260 PRINT "*************************************" +2270 IF A<>0 THEN 2300 +2280 D7=-1 +2290 FOR A = 1 TO 21 +2300 IF S(A)=1 THEN 2520 +2310 IF R(A)=-1 THEN 2550 +2320 IF E(A)=0 THEN 2500 +2330 IF U(A)=-1 THEN 2380 +2340 IF E(A)=-1 THEN 2410 +2350 PRINT "THE BEES WILL ARRIVE AT THE MAJOR CITY IN" +2360 PRINT " SECTION ";A;" AT ";E(A)+T;" HOURS." +2370 GOTO 2570 +2380 PRINT "THE BEES HAVE ALREADY DESTROYED THE CITY IN" +2390 PRINT "SECTION ";A;" AND ARE NOW INHABITING IT." +2400 GOTO 2570 +2410 PRINT "THE BEES HAVE ARRIVED AT THE CITY IN" +2420 IF V(A)<>-1 THEN 2460 +2430 PRINT "SECTION ";A;" BUT THE POPULATION HAS BEEN" +2440 PRINT " EVACUATED" +2450 GOTO 2570 +2460 PRINT "SECTION ";A;" AND THE POPULATION OF THAT CITY" +2470 PRINT "CAN ONLY SURVIVE FOR ABOUT ";U(A);" MORE HOURS." +2480 PRINT " USE OF URBAN DEFENSES IS RECOMMENDED." +2490 GOTO 2570 +2500 PRINT " NO SWARMS REPORTED IN SECTION ";A +2510 GOTO 2570 +2520 PRINT "THE BEES IN SECTION ";A;" ARE READY TO BE " +2530 PRINT "DESTROYED." +2540 GOTO 2570 +2550 PRINT "SECTION ";A;" IS A RADIOACTIVE WASTELAND THAT" +2560 PRINT " IS COMPLETELY UNPOPULATED" +2570 PRINT "*************************************" +2580 IF D7<>-1 THEN 2600 +2590 NEXT A +2600 D7=0 +2610 GOTO 300 +2620 REM BATTLE PHASE OPTIONS +2630 PRINT CHR$(26) +2640 PRINT "3) BATTLE PHASE OPTIONS" +2650 INPUT "ENTER SECTION #"; A +2660 INPUT "ENTER PHASE"; P +2670 IF V(A)<1 THEN 2700 +2680 PRINT "SECTION ";A;" IS BEING EVACUATED" +2690 GOTO 300 +2700 IF G(A)>0 THEN 2720 +2710 GOTO 2740 +2720 PRINT "THE SWARM IN SECTION ";A;" IS ALREADY BEING COMBATTED" +2730 GOTO 300 +2740 IF S(A)=0 THEN 2760 +2750 GOTO 2780 +2760 PRINT "NO SWARM IS REPORTED IN SECTION ";A +2770 GOTO 300 +2780 IF S(A)<>1 THEN 2820 +2790 IF P=5 THEN 2860 +2800 PRINT "THE DESTRUCTION PHASE SHOULD BE USED IN SECTION ";A +2810 GOTO 300 +2820 IF E(A)<>-1 THEN 2860 +2830 IF P=6 THEN 2860 +2840 PRINT "URBAN DEFENSES SHOULD BE USED IN SECTION ";A +2850 GOTO 300 +2860 N=RND(1) +2870 ON P GOTO 2880,2970,3060,3120,3210,3290 +2880 REM PHASE 1 +2890 PRINT "BEE COCKTAIL: PHASE ONE, NOW BEING ATTEMPTED." +2900 IF N>.95 THEN 300 +2910 G(A)=T+INT(RND(1)*3+1) +2920 IF S(A)>5 THEN 2950 +2930 M(A)=S(A)-2 +2940 GOTO 300 +2950 M(A)=S(A)-5 +2960 GOTO 300 +2970 REM PHASE TWO +2980 PRINT "PROJECT QUEEN: PHASE TWO, NOW BEING ATTEMPTED." +2990 IF N>.92 THEN 300 +3000 G(A) = T+INT(RND(1)*3+4) +3010 IF S(A)>3 THEN 3040 +3020 M(A)=1 +3030 GOTO 300 +3040 M(A)=S(A)-1 +3050 GOTO 300 +3060 REM PHASE THREE +3070 PRINT "PROJECT BRUSH FIRE: PHASE THREE, NOW BEING ATTEMPTED." +3080 IF N>.96 THEN 300 +3090 G(A)=T+1 +3100 M(A)=2 +3110 GOTO 300 +3120 REM PHASE 4 +3130 PRINT "PROJECT STERILE MALE: PHASE FOUR, NOW BEING ATTEMPTED." +3140 IF N>.89 THEN 300 +3150 G(A)=T+INT(RND(1)*3+3) +3160 IF S(A)>6 THEN 3190 +3170 M(A)=S(A)-1 +3180 GOTO 300 +3190 M(A)=4 +3200 GOTO 300 +3210 REM PHASE 5 +3220 IF S(A)=1 THEN 3250 +3230 PRINT "SWARM TOO LARGE: DESTRUCTION NOT POSSIBLE" +3240 GOTO 300 +3250 PRINT "DESTRUCTION: PHASE FIVE, NOW BEING ATTEMPTED." +3260 IF N>.7 THEN 300 +3270 G(A)=T+INT(RND(1)*3+2) +3280 GOTO 300 +3290 REM PHASE 6 +3300 IF E(A)<>-1 THEN 2800 +3310 INPUT "ENTER URBAN DEFENSE CODE"; D$ +3320 C(A)=C(A)+INT(200*RND(1)) +3330 IF RND(1) >.8 THEN 300 +3340 IF D$="A" THEN 3430 +3350 IF D$="B" THEN 3490 +3360 IF D$="C" THEN 3550 +3370 IF D$="D" THEN 3610 +3380 IF D$="E" THEN 3670 +3390 IF D$="F" THEN 3710 +3400 IF D$="G" THEN 3750 +3410 PRINT "INVALID URBAN DEFENSE CODE !!!" : PRINT : GOTO 3310 +3420 GOTO 300 +3430 REM *A* +3440 IF S(A)>5 THEN 3470 +3450 S(A)=S(A)-1 +3460 GOTO 3780 +3470 S(A)=2 +3480 GOTO 3780 +3490 REM *B* +3500 IF S(A)>4 THEN 3530 +3510 S(A)=S(A)-3 +3520 GOTO 3780 +3530 S(A)=S(A)-2 +3540 GOTO 3780 +3550 REM *C* +3560 IF S(A)>7 THEN 3590 +3570 S(A)=S(A)-3 +3580 GOTO 3780 +3590 S(A)=1 +3600 GOTO 3780 +3610 REM *D* +3620 IF S(A)>3 THEN 3650 +3630 S(A)=1 +3640 GOTO 3780 +3650 S(A)=S(A)-3 +3660 GOTO 3780 +3670 REM *E* +3680 IF RND(1)>.5 THEN 3780 +3690 S(A)=2 +3700 GOTO 3780 +3710 REM *F* +3720 IF RND(1)>.4 THEN 3780 +3730 S(A)=1 +3740 GOTO 3780 +3750 REM *G* +3760 IF RND(1)>.8 THEN 3780 +3770 S(A)=S(A)-4 +3780 PRINT "THE URBAN DEFENSE IN SECTION ";A;" WAS SUCCESSFUL" +3790 IF S(A)>1 THEN 300 +3800 S(A)=1 +3810 D(A)=1 +3820 PRINT "** SWARM IN SECTION ";A;" IS READY TO BE DESTROYED" +3830 GOTO 300 +3840 REM EVACUATION PROCEDURE +3850 PRINT CHR$(26); +3860 PRINT "4) EVACUATION PROCEDURE" +3870 INPUT "ENTER SECTION #"; A +3880 IF A<1 OR A>21 OR A<>INT(A) THEN PRINT "WRONG !!! "; : GOTO 3870 +3890 IF S(A)=0 THEN 3950 +3900 IF V(A)>0 THEN 3970 +3910 IF V(A)=-1 THEN 3990 +3920 IF K(A)>0 THEN 4010 +3930 IF U(A)=-1 THEN 4010 +3940 GOTO 4030 +3950 PRINT "COMPUTER FAILSAFE...NO SWARMS REPORTED IN SECTION ";A +3960 GOTO 300 +3970 PRINT "SECTION ";A;" IS BEING EVACUATED ALREADY" +3980 GOTO 300 +3990 PRINT "CITY IN SECTION ";A;" IS ALREADY EVACUATED" +4000 GOTO 300 +4010 PRINT "POPULATION IN SECTION ";A;" HAS BEEN DESTROYED" +4020 GOTO 300 +4030 PRINT "EVACUATION PROCEDURE NOW IN PROGRESS" +4040 V(A)=5+T +4050 GOTO 300 +4060 REM ***** NUCLEAR DESTRUCTION SEQUENCE ***** +4070 PRINT CHR$(26) +4080 PRINT "5) NUCLEAR DESTRUCTION SEQUENCE" +4090 INPUT "PLEASE ENTER YOUR NAME"; N1$ +4100 IF N$<>N1$ THEN 4270 +4110 INPUT "PLEASE ENTER YOUR CODE WORD"; C1$ +4120 IF C$<>C1$ THEN 4270 +4130 PRINT "POSITIVE IDENTIFICATION CHECK";CHR$(7) +4140 PRINT "CODE WORD CHECK IS VALID" +4150 PRINT "ID SEQUENCE COMPLETED" +4160 INPUT "PLEASE ENTER SECTION #"; A +4170 IF A<1 OR A>21 OR A<>INT(A) THEN PRINT "WRONG !!! "; : GOTO 4160 +4180 IF E(A)<>-1 THEN 4220 +4190 IF S(A)=0 THEN 4250 +4200 PRINT +4210 GOTO 4310 +4220 PRINT "COMPUTER FAILSAFE: BEES NOT ARRIVED IN THE MAJOR" +4230 PRINT "CITY IN SECTION ";A +4240 GOTO 300 +4250 PRINT "COMPUTER FAILSAFE: NO SWARM REPORTED IN SECTION ";A +4260 GOTO 300 +4270 PRINT "ID SEQUENCE DEFAULT....IGNORED" +4280 GOTO 300 +4290 PRINT "NUCLEAR DESTRUCTION ABORTED." +4300 GOTO 300 +4310 PRINT "BOMB IN SECTION ";A;" IS NOW ACTIVE" +4320 IF K(A)=1 THEN 4370 +4330 IF V(A)=-1 THEN 4370 +4340 PRINT "SECTION ";A;" HAS NOT BEEN EVACUATED" +4350 INPUT "DO YOU WISH TO CONTINUE"; K$ +4360 IF LEFT$(K$,1)="Y" THEN 4370 ELSE 4290 +4370 INPUT "TYPE 'X' FOR BOMB DETONATION"; F$ +4380 IF F$<>"X" THEN 4290 +4390 PRINT CHR$(26) +4400 PRINT "!!!!!!!!!!!!!!!! BOMB DETONATED !!!!!!!!!!!!!!!!" +4410 PRINT "SWARM HAS BEEN DESTROYED!!!!!!!!!" +4420 PRINT "CITY HAS BEEN DESTROYED!!!!!!!!!!" +4430 C(A)=2413 +4440 S(A)=0 +4450 E(A)=0 +4460 U(A)=0 +4470 D(A)=0 +4480 G(A)=0 +4490 M(A)=0 +4500 IF K(A)=1 THEN 4590 +4510 IF V(A)<>-1 THEN 4580 +4520 PRINT "THE POPULATION WILL MOVE BACK TO THE CITY" +4530 PRINT "IN SECTION ";A;" WHEN THE RADIATION LEVEL" +4540 PRINT "HAS DECREASED." +4550 K(A)=2 +4560 R(A)=T+7 +4570 GOTO 300 +4580 C(A)=INT(2E+06*(RND(1)*A+1))+C(A) +4590 PRINT "** NO SURVIVORS ARE REPORTED IN SECTION ";A +4600 PRINT "** THE BEES WILL NOT ENTER A SECTION WITH" +4610 PRINT "** NO HUMAN INHABITANTS, SO SECTION ";A +4620 PRINT "** IS COMPLETELY LACKING LIFE OF ANY KIND." +4630 K(A)=2 +4640 R(A)=-1 +4650 GOTO 300 +4660 REM CASUALTY REPORT +4670 PRINT CHR$(26);"6) CASUALTY REPORT" +4680 INPUT "ENTER SECTION #"; A +4690 PRINT "************************************" +4700 IF A<>0 THEN 4750 +4710 D7=-1 +4720 FOR A=1 TO 21 +4730 IF C(A)=0 THEN 4770 +4740 IF C(A)>=1E+06 THEN 4790 +4750 PRINT "SECTION ";A;": ";C(A);" CASUALTIES REPORTED" +4760 GOTO 4800 +4770 PRINT "SECTION ";A;": NO BEE RELATED CASUALTIES" +4780 GOTO 4800 +4790 PRINT "SECTION ";A;": ";C(A)/1E+06;" MILLION CASUALTIES" +4800 PRINT "************************************" +4810 F=C(A)+F +4820 IF D7<>-1 THEN 4890 +4830 NEXT A +4840 D7=0 +4850 IF F<1E+06 THEN 4880 +4860 PRINT "TOTAL CASUALTIES REPORTED: ";F/1E+06;" MILLION CASUALTIES" +4870 GOTO 4890 +4880 PRINT "TOTAL CASUALTIES REPORTED: ";F +4890 IF W=0 THEN 5200 +4900 F=0 +4910 GOTO 300 +4920 REM PRINT COMMANDS IN SHORT +4930 PRINT CHR$(26) +4940 PRINT "************************COMMANDS*********************" +4950 PRINT +4960 PRINT " 1) ATTACK SCAN MAP" +4970 PRINT " 2) ETA REPORT" +4980 PRINT " 3) BATTLE PHASE OPTIONS" +4990 PRINT " 1. BEE COCKTAIL" +5000 PRINT " 2. PROJECT QUEEN" +5010 PRINT " 3. PROJECT BRUSH FIRE" +5020 PRINT " 4. PROJECT STERILE MALE" +5030 PRINT " 5. DESTRUCTION" +5040 PRINT " 6. URBAN DEFENSES" +5050 PRINT " A) FLIGHT PATTERNS" +5060 PRINT " B) SONIC BOOM" +5070 PRINT " C) SUPER-SONIC BEAMS" +5080 PRINT " D) POLLUTION" +5090 PRINT " E) METHYL PARATHION" +5100 PRINT " F) FIRE WALL" +5110 PRINT " G) STROBE LIGHT" +5120 PRINT " 4) EVACUATION PROCEDURES" +5130 PRINT " 5) NUCLEAR DESTRUCTION" +5140 PRINT " 6) CASUALTY REPORT" +5150 PRINT " 7) COMMANDS (SHORT)" +5160 PRINT " 8) CANCEL GAME" +5170 GOTO 300 +5180 REM GAME CANCELLED +5190 REM +5200 REM +5210 RESET : END +5220 X9=LEN(N$) : X8=LEN(C$) +5230 X7=RND(-X9) : X7=X9+X8 +5240 FOR X9=1 TO X7+1 : X8=RND(1) : NEXT +5250 RETURN +RESET : END +5220 X9=LEN(N$) : X8=LEN(C$) +5230 X7=RND(-X9) : X7=X9+X8 +5240 \ No newline at end of file diff --git a/software/BAS/TREKINST.BAS b/software/BAS/TREKINST.BAS new file mode 100644 index 0000000..2e4f038 --- /dev/null +++ b/software/BAS/TREKINST.BAS @@ -0,0 +1,133 @@ +10 REM INSTRUCTIONS FOR "SUPER STARTREK" MAR 5, 1978 +20 FOR I=1 TO 12:PRINT:NEXT I +25 PRINT CHR$(26) +30 PRINT TAB(10);"*************************************" +40 PRINT TAB(10);"* *" +50 PRINT TAB(10);"* *" +60 PRINT TAB(10);"* * * SUPER STAR TREK * * *" +70 PRINT TAB(10);"* *" +80 PRINT TAB(10);"* *" +90 PRINT TAB(10);"*************************************" +100 FOR I=1 TO 8:PRINT:NEXT I +110 INPUT "DO YOU NEED INSTRUCTIONS (Y/N)";K$:IF K$="N" THEN 1210 +120 PRINT CHR$(26) +130 PRINT "NOTE: YOU MUST BE RUNNING 40K CP/M TO RUN STARTREK." +140 PRINT " THIS MEANS THAT BASIC MUST HAVE ABOUT 18K OF FREE MEMORY." +150 PRINT +160 PRINT" INSTRUCTIONS FOR 'SUPER STAR TREK'" +170 PRINT +180 PRINT"1. WHEN YOU SEE \COMMAND ?\ PRINTED, ENTER ONE OF THE LEGAL" +190 PRINT" COMMANDS (NAV,SRS,LRS,PHA,TOR,SHE,DAM,COM, OR XXX)." +200 PRINT"2. IF YOU SHOULD TYPE IN AN ILLEGAL COMMAND, YOU'LL GET A SHORT" +210 PRINT" LIST OF THE LEGAL COMMANDS PRINTED OUT." +220 PRINT"3. SOME COMMANDS REQUIRE YOU TO ENTER DATA (FOR EXAMPLE, THE" +230 PRINT" 'NAV' COMMAND COMES BACK WITH 'COURSE (1-9) ?'.) IF YOU" +240 PRINT" TYPE IN ILLEGAL DATA (LIKE NEGATIVE NUMBERS), THAT COMMAND" +250 PRINT" WILL BE ABORTED" +260 PRINT +270 PRINT" THE GALAXY IS DIVIDED INTO AN 8 X 8 QUADRANT GRID," +280 PRINT"AND EACH QUADRANT IS FURTHER DIVIDED INTO AN 8 X 8 SECTOR GRID." +290 PRINT +300 PRINT" YOU WILL BE ASSIGNED A STARTING POINT SOMEWHERE IN THE" +310 PRINT"GALAXY TO BEGIN A TOUR OF DUTY AS COMMANDER OF THE STARSHIP" +320 PRINT"\ENTERPRISE\; YOUR MISSION: TO SEEK AND DESTROY THE FLEET OF" +330 PRINT"KLINGON WARWHIPS WHICH ARE MENACING THE UNITED FEDERATION OF" +340 PRINT"PLANETS." +350 PRINT +352 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) +360 PRINT" YOU HAVE THE FOLLOWING COMMANDS AVAILABLE TO YOU AS CAPTAIN" +370 PRINT"OF THE STARSHIP ENTERPRISE:" +380 PRINT +390 PRINT"\NAV\ COMMAND = WARP ENGINE CONTROL --" +400 PRINT" COURSE IS IN A CIRCULAR NUMERICAL 4 3 2" +410 PRINT" VECTOR ARRANGEMENT AS SHOWN . . ." +420 PRINT" INTEGER AND REAL VALUES MAY BE ..." +430 PRINT" USED. (THUS COURSE 1.5 IS HALF- 5 ---*--- 1" +440 PRINT" WAY BETWEEN 1 AND 2 ..." +450 PRINT" . . ." +460 PRINT" VALUES MAY APPROACH 9.0, WHICH 6 7 8" +470 PRINT" ITSELF IS EQUIVALENT TO 1.0" +480 PRINT" COURSE" +490 PRINT" ONE WARP FACTOR IS THE SIZE OF " +500 PRINT" ONE QUADTANT. THEREFORE, TO GET" +510 PRINT" FROM QUADRANT 6,5 TO 5,5, YOU WOULD" +520 PRINT" USE COURSE 3, WARP FACTOR 1." +530 PRINT:PRINT +531 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) +540 PRINT"\SRS\ COMMAND = SHORT RANGE SENSOR SCAN" +550 PRINT" SHOWS YOU A SCAN OF YOUR PRESENT QUADRANT." +560 PRINT +570 PRINT" SYMBOLOGY ON YOUR SENSOR SCREEN IS AS FOLLOWS:" +580 PRINT" <*> = YOUR STARSHIP'S POSITION" +590 PRINT" +K+ = KLINGON BATTLE CRUISER" +600 PRINT" >!< = FEDERATION STARBASE (REFUEL/REPAIR/RE-ARM HERE!)" +610 PRINT" * = STAR" +620 PRINT +630 PRINT" A CONDENSED 'STATUS REPORT' WILL ALSO BE PRESENTED." +640 PRINT +650 PRINT"\LRS\ COMMAND = LONG RANGE SENSOR SCAN" +660 PRINT" SHOWS CONDITIONS IN SPACE FOR ONE QUADRANT ON EACH SIDE" +670 PRINT" OF THE ENTERPRISE (WHICH IS IN THE MIDDLE OF THE SCAN)" +680 PRINT" THE SCAN IS CODED IN THE FORM \###\, WHERE TH UNITS DIGIT" +690 PRINT" IS THE NUMBER OF STARS, THE TENS DIGIT IS THE NUMBER OF" +700 PRINT" STARBASES, AND THE HUNDRESDS DIGIT IS THE NUMBER OF" +710 PRINT" KLINGONS." +720 PRINT +730 PRINT" EXAMPLE - 207 = 2 KLINGONS, NO STARBASES, & 7 STARS." +740 PRINT:PRINT +741 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) +750 PRINT"\PHA\ COMMAND = PHASER CONTROL." +760 PRINT" ALLOWS YOU TO DESTROY THE KLINGON BATTLE CRUISERS BY " +770 PRINT" ZAPPING THEM WITH SUITABLY LARGE UNITS OF ENERGY TO" +780 PRINT" DEPLETE THEIR SHIELD POWER. (REMEMBER, KLINGONS HAVE" +790 PRINT" PHASERS TOO!)" +800 PRINT +810 PRINT"\TOR\ COMMAND = PHOTON TORPEDO CONTROL" +820 PRINT" TORPEDO COURSE IS THE SAME AS USED IN WARP ENGINE CONTROL" +830 PRINT" IF YOU HIT THE KLINGON VESSEL, HE IS DESTROYED AND" +840 PRINT" CANNOT FIRE BACK AT YOU. IF YOU MISS, YOU ARE SUBJECT TO" +850 PRINT" HIS PHASER FIRE. IN EITHER CASE, YOU ARE ALSO SUBJECT TO " +860 PRINT" THE PHASER FIRE OF ALL OTHER KLINGONS IN THE QUADRANT." +870 PRINT +880 PRINT" THE LIBRARY-COMPUTER (\COM\ COMMAND) HAS AN OPTION TO " +890 PRINT" COMPUTE TORPEDO TRAJECTORY FOR YOU (OPTION 2)" +900 PRINT +910 PRINT"\SHE\ COMMAND = SHIELD CONTROL" +920 PRINT" DEFINES THE NUMBER OF ENERGY UNITS TO BE ASSIGNED TO THE" +930 PRINT" SHIELDS. ENERGY IS TAKEN FROM TOTAL SHIP'S ENERGY. NOTE" +940 PRINT" THAT THE STATUS DISPLAY TOTAL ENERGY INCLUDES SHIELD ENERGY" +950 PRINT +951 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) +960 PRINT"\DAM\ COMMAND = DAMMAGE CONTROL REPORT" +970 PRINT" GIVES THE STATE OF REPAIR OF ALL DEVICES. WHERE A NEGATIVE" +980 PRINT" 'STATE OF REPAIR' SHOWS THAT THE DEVICE IS TEMPORARILY" +990 PRINT" DAMAGED." +1000 PRINT +1010 PRINT"\COM\ COMMAND = LIBRARY-COMPUTER" +1020 PRINT" THE LIBRARY-COMPUTER CONTAINS SIX OPTIONS:" +1030 PRINT" OPTION 0 = CUMULATIVE GALACTIC RECORD" +1040 PRINT" THIS OPTION SHOWES COMPUTER MEMORY OF THE RESULTS OF ALL" +1050 PRINT" PREVIOUS SHORT AND LONG RANGE SENSOR SCANS" +1060 PRINT" OPTION 1 = STATUS REPORT" +1070 PRINT" THIS OPTION SHOWS THE NUMBER OF KLINGONS, STARDATES," +1080 PRINT" AND STARBASES REMAINING IN THE GAME." +1090 PRINT" OPTION 2 = PHOTON TORPEDO DATA" +1100 PRINT" WHICH GIVES DIRECTIONS AND DISTANCE FROM THE ENTERPRISE" +1110 PRINT" TO ALL KLINGONS IN YOUR QUADRANT" +1115 PRINT:PRINT +1116 LINE INPUT "ENTER [CR] TO CONTINUE";A$:IF A$="" THEN PRINT CHR$(26) +1117 PRINT"\COM\ COMMAND = LIBRARY-COMPUTER" +1118 PRINT +1120 PRINT" OPTION 3 = STARBASE NAV DATA" +1130 PRINT" THIS OPTION GIVES DIRECTION AND DISTANCE TO ANY " +1140 PRINT" STARBASE WITHIN YOUR QUADRANT" +1150 PRINT" OPTION 4 = DIRECTION/DISTANCE CALCULATOR" +1160 PRINT" THIS OPTION ALLOWS YOU TO ENTER COORDINATES FOR" +1170 PRINT" DIRECTION/DISTANCE CALCULATIONS" +1180 PRINT" OPTION 5 = CALACTIC /REGION NAME/ MAP" +1190 PRINT" THIS OPTION PRINTS THE NAMES OF THE SIXTEEN MAJOR " +1200 PRINT" GALACTIC REGIONS REFERRED TO IN THE GAME." +1210 PRINT:PRINT:PRINT +1220 PRINT "...CHAINING TO STARTREK..." +1230 LOAD "STARTREK.BAS",R +1240 END diff --git a/software/BAS/TREKMOD.bas b/software/BAS/TREKMOD.bas new file mode 100644 index 0000000..c896ca7 --- /dev/null +++ b/software/BAS/TREKMOD.bas @@ -0,0 +1,1279 @@ +10 'BASED ON BIGTREK GAME / SHORTENED BY EDISON DOGGE. +20 WIDTH90:LQ=1000'REM NO SCORE - NO VISUALS +30 INPUT"CLEARANCE NUMBER (1 TO 25000)...";I +40 IFI<1ORI>25000ORI<>INT(I)THEN30 +50 I1=IMOD97:IFI1=0THENI=I+199:GOTO50 +60 I=RND(-I1):FORI1=1TOI:X=RND(1):NEXT +70 DIM G1$(16),V$(5,5),C$(20),G(8,8),D$(12),Q$(10,10),D4(12),D9(106) +80 DIM S2(8,8):Q$="?" +90 DATA S.R. SENSORS,L.R. SENSORS,PHASERS,PHOTON TUBES,LIFE SUPPORT +100 DATA WARP ENGINES,IMPULSE ENGINES,SHIELDS,SUBSPACE RADIO +110 DATA SHUTTLE CRAFT,COMPUTER,TRANSFER PANEL,ABANDON,CHART,COMPUTER +120 DATA DAMAGES,DESTRUCT,DOCK,IDLE,IMPULSE,LRSCAN,NAVIGATE,PHASERS,QUIT +130 DATA SHIELDS,SOS,SRSCAN,STATUS,TORPEDO,TRANSFER,VISUAL,WARP,SHORT +140 DATA MEDIUM,LONG,BEGINNER,NOVICE,SENIOR,EXPERT,COURSE,WCOST,ICOST +150 DATA PEFFECT,OUT,ANTARES,SIRIUS,RIGEL,MERAK,PROCYON,CAPELLA +160 DATA VEGA,DENEB,CANOPUS,ALDEBARAN,ALTAIR,REGULUS,BELLATRIX,ARCTURUS +170 DATA POLLUX,SPICA,10.5,12,1.5,9,0,3,7.5,6,4.5 +180 DEF FNA(X)=INT(8*RND(X))+1:DEF FNB(X)=INT(10*RND(X))+1 +190 DEF FND(X)=X/60 +200 DEFFNR(X)=INT(X*10+.5)/10:DEFFNS(X)=INT(X*100+.5)/100 +210 FORI=1TO12:READD$(I):NEXT:FORI=1TO20:READC$(I):NEXT +220 FORI=1TO3:READT$(I):NEXT:FORI=1TO4:READS$(I):NEXT:FORI=1TO5 +230 READC2$(I):NEXT:FORI=1TO16:READG1$(I):NEXT:FORI=1TO9:READC5(I):NEXT +240 GOSUB9760:S7$(1)="":S7$(2)=" ":S7$(3)=" ":S7$(4)="" +250 IFA2<>0THEN760 +260 J4=0:T1=0:INPUT"COMMAND";A$:IFLEN(A$)>1THEN280 +270 PRINT"2 LETTERS, PLEASE.":GOTO260 +280 FORI=1TO20 +290 IFA$=LEFT$(C$(I),LEN(A$))THEN350 +300 NEXT +310 PRINT"ILLEGAL !! - USE THIS LIST" +320 PRINT:FORI=1TO20STEP4 +330 PRINTC$(I);TAB(12);C$(I+1);TAB(22);C$(I+2);TAB(32);C$(I+3) +340 NEXT:PRINT:GOTO250 +350 ONIGOTO370,380,390,400,410,420,430,470,490,500 +360 ONI-10GOTO530,760,550,580,590,600,610,620,660,670 +370 GOSUB 12310:GOTO250 +380 GOSUB 2020:GOTO250 +390 GOSUB2540:GOTO250 +400 GOSUB3540:GOTO250 +410 GOSUB12550:GOTO250 +420 GOSUB3430:GOTO250 +430 GOSUB11700:IFJ3=0THEN250 +440 IFA2<>0THEN760 +450 IFG(Q1,Q2)=1000THEN720 +460 GOSUB790:GOTO250 +470 GOSUB5390:IFJ3=0THEN250 +480 GOTO680 +490 GOSUB5650:GOTO250 +500 GOSUB11830 +510 IFJ3=0THEN250 +520 GOTO680 +530 GOSUB8270:IFJ3=0THEN250 +540 GOSUB790:GOTO250 +550 GOSUB10370:IFJ3=0THEN250 +560 IFA2<>0THEN760 +570 GOSUB790:S9=0:GOTO250 +580 GOSUB4720:GOTO250 +590 GOSUB11090:GOSUB5650:GOTO250 +600 PRINT:GOSUB12770:GOTO250 +610 GOSUB8660:IFJ3=0THEN250ELSE680 +620 GOSUB11560:IFJ3=0THEN250 +630 IFA2<>0THEN760 +640 IFG(Q1,Q2)<>LQTHEN250 +650 GOTO720 +660 PRINT:PRINT"VISUAL INOPERATIVE !":RETURN +670 GOSUB10210:GOTO250 +680 IFA2<>0THEN760 +690 IFT1<>0THENGOSUB3640 +700 IFA2<>0THEN760 +710 IFG(Q1,Q2)0THEN760 +730 IFA2<>0THEN760 +740 GOTO710 +750 GOSUB790:GOTO250 +760 PRINT:PRINT:INPUT"ANOTHER GAME ";A$ +770 IFLEFT$(A$,1)="Y"THEN240 +780 PRINTCHR$(26):END +790 IF(C3<>0)AND(J4=0)THENGOSUB6620 +800 IFK3=0THENRETURN +810 IFA2<>0THENRETURN +820 P2=1/I8 +830 J5=0 +840 PRINT +850 IFC5$="DOCKED"THEN1530 +860 H2=0:H3=0:C6=1 +870 IFS9=1THENC6=.5+.5*RND(1) +880 A3=0 +890 FORL=1TOK3 +900 IFK6(L)<0THEN1320 +910 A3=1 +920 D6=.8+.05*RND(1) +930 H4=K6(L)*D6^K8(L) +940 IF(S4=0)AND(S9=0)THEN1000 +950 P3=.1:IFP2*S3>P3THENP3=P2*S3 +960 H5=P3*C6*H4+1 +970 IFH5>S3THENH5=S3 +980 S3=S3-H5:H4=H4-H5 +990 IF(P3>.1)AND(H4<5E-03*E1)THEN1320 +1000 J5=1 +1010 PRINTFNR(H4);"UNIT HIT ON THE ";S5$;" FROM "; +1020 J6=K4(L):J7=K5(L) +1030 IFQ$(J6,J7)="K"THENPRINT"KLINGON AT"; +1040 IFQ$(J6,J7)="C"THENPRINT"COMMANDER AT"; +1050 PRINTJ6;"-";J7 +1060 IFH4>H2THENH2=H4 +1070 H3=H3+H4 +1080 IFH4<(275-25*S8)*(1+.5*RND(1))THEN1310 +1090 N4=1+INT(H4/(500+100*RND(1))) +1100 PRINT"*** CRITICAL HIT--"; +1110 K9=1 +1120 FORW4=1TON4 +1130 J9=INT(12*RND(1))+1 +1140 C5(W4)=J9 +1150 E3=(H4*D5)/(N4*(75+25*RND(1))) +1160 IFJ9=6THENE3=E3/3 +1170 D4(J9)=D4(J9)+E3 +1180 IFW4=1THEN1250 +1190 FORV=1TOW4 +1200 IFJ9=C5(V-1)THEN1260 +1210 NEXTV +1220 K9=K9+1 +1230 IFK9=3THENPRINT +1240 PRINT " AND "; +1250 PRINTD$(J9); +1260 NEXTW4 +1270 PRINT " DAMAGED." +1280 IFD4(8)=0THEN1310 +1290 IFS4<>0THENPRINT"*** SHIELDS KNOCKED DOWN." +1300 S4=0 +1310 E1=E1-H4 +1320 NEXTL +1330 IFA3=0THENRETURN +1340 IFE1<=0THEN1510 +1350 P4=100*P2*S3+.5 +1360 IFJ5<>0THEN1390 +1370 PRINT"ENEMY ATTACK--SHIELDS REDUCED TO "; +1380 GOTO1430 +1390 PRINT"ENERGY LEFT:";FNS(E1);" SHIELDS "; +1400 IFS4<>0THENPRINT"UP,"; +1410 IF(S4=0)AND(D4(8)=0)THENPRINT"DOWN, "; +1420 IFD4(8)>0THENPRINT"DAMÿGED, "; +1430 PRINTINT(P4);"%" +1440 IF(H2<200)AND(H3<500)THEN1540 +1450 J8=INT(H3*RND(1)*.015) +1460 IFJ8<2THEN1540 +1470 PRINT +1480 PRINT"---> 'SICKBAY TO BRIDGE. WE SUFFERED ";J8;"CASUALTIES IN THAT ATTACK" +1490 C4=C4+J8 +1500 GOTO1540 +1510 F9=5 +1520 GOSUB4710:RETURN +1530 PRINT"*** KLINGONS ATTACK-- STARBASE SHIELDS PROTECT THE ";S5$ +1540 FORW4=1TOK3 +1550 K8(W4)=K7(W4) +1560 NEXTW4 +1570 GOSUB10980:RETURN +1580 PRINT:IFJ4=0THEN1610 +1590 PRINT"*** RED ALERT! RED ALERT!" +1600 PRINT"*** THE ";S5$;" HAS STOPPED IN QUADRANT CONTAINING SUPERNOVA" +1610 PRINT "*** AUTO-OVERRIDE ATTEMPTS TO HURL ";S5$;" TO OTHER QUADRANT" +1620 S2(Q1,Q2)=1 +1630 GOSUB7260 +1640 IFD4(6)=0THEN1830 +1650 PRINT +1660 PRINT"WARP ENGINES DAMAGED." +1670 PRINT:PRINT"TRYING TO ENGAGE IMPULSE ENGINES..." +1680 IFD4(7)=0THEN1730 +1690 PRINT"IMPULSE ENGINES DAMAGED." +1700 F9=8 +1710 GOSUB4710 +1720 RETURN +1730 P2=.75*E1 +1740 D6=4E-03*(P2-50) +1750 D7=1.4142+1.2*RND(1) +1760 D1=D6 +1770 IFD6>D7THEND1=D7 +1780 T1=D1/.4 +1790 D2=12*RND(1) +1800 J4=0 +1810 GOSUB5590 +1820 GOTO1940 +1830 W1=6+2*RND(1) +1840 W2=W1*W1 +1850 P2=.75*E1 +1860 D6=P2/(W1*W1*W1*(S4+1)) +1870 D7=1.4142+2*RND(1) +1880 D1=D6 +1890 IFD6>D7THEND1=D7 +1900 T1=10*D1/W2 +1910 D2=12*RND(1) +1920 J4=0 +1930 GOSUB12040 +1940 IFJ4<>0THEN1980 +1950 F9=8 +1960 GOSUB4710 +1970 RETURN +1980 IFR1<>0THENRETURN +1990 F9=1 +2000 GOSUB4710 +2010 RETURN +2020 PRINT:PRINT" 1 2 3 4 5 6 7 8" +2030 PRINT" --- --- --- --- --- --- --- ---" +2040 FORI=1TO8 +2050 PRINTI;" "; +2060 FORJ=1TO8 +2070 ONSGN(S2(I,J))+2GOTO2080,2100,2120 +2080 PRINT" .1."; +2090 GOTO 2170 +2100 PRINT" ..."; +2110 GOTO2170 +2120 IFS2(I,J)>LQTHEN2160 +2130 IFG(I,J)5THENI2=5 +2420 R3=I2 +2430 I5=7*L2 +2440 R5=I5 +2450 R7=(S8-2*RND(1)+1)*S8*.1+.1 +2460 IFR7<.2THENR7=R7+.1 +2470 I1=INT(2*R7*I5) +2480 R1=I1 +2490 I4=INT(S8+.0625*I1*RND(1)) +2500 R2=I4 +2510 I3=(I1+4*I4)*I5 +2520 R4=I3 +2530 RETURN +2540 IFD4(11)=0THEN2570 +2550 PRINT" COMPUTER DISABLED" +2560 RETURN +2570 PRINT"----COMPUTER ACTIVE----" +2580 INPUT"PROGRAM NAME";B$ +2590 FORI=1TO6 +2600 IFB$=LEFT$(C2$(I),LEN(B$))THEN2660 +2610 NEXT +2620 PRINT"VALID PROGRAMS ARE:" +2630 PRINT" COURSE WCOST OUT" +2640 PRINT" PEFFECT ICOST" +2650 GOTO2580 +2660 ON IGOTO2670,2910,2980,3040,2580,3110 +2670 INPUT "ENTER QUADRANT AND SECTOR - ";A3,A4 +2680 IF(A3<>INT(A3))OR(A4<>INT(A4))THEN3120 +2690 IFA3<0THEN2580 +2700 IFA3=0THENA3=10*Q1+Q2 +2710 A3=A3+.5 +2720 K=INT(A3/10) +2730 IF(K<1)OR(K>8)THEN3120 +2740 C6(1)=K:K=INT(A3-C6(1)*10) +2750 IF(K<1)OR(K>8)THEN3120 +2760 C6(2)=K:A4=A4+.5 +2770 K=INT(A4/100) +2780 IF(K<1)OR(K>10)THEN3120 +2790 C6(1)=C6(1)+(K-1)/10:K=INT(A4-K*100) +2800 IF(K<1)OR(K>10)THEN3120 +2810 C6(2)=C6(2)+(K-1)/10 +2820 X=Q1+((S6-1)/10)-C6(1):Y=Q2+((S7-1)/10)-C6(2) +2830 D1=0:D2=0:IF(X=0)AND(Y=0)THEN2890 +2840 D1=SQR(X*X+Y*Y) +2850 IFX<0THENZ7=SGN(Y)*(3.1416-ATN(ABS(Y/X))) +2860 IFX=0THENZ7=SGN(Y)*1.5708 +2870 IFX>0THENZ7=ATN(Y/X) +2880 D2=12-Z7*1.9098593#:IFD2>12THEND2=D2-12 +2890 PRINT"COURSE IS";FNS(D2);" FOR A DISTANCE OF"; +2900 PRINTFNS(D1);"QUADRANTS.":GOTO2580 +2910 INPUT"ENTER DISTANCE AND WARP FACTOR";D1,A4 +2920 IF(D1<0)THEN2580 +2930 C7=D1*A4*A4*A4 +2940 T1=(10*D1)/((A4*A4)+1E-05) +2950 PRINT"IT WOULD TAKE";FNS(T1);"STARDATES AND USE" +2960 PRINTFNR(C7);"UNITS OF ENERGY (";FNR(C7+C7);"IF SHIELDS ARE UP)" +2970 GOTO2580 +2980 INPUT"ENTER DISTANCE...";D1 +2990 IFD1<0THEN2580 +3000 C7=250*D1+50:T1=D1/.4 +3010 PRINT"IT WOULD TAKE";FNR(T1);"STARDATES AND USE" +3020 PRINTC7;"UNITS OF ENERGY" +3030 GOTO2580 +3040 INPUT"ENTER PHASER RANGE IN QUADRANTS";A3 +3050 IFA3<0THEN2580 +3060 A3=A3*10:C7=(.9^A3)*100 +3070 PRINT"PHASERS ARE ";LEFT$(STR$(C7),5);"% EFFECTIVE AT THAT RANGE" +3080 GOTO2580 +3090 GOSUB9750 +3100 GOTO2580 +3110 RETURN +3120 PRINT"FORMAT IS MN,XXYY...WHERE MN IS THE QUADRANT" +3130 PRINT"AND XXYY IS THE SECTOR...E.G. 64,0307 REFERS" +3140 PRINT"TO QUADRANT 6-4, SECTOR 3-7." +3150 GOTO 2580 +3160 IFT2$<>"C"THEN3250 +3170 C3=0:PRINT"*** COMMANDER AT"; +3180 FORF=1TOR2:IF(C1(F)=Q1)AND(C2(F)=Q2)THEN3200 +3190 NEXTF +3200 C1(F)=C1(R2):C2(F)=C2(R2):C1(R2)=0:C2(R2)=0 +3210 R2=R2-1:F1(2)=1E+30 +3220 IFR2<>0THENF1(2)=D0-(I4/R2)*LOG(RND(1)) +3230 K2=K2+1 +3240 GOTO3270 +3250 PRINT"*** KLINGON AT"; +3260 K1=K1+1 +3270 PRINTA5;"-";A6;"DESTROYED." +3280 Q$(A5,A6)=".":R1=R1-1 +3290 IFR1=0THENRETURN +3300 R5=R4/(R1+4*R2) +3310 G(Q1,Q2)=G(Q1,Q2)-100 +3320 FORF=1TOK3 +3330 IF(K4(F)=A5)AND(K5(F)=A6)THEN3350 +3340 NEXTF +3350 K3=K3-1 +3360 IFF>K3THEN3410 +3370 FORG=FTOK3 +3380 K4(G)=K4(G+1):K5(G)=K5(G+1):K6(G)=K6(G+1) +3390 K7(G)=K7(G+1):K8(G)=K7(G) +3400 NEXTG +3410 K4(K3+1)=0:K5(K3+1)=0:K7(K3+1)=0:K8(K3+1)=0:K6(K3+1)=0 +3420 RETURN +3430 IFC5$="DOCKED"THEN3520 +3440 IFB6=0THEN3460 +3450 IF(ABS(S6-B6)<=1)AND(ABS(S7-B7)<=1)THEN3480 +3460 PRINTS5$;" NOT ADJACENT TO A BASE." +3470 RETURN +3480 C5$="DOCKED" +3490 PRINT"---> DOCKING COMPLETED" +3500 E1=I7:S3=I8:T4[9:L1=J1 +3510 RETURN +3520 PRINT"CAPTAIN, WE'RE ALREADY DOCKED!" +3530 RETURN +3540 J=0:PRINT:FORI=1TO12 +3550 IFD4(I)<=0THEN3600 +3560 IFJ<>0THEN3590 +3570 PRINT" DEVICE";SPC(12);"-REPAIR TIMES-" +3580 PRINTSPC(21);"IN FLIGHT DOCKED":J=1 +3590 PRINT" ";D$(I);TAB(23);FNS(D4(I));TAB(33);FNS(D3*D4(I)) +3600 NEXTI +3610 PRINT"TAB(23);"VISUAL SENSORS PERMANENTLY DAMAGED" +3620 IFJ=0THENPRINT" - ALL DEVICES (EXCEPT VISUAL) FUNCTIONAL -" +3630 RETURN +3640 M=0:D7=D0+T1:FORL=1TO5 +3650 IFF1(L)>D7THEN3670 +3660 M=L:D7=F1(L) +3670 NEXTL +3680 X6=D7-D0:D0=D7 +3690 R4=R4-(R1+4*R2)*X6 +3700 R5=R4/(R1+4*R2) +3710 IFR5>0THEN3750 +3720 F9=2 +3730 GOSUB4710 +3740 RETURN +3750 IF(D4(5)=0)OR(C5$="DOCKED")THEN3810 +3760 IF(L1>=X6)OR(D4(5)<=L1)THEN3790 +3770 F9=3:GOSUB4710 +3780 RETURN +3790 L1=L1-X6 +3800 IFD4(5)<=X6THENL1=J1 +3810 R=X6 +3820 IFC5$="DOCKED"THENR=X6/D3 +3830 FORL=1TO12 +3840 IFD4(L)<=0THEN3890 +3850 D4(L)=D4(L)-R +3860 IFD4(L)<0THEND4(L)=0 +3870 IFD4(L)<>0THEN3890 +3880 PRINT:PRINT"DAMAGE CONTROL- ";D$(L);" NOW OPERATIONAL." +3890 NEXTL +3900 IFM=0THENRETURN +3910 T1=T1-X6 +3920 ONMGOTO3930,3970,4190,4280,4450 +3930 X2=0:Y2=0:GOSUB10520 +3940 F1(1)=D0-.5*I5*LOG(RND(1)) +3950 IFG(Q1,Q2)=LQTHENRETURN +3960 GOTO3640 +3970 IFR2=0THEN4180 +3980 IFC5$="DOCKED"THEN4160 +3990 I=INT(RND(1)*R2)+1 +4000 Y6=(C1(I)-Q1)^2+(C2(I)-Q2)^2 +4010 IFY6=0THEN4160 +4020 Y6=SQR(Y6):T1=.17778*Y6 +4030 PRINT:PRINT"*** ";S5$;" CAUGHT IN LONG-RANGE TRACTOR BEAM--" +4040 Q1=C1(I):Q2=C2(I) +4050 S6=FNB(1):S7=FNB(1) +4060 PRINT"PULLED TO QUADRANT";Q1;"-";Q2;", SECTOR";S6;"-";S7 +4070 IFR6<>0THENPRINT"(IDLE PERIOD CANCELLED)" +4080 R6=0 +4090 IFS4<>0THEN4150 +4100 IF(D4(8)=0)AND(S3>0)THEN4130 +4110 PRINT"(SHIELDS NOT CURRENTLY USABLE.)" +4120 GOTO4150 +4130 GOSUB10390 +4140 S9=0 +4150 GOSUB7260 +4160 F1(2)=D0+T1-1.5*(I5/R2)*LOG(RND(1)) +4170 GOTO3640 +4180 F1(2)=1E+30:GOTO3640 +4190 D9(1)=D0:D9(2)=R1:D9(3)=R2:D9(4)=R3:D9(5)=R4:D9(6)=R5 +4200 D9(7)=S1:D9(8)=B1:D9(9)=K1:D9(10)=K2 +4210 FORI=1TO8:FORJ=1TO8:D9(I-1+8*(J-1)+11)=G(I,J):NEXTJ:NEXTI +4220 FORI=75TO84:D9(I)=C1(I-74):NEXT +4230 FORI=85TO94:D9(I)=C2(I-84):NEXT +4240 FORI=95TO99:D9(I)=B2(I-94):NEXT +4250 FORI=100TO104:D9(I)=B3(I-99):NEXT +4260 D9(105)=B4:D9(106)=B5 +4270 S0=1:F1(3)=D0-.3*I5*LOG(RND(1)):GOTO3640 +4280 IF(R2=0)OR(R3=0)THEN4330 +4290 FORI=1TOR3:FORJ=1TOR2:IF(B2(I)=C1(J))AND(B3(I)=C2(J))THEN4340 +4300 NEXTJ:NEXTI +4310 F1(4)=D0+.5+3*RND(1) +4320 F1(5)=1E+30:GOTO3640 +4330 F1(4)=1E+30:F1(5)=1E+30:GOTO3640 +4340 B4=B2(I):B5=B3(I) +4350 IF(B4=Q1)AND(B5=Q2)THEN4310 +4360 F1(5)=D0+.5+3*RND(1) +4370 F1(4)=F1(5)-.3*I5*LOG(RND(1)) +4380 IFD4(9)>0THEN3640 +4390 PRINT:PRINT" CAPTAIN, THE STARBASE IN";B4;"-";B5;"IS UNDER ATTACK-" +4400 PRINT" AND CAN ONLY RESIST UNTIL STARDATE";FNR(F1(5));"!!!" +4410 IFR6=0THEN3640 +4420 INPUT" SHALL WE CANCEL IDLE PERIOD";B$ +4430 IFLEFT$(B$,1)="Y"THENR6=0 +4440 GOTO3640 +4450 F1(5)=1E+30:IF(R2=0)OR(R3=0)THEN3640 +4460 K=INT(G(B4,B5)/100):IFG(B4,B5)-K*100<10THEN3640 +4470 FORI=1TOR2:IF(C1(I)=B4)AND(C2(I)=B5)THEN4490 +4480 NEXT:GOTO3640 +4490 IFS2(B4,B5)=-1THENS2(B4,B5)=0 +4500 IFS2(B4,B5)>999THENS2(B4,B5)=S2(B4,B5)-10 +4510 IF(B4<>Q1)OR(B5<>Q2)THEN4600 +4520 FORI=1TOK3:K=K4(I):L=K5(I) +4530 IFQ$(K,L)="C"THEN4550 +4540 NEXT +4550 IFK6(I)<25+50*RND(1)THEN3640 +4560 Q$(B6,B7)=".":B6=0:B7=0 +4570 GOSUB7230 +4580 PRINT:PRINT"CAPTAIN, I BELIEVE THE STARBASE HAS BEEN DESTROYED" +4590 GOTO4640 +4600 IF(R3=1)OR(D4(9)>0)THEN4640 +4610 PRINT +4620 PRINT"--> STARFLEET COMMAND REPORTS THAT STARBASE IN QUADRANT";B4;"-";B5 +4630 PRINT"HAS BEEN DESTROYED BY ENEMY COMMANDER !!" +4640 G(B4,B5)=G(B4,B5)-10 +4650 IFR3<=1THEN4690 +4660 FORI=1TOR3:IF(B2(I)=B4)AND(B3(I)=B5)THEN4680 +4670 NEXT +4680 B2(I)=B2(R3):B3(I)=B3(R3) +4690 R3=R3-1 +4700 GOTO3640 +4710 PRINT:PRINT:PRINT:PRINT"CONFLICT RESOLVED -GAME OVER":GOTO760 +4720 IFC5$<>"DOCKED"THEN4750 +4730 PRINT"--> CAPTAIN, WE'RE ALREADY DOCKED!" +4740 RETURN +4750 IFD4(9)=0THEN4770 +4760 PRINT"SUBSPACE RADIO DAMAGED...CANNOT TRANSMIT.":RETURN +4770 IFR3<>0THEN4790 +4780 PRINT"CAPTAIN, NO RESPONSE FROM STARBASE !":RETURN +4790 N1=N1+1:IFB6=0THEN4810 +4800 GOTO4870 +4810 D1=1E+30 +4820 FORL=1TOR3:X=10*SQR((B2(L)-Q1)^2+(B3(L)-Q2)^2) +4830 IFX>D1THEN4850 +4840 D1=X:K=L +4850 NEXTL +4860 Q1=B2(K):Q2=B3(K):GOSUB7260 +4870 Q$(S6,S7)="." +4880 PRINT +4890 PRINT"STARBASE IN QUADRANT";Q1;"-";Q2;"RESPONDS --"; +4900 PRINT" ";S5$;" DEMATERIALIZES." +4910 P2=(1-.98^D1)^.333333 +4920 FORL=1TO3 +4930 IFL=1THENPRINT"1ST "; +4940 IFL=2THENPRINT"2ND "; +4950 IFL=3THENPRINT"3RD "; +4960 PRINT"ATTEMPT TO RE-MATERIALIZE THE ";S5$;". . . . ."; +4970 IFRND(1)>P2THEN5000 +4980 PRINT"FAILS.":NEXTL +4990 F9=11:GOSUB4710:RETURN +5000 FORL=1TO5:I=B6+INT(3*RND(1))-1 +5010 IF(I<1)OR(I>10)THEN5050 +5020 J=B7+INT(3*RND(1))-1 +5030 IF(J<1)OR(J>10)THEN5050 +5040 IFQ$(I,J)="."THEN5060 +5050 NEXTL:PRINT"FAILS.":GOTO4990 +5060 PRINT"SUCCEEDS.":S6=I:S7=J:Q$(I,J)=LEFT$(S5$,1) +5070 GOSUB3430:PRINT"CAPTAIN, WE MADE IT!":RETURN +5080 P4=2:L5=K3:N=1 +5090 FORK=1TOL5 +5100 IFH3(K)=0THEN5360 +5110 D6=.9+.01*RND(1):H2=H3(K)*D6^K7(N) +5120 P3=K6(N) +5130 P=ABS(P3):IFP4*H24.99THEN5180 +5170 PRINT"MINOR HIT ON ":GOTO5190 +5180 PRINTFNR(H2);"UNIT HIT ON "; +5190 M$=Q$(X8,Y8) +5200 IF M$="K"THENPRINT"KLINGON AT"; +5210 IFM$="C"THENPRINT"COMMANDER AT"; +5220 PRINTX8;"-";Y8 +5230 IFK6(N)<>0THEN5270 +5240 A5=X8:A6=Y8:T2$=Q$(X8,Y8):GOSUB3160 +5250 IFR1<>0THEN5370 +5260 F9=1:GOSUB4710:GOTO5370 +5270 IFK6(N)<0THEN5360 +5280 IFRND(1)<.9THEN5360 +5290 IFK6(N)>(.4+.4*RND(1))*P3THEN5360 +5300 PRINT +5310 PRINT"*** CAPTAIN, THE VESSEL AT SECTOR"; +5320 PRINTX8;"-";Y8 +5330 PRINT" HAS JUST LOST ITS FIREPOWER !!!" +5340 PRINT +5350 K6(N)=-K6(N) +5360 N=N+1 +5370 NEXTK +5380 RETURN +5390 J3=0 +5400 IFD4(7)<>0THEN5640 +5410 IFE1<=75THEN5470 +5420 INPUT"ENTER COURSE....";D2 +5430 IFD2<.01ORD2>12THENGOSUB12780ELSE5450 +5440 RETURN +5450 P3=50+250*D1 +5460 IFP375THEN5520 +5510 PRINT"QUADRANT. THEY ARE USELESS NOW.'":RETURN +5520 PRINT"QUADRANT. WE CAN GO A MAXIMUM OF "; +5530 PRINTFNR(4E-03*(E1-50)-.05);"QUADRANTS.'":RETURN +5540 T1=D1/.4 +5550 IFT1"Y"THENRETURN +5590 GOSUB5850:J3=1 +5600 IFA2<>0THENRETURN +5610 E1=E1-P3 +5620 IFE1>0THENRETURN +5630 F9=4:GOSUB4710:RETURN +5640 PRINT"IMPULSE ENGINES DAMAGED.":RETURN +5650 N$=" #" +5660 PRINT +5670 IFD4(2)<>0THEN5840 +5680 PRINT"L.R. SCAN FOR QUADRANT";Q1;"-";Q2:PRINT +5690 I=Q1-1:J=Q1+1:K=Q2-1:L=Q2+1 +5700 FORM=ITOJ:FORN=KTOL +5710 IF(M<=0)OR(M>8)THEN5770 +5720 IF(N<=0)OR(N>8)THEN5770 +5730 IFD4(11)=0THENS2(M,N)=1 +5740 IFG(M,N)>=LQTHEN PRINT" ***";" "; +5750 IFG(M,N)B8THENB8=ABS(D6) +5870 D4=D4/B8:D6=D6/B8:T5=0:T6=0 +5880 IFD0+T110)THEN6190 +5960 IF(Y1<1)OR(Y1>10)THEN6190 +5970 IFQ$(X1,Y1)="O"THEN6000 +5980 IFQ$(X1,Y1)<>"."THEN6070 +5990 NEXTL +6000 D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +6010 S6=X1:S7=Y1 +6020 F4=S6:F5=S7 +6030 IFQ$(X1,Y1)<>"O"THEN6520 +6040 T2=FNA(1):T3=FNA(1) +6050 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):PRINT +6060 PRINT"*** SPACE PORTAL ENTERED ***":GOTO6490 +6070 T6=1:K=50*D1/T1+1E-03:D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +6080 IF(Q$(X1,Y1)="K")OR(Q$(X1,Y1)="C")THEN6180 +6090 PRINT:PRINTS5$;" BLOCKED BY "; +6100 IFQ$(X1,Y1)="*"THENPRINT"STAR AT"; +6110 IFQ$(X1,Y1)="B"THENPRINT"STARBASE AT"; +6120 PRINT" SECTOR";X1;"-";Y1;"...." +6130 PRINT"EMERGENCY STOP REQUIRED";FNR(K);"UNITS OF ENERGY." +6140 E1=E1-K +6150 S6=INT(X7-D4+.5):F4=S6:S7=INT(Y7-D6+.5):F5=S7 +6160 IFE1>0THEN6520 +6170 F9=4:GOSUB4710:RETURN +6180 S6=X1:S7=Y1:GOSUB9600:F4=S6:F5=S7:GOTO6520 +6190 IFK3=0THEN6250 +6200 FORL=1TOK3 +6210 F3=SQR((X1-K4(L))^2+(Y1-K5(L))^2) +6220 K8(L)=.5*(F3+K7(L)):NEXTL +6230 IFG(Q1,Q2)<>LQTHENGOSUB790 +6240 IFA2<>0THENRETURN +6250 X7=10*(Q1-1)+S6:Y7=10*(Q2-1)+S7 +6260 X1=INT(X7+10*D1*B8*D4+.5) +6270 Y1=INT(Y7+10*D1*B8*D6+.5):L6=0 +6280 L5=0 +6290 IFX1>0THEN6310 +6300 X1=-X1+1:L5=1 +6310 IFY1>0THEN6330 +6320 Y1=-Y1+1:L5=1 +6330 IFX1<=80THEN6350 +6340 X1=161-X1:L5=1 +6350 IFY1<=80THEN6370 +6360 Y1=161-Y1:L5=1 +6370 IFL5=0THEN6390 +6380 L6=1:GOTO6280 +6390 IFL6=0THEN6460 +6400 PRINT:PRINT"*** MESSAGE FROM STARFLEET COMMAND.....STARDATE";FNR(DO) +6410 PRINT"PERMISSION TO EXIT GALAXY - DENIED -" +6420 PRINT"'ENGINES SHUT DOWN AT "; +6430 Z1=INT((X1+9)/10):Z2=INT((Y1+9)/10) +6440 PRINT"QUADRANT";Z1;"-";Z2;", "; +6450 PRINT"SECTOR";X1-10*(Z1-1);"-";Y1-10*(Z2-1);"'" +6460 IFT5<>0THENRETURN +6470 Q1=INT((X1+9)/10):Q2=INT((Y1+9)/10) +6480 S6=X1-10*(Q1-1):S7=Y1-10*(Q2-1) +6490 GOSUB7550:PRINT:GOTO6510 +6500 PRINTCHR$(26):PRINT"ENTERING THE ";G2$;" QUADRANT (";Q1;"-";Q2;")" +6510 Q$(S6,S7)=LEFT$(S5$,1):GOSUB7260:GOSUB11090:GOSUB5650:RETURN +6520 Q$(S6,S7)=LEFT$(S5$,1) +6530 IFL6=1THENRETURN +6540 IFK3=0THEN6610 +6550 FORL=1TOK3 +6560 F3=SQR((F4-K4(L))^2+(F5-K5(L))^2) +6570 K8(L)=.5*(K7(L)+F3) +6580 K7(L)=F3 +6590 NEXTL +6600 GOSUB10980 +6610 GOSUB7230:RETURN +6620 A=1:B=1 +6630 FORK=1TOK3 +6640 C=K4(K):D=K5(K) +6650 IFQ$(C,D)="C"THEN6670 +6660 NEXTK +6670 N=0:F=K6(K)+100*K3 +6680 IFF>LQTHENN=INT(RND(1)*K7(K)+1) +6690 IF((C5$="DOCKED")AND((B4<>Q1)OR(B5<>Q2)))THENN=-S8 +6700 IFN=0THENN=INT(((F+200*RND(1))/150)-5) +6710 IFN=0THENRETURN +6720 IF(N>0)AND(K7(K)<1.5)THENRETURN +6730 IFABS(N)>S8THENN=SGN(N)*ABS(S8) +6740 T=ABS(N):P=S6-C:Q=S7-D +6750 IF2*ABS(P)0THENP=SGN(P*N) +6780 IFQ<>0THENQ=SGN(Q*N) +6790 R=C:S=D:Q$(C,D)="." +6800 FORL2=1TOT:L=R+P:M=S+Q +6810 IF(L>0)AND(L<=10)THEN6830 +6820 ONSGN(N)+2GOTO7060,6920,6920 +6830 IF(M>0)AND(M<=10)THEN6850 +6840 ONSGN(N)+2GOTO7060,6860,6860 +6850 IFQ$(L,M)="."THEN6980 +6860 IF(Q=B)OR(P=0)THEN6920 +6870 M=S+B +6880 IF(M>0)AND(M<=10)THEN6900 +6890 ONSGN(N)+2GOTO7060,6910,6910 +6900 IFQ$(L,M)="."THEN6980 +6910 B=-B +6920 IF(P=A)OR(Q=0)THEN6990 +6930 L=R+A +6940 IF(L>0)AND(L<=10)THEN6960 +6950 ONSGN(N)+2GOTO7060,6970,6970 +6960 IFQ$(L,M)="."THEN6980 +6970 A=-A:GOTO6990 +6980 R=L:S=M +6990 NEXTL2 +7000 Q$(R,S)="C" +7010 IF(R=C)AND(S=D)THENRETURN +7020 K4(K)=R:K5(K)=S:K7(K)=SQR((S6-R)^2+(S7-S)^2) +7030 K8(K)=K7(K):IFN>0THENPRINT"*** COMMANDER ADVANCES TO"; +7040 IFN<0THENPRINT"*** COMMANDER RETREATS TO"; +7050 PRINT" SECTOR";R;"-";S:GOSUB10980:RETURN +7060 I=Q1+INT((L+9)/10)-1:J=Q2+INT((M+9)/10)-1 +7070 IF(I<1)OR(I>8)THEN7220 +7080 IF(J<1)OR(J>8)THEN7220 +7090 FORL3=1TOR2 +7100 IF(C1(L3)=I)AND(C2(L3)=J)THEN7220 +7110 NEXTL3:PRINT"*** COMMANDER ESCAPES TO "; +7120 PRINT"QUADRANT";I;"-";J;" (AND REGAINS STRENGTH)" +7130 K4(K)=K4(K3):K5(K)=K5(K3):K7(K)=K7(K3):K8(K)=K8(K3) +7140 K6(K)=K6(K3):K3=K3-1:C3=0 +7150 IFC5$<>"DOCKED"THENGOSUB7230 +7160 GOSUB10980 +7170 G(Q1,Q2)=G(Q1,Q2)-100:G(I,J)=G(I,J)+100 +7180 FORL3=1TOR2 +7190 IF(C1(L3)=Q1)AND(C2(L3)=Q2)THEN7210 +7200 NEXTL3 +7210 C1(L3)=I:C2(L3)=J:RETURN +7220 A=-A:B=-B:GOTO6990 +7230 C5$="GREEN":IFE199THENC5$="RED" +7250 RETURN +7260 J4=1:B6=0:B7=0:K3=0:C3=0:U=G(Q1,Q2):IFU>999THEN7530 +7270 K3=INT(.01*U):FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +7280 Q$(S6,S7)=LEFT$(S5$,1):U=G(Q1,Q2):IFU<100THEN7400 +7290 U=U-100*K3:FORA=1TOK3 +7300 S=FNB(1):K4(A)=S:T=FNB(1):K5(A)=T +7310 IFQ$(S,T)<>"."THEN7300 +7320 Q$(S,T)="K":K7(A)=SQR((S6-S)^2+(S7-T)^2):K8(A)=K7(A) +7330 K6(A)=RND(1)*150+325:NEXTA +7340 IFR2=0THEN7390 +7350 FORA=1TOR2 +7360 IF(C1(A)=Q1)AND(C2(A)=Q2)THEN7380 +7370 NEXTA:GOTO7390 +7380 Q$(S,T)="C":K6(K3)=LQ+400*RND(1):C3=1 +7390 GOSUB10980 +7400 IFU<10THEN7440 +7410 U=U-10 +7420 B6=FNB(1):B7=FNB(1):IFQ$(B6,B7)<>"."THEN7420 +7430 Q$(B6,B7)="B" +7440 GOSUB7230:IFU<1THENRETURN +7450 FORA=1TOU +7460 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN7460 +7470 Q$(S,T)="*":NEXTA +7480 IF(T2<>Q1)OR(T3<>Q2)THENRETURN +7490 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN7490 +7500 Q$(S,T)="O":PRINT +7510 PRINT"*** SHORT-RANGE SENSORS DETECT A SPACE-WARP IN THIS QUADRANT" +7520 RETURN +7530 FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +7540 Q$(S6,S7)=LEFT$(S5$,1):RETURN +7550 G4$="III":L=2:IFQ2>=5THEN7570 +7560 L=1 +7570 G2$=G1$(2*(Q1-1)+L):L=Q2 +7580 IFL<=4THEN7600 +7590 L=Q2-4 +7600 G3$="IV":IFL=4THEN7620 +7610 G3$=LEFT$(G4$,L) +7620 G2$=G2$+" "+G3$:RETURN +7630 IFRND(1)>.1THEN7650 +7640 GOSUB10520:RETURN +7650 Q$(A5,A6)=".":PRINT"*** STAR AT SECTOR";A5;"-";A6;"NOVAS." +7660 G(Q1,Q2)=G(Q1,Q2)-1:S1=S1+1 +7670 B9=1:T6=1:T7=1:K=0:X1=0:Y1=0 +7680 H4(B9,1)=A5:H4(B9,2)=A6 +7690 FORM=B9TOT6:FORQ=1TO3:FORJ=1TO3 +7700 IFJ*Q=4THEN8140 +7710 J5=H4(M,1)+Q-2:J6=H4(M,2)+J-2 +7720 IF(J5<1)OR(J5>10)THEN8140 +7730 IF(J6<1)OR(J6>10)THEN8140 +7740 IFQ$(J5,J6)="."THEN8140 +7750 IFQ$(J5,J6)="O"THEN8140 +7760 IFQ$(J5,J6)<>"*"THEN7820 +7770 IFRND(1)>=.1THEN7790 +7780 X2=J5:Y2=J6:GOSUB10520:RETURN +7790 T7=T7+1:H4(T7,1)=J5:H4(T7,2)=J6:G(Q1,Q2)=G(Q1,Q2)-1 +7800 S1=S1+1:PRINT"*** STAR AT SECTOR";J5;"-";J6;"NOVAS." +7810 GOTO8130 +7820 IFQ$(J5,J6)<>"B"THEN7890 +7830 G(Q1,Q2)=G(Q1,Q2)-10:FORV=1TOR3 +7840 IF(B2(V)<>Q1)OR(B3(V)<>Q2)THEN7860 +7850 B2(V)=B2(R3):B3(V)=B3(R3) +7860 NEXTV:R3=R3-1:B6=0:B7=0:B1=B1+1:GOSUB7230 +7870 PRINT"*** STARBASE AT SECTOR";J5;"-";J6;"DESTROYED." +7880 GOTO8130 +7890 IF(S6<>J5)OR(S7<>J6)THEN7990 +7900 PRINT"*** STARSHIP BUFFETED BY NOVA.":IFS4<>0THEN7920 +7910 E1=E1-LQ:GOTO7950 +7920 IFS3>=LQTHEN7970 +7930 D6=LQ-S3:E1=E1-D6:GOSUB7230:S3=0:S4=0 +7940 PRINT"*** STARSHIP SHIELDS KNOCKED OUT.":D4(8)=5E-03*D5*RND(1))*D6 +7950 IFE1>0THEN7980 +7960 F9=7:GOSUB4710:RETURN +7970 S3=S3-LQ +7980 X1=X1+S6-H4(M,1):Y1=Y1+S7-H4(M,2):K=K+1:GOTO8140 +7990 IFQ$(J5,J6)<>"C"THEN8120 +8000 FORV=1TOK3 +8010 IF(K4(V)=J5)AND(K5(V)=J6)THEN8030 +8020 NEXTV +8030 K6(V)=K6(V)-800:IFK6(V)<=0THEN8120 +8040 N5=J5+J5-H4(M,1):N6=J6+J6-H4(M,2) +8050 PRINT"*** COMMANDER AT SECTOR";J5;"-";J6;"DAMAGED"; +8060 IF(N5<1)OR(N5>10)OR(N6<1)OR(N6>10)THEN8110 +8070 PRINT" AND BUFFETED TO SECTOR";N5;"-";N6 +8080 Q$(N5,N6)="C":K4(V)=N5:K5(V)=N6 +8090 K7(V)=SQR((S6-N5)^2+(S7-N6)^2):K8(V)=K7(V) +8100 Q$(J5,J6)="." +8110 PRINT:GOTO8140 +8120 A5=J5:A6=J6:T2$=Q$(J5,J6):GOSUB3160:GOTO8140 +8130 PRINT:Q$(J5,J6)="." +8140 NEXTJ:NEXTQ:NEXTM +8150 IFT6=T7THEN8170 +8160 B9=T6+1:T6=T7:GOTO7690 +8170 IFK=0THENRETURN +8180 D1=K*.1 +8190 IFX1<>0THENX1=SGN(X1) +8200 IFY1<>0THENY1=SGN(Y1) +8210 I=3*(X1+1)+Y1+2 +8220 D2=C5(I) +8230 IFD2=0THEND1=0 +8240 IFD1=0THENRETURN +8250 PRINT:PRINT"FORCE OF NOVA DISPLACES STARSHIP." +8260 GOSUB5850:RETURN +8270 P=2:J3=1 +8280 IFC5$<>"DOCKED"THEN8300 +8290 PRINT"PHASERS CAN'T BE FIRED THRU BASE SHIELDS.":GOTO8370 +8300 IFD4(3)=0THEN8320 +8310 PRINT"PHASER BANKS DAMAGED.":GOTO8370 +8320 IFS4=0THEN8340 +8330 PRINT"SHIELDS MUST BE DOWN TO FIRE PHASERS.":GOTO8370 +8340 IFK3>0THEN8380 +8350 PRINT +8360 PRINT"THE SHORT-RANGE SENSORS DETECT NO ENEMY IN THIS QUADRANT." +8370 J3=0:RETURN +8380 PRINT"PHASERS LOCKED ON TARGET. ENERGY AVAILABLE="; +8390 PRINT.01*INT(100*E1) +8400 INPUT"UNITS TO FIRE";P1:IFP1=ETHEN8610 +8590 H3(I)=H5(I):E=E-R7 +8600 NEXTI:GOTO8620 +8610 H3(I)=H3(I)+E:E=0 +8620 GOSUB5080 +8630 IF(E<>0)AND(A2=0)THEN8650 +8640 J3=1:RETURN +8650 PRINTFNR(E);"EXPENDED ON EMPTY SPACE.":J3=1:RETURN +8660 J3=1:IFD4(4)=0THEN8680 +8670 PRINT"PHOTON TUBES DAMAGED.":GOTO8720 +8680 IFT4<>0THEN8700 +8690 PRINT"NO TORPEDOS LEFT.":GOTO8720 +8700 INPUT"TORPEDO COURSE";C6 +8710 IFC6<.01ORC6>12THENGOSUB12780ELSE8730 +8720 J3=0:RETURN +8730 INPUT"BURST OF 3";B$:N=1 +8740 IFLEFT$(B$,1)="N"THEN8830 +8750 IFLEFT$(B$,1)<>"Y"THEN8730 +8760 IFT4>2THEN8780 +8770 PRINT"NO BURST. ONLY";T4;"TORPEDOS LEFT.":GOTO8720 +8780 INPUT"SPREAD ANGLE (3 - 30 DEG)";G2 +8790 IFG2<0THEN8720 +8800 IF(G2<3)OR(G2>30)THEN8780 +8810 G2=FND(G2) +8820 N=3 +8830 FORZ6=1TON +8840 IFC5$<>"DOCKED"THENT4=T4-1 +8850 Z7=Z6:R=RND(1) +8860 R=(R+RND(1))*.5-.5 +8870 IF(R>=-.4)AND(R<=.4)THEN8940 +8880 R=(RND(1)+1.2)*R:IFN=3THEN8900 +8890 PRINT"*** TORPEDO MISFIRES...":GOTO8910 +8900 PRINT"*** TORPEDO NUMBER";Z6;"MISFIRES..." +8910 IF RND(1)>.2THEN8940 +8920 PRINT"*** PHOTON TUBES DAMAGED BY MISFIRE." +8930 D4(4)=D5*(1+2*RND(1)):GOTO9580 +8940 IF(S4<>0)OR(C5$="DOCKED")THENR=R+1E-03*S3*R +8950 A3=C6+.25*R:IFN=1THEN8980 +8960 A8=(15-A3+(2-Z6)*G2)*.523599:PRINT +8970 PRINT"TRACK FOR TORPEDO NUMBER";Z7;"--":GOTO8990 +8980 PRINT:PRINT"TORPEDO TRACK --":A8=(15-A3)*.523599 +8990 X4=-SIN(A8):Y4=COS(A8):B8=ABS(X4) +9000 IFABS(Y4)>ABS(X4)THENB8=ABS(Y4) +9010 X4=X4/B8:Y4=Y4/B8:X5=S6:Y5=S7 +9020 FORL9=1TO15:X5=X5+X4:A5=INT(X5+.5) +9030 IF(A5<1)OR(A5>10)THEN9560 +9040 Y5=Y5+Y4:A6=INT(Y5+.5) +9050 IF(A6<1)OR(A6>10)THEN9560 +9060 IF(L9=5)OR(L9=9)THENPRINT +9070 PRINTFNR(X5);"-";FNR(Y5);", "; +9080 IFQ$(A5,A6)<>"."THEN9100 +9090 GOTO9550 +9100 PRINT:IFQ$(A5,A6)="K"THEN9150 +9110 IFQ$(A5,A6)<>"C"THEN9370 +9120 IFRND(1)>.1THEN9150 +9130 PRINT"*** COMMANDER AT SECTOR";A5;"-";A6;"USES ANTI-PHOTON DEVICE !" +9140 PRINT"-- TORPEDO NEUTRALIZED.":GOTO9570 +9150 FORV=1TOK3 +9160 IF(A5=K4(V))AND(A6=K5(V))THEN9180 +9170 NEXTV +9180 K=K6(V):W3=200+800*RND(1) +9190 IFABS(K)0THEN9220 +9210 T2$=Q$(A5,A6):GOSUB3160:GOTO9570 +9220 IFQ$(A5,A6)="K"THENPRINT"*** KLINGON AT"; +9230 IFQ$(A5,A6)="C"THENPRINT"*** COMMANDER AT"; +9240 PRINTA5;"-";A6; +9250 A7=A8+2.5*(RND(1)-.5) +9260 W3=ABS(-SIN(A7)):IFABS(COS(A7))>W3THENW3=ABS(COS(A7)) +9270 X7=-SIN(A7)/W3:Y7=COS(A7)/W3 +9280 P=INT(A5+X7+.5):Q=INT(A6+Y7+.5) +9290 IF(P<1)OR(P>10)OR(Q<1)OR(Q>10)THEN9360 +9300 IFQ$(P,Q)<>"."THEN9360 +9310 Q$(P,Q)=Q$(A5,A6):Q$(A5,A6)=".":PRINT"DAMAGED--" +9320 PRINT" DISPLACED BY BLAST TO SECTOR";P;"-";Q +9330 K4(V)=P:K5(V)=Q:K7(V)=SQR((S6-P)^2+(S7-Q)^2) +9340 K8(V)=K7(V) +9350 GOSUB10980:GOTO9570 +9360 PRINT"DAMAGED, BUT NOT DESTROYED.":GOTO9570 +9370 IFQ$(A5,A6)<>"B"THEN9450 +9380 PRINT"*** STARBASE DESTROYED...!!!" +9390 IFS2(Q1,Q2)<0THENS2(Q1,Q2)=0 +9400 FORW=1TOR3 +9410 IF(B2(W)<>Q1)OR(B3(W)<>Q2)THEN9430 +9420 B2(W)=B2(R3):B3(W)=B3(R3) +9430 NEXTW:Q$(A5,A6)=".":R3=R3-1:B6=0:B7=0 +9440 G(Q1,Q2)=G(Q1,Q2)-10:B1=B1+1:GOSUB7230:GOTO9570 +9450 IFQ$(A5,A6)<>"*"THEN9530 +9460 IFRND(1)>.15THEN9490 +9470 PRINT"*** STAR AT SECTOR";A5;"-";A6;"UNAFFECTED BY PHOTON BLAST" +9480 GOTO9570 +9490 X2=A5:Y2=A6:GOSUB7630:A5=X2:A6=Y2 +9500 IFG(Q1,Q2)=LQTHENRETURN +9510 IFA2<>0THENRETURN +9520 GOTO9570 +9530 PRINT:PRINT" >>> ORGANIAN TRUCE-MONITOR DESTROYED <<<":Q$(A5,A6)=".":PRINT +9540 T2=0:T3=0:GOTO9570 +9550 NEXTL9 +9560 PRINT:PRINT"TORPEDO MISSED!" +9570 NEXTZ6 +9580 IFR1<>0THENRETURN +9590 F9=1:GOSUB4710:RETURN +9600 PRINT:PRINT"*** RED ALERT!! RED ALERT!! ***":PRINT +9610 PRINT"*** COLLISION IMMINENT!!":PRINT +9620 PRINT"*** ";S5$;" RAMS ";:W7=1:IFQ$(S6,S7)="C"THENW7=2 +9630 IFW7=1THENPRINT"KLINGON AT "; +9640 IFW7=2THENPRINT"COMMANDER AT "; +9650 PRINT"SECTOR";S6;"-";S7:A5=S6:A6=S7:T2$=Q$(S6,S7) +9660 GOSUB3160:PRINT"*** ";S5$;" HEAVILY DAMAGED." +9670 K=INT(5+RND(1)*20):PRINT"***SICKBAY REPORTS";K;"CASUALTIES!" +9680 C4=C4+K:FORL=1TO12:I=RND(1) +9690 J=(3.5*W7*(RND(1)+I)+1)*D5 +9700 IFL=6THENJ=J/3 +9710 D4(L)=D4(L)+T1+J:NEXTL:D4(6)=D4(6)-3 +9720 IFD4(6)<0THEND4(6)=0 +9730 S4=0:IFR1<>0THENRETURN +9740 F9=1:GOSUB4710:RETURN +9750 RETURN +9760 A2=0:G1=0:GOSUB2200:S5$="ENTERPRISE" +9770 I7=5000:E1=I7:I8=2500:S3=I8:S4=0:S9=S4:J1=4:L1=J1 +9780 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):I9=10:T4=I9 +9790 W1=5:W2=25:FORI=1TO12:D4(I)=0:NEXT +9800 J2=100*INT(31*RND(1)+20):D0=J2:K1=0:K2=0:N1=0:N2=0:R6=0:C4=0 +9810 A1=1:D3=.25:FORI=1TO8:FORJ=1TO8:S2(I,J)=0:NEXTJ:NEXTI +9820 F1(1)=D0-.5*I5*LOG(RND(1)):F1(5)=1E+30 +9830 F1(2)=D0-1.5*(I5/R2)*LOG(RND(1)):I6=0 +9840 F1(3)=D0-.3*I5*LOG(RND(1)):F1(4)=D0-.3*I5*LOG(RND(1)) +9850 FORI=1TO8:FORJ=1TO8:K=INT(RND(1)*9+1):I6=I6+K +9860 G(I,J)=K:NEXTJ:NEXTI:S1=0 +9870 FOR I=1TOI2 +9880 X=INT(RND(1)*6+2):Y=INT(RND(1)*6+2) +9890 IFG(X,Y)>=10THEN9880 +9900 IFI<2THEN9940 +9910 K=I-1:FORJ=1TOK:D1=SQR((B2(J)-X)^2+(B3(J)-Y)^2) +9920 IFD1<2THEN9880 +9930 NEXTJ +9940 B2(I)=X:B3(I)=Y:S2(X,Y)=-1:G(X,Y)=G(X,Y)+10:NEXTI +9950 B1=0:K=I1-I4:L=INT(.25*S8*(9-L2)+1) +9960 M=INT((1-RND(1)^2)*L):IFM>KTHENM=K +9970 N=100*M +9980 X=FNA(1):Y=FNA(1):IFG(X,Y)+N>999THEN9980 +9990 G(X,Y)=G(X,Y)+N:K=K-M:IFK<>0THEN9960 +10000 FORI=1TOI4 +10010 X=FNA(1):Y=FNA(1):IF(G(X,Y)<99)AND(RND(1)<.75)THEN10010 +10020 IFG(X,Y)>899THEN10010 +10030 IFI=1THEN10060 +10040 M=I-1:FORJ=1TOM:IF(C1(J)=X)AND(C2(J)=Y)THEN10010 +10050 NEXTJ +10060 G(X,Y)=G(X,Y)+100:C1(I)=X:C2(I)=Y:NEXTI +10070 I=INT(D0):PRINT:S0=0 +10080 T2=FNA(1):T3=FNA(1):IFG(T2,T3)<100THEN10080 +10090 PRINT"STARDATE..............";I +10100 PRINT"NUMBER OF KLINGONS....";I1 +10110 PRINT"NUMBER OF STARDATES...";INT(I5) +10120 PRINT"NUMBER OF STARBASES...";I2 +10130 PRINT"STARBASE LOCATIONS...."; +10140 FORI=1TOI2:PRINTB2(I);"-";B3(I); +10150 IFI<>I2THENPRINT", "; +10160 NEXTI:PRINT:PRINT +10170 GOSUB7550 +10180 PRINT"THE ";S5$;" IS CURRENTLY IN THE ";G2$;" QUADRANT." +10190 GOSUB7260 +10200 PRINT:INPUT"READY TO CONTINUE";NL$:PRINTCHR$(26):GOSUB11090:GOSUB5650:RETURN +10210 INPUT"WARP FACTOR";K +10220 PRINT +10230 IFK<1THEN10340 +10240 IFK>10THEN10350 +10250 J=W1:W1=K:W2=W1*W1 +10260 IF(W1<=J)OR(W1<=6)THEN10290 +10270 IFW1<=8THEN10300 +10280 IFW1>8THEN10310 +10290 PRINT"'WARP FACTOR";W1;"CAPTAIN'":RETURN +10300 PRINT"*** OUR MAXIMUM SAFE SPEED IS WARP 6":RETURN"; +10310 IFW1=10THEN10330 +10320 PRINT"*** CAPTAIN, OUR ENGINES MAY NOT TAKE IT !":RETURN +10330 PRINT"-'AYE, CAPTAIN, WE'LL GIVE IT A TRY.'":RETURN +10340 PRINT"-'WE CAN'T GO BELOW WARP 1, CAPTAIN.'":RETURN +10350 PRINT"-'OUR TOP SPEED IS WARP 10, CAPTAIN.'" +10360 RETURN +10370 J3=0:IFD4(8)<>0THEN10490 +10380 IFS4<>0THEN10420 +10390 INPUT"SHIELDS ARE DOWN. DO YOU WANT THEM UP";B$ +10400 IFLEFT$(B$,1)="Y"THEN10450 +10410 RETURN +10420 INPUT"SHIELDS ARE UP. DO YOU WANT THEM DOWN";B$ +10430 IFLEFT$(B$,1)="Y"THEN10480 +10440 RETURN +10450 S4=1:S9=1:IFC5$<>"DOCKED"THENE1=E1-50 +10460 PRINT"SHIELDS RAISED.":IFE1<=0THEN10500 +10470 J3=1:RETURN +10480 S4=0:S9=1:PRINT"SHIELDS LOWERED.":J3=1:RETURN +10490 PRINT"SHIELDS DAMAGED AND DOWN. ":RETURN +10500 PRINT:PRINT"SHIELDS CONSUME ALL ENERGY." +10510 F9=4:GOSUB4710:RETURN +10520 IFX2<>0THEN10620 +10530 N=INT(RND(1)*I6+1):FORX=1TO8:FORY=1TO8 +10540 N=N-(G(X,Y)-INT(G(X,Y)/10)*10):IFN<=0THEN10560 +10550 NEXTY:NEXTX:RETURN +10560 IF(X<>Q1)OR(Y<>Q2)THEN10680 +10570 IFJ4<>0THEN10680 +10580 N=INT(RND(1)*(G(X,Y)-INT(G(X,Y)/10)*10))+1 +10590 FORX3=1TO10:FORY3=1TO10:IFQ$(X3,Y3)<>"*"THEN10610 +10600 N=N-1:IFN=0THEN10620 +10610 NEXTY3:NEXTX3 +10620 PRINT:PRINT"*** RED ALERT!! RED ALERT!! *** +10630 X3=X2:Y3=Y2 +10640 PRINT"*** INCIPIENT SUPERNOVA DETECTED AT SECTOR";X3;"-";Y3 +10650 X=Q1:Y=Q2:K=(X2-S6)^2+(Y2-S7)^2 +10660 IFK>1.5THEN10720 +10670 PRINT"*** EMERGENCY AUTO-OVERRIDE JAMMED ***":A2=1:GOTO10720 +10680 IFD4(9)<>0THEN10720 +10690 PRINT:PRINT"MESSAGE FROM STARFLEET COMMAND...STARDATE";INT(D0) +10700 PRINT"'SUPERNOVA IN QUADRANT";X;"-";Y; +10710 PRINT"....CAUTION ADVISED'" +10720 N=G(X,Y):R=INT(N/100):Q=0 +10730 IF(X<>Q1)OR(Y<>Q2)THEN10750 +10740 K3=0:C3=0 +10750 IFR=0THEN10810 +10760 R1=R1-R:IFR2=0THEN10810 +10770 FORL=1TOR2:IF(C1(L)<>X)OR(C2(L)<>Y)THEN10800 +10780 C1(L)=C1(R2):C2(L)=C2(R2):C1(R2)=0:C2(R2)=0 +10790 R2=R2-1:R=R-1:Q=1:IFR2=0THENF1(2)=1E+30 +10800 NEXTL +10810 IFR3=0THEN10850 +10820 FORL=1TOR3:IF(B2(L)<>X)OR(B3(L)<>Y)THEN10840 +10830 B2(L)=B2(R3):B3(L)=B3(R3):B2(R3)=0:B3(R3)=0:R3=R3-1 +10840 NEXTL +10850 IFX2=0THEN10890 +10860 N=G(X,Y)-INT(G(X,Y)/100)*100 +10870 S1=S1+(N-INT(N/10)*10):B1=B1+INT(N/10) +10880 K1=K1+R:K2=K2+Q +10890 IF(S2(X,Y)<>0)AND(D4(9)<>0)THENS2(X,Y)=LQ+G(X,Y) +10900 IF(D4(9)=0)OR((Q1=X)AND(Q2=Y))THENS2(X,Y)=1 +10910 G(X,Y)=1000 +10920 IF(R1<>0)OR((X=Q1)AND(Y=Q2))THEN10960 +10930 PRINTCHR$(26):PRINT"*** SUPERNOVA IN QUADRANT";X;"-";Y;"HAS DESTROYED THE" +10940 PRINT"REMAINDER OF THE ENEMY FLEET !!" +10950 F9=1:GOTO4710 +10960 IFA2=0THENRETURN +10970 F9=8:GOTO4710 +10980 IFK3<=1THENRETURN +10990 Z4=0:FORO=1TOK3-1:IFK7(O)<=K7(O+1)THEN11060 +11000 K=K7(O):K7(O)=K7(O+1):K7(O+1)=K +11010 K=K8(O):K8(O)=K8(O+1):K8(O+1)=K +11020 K=K4(O):K4(O)=K4(O+1):K4(O+1)=K +11030 K=K5(O):K5(O)=K5(O+1):K5(O+1)=K +11040 K=K6(O):K6(O)=K6(O+1):K6(O+1)=K +11050 Z4=1 +11060 NEXTO +11070 IFZ4<>0THEN10990 +11080 RETURN +11090 IFD(1)<>0THEN11330 +11100 PRINT:PRINT" 1 2 3 4 5 6 7 8 9 10" +11110 FORI=1TO10:IFI<10THENPRINT" "; +11120 PRINTI;:FORJ=1TO10:PRINTQ$(I,J);" ";:NEXTJ +11130 ONIGOTO11150,11160,11180,11190,11240 +11140 ONI-5GOTO11250,11260,11270,11300,11310 +11150 PRINT" STARDATE ";FNR(D0):GOTO11320 +11160 IFC5$<>"DOCKED"THENGOSUB7230 +11170 PRINT" CONDITION ";C5$:GOTO11320 +11180 PRINT" POSITION ";Q1;"-";Q2;", ";S6;"-";S7:GOTO11320 +11190 PRINT" LIFE SUPPORT ";:IFD4(5)<>0THEN11210 +11200 PRINT"ACTIVE":GOTO11320 +11210 IFC5$<>"DOCKED"THEN11230 +11220 PRINT"DAMAGED, SUPPORTED BY STARBASE":GOTO11320 +11230 PRINT"DAMAGED, RESERVES=";FNS(L1):GOTO11320 +11240 PRINT" WARP FACTOR ";FNR(W1):GOTO11320 +11250 PRINT" ENERGY";SPC(8);.01*INT(100*E1):GOTO11320 +11260 PRINT" TORPEDOS ";T4:GOTO11320 +11270 PRINT" SHIELDS ";:B$="DOWN,":IFS4<>0THENB$="UP," +11280 IFD4(8)>0THENB$="DAMAGED," +11290 PRINTB$;INT(100*S3/I8+.5);"%":GOTO11320 +11300 PRINT" KLINGONS LEFT ";R1:GOTO11320 +11310 PRINT" TIME LEFT ";FNS(R5) +11320 NEXTI:RETURN +11330 PRINT"SHORT RANGE SENSORS DAMAGED.":RETURN +11340 PRINT:PRINT"*** TIME WARP ENTERED ***":PRINT"YOU ARE TRAVELING "; +11350 IFS0<>0THEN11390 +11360 T1=-.5*I5*LOG(RND(1)) +11370 PRINT"FORWARD IN TIME";FNR(T1);"STARDATES." +11380 F1(2)=F1(2)+T1:GOTO11550 +11390 M=D0:D0=D9(1) +11400 PRINT"BACKWARD IN TIME";FNR(M-D0);"STARDATES.":S0=0 +11410 R1=D9(2):R2=D9(3):R3=D9(4):R4=D9(5):R5=D9(6) +11420 S1=D9(7):B1=D9(8):K1=D9(9):K2=D9(10) +11430 FORI=1TO8:FORJ=1TO8:G(I,J)=D9(I-1+8*(J-1)+11):NEXTJ:NEXTI +11440 FORI=75TO84:C1(I-74)=D9(I):NEXT +11450 FORI=85TO94:C2(I-84)=D9(I):NEXT +11460 FORI=95TO99:B2(I-94)=D9(I):NEXT +11470 FORI=100TO104:B3(I-99)=D9(I):NEXT:B4=D9(105):B5=D9(106) +11480 F1(1)=D0-.5*I5*LOG(RND(1)) +11490 IFR2<>0THENF1(2)=D0-(I5/R2)*LOG(RND(1)) +11500 F1(3)=D0-.5*I5*LOG(RND(1)) +11510 FORI=1TO8:FORJ=1TO8:IF10THEN11690 +11570 INPUT"NUMBER OF UNITS TO SHIELDS";Z3 +11580 IFZ3<0THENRETURN +11590 IFE1+S3-Z3>0THEN11620 +11600 PRINT"SCOTT HERE- 'WE ONLY HAVE";FNR(E1+S3);"UNITS LEFT.'" +11610 RETURN +11620 E1=E1+S3-Z3:S3=Z3:PRINT"--ENERGY TRANSFER COMPLETE--" +11630 PRINT"(SHIP ENERGY=";FNR(E1);" SHIELD ENERGY=";FNR(S3);")" +11640 J3=1 +11650 T1=.1:P5=(K3+4*C3)/48:IFP5<.1THENP5=.1 +11660 IFP5>RND(1)THENGOSUB790 +11670 IFA2<>0THENRETURN +11680 GOSUB3640:RETURN +11690 PRINT"TRANSFER PANEL DAMAGED.":RETURN +11700 J3=0:INPUT"HOW MANY STARDATES";Z5:IF(Z5"Y"THENRETURN +11720 R6=1 +11730 IFZ5<=0THENR6=0 +11740 IFR6=0THENRETURN +11750 T1=Z5:Z6=Z5 +11760 IFK3=0THEN11790 +11770 T1=1+RND(1):IFZ50THENRETURN +11810 GOSUB3640:J3=1:IFA2<>0THENRETURN +11820 Z5=Z5-Z6:GOTO11730 +11830 J3=0:IFD4(6)<>0THEN12300 +11840 INPUT"ENTER COURSE...";D2:IFD2<.01ORD2>12THENGOSUB12780 +11850 INPUT"DISTANCE...";D1 +11860 P=(D1+.05)*W1*W1*W1*(S4+1):IFPE1)THEN11910 +11890 PRINT" WE HAVEN'T THE ENERGY TO GO THAT FAR WITH"; +11900 PRINT" THE SHIELDS UP.":RETURN +11910 W=INT((E1/(D1+.05))^.333333):IFW<=0THEN11960 +11920 PRINT" WE HAVEN'T THE ENERGY. BUT WE COULD DO IT AT WARP";W +11930 IFS4<>0THEN11950 +11940 RETURN +11950 PRINT" IF YOU'LL LOWER THE SHIELDS.":RETURN +11960 PRINT" WE CAN'T DO IT, CAPTAIN. WE HAVEN'T GOT THE ENERGY." +11970 RETURN +11980 T1=10*D1/W2:IFT1<.8*R5THEN12040 +11990 PRINT:PRINT"MR. SPOCK - 'CAPTAIN, I COMPUTE THAT SUCH A TRIP" +12000 PRINT" WILL REQUIRE APPROXIMATELY";FNR(100*T1/R5); +12010 PRINT"PERCENT":PRINT" OF OUR REMAINING TIME. ARE YOU SURE "; +12020 INPUT "THIS IS WISE";B$:IFLEFT$(B$,1)="Y"THEN12040 +12030 J3=0:RETURN +12040 Q4=0:W=0:IFW1<=6THEN12200 +12050 P=D1*(6-W1)^2/66.6667:IFP>RND(1)THENQ4=1 +12060 IFQ4<>0THEND1=RND(1)*D1 +12070 W=0:IFW1<10THEN12090 +12080 IF.25*D1>RND(1)THENW=1 +12090 IF(Q4=0)AND(W=0)THEN12200 +12100 A=(15-D2)*.5236:X1=-SIN(A):X2=COS(A) +12110 B8=ABS(X1):IFABS(X2)>ABS(X1)THENB8=ABS(X2) +12120 X1=X1/B8:Y1=Y1/B8:N=INT(10*D1*B8+.5):X=S6:Y=S7 +12130 IFN=0THEN12200 +12140 FORL=1TON +12150 X=X+X1:Q=INT(X+.5):IF(Q<1)OR(Q>10)THEN12200 +12160 Y=Y+Y1:R=INT(Y+.5):IF(R<1)OR(R>10)THEN12200 +12170 IFQ$(Q,R)="."THEN12190 +12180 Q4=0:W=0 +12190 NEXTL +12200 GOSUB5850:IFA2<>0THENRETURN +12210 E1=E1-D1*W1*W1*W1*(S4+1):IFE1>0THEN12230 +12220 F9=4:GOSUB4710:RETURN +12230 T1=10*D1/W2:IFW<>0THENGOSUB11340 +12240 IFQ4=0THEN12290 +12250 PRINT:PRINT"ENGINEERING TO BRIDGE--":PRINT" SCOTT HERE- "; +12260 PRINT"'WE'VE JUST BLOWN THE WARP ENGINES." +12270 PRINT" WE'LL HAVE TO SHUT 'ER DOWN HERE, CAPTAIN.'" +12280 D4(6)=D5*(3*RND(1)+1) +12290 J3=1:RETURN +12300 PRINT"WARP ENGINES DAMAGED.":RETURN +12310 ONSGN(D4(10))+2GOTO12320,12340,12330 +12320 PRINT"YE FAERIE QUEENE HAS NO SHUTTLE CRAFT.":RETURN +12330 PRINT"SHUTTLE CRAFT DAMAGED.":RETURN +12340 PRINT:PRINT"***ABANDON SHIP! ABANDON SHIP!" +12350 PRINT"***ALL HANDS ABANDON SHIP!":PRINT +12360 PRINT"YOU AND THE BRIDGE CREW ESCAPE IN THE GALILEO." +12370 PRINT"THE REMAINDER OF THE CREW BEAMS DOWN" +12380 PRINT"TO THE NEAREST HABITABLE PLANET.":IFR3<>0THEN12400 +12390 F9=9:GOSUB4710:RETURN +12400 PRINT:PRINT"YOU ARE CAPTURED BY KLINGONS AND RELEASED TO" +12410 PRINT"THE FEDERATION IN A PRISONER-OF-WAR EXCHANGE." +12420 PRINT"STARFLEET PUTS YOU IN COMMAND OF ANOTHER SHIP," +12430 PRINT"THE FAERIE QUEENE WHICH IS ANTIQUATED, BUT" +12440 PRINT"STILL USABLE.":N=INT(RND(1)*R3+1):Q1=B2(N):Q2=B3(N) +12450 S6=5:S7=5:GOSUB7260:Q$(S6,S7)="." +12460 FORL=1TO3:S6=INT(3*RND(1)-1+B6) +12470 IF(S6<1)OR(S7>10)THEN12500 +12480 S7=INT(3*RND(1)-1+B7):IF(S7<1)OR(S7>10)THEN12500 +12490 IFQ$(S6,S7)="."THEN12510 +12500 NEXTL:GOTO12450 +12510 S5$="FAERIE QUEENE":Q$(S6,S7)=LEFT$(S5$,1):C5$="DOCKED" +12520 FORL=1TO12:D4(L)=0:NEXT:D4(10)=-1:E1=3000:I7=E1 +12530 S3=1500:I8=S3:T4=6:I9=T4:L1=3:J1=L1:S4=0:W1=5:W2=25 +12540 RETURN +12550 IFD4(11)=0THEN12580 +12560 PRINT"COMPUTER DAMAGED - CANNOT EXECUTE DESTRUCT SEQUENCE" +12570 RETURN +12580 PRINT:PRINT" ---WORKING---" +12590 PRINT"IDENTIFICATION-POSITIVE" +12600 PRINT"SELF-DESTRUCT-SEQUENCE-ACTIVATED":J=3 +12610 FORI=10TO6STEP-1:PRINTSPC(J);I:GOSUB12760:J=J+3:NEXT +12620 PRINT"ENTER-YOUR-MISSION-PASSWORD-TO-CONTINUE" +12630 PRINT"SELF-DESTRUCT-SEQUENCE-OTHERWISE-DESTRUCT" +12640 PRINT"SEQUENCE-WILL-BE-ABORTED" +12650 INPUTB$:IFB$<>X$THEN12740 +12660 PRINT"PASSWORD-ACCEPTED":J=10 +12670 FORI=5TO1STEP-1:PRINTSPC(J);I:GOSUB12760:J=J+3:NEXT +12680 PRINT:PRINT"*****ENTROPY OF ";S5$;" MAXIMIZED*****" +12690 PRINT:IFK3=0THEN12730 +12700 W=20*E1:FORL=1TOK3:IFK6(L)*K7(L)>WTHEN12720 +12710 A5=K4(L):A6=K5(L):T2$=Q$(A5,A6):GOSUB3160 +12720 NEXTL +12730 F9=10:GOSUB4710:RETURN +12740 PRINT"PASSWORD-REJECTED" +12750 PRINT"CONTINUITY-EFFECTED":PRINT:RETURN +12760 K=12345:FORM=1TO90:K=K+1:NEXTM:RETURN +12770 FORI=1TO10:GOTO11130:RETURN +12780 PRINT"---> COURSE(S) .01-12 ONLY !!!":RETURN + \ No newline at end of file diff --git a/software/BAS/TVIGAMMO.BAS b/software/BAS/TVIGAMMO.BAS new file mode 100644 index 0000000..012a66b --- /dev/null +++ b/software/BAS/TVIGAMMO.BAS @@ -0,0 +1,371 @@ +10 REM **************** GAMMON ***************** +20 REM +22 REM Converted for Televideo 912 terminal by Bill Soon, August 1981 +24 REM Cursor control codes probably OK for ADM-3 & SOROC also. +26 REM * further refinements encouraged * +30 REM originally written for HEATH H-8 OR H-89 WITH H-19 +35 REM REQUIRES MICROSOFT +40 REM +50 REM By: R. Wild +55 REM OSO11 Nepil Ave. +60 REM Wheaton, Ill. 60187 +70 REM +80 REM Idea by Cursor Magazine +100 CLEAR 1000 +200 GOSUB 9000 +210 RR=RND(1) +240 DIM B(27),D(4),DA$(3),DI$(6,6),US(4),P(24),PR(6),M$(5) +260 DIM T(6) +280 BK$=SPACE$(38) +300 M$(1)=" HIT YOUR BLOT AT ":M$(2)=" COVERED MY BLOT AT " +310 M$(3)=" MOVED TO " +320 M$(5)="MOVED BLOT TO SAFETY AT ":M$(4)=" CAN'T MAKE MOVE " +340 M$(0)=" BEARING OFF FROM ":FR$=" FROM " +360 A$="":DA$(1)="q":DA$(2)=" ":DA$(3)="*":ER$=A$+"" +380 AA$=CHR$(27)+CHR$(61)+CHR$(31+6)+CHR$(33):AL$="XWVUTSRQPONMLKJIHGFEDCBA" +390 A$=CHR$(27)+CHR$(61)+CHR$(31+10)+CHR$(33) +400 FOR I=1 TO 12:READ P(I):NEXT +420 DATA .31,.33,.39,.42,.42,.47,.17,.17,.14,.08,.06,.08 +440 FOR I=0 TO 6:READ PR(I):NEXT +460 DATA 0,.03,.11,.25,.44,.69,1 +480 GOSUB 8000 +640 CM=24:F=6:S=0:HM=24:HB=0:CB=0:XC=0:XH=0 +660 PRINT ERAS$;"* BACKGAMMON *" +662 PRINT "Difficulty (1=easy, 10=hard)? ";:LINE INPUT IN$ +665 PRINT CO$ +680 TT=(VAL(IN$)/10):PRINT GRA$ +700 IF TT>1 OR TT<=0 THEN 660 +720 PRINT ERAS$:A=TT:IF RND(1)<.5 THEN F=1 +740 GOSUB 4220:GOSUB 4460 +760 GOSUB 8250:IF D(1)=D(2)THEN 760 +780 NP=1: PRINT AA$" MINE YOURS":FOR I=1 TO 500:NEXT +790 GOSUB 8280:FOR I=1 TO 500:NEXT:GOSUB 4580 +820 PRINT A$;:IF D(2)>D(1)THEN NP=-1:PRINT"YOU"; +840 IF D(2)2 THEN IN$=MID$(IN$,2):GOTO 1120 +1100 GOSUB 4580:PRINT A$;CN$;" MOVE";I;"? ";:GOSUB 6240:PRINT:PRINT:IF IN$=""THEN 2180 +1120 IF LEN(IN$)>1 THEN 1220 +1140 IF IN$>="A"AND IN$<="F"THEN IN$="="+IN$ +1160 IF IN$>="S"AND IN$<="X"THEN IN$=IN$+"-" +1180 IF LEN(IN$)>1 THEN 1220 +1200 PRINT"BAD MOVE.":GOTO 1060 +1220 IF LEN(IN$)>3 THEN 1200 +1240 IF MID$(IN$,2,1)=","THEN IN$=LEFT$(IN$,1)+MID$(IN$,3):GOTO 1240 +1260 F$=LEFT$(IN$,1) +1280 IF F$>="A"AND F$<="X"THEN FM=89-ASC(F$):GOTO 1320 +1300 FM=25:IF F$<>"="AND F$<>"-"THEN 1200 +1320 T$=MID$(IN$,2,1) +1340 IF T$="="OR T$="-"THEN TM=0:GOTO 1400 +1360 IF T$<"A"OR T$>"X"THEN 1200 +1380 TM=89-ASC(T$):N=0:M=FM-TM:K=1:L=0 +1400 IF FM=25 AND B(25)=0 THEN PRINT"YOU HAVE NO MEN ON THE BAR.":GOTO 1060 +1420 IF FM25 THEN PRINT"YOU HAVE MEN ON THE BAR.":GOTO 1060 +1460 IF B(FM)>=0 THEN PRINT"YOU HAVE NO MEN ON ";F$;".":GOTO 1060 +1480 IF TM=0 THEN 1920 +1500 L=0:FOR J=1 TO TU:IF US(J)THEN K=K+1:GOTO 1560 +1520 L=L+1:N=N+D(J):IF N=M THEN 1580 +1540 IF D(J)=M THEN K=J:L=1:GOTO 1580 +1560 NEXT J:PRINT"YOU CAN'T MOVE";M;".":GOTO 1060 +1580 IF B(TM)>1 THEN PRINT"POINT ";T$;" IS BLOCKED.":GOTO 1060 +1600 IF L=1 THEN GOSUB 5880:US(K)=1:GOTO 2580 +1620 IF B(25)<-1 THEN PRINT"YOU HAVE MEN ON THE BAR.":GOTO 1060 +1640 IF TU=4 THEN 1760 +1660 IF B(FM-D(1))<=1 THEN M=1:GOTO 1720 +1680 IF B(FM-D(2))<=1 THEN M=2:GOTO 1720 +1700 PRINT"THE PATH IS BLOCKED.":GOTO 1060 +1720 N=TM:TM=FM-D(M):GOSUB 5880:FM=TM:TM=N::GOSUB 5880:I=I+1 +1740 GOTO 2580 +1760 FOR N=1 TO L +1780 IF B(FM-D(1)*N)>1 THEN 1700 +1800 NEXT N +1820 FOR N=K TO J +1840 TM=FM-D(N):US(N)=1:GOSUB 5880 +1860 I=I+1:FM=TM:NEXT N +1880 I=I-1:GOTO 2580 +1900 NEXT K +1920 FOR J=7 TO 25:IF B(J)<0 THEN PRINT"YOU CAN'T CHEAT!!":GOTO 1060 +1940 NEXT J +1960 TM=26:FOR J=1 TO TU:IF US(J)=0 AND FM=D(J)THEN GOSUB 5880:US(J)=1:GOTO 2580 +1980 NEXT J +2000 IF FM=6 THEN 2080 +2020 FOR J=6 TO FM+1 STEP-1 +2040 IF B(J)<0 THEN PRINT"YOU CAN'T BEAR OFF FROM ";F$;".":GOTO 1060 +2060 NEXT J +2080 K=0:D(K)=0:FOR J=1 TO TU:IF US(J)=0 AND D(J)>FM AND D(J)>D(K)THEN K=J +2100 NEXT J +2120 IF K=0 THEN PRINT"YOU CAN'T MOVE";FM;".":GOTO 1060 +2140 PRINT"ASSUMING USE OF";D(K);".":US(K)=1 +2160 GOSUB 5880:GOTO 2580 +2180 IF B(25)>=0 THEN 2280 +2200 FOR J=1 TO 6 +2220 IF J=D(TU)AND US(TU)=0 AND B(25-J)<2 THEN 2560 +2240 IF J=D(TU-1)AND US(TU-1)=0 AND B(25-J)<2 THEN 2560 +2260 NEXT J:GOTO 2600 +2280 FOR J=24 TO 2 STEP-1 +2300 IF B(J)>=0 THEN 2360 +2320 IF J-D(TU-1)>0 THEN IF US(TU-1)=0 AND B(J-D(TU-1))<2 THEN 2560 +2340 IF J-D(TU)>0 THEN IF US(TU)=0 AND B(J-D(TU))<2 THEN 2560 +2360 NEXT J +2380 FOR J=24 TO 7 STEP-1:IF B(J)<0 THEN 2600 +2400 NEXT J +2420 IF US(TU)=0 AND B(D(TU))<0 THEN 2560 +2440 IF US(TU-1)=0 AND B(D(TU-1))<0 THEN 2560 +2460 IF US(TU)THEN D=D(TU-1):GOTO 2500 +2480 D=D(TU):IF US(TU-1)=0 AND DTU THEN 2800 +2700 IF B(D(K))<>-1 THEN 2680 +2720 US(K)=1:MO=MO+1 +2740 FM=0:TM=D(K):GOSUB 5880 +2760 PRINT"OFF BAR AND HIT BLOT AT ";MID$(AL$,TM,1) +2780 GOTO 2680 +2800 K=0 +2820 K=K+1:IF B(0)=0 OR K>TU THEN 2940 +2840 IF B(D(K))<0 OR US(K)>0 THEN 2820 +2860 US(K)=1:MO=MO+1 +2880 FM=0:TM=D(K):GOSUB 5880 +2900 PRINT"OFF BAR TO ";MID$(AL$,TM,1) +2920 GOTO 2820 +2940 IF B(0)=0 AND MO6 THEN 3380 +3020 FOR J=1 TO TU:L=25-D(J):IF B(L)<1 THEN 3060 +3040 FM=L:TM=27:GOSUB 5880:PRINT M$(0);MID$(AL$,L,1):MO=MO+1 +3150 GOSUB 8500:GOTO 3300 +3060 K=6 +3080 Y=25-K:IF B(L-K)<1 OR B(Y)<-1 THEN 3160 +3100 IF B(Y)=-1 THEN B(Y)=0 +3120 FM=L-K:TM=Y:GOSUB 5880 +3140 PRINT M$(3);MID$(AL$,Y,1);FR$;MID$(AL$,FM,1) +3150 GOSUB 8500:GOTO 3300 +3160 IF K>1 THEN K=K-1:GOTO 3080 +3180 K=1 +3200 IF L+K>24 THEN 3280 +3220 IF B(L+K)<1 THEN 3280 +3240 MO=MO+1:FM=L+K:TM=27:GOSUB 5880 +3260 PRINT M$(0);MID$(AL$,FM,1);" WITH ROLL OF";D(J) +3270 GOSUB 8500:GOTO 3300 +3280 IF K<6 THEN K=K+1:GOTO 3200 +3300 IF B(27)=15 THEN 5460 +3320 IF TU=MO THEN 4160 +3340 NEXT J +3360 GOTO 4160 +3380 IF TU=MO THEN 4160 +3400 IF TU-MO<2 THEN 3720 +3420 IF HB=0 THEN 3720 +3440 J=1 +3460 IF B(J)<>-1 THEN 3700 +3480 J1=J-D(1):J2=J-D(2):IF J1<1 OR J2<1 THEN 3700 +3500 IF D(1)=D(2)AND B(J1)=1 THEN 3700 +3520 IF B(J1)<1 OR B(J2)<1 THEN 3700 +3540 IF TU=4 THEN 3600 +3560 IF J1>18 AND B(J1)=2 THEN 3700 +3580 IF J2>18 AND B(J2)=2 THEN 3700 +3600 MV=MV-1:TM=J:FM=J1:GOSUB 5880:FM=J2:GOSUB 5880 +3620 PRINT M$(1);MID$(AL$,J,1);FR$; +3640 PRINT MID$(AL$,J1,1);" AND ";MID$(AL$,J2,1):MO=MO+2:HB=HB-1 +3650 GOSUB 8500 +3660 IF TU=4 THEN US(3)=1:US(4)=1 +3680 GOTO 3380 +3700 IF J<24 THEN J=J+1:GOTO 3460 +3720 TRY=0:Y=1 +3740 IF US(Y)=1 THEN 4120 +3760 GOSUB 5120 +3780 IF Y<>1 OR MO<>0 OR TU=4 OR BM=4 THEN 3900 +3800 S1=BS:F1=FM:M1=BM:Y=2:GOSUB 5120 +3820 S2=BS:F2=FM:M2=BM:Y=3:G=1:GOSUB 5120 +3840 G=0:IF BS>S1+S2 THEN Y=TM:TM=FM+D(Y):GOTO 3900 +3860 IF S2>S1 THEN FM=F2:Y=2:TM=F2+D(Y):BM=M2:GOTO 3900 +3880 FM=F1:Y=1:TM=F1+D(Y):BM=M1 +3900 IF BM<>4 THEN 4020 +3920 IF F<>1 THEN F=1:GOTO 3760 +3940 IF TRY0 OR B9 THEN PRINT M$(4);:GOSUB 8500:GOTO 4160 +3980 NEXT J:B9=1:GOTO 3020 +4000 GOTO 4120 +4020 IF BM=1 THEN HB=HB-1 +4040 MO=MO+1:US(Y)=1:IF HM<24-CM THEN BM=3:A=0 +4060 GOSUB 5880 +4080 PRINT M$(BM);MID$(AL$,TM,1);FR$;MID$(AL$,FM,1) +4090 GOSUB 8500 +4100 IF MO=TU THEN 4160 +4120 Y=Y+1:IF Y>TU THEN Y=1 +4140 GOTO 3740 +4160 NP=-1 +4180 GOTO 5460 +4200 PRINT M$(MN);MID$(AL$,TM,1); +4210 GOSUB 8500 +4220 PRINT ERAS$;:H=8:L$=" 2 ":M$=" 2 ":R$=" 2" +4240 ESC$=CHR$(27):GR$="":LC$="":RV$=ESC$+"j":RVO$=ESC$+"k" +4245 DA$(1)="q" +4250 ERAS$=CHR$(26):PRINT ERAS$ +4260 PRINT TAB(39);ESC$;"j";" A B C D E F = G H I J K L "RVO$ +4280 FOR I=1 TO 8 +4300 PRINT TAB(39);GR$"i ` ` ` iii ` ` ` i":NEXT +4320 FOR I=1 TO 2 +4340 PRINT TAB(39);GR$"i iii i"LC$:NEXT +4360 FOR I=1 TO 8 +4380 PRINT TAB(39);GR$; "i ` ` ` iii ` ` ` i"LC$:NEXT +4400 PRINT TAB(39);ESC$"j X W V U T S R Q P O N M "RVO$ +4420 GOTO 8320 +4440 PRINT RIGHT$(" "+STR$(13-I),2);"&";TAB(21);"&";MID$(STR$(I+12),2):RETURN +4460 FOR I=0 TO 25:B(I)=0:NEXT I:B(26)=-15:B(27)=15 +4480 B(1)=2:B(6)=-5:B(8)=-3:B(12)=5 +4500 B(13)=-5:B(17)=3:B(19)=5:B(24)=-2 +4520 FOR I=1 TO 24:N=B(I):TM=I:FM=27+(N<0) +4540 B(I)=0:IF N<>0 THEN FOR J=1 TO ABS(N):GOSUB 5880:NEXT J +4560 NEXT I +4580 PRINT A$; +4600 FOR L=1 TO 3:PRINT BK$:NEXT L +4640 RETURN +4660 PRINT ESC$"=";CHR$(31+6);CHR$(33+9);" ";:PRINT TEMP$;MID$("YOUR MY ",3+NP+NP,4);:PRINT" ROLL "; +4670 PRINT RO$ +4680 GOSUB 8280 +4700 RETURN +4720 PP=0:J6=24:IF K<13 THEN J6=K+12 +4740 FOR I=K TO J6:IF B(I)<0 THEN PP=PP+P(I-K) +4760 NEXT I:IF K>14 THEN PP=PP+P(25-K)*2 +4780 RETURN +4800 MS=3:CS=0 +4820 Q4=8*PR(BH)*(1+PR(BH)) +4840 Q5=8*PR(BC)*(1+PR(BC)) +4860 K=P5:GOSUB 4720:CZ=PP*(P5+Q4)*A +4880 K=P5+RL:GOSUB 4720:PZ=PP +4900 CW=PZ*(P5+RL+Q4)*A +4920 IF B(P5)=2 THEN CS=CS-CZ +4940 IF B(P5)=1 AND B(K)>0 THEN CS=CS+CZ:MS=5 +4960 IF B(K)=-1 THEN CS=CS+25-K+Q5:MS=1:IF K>18 THEN CS=CS-4 +4980 IF B(K)<>1 THEN 5040 +5000 CS=CS+CW:IF B(P5)>2 THEN MS=2 +5020 GOTO 5100 +5040 SM=0:J=20:NN=K+R1:IF NN<20 THEN J=NN +5060 FOR I=K TO J:IF B(I)=-1 THEN SM=SM+P(I-K)*(25-I) +5080 NEXT I:CS=CS-CW+(1-PZ)*SM +5100 RETURN +5120 BS=-999:BM=4:FM=0:TM=0:TRY=TRY+1 +5140 FOR L=24 TO 1 STEP-1:IF B(L)<1 THEN 5440 +5160 RL=D(Y):R=L+RL:IF R>24 THEN 5440 +5180 IF R-1 THEN 5440 +5200 IF B(R)<-1 THEN 5440 +5220 IF G<>1 THEN 5300 +5240 Q=0:L1=L+D(1):L2=L+D(2):IF B(L1)>-2 THEN Q=1 +5260 IF B(L2)>-2 THEN Q=2 +5280 IF Q=0 THEN 5440 +5300 P5=L:GOSUB 4800 +5320 IF G<>1 THEN 5400 +5340 MS=3:IF B(L1)=-1 THEN Q=1:CS=CS+25-L1:MS=1 +5360 IF B(L2)=-1 THEN Q=2:CS=CS+25-L2:MS=1 +5380 K=Q +5400 IF CS0 THEN CP=CP+B(I)*(25-I):JM=25-I +5580 IF JM>CM THEN CM=JM +5600 IF B(I)=-1 THEN HB=HB+1 +5620 IF B(I)=+1 THEN CB=CB+1 +5640 IF I<7 AND B(I)<-1 THEN BH=BH+1 +5660 IF I>18 AND B(I)>1 THEN BC=BC+1 +5680 NEXT +5700 XX=CP:IF HP.2 THEN S=1:F=6:A=.1 +5740 IF Y<-.1 THEN S=0:F=1:A=TT +5760 IF S=1 AND HM<6 THEN F=HM +5780 GOTO 900 +5800 PRINT ER$A$;X$;" WON BY";X;"POINTS." +5810 PRINT CN$ +5820 PRINT"TOTAL POINTS ROLLED";XH;DA$(1);XC;DA$(3):PRINT:INPUT"WANT TO PLAY AGAIN";X$ +5840 IF LEFT$(X$,1)="Y"THEN 640 +5860 PRINT CN$:END +5880 PT=FM:GOSUB 6060:P=SGN(B(FM)):GOSUB 6060:B(FM)=B(FM)-P +5900 IF FM=25 OR FM=0 THEN PRINT GR$"i";LC$:GOTO 5940 +5920 IF FM<26 THEN PRINT GR$;MID$(" `",2+((1 AND PT)=1 OR ABS(B(PT))>8),1);LC$ +5940 IF B(TM)<>-P THEN 5980 +5960 PT=-25*(P>0):B(PT)=B(PT)-P:GOSUB 6060:B(TM)=0 +5965 IF P=-1 THEN PRINT DA$(3)ELSE PRINT DA$(1) +5980 B(TM)=B(TM)+P:PT=TM:IF TM<26 THEN GOSUB 6060:PRINT DA$(2+P) +6000 IF MV<=-1 THEN MV=0 +6020 PRINT A$:MV=MV+1 +6040 RETURN +6060 IF PT>25 THEN RETURN +6080 IF PT=0 OR PT=25 THEN 6180 +6100 VT=ABS(B(PT)):IF PT<13 THEN VT=19-VT +6120 TB=ABS(12.5-PT)*2+1:IF TB>12 THEN TB=TB+4 +6140 TB=30-TB +6160 GOTO 6220 +6180 VT=-B(PT):IF VT<0 THEN VT=19+VT +6200 TB=15 +6220 PRINT ESC$"=";CHR$(31+2+VT);CHR$(31+40+TB);:RETURN +6240 LINE INPUT IN$ +6250 PRINT A$;CO$; +6260 RETURN +7000 REM INPUT SI WAS HERE +7010 GOSUB 4580 +7050 PRINT A$;" "; +7100 REM +7200 GOSUB 8250 +7300 INPUT "PRESS RETURN TO ROLL";ZZ$ +7400 RETURN +8000 REM DICE ROUTINE +8050 E$=CHR$(27):H$=CHR$(30) +8060 ER$=CHR$(26):PRINT ER$; +8070 RO$=E$+"k":PRINT RO$ +8080 EG$="" +8090 RV$=E$+"j" +8100 TEMP$=RV$ +8110 COF$="" +8120 CH$="" +8130 PRINT ER$ +8150 FOR I=1 TO 6:FOR J=1 TO 6:READ DI$(I,J):NEXT J,I +8160 DATA" "," ^","^ ","^ ^","^ ^","^^^" +8170 DATA" ^ "," "," ^ "," "," ^ "," " +8180 DATA" ","^ "," ^","^ ^","^ ^","^^^" +8190 DATA" ","^ "," ^","^ ^","^ ^","^ ^" +8200 DATA" ^ "," "," ^ "," "," ^ ","^ ^" +8210 DATA" "," ^","^ ","^ ^","^ ^","^ ^" +8220 RETURN +8250 FOR I=1 TO 2 +8260 FX=INT(RND(1)*6+1):T(I)=3*(RND(1)>.5)+3:CT(FX)=CT(FX)+1:D(I)=FX +8270 NEXT I +8275 RETURN +8280 PRINT H$;GR$;:FOR I=1 TO 3:PRINT +8283 FOR J=1 TO 2 +8285 IF DI$(I+T(J),D(J))=""THEN DI$(I+T(J),D(J))=" " +8290 PRINT TAB(2*J+7);"| "+DI$(I+T(J),D(J))+" | ";:NEXT J,I +8300 PRINT CHR$(27);"G";:PRINT +8310 RETURN +8320 PRINT H$;E$+"F";:PRINT TAB(8);" zzzzz zzzzz " +8330 FOR I=1 TO 3:PRINT TAB(9);"| | | |" +8340 NEXT I +8350 PRINT TAB(10)"zzzzz zzzzz" +8355 PRINT LC$ +8360 RETURN +8500 REM DELAY ROUTINE +8510 FOR I=1 TO 2000:NEXT I:RETURN +9000 RETURN : REM INSTRUCTION FILE READ ROUTINE WAS HERE + \ No newline at end of file diff --git a/software/BAS/WEATHER.bas b/software/BAS/WEATHER.bas new file mode 100644 index 0000000..1d478c4 --- /dev/null +++ b/software/BAS/WEATHER.bas @@ -0,0 +1,255 @@ +100 DIM S$(10) +110 PRINT"THIS PROGRAM WILL ATTEMPT TO PREDICT TOMORROWS WEATHER IF" +120 PRINT"GIVEN THE WEATHER STATISTICS FROM THE PAST TWO DAYS." +130 PRINT TAB(5);"SEASON" +140 INPUT S$(1) +150 GOSUB 1500 +160 GOTO 130 +170 PRINT"AFTER THE FOLLOWING QUESTION MARKS YOU WILL BE REQUIRED" +180 PRINT"TO INPUT TWO VALUES, ONE FOR YESTERDAY'S READING AND ONE" +190 PRINT"FOR TODAY'S READING. SEPERATE THESE READINGS BY A COMMA." +200 PRINT TAB(5);"TEMPERATURE" +210 INPUT T1,T2 +220 GOSUB 1570 +230 GOTO 200 +240 PRINT TAB(5);"BAROMETER" +250 INPUT B1,B2 +260 GOSUB 1640 +270 GOTO 240 +280 PRINT TAB(5);"BAROMETER TENDENCY(1=RISING,2=FALLING,3=STEADY):" +290 INPUT T3,T4 +300 GOSUB 1710 +310 GOTO 280 +320 PRINT TAB(5);"RELATIVE HUMIDITY" +330 INPUT H1,H2 +340 GOSUB 1780 +350 GOTO 320 +360 PRINT TAB(5);"CLOUDS(1=STRATUS,2=CUMULUS,3=CIRRUS)" +370 INPUT C1,C2 +380 GOSUB 1850 +390 GOTO 360 +400 PRINT TAB(5);"CLOUD COVER(PERCENTAGE)" +410 INPUT C4,C5 +420 GOSUB 1920 +430 GOTO 400 +440 PRINT TAB(5);"WIND DIRECTION (1=NORTH,2=SOUTH,3=EAST,4=WEST)" +450 INPUTD1,D2 +460 GOSUB 1990 +470 GOTO 440 +480 PRINT TAB(5);"WIND SPEED" +490 INPUT S2,S3 +500 GOSUB 2060 +510 GOTO 480 +520 PRINT +530 PRINT +540 PRINT +550 PRINT"------------------------------------------------------" +560 PRINT"PRESENT SEASON IS ";S$(1) +570 PRINT +580 PRINT "FORECAST FOR TOMORROW:" +590 PRINT +600 PRINT +610 PRINT"TEMPERATURES:" +620 LET T7=((T1+T2)/2)-30 +630 LET T6=T7+10 +640 PRINT "LOWS TONIGHT BETWEEN";T7;"AND";T6;"DEGREES" +650 LET T9=((T1+T2)/2)+5 +660 LET T8=T9-5 +670 PRINT "HIGHS TOMORROW NIGHT BETWEEN";T8;"AND";T9;"DEGREES" +680 LET T0=T7-5 +690 PRINT "LOWS TOMORROW NIGHT BETWEEN ";T0;"AND";T7;"DEGREES" +700 LET B4=(B1+B2)/2 +710 B0=INT(ABS(B1-B2)) +720 LET T9=(T3+T4)/2 +730 LET T9=INT(T9) +740 IF T9=2 THEN 780 +750 IF T9=3 THEN 800 +760 PRINT"BAROMETER";B4;" AND RISING." +770 GOTO 810 +780 PRINT"BAROMETER";B4;" AND FALLING." +790 GOTO 810 +800 PRINT"BAROMETER";B4;" AND STEADY." +810 LET H3=((H1+H2)/2)+5 +820 LET H4=H3-5 +830 PRINT "HUMIDITY BETWEEN ";H4;"AND ";H3;"PERCENT" +840 LET C3=(C1+C2)/2 +850 LET C3=INT(C3) +860 LET C9=((C4+C5)/2)+5 +870 LET C8=C9-5 +880 PRINT"CLOUD COVER BETWEEN";C8;"AND";C9;"PERCENT" +890 IF C3=2 THEN 940 +900 IF C3=3 THEN 970 +910 PRINT"CLOUD HEIGHT BETWEEN 500 TO 580 FEET." +920 PRINT"MAJOR CLOUD TYPE WILL BE STRATUS." +930 GOTO 990 +940 PRINT"CLOUD HEIGHT BETWEEN 1550 TO 1800 FEET." +950 PRINT"MAJOR CLOUD TYPE WILL BE CUMULUS." +960 GOTO 990 +970 PRINT"CLOUD HEIGHT BETWEEN 16500 TO 17000 FEET." +980 PRINT"MAJOR CLOUD TYPE WILL BE CIRRUS." +990 LET D5=(D1+D2)/2 +1000 LET D5=INT(D5) +1010 LET S5=((S2+S3)/2)+5 +1020 LET S6=S5-5 +1030 IF D5=2 THEN 1080 +1040 IF D5=3 THEN 1100 +1050 IF D5=4 THEN 1120 +1060 PRINT"WIND FROM THE NORTH FROM";S6;"TO";S5;"MPH" +1070 GOTO 1130 +1080 PRINT"WIND FROM THE SOUTH FROM";S6;"TO";S5;"MPH" +1090 GOTO 1130 +1100 PRINT "WIND FORM THE EAST FROM";S6;"TO";S5;"MPH" +1110 GOTO 1130 +1120 PRINT"WIND FROM THE WEST FROM";S6;"TO";S5;"MPH" +1130 PRINT"CHANCE OF PRECIPITATION:" +1140 LET P1=INT((((C5/2)+B2)+C2)/.5) +1150 IF P1>100 THEN 2170 +1160 PRINT "TONIGHT";P1;"%" +1170 LET P2=INT(((C9/2)+B4)+C3) +1180 IF P2>100 THEN 2190 +1190 PRINT"TOMORROW";P2;"%" +1200 IF P3>100 THEN 2210 +1210 PRINT"TOMORROW NIGHT";P3;"%" +1220 PRINT +1230 IF C2=2 THEN 1340 +1240 IF C2=3 THEN 1420 +1250 PRINT"FORECAST FOR TOMORROWS WEATHER:" +1260 PRINT +1270 PRINT"IT SHOULD BE FAIR TOMORROW." +1280 IF S$(1)="SPRING"THEN 1320 +1290 IF S$(1)="SUMMER"THEN 1320 +1300 PRINT"IT SHOULD BE COOLER TOMORROW WITH NO PRECIPITATION LIKELY." +1310 GOTO 1490 +1320 PRINT"IT SHOULD BE WARMER TOMORROW WITH NO PRECIPITATION LIKELY." +1330 GOTO 1490 +1340 PRINT"FORECAST FOR TOMORROWS WEATHER." +1350 PRINT +1360 IF S$(1)="SUMMER"THEN 1390 +1370 PRINT"IT SHOULD BE FAIR TOMORROW." +1380 GOTO 1280 +1390 PRINT"IF THEY ARE HEAVY CLOUDS--BE READY FOR RAIN." +1400 PRINT"IF THE CLOUDS ARE LIGHT--IT WILL BE FAIR." +1410 GOTO 1490 +1420 IF S$(1)="FALL" THEN 1490 +1430 PRINT +1440 IF S$(1)="SPRING"THEN 1480 +1450 IF S$(1)="SUMMER"THEN 1480 +1460 PRINT"TOMORROW,EXPECT SNOW TO FALL FOLLOWED BY HIGHER TEMPERATURES." +1470 GOTO 1490 +1480 PRINT"TOMORROW,EXPECT RAIN TO FALL FOLLOWED BY HIGHER TEMPERATURES." +1490 GOTO 2130 +1500 IF S$(1)="WINTER"THEN 170 +1510 IF S$(1)="FALL"THEN 170 +1520 IF S$(1)="SPRING"THEN 170 +1530 IF S$(1)="SUMMER" THEN 170 +1540 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(SEASONS:WINTER,SPRING"; +1550 PRINT"FALL,SUMMER)..." +1560 RETURN +1570 IF T1>135 THEN 1620 +1580 IF T1<-80 THEN 1620 +1590 IF T2>135 THEN 1620 +1600 IF T2<-80 THEN 1620 +1610 GOTO 240 +1620 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(NORMALS-80-135)..." +1630 RETURN +1640 IF B1>31.5 THEN 1690 +1650 IF B1<28.5 THEN 1690 +1660 IF B2>31.5 THEN 1690 +1670 IF B2<28.5 THEN 1690 +1680 GOTO 280 +1690 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(NORMALS:28.5-31.5)..." +1700 RETURN +1710 IF T3<1 THEN 1760 +1720 IF T3>3 THEN 1760 +1730 IF T4<1 THEN 1760 +1740 IF T4>3 THEN 1760 +1750 GOTO 320 +1760 PRINT TAB(5);"LETS TRY THAT ONE AGAIN..." +1770 RETURN +1780 IF H1<0 THEN 1830 +1790 IF H1>100 THEN 1830 +1800 IF H2<0 THEN 1830 +1810 IF H2>100 THEN 1830 +1820 GOTO 360 +1830 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(HUMIDITY:0-100)..." +1840 RETURN +1850 IF C1<1 THEN 1900 +1860 IF C1>3 THEN 1900 +1870 IF C2<1 THEN 1900 +1880 IF C2>3 THEN 1900 +1890 GOTO 400 +1900 PRINT TAB(5);"LETS TRY THAT ONE AGAIN..." +1910 RETURN +1920 IF C4<0 THEN 1970 +1930 IF C4>100 THEN 1970 +1940 IF C5<0 THEN 1970 +1950 IF C5>100 THEN 1970 +1960 GOTO 440 +1970 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(COVER:0-100)..." +1980 RETURN +1990 IF D1<1 THEN 2040 +2000 IF D1>4 THEN 2040 +2010 IF D2<1 THEN 2040 +2020 IF D2>4 THEN 2040 +2030 GOTO 480 +2040 PRINT TAB(5);"LETS TRY THAT ONE AGAIN..." +2050 RETURN +2060 IF S2<0 THEN 2110 +2070 IF S2>75 THEN 2110 +2080 IF S3<0 THEN 2110 +2090 IF S3>75 THEN 2110 +2100 GOTO 520 +2110 PRINT TAB(5);"LETS TRY THAT ON E AGAIN(NORMAL:0-75)..." +2120 RETURN +2130 GOSUB 2230 +2140 PRINT"THE END" +2150 PRINT"---------------------------------------------------" +2160 STOP +2170 LET P1=100 +2180 GOTO 1160 +2190 LET P2=100 +2200 GOTO 1190 +2210 LET P3=100 +2220 GOTO 1210 +2230 IF D2=2 THEN 2390 +2240 IF D2=3 THEN 2480 +2250 IF D2=1 THEN 2580 +2260 IF B2=>30.2 THEN 2340 +2270 IF B2=>30.1 THEN 2300 +2280 PRINT"IT WILL BE CLEARING AND COLDER TOMORROW." +2290 GOTO 2620 +2300 IF T2=3 THEN 2330 +2310 PRINT"IT WILL BE FAIR TOMORROW, FOLLOWED BY WINDS AND PRECIPITATION." +2320 GOTO 2620 +2330 PRINT"IT WILL BE FAIR TOMORROW, WITH LITTLE TEMPERATURE CHANGE." +2340 IF T2=3 THEN 2370 +2350 PRINT"IT WILL BE FAIR TOMORROW WITH SLOWLY RISING TEMPERATURES." +2360 GOTO 2620 +2370 PRINT "IT WILL BE CONTINUED FAIR TOMORROW." +2380 GOTO 2620 +2390 IF B2<=29.8 THEN 2450 +2400 IF B2<=30! THEN 2430 +2410 PRINT"IT WILL BE WINDY WITH RAIN IN 12-24 HOURS." +2420 GOTO 2620 +2430 PRINT"IT WILL BE CLEARING AND FAIR FOR SEVERAL DAYS FOLLOWING." +2440 GOTO 2620 +2450 PRINT"THERE WILL BE A SEVERE STORM IN 24 HOURS FOLLOWED BY "; +2460 PRINT"CLEARING." +2470 GOTO 2620 +2480 IF B2<=29.8 THEN 2530 +2490 IF B2=> 30.1 THEN 2550 +2500 PRINT"IN WINTER, EXPECT SNOW WITH WINDS." +2510 PRINT"IN SUMMER, EXPECT A LONG DRY SPELL." +2520 GOTO 2620 +2530 PRINT"THERE WILL BE A NORTHEAST WIND WITH HEAVY PRECIPITATION." +2540 GOTO 2620 +2550 PRINT"IN WINTER, EXPECT SNOW IN 24 HOURS." +2560 PRINT"IN SUMMER, EXPECT A DRY SPELL." +2570 GOTO 2620 +2580 IF B2<=30! THEN 2610 +2590 PRINT"RAIN WILL CONTINUE WITH WINDS FOR 36 HOURS, THEN CLEARING." +2600 GOTO 2620 +2610 PRINT "RAIN WILL FALL IN 12 TO 18 HOURS." +2620 RETURN +UE WITH WINDS FOR 36 HOURS, THEN CLEARING." +2600 GOTO 2620 \ No newline at end of file diff --git a/software/BAS/WORD-PZL.bas b/software/BAS/WORD-PZL.bas new file mode 100644 index 0000000..9e21713 --- /dev/null +++ b/software/BAS/WORD-PZL.bas @@ -0,0 +1,221 @@ +100 CLEAR 1200 +110 B$="." +120 INPUT"INPUT X AND Y DIMENSIONS ";X,Y +130 IF X>30 OR Y>30 THEN 120 +140 IF X>Y THEN U0=X:GOTO 180 +150 U0=Y +160 INPUT"NUMBER OF WORDS ";N +170 C1=100*INT(N/10):IF C1<100 THEN C1=100 +180 DIM W$(50),A$(X,Y),N$(N),L(N,4) +190 W$(1)="DUMMEY ARGUMENT" +200 GOTO2150 +210 GOSUB 1960 +220 GOTO2020 +230 INPUT"PUNCH LIST ON TAPE";T$:IF LEFT$(T$,1)="Y" THEN GOTO 2220 +240 Q8=1 +250 GOSUB 1940 +260 PRINT:PRINT Q8 +270 FOR I1=1 TO N +280 GOTO 360 +290 PRINT:PRINT"FIRST CHAR. CHANGED ON PASS";C0;" OF THE";I1;"TH WORD" +300 A$(L(1,1),L(1,2))=LEFT$(N$(1),1) +310 GOTO430 +320 REM +330 L(I1,1)=A:L(I1,2)=B:L(I1,3)=D +340 L(I1,4)=C0 +350 GOTO 1580 +360 C0=0 +370 S$=N$(I1) +380 Z=LEN(S$)-1 +390 GOSUB 1540 +400 C0=C0+1 +410 IF I1=1 THEN GOTO 430 +420 IF A$(L(1,1),L(1,2))<>LEFT$(N$(1),1) THEN GOTO 290 +430 IF C0/C1<>INT(C0/C1) THEN 450 +440 PRINT S$;" TRY#";C0 +450 IF C0Y THEN 390 +510 FOR I=1 TO LEN(S$) +520 A1=A:B1=B+I-1 +530 GOSUB 1910 +540 GOSUB 1930 +550 IF L$=B$ OR L$=N1$ THEN 570 +560 GOTO 390 +570 NEXT I +580 FOR I=1 TO LEN(S$) +590 GOSUB 1910 +600 A$(A,B+I-1)=N1$ +610 NEXT I +620 GOTO 320 +630 IF B+Z>Y OR A-Z<1 THEN390 +640 FOR I=1 TO LEN(S$) +650 A1=A-(I-1):B1=B+I-1 +660 GOSUB 1910 +670 GOSUB 1930 +680 IF L$=B$ OR L$=N1$ THEN 700 +690 GOTO 390 +700 NEXT I +710 FOR I=1 TO LEN(S$) +720 GOSUB 1910 +730 A$(A-(I-1),B+I-1)=N1$ +740 NEXT I +750 GOTO 320 +760 IF A-Z<1 THEN 390 +770 FOR I=1 TO LEN(S$) +780 A1=A-(I-1):B1=B +790 GOSUB 1910 +800 GOSUB 1930 +810 IF L$=B$ OR L$=N1$ THEN 830 +820 GOTO 390 +830 NEXT I +840 FOR I=1 TO LEN(S$) +850 GOSUB 1910 +860 A$(A-(I-1),B)=N1$ +870 NEXT I +880 GOTO320 +890 IF A-Z<1 OR B-Z<1 THEN390 +900 FOR I=1 TO LEN(S$) +910 A1=A-(I-1):B1=B-(I-1) +920 GOSUB 1910 +930 GOSUB 1930 +940 IF L$=B$ OR L$=N1$ THEN960 +950 GOTO 390 +960 NEXT I +970 FOR I=1 TO LEN(S$) +980 GOSUB 1910 +990 A$(A-(I-1),B-(I-1))=N1$ +1000 NEXT I +1010 GOTO 320 +1020 IF B-Z<1 THEN 390 +1030 FOR I=1 TO LEN(S$) +1040 A1=A:B1=B-(I-1) +1050 GOSUB 1910 +1060 GOSUB 1930 +1070 IF L$=B$ OR L$=N1$ THEN 1090 +1080 GOTO 390 +1090 NEXT I +1100 FOR I=1 TO LEN(S$) +1110 GOSUB 1910 +1120 A$(A,B-(I-1))=N1$ +1130 NEXT I +1140 GOTO 320 +1150 IF A+Z>X OR B-Z<1 THEN390 +1160 FOR I=1 TO LEN(S$) +1170 A1=A+I-1:B1=B-(I-1) +1180 GOSUB 1910 +1190 GOSUB 1930 +1200 IF L$=N1$ OR L$=B$ THEN1220 +1210 GOTO390 +1220 NEXT I +1230 FOR I=1 TO LEN(S$) +1240 GOSUB 1910 +1250 A$(A+I-1,B-(I-1))=N1$ +1260 NEXT I +1270 GOTO320 +1280 IF A+Z>X THEN 390 +1290 FOR I=1 TO LEN(S$) +1300 A1=A+I-1:B1=B +1310 GOSUB 1910 +1320 GOSUB 1930 +1330 IF L$=N1$ OR L$=B$ THEN1350 +1340 GOTO 390 +1350 NEXT I +1360 FOR I=1 TO LEN(S$) +1370 GOSUB 1910 +1380 A$(A+I-1,B)=N1$ +1390 NEXT I +1400 GOTO 320 +1410 IF A+Z>X OR B+Z>Y THEN390 +1420 FOR I=1 TO LEN(S$) +1430 A1=A+I-1:B1=B+I-1 +1440 GOSUB 1910 +1450 GOSUB 1930 +1460 IF L$=B$ OR L$=N1$ THEN 1480 +1470 GOTO 390 +1480 NEXT I +1490 FOR I=1 TO LEN(S$) +1500 GOSUB 1910 +1510 A$(A+I-1,B+I-1)=N1$ +1520 NEXT I +1530 GOTO320 +1540 A=INT(X*RND(8)+1) +1550 B=INT(Y*RND(8)+1) +1560 D=INT(8*RND(5)+1) +1570 RETURN +1580 NEXT I1 +1590 GOTO 1610 +1600 FOR I=1TOX:FORJ=1TOY:PRINTA$(I,J);" ";:NEXTJ:PRINT:NEXTI +1610 FOR I=1 TO 5:PRINT:NEXT I +1620 PRINT"THE";N;"HIDDEN WORDS ARE":PRINT +1630 Z=2:FORI=1TON:PRINTTAB(Z);N$(I);:Z=Z+18:IFZ>60 THENZ=2:PRINT +1640 NEXT I:PRINT:PRINT:PRINT +1650 FOR I=1 TO X +1660 FOR J=1 TO Y +1670 IF A$(I,J)=B$ THEN 1770 +1680 PRINT A$(I,J);" "; +1690 NEXT J +1700 PRINT +1710 NEXT I +1720 PRINT +1730 GOSUB 1800 +1740 PRINT +1750 GOTO 240 +1760 END +1770 A$(I,J)=CHR$(INT(26*RND(1)+65)) +1780 GOTO 1680 +1790 PRINT +1800 REM +1810 AN=1 +1820 PRINT "THE HIDDEN WORDS ARE LOCATED AT" +1830 FOR K=1 TO N +1840 PRINT N$(K); +1850 IF AN=0 THEN PRINT: GOTO 1880 +1860 PRINT TAB(30);L(K,1);",";L(K,2);",";L(K,3); +1870 PRINT ",";L(K,4) +1880 NEXT K +1890 RETURN +1900 END +1910 N1$=MID$(S$,I,1) +1920 RETURN +1930 L$=A$(A1,B1):RETURN +1940 FORI=1TOX:FORJ=1TOY:A$(I,J)=B$:NEXT J,I +1950 RETURN +1960 FOR I=1 TO N +1970 PRINT"WORD #";I; +1980 INPUT N$(I) +1990 IF LEN(N$(I))>U0 THEN1970 +2000 NEXT I +2010 RETURN +2020 IF N<3 THEN GOTO240 +2030 FOR J=2 TO (N-1) +2040 L=0:M=0 +2050 FOR I=J TO N +2060 IF LEN(N$(I))>L THEN L=LEN(N$(I)):M=I +2070 NEXT I +2080 T$=N$(M) +2090 FOR I=(M-1)TO J STEP -1 +2100 N$(I+1)=N$(I) +2110 NEXT I +2120 N$(J)=T$ +2130 NEXT J +2140 GOTO 230 +2150 INPUT"INPUT FROM TAPE";T$:IF LEFT$(T$,1)="N" THEN GOTO210 +2160 PRINT CHR$(17):REM TAPE READER ON +2170 FOR I=1 TO N +2180 INPUT N$(I) +2190 NEXT I +2200 PRINT CHR$(19):REM TAPE READER OFF +2210 GOTO 2020 +2220 NULL6 +2230 PRINT CHR$(18);:REM TAPE PUNCH ON +2240 FOR I=1TO75:PRINT CHR$(0);:NEXT I:REM LEADER +2250 FOR I=1TON:PRINTN$(I):NEXT I +2260 FOR I=1TO75:PRINT CHR$(0);:NEXT I:PRINT CHR$(20) +2270 NULL0:GOTO240 +XT I:REM LEADER +2250 FOR I=1TON:PRINTN$(I):NEXT I +2260 FOR I=1TO75:PRINT CHR$ \ No newline at end of file diff --git a/software/BAS/WORDPUZL.BAS b/software/BAS/WORDPUZL.BAS new file mode 100644 index 0000000..761e618 Binary files /dev/null and b/software/BAS/WORDPUZL.BAS differ diff --git a/software/BAS/ZILCH.BAS b/software/BAS/ZILCH.BAS new file mode 100644 index 0000000..d1ab3ba --- /dev/null +++ b/software/BAS/ZILCH.BAS @@ -0,0 +1,213 @@ +1 REM ZILCH (C) COPYRIGHT 1980 BY MORRIE WILSON +2 REM ****** ZILCH BY MORRIE WILSON +3 REM +4 REM A DICE GAME FOR 1 TO 9 PLAYERS, +5 REM AND THE COMPUTER CAN BE A PLAYER TOO. +6 REM +7 REM +8 REM THIS IS A FREE PROGRAM. NO COMMERCIAL USE ALLOWED. +9 REM FOR INFO: MORRIE WILSON / 2527 56TH SW /SEATTLE WASH / 98116 +10 REM IF YOU HAVE MICROSOFT 5.+ BASIC, REMOVE "REM" FROM LINE 35 +11 REM TO ALLOW IT TO GENERATE RANDOM NUMBERS. THIS PROGRAM IS +12 REM COMPATIBLE WITH MICROSOFT BASIC 4.51 AND 5.03 +13 REM IF CODING LOOKS STRANGE & REDUNDANT, IT IS BECAUSE I'M TRYING +14 REM TO REMAIN COMPATIBLE WITH BOTH BASICS. +15 REM +16 REM IF IT RUNS, BUT THE DICE VALUES ARE STRANGE, THEN ITS +17 REM PROBABLY THAT YOUR BASIC HANDLES RANDOM NUMBER GENERATION +18 REM DIFFERENTLY. CHECK OUT THE RND(X) STUFF IN LINE 74 +19 W6=250 +20 A1$="ABCDEF" +21 A=ASC("A") +22 PRINT TAB(30);"ZILCH" +23 A$="N":INPUT "DO YOU WANT INSTRUCTIONS ";A$ +24 IF LEFT$(A$,1)="Y" THEN GOSUB 149 +25 INPUT "NUMBER OF PLAYERS";N1 +26 N1=INT(N1):IF N1<1 THEN PRINT "WHAT....YOU CAN'T DO THAT":GOTO 25 +27 IF N1>9 THEN PRINT "TOO MANY PLAYERS FOR THIS GAME":GOTO 25 +28 FOR II=1 TO N1:PRINT "THE NAME PLEASE....OF PLAYER #";II;" " +29 INPUT N9$(II):FOR I9=1 TO LEN(N9$(II)):R9=R9+ASC(MID$(N9$(II),I9,1)):NEXT I9 +30 NEXT II +31 R9=R9*3.14161:IF R9>65000! THEN R9=R9/5.67:GOTO 31 +32 R9=INT(R9) +33 FOR I=1 TO 200:NEXT I +34 PRINT:PRINT +35 REM RANDOMIZE R9 +36 W7$="Y":W4=0:INPUT "CAN I PLAY TOO ";W7$ +37 IF LEFT$(W7$,1)<>"Y" THEN 40 +38 N1=N1+1:N9$(N1)="" +39 W4=N1 +40 S8=0 +41 FOR N=1 TO N1 : S1(N)=0 : NEXT N +42 FOR N=1 TO N1 +43 IF N=S8 THEN 137 +44 S=0:D=6:S9=0 +45 PRINT:PRINT:PRINT:PRINT "IT'S ";N9$(N);"'S TURN" +46 PRINT:PRINT +47 IF S8<>0 THEN PRINT "************************ LAST TURN******" +48 FOR K9=1 TO N1:PRINT N9$(K9);" HAS ";S1(K9):NEXT K9 +49 PRINT N9$(N)". YOUR GAME TOTAL SO FAR IS ";S1(N) +50 PRINT "CURRENT TURN SCORE IS ";S +51 S2=S1(N)+S +52 IF S2<500 THEN S2=0 +53 PRINT "IF YOU STOP NOW YOUR TOTAL WILL BE ";S2 +54 W$="DICE":IF D=1 THEN W$="DIE" +55 PRINT "YOU HAVE";D;" ";W$;" LEFT. DO YOU WISH TO ROLL "; +56 A$="Y":IF W4<>N THEN INPUT A$:GOTO 67 +57 PRINT "?";:FOR W5=1 TO W6:NEXT W5:A$="Y" +58 IF D<=2 THEN A$="N" +59 IF S2=0 THEN A$="Y" +60 IF S>999 AND D<=4 THEN A$="N" +61 W9=S2 +62 IF S8=0 THEN 66 +63 FOR W5=1 TO N1:IF W9N THEN INPUT "WHICH DIE DO YOU WISH TO KEEP";A$:GOTO 83 +80 PRINT "WHICH DIE DO YOU WISH TO KEEP? "; +81 FOR W5=1 TO W6*2:NEXT W5:A$=LEFT$(A1$,D) +82 PRINT A$ +83 PRINT:PRINT:IF A$="?" THEN GOSUB 204: GOTO 79 +84 IF LEN(A$)=0 THEN A$=LEFT$(A1$,D):GOTO 89 +85 L=LEN(A$):IF L<2 THEN 89 +86 FOR I=1 TO L-1:FOR II=I+1 TO L +87 IF MID$(A$,I,1)=MID$(A$,II,1) THEN 78 +88 NEXT II:NEXT I +89 L=LEN(A$):IF L>D THEN 78 +90 FOR D9=1 TO L:D8=ASC(MID$(A$,D9,1))-A+1 +91 IF D8<1 OR D8>D THEN 78 +92 H9(D9)=D1(D8) +93 NEXT D9 +94 IF L=1 THEN 100 +95 FOR I=1 TO L-1 +96 FOR J=1 TO L-I +97 IF H9(J)6 THEN 107 +101 FOR I=1 TO 6 +102 IF H9(I)<>I THEN 107 +103 NEXT I +104 S=S+1000 +105 D=0 +106 GOTO 121 +107 C=1 +108 IF C>L THEN 121 +109 IF C+2>L THEN 117 +110 FOR C9=C TO C+1 +111 IF H9(C9)<>H9(C9+1) THEN 117 +112 NEXT C9 +113 S=H9(C)*100+S +114 IF H9(C)=1 THEN S=S+900 +115 C=C+3:D=D-3 +116 GOTO 108 +117 IF H9(C)=5 THEN S=S+50:D=D-1 +118 IF H9(C)=1 THEN S=S+100:D=D-1 +119 C=C+1 +120 GOTO 108 +121 IF S=S9 THEN 126 +122 S9=S +123 IF D<>0 THEN 49 +124 PRINT "ALL DIE SCORED, YOU GET 6 MORE DIE TO CONTINUE" +125 D=6:GOTO 50 +126 S=0 +127 PRINT " *** ZILCH ***" +128 FOR W5=1 TO 300 : NEXT W5 +129 REM +130 IF S1(N)<>0 THEN 132 +131 IF S<500 THEN 133 +132 S1(N)=S1(N)+S +133 IF S8<>0 THEN 135 +134 IF S1(N)>4999 THEN S8=N +135 NEXT N +136 GOTO 42 +137 PRINT:PRINT:PRINT +138 Q=0 +139 FOR I=1 TO N1 +140 PRINT N9$(I);" HAS A SCORE OF ";S1(I) +141 IF S1(I)>Q THEN Q1=I:Q=S1(I) +142 NEXT I +143 PRINT:PRINT N9$(Q1);" HAS WON THIS GAME" +144 GOTO 145 +145 A$="Y":INPUT "WOULD YOU LIKE TO PLAY AGAIN";A$ +146 IF LEN(A$)=0 THEN A$="Y" +147 IF LEFT$(A$,1)="Y" THEN 25 +148 END +149 PRINT:PRINT:PRINT:PRINT +150 PRINT " ZILCH" +151 PRINT " BY MORRIE WILSON" +152 PRINT +153 PRINT +154 PRINT +155 PRINT "THIS IS THE GAME OF ZILCH. IT IS A DICE GAME FOR 1 TO 9 PLAYERS." +156 PRINT "THE OBJECT OF THE GAME IS TO ROLL DIE, AND GAIN THE MOST POINTS" +157 PRINT "DURING THE COURSE OF THE GAME. IN ORDER TO WIN, A COMBINATION OF" +158 PRINT "BOTH LUCK AND STRATEGY IS NECESSARY. WHAT YOU ROLL IS LUCK, BUT" +159 PRINT "WHAT YOU DO WITH YOUR ROLL IS STRATEGY. NOW FOR THE DETAILS" +160 PRINT +161 PRINT "PRESS RETURN TO CONTINUE";:INPUT A$ +162 FOR I=1 TO 25:PRINT:NEXT I +163 PRINT +164 PRINT "THE PLAY ROTATES AMONGST THE PLAYERS, WITH EACH PLAYER" +165 PRINT "COMPLETING A SERIES OF ROLLS WHICH COMPRISE HIS TURN." +166 PRINT +167 PRINT "A TURN CONSISTS OF STARTING OUT WITH SIX DIE. ALL OF THEM ARE" +168 PRINT "ROLLED. THE DIE ARE THEN EXAMINED, AND SOME OF THE DIE THAT" +169 PRINT "HAVE POINTS ARE PULLED FROM THE PLAY, WITH THE POINTS REPRESENTED" +170 PRINT "BEING ADDED TO A PLAYER'S TURN TOTAL. THE PLAYER THEN ROLLS" +171 PRINT "THE REMAINING DIE. THE PLAYER CONTINUES TO ROLL AND PULL DIE" +172 PRINT "UNTIL IT IS FELT THAT TO CONTINUE TO DO SO WILL RESULT IN A ZILCH." +173 PRINT "IF A PLAYER ROLLS THE DIE AND FINDS THAT NONE OF DIE HAVE POINTS" +174 PRINT "SHOWING, THEN THE PLAYER HAS ZILCHED, AND LOSES ALL POINTS THAT" +175 PRINT "HE HAS ACCUMULATED DURING THE CURRENT TURN. NOTE THAT POINTS" +176 PRINT "FROM PREVIOUS TURNS ARE NOT AFFECTED. CONFUSING, ISN'T IT?" +177 PRINT "WELL PLAY A FEW TIMES AND THEN IT WILL BECOME OBVIOUS." +179 PRINT +180 PRINT "PRESS RETURN TO CONTINUE";:INPUT A$ +181 FOR I=1 TO 25:PRINT:NEXT I +182 PRINT "A PLAYER MUST GET AT LEAST 500 POINTS IN ONE TURN" +183 PRINT "TO GET INTO THE GAME. AFTER THE INITIAL 500 POINTS IS" +184 PRINT "OBTAINED, THERE IS NO MINIMUM NUMBER OF POINTS NECESSARY TO +185 PRINT "ACCUMULATE MORE POINTS. +186 PRINT +187 PRINT "IF A PLAYER SCORES ON ALL SIX OF THE ORIGINAL DIE, SIX MORE" +188 PRINT "DIE ARE GIVEN TO OBTAIN ADDITIONAL POINTS (BUT WATCH OUT" +189 PRINT "FOR ZILCHING)." +190 PRINT +191 PRINT "WHENEVER A PLAYER GET 5000 OR MORE POINTS, ALL THE OTHER PLAYERS" +192 PRINT "GET ONE MORE TURN TO TRY TO BEAT THE HIGHEST SCORE. THE PLAYER" +193 PRINT "WITH THE HIGHEST SCORE WINS." +194 PRINT +195 PRINT "THE COMPUTER CAN ALSO ACT AS ONE OF THE PLAYERS, IF YOU LET HIM." +196 PRINT ", THE COMPUTER WILL ASK IF HE CAN PLAY LATER." +197 PRINT:PRINT:PRINT "PRESS RETURN TO CONTINUE";:INPUT A$ +198 FOR I=1 TO 25:PRINT:NEXT I +199 GOSUB 204 +200 PRINT "DURING THE PLAY OF THE GAME, A QUESTION MARK WILL GET YOU A " +201 PRINT "LISTING OF HOW THE DIE SCORE AGAIN." +202 PRINT:PRINT:PRINT:PRINT:PRINT +203 RETURN +204 PRINT "SCORING" +205 PRINT +206 PRINT "5 - 50 POINTS 1 - 100 POINTS" +207 PRINT "2 : 2 : 2 - 200 POINTS 3 : 3 : 3 - 300 POINTS" +208 PRINT "4 : 4 : 4 - 400 POINTS 5 : 5 : 5 - 500 POINTS" +209 PRINT "6 : 6 : 6 - 600 POINTS 1 : 1 : 1 - 1000 POINTS" +210 PRINT +211 PRINT "1 : 2 : 3 : 4 : 5 : 6 - (IN 1 ROLL, IN ANY ORDER) 1000 POINTS" +212 PRINT:PRINT "A RETURN WILL ALWAYS GIVE YOU THE MAXIMUM POINTS POSSIBLE" +213 PRINT:PRINT:PRINT:RETURN + \ No newline at end of file diff --git a/software/BAS/lander.bas b/software/BAS/lander.bas new file mode 100644 index 0000000..eb2a33f --- /dev/null +++ b/software/BAS/lander.bas @@ -0,0 +1,31 @@ +10 REM Lunar lander program. + +20 LET dist = 100 +30 LET v = 1 +40 LET fuel = 1000 +50 LET mass = 1000 + +60 PRINT "You are a in control of a lunar lander." +70 PRINT "You are drifiting towards the surface of the moon." +80 PRINT "Each turn you must decide how much fuel to burn." +90 PRINT "To accelerate enter a positive number, to decelerate a negative" + +100 PRINT "Distance", dist, "km", "velocity", v, "km/s", "Fuel", fuel +110 INPUT burn +115 IF ABS(burn) <= fuel THEN 120 +116 PRINT "You don't have that much fuel" +117 GOTO 100 +120 LET v = v + burn * 10 / (fuel + mass) +130 LET fuel = fuel - ABS(burn) +140 LET dist = dist - v +150 IF dist > 0 THEN 100 +160 PRINT "You have hit the surface" +170 IF v < 3 THEN 210 +180 PRINT "Hit surface too fast (", v,")km/s" +190 PRINT "You Crash" +200 GOTO 220 +210 PRINT "Well done" +220 REM END + + + diff --git a/software/BAS/median.bas b/software/BAS/median.bas new file mode 100644 index 0000000..ef43909 --- /dev/null +++ b/software/BAS/median.bas @@ -0,0 +1,31 @@ +10 REM Median program. +20 LET N = 0 +30 DIM array(N+1) +40 PRINT "Enter a number, q to quit" +50 INPUT line$ +60 IF line$ = "q" THEN 100 +70 LET N = N + 1 +80 LET array(N) = VAL(line$) +90 GOTO 30 +100 PRINT N, "numbers entered" +105 IF N = 0 THEN 1000 +106 IF N = 1 THEN 210 +110 REM Bubble sort the numbers +120 LET flag = 0 +130 LET i = 1 +140 IF array(i) <= array(i+1) THEN 190 +150 LET flag = 1 +160 LET temp = array(i) +170 LET array(i) = array(i+1) +180 LET array(i+1) = temp +190 LET i = i + 1 +195 IF i < N THEN 140 +200 IF flag = 1 THEN 120 +210 REM print out the middle +220 IF N MOD 2 = 0 THEN 250 +230 LET mid = array( (N + 1) / 2) +240 GOTO 270 +250 LET mid = array(N/2) + array(N/2+1) +260 LET mid = mid/2 +270 PRINT "Median", mid +1000 REM end diff --git a/software/BAS/name.bas b/software/BAS/name.bas new file mode 100644 index 0000000..e81e67c --- /dev/null +++ b/software/BAS/name.bas @@ -0,0 +1,53 @@ +10 REM String-handling program +20 REM Inputs a name, tests for validity +30 REM and breaks up into parts. +40 PRINT "Enter your full name" +50 INPUT name$ + +60 REM First check for non-English characters +70 LET flag = 0 +80 FOR I = 1 TO LEN(name$) +90 LET ch$ = MID$(name$, I,1) +100 IF (ch$ >= "A" AND ch$ <= "z") OR ch$ = " " THEN 140 +110 LET flag = 1 +120 REM This forces the loop to stop +130 LET I = LEN(name$) +140 NEXT I +150 IF flag = 0 THEN 180 +160 PRINT "Non-English letter,", ch$ +170 GOTO 40 + +180 REM Jump to subroutine +190 LET return = 210 +200 GOTO 1000 +210 IF name$ = "" THEN 280 +220 LET return = 240 +230 GOTO 2000 +240 LET N = N + 1 +250 DIM out$(N) +260 LET out$(N) = word$ +270 GOTO 180 + +280 REM Print out the name +285 PRINT "Name accepted" +290 FOR I = 1 TO N +300 PRINT out$(I) + " "; +310 NEXT I +320 PRINT "" +330 GOTO 3000 + +1000 REM strips the leading space +1010 IF LEFT$(name$, 1) <> " " THEN return +1020 LET name$ = MID$(name$, 2, -1) +1030 GOTO 1010 + +2000 REM get the leading word and put it in word$ +2010 LET word$ = "" +2020 LET ch$ = LEFT$(name$, 1) +2030 IF ch$ < "A" OR ch$ > "z" THEN return +2040 LET word$ = word$ + ch$ +2050 LET name$ = MID$(name$, 2, -1) +2060 GOTO 2020 + +3000 REM END + diff --git a/software/CAS/3dnc.cas b/software/CAS/3dnc.cas new file mode 100644 index 0000000..f2c32aa Binary files /dev/null and b/software/CAS/3dnc.cas differ diff --git a/software/CAS/Adventr.cas b/software/CAS/Adventr.cas new file mode 100644 index 0000000..b0e8960 Binary files /dev/null and b/software/CAS/Adventr.cas differ diff --git a/software/CAS/Camel.cas b/software/CAS/Camel.cas new file mode 100644 index 0000000..71f2b19 Binary files /dev/null and b/software/CAS/Camel.cas differ diff --git a/software/CAS/Dame.cas b/software/CAS/Dame.cas new file mode 100644 index 0000000..fe3d7f2 Binary files /dev/null and b/software/CAS/Dame.cas differ diff --git a/software/CAS/Filter.cas b/software/CAS/Filter.cas new file mode 100644 index 0000000..74908e2 Binary files /dev/null and b/software/CAS/Filter.cas differ diff --git a/software/CAS/Ldgold.cas b/software/CAS/Ldgold.cas new file mode 100644 index 0000000..7dc0554 Binary files /dev/null and b/software/CAS/Ldgold.cas differ diff --git a/software/CAS/Schiffe.cas b/software/CAS/Schiffe.cas new file mode 100644 index 0000000..e527754 Binary files /dev/null and b/software/CAS/Schiffe.cas differ diff --git a/software/CAS/Scramble.cas b/software/CAS/Scramble.cas new file mode 100644 index 0000000..d69faa5 Binary files /dev/null and b/software/CAS/Scramble.cas differ diff --git a/software/CAS/Snailr.cas b/software/CAS/Snailr.cas new file mode 100644 index 0000000..db3e59d Binary files /dev/null and b/software/CAS/Snailr.cas differ diff --git a/software/CAS/Startrek.cas b/software/CAS/Startrek.cas new file mode 100644 index 0000000..97971b8 Binary files /dev/null and b/software/CAS/Startrek.cas differ diff --git a/software/CAS/Swinghs.cas b/software/CAS/Swinghs.cas new file mode 100644 index 0000000..0a2ca66 Binary files /dev/null and b/software/CAS/Swinghs.cas differ diff --git a/software/CAS/Swords.cas b/software/CAS/Swords.cas new file mode 100644 index 0000000..bb7e699 Binary files /dev/null and b/software/CAS/Swords.cas differ diff --git a/software/CAS/Symdiff.cas b/software/CAS/Symdiff.cas new file mode 100644 index 0000000..8a81577 Binary files /dev/null and b/software/CAS/Symdiff.cas differ diff --git a/software/CAS/The_Invaders.cas b/software/CAS/The_Invaders.cas new file mode 100644 index 0000000..0bf55bd Binary files /dev/null and b/software/CAS/The_Invaders.cas differ diff --git a/software/CAS/Vector.cas b/software/CAS/Vector.cas new file mode 100644 index 0000000..88abcce Binary files /dev/null and b/software/CAS/Vector.cas differ diff --git a/software/CAS/alieninv.cas b/software/CAS/alieninv.cas new file mode 100644 index 0000000..7012cd0 Binary files /dev/null and b/software/CAS/alieninv.cas differ diff --git a/software/CAS/amaster.cas b/software/CAS/amaster.cas new file mode 100644 index 0000000..14f74b3 Binary files /dev/null and b/software/CAS/amaster.cas differ diff --git a/software/CAS/bio.cas b/software/CAS/bio.cas new file mode 100644 index 0000000..99a042e Binary files /dev/null and b/software/CAS/bio.cas differ diff --git a/software/CAS/bio2.cas b/software/CAS/bio2.cas new file mode 100644 index 0000000..19c85fe Binary files /dev/null and b/software/CAS/bio2.cas differ diff --git a/software/CAS/drive.cas b/software/CAS/drive.cas new file mode 100644 index 0000000..970b957 Binary files /dev/null and b/software/CAS/drive.cas differ diff --git a/software/CAS/hangman.cas b/software/CAS/hangman.cas new file mode 100644 index 0000000..3b3b5d9 Binary files /dev/null and b/software/CAS/hangman.cas differ diff --git a/software/CAS/hello.cas b/software/CAS/hello.cas new file mode 100644 index 0000000..88b496b Binary files /dev/null and b/software/CAS/hello.cas differ diff --git a/software/CAS/keyskraal.cas b/software/CAS/keyskraal.cas new file mode 100644 index 0000000..070c8b7 Binary files /dev/null and b/software/CAS/keyskraal.cas differ diff --git a/software/CAS/labyrb.cas b/software/CAS/labyrb.cas new file mode 100644 index 0000000..3e3c320 Binary files /dev/null and b/software/CAS/labyrb.cas differ diff --git a/software/CAS/limo.cas b/software/CAS/limo.cas new file mode 100644 index 0000000..44e57f8 Binary files /dev/null and b/software/CAS/limo.cas differ diff --git a/software/CAS/lunar2.cas b/software/CAS/lunar2.cas new file mode 100644 index 0000000..a5a6882 Binary files /dev/null and b/software/CAS/lunar2.cas differ diff --git a/software/CAS/maloche.cas b/software/CAS/maloche.cas new file mode 100644 index 0000000..865d907 Binary files /dev/null and b/software/CAS/maloche.cas differ diff --git a/software/CAS/moonbase.cas b/software/CAS/moonbase.cas new file mode 100644 index 0000000..bba74e9 Binary files /dev/null and b/software/CAS/moonbase.cas differ diff --git a/software/CAS/othello.cas b/software/CAS/othello.cas new file mode 100644 index 0000000..b0bd470 Binary files /dev/null and b/software/CAS/othello.cas differ diff --git a/software/CAS/quest.cas b/software/CAS/quest.cas new file mode 100644 index 0000000..5f3d620 Binary files /dev/null and b/software/CAS/quest.cas differ diff --git a/software/CAS/sheepdog.cas b/software/CAS/sheepdog.cas new file mode 100644 index 0000000..b9fd566 Binary files /dev/null and b/software/CAS/sheepdog.cas differ diff --git a/software/CAS/srmbl.cas b/software/CAS/srmbl.cas new file mode 100644 index 0000000..bc9a1cd Binary files /dev/null and b/software/CAS/srmbl.cas differ diff --git a/software/CAS/startk16.cas b/software/CAS/startk16.cas new file mode 100644 index 0000000..b47bd11 Binary files /dev/null and b/software/CAS/startk16.cas differ diff --git a/software/CAS/wraptrap.cas b/software/CAS/wraptrap.cas new file mode 100644 index 0000000..1d326a4 Binary files /dev/null and b/software/CAS/wraptrap.cas differ diff --git a/software/CPM/1M44/DSK/CPM23_1M44_PLI.DSK b/software/CPM/1M44/DSK/CPM23_1M44_PLI.DSK index 5ce4b3b..f74a89c 100644 Binary files a/software/CPM/1M44/DSK/CPM23_1M44_PLI.DSK and b/software/CPM/1M44/DSK/CPM23_1M44_PLI.DSK differ diff --git a/software/CPM/1M44/RAW/CPM23_1M44_PLI.RAW b/software/CPM/1M44/RAW/CPM23_1M44_PLI.RAW index 774cd0f..cda1e97 100644 Binary files a/software/CPM/1M44/RAW/CPM23_1M44_PLI.RAW and b/software/CPM/1M44/RAW/CPM23_1M44_PLI.RAW differ diff --git a/software/CPM/ASM80/ASM80 b/software/CPM/ASM80/ASM80 new file mode 100644 index 0000000..343db52 Binary files /dev/null and b/software/CPM/ASM80/ASM80 differ diff --git a/software/CPM/ASM80/ASM80.EXE b/software/CPM/ASM80/ASM80.EXE new file mode 100644 index 0000000..05e2dcd Binary files /dev/null and b/software/CPM/ASM80/ASM80.EXE differ diff --git a/software/CPM/ASM80/ASM80.OV0 b/software/CPM/ASM80/ASM80.OV0 new file mode 100644 index 0000000..5b38aa5 Binary files /dev/null and b/software/CPM/ASM80/ASM80.OV0 differ diff --git a/software/CPM/ASM80/ASM80.OV1 b/software/CPM/ASM80/ASM80.OV1 new file mode 100644 index 0000000..4b4cf91 Binary files /dev/null and b/software/CPM/ASM80/ASM80.OV1 differ diff --git a/software/CPM/ASM80/ASM80.OV2 b/software/CPM/ASM80/ASM80.OV2 new file mode 100644 index 0000000..da08650 Binary files /dev/null and b/software/CPM/ASM80/ASM80.OV2 differ diff --git a/software/CPM/ASM80/ASM80.OV3 b/software/CPM/ASM80/ASM80.OV3 new file mode 100644 index 0000000..75658d4 Binary files /dev/null and b/software/CPM/ASM80/ASM80.OV3 differ diff --git a/software/CPM/ASM80/ASM80.OV4 b/software/CPM/ASM80/ASM80.OV4 new file mode 100644 index 0000000..b6d9547 Binary files /dev/null and b/software/CPM/ASM80/ASM80.OV4 differ diff --git a/software/CPM/ASM80/ASM80.OV5 b/software/CPM/ASM80/ASM80.OV5 new file mode 100644 index 0000000..da48e7a Binary files /dev/null and b/software/CPM/ASM80/ASM80.OV5 differ diff --git a/software/CPM/ASM80/ASXREF b/software/CPM/ASM80/ASXREF new file mode 100644 index 0000000..7d1740c Binary files /dev/null and b/software/CPM/ASM80/ASXREF differ diff --git a/software/CPM/ASM80/CONV86 b/software/CPM/ASM80/CONV86 new file mode 100644 index 0000000..b4ee6ba Binary files /dev/null and b/software/CPM/ASM80/CONV86 differ diff --git a/software/CPM/ASM80/FPAL.LIB b/software/CPM/ASM80/FPAL.LIB new file mode 100644 index 0000000..eadd36e Binary files /dev/null and b/software/CPM/ASM80/FPAL.LIB differ diff --git a/software/CPM/ASM80/HEXOBJ b/software/CPM/ASM80/HEXOBJ new file mode 100644 index 0000000..136e296 Binary files /dev/null and b/software/CPM/ASM80/HEXOBJ differ diff --git a/software/CPM/ASM80/ISIS.DOC b/software/CPM/ASM80/ISIS.DOC new file mode 100644 index 0000000..b01e041 --- /dev/null +++ b/software/CPM/ASM80/ISIS.DOC @@ -0,0 +1,59 @@ + + + Instructions for ISIS environment V1.0 + ====================================== + +The ISIS environment is designed to allow 8080 based Intel tools to run on +an 8086 PCDOS based system. The ISIS environment does not support all ISIS +calls, but sufficient to run 8051 translators and utilities. (If the program +uses an unsupported ISIS call an error message is generated). + + +DOS instructions +---------------- + +Load the software(ISIS) onto the harddisk. If ISIS is installed in the DOS +search path it will be directly loadable by entering "ISIS". + +Before entering ISIS, logical names must be set to match any ISIS disk drives +used by the ISIS tools. This includes :F0: - the ISIS environment does NOT +default to the current drive. As with 8080 ISIS, filenames without a drive +prefix are directed to :F0:. + + +C>SET :F0:=\ISIS /* make sure there is no before the "=" */ +C>SET :F1:=\BITBUS + +C>ISIS /* invoke ISIS emulator */ +DOS ISIS Environment X003 +=ASM51 :F1:SAMP1.A51 /* enter ISIS commands */ +... +... +=EXIT /* return to DOS */ + + +The ISIS environment will also run under DOS in batch mode + +Command file (DEMO.CMD) contains: + +ASM51 :F1:SAMP1.A51 +ASM51 :F1:SAMP2.A51 +ASM51 :F1:SAMP3.A51 +RL51 :F1:SAMP1.OBJ, & +:F1:SAMP2.OBJ, & +:F1:SAMP3.OBJ TO :F1:SAMPLE +EXIT /* must include EXIT since all program + input must be in command file + otherwise DOS will wait forever */ + +To invoke the command file + +C>ISIS < DEMO.CMD /* This could be part of a batch job */ + + or will abort the ISIS environment. You will need to +enter also if the ISIS environment is at the prompt level. Also the +command "BREAK ON" should be included in the AUTOEXEC.BAT file to permit DOS +to recognise all the time (not just when performing DOS calls). + + +Known Bugs/Problems: None diff --git a/software/CPM/ASM80/ISIS.EXE b/software/CPM/ASM80/ISIS.EXE new file mode 100644 index 0000000..75b4e6d Binary files /dev/null and b/software/CPM/ASM80/ISIS.EXE differ diff --git a/software/CPM/ASM80/IXREF b/software/CPM/ASM80/IXREF new file mode 100644 index 0000000..d7d1d30 Binary files /dev/null and b/software/CPM/ASM80/IXREF differ diff --git a/software/CPM/ASM80/LIB b/software/CPM/ASM80/LIB new file mode 100644 index 0000000..2913c75 Binary files /dev/null and b/software/CPM/ASM80/LIB differ diff --git a/software/CPM/ASM80/LINK b/software/CPM/ASM80/LINK new file mode 100644 index 0000000..f44e717 Binary files /dev/null and b/software/CPM/ASM80/LINK differ diff --git a/software/CPM/ASM80/LINK.OVL b/software/CPM/ASM80/LINK.OVL new file mode 100644 index 0000000..31aa7a2 Binary files /dev/null and b/software/CPM/ASM80/LINK.OVL differ diff --git a/software/CPM/ASM80/LOCATE b/software/CPM/ASM80/LOCATE new file mode 100644 index 0000000..0020ac7 Binary files /dev/null and b/software/CPM/ASM80/LOCATE differ diff --git a/software/CPM/ASM80/OBJHEX b/software/CPM/ASM80/OBJHEX new file mode 100644 index 0000000..3ebad01 Binary files /dev/null and b/software/CPM/ASM80/OBJHEX differ diff --git a/software/CPM/ASM80/PLM51.LIB b/software/CPM/ASM80/PLM51.LIB new file mode 100644 index 0000000..ea1038a Binary files /dev/null and b/software/CPM/ASM80/PLM51.LIB differ diff --git a/software/CPM/ASM80/PLM80.LIB b/software/CPM/ASM80/PLM80.LIB new file mode 100644 index 0000000..ebb685a Binary files /dev/null and b/software/CPM/ASM80/PLM80.LIB differ diff --git a/software/CPM/ASM80/SUBMIT b/software/CPM/ASM80/SUBMIT new file mode 100644 index 0000000..d9a6e2f Binary files /dev/null and b/software/CPM/ASM80/SUBMIT differ diff --git a/software/CPM/ASM80/SYSTEM.LIB b/software/CPM/ASM80/SYSTEM.LIB new file mode 100644 index 0000000..c6e06ef Binary files /dev/null and b/software/CPM/ASM80/SYSTEM.LIB differ diff --git a/software/CPM/CPM23_PLI/BIOSKRNL.ASM b/software/CPM/CPM23_PLI/BIOSKRNL.ASM new file mode 100644 index 0000000..faff988 --- /dev/null +++ b/software/CPM/CPM23_PLI/BIOSKRNL.ASM @@ -0,0 +1,704 @@ +;******************************************************************************************** +; +; BIOSKRNL.ASM - S170319 +; CP/M 3.0 ROOT BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R260119 (or following revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; (Search the string 'Z80-MBC2' for changes) +; +; CHANGELOG: +; +; S170319 First release +; +; +;******************************************************************************************** + title 'Root module of relocatable BIOS for CP/M 3.0' + + ; version 1.0 15 Sept 82 + +true equ -1 +false equ not true + +banked equ TRUE ;<------ BANKED Version + + +; Copyright (C), 1982 +; Digital Research, Inc +; P.O. Box 579 +; Pacific Grove, CA 93950 + + +; This is the invariant portion of the modular BIOS and is +; distributed as source for informational purposes only. +; All desired modifications should be performed by +; adding or changing externally defined modules. +; This allows producing "standard" I/O modules that +; can be combined to support a particular system +; configuration. + +cr equ 13 +lf equ 10 +bell equ 7 +ctlQ equ 'Q'-'@' +ctlS equ 'S'-'@' + +ccp equ 0100h ; Console Command Processor gets loaded into the TPA + + cseg ; GENCPM puts CSEG stuff in common memory + + + ; variables in system data page + + extrn @covec,@civec,@aovec,@aivec,@lovec ; I/O redirection vectors + extrn @mxtpa ; addr of system entry point + extrn @bnkbf ; 128 byte scratch buffer + + ; initialization + + extrn ?init ; general initialization and signon + extrn ?ldccp,?rlccp ; load & reload CCP for BOOT & WBOOT + + ; user defined character I/O routines + + extrn ?ci,?co,?cist,?cost ; each take device in + extrn ?cinit ; (re)initialize device in + extrn @ctbl ; physical character device table + + ; --------------------------------------------------------------- + extrn ?cnstFlg ; CONST mode flag (Z80-MBC2) + ; --------------------------------------------------------------- + + ; disk communication data items + + extrn @dtbl ; table of pointers to XDPHs + public @adrv,@rdrv,@trk,@sect ; parameters for disk I/O + public @dma,@dbnk,@cnt ; '' '' '' '' + + ; memory control + + public @cbnk ; current bank + extrn ?xmove,?move ; select move bank, and block move + extrn ?bank ; select CPU bank + + ; clock support + + extrn ?time ; signal time operation + + ; general utility routines + + public ?pmsg,?pdec ; print message, print number from 0 to 65535 + public ?pderr ; print BIOS disk error message header + + maclib modebaud ; define mode bits + + + ; External names for BIOS entry points + + public ?boot,?wboot,?const,?conin,?cono,?list,?auxo,?auxi + public ?home,?sldsk,?sttrk,?stsec,?stdma,?read,?write + public ?lists,?sctrn + public ?conos,?auxis,?auxos,?dvtbl,?devin,?drtbl + public ?mltio,?flush,?mov,?tim,?bnksl,?stbnk,?xmov + + + ; BIOS Jump vector. + + ; All BIOS routines are invoked by calling these + ; entry points. + +?boot: jmp boot ; initial entry on cold start +?wboot: jmp wboot ; reentry on program exit, warm start + +?const: jmp const ; return console input status +?conin: jmp conin ; return console input character +?cono: jmp conout ; send console output character +?list: jmp list ; send list output character +?auxo: jmp auxout ; send auxilliary output character +?auxi: jmp auxin ; return auxilliary input character + +?home: jmp home ; set disks to logical home +?sldsk: jmp seldsk ; select disk drive, return disk parameter info +?sttrk: jmp settrk ; set disk track +?stsec: jmp setsec ; set disk sector +?stdma: jmp setdma ; set disk I/O memory address +?read: jmp read ; read physical block(s) +?write: jmp write ; write physical block(s) + +?lists: jmp listst ; return list device status +?sctrn: jmp sectrn ; translate logical to physical sector + +?conos: jmp conost ; return console output status +?auxis: jmp auxist ; return aux input status +?auxos: jmp auxost ; return aux output status +?dvtbl: jmp devtbl ; return address of device def table +?devin: jmp ?cinit ; change baud rate of device + +?drtbl: jmp getdrv ; return address of disk drive table +?mltio: jmp multio ; set multiple record count for disk I/O +?flush: jmp flush ; flush BIOS maintained disk caching + +?mov: jmp ?move ; block move memory to memory +?tim: jmp ?time ; Signal Time and Date operation +?bnksl: jmp bnksel ; select bank for code execution and default DMA +?stbnk: jmp setbnk ; select different bank for disk I/O DMA operations. +?xmov: jmp ?xmove ; set source and destination banks for one operation + +; ----------------------------------------------------------------------------------- +cnstmd: jmp cnstmde ; set 8 bit CONST mode (non standard jmp. Added for the Z80-MBC2) +; ----------------------------------------------------------------------------------- + + jmp 0 ; reserved for future expansion + jmp 0 ; reserved for future expansion + + + ; ------------------------------------------------------------- + ; CONST MODE (Z80-MBC2) + ; Set the Console Input Status mode to 8 bit + ; This is a non standard function only for the Z80-MBC2 + ; ------------------------------------------------------------- + +cnstmde: + push psw + mvi a, 01H ; A = 1 + sta ?cnstFlg ; Set the CONST mode to 8 bit (Z80-MBC2) + pop psw + ret + + + ; BOOT + ; Initial entry point for system startup. + + dseg ; this part can be banked + +boot: + lxi sp,boot$stack + mvi c,15 ; initialize all 16 character devices +c$init$loop: + push b ! call ?cinit ! pop b + dcr c ! jp c$init$loop + + call ?init ; perform any additional system initialization + ; and print signon message + + lxi b,16*256+0 ! lxi h,@dtbl ; init all 16 logical disk drives +d$init$loop: + push b ; save remaining count and abs drive + mov e,m ! inx h ! mov d,m ! inx h ; grab @drv entry + mov a,e ! ora d ! jz d$init$next ; if null, no drive + push h ; save @drv pointer + xchg ; XDPH address in + dcx h ! dcx h ! mov a,m ! sta @RDRV ; get relative drive code + mov a,c ! sta @ADRV ; get absolute drive code + dcx h ; point to init pointer + mov d,m ! dcx h ! mov e,m ; get init pointer + xchg ! call ipchl ; call init routine + pop h ; recover @drv pointer +d$init$next: + pop b ; recover counter and drive # + inr c ! dcr b ! jnz d$init$loop ; and loop for each drive + jmp boot$1 + + cseg ; following in resident memory + +boot$1: + call set$jumps + call ?ldccp ; fetch CCP for first time + jmp ccp + + + ; WBOOT + ; Entry for system restarts. + +wboot: + lxi sp,boot$stack + call set$jumps ; initialize page zero + + ; --------------------------------------------------------- + ; Set the CONST mode to 7 bit (Z80-MBC2) + ; --------------------------------------------------------- + push psw + xra a ; A = 0 + sta ?cnstFlg ; Set the CONST mode flag to 7 bit (Z80-MBC2) + pop psw + + call ?rlccp ; reload CCP + jmp ccp ; then reset jmp vectors and exit to ccp + + +set$jumps: + + if banked + mvi a,1 ! call ?bnksl + endif + + mvi a,JMP + sta 0 ! sta 5 ; set up jumps in page zero + lxi h,?wboot ! shld 1 ; BIOS warm start entry + lhld @MXTPA ! shld 6 ; BDOS system call entry + ret + + + ds 64 +boot$stack equ $ + + + ; DEVTBL + ; Return address of character device table + +devtbl: + lxi h,@ctbl ! ret + + + ; GETDRV + ; Return address of drive table + +getdrv: + lxi h,@dtbl ! ret + + + + ; CONOUT + ; Console Output. Send character in + ; to all selected devices + +conout: + + lhld @covec ; fetch console output bit vector + jmp out$scan + + + ; AUXOUT + ; Auxiliary Output. Send character in + ; to all selected devices + +auxout: + lhld @aovec ; fetch aux output bit vector + jmp out$scan + + + ; LIST + ; List Output. Send character in + ; to all selected devices. + +list: + lhld @lovec ; fetch list output bit vector + +out$scan: + mvi b,0 ; start with device 0 +co$next: + dad h ; shift out next bit + jnc not$out$device + push h ; save the vector + push b ; save the count and character +not$out$ready: + call coster ! ora a ! jz not$out$ready + pop b ! push b ; restore and resave the character and device + call ?co ; if device selected, print it + pop b ; recover count and character + pop h ; recover the rest of the vector +not$out$device: + inr b ; next device number + mov a,h ! ora l ; see if any devices left + jnz co$next ; and go find them... + ret + + + ; CONOST + ; Console Output Status. Return true if + ; all selected console output devices + ; are ready. + +conost: + lhld @covec ; get console output bit vector + jmp ost$scan + + + ; AUXOST + ; Auxiliary Output Status. Return true if + ; all selected auxiliary output devices + ; are ready. + +auxost: + lhld @aovec ; get aux output bit vector + jmp ost$scan + + + ; LISTST + ; List Output Status. Return true if + ; all selected list output devices + ; are ready. + +listst: + lhld @lovec ; get list output bit vector + +ost$scan: + mvi b,0 ; start with device 0 +cos$next: + dad h ; check next bit + push h ; save the vector + push b ; save the count + mvi a,0FFh ; assume device ready + cc coster ; check status for this device + pop b ; recover count + pop h ; recover bit vector + ora a ; see if device ready + rz ; if any not ready, return false + inr b ; drop device number + mov a,h ! ora l ; see if any more selected devices + jnz cos$next + ori 0FFh ; all selected were ready, return true + ret + +coster: ; check for output device ready, including optional + ; xon/xoff support + mov l,b ! mvi h,0 ; make device code 16 bits + push h ; save it in stack + dad h ! dad h ! dad h ; create offset into device characteristics tbl + lxi d,@ctbl+6 ! dad d ; make address of mode byte + mov a,m ! ani mb$xonxoff + pop h ; recover console number in + jz ?cost ; not a xon device, go get output status direct + lxi d,xofflist ! dad d ; make pointer to proper xon/xoff flag + call cist1 ; see if this keyboard has character + mov a,m ! cnz ci1 ; get flag or read key if any + cpi ctlq ! jnz not$q ; if its a ctl-Q, + mvi a,0FFh ; set the flag ready +not$q: + cpi ctls ! jnz not$s ; if its a ctl-S, + mvi a,00h ; clear the flag +not$s: + mov m,a ; save the flag + call cost1 ; get the actual output status, + ana m ; and mask with ctl-Q/ctl-S flag + ret ; return this as the status + +cist1: ; get input status with and saved + push b ! push h + call ?cist + pop h ! pop b + ora a + ret + +cost1: ; get output status, saving & + push b ! push h + call ?cost + pop h ! pop b + ora a + ret + +ci1: ; get input, saving & + push b ! push h + call ?ci + pop h ! pop b + ret + + + + + + ; CONST + ; Console Input Status. Return true if + ; any selected console input device + ; has an available character. + +const: + lhld @civec ; get console input bit vector + jmp ist$scan + + + ; AUXIST + ; Auxiliary Input Status. Return true if + ; any selected auxiliary input device + ; has an available character. + +auxist: + lhld @aivec ; get aux input bit vector + +ist$scan: + mvi b,0 ; start with device 0 +cis$next: + dad h ; check next bit + mvi a,0 ; assume device not ready + cc cist1 ; check status for this device + ora a ! rnz ; if any ready, return true + inr b ; drop device number + mov a,h ! ora l ; see if any more selected devices + jnz cis$next + xra a ; all selected were not ready, return false + ret + + + ; CONIN + ; Console Input. Return character from first + ; ready console input device. + +conin: + lhld @civec + jmp in$scan + + + ; AUXIN + ; Auxiliary Input. Return character from first + ; ready auxiliary input device. + +auxin: + lhld @aivec + +in$scan: + push h ; save bit vector + mvi b,0 +ci$next: + dad h ; shift out next bit + mvi a,0 ; insure zero a (nonexistant device not ready). + cc cist1 ; see if the device has a character + ora a + jnz ci$rdy ; this device has a character + inr b ; else, next device + mov a,h ! ora l ; see if any more devices + jnz ci$next ; go look at them + pop h ; recover bit vector + jmp in$scan ; loop til we find a character + +ci$rdy: + pop h ; discard extra stack + jmp ?ci + + +; Utility Subroutines + + +ipchl: ; vectored CALL point + pchl + + +?pmsg: ; print message @ up to a null + ; saves & + push b + push d +pmsg$loop: + mov a,m ! ora a ! jz pmsg$exit + mov c,a ! push h + call ?cono ! pop h + inx h ! jmp pmsg$loop +pmsg$exit: + pop d + pop b + ret + +?pdec: ; print binary number 0-65535 from + lxi b,table10! lxi d,-10000 +next: + mvi a,'0'-1 +pdecl: + push h! inr a! dad d! jnc stoploop + inx sp! inx sp! jmp pdecl +stoploop: + push d! push b + mov c,a! call ?cono + pop b! pop d +nextdigit: + pop h + ldax b! mov e,a! inx b + ldax b! mov d,a! inx b + mov a,e! ora d! jnz next + ret + +table10: + dw -1000,-100,-10,-1,0 + +?pderr: + lxi h,drive$msg ! call ?pmsg ; error header + lda @adrv ! adi 'A' ! mov c,a ! call ?cono ; drive code + lxi h,track$msg ! call ?pmsg ; track header + lhld @trk ! call ?pdec ; track number + lxi h,sector$msg ! call ?pmsg ; sector header + lhld @sect ! call ?pdec ; sector number + ret + + + ; BNKSEL + ; Bank Select. Select CPU bank for further execution. + +bnksel: + sta @cbnk ; remember current bank + jmp ?bank ; and go exit through users + ; physical bank select routine + + +xofflist db -1,-1,-1,-1,-1,-1,-1,-1 ; ctl-s clears to zero + db -1,-1,-1,-1,-1,-1,-1,-1 + + + + dseg ; following resides in banked memory + + + +; Disk I/O interface routines + + + ; SELDSK + ; Select Disk Drive. Drive code in . + ; Invoke login procedure for drive + ; if this is first select. Return + ; address of disk parameter header + ; in + +seldsk: + mov a,c ! sta @adrv ; save drive select code + mov l,c ! mvi h,0 ! dad h ; create index from drive code + lxi b,@dtbl ! dad b ; get pointer to dispatch table + mov a,m ! inx h ! mov h,m ! mov l,a ; point at disk descriptor + ora h ! rz ; if no entry in table, no disk + mov a,e ! ani 1 ! jnz not$first$select ; examine login bit + push h ! xchg ; put pointer in stack & + lxi h,-2 ! dad d ! mov a,m ! sta @RDRV ; get relative drive + lxi h,-6 ! dad d ; find LOGIN addr + mov a,m ! inx h ! mov h,m ! mov l,a ; get address of LOGIN routine + call ipchl ; call LOGIN + pop h ; recover DPH pointer +not$first$select: + ret + + + ; HOME + ; Home selected drive. Treated as SETTRK(0). + +home: + lxi b,0 ; same as set track zero + + + ; SETTRK + ; Set Track. Saves track address from + ; in @TRK for further operations. + +settrk: + mov l,c ! mov h,b + shld @trk + ret + + + ; SETSEC + ; Set Sector. Saves sector number from + ; in @sect for further operations. + +setsec: + mov l,c ! mov h,b + shld @sect + ret + + + ; SETDMA + ; Set Disk Memory Address. Saves DMA address + ; from in @DMA and sets @DBNK to @CBNK + ; so that further disk operations take place + ; in current bank. + +setdma: + mov l,c ! mov h,b + shld @dma + + lda @cbnk ; default DMA bank is current bank + ; fall through to set DMA bank + + ; SETBNK + ; Set Disk Memory Bank. Saves bank number + ; in @DBNK for future disk data + ; transfers. + +setbnk: + sta @dbnk + ret + + + ; SECTRN + ; Sector Translate. Indexes skew table in + ; with sector in . Returns physical sector + ; in . If no skew table (=0) then + ; returns physical=logical. + +sectrn: + mov l,c ! mov h,b + mov a,d ! ora e ! rz + xchg ! dad b ! mov l,m ! mvi h,0 + ret + + + ; READ + ; Read physical record from currently selected drive. + ; Finds address of proper read routine from + ; extended disk parameter header (XDPH). + +read: + lhld @adrv ! mvi h,0 ! dad h ; get drive code and double it + lxi d,@dtbl ! dad d ; make address of table entry + mov a,m ! inx h ! mov h,m ! mov l,a ; fetch table entry + push h ; save address of table + lxi d,-8 ! dad d ; point to read routine address + jmp rw$common ; use common code + + + ; WRITE + ; Write physical sector from currently selected drive. + ; Finds address of proper write routine from + ; extended disk parameter header (XDPH). + +write: + lhld @adrv ! mvi h,0 ! dad h ; get drive code and double it + lxi d,@dtbl ! dad d ; make address of table entry + mov a,m ! inx h ! mov h,m ! mov l,a ; fetch table entry + push h ; save address of table + lxi d,-10 ! dad d ; point to write routine address + +rw$common: + mov a,m ! inx h ! mov h,m ! mov l,a ; get address of routine + pop d ; recover address of table + dcx d ! dcx d ; point to relative drive + ldax d ! sta @rdrv ; get relative drive code and post it + inx d ! inx d ; point to DPH again + pchl ; leap to driver + + + ; MULTIO + ; Set multiple sector count. Saves passed count in + ; @CNT + +multio: + sta @cnt ! ret + + + ; FLUSH + ; BIOS deblocking buffer flush. Not implemented. + +flush: + xra a ! ret ; return with no error + + + + ; error message components +drive$msg db cr,lf,bell,'BIOS Error on ',0 +track$msg db ': T-',0 +sector$msg db ', S-',0 + + + ; disk communication data items + +@adrv ds 1 ; currently selected disk drive +@rdrv ds 1 ; controller relative disk drive +@trk ds 2 ; current track number +@sect ds 2 ; current sector number +@dma ds 2 ; current DMA address +@cnt db 0 ; record count for multisector transfer +@dbnk db 0 ; bank for DMA operations + + + cseg ; common memory + +@cbnk db 0 ; bank for processor operations + + + end + \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/BOOT.ASM b/software/CPM/CPM23_PLI/BOOT.ASM new file mode 100644 index 0000000..464b196 --- /dev/null +++ b/software/CPM/CPM23_PLI/BOOT.ASM @@ -0,0 +1,375 @@ +;******************************************************************************************** +; +; BOOT.ASM - S220918-R180319 +; CP/M 3.0 BOOT LOADER BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +; CHANGELOG: +; +; S220918 First release +; S220918-R090319 Changed system sign-on message +; S220918-R180319 Changed system sign-on message +; +;******************************************************************************************** + + TITLE 'BOOT LOADER MODULE FOR CP/M 3.0 - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT: +BANKED EQU TRUE ; <------ BANKED/NON-BANKED SWITCH + + ; DEFINE PUBLIC LABELS: + PUBLIC ?INIT,?LDCCP,?RLCCP,?TIME + ;PUBLIC OUT$BLOCKS + + ; EXTERNALLY DEFINED ENTRY POINTS AND LABELS: + EXTRN ?PMSG,?CONIN + EXTRN @CIVEC,@COVEC,@AIVEC,@AOVEC,@LOVEC + EXTRN @CBNK,?BNKSL + EXTRN @SEC,@MIN,@HOUR,@DATE ;FIELDS HOLDING CURRENT TIME AND DATE + + ; INCLUDE Z-80 MACROS: + MACLIB Z80 + + ; SOME MISCELLANEOUS EQUATES: +BDOS EQU 5 +CR EQU 13 ; ASCII CARRIAGE RETURN +LF EQU 10 ; ASCII LINEFEED + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; WE CAN DO INITIALIZATION FROM BANKED MEMORY (IF WE HAVE IT): + IF BANKED + ; -------------------------- + DSEG ; INIT DONE FROM BANKED MEMORY + ; -------------------------- + ELSE + ; -------------------------- + CSEG ; INIT TO BE DONE FROM COMMON MEMORY + ; -------------------------- + ENDIF + + ; HARDWARE INITIALIZATION OTHER THAN CHARACTER AND DISK I/O + +?INIT: + ; ASSIGN CONSOLE INPUT AND OUTPUT TO CRT: + LXI H,8000H ;SIGNIFIES DEVICE 0 + SHLD @CIVEC ;CONSOLE INPUT VECTOR + SHLD @COVEC ;CONSOLE OUTPUT VECTOR + + ; PRINT THE SIGN-ON MESSAGE: + LXI H,SIGNON$MSG ;POINT TO IT + JMP ?PMSG ;AND PRINT IT + ; Note: "RET" here is not needed because we use the that one at the end of ?PMSG + + IF BANKED + ; -------------------------- + CSEG + ; -------------------------- + ENDIF + + ; THIS ROUTINE IS ENTERED TO LOAD THE CCP.COM FILE INTO THE TPA BANK + ; AT SYSTEM COLD START + +?LDCCP: + ; SET UP THE FCB FOR THE FILE OPERATION + ; NOTE: If banked at this point bank 1 is alredy selected + ; (see BIOSKRNL.ASM) + XRA A ;ZERO EXTENT + STA CCP$FCB+15 + LXI H,0 ;START AT BEGINNING OF FILE + SHLD FCB$NR + + ; TRY TO OPEN THE CCP.COM FILE: + LXI D,CCP$FCB ;POINT TO FCB + CALL OPEN ;ATTEMPT THE OPEN OPERATION + INR A ;WAS IT ON THE DISK ? + JRNZ CCP$FOUND ;YES -- GO LOAD IT + + ; WE ARRIVE HERE WHEN CCP.COM FILE WASN'T FOUND: + LXI H,CCP$MSG ;REPORT THE ERROR + CALL ?PMSG + CALL ?CONIN ;GET A RESPONSE + JR ?LDCCP ;AND TRY AGAIN + + ; FILE WAS OPENED OK -- READ IT IN: +CCP$FOUND: + LXI D,0100H ;LOAD AT BOTTOM OF TPA + CALL SETDMA ;BY SETTING THE NEXT DMA ADDRESS + LXI D,128 ;SET MULTI SECTOR I/O COUNT + CALL SETMULTI ; TO ALLOW UP TO 16K BYTES IN ONE OPERATION + LXI D,CCP$FCB ;POINT TO THE FCB + CALL READ ;AND READ THE CCP IN + RET + + ; ROUTINE RELOADS CCP IMAGE FROM BANK 2 IF BANKED SYSTEM OR FROM THE + ; DISK IF NON-BANKED VERSION + +?RLCCP: + JMP ?LDCCP ;JUST DO LOAD AS THOUGH COLD BOOT + +; -------------------------------------------------------------------------------- +; +; SETS/GETS TIME (Z80-MBC2) +; +; The time of day is kept as four fields. +; @DATE is a binary word containing the number of days since 31 December 1977. +; The bytes @HOUR, @MIN, and @SEC in the System Control Block contain the +; hour, minute, and second in Binary Coded Decimal (BCD) format. +; +; C = Get/Set Flag +; C=000H if get, C=0FFH if set +; (see Appendix J, Table J-1 of CP/M 3 System Guide) +; +; NOTE1: Only the Get function is implemented. +; To change RTC date/time use the IOS "SELECT BOOT MODE OR SYSTEM PARAMETERS" menu. +; NOTE2: Because the IOS RTC year is from 00 to 99 only date from 1-1-2000 to 31-12-2099 +; are valid for this algorithm (I think that it's enough...) +; +; -------------------------------------------------------------------------------- + +?TIME: + ; + ; Check if it is a get time operation + mov a, c + ora a ; Get/Set Flag = 0? + rnz ; Return if it is a Set Time request + ; + ; Check if the RTC module is present + mvi a, SYSFLAG$OPC ; Select SYSFLAG opcode + out STO$OPCD + in EXC$RD$OPCD ; A = SYSFLAG + ani 02h ; Isolate the RTC flag bit + rz ; Return if the RTC is not present + push b + push d + push h + ; + ; Load date/time from the RTC to RTCBUFF + mvi a, DATETIM$OPC ; Select DATETIME opcode + out STO$OPCD + mvi c, EXC$RD$OPCD ; C = EXECUTE READ opcode + lxi h, RTCBUFF ; HL -> RTC Buffer + mvi b, 6 ; Byte counter = 6 + inir ; Read date/time to RTCBUFF + ; + ; Update @SEC (BCD) + lxi b, RTCBUFF ; BC -> RTC seconds + ldax b ; A = RTC seconds (binary) + call bin2bcd ; Binary to BCD + sta @SEC ; Store it into @SEC + ; + ; Update @MIN (BCD) + inx b ; BC -> RTC minutes + ldax b ; A = RTC minutes (binary) + call bin2bcd ; Binary to BCD + sta @MIN ; Store it into @MIN + ; + ; Update @HOUR (BCD) + inx b ; BC -> RTC hours + ldax b ; A = RTC hours (binary) + call bin2bcd ; Binary to BCD + sta @HOUR ; Store it into @HOUR + ; + ; Calculate how many whole years elapsed from 31-12-1977 to now + lda RTCYEAR + adi 22 + mov c, a ; C = elapsed_years = (RTCYEAR) + 22 + ; + ; Convert it in days into HL (16 bit) + xra a ; A = 0 + mov b, a ; B = 0. BC = elapsed_years (16bit) + lxi d, 365 ; DE = 365 + call Mult16 ; HL = elapsed_years * 365 = elapsed_years_days + ; + ; Calculate how many whole leap years elapsed from 31-12-1977 to now + ; (current year excluded) and add it to elapsed_years_days + lda RTCYEAR + ora a + jrz addleapyrs ; If RTCYEAR = 00 -> A = 0 + dcr a ; If RTCYEAR > 00 -> A = (RTRYEAR) - 1 + srlr a ; / 2S + srlr a ; / 4 + inr a ; If RTCYEAR > 00 -> A = (((RTCYEAR) - 1) / 4) + 1 = + ; leap years from 31-12-1999 to now (current year excluded) +addleapyrs: + adi 5 ; Add leap years from 31-12-1977 to 31-12-1999 + mov c, a ; C = elapsed_leap_years = (((RTCYEAR) - 1) / 4) + 1 + 5 + xra a ; A = 0 + mov d, a ; D = 0 + mov b ,a ; B = 0. BC = elapsed_leap_years (16bit) + dad b ; HL = elapsed_years_days + elapsed_leap_years + ; + ; Add days of current month + lda RTCDAY + mov c, a ; BC = days_of_current_month (16bit) + dad b ; Add to HL days_of_current_month (BC) + lda RTCMONTH ; A = current_month + dcr a ; A = Number_of_months_before_current + jrz checkCurrYear ; Jump if Number_of_months_before_current = 0 + ; + ; Add days of all previous months of current year, starting with January + lxi b, MONTHTAB ; BC -> days_of_month (starting from Jan) +addDays: + push a ; Save A = Number_of_months_before_current + ldax b ; A = days_of_month (month pointed by BC) + mov e, a ; DE = days of month (16bit) + dad d ; Add it to HL + inx b ; BC -> next month + pop a + dcr a ; There is an other month? + jrnz addDays ; Jump if there is an other month to compute + ; + ; If current year is a leap year and current month is > February add one day + ; to HL +checkCurrYear: + lda RTCMONTH + cpi 3 ; Current month < March? + jrc TIMEend ; Jump if yes + lda RTCYEAR ; No, check if current year is leap + mov b, a ; A = B = current year + srlr a ; / 2 + srlr a ; / 4 + slar a ; * 2 + slar a ; * 4 + cmp b ; A = B if A is leap + jrnz TIMEend ; Jump if not leap + inx h ; Add 1 to HL +TIMEend: + ; + ; All done, store days from 31-12-1977 to now into @DATE + shld @DATE ; Store the date in days from CP/M epoch + pop h + pop d + pop b + ret + +MONTHTAB: + DB 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30 ; Only Jan-Nov needed + +; Multiply 16-bit values (with 16-bit result) +; In: Multiply BC with DE +; Out: HL = result +; +Mult16: + mov a, b + mvi b, 16 +Mult16Loop: + dad h + slar c + ral + jrnc Mult16NoAdd + dad d +Mult16NoAdd: + djnz Mult16Loop + ret + +; BIN to BCD conversion +; a(BIN) => a(BCD) +; [0..99] => [00h..99h] +; +bin2bcd: + push b + mvi b,10 + mvi c,-1 +div10: + inr c + sub b + jrnc div10 + add b + mov b, a + mov a, c + add a + add a + add a + add a + ora b + pop b + ret + +RTCBUFF: ; Buffer for the RTC data (binary) + DB 1 ; Seconds [0..59] + DB 1 ; Minutes [0..59] + DB 1 ; Hours [0..23] +RTCDAY; + DB 1 ; Day [1..31] +RTCMONTH: + DB 1 ; Month [1..12] +RTCYEAR: + DB 1 ; Year [0..99] + +; -------------------------------------------------------------------------------- + + IF BANKED + ; -------------------------- + CSEG + ; -------------------------- + ENDIF + + ; CP/M BDOS FUNCTION INTERFACES + + ; OPEN FILE: +OPEN: + MVI C,15 ! JMP BDOS ; OPEN FILE CONTROL BLOCK + + ; SET DMA ADDRESS: +SETDMA: + MVI C,26 ! JMP BDOS ; SET DATA TRANSFER ADDRESS + + ; SET MULTI SECTOR I/O COUNT: +SETMULTI: + MVI C,44 ! JMP BDOS ; SET RECORD COUNT + + ; READ FILE RECORD: +READ: + MVI C,20 ! JMP BDOS ; READ RECORDS + + ; CCP NOT FOUND ERROR MESSAGE: +CCP$MSG: + DB CR,LF,'BIOS ERR ON A: NO CCP.COM FILE',0 + + + ; FCB FOR CCP.COM FILE LOADING: +CCP$FCB: + DB 1 ;AUTO-SELECT DRIVE A + DB 'CCP COM' ;FILE NAME AND TYPE + DB 0,0,0,0 + DS 16 +FCB$NR: DB 0,0,0 + + ; SYSTEM SIGN-ON MESSAGE: +SIGNON$MSG: + DB CR,LF,'Z80-MBC2 128KB ' + DB '(Banked) CP/M V3.0' + DB CR,LF,'Z80-MBC2 BIOS Modules: S200918, S210918-R170319, ' + DB 'S220918-R180319, S290918,', CR,LF,' S170319' + DB CR,LF,LF,0 + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/CHARIO.ASM b/software/CPM/CPM23_PLI/CHARIO.ASM new file mode 100644 index 0000000..ba9a9fa --- /dev/null +++ b/software/CPM/CPM23_PLI/CHARIO.ASM @@ -0,0 +1,469 @@ +;******************************************************************************************** +; +; CHARIO.ASM - S210918-R170319 +; CP/M 3.0 CHARACTER I/O BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R260119 (or following revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; CHANGELOG: +; +; S210918 First release +; S210918-R090319 Changed CIST0: and CI0: to allow full 8 bit data I/O +; S210918-R170319 Added the selection of the mode of CIST0: (7 or 8 bit mode, for XMODEM) +; +; +;******************************************************************************************** + +TITLE 'CP/M 3 MODULE FOR CHARACTER I/O HANDLING - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT: +BANKED EQU FALSE ; <------ BANKED/NON-BANKED SWITCH + +; ------------------------------------------------------------------- +; +; >>>>>>>>>>>>>> READ CAREFULLY <<<<<<<<<<<<<< +; +; To prevent the CHARIO.ASM bank swiching IOS requests from +; interfering with user program IOS request if using +; "slow" interpreters as e.g. MBASIC.COM, I've decided to avoid +; bank switching here. This is a simple solution to avoid more +; complex one. For this reason the "BANKED" switch is intentionally +; set at "FALSE" (although the system is banked) +; +; ------------------------------------------------------------------- + + + ; DEFINE PUBLIC LABELS: + PUBLIC ?CINIT,?CI,?CO,?CIST,?COST + PUBLIC @CTBL + PUBLIC ?cnstFlg ; CONST mode flag (Z80-MBC2) *** + + ; DEFINE EXTERNAL LABELS AND ENTRY POINTS: + IF BANKED + EXTRN @CBNK + EXTRN ?BNKSL + ENDIF + EXTRN OUT$BLOCKS ; BLOCK OUTPUT ROUTINE TO I/O PORTS + EXTRN ?PMSG + + ; INCLUDE Z-80 MACROS: + + MACLIB Z80 + + ; EQUATES FOR MODE BYTE BIT FIELDS + +MB$INPUT EQU 0000$0001B ; DEVICE MAY DO INPUT +MB$OUTPUT EQU 0000$0010B ; DEVICE MAY DO OUTPUT +MB$IN$OUT EQU MB$INPUT+MB$OUTPUT + +MB$SOFT$BAUD EQU 0000$0100B ; SOFTWARE SELECTABLE BAUD RATES + +MB$SERIAL EQU 0000$1000B ; DEVICE MAY USE PROTOCOL +MB$XON$XOFF EQU 0001$0000B ; XON/XOFF PROTOCOL ENABLED + +BAUD$NONE EQU 0 ; NO BAUD RATE ASSOCIATED WITH THIS DEVICE +BAUD$50 EQU 1 ; 50 BAUD +BAUD$75 EQU 2 ; 75 BAUD +BAUD$110 EQU 3 ; 110 BAUD +BAUD$134 EQU 4 ; 134.5 BAUD +BAUD$150 EQU 5 ; 150 BAUD +BAUD$300 EQU 6 ; 300 BAUD +BAUD$600 EQU 7 ; 600 BAUD +BAUD$1200 EQU 8 ; 1200 BAUD +BAUD$1800 EQU 9 ; 1800 BAUD +BAUD$2400 EQU 10 ; 2400 BAUD +BAUD$3600 EQU 11 ; 3600 BAUD +BAUD$4800 EQU 12 ; 4800 BAUD +BAUD$7200 EQU 13 ; 7200 BAUD +BAUD$9600 EQU 14 ; 9600 BAUD +BAUD$19200 EQU 15 ; 19.2K BAUD + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; WILL START OFF IN COMMON MEMORY FOR BANKED OR NON-BANKED SYSTEMS: + ; -------------------------- + CSEG + ; -------------------------- + + + IF BANKED + ; WE PROVIDE ALTERNATE DEFINITIONS OF THE ROUTINE ENTRY POINTS IF + ; WE ARE RUNNING A BANKED SYSTEM VERSUS A NON-BANKED SYSTEM: + + ;;;;; ?CINIT + ; ENTER HERE FOR BANKED SYSTEMS FOR DEVICE INITIALIZATIONS: +?CINIT: + LXI H,BCINIT ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CI + ; ENTER HERE FOR BANKED SYSTEM DEVICE INPUT: +?CI: LXI H,BCI ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CO + ; ENTER HERE FOR BANKED SYSTEM DEVICE OUTPUT: +?CO: LXI H,BCO ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CIST + ; ENTER HERE FOR BANKED SYSTEM DEVICE INPUT STATUS: +?CIST: LXI H,BCIST ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?COST + ; ENTER HERE FOR BANKED SYSTEM DEVICE OUTPUT STATUS: +?COST: LXI H,BCOST ;POINT TO BANKED ROUTINE ADDRESS + + + ;;;;; BANKIO + ; ROUTINE DISPATCHES TO BANKED PORTION OF CHARACTER I/O ROUTINES: +BANKIO: + SSPD SPSAVE ;SAVE CURRENT STACK POINTER + LXI SP,IOSP ; AND USE LOCAL STACK FOR I/O + LDA @CBNK ;GET CURRENT BANK + PUSH PSW ;SAVE ON LOCAL STACK + XRA A ;WE WILL SELECT BANK 0 (OP SYS) + CALL ?BNKSL + LXI D,BIORET ;RETURN ADDRESS IN [DE] + PUSH D ;PUT IT ON STACK FOR RETURN + PCHL ;DISPATCH TO BANKED PART OF ROUTINE + + ; ARRIVE HERE AFTER DEVICE HANDLER FINISHED: +BIORET: + POP D ;GET PREVIOUS CURRENT BANK TO [D] + PUSH PSW ;SAVE HANDLER RETURNED RESULT (IF ANY) + MOV A,D ;RESELECT PREVIOUS CURRENT BANK + CALL ?BNKSL + POP PSW ;GET BACK RESULT CODE TO [A] + LSPD SPSAVE ;RESTORE PREVIOUS STACK + RET ;AND RETURN... + ENDIF + + + ;;;;; + ;;;;; ACTUAL DEVICE HANDLERS + ;;;;; + + + ;;;;; ?CINIT (BCINIT FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INITIALIZATION: + IF BANKED + ; -------------------------- + DSEG ;CAN PUT IN BANKED SEGMENT IF BANKED + ; -------------------------- +BCINIT: + ELSE +?CINIT: + ENDIF + MOV B,C ;ON ENTRY DEVICE # IS IN [C] BUT WE NEED + ; IT IN [B] + CALL DEV$DISPATCH ;GO TO CORRECT INIT ROUTINE + DW CINIT0 ;INIT FOR DEVICE 0 + DW NULL$INIT ;INIT FOR DEVICE 1 + DW NULL$INIT ;INIT FOR DEVICE 2 + DW NULL$INIT ;INIT FOR DEVICE 3 + DW NULL$INIT ;INIT FOR DEVICE 4 + DW NULL$INIT ;INIT FOR DEVICE 5 + DW NULL$INIT ;INIT FOR DEVICE 6 + DW NULL$INIT ;INIT FOR DEVICE 7 + DW NULL$INIT ;INIT FOR DEVICE 8 + DW NULL$INIT ;INIT FOR DEVICE 9 + DW NULL$INIT ;INIT FOR DEVICE 10 + DW NULL$INIT ;INIT FOR DEVICE 11 + DW NULL$INIT ;INIT FOR DEVICE 12 + DW NULL$INIT ;INIT FOR DEVICE 13 + DW NULL$INIT ;INIT FOR DEVICE 14 + DW NULL$INIT ;INIT FOR DEVICE 15 + + + ;;;;; ?CI (BCI FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INPUT: + IF BANKED +BCI: + ELSE +?CI: + ENDIF + CALL DEV$DISPATCH + DW CI0 ;DEVICE 0 INPUT + DW NULL$CI ;DEVICE 1 INPUT + DW NULL$CI ;DEVICE 2 INPUT + DW NULL$CI ;DEVICE 3 INPUT + DW NULL$CI ;DEVICE 4 INPUT + DW NULL$CI ;DEVICE 5 INPUT + DW NULL$CI ;DEVICE 6 INPUT + DW NULL$CI ;DEVICE 7 INPUT + DW NULL$CI ;DEVICE 8 INPUT + DW NULL$CI ;DEVICE 9 INPUT + DW NULL$CI ;DEVICE 10 INPUT + DW NULL$CI ;DEVICE 11 INPUT + DW NULL$CI ;DEVICE 12 INPUT + DW NULL$CI ;DEVICE 13 INPUT + DW NULL$CI ;DEVICE 14 INPUT + DW NULL$CI ;DEVICE 15 INPUT + + + ;;;;; ?CO (BCO FOR BANKED) + ; PHYSICAL CODE FOR DEVICE OUTPUT: + IF BANKED +BCO: + ELSE +?CO: + ENDIF + CALL DEV$DISPATCH ;GO TO CORRECT DEVICE OUTPUT HANDLER + DW CO0 ;DEVICE 0 OUTPUT + DW NULL$CO ;DEVICE 1 OUTPUT + DW NULL$CO ;DEVICE 2 OUTPUT + DW NULL$CO ;DEVICE 3 OUTPUT + DW NULL$CO ;DEVICE 4 OUTPUT + DW NULL$CO ;DEVICE 5 OUTPUT + DW NULL$CO ;DEVICE 6 OUTPUT + DW NULL$CO ;DEVICE 7 OUTPUT + DW NULL$CO ;DEVICE 8 OUTPUT + DW NULL$CO ;DEVICE 9 OUTPUT + DW NULL$CO ;DEVICE 10 OUTPUT + DW NULL$CO ;DEVICE 11 OUTPUT + DW NULL$CO ;DEVICE 12 OUTPUT + DW NULL$CO ;DEVICE 13 OUTPUT + DW NULL$CO ;DEVICE 14 OUTPUT + DW NULL$CO ;DEVICE 15 OUTPUT + + + ;;;;; ?CIST (BCIST FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INPUT STATUS: + IF BANKED +BCIST: + ELSE +?CIST: + ENDIF + CALL DEV$DISPATCH + DW CIST0 ;DEVICE 0 INPUT STATUS + DW NULL$CIST ;DEVICE 1 INPUT STATUS + DW NULL$CIST ;DEVICE 2 INPUT STATUS + DW NULL$CIST ;DEVICE 3 INPUT STATUS + DW NULL$CIST ;DEVICE 4 INPUT STATUS + DW NULL$CIST ;DEVICE 5 INPUT STATUS + DW NULL$CIST ;DEVICE 6 INPUT STATUS + DW NULL$CIST ;DEVICE 7 INPUT STATUS + DW NULL$CIST ;DEVICE 8 INPUT STATUS + DW NULL$CIST ;DEVICE 9 INPUT STATUS + DW NULL$CIST ;DEVICE 10 INPUT STATUS + DW NULL$CIST ;DEVICE 11 INPUT STATUS + DW NULL$CIST ;DEVICE 12 INPUT STATUS + DW NULL$CIST ;DEVICE 13 INPUT STATUS + DW NULL$CIST ;DEVICE 14 INPUT STATUS + DW NULL$CIST ;DEVICE 15 INPUT STATUS + + + ;;;;; ?COST (BCOST FOR BANKED) + ; PHYSICAL CODE FOR DEVICE OUTPUT STATUS: + IF BANKED +BCOST: + ELSE +?COST: + ENDIF + CALL DEV$DISPATCH ;GO TO CONSOLE OUTPUT STATUS HANDLER + DW COST0 ;DEVICE 0 OUTPUT STATUS + DW NULL$COST ;DEVICE 1 OUTPUT STATUS + DW NULL$COST ;DEVICE 2 OUTPUT STATUS + DW NULL$COST ;DEVICE 3 OUTPUT STATUS + DW NULL$COST ;DEVICE 4 OUTPUT STATUS + DW NULL$COST ;DEVICE 5 OUTPUT STATUS + DW NULL$COST ;DEVICE 6 OUTPUT STATUS + DW NULL$COST ;DEVICE 7 OUTPUT STATUS + DW NULL$COST ;DEVICE 8 OUTPUT STATUS + DW NULL$COST ;DEVICE 9 OUTPUT STATUS + DW NULL$COST ;DEVICE 10 OUTPUT STATUS + DW NULL$COST ;DEVICE 11 OUTPUT STATUS + DW NULL$COST ;DEVICE 12 OUTPUT STATUS + DW NULL$COST ;DEVICE 13 OUTPUT STATUS + DW NULL$COST ;DEVICE 14 OUTPUT STATUS + DW NULL$COST ;DEVICE 15 OUTPUT STATUS + + + ;;;;; DEV$DISPATCH + ; ROUTINE JUMPS TO CORRECT DEVICE HANDLER: +DEV$DISPATCH: + MOV A,B ;GET DEVICE # TO [A] + STA DEV$CODE ;SAVE FOR LATER USE + ADD A ;X2 FOR WORD OFFSET + POP H ;RETURN ADDRESS IS 1ST PARAMETER ADDRESS + MOV E,A ;SET UP OFFSET IN [DE] + MVI D,0 + DAD D ;[HL] = PTR TO HANDLER ADDRESS + MOV E,M ;GET HANDLER ADDRESS TO [DE] + INX H + MOV D,M + XCHG ;PUT IN [HL] + PCHL ;AND DISPATCH TO IT... + + + ;;;;; + ;;;;; PHYSICAL DEVICE HANDLER CODE: + ;;;;; + +; ---------------------------------------------------------- +; +; Z80-MBC2 I/O +; +; ---------------------------------------------------------- + + +CINIT0: ; DEVICE 0 INITIALIZATION (Z80-MBC2) + RET ; Nothing to do + +; +;<<<<<<<<<<<<<<<<<<< MAIN CONSOLE STATUS ROUTINE (Z80-MBC2) >>>>>>>>>>>>>>>>>>>>>> +; + + +CIST0: ; DEVICE 0 INPUT STATUS + lda ?cnstFlg ; A = CONST mode flag + ora a ; CONST mode flag = 0? + jrz CONST7 ; Yes, jump to 7 bit CONST routine +CONST8: ; No, 8 bit mode CONST routine + mvi a, SYSFLAG$OPC ; A = SYSFLAG opcode + out STO$OPCD ; Write the opcode + in EXC$RD$OPCD ; Read SYSFLAG data into A + ani 04H ; Rx serial buffer empty (D2 = 0)? + jrz NoInChr ; Yes, jump + ; No, set char ready flag + +InChr: ; Set char ready flag + mvi a, 0ffH ; Return CP/M a char ready flag ($FF) + ret + +CONST7: + lda InChrBuf ; A = previous char read by CONST, if any + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrnz InChr ; No, jump (char already read and ready) + in SERIAL$RX ; Yes, Read a char from "virtual" UART + sta InChrBuf ; Store it + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrnz InChr ; No, set char ready flag + ; Yes, set char not ready flag + +NoInChr: ; Set char not ready flag + xra a ; Set no char flag (A = 0) + ret ; Return CP/M no char flag ($00) + +InChrBuf: ; Last read char by CONST ($FF = no char) + db 0ffH ; Initialized as $FF +?cnstFlg: + db 0H ; CONST mode flag. If = 1 the full 8 bit mode is active, + ; if = 0 the "legacy" 7 bit mode is used (not really 7 bit + ; but only the $ff char is ignored and used as "no char" flag *** + +COST0: ; DEVICE 0 OUTPUT STATUS (Z80-MBC2) + mvi a, 0ffH ; Always ready to TX + ret + +; +;<<<<<<<<<<<<<<<<<<<< MAIN CONSOLE INPUT ROUTINE (Z80-MBC2) >>>>>>>>>>>>>>>>>>>> +; + +CI0: ;DEVICE 0 INPUT + lda InChrBuf ; A = previous char read by CONST, if any + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrz GetChr ; Yes, jump to read a char + push psw ; No, InChrBuf = $FF (clear buffer) + mvi a, 0ffH + sta InChrBuf + pop psw ; Return with the previously saved char + ret + +GetChr: + in SERIAL$RX ; Read a char from UART + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + rnz ; No, retun with it in A + ; Yes, check if ffH is a valid char + +ChkFF: ; Check if ffH is a valid char + mvi a, SYSFLAG$OPC ; A = SYSFLAG opcode + out STO$OPCD ; Write the opcode + in EXC$RD$OPCD ; Read SYSFLAG data into A + ani 08H ; It was a "serial buffer empty" flag (D3 = 1)? + jrnz GetChr ; Yes, jump and wait for a char + mvi a, 0ffH ; No, it is a valid ffH char + ret ; Retun with it in A + + +; +;<<<<<<<<<<<<<<<<<<<<<< MAIN CONSOLE OUTPUT ROUTINE (Z80-MBC2) >>>>>>>>>>>>>>>>>>>>>>>>> +; + +CO0: ; DEVICE 0 OUTPUT + mvi a, SERTX$OPC ; A = SERIAL TX opcode + out STO$OPCD ; Write the opcode + mov a, c + out EXC$WR$OPCD ; Send A to serial Tx + ret + +; +; ------------------------------------------------------------------------- +; + + ;;;;; NULL ROUTINES: +NULL$CIST: +NULL$COST: + XRA A ;RETURN A FALSE STATUS RESULT + JR NULL$RET +NULL$CI: + MVI A,1AH ;FOR INPUT RETURN A CNTL-Z (EOF) +NULL$INIT: +NULL$CO: +NULL$RET: + RET ;HARMLESS RETURN + + + ; STORAGE FOR DEVICE CODE -- CAN RESIDE IN SAME SEGMENT AS THE BULK + ; OF CHARACTER I/O ROUTINES: +DEV$CODE: DS 1 + + ;;;;; CHRTBL + ; CHARACTER DEVICE TABLE + ; -------------------------- + CSEG ;MUST RESIDE IN COMMON MEMORY + ; -------------------------- + +@CTBL: + DB 'CRT ' ;CONSOLE (DEVICE 0) + DB MB$IN$OUT + DB BAUD$NONE + +MAX$DEVICES EQU ($-@CTBL)/8 ;# DEVICES IN TABLE + DB 0 ;TABLE TERMINATOR + + + ; OTHER DATA AREAS: + DS 24 ;CHARACTER I/O LOCAL STACK +IOSP EQU $ +SPSAVE DS 2 + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/LDRBIOS.ASM b/software/CPM/CPM23_PLI/LDRBIOS.ASM new file mode 100644 index 0000000..075e4cf --- /dev/null +++ b/software/CPM/CPM23_PLI/LDRBIOS.ASM @@ -0,0 +1,361 @@ +;******************************************************************************************** +; +; LRDBIOS.ASM - S180918 +; CP/M 3.0 CPMLDR BIOS FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +; +;******************************************************************************************** + + +TRUE EQU -1 ; DEFINE LOGICAL VALUES: +FALSE EQU NOT TRUE + +BELL EQU 07H +eos EQU 00H ; End of string +CR EQU 0DH +LF EQU 0AH + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + +; INCLUDE CP/M 3.0 MACRO LIBRARY: + + MACLIB CPM3 + MACLIB Z80 + +;-------------------------------------------------------------------------- +; CODE BEGINS HERE: +;-------------------------------------------------------------------------- + + JMP BOOT ;<----- INITIAL ENTRY ON COLD START + JMP WBOOT ;REENTRY ON PROGRAM EXIT, WARM START + JMP CONST ;RETURN CONSOLE INPUT STATUS + JMP CONIN ;RETURN CONSOLE INPUT CHARACTER + JMP CONOUT ;<------------ SEND CONSOLE OUTPUT CHARACTER + JMP LIST ;SEND LIST OUTPUT CHARACTER + JMP AUXOUT ;SEND AUXILLIARY OUTPUT CHARACTER + JMP AUXIN ;RETURN AUXILLIARY INPUT CHARACTER + JMP HOME ;SET DISKS TO LOGICAL HOME + JMP SELDSK ;SELECT DISK DRIVE RETURN DISK PARAMETER INFO + JMP SETTRK ;SET DISK TRACK + JMP SETSEC ;SET DISK SECTOR + JMP SETDMA ;SET DISK I/O MEMORY ADDRESS + JMP READ ;<----------- READ PHYSICAL BLOCK(S) + JMP WRITE ;WRITE PHYSICAL BLOCK(S) + JMP LISTST ;RETURN LIST DEVICE STATUS + JMP SECTRN ;TRANSLATE LOGICAL TO PHYSICAL SECTOR + JMP CONOST ;RETURN CONSOLE OUTPUT STATUS + JMP AUXIST ;RETURN AUXILLIARY INPUT STATUS + JMP AUXOST ;RETURN AUXILLIARY OUTPUT STATUS + JMP DEVTBL ;RETURN ADDRESS OF DEVICE DEFINITION TABLE + JMP ?CINIT ;CHANGE BAUD RATE OF DEVICE + JMP GETDRV ;RETURN ADDRESS OF DISK DRIVE TABLE + JMP MULTIO ;SET MULTIPLE RECORD COUNT FOR DISK I/O + JMP FLUSH ;FLUSH BIOS MAINTAINED DISK CACHING + JMP ?MOVE ;BLOCK MOVE MEMORY TO MEMORY + JMP ?TIME ;SIGNAL TIME AND DATE OPERATION + JMP BNKSEL ;SEL BANK FOR CODE EXECUTION AND DEFAULT DMA + JMP SETBNK ;SELECT DIFFERENT BANK FOR DISK I/O DMA OPS. + JMP ?XMOVE ;SET SOURCE AND DEST. BANKS FOR ONE OPERATION + JMP 0 ;RESERVED FOR FUTURE EXPANSION + JMP 0 ; DITTO + JMP 0 ; DITTO + + +CONST: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +LISTST: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +AUXIST: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +AUXOST: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +FLUSH: + XRA A ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + RET ; RETURN A FALSE STATUS + +LIST: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +AUXOUT: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +DEVTBL: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +?CINIT: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +MULTIO: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +?TIME: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +BNKSEL: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +SETBNK: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +?XMOVE: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +CONIN: + MVI A,'Z'-40H ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + RET + +AUXIN: + MVI A,'Z'-40H ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + RET + +CONOUT: + ; Write Console Character out. Output char is in C + mvi a, SERTX$OPC ; A = SERIAL TX opcode + out STO$OPCD ; Write the opcode + mov a, c + out EXC$WR$OPCD ; Send A to serial Tx + ret + +CONOST: + ; Return Output Status of Console. Return A=00H if not ready, A=0FFH if ready + mvi a, 0FFH ; Always ready + ret + +?MOVE: + XCHG + LDIR + XCHG + RET + +SELDSK: + LXI H,DPH0 ; RETURN DPH ADDRESS FOR DRIVE A: + RET + +HOME: + LXI B,0 ; HOME SELECTED DRIVE -- TREAT AS SETTRK(0): + +SETTRK: + SBCD @TRK ; ROUTINE SETS TRACK TO ACCESS ON NEXT READ + RET + +SETSEC: + SBCD @SECT ; ROUTINE SETS SECTOR TO ACCESS ON NEXT READ + RET + +SETDMA: + SBCD @DMA ; ROUTINE SETS DISK MEMORY ADDRESS FOR READ + RET + +SECTRN: + MOV L,C ; NO TRANSLATION FOR HDISK + MOV H,B + RET + +GETDRV: + LXI H,@DTBL ; RETURN ADDRESS OF DISK DRIVE TABLE: + RET + +DCBINIT: + RET ; ROUTINE HAS NO FUNCTION IN LOADER BIOS: + +WRITE: + XRA A ; RETURN GOOD RESULT CODE + RET + +WBOOT: + RET ; WARM BOOT IS NOT USED IN LOADER BIOS + +;-------------------------------------------------------------------------- +; BOOT +; ROUTINE DOES COLD BOOT INITIALIZATION: +;-------------------------------------------------------------------------- + + +BOOT: + lxi h, BiosMsg ; Print a message + call puts + RET + +;-------------------------------------------------------------------------------- +; HARD DISK READ A SECTOR AT @TRK, @SECT TO Address at @DMA +; Return A=00H if no Error, A=01H if Non-recov Err +;-------------------------------------------------------------------------------- + +READ: + push b + push h + ; + ; Select host disk 0 + lda lastDsk ; A = last disk number + ora a ; Set Z flag. Last disk = 0? + jrz setTrack ; Yes, jump to track selection + mvi a, SELDISK$OPC ; No, select SELDISK opcode (IOS) + out STO$OPCD + xra a ; Select the disk 0 + out EXC$WR$OPCD + sta lastDsk ; Update last disk number + ; + ; Select @TRK host track +setTrack: + mvi a, SELTRCK$OPC ; Select SELTRACK opcode (IOS) + out STO$OPCD + lda @TRK ; Select the track number LSB + out EXC$WR$OPCD + lda @TRK + 1 ; Select the track number MSB + out EXC$WR$OPCD + ; + ; Select @SECT host sector + mvi a, SELSECT$OPC ; Select SELSECT opcode (IOS) + out STO$OPCD + lda @SECT ; Select the sector number (LSB only) + out EXC$WR$OPCD + ; + ; Read current host sector (512 byte) to DMA + mvi c, EXC$RD$OPCD ; Set the EXECUTE READ OPCODE port into C + lhld @DMA ; HL = DMA address + mvi a, RDSECT$OPC ; Select READSECT opcode (IOS) + out STO$OPCD + mvi b, 0 ; Byte counter = 256 + inir ; Read 256 byte to hstbuf + inir ; Read 256 byte to hstbuf + ; + ; Check for errors + mvi a, ERRDSK$OPC ; Select ERRDISK opcode (IOS) + out STO$OPCD + in EXC$RD$OPCD ; Read error code into A + ora a ; Set Z flag + pop h + pop b + rz ; Return with A = 0 (no error) + mvi a, 1 ; Set error code + ret ; Return with A = 1 (read error) + +lastDsk: DB 0ffH ; Last disk number (= ff after cold boot) + + +;============================================================================= +; Z80-MBC2 SUPPORT ROUTINES +;============================================================================= + +; ---------------------------------------------------------------------------- ; +; +; Send a string to the serial line, HL holds the pointer to the string. +; NOTE: Only A and HL are used +; +; ---------------------------------------------------------------------------- ; + +puts + mov a, m ; A = (HL) = current char to print + cpi eos ; End of string reached? + rz ; Yes, return + mvi a, SERTX$OPC ; A = SERIAL TX opcode + out STO$OPCD ; Write the opcode + mov a, m ; A = (HL) = current char to print + out EXC$WR$OPCD ; Print A + inx h ; Increment character pointer + jr puts ; Transmit next character + + +; --------------------------------------------------------------------------- ; +; +; MESSAGES +; +; --------------------------------------------------------------------------- ; + +BiosMsg db CR, LF, LF, 'Z80-MBC2 CPMLDR BIOS - S180918', CR, LF, eos + +@TRK: DS 2 ;2 BYTES FOR NEXT TRACK TO READ OR WRITE +@DMA: DS 2 ;2 BYTES FOR NEXT DMA ADDRESS +@SECT DS 2 ;2 BYTES FOR SECTOR + + +;-------------------------------------------------------- +; BUILD CPM3 DPH'S ETC USING MACROS FOR HDISK AND BY HAND +;-------------------------------------------------------- + + ; DISK DRIVE TABLE: +@DTBL: DW DPH0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + + ; DRIVE A DISK PARAMETER HEADER: + DW WRITE ;WRITE ROUTINE + DW READ ;READ ROUTINE + DW SELDSK ;LOGIN PROCEDURE + DW DCBINIT ;DRIVE INITIALIZATION ROUTINE + DB 0 ;RELATIVE DRIVE 0 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE ALWAYS KNOWN FOR HARD DISK +DPH0: DW 0 ;TRANSLATION VECTOR + DB 0,0,0,0,0,0,0,0,0 + DB 0 ;MEDIA FLAG + DW HD$DPB ;ADDRESS OF DISK PARAMETER BLOCK + DW CSV ;CHECKSUM VECTOR + DW ALV ;ALLOCATION VECTOR + DW DIRBCB ;DIRECTORY BUFFER CONTROL BLOCK + DW DATABCB ;DATA BUFFER CONTROL BLOCK + DW 0FFFFH ;NO HASHING + DB 0 ;HASH BANK + + ; HARD DISK PARAMETER BLOCK: + ; Bytes per sector, num sec, num trk, block size, dir entries, res trk, HD flag + +HD$DPB: DPB 512,32,512,4096,512,1,8000H + + ; DIRECTORY BUFFER CONTROL BLOCK: +DIRBCB: + DB 0FFH ;DRIVE 0 + DS 3 + DS 1 + DS 1 + DS 2 + DS 2 + DW DIRBUF ;POINTER TO DIRECTORY BUFFER + + ; DATA BUFFER CONTROL BLOCK: +DATABCB: + DB 0FFH ;DRIVE 0 + DS 3 + DS 1 + DS 1 + DS 2 + DS 2 + DW DATABUF ;POINTER TO DATA BUFFER + + + ; DIRECTORY BUFFER +DIRBUF: DS 512 ;1 PHYSICAL SECTOR + + ; DATA BUFFER: +DATABUF:DS 512 ;1 PHYSICAL SECTOR + + ; DRIVE ALLOCATION VECTOR: +ALV: DS 1000 ;SPACE FOR DOUBLE BIT ALLOCATION VECTORS +CSV: ;NO CHECKSUM VECTOR REQUIRED FOR A HDISK + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/MOVE.ASM b/software/CPM/CPM23_PLI/MOVE.ASM new file mode 100644 index 0000000..6aba887 --- /dev/null +++ b/software/CPM/CPM23_PLI/MOVE.ASM @@ -0,0 +1,89 @@ +;******************************************************************************************** +; +; MOVE.ASM - S290918 +; CP/M 3.0 BANK & MOVE BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +;******************************************************************************************** + + title 'bank & move module for CP/M3 linked BIOS' + + ; DEFINE LOGICAL VALUES +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT +BANKED EQU TRUE ; <------ BANKED/NON-BANKED SWITCH + + ; LOCATE CODE IN THE COMMON SEGMENT: + ; -------------------------- + CSEG + ; -------------------------- + + ; DEFINE PUBLIC LABELS + public ?move,?xmove,?bank + + ; EXTERNALLY DEFINED ENTRY POINTS AND LABELS + extrn @cbnk + + ; INCLUDE Z-80 MACROS + maclib z80 + ;maclib ports + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SETBANK$OPC EQU 00DH ; SETBANK opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; ROUTINE SETS UP AN INTER-BANK MOVE OF 128 BYTES ON THE NEXT CALL + ; TO ?MOVE +?xmove: ; Interbank moves not implemented + ret + + + ; ROUTINE PERFORMS INTRA-BANK MOVES IF ?XMOVE WAS NOT CALLED PRIOR TO + ; THIS CALL TO ?MOVE ELSE A 128 BYTE TRANSFER IS CONDUCTED BETWEEN + ; DIFFERENT BANKS +?move: + xchg ; we are passed source in DE and dest in HL + ldir ; use Z80 block move instruction + xchg ; need next addresses in same regs + ret + + + ; ROUTINE SWITCHES IN PHYSICAL BANK. + ; ?BANK is called with the bank address in register A. This bank address has already been + ; stored in @CBNK for future reference. All registers except A must be maintained upon return. +?bank: + IF BANKED + push psw ; Save requested bank + mvi a, SETBANK$OPC ; Select the SETBANK opcode + out STO$OPCD + pop psw ; A = bank number [0..2] + out EXC$WR$OPCD ; Select it + ENDIF + ret + + end \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/O1BOOT.ASM b/software/CPM/CPM23_PLI/O1BOOT.ASM new file mode 100644 index 0000000..c599511 --- /dev/null +++ b/software/CPM/CPM23_PLI/O1BOOT.ASM @@ -0,0 +1,374 @@ +;******************************************************************************************** +; +; BOOT.ASM - S220918 +; CP/M 3.0 BOOT LOADER BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +; CHANGELOG: +; +; S220918 First release +; S220918-R090319 Changed system sign-on message +; +;******************************************************************************************** + + TITLE 'BOOT LOADER MODULE FOR CP/M 3.0 - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT: +BANKED EQU TRUE ; <------ BANKED/NON-BANKED SWITCH + + ; DEFINE PUBLIC LABELS: + PUBLIC ?INIT,?LDCCP,?RLCCP,?TIME + ;PUBLIC OUT$BLOCKS + + ; EXTERNALLY DEFINED ENTRY POINTS AND LABELS: + EXTRN ?PMSG,?CONIN + EXTRN @CIVEC,@COVEC,@AIVEC,@AOVEC,@LOVEC + EXTRN @CBNK,?BNKSL + EXTRN @SEC,@MIN,@HOUR,@DATE ;FIELDS HOLDING CURRENT TIME AND DATE + + ; INCLUDE Z-80 MACROS: + MACLIB Z80 + + ; SOME MISCELLANEOUS EQUATES: +BDOS EQU 5 +CR EQU 13 ; ASCII CARRIAGE RETURN +LF EQU 10 ; ASCII LINEFEED + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; WE CAN DO INITIALIZATION FROM BANKED MEMORY (IF WE HAVE IT): + IF BANKED + ; -------------------------- + DSEG ; INIT DONE FROM BANKED MEMORY + ; -------------------------- + ELSE + ; -------------------------- + CSEG ; INIT TO BE DONE FROM COMMON MEMORY + ; -------------------------- + ENDIF + + ; HARDWARE INITIALIZATION OTHER THAN CHARACTER AND DISK I/O + +?INIT: + ; ASSIGN CONSOLE INPUT AND OUTPUT TO CRT: + LXI H,8000H ;SIGNIFIES DEVICE 0 + SHLD @CIVEC ;CONSOLE INPUT VECTOR + SHLD @COVEC ;CONSOLE OUTPUT VECTOR + + ; PRINT THE SIGN-ON MESSAGE: + LXI H,SIGNON$MSG ;POINT TO IT + JMP ?PMSG ;AND PRINT IT + ; Note: "RET" here is not needed because we use the that one at the end of ?PMSG + + IF BANKED + ; -------------------------- + CSEG + ; -------------------------- + ENDIF + + ; THIS ROUTINE IS ENTERED TO LOAD THE CCP.COM FILE INTO THE TPA BANK + ; AT SYSTEM COLD START + +?LDCCP: + ; SET UP THE FCB FOR THE FILE OPERATION + ; NOTE: If banked at this point bank 1 is alredy selected + ; (see BIOSKRNL.ASM) + XRA A ;ZERO EXTENT + STA CCP$FCB+15 + LXI H,0 ;START AT BEGINNING OF FILE + SHLD FCB$NR + + ; TRY TO OPEN THE CCP.COM FILE: + LXI D,CCP$FCB ;POINT TO FCB + CALL OPEN ;ATTEMPT THE OPEN OPERATION + INR A ;WAS IT ON THE DISK ? + JRNZ CCP$FOUND ;YES -- GO LOAD IT + + ; WE ARRIVE HERE WHEN CCP.COM FILE WASN'T FOUND: + LXI H,CCP$MSG ;REPORT THE ERROR + CALL ?PMSG + CALL ?CONIN ;GET A RESPONSE + JR ?LDCCP ;AND TRY AGAIN + + ; FILE WAS OPENED OK -- READ IT IN: +CCP$FOUND: + LXI D,0100H ;LOAD AT BOTTOM OF TPA + CALL SETDMA ;BY SETTING THE NEXT DMA ADDRESS + LXI D,128 ;SET MULTI SECTOR I/O COUNT + CALL SETMULTI ; TO ALLOW UP TO 16K BYTES IN ONE OPERATION + LXI D,CCP$FCB ;POINT TO THE FCB + CALL READ ;AND READ THE CCP IN + RET + + ; ROUTINE RELOADS CCP IMAGE FROM BANK 2 IF BANKED SYSTEM OR FROM THE + ; DISK IF NON-BANKED VERSION + +?RLCCP: + JMP ?LDCCP ;JUST DO LOAD AS THOUGH COLD BOOT + +; -------------------------------------------------------------------------------- +; +; SETS/GETS TIME (Z80-MBC2) +; +; The time of day is kept as four fields. +; @DATE is a binary word containing the number of days since 31 December 1977. +; The bytes @HOUR, @MIN, and @SEC in the System Control Block contain the +; hour, minute, and second in Binary Coded Decimal (BCD) format. +; +; C = Get/Set Flag +; C=000H if get, C=0FFH if set +; (see Appendix J, Table J-1 of CP/M 3 System Guide) +; +; NOTE1: Only the Get function is implemented. +; To change RTC date/time use the IOS "SELECT BOOT MODE OR SYSTEM PARAMETERS" menu. +; NOTE2: Because the IOS RTC year is from 00 to 99 only date from 1-1-2000 to 31-12-2099 +; are valid for this algorithm (I think that it's enough...) +; +; -------------------------------------------------------------------------------- + +?TIME: + ; + ; Check if it is a get time operation + mov a, c + ora a ; Get/Set Flag = 0? + rnz ; Return if it is a Set Time request + ; + ; Check if the RTC module is present + mvi a, SYSFLAG$OPC ; Select SYSFLAG opcode + out STO$OPCD + in EXC$RD$OPCD ; A = SYSFLAG + ani 02h ; Isolate the RTC flag bit + rz ; Return if the RTC is not present + push b + push d + push h + ; + ; Load date/time from the RTC to RTCBUFF + mvi a, DATETIM$OPC ; Select DATETIME opcode + out STO$OPCD + mvi c, EXC$RD$OPCD ; C = EXECUTE READ opcode + lxi h, RTCBUFF ; HL -> RTC Buffer + mvi b, 6 ; Byte counter = 6 + inir ; Read date/time to RTCBUFF + ; + ; Update @SEC (BCD) + lxi b, RTCBUFF ; BC -> RTC seconds + ldax b ; A = RTC seconds (binary) + call bin2bcd ; Binary to BCD + sta @SEC ; Store it into @SEC + ; + ; Update @MIN (BCD) + inx b ; BC -> RTC minutes + ldax b ; A = RTC minutes (binary) + call bin2bcd ; Binary to BCD + sta @MIN ; Store it into @MIN + ; + ; Update @HOUR (BCD) + inx b ; BC -> RTC hours + ldax b ; A = RTC hours (binary) + call bin2bcd ; Binary to BCD + sta @HOUR ; Store it into @HOUR + ; + ; Calculate how many whole years elapsed from 31-12-1977 to now + lda RTCYEAR + adi 22 + mov c, a ; C = elapsed_years = (RTCYEAR) + 22 + ; + ; Convert it in days into HL (16 bit) + xra a ; A = 0 + mov b, a ; B = 0. BC = elapsed_years (16bit) + lxi d, 365 ; DE = 365 + call Mult16 ; HL = elapsed_years * 365 = elapsed_years_days + ; + ; Calculate how many whole leap years elapsed from 31-12-1977 to now + ; (current year excluded) and add it to elapsed_years_days + lda RTCYEAR + ora a + jrz addleapyrs ; If RTCYEAR = 00 -> A = 0 + dcr a ; If RTCYEAR > 00 -> A = (RTRYEAR) - 1 + srlr a ; / 2S + srlr a ; / 4 + inr a ; If RTCYEAR > 00 -> A = (((RTCYEAR) - 1) / 4) + 1 = + ; leap years from 31-12-1999 to now (current year excluded) +addleapyrs: + adi 5 ; Add leap years from 31-12-1977 to 31-12-1999 + mov c, a ; C = elapsed_leap_years = (((RTCYEAR) - 1) / 4) + 1 + 5 + xra a ; A = 0 + mov d, a ; D = 0 + mov b ,a ; B = 0. BC = elapsed_leap_years (16bit) + dad b ; HL = elapsed_years_days + elapsed_leap_years + ; + ; Add days of current month + lda RTCDAY + mov c, a ; BC = days_of_current_month (16bit) + dad b ; Add to HL days_of_current_month (BC) + lda RTCMONTH ; A = current_month + dcr a ; A = Number_of_months_before_current + jrz checkCurrYear ; Jump if Number_of_months_before_current = 0 + ; + ; Add days of all previous months of current year, starting with January + lxi b, MONTHTAB ; BC -> days_of_month (starting from Jan) +addDays: + push a ; Save A = Number_of_months_before_current + ldax b ; A = days_of_month (month pointed by BC) + mov e, a ; DE = days of month (16bit) + dad d ; Add it to HL + inx b ; BC -> next month + pop a + dcr a ; There is an other month? + jrnz addDays ; Jump if there is an other month to compute + ; + ; If current year is a leap year and current month is > February add one day + ; to HL +checkCurrYear: + lda RTCMONTH + cpi 3 ; Current month < March? + jrc TIMEend ; Jump if yes + lda RTCYEAR ; No, check if current year is leap + mov b, a ; A = B = current year + srlr a ; / 2 + srlr a ; / 4 + slar a ; * 2 + slar a ; * 4 + cmp b ; A = B if A is leap + jrnz TIMEend ; Jump if not leap + inx h ; Add 1 to HL +TIMEend: + ; + ; All done, store days from 31-12-1977 to now into @DATE + shld @DATE ; Store the date in days from CP/M epoch + pop h + pop d + pop b + ret + +MONTHTAB: + DB 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30 ; Only Jan-Nov needed + +; Multiply 16-bit values (with 16-bit result) +; In: Multiply BC with DE +; Out: HL = result +; +Mult16: + mov a, b + mvi b, 16 +Mult16Loop: + dad h + slar c + ral + jrnc Mult16NoAdd + dad d +Mult16NoAdd: + djnz Mult16Loop + ret + +; BIN to BCD conversion +; a(BIN) => a(BCD) +; [0..99] => [00h..99h] +; +bin2bcd: + push b + mvi b,10 + mvi c,-1 +div10: + inr c + sub b + jrnc div10 + add b + mov b, a + mov a, c + add a + add a + add a + add a + ora b + pop b + ret + +RTCBUFF: ; Buffer for the RTC data (binary) + DB 1 ; Seconds [0..59] + DB 1 ; Minutes [0..59] + DB 1 ; Hours [0..23] +RTCDAY; + DB 1 ; Day [1..31] +RTCMONTH: + DB 1 ; Month [1..12] +RTCYEAR: + DB 1 ; Year [0..99] + +; -------------------------------------------------------------------------------- + + IF BANKED + ; -------------------------- + CSEG + ; -------------------------- + ENDIF + + ; CP/M BDOS FUNCTION INTERFACES + + ; OPEN FILE: +OPEN: + MVI C,15 ! JMP BDOS ; OPEN FILE CONTROL BLOCK + + ; SET DMA ADDRESS: +SETDMA: + MVI C,26 ! JMP BDOS ; SET DATA TRANSFER ADDRESS + + ; SET MULTI SECTOR I/O COUNT: +SETMULTI: + MVI C,44 ! JMP BDOS ; SET RECORD COUNT + + ; READ FILE RECORD: +READ: + MVI C,20 ! JMP BDOS ; READ RECORDS + + ; CCP NOT FOUND ERROR MESSAGE: +CCP$MSG: + DB CR,LF,'BIOS ERR ON A: NO CCP.COM FILE',0 + + + ; FCB FOR CCP.COM FILE LOADING: +CCP$FCB: + DB 1 ;AUTO-SELECT DRIVE A + DB 'CCP COM' ;FILE NAME AND TYPE + DB 0,0,0,0 + DS 16 +FCB$NR: DB 0,0,0 + + ; SYSTEM SIGN-ON MESSAGE: +SIGNON$MSG: + DB CR,LF,'Z80-MBC2 128KB ' + DB '(Banked) CP/M V3.0' + DB CR,LF,'Z80-MBC2 BIOS Modules: S200918, S210918-R090319,' + DB 'S220918-R090319, S290918' + DB CR,LF,LF,0 + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/O1CHARIO.ASM b/software/CPM/CPM23_PLI/O1CHARIO.ASM new file mode 100644 index 0000000..0a5a43d --- /dev/null +++ b/software/CPM/CPM23_PLI/O1CHARIO.ASM @@ -0,0 +1,433 @@ +;******************************************************************************************** +; +; CHARIO.ASM - S210918-R090319 +; CP/M 3.0 CHARACTER I/O BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R260119 (or following revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; CHANGELOG: +; +; S210918 First release +; S210918-R090319 Changed CIST0: and CI0: to allow full 8 bit data I/O +; +; +;******************************************************************************************** + +TITLE 'CP/M 3 MODULE FOR CHARACTER I/O HANDLING - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT: +BANKED EQU FALSE ; <------ BANKED/NON-BANKED SWITCH + +; ------------------------------------------------------------------- +; +; >>>>>>>>>>>>>> READ CAREFULLY <<<<<<<<<<<<<< +; +; To prevent the CHARIO.ASM bank swiching IOS requests from +; interfering with user program IOS request if using +; "slow" interpreters as e.g. MBASIC.COM, I've decided to avoid +; bank switching here. This is a simple solution to avoid more +; complex one. For this reason the "BANKED" switch is intentionally +; set at "FALSE" (although the system is banked) +; +; ------------------------------------------------------------------- + + + ; DEFINE PUBLIC LABELS: + PUBLIC ?CINIT,?CI,?CO,?CIST,?COST + PUBLIC @CTBL + + ; DEFINE EXTERNAL LABELS AND ENTRY POINTS: + IF BANKED + EXTRN @CBNK + EXTRN ?BNKSL + ENDIF + EXTRN OUT$BLOCKS ;BLOCK OUTPUT ROUTINE TO I/O PORTS + EXTRN ?PMSG + + ; INCLUDE Z-80 MACROS: + + MACLIB Z80 + + ; EQUATES FOR MODE BYTE BIT FIELDS + +MB$INPUT EQU 0000$0001B ; DEVICE MAY DO INPUT +MB$OUTPUT EQU 0000$0010B ; DEVICE MAY DO OUTPUT +MB$IN$OUT EQU MB$INPUT+MB$OUTPUT + +MB$SOFT$BAUD EQU 0000$0100B ; SOFTWARE SELECTABLE BAUD RATES + +MB$SERIAL EQU 0000$1000B ; DEVICE MAY USE PROTOCOL +MB$XON$XOFF EQU 0001$0000B ; XON/XOFF PROTOCOL ENABLED + +BAUD$NONE EQU 0 ; NO BAUD RATE ASSOCIATED WITH THIS DEVICE +BAUD$50 EQU 1 ; 50 BAUD +BAUD$75 EQU 2 ; 75 BAUD +BAUD$110 EQU 3 ; 110 BAUD +BAUD$134 EQU 4 ; 134.5 BAUD +BAUD$150 EQU 5 ; 150 BAUD +BAUD$300 EQU 6 ; 300 BAUD +BAUD$600 EQU 7 ; 600 BAUD +BAUD$1200 EQU 8 ; 1200 BAUD +BAUD$1800 EQU 9 ; 1800 BAUD +BAUD$2400 EQU 10 ; 2400 BAUD +BAUD$3600 EQU 11 ; 3600 BAUD +BAUD$4800 EQU 12 ; 4800 BAUD +BAUD$7200 EQU 13 ; 7200 BAUD +BAUD$9600 EQU 14 ; 9600 BAUD +BAUD$19200 EQU 15 ; 19.2K BAUD + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; WILL START OFF IN COMMON MEMORY FOR BANKED OR NON-BANKED SYSTEMS: + ; -------------------------- + CSEG + ; -------------------------- + + + IF BANKED + ; WE PROVIDE ALTERNATE DEFINITIONS OF THE ROUTINE ENTRY POINTS IF + ; WE ARE RUNNING A BANKED SYSTEM VERSUS A NON-BANKED SYSTEM: + + ;;;;; ?CINIT + ; ENTER HERE FOR BANKED SYSTEMS FOR DEVICE INITIALIZATIONS: +?CINIT: + LXI H,BCINIT ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CI + ; ENTER HERE FOR BANKED SYSTEM DEVICE INPUT: +?CI: LXI H,BCI ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CO + ; ENTER HERE FOR BANKED SYSTEM DEVICE OUTPUT: +?CO: LXI H,BCO ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CIST + ; ENTER HERE FOR BANKED SYSTEM DEVICE INPUT STATUS: +?CIST: LXI H,BCIST ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?COST + ; ENTER HERE FOR BANKED SYSTEM DEVICE OUTPUT STATUS: +?COST: LXI H,BCOST ;POINT TO BANKED ROUTINE ADDRESS + + + ;;;;; BANKIO + ; ROUTINE DISPATCHES TO BANKED PORTION OF CHARACTER I/O ROUTINES: +BANKIO: + SSPD SPSAVE ;SAVE CURRENT STACK POINTER + LXI SP,IOSP ; AND USE LOCAL STACK FOR I/O + LDA @CBNK ;GET CURRENT BANK + PUSH PSW ;SAVE ON LOCAL STACK + XRA A ;WE WILL SELECT BANK 0 (OP SYS) + CALL ?BNKSL + LXI D,BIORET ;RETURN ADDRESS IN [DE] + PUSH D ;PUT IT ON STACK FOR RETURN + PCHL ;DISPATCH TO BANKED PART OF ROUTINE + + ; ARRIVE HERE AFTER DEVICE HANDLER FINISHED: +BIORET: + POP D ;GET PREVIOUS CURRENT BANK TO [D] + PUSH PSW ;SAVE HANDLER RETURNED RESULT (IF ANY) + MOV A,D ;RESELECT PREVIOUS CURRENT BANK + CALL ?BNKSL + POP PSW ;GET BACK RESULT CODE TO [A] + LSPD SPSAVE ;RESTORE PREVIOUS STACK + RET ;AND RETURN... + ENDIF + + + ;;;;; + ;;;;; ACTUAL DEVICE HANDLERS + ;;;;; + + + ;;;;; ?CINIT (BCINIT FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INITIALIZATION: + IF BANKED + ; -------------------------- + DSEG ;CAN PUT IN BANKED SEGMENT IF BANKED + ; -------------------------- +BCINIT: + ELSE +?CINIT: + ENDIF + MOV B,C ;ON ENTRY DEVICE # IS IN [C] BUT WE NEED + ; IT IN [B] + CALL DEV$DISPATCH ;GO TO CORRECT INIT ROUTINE + DW CINIT0 ;INIT FOR DEVICE 0 + DW NULL$INIT ;INIT FOR DEVICE 1 + DW NULL$INIT ;INIT FOR DEVICE 2 + DW NULL$INIT ;INIT FOR DEVICE 3 + DW NULL$INIT ;INIT FOR DEVICE 4 + DW NULL$INIT ;INIT FOR DEVICE 5 + DW NULL$INIT ;INIT FOR DEVICE 6 + DW NULL$INIT ;INIT FOR DEVICE 7 + DW NULL$INIT ;INIT FOR DEVICE 8 + DW NULL$INIT ;INIT FOR DEVICE 9 + DW NULL$INIT ;INIT FOR DEVICE 10 + DW NULL$INIT ;INIT FOR DEVICE 11 + DW NULL$INIT ;INIT FOR DEVICE 12 + DW NULL$INIT ;INIT FOR DEVICE 13 + DW NULL$INIT ;INIT FOR DEVICE 14 + DW NULL$INIT ;INIT FOR DEVICE 15 + + + ;;;;; ?CI (BCI FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INPUT: + IF BANKED +BCI: + ELSE +?CI: + ENDIF + CALL DEV$DISPATCH + DW CI0 ;DEVICE 0 INPUT + DW NULL$CI ;DEVICE 1 INPUT + DW NULL$CI ;DEVICE 2 INPUT + DW NULL$CI ;DEVICE 3 INPUT + DW NULL$CI ;DEVICE 4 INPUT + DW NULL$CI ;DEVICE 5 INPUT + DW NULL$CI ;DEVICE 6 INPUT + DW NULL$CI ;DEVICE 7 INPUT + DW NULL$CI ;DEVICE 8 INPUT + DW NULL$CI ;DEVICE 9 INPUT + DW NULL$CI ;DEVICE 10 INPUT + DW NULL$CI ;DEVICE 11 INPUT + DW NULL$CI ;DEVICE 12 INPUT + DW NULL$CI ;DEVICE 13 INPUT + DW NULL$CI ;DEVICE 14 INPUT + DW NULL$CI ;DEVICE 15 INPUT + + + ;;;;; ?CO (BCO FOR BANKED) + ; PHYSICAL CODE FOR DEVICE OUTPUT: + IF BANKED +BCO: + ELSE +?CO: + ENDIF + CALL DEV$DISPATCH ;GO TO CORRECT DEVICE OUTPUT HANDLER + DW CO0 ;DEVICE 0 OUTPUT + DW NULL$CO ;DEVICE 1 OUTPUT + DW NULL$CO ;DEVICE 2 OUTPUT + DW NULL$CO ;DEVICE 3 OUTPUT + DW NULL$CO ;DEVICE 4 OUTPUT + DW NULL$CO ;DEVICE 5 OUTPUT + DW NULL$CO ;DEVICE 6 OUTPUT + DW NULL$CO ;DEVICE 7 OUTPUT + DW NULL$CO ;DEVICE 8 OUTPUT + DW NULL$CO ;DEVICE 9 OUTPUT + DW NULL$CO ;DEVICE 10 OUTPUT + DW NULL$CO ;DEVICE 11 OUTPUT + DW NULL$CO ;DEVICE 12 OUTPUT + DW NULL$CO ;DEVICE 13 OUTPUT + DW NULL$CO ;DEVICE 14 OUTPUT + DW NULL$CO ;DEVICE 15 OUTPUT + + + ;;;;; ?CIST (BCIST FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INPUT STATUS: + IF BANKED +BCIST: + ELSE +?CIST: + ENDIF + CALL DEV$DISPATCH + DW CIST0 ;DEVICE 0 INPUT STATUS + DW NULL$CIST ;DEVICE 1 INPUT STATUS + DW NULL$CIST ;DEVICE 2 INPUT STATUS + DW NULL$CIST ;DEVICE 3 INPUT STATUS + DW NULL$CIST ;DEVICE 4 INPUT STATUS + DW NULL$CIST ;DEVICE 5 INPUT STATUS + DW NULL$CIST ;DEVICE 6 INPUT STATUS + DW NULL$CIST ;DEVICE 7 INPUT STATUS + DW NULL$CIST ;DEVICE 8 INPUT STATUS + DW NULL$CIST ;DEVICE 9 INPUT STATUS + DW NULL$CIST ;DEVICE 10 INPUT STATUS + DW NULL$CIST ;DEVICE 11 INPUT STATUS + DW NULL$CIST ;DEVICE 12 INPUT STATUS + DW NULL$CIST ;DEVICE 13 INPUT STATUS + DW NULL$CIST ;DEVICE 14 INPUT STATUS + DW NULL$CIST ;DEVICE 15 INPUT STATUS + + + ;;;;; ?COST (BCOST FOR BANKED) + ; PHYSICAL CODE FOR DEVICE OUTPUT STATUS: + IF BANKED +BCOST: + ELSE +?COST: + ENDIF + CALL DEV$DISPATCH ;GO TO CONSOLE OUTPUT STATUS HANDLER + DW COST0 ;DEVICE 0 OUTPUT STATUS + DW NULL$COST ;DEVICE 1 OUTPUT STATUS + DW NULL$COST ;DEVICE 2 OUTPUT STATUS + DW NULL$COST ;DEVICE 3 OUTPUT STATUS + DW NULL$COST ;DEVICE 4 OUTPUT STATUS + DW NULL$COST ;DEVICE 5 OUTPUT STATUS + DW NULL$COST ;DEVICE 6 OUTPUT STATUS + DW NULL$COST ;DEVICE 7 OUTPUT STATUS + DW NULL$COST ;DEVICE 8 OUTPUT STATUS + DW NULL$COST ;DEVICE 9 OUTPUT STATUS + DW NULL$COST ;DEVICE 10 OUTPUT STATUS + DW NULL$COST ;DEVICE 11 OUTPUT STATUS + DW NULL$COST ;DEVICE 12 OUTPUT STATUS + DW NULL$COST ;DEVICE 13 OUTPUT STATUS + DW NULL$COST ;DEVICE 14 OUTPUT STATUS + DW NULL$COST ;DEVICE 15 OUTPUT STATUS + + + ;;;;; DEV$DISPATCH + ; ROUTINE JUMPS TO CORRECT DEVICE HANDLER: +DEV$DISPATCH: + MOV A,B ;GET DEVICE # TO [A] + STA DEV$CODE ;SAVE FOR LATER USE + ADD A ;X2 FOR WORD OFFSET + POP H ;RETURN ADDRESS IS 1ST PARAMETER ADDRESS + MOV E,A ;SET UP OFFSET IN [DE] + MVI D,0 + DAD D ;[HL] = PTR TO HANDLER ADDRESS + MOV E,M ;GET HANDLER ADDRESS TO [DE] + INX H + MOV D,M + XCHG ;PUT IN [HL] + PCHL ;AND DISPATCH TO IT... + + + ;;;;; + ;;;;; PHYSICAL DEVICE HANDLER CODE: + ;;;;; + +; ---------------------------------------------------------- +; +; Z80-MBC2 I/O +; +; ---------------------------------------------------------- + + +CINIT0: ; DEVICE 0 INITIALIZATION + RET ; Nothing to do + +; +;<<<<<<<<<<<<<<<<<<< MAIN CONSOLE STATUS ROUTINE >>>>>>>>>>>>>>>>>>>>>> +; + +CIST0: ; DEVICE 0 INPUT STATUS + mvi a, SYSFLAG$OPC ; A = SYSFLAG opcode + out STO$OPCD ; Write the opcode + in EXC$RD$OPCD ; Read SYSFLAG data into A + ani 04H ; Rx serial buffer empty (D2 = 0)? + jrz NoInChr ; Yes, jump + + + mvi a, 0ffH ; No, set char ready flag (A = FF) + ret ; Return CP/M char ready flag ($FF) + +NoInChr + xra a ; Set no char flag (A = 0) + ret ; Return CP/M no char flag ($00) + +COST0: ; DEVICE 0 OUTPUT STATUS + mvi a, 0ffH ; Always ready to TX + ret + +; +;<<<<<<<<<<<<<<<<<<<< MAIN CONSOLE INPUT ROUTINE >>>>>>>>>>>>>>>>>>>> +; + +CI0: ;DEVICE 0 INPUT + in SERIAL$RX ; Read a char from serial port + cpi 0ffH ; Is = $FF? + jrz ChkFF ; Yes, jump + ret ; No, return the read char in A + +ChkFF + mvi a, SYSFLAG$OPC ; A = SYSFLAG opcode + out STO$OPCD ; Write the opcode + in EXC$RD$OPCD ; Read SYSFLAG data into A + ani 08H ; It was a "serial buffer empty" flag (D3 = 1)? + jrnz CI0 ; Yes, jump and wait for a char + mvi a, 0ffH ; No, it is a valid ffH char + ret ; Retun with it in A + +; +;<<<<<<<<<<<<<<<<<<<<<< MAIN CONSOLE OUTPUT ROUTINE >>>>>>>>>>>>>>>>>>>>>>>>> +; + +CO0: ; DEVICE 0 OUTPUT + mvi a, SERTX$OPC ; A = SERIAL TX opcode + out STO$OPCD ; Write the opcode + mov a, c + out EXC$WR$OPCD ; Send A to serial Tx + ret + +; +; ------------------------------------------------------------------------- +; + + ;;;;; NULL ROUTINES: +NULL$CIST: +NULL$COST: + XRA A ;RETURN A FALSE STATUS RESULT + JR NULL$RET +NULL$CI: + MVI A,1AH ;FOR INPUT RETURN A CNTL-Z (EOF) +NULL$INIT: +NULL$CO: +NULL$RET: + RET ;HARMLESS RETURN + + + ; STORAGE FOR DEVICE CODE -- CAN RESIDE IN SAME SEGMENT AS THE BULK + ; OF CHARACTER I/O ROUTINES: +DEV$CODE: DS 1 + + ;;;;; CHRTBL + ; CHARACTER DEVICE TABLE + ; -------------------------- + CSEG ;MUST RESIDE IN COMMON MEMORY + ; -------------------------- + +@CTBL: + DB 'CRT ' ;CONSOLE (DEVICE 0) + DB MB$IN$OUT + DB BAUD$NONE + +MAX$DEVICES EQU ($-@CTBL)/8 ;# DEVICES IN TABLE + DB 0 ;TABLE TERMINATOR + + + ; OTHER DATA AREAS: + DS 24 ;CHARACTER I/O LOCAL STACK +IOSP EQU $ +SPSAVE DS 2 + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/O2BOOT.ASM b/software/CPM/CPM23_PLI/O2BOOT.ASM new file mode 100644 index 0000000..d9bc4b6 --- /dev/null +++ b/software/CPM/CPM23_PLI/O2BOOT.ASM @@ -0,0 +1,369 @@ +;******************************************************************************************** +; +; BOOT.ASM - S220918 +; CP/M 3.0 BOOT LOADER BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +; +;******************************************************************************************** + + TITLE 'BOOT LOADER MODULE FOR CP/M 3.0 - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT: +BANKED EQU TRUE ; <------ BANKED/NON-BANKED SWITCH + + ; DEFINE PUBLIC LABELS: + PUBLIC ?INIT,?LDCCP,?RLCCP,?TIME + ;PUBLIC OUT$BLOCKS + + ; EXTERNALLY DEFINED ENTRY POINTS AND LABELS: + EXTRN ?PMSG,?CONIN + EXTRN @CIVEC,@COVEC,@AIVEC,@AOVEC,@LOVEC + EXTRN @CBNK,?BNKSL + EXTRN @SEC,@MIN,@HOUR,@DATE ;FIELDS HOLDING CURRENT TIME AND DATE + + ; INCLUDE Z-80 MACROS: + MACLIB Z80 + + ; SOME MISCELLANEOUS EQUATES: +BDOS EQU 5 +CR EQU 13 ; ASCII CARRIAGE RETURN +LF EQU 10 ; ASCII LINEFEED + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; WE CAN DO INITIALIZATION FROM BANKED MEMORY (IF WE HAVE IT): + IF BANKED + ; -------------------------- + DSEG ; INIT DONE FROM BANKED MEMORY + ; -------------------------- + ELSE + ; -------------------------- + CSEG ; INIT TO BE DONE FROM COMMON MEMORY + ; -------------------------- + ENDIF + + ; HARDWARE INITIALIZATION OTHER THAN CHARACTER AND DISK I/O + +?INIT: + ; ASSIGN CONSOLE INPUT AND OUTPUT TO CRT: + LXI H,8000H ;SIGNIFIES DEVICE 0 + SHLD @CIVEC ;CONSOLE INPUT VECTOR + SHLD @COVEC ;CONSOLE OUTPUT VECTOR + + ; PRINT THE SIGN-ON MESSAGE: + LXI H,SIGNON$MSG ;POINT TO IT + JMP ?PMSG ;AND PRINT IT + ; Note: "RET" here is not needed because we use the that one at the end of ?PMSG + + IF BANKED + ; -------------------------- + CSEG + ; -------------------------- + ENDIF + + ; THIS ROUTINE IS ENTERED TO LOAD THE CCP.COM FILE INTO THE TPA BANK + ; AT SYSTEM COLD START + +?LDCCP: + ; SET UP THE FCB FOR THE FILE OPERATION + ; NOTE: If banked at this point bank 1 is alredy selected + ; (see BIOSKRNL.ASM) + XRA A ;ZERO EXTENT + STA CCP$FCB+15 + LXI H,0 ;START AT BEGINNING OF FILE + SHLD FCB$NR + + ; TRY TO OPEN THE CCP.COM FILE: + LXI D,CCP$FCB ;POINT TO FCB + CALL OPEN ;ATTEMPT THE OPEN OPERATION + INR A ;WAS IT ON THE DISK ? + JRNZ CCP$FOUND ;YES -- GO LOAD IT + + ; WE ARRIVE HERE WHEN CCP.COM FILE WASN'T FOUND: + LXI H,CCP$MSG ;REPORT THE ERROR + CALL ?PMSG + CALL ?CONIN ;GET A RESPONSE + JR ?LDCCP ;AND TRY AGAIN + + ; FILE WAS OPENED OK -- READ IT IN: +CCP$FOUND: + LXI D,0100H ;LOAD AT BOTTOM OF TPA + CALL SETDMA ;BY SETTING THE NEXT DMA ADDRESS + LXI D,128 ;SET MULTI SECTOR I/O COUNT + CALL SETMULTI ; TO ALLOW UP TO 16K BYTES IN ONE OPERATION + LXI D,CCP$FCB ;POINT TO THE FCB + CALL READ ;AND READ THE CCP IN + RET + + ; ROUTINE RELOADS CCP IMAGE FROM BANK 2 IF BANKED SYSTEM OR FROM THE + ; DISK IF NON-BANKED VERSION + +?RLCCP: + JMP ?LDCCP ;JUST DO LOAD AS THOUGH COLD BOOT + +; -------------------------------------------------------------------------------- +; +; SETS/GETS TIME (Z80-MBC2) +; +; The time of day is kept as four fields. +; @DATE is a binary word containing the number of days since 31 December 1977. +; The bytes @HOUR, @MIN, and @SEC in the System Control Block contain the +; hour, minute, and second in Binary Coded Decimal (BCD) format. +; +; C = Get/Set Flag +; C=000H if get, C=0FFH if set +; (see Appendix J, Table J-1 of CP/M 3 System Guide) +; +; NOTE1: Only the Get function is implemented. +; To change RTC date/time use the IOS "SELECT BOOT MODE OR SYSTEM PARAMETERS" menu. +; NOTE2: Because the IOS RTC year is from 00 to 99 only date from 1-1-2000 to 31-12-2099 +; are valid for this algorithm (I think that it's enough...) +; +; -------------------------------------------------------------------------------- + +?TIME: + ; + ; Check if it is a get time operation + mov a, c + ora a ; Get/Set Flag = 0? + rnz ; Return if it is a Set Time request + ; + ; Check if the RTC module is present + mvi a, SYSFLAG$OPC ; Select SYSFLAG opcode + out STO$OPCD + in EXC$RD$OPCD ; A = SYSFLAG + ani 02h ; Isolate the RTC flag bit + rz ; Return if the RTC is not present + push b + push d + push h + ; + ; Load date/time from the RTC to RTCBUFF + mvi a, DATETIM$OPC ; Select DATETIME opcode + out STO$OPCD + mvi c, EXC$RD$OPCD ; C = EXECUTE READ opcode + lxi h, RTCBUFF ; HL -> RTC Buffer + mvi b, 6 ; Byte counter = 6 + inir ; Read date/time to RTCBUFF + ; + ; Update @SEC (BCD) + lxi b, RTCBUFF ; BC -> RTC seconds + ldax b ; A = RTC seconds (binary) + call bin2bcd ; Binary to BCD + sta @SEC ; Store it into @SEC + ; + ; Update @MIN (BCD) + inx b ; BC -> RTC minutes + ldax b ; A = RTC minutes (binary) + call bin2bcd ; Binary to BCD + sta @MIN ; Store it into @MIN + ; + ; Update @HOUR (BCD) + inx b ; BC -> RTC hours + ldax b ; A = RTC hours (binary) + call bin2bcd ; Binary to BCD + sta @HOUR ; Store it into @HOUR + ; + ; Calculate how many whole years elapsed from 31-12-1977 to now + lda RTCYEAR + adi 22 + mov c, a ; C = elapsed_years = (RTCYEAR) + 22 + ; + ; Convert it in days into HL (16 bit) + xra a ; A = 0 + mov b, a ; B = 0. BC = elapsed_years (16bit) + lxi d, 365 ; DE = 365 + call Mult16 ; HL = elapsed_years * 365 = elapsed_years_days + ; + ; Calculate how many whole leap years elapsed from 31-12-1977 to now + ; (current year excluded) and add it to elapsed_years_days + lda RTCYEAR + ora a + jrz addleapyrs ; If RTCYEAR = 00 -> A = 0 + dcr a ; If RTCYEAR > 00 -> A = (RTRYEAR) - 1 + srlr a ; / 2S + srlr a ; / 4 + inr a ; If RTCYEAR > 00 -> A = (((RTCYEAR) - 1) / 4) + 1 = + ; leap years from 31-12-1999 to now (current year excluded) +addleapyrs: + adi 5 ; Add leap years from 31-12-1977 to 31-12-1999 + mov c, a ; C = elapsed_leap_years = (((RTCYEAR) - 1) / 4) + 1 + 5 + xra a ; A = 0 + mov d, a ; D = 0 + mov b ,a ; B = 0. BC = elapsed_leap_years (16bit) + dad b ; HL = elapsed_years_days + elapsed_leap_years + ; + ; Add days of current month + lda RTCDAY + mov c, a ; BC = days_of_current_month (16bit) + dad b ; Add to HL days_of_current_month (BC) + lda RTCMONTH ; A = current_month + dcr a ; A = Number_of_months_before_current + jrz checkCurrYear ; Jump if Number_of_months_before_current = 0 + ; + ; Add days of all previous months of current year, starting with January + lxi b, MONTHTAB ; BC -> days_of_month (starting from Jan) +addDays: + push a ; Save A = Number_of_months_before_current + ldax b ; A = days_of_month (month pointed by BC) + mov e, a ; DE = days of month (16bit) + dad d ; Add it to HL + inx b ; BC -> next month + pop a + dcr a ; There is an other month? + jrnz addDays ; Jump if there is an other month to compute + ; + ; If current year is a leap year and current month is > February add one day + ; to HL +checkCurrYear: + lda RTCMONTH + cpi 3 ; Current month < March? + jrc TIMEend ; Jump if yes + lda RTCYEAR ; No, check if current year is leap + mov b, a ; A = B = current year + srlr a ; / 2 + srlr a ; / 4 + slar a ; * 2 + slar a ; * 4 + cmp b ; A = B if A is leap + jrnz TIMEend ; Jump if not leap + inx h ; Add 1 to HL +TIMEend: + ; + ; All done, store days from 31-12-1977 to now into @DATE + shld @DATE ; Store the date in days from CP/M epoch + pop h + pop d + pop b + ret + +MONTHTAB: + DB 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30 ; Only Jan-Nov needed + +; Multiply 16-bit values (with 16-bit result) +; In: Multiply BC with DE +; Out: HL = result +; +Mult16: + mov a, b + mvi b, 16 +Mult16Loop: + dad h + slar c + ral + jrnc Mult16NoAdd + dad d +Mult16NoAdd: + djnz Mult16Loop + ret + +; BIN to BCD conversion +; a(BIN) => a(BCD) +; [0..99] => [00h..99h] +; +bin2bcd: + push b + mvi b,10 + mvi c,-1 +div10: + inr c + sub b + jrnc div10 + add b + mov b, a + mov a, c + add a + add a + add a + add a + ora b + pop b + ret + +RTCBUFF: ; Buffer for the RTC data (binary) + DB 1 ; Seconds [0..59] + DB 1 ; Minutes [0..59] + DB 1 ; Hours [0..23] +RTCDAY; + DB 1 ; Day [1..31] +RTCMONTH: + DB 1 ; Month [1..12] +RTCYEAR: + DB 1 ; Year [0..99] + +; -------------------------------------------------------------------------------- + + IF BANKED + ; -------------------------- + CSEG + ; -------------------------- + ENDIF + + ; CP/M BDOS FUNCTION INTERFACES + + ; OPEN FILE: +OPEN: + MVI C,15 ! JMP BDOS ; OPEN FILE CONTROL BLOCK + + ; SET DMA ADDRESS: +SETDMA: + MVI C,26 ! JMP BDOS ; SET DATA TRANSFER ADDRESS + + ; SET MULTI SECTOR I/O COUNT: +SETMULTI: + MVI C,44 ! JMP BDOS ; SET RECORD COUNT + + ; READ FILE RECORD: +READ: + MVI C,20 ! JMP BDOS ; READ RECORDS + + ; CCP NOT FOUND ERROR MESSAGE: +CCP$MSG: + DB CR,LF,'BIOS ERR ON A: NO CCP.COM FILE',0 + + + ; FCB FOR CCP.COM FILE LOADING: +CCP$FCB: + DB 1 ;AUTO-SELECT DRIVE A + DB 'CCP COM' ;FILE NAME AND TYPE + DB 0,0,0,0 + DS 16 +FCB$NR: DB 0,0,0 + + ; SYSTEM SIGN-ON MESSAGE: +SIGNON$MSG: + DB CR,LF,'Z80-MBC2 128KB ' + DB '(Banked) CP/M V3.0' + DB CR,LF,'Z80-MBC2 BIOS Modules: S200918, S210918, S220918, S290918' + DB CR,LF,LF,0 + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/O2CHARIO.ASM b/software/CPM/CPM23_PLI/O2CHARIO.ASM new file mode 100644 index 0000000..bc4bff9 --- /dev/null +++ b/software/CPM/CPM23_PLI/O2CHARIO.ASM @@ -0,0 +1,438 @@ +;******************************************************************************************** +; +; CHARIO.ASM - S210918 +; CP/M 3.0 CHARACTER I/O BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +;******************************************************************************************** + +TITLE 'CP/M 3 MODULE FOR CHARACTER I/O HANDLING - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF FOR BANK SELECT OR NOT: +BANKED EQU FALSE ; <------ BANKED/NON-BANKED SWITCH + +; ------------------------------------------------------------------- +; +; >>>>>>>>>>>>>> READ CAREFULLY <<<<<<<<<<<<<< +; +; To prevent the CHARIO.ASM bank swiching IOS requests from +; interfering with user program IOS request if using +; "slow" interpreters as e.g. MBASIC.COM, I've decided to avoid +; bank switching here. This is a simple solution to avoid more +; complex one. For this reason the "BANKED" switch is intentionally +; set at "FALSE" (although the system is banked) +; +; ------------------------------------------------------------------- + + + ; DEFINE PUBLIC LABELS: + PUBLIC ?CINIT,?CI,?CO,?CIST,?COST + PUBLIC @CTBL + + ; DEFINE EXTERNAL LABELS AND ENTRY POINTS: + IF BANKED + EXTRN @CBNK + EXTRN ?BNKSL + ENDIF + EXTRN OUT$BLOCKS ;BLOCK OUTPUT ROUTINE TO I/O PORTS + EXTRN ?PMSG + + ; INCLUDE Z-80 MACROS: + + MACLIB Z80 + + ; EQUATES FOR MODE BYTE BIT FIELDS + +MB$INPUT EQU 0000$0001B ; DEVICE MAY DO INPUT +MB$OUTPUT EQU 0000$0010B ; DEVICE MAY DO OUTPUT +MB$IN$OUT EQU MB$INPUT+MB$OUTPUT + +MB$SOFT$BAUD EQU 0000$0100B ; SOFTWARE SELECTABLE BAUD RATES + +MB$SERIAL EQU 0000$1000B ; DEVICE MAY USE PROTOCOL +MB$XON$XOFF EQU 0001$0000B ; XON/XOFF PROTOCOL ENABLED + +BAUD$NONE EQU 0 ; NO BAUD RATE ASSOCIATED WITH THIS DEVICE +BAUD$50 EQU 1 ; 50 BAUD +BAUD$75 EQU 2 ; 75 BAUD +BAUD$110 EQU 3 ; 110 BAUD +BAUD$134 EQU 4 ; 134.5 BAUD +BAUD$150 EQU 5 ; 150 BAUD +BAUD$300 EQU 6 ; 300 BAUD +BAUD$600 EQU 7 ; 600 BAUD +BAUD$1200 EQU 8 ; 1200 BAUD +BAUD$1800 EQU 9 ; 1800 BAUD +BAUD$2400 EQU 10 ; 2400 BAUD +BAUD$3600 EQU 11 ; 3600 BAUD +BAUD$4800 EQU 12 ; 4800 BAUD +BAUD$7200 EQU 13 ; 7200 BAUD +BAUD$9600 EQU 14 ; 9600 BAUD +BAUD$19200 EQU 15 ; 19.2K BAUD + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + ; WILL START OFF IN COMMON MEMORY FOR BANKED OR NON-BANKED SYSTEMS: + ; -------------------------- + CSEG + ; -------------------------- + + + IF BANKED + ; WE PROVIDE ALTERNATE DEFINITIONS OF THE ROUTINE ENTRY POINTS IF + ; WE ARE RUNNING A BANKED SYSTEM VERSUS A NON-BANKED SYSTEM: + + ;;;;; ?CINIT + ; ENTER HERE FOR BANKED SYSTEMS FOR DEVICE INITIALIZATIONS: +?CINIT: + LXI H,BCINIT ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CI + ; ENTER HERE FOR BANKED SYSTEM DEVICE INPUT: +?CI: LXI H,BCI ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CO + ; ENTER HERE FOR BANKED SYSTEM DEVICE OUTPUT: +?CO: LXI H,BCO ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?CIST + ; ENTER HERE FOR BANKED SYSTEM DEVICE INPUT STATUS: +?CIST: LXI H,BCIST ;POINT TO BANKED ROUTINE ADDRESS + JR BANKIO ;GO TO DISPATCHER + + ;;;;; ?COST + ; ENTER HERE FOR BANKED SYSTEM DEVICE OUTPUT STATUS: +?COST: LXI H,BCOST ;POINT TO BANKED ROUTINE ADDRESS + + + ;;;;; BANKIO + ; ROUTINE DISPATCHES TO BANKED PORTION OF CHARACTER I/O ROUTINES: +BANKIO: + SSPD SPSAVE ;SAVE CURRENT STACK POINTER + LXI SP,IOSP ; AND USE LOCAL STACK FOR I/O + LDA @CBNK ;GET CURRENT BANK + PUSH PSW ;SAVE ON LOCAL STACK + XRA A ;WE WILL SELECT BANK 0 (OP SYS) + CALL ?BNKSL + LXI D,BIORET ;RETURN ADDRESS IN [DE] + PUSH D ;PUT IT ON STACK FOR RETURN + PCHL ;DISPATCH TO BANKED PART OF ROUTINE + + ; ARRIVE HERE AFTER DEVICE HANDLER FINISHED: +BIORET: + POP D ;GET PREVIOUS CURRENT BANK TO [D] + PUSH PSW ;SAVE HANDLER RETURNED RESULT (IF ANY) + MOV A,D ;RESELECT PREVIOUS CURRENT BANK + CALL ?BNKSL + POP PSW ;GET BACK RESULT CODE TO [A] + LSPD SPSAVE ;RESTORE PREVIOUS STACK + RET ;AND RETURN... + ENDIF + + + ;;;;; + ;;;;; ACTUAL DEVICE HANDLERS + ;;;;; + + + ;;;;; ?CINIT (BCINIT FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INITIALIZATION: + IF BANKED + ; -------------------------- + DSEG ;CAN PUT IN BANKED SEGMENT IF BANKED + ; -------------------------- +BCINIT: + ELSE +?CINIT: + ENDIF + MOV B,C ;ON ENTRY DEVICE # IS IN [C] BUT WE NEED + ; IT IN [B] + CALL DEV$DISPATCH ;GO TO CORRECT INIT ROUTINE + DW CINIT0 ;INIT FOR DEVICE 0 + DW NULL$INIT ;INIT FOR DEVICE 1 + DW NULL$INIT ;INIT FOR DEVICE 2 + DW NULL$INIT ;INIT FOR DEVICE 3 + DW NULL$INIT ;INIT FOR DEVICE 4 + DW NULL$INIT ;INIT FOR DEVICE 5 + DW NULL$INIT ;INIT FOR DEVICE 6 + DW NULL$INIT ;INIT FOR DEVICE 7 + DW NULL$INIT ;INIT FOR DEVICE 8 + DW NULL$INIT ;INIT FOR DEVICE 9 + DW NULL$INIT ;INIT FOR DEVICE 10 + DW NULL$INIT ;INIT FOR DEVICE 11 + DW NULL$INIT ;INIT FOR DEVICE 12 + DW NULL$INIT ;INIT FOR DEVICE 13 + DW NULL$INIT ;INIT FOR DEVICE 14 + DW NULL$INIT ;INIT FOR DEVICE 15 + + + ;;;;; ?CI (BCI FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INPUT: + IF BANKED +BCI: + ELSE +?CI: + ENDIF + CALL DEV$DISPATCH + DW CI0 ;DEVICE 0 INPUT + DW NULL$CI ;DEVICE 1 INPUT + DW NULL$CI ;DEVICE 2 INPUT + DW NULL$CI ;DEVICE 3 INPUT + DW NULL$CI ;DEVICE 4 INPUT + DW NULL$CI ;DEVICE 5 INPUT + DW NULL$CI ;DEVICE 6 INPUT + DW NULL$CI ;DEVICE 7 INPUT + DW NULL$CI ;DEVICE 8 INPUT + DW NULL$CI ;DEVICE 9 INPUT + DW NULL$CI ;DEVICE 10 INPUT + DW NULL$CI ;DEVICE 11 INPUT + DW NULL$CI ;DEVICE 12 INPUT + DW NULL$CI ;DEVICE 13 INPUT + DW NULL$CI ;DEVICE 14 INPUT + DW NULL$CI ;DEVICE 15 INPUT + + + ;;;;; ?CO (BCO FOR BANKED) + ; PHYSICAL CODE FOR DEVICE OUTPUT: + IF BANKED +BCO: + ELSE +?CO: + ENDIF + CALL DEV$DISPATCH ;GO TO CORRECT DEVICE OUTPUT HANDLER + DW CO0 ;DEVICE 0 OUTPUT + DW NULL$CO ;DEVICE 1 OUTPUT + DW NULL$CO ;DEVICE 2 OUTPUT + DW NULL$CO ;DEVICE 3 OUTPUT + DW NULL$CO ;DEVICE 4 OUTPUT + DW NULL$CO ;DEVICE 5 OUTPUT + DW NULL$CO ;DEVICE 6 OUTPUT + DW NULL$CO ;DEVICE 7 OUTPUT + DW NULL$CO ;DEVICE 8 OUTPUT + DW NULL$CO ;DEVICE 9 OUTPUT + DW NULL$CO ;DEVICE 10 OUTPUT + DW NULL$CO ;DEVICE 11 OUTPUT + DW NULL$CO ;DEVICE 12 OUTPUT + DW NULL$CO ;DEVICE 13 OUTPUT + DW NULL$CO ;DEVICE 14 OUTPUT + DW NULL$CO ;DEVICE 15 OUTPUT + + + ;;;;; ?CIST (BCIST FOR BANKED) + ; PHYSICAL CODE FOR DEVICE INPUT STATUS: + IF BANKED +BCIST: + ELSE +?CIST: + ENDIF + CALL DEV$DISPATCH + DW CIST0 ;DEVICE 0 INPUT STATUS + DW NULL$CIST ;DEVICE 1 INPUT STATUS + DW NULL$CIST ;DEVICE 2 INPUT STATUS + DW NULL$CIST ;DEVICE 3 INPUT STATUS + DW NULL$CIST ;DEVICE 4 INPUT STATUS + DW NULL$CIST ;DEVICE 5 INPUT STATUS + DW NULL$CIST ;DEVICE 6 INPUT STATUS + DW NULL$CIST ;DEVICE 7 INPUT STATUS + DW NULL$CIST ;DEVICE 8 INPUT STATUS + DW NULL$CIST ;DEVICE 9 INPUT STATUS + DW NULL$CIST ;DEVICE 10 INPUT STATUS + DW NULL$CIST ;DEVICE 11 INPUT STATUS + DW NULL$CIST ;DEVICE 12 INPUT STATUS + DW NULL$CIST ;DEVICE 13 INPUT STATUS + DW NULL$CIST ;DEVICE 14 INPUT STATUS + DW NULL$CIST ;DEVICE 15 INPUT STATUS + + + ;;;;; ?COST (BCOST FOR BANKED) + ; PHYSICAL CODE FOR DEVICE OUTPUT STATUS: + IF BANKED +BCOST: + ELSE +?COST: + ENDIF + CALL DEV$DISPATCH ;GO TO CONSOLE OUTPUT STATUS HANDLER + DW COST0 ;DEVICE 0 OUTPUT STATUS + DW NULL$COST ;DEVICE 1 OUTPUT STATUS + DW NULL$COST ;DEVICE 2 OUTPUT STATUS + DW NULL$COST ;DEVICE 3 OUTPUT STATUS + DW NULL$COST ;DEVICE 4 OUTPUT STATUS + DW NULL$COST ;DEVICE 5 OUTPUT STATUS + DW NULL$COST ;DEVICE 6 OUTPUT STATUS + DW NULL$COST ;DEVICE 7 OUTPUT STATUS + DW NULL$COST ;DEVICE 8 OUTPUT STATUS + DW NULL$COST ;DEVICE 9 OUTPUT STATUS + DW NULL$COST ;DEVICE 10 OUTPUT STATUS + DW NULL$COST ;DEVICE 11 OUTPUT STATUS + DW NULL$COST ;DEVICE 12 OUTPUT STATUS + DW NULL$COST ;DEVICE 13 OUTPUT STATUS + DW NULL$COST ;DEVICE 14 OUTPUT STATUS + DW NULL$COST ;DEVICE 15 OUTPUT STATUS + + + ;;;;; DEV$DISPATCH + ; ROUTINE JUMPS TO CORRECT DEVICE HANDLER: +DEV$DISPATCH: + MOV A,B ;GET DEVICE # TO [A] + STA DEV$CODE ;SAVE FOR LATER USE + ADD A ;X2 FOR WORD OFFSET + POP H ;RETURN ADDRESS IS 1ST PARAMETER ADDRESS + MOV E,A ;SET UP OFFSET IN [DE] + MVI D,0 + DAD D ;[HL] = PTR TO HANDLER ADDRESS + MOV E,M ;GET HANDLER ADDRESS TO [DE] + INX H + MOV D,M + XCHG ;PUT IN [HL] + PCHL ;AND DISPATCH TO IT... + + + ;;;;; + ;;;;; PHYSICAL DEVICE HANDLER CODE: + ;;;;; + +; ---------------------------------------------------------- +; +; Z80-MBC2 I/O +; +; ---------------------------------------------------------- + + +CINIT0: ; DEVICE 0 INITIALIZATION + RET ; Nothing to do + +; +;<<<<<<<<<<<<<<<<<<< MAIN CONSOLE STATUS ROUTINE >>>>>>>>>>>>>>>>>>>>>> +; + +CIST0: ; DEVICE 0 INPUT STATUS + lda InChrBuf ; A = previous char read by CONST, if any + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrnz InChr ; No, jump (char already read) + in SERIAL$RX ; Yes, Read a char from "virtual" UART + sta InChrBuf ; Store it + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrz NoInChr ; Yes, jump +InChr + mvi a, 0ffH ; No, return CP/M char ready flag ($FF) + ret + +NoInChr + xra a ; A = 0 + ret ; Return CP/M no char flag ($00) + +InChrBuf ; Last read char by CONST ($FF = no char) + db 0ffH ; Initialized as $FF + + + + +COST0: ; DEVICE 0 OUTPUT STATUS + mvi a, 0ffH ; Always ready to TX + ret + +; +;<<<<<<<<<<<<<<<<<<<< MAIN CONSOLE INPUT ROUTINE >>>>>>>>>>>>>>>>>>>> +; + +CI0: ;DEVICE 0 INPUT + lda InChrBuf ; A = previous char read by CONST, if any +ChkInChr + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrz GetChr ; Yes, jump to read a char + push psw ; No, InChrBuf = $FF (clear buffer) + mvi a, 0ffH + sta InChrBuf + pop psw + jr SetChrPar +GetChr + in SERIAL$RX ; Read a char from UART + cpi 0ffH ; Is = $FF ($FF from UART = no char)? + jrz GetChr ; Yes jump until a valid char is received +SetChrPar ; Set parity bit to 0 + ani 7fH + ret + +; +;<<<<<<<<<<<<<<<<<<<<<< MAIN CONSOLE OUTPUT ROUTINE >>>>>>>>>>>>>>>>>>>>>>>>> +; + +CO0: ; DEVICE 0 OUTPUT + mvi a, SERTX$OPC ; A = SERIAL TX opcode + out STO$OPCD ; Write the opcode + mov a, c + out EXC$WR$OPCD ; Send A to serial Tx + ret + +; +; ------------------------------------------------------------------------- +; + + ;;;;; NULL ROUTINES: +NULL$CIST: +NULL$COST: + XRA A ;RETURN A FALSE STATUS RESULT + JR NULL$RET +NULL$CI: + MVI A,1AH ;FOR INPUT RETURN A CNTL-Z (EOF) +NULL$INIT: +NULL$CO: +NULL$RET: + RET ;HARMLESS RETURN + + + ; STORAGE FOR DEVICE CODE -- CAN RESIDE IN SAME SEGMENT AS THE BULK + ; OF CHARACTER I/O ROUTINES: +DEV$CODE: DS 1 + + ;;;;; CHRTBL + ; CHARACTER DEVICE TABLE + ; -------------------------- + CSEG ;MUST RESIDE IN COMMON MEMORY + ; -------------------------- + +@CTBL: + DB 'CRT ' ;CONSOLE (DEVICE 0) + DB MB$IN$OUT + DB BAUD$NONE + +MAX$DEVICES EQU ($-@CTBL)/8 ;# DEVICES IN TABLE + DB 0 ;TABLE TERMINATOR + + + ; OTHER DATA AREAS: + DS 24 ;CHARACTER I/O LOCAL STACK +IOSP EQU $ +SPSAVE DS 2 + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/VDISK.ASM b/software/CPM/CPM23_PLI/VDISK.ASM new file mode 100644 index 0000000..c76927c --- /dev/null +++ b/software/CPM/CPM23_PLI/VDISK.ASM @@ -0,0 +1,529 @@ +;******************************************************************************************** +; +; VDISK.ASM - S200918 +; CP/M 3.0 VIRTUAL DISK ON SD BIOS MODULE FOR THE Z80-MBC2 (HW ref. A040618) +; +; Required IOS S220718-R190918 (or newer revisions until otherwise stated) +; +; NOTE: Use the RMAC.COM relocatable assembler +; +; +; +;******************************************************************************************** + +TITLE 'CP/M 3 MODULE FOR VIRTUAL DISKS ON SD - Z80-MBC2 (A040618)' + + ; DEFINE LOGICAL VALUES: +TRUE: EQU -1 +FALSE EQU NOT TRUE + + ; DETERMINE IF BANKED SELECT OR NOT +BANKED EQU TRUE ; <------ BANKED/NON-BANKED SWITCH + +BELL EQU 07H +CR EQU 0DH +LF EQU 0AH + +; -------------------------------------------------------------------------------- +; +; Z80-MBC2 IOS equates +; +; -------------------------------------------------------------------------------- + +EXC$WR$OPCD EQU 000H ; Address of the EXECUTE WRITE OPCODE write port +EXC$RD$OPCD EQU 000H ; Address of the EXECUTE READ OPCODE read port +STO$OPCD EQU 001H ; Address of the STORE OPCODE write port +SERIAL$RX EQU 001H ; Address of the SERIAL RX read port +SERTX$OPC EQU 001H ; SERIAL TX opcode +SELDISK$OPC EQU 009H ; SELDISK opcode +SELTRCK$OPC EQU 00AH ; SELTRACK opcode +SELSECT$OPC EQU 00BH ; SELSECT opcode +WRTSECT$OPC EQU 00CH ; WRITESECT opcode +SYSFLAG$OPC EQU 083H ; SYSFLAG opcode +DATETIM$OPC EQU 084H ; DATETIME opcode +ERRDSK$OPC EQU 085H ; ERRDISK opcode +RDSECT$OPC EQU 086H ; READSECT opcode +SDMOUNT$OPC EQU 087H ; SDMOUNT opcode + + + PUBLIC @DTBL + + ; DEFINE EXTERNAL LABELS: + EXTRN @ADRV,@RDRV + EXTRN @DMA,@TRK,@SECT + EXTRN @CBNK + EXTRN @DBNK ;BANK FOR DMA OPERATION + EXTRN @ERMDE ;BDOS ERROR MODE + EXTRN ?WBOOT ;WARM BOOT VECTOR + EXTRN ?PMSG ;PRINT MESSAGE @ UP TO 00, SAVES + ; [BC] AND [DE] + EXTRN ?PDERR ;PRINT BIOS DISK ERROR HEADER + EXTRN ?CONIN,?CONO ;CONSOLE IN AND OUT + EXTRN ?CONST ;CONSOLE STATUS + + IF BANKED + EXTRN ?BNKSL ;SELECT PROCESSOR MEMORY BANK + ENDIF + + ; INCLUDE CP/M 3.0 DISK DEFINITION MACROS: + MACLIB CPM3 + + ; INCLUDE Z-80 MACRO LIBRARY: + MACLIB Z80 + + IF BANKED + ; -------------------------- + DSEG ;PUT IN OP SYS BANK IF BANKING + ; -------------------------- + ENDIF + +; -------------------------------------------------------------------------------- +; +; EXTENDED DISK PARAMETER HEADER FOR 16 VIRTUAL DISKS (Z80-MBC2) +; +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 0: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 0 ;RELATIVE DRIVE 0 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH0: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 1: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 1 ;RELATIVE DRIVE 1 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH1: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 2: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 2 ;RELATIVE DRIVE 2 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH2: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 3: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 3 ;RELATIVE DRIVE 3 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH3: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 4: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 4 ;RELATIVE DRIVE 4 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH4: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 5: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 5 ;RELATIVE DRIVE 5 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH5: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 6: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 6 ;RELATIVE DRIVE 6 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH6: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 7: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 7 ;RELATIVE DRIVE 7 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH7: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 8: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 8 ;RELATIVE DRIVE 8 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH8: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 9: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 9 ;RELATIVE DRIVE 9 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH9: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 10: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 10 ;RELATIVE DRIVE 10 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH10: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 11: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 11 ;RELATIVE DRIVE 11 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH11: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 12: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 12 ;RELATIVE DRIVE 12 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH12: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 13: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 13 ;RELATIVE DRIVE 13 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH13: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 14: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 14 ;RELATIVE DRIVE 14 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH14: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- + + ; EXTENDED DISK PARAMETER HEADER FOR DRIVE 15: + ; + DW HDWRT ;HARD DISK WRITE ROUTINE + DW HDRD ;HARD DISK READ ROUTINE + DW HDLOGIN ;HARD DISK LOGIN PROCEDURE + DW HDINIT ;HARD DISK DRIVE INITIALIZATION ROUTINE + DB 15 ;RELATIVE DRIVE 15 ON THIS CONTROLLER + DB 0 ;MEDIA TYPE + +DPH15: DPH 0,IDEHD$DPB0 + +; -------------------------------------------------------------------------------- +; +; Disk Drive Table or DTBL (So the file DRVTBL.ASM is not needed) +; +; -------------------------------------------------------------------------------- + + IF BANKED + ; -------------------------- + DSEG ;BANKED SYSTEMS CAN HAVE DRIVE TABLE IN THE OP SYS BANK + ; -------------------------- + ELSE + ; -------------------------- + CSEG ;NON-BANKED SYSTEMS HAVE NO CHOICE BUT TO PUT IN THE COMMON AREA + ; -------------------------- + ENDIF + +@dtbl: + dw dph0 ; A: + dw dph1 ; B: + dw dph2 ; C: + dw dph3 ; D: + dw dph4 ; E: + dw dph5 ; F: + dw dph6 ; G: + dw dph7 ; H: + dw dph8 ; I: + dw dph9 ; J: + dw dph10 ; K: + dw dph11 ; L: + dw dph12 ; M: + dw dph13 ; N: + dw dph14 ; O: + dw dph15 ; P: + +; -------------------------------------------------------------------------------- +; +; Disk Parameter Block table (DPB) +; +; DBP macro parameters: +; Bytes per sector, num sec, num trk, block size, dir entries, reserved trk, HD flag +; +; -------------------------------------------------------------------------------- + + ; -------------------------- + CSEG ; MAKE SURE DPB'S ARE IN COMMON MEMORY + ; -------------------------- + +IDEHD$DPB0: + DPB 512,32,512,4096,512,1,8000H + +; -------------------------------------------------------------------------------- +; +; >>>>>>> READ CAREFULLY <<<<<<<< +; +; NOTE: the disk capacity *MUST* be *LESS* than 8MBytes with DPB macro!!! +; (See CP/M 3 System Guide par. 3.3.5) +; But Z80-MBC2 virtual disks are exactly 8Mbytes (512 * 512 * 32), +; so I've used a little trick to keep things simple and avoid to do the table +; by hand... I've used for all disk an 1 reserved track, so the available +; disk capacity is less that 8MB (and the DPB macro works...) +; Yeahhh... I'm lazy... :-) +; -------------------------------------------------------------------------------- + + IF BANKED + ; -------------------------- + DSEG ;CAN SET BACK TO BANKED SEGMENT IF BANKING + ; -------------------------- + ENDIF + +;----------------------- INITIALIZE THE HARD DISK ------------------------------- + +HDINIT: + RET ; Nothing to initialize + + +HDLOGIN: + ; This entry is called when a logical drive is about to + ; be logged into for the purpose of density determination. + ; + ; It may adjust the parameters contained in the disk + ; parameter header pointed at by + ret ; We have nothing to do + + +;-------------------------------------------------------------------------------- +; HARD DISK WRITE/READ A SECTOR AT @TRK, @SECT of disk @ADRV TO Address at @DMA +; Return A=00H if no Error, A=01H if Non-recov Err +; +; +; >>>> WARNING <<<<: In a banked system @ADRV, @RDRV, @DBNK, @TRK, @SECT, @DMA are +; all in bank 0 +; +;-------------------------------------------------------------------------------- + + ; relative drive number in @rdrv (8 bits) + ; absolute drive number in @adrv (8 bits) + ; disk transfer address in @dma (16 bits) + ; disk transfer bank in @dbnk (8 bits) + ; disk track address in @trk (16 bits) + ; disk sector address in @sect (16 bits) + ; pointer to XDPH in + +;-------------------------------------------------------------------------------- + +lastDsk: + DB 0ffH ; Last disk number (= ff after cold boot) + +HDWRT: ; Write a sector (512 bytes) + push b + push h + call setDTS ; Set disk, track, sector (after return HL = DMA) + IF BANKED ; Banked system handling + JMP BHDWRT + ; -------------------------- + CSEG ; This I/O part must be in the common bank + ; -------------------------- +BHDWRT: + LDA @CBNK ; Save current bank in the stack + PUSH PSW + LDA @DBNK ; Select the bank for disk I/O + CALL ?BNKSL + ENDIF + ; + ; Write current host sector (512 byte) to DMA (HL = DMA) + mvi c, EXC$WR$OPCD ; Set the EXECUTE WRITE OPCODE port into C + mvi a, WRTSECT$OPC ; Select WRITESECT opcode (IOS) + out STO$OPCD + mvi b, 0 ; Byte counter = 256 + outir ; Write 256 byte + outir ; Write 256 byte + IF BANKED + POP PSW ; Restore previous bank + CALL ?BNKSL + JMP CHECKWR + ; -------------------------- + DSEG + ; -------------------------- + ENDIF + ; + ; Check for errors +CHECKWR: + mvi a, ERRDSK$OPC ; Select ERRDISK opcode (IOS) + out STO$OPCD + in EXC$RD$OPCD ; Read error code into A + ora a ; Set Z flag + pop h + pop b + rz ; Return with A = 0 (no error) + mvi a, 1 ; Set error code + ret ; Return with A = 1 (read error) + + +;-------------------------------------------------------------------------------- + + +HDRD: ; Read a sector (512 bytes) + push b + push h + call setDTS ; Set disk, track, sector (after return HL = DMA) + IF BANKED ; Banked system handling + JMP BHDRD + ; -------------------------- + CSEG ; This I/O part must be in the common bank + ; -------------------------- +BHDRD: + LDA @CBNK ; Save current bank in the stack + PUSH PSW + LDA @DBNK ; Select the bank for disk I/O + CALL ?BNKSL + ENDIF + ; + ; Read current host sector (512 byte) to DMA (HL = DMA) + mvi c, EXC$RD$OPCD ; Set the EXECUTE READ OPCODE port into C + mvi a, RDSECT$OPC ; Select READSECT opcode (IOS) + out STO$OPCD + mvi b, 0 ; Byte counter = 256 + inir ; Read 256 byte + inir ; Read 256 byte + IF BANKED + POP PSW ; Restore previous bank + CALL ?BNKSL + JMP CHECKRD + ; -------------------------- + DSEG + ; -------------------------- + ENDIF + ; + ; Check for errors +CHECKRD: + mvi a, ERRDSK$OPC ; Select ERRDISK opcode (IOS) + out STO$OPCD + in EXC$RD$OPCD ; Read error code into A + ora a ; Set Z flag + pop h + pop b + rz ; Return with A = 0 (no error) + mvi a, 1 ; Set error code + ret ; Return with A = 1 (read error) + +;-------------------------------------------------------------------------------- + +; Set disk, track and sector routine for a read or write operation and load into +; HL the address in @DMA (used for the read/write operaton) + +setDTS: ; Select the disk, track and sector + ; + ; Select @ADRV host disk + lda @ADRV ; A = new disk + mov b, a ; B = new disk + lda lastDsk ; A = last disk number + cmp b ; Previous disk = new disk? + jrz setTrack ; Yes, jump to track selection + mvi a, SELDISK$OPC ; No, select SELDISK opcode (IOS) + out STO$OPCD + mov a, b ; A = new disk + out EXC$WR$OPCD + sta lastDsk ; Update last disk number + ; + ; Select @TRK host track +setTrack: + mvi a, SELTRCK$OPC ; Select SELTRACK opcode (IOS) + out STO$OPCD + lda @TRK ; Select the track number LSB + out EXC$WR$OPCD + lda @TRK + 1 ; Select the track number MSB + out EXC$WR$OPCD + ; + ; Select @SECT host sector + mvi a, SELSECT$OPC ; Select SELSECT opcode (IOS) + out STO$OPCD + lda @SECT ; Select the sector number (LSB only) + out EXC$WR$OPCD + ; + ; Load into HL the address in @DMA + LHLD @DMA + ret + + END \ No newline at end of file diff --git a/software/CPM/CPM23_PLI/Z80.LIB b/software/CPM/CPM23_PLI/Z80.LIB new file mode 100644 index 0000000..4f29a00 --- /dev/null +++ b/software/CPM/CPM23_PLI/Z80.LIB @@ -0,0 +1,457 @@ +; @CHK MACRO USED FOR CHECKING 8 BIT DISPLACMENTS +; +@CHK MACRO ?DD ;; USED FOR CHECKING RANGE OF 8-BIT DISP.S + IF (?DD GT 7FH) AND (?DD LT 0FF80H) + 'DISPLACEMENT RANGE ERROR - Z80 LIB' + ENDIF + ENDM +LDX MACRO ?R,?D + @CHK ?D + DB 0DDH,?R*8+46H,?D + ENDM +LDY MACRO ?R,?D + @CHK ?D + DB 0FDH,?R*8+46H,?D + ENDM +STX MACRO ?R,?D + @CHK ?D + DB 0DDH,70H+?R,?D + ENDM +STY MACRO ?R,?D + @CHK ?D + DB 0FDH,70H+?R,?D + ENDM +MVIX MACRO ?N,?D + @CHK ?D + DB 0DDH,36H,?D,?N + ENDM +MVIY MACRO ?N,?D + @CHK ?D + DB 0FDH,36H,?D,?N + ENDM +LDAI MACRO + DB 0EDH,57H + ENDM +LDAR MACRO + DB 0EDH,5FH + ENDM +STAI MACRO + DB 0EDH,47H + ENDM +STAR MACRO + DB 0EDH,4FH + ENDM + +LXIX MACRO ?NNNN + DB 0DDH,21H + DW ?NNNN + ENDM +LXIY MACRO ?NNNN + DB 0FDH,21H + DW ?NNNN + ENDM +LDED MACRO ?NNNN + DB 0EDH,5BH + DW ?NNNN + ENDM +LBCD MACRO ?NNNN + DB 0EDH,4BH + DW ?NNNN + ENDM +LSPD MACRO ?NNNN + DB 0EDH,07BH + DW ?NNNN + ENDM +LIXD MACRO ?NNNN + DB 0DDH,2AH + DW ?NNNN + ENDM +LIYD MACRO ?NNNN + DB 0FDH,2AH + DW ?NNNN + ENDM +SBCD MACRO ?NNNN + DB 0EDH,43H + DW ?NNNN + ENDM +SDED MACRO ?NNNN + DB 0EDH,53H + DW ?NNNN + ENDM +SSPD MACRO ?NNNN + DB 0EDH,73H + DW ?NNNN + ENDM +SIXD MACRO ?NNNN + DB 0DDH,22H + DW ?NNNN + ENDM +SIYD MACRO ?NNNN + DB 0FDH,22H + DW ?NNNN + ENDM +SPIX MACRO + DB 0DDH,0F9H + ENDM +SPIY MACRO + DB 0FDH,0F9H + ENDM +PUSHIX MACRO + DB 0DDH,0E5H + ENDM +PUSHIY MACRO + DB 0FDH,0E5H + ENDM +POPIX MACRO + DB 0DDH,0E1H + ENDM +POPIY MACRO + DB 0FDH,0E1H + ENDM +EXAF MACRO + DB 08H + ENDM +EXX MACRO + DB 0D9H + ENDM +XTIX MACRO + DB 0DDH,0E3H + ENDM +XTIY MACRO + DB 0FDH,0E3H + ENDM + +LDI MACRO + DB 0EDH,0A0H + ENDM +LDIR MACRO + DB 0EDH,0B0H + ENDM +LDD MACRO + DB 0EDH,0A8H + ENDM +LDDR MACRO + DB 0EDH,0B8H + ENDM +CCI MACRO + DB 0EDH,0A1H + ENDM +CCIR MACRO + DB 0EDH,0B1H + ENDM +CCD MACRO + DB 0EDH,0A9H + ENDM +CCDR MACRO + DB 0EDH,0B9H + ENDM + +ADDX MACRO ?D + @CHK ?D + DB 0DDH,86H,?D + ENDM +ADDY MACRO ?D + @CHK ?D + DB 0FDH,86H,?D + ENDM +ADCX MACRO ?D + @CHK ?D + DB 0DDH,8EH,?D + ENDM +ADCY MACRO ?D + @CHK ?D + DB 0FDH,8EH,?D + ENDM +SUBX MACRO ?D + @CHK ?D + DB 0DDH,96H,?D + ENDM +SUBY MACRO ?D + @CHK ?D + DB 0FDH,96H,?D + ENDM +SBCX MACRO ?D + @CHK ?D + DB 0DDH,9EH,?D + ENDM +SBCY MACRO ?D + @CHK ?D + DB 0FDH,9EH,?D + ENDM +ANDX MACRO ?D + @CHK ?D + DB 0DDH,0A6H,?D + ENDM +ANDY MACRO ?D + @CHK ?D + DB 0FDH,0A6H,?D + ENDM +XORX MACRO ?D + @CHK ?D + DB 0DDH,0AEH,?D + ENDM +XORY MACRO ?D + @CHK ?D + DB 0FDH,0AEH,?D + ENDM +ORX MACRO ?D + @CHK ?D + DB 0DDH,0B6H,?D + ENDM +ORY MACRO ?D + @CHK ?D + DB 0FDH,0B6H,?D + ENDM +CMPX MACRO ?D + @CHK ?D + DB 0DDH,0BEH,?D + ENDM +CMPY MACRO ?D + @CHK ?D + DB 0FDH,0BEH,?D + ENDM +INRX MACRO ?D + @CHK ?D + DB 0DDH,34H,?D + ENDM +INRY MACRO ?D + @CHK ?D + DB 0FDH,34H,?D + ENDM +DCRX MACRO ?D + @CHK ?D + DB 0DDH,035H,?D + ENDM +DCRY MACRO ?D + @CHK ?D + DB 0FDH,35H,?D + ENDM + +NEG MACRO + DB 0EDH,44H + ENDM +IM0 MACRO + DB 0EDH,46H + ENDM +IM1 MACRO + DB 0EDH,56H + ENDM +IM2 MACRO + DB 0EDH,5EH + ENDM + + +BC EQU 0 +DE EQU 2 +HL EQU 4 +IX EQU 4 +IY EQU 4 +DADC MACRO ?R + DB 0EDH,?R*8+4AH + ENDM +DSBC MACRO ?R + DB 0EDH,?R*8+42H + ENDM +DADX MACRO ?R + DB 0DDH,?R*8+09H + ENDM +DADY MACRO ?R + DB 0FDH,?R*8+09H + ENDM +INXIX MACRO + DB 0DDH,23H + ENDM +INXIY MACRO + DB 0FDH,23H + ENDM +DCXIX MACRO + DB 0DDH,2BH + ENDM +DCXIY MACRO + DB 0FDH,2BH + ENDM + +BIT MACRO ?N,?R + DB 0CBH,?N*8+?R+40H + ENDM +SETB MACRO ?N,?R + DB 0CBH,?N*8+?R+0C0H + ENDM +RES MACRO ?N,?R + DB 0CBH,?N*8+?R+80H + ENDM + +BITX MACRO ?N,?D + @CHK ?D + DB 0DDH,0CBH,?D,?N*8+46H + ENDM +BITY MACRO ?N,?D + @CHK ?D + DB 0FDH,0CBH,?D,?N*8+46H + ENDM +SETX MACRO ?N,?D + @CHK ?D + DB 0DDH,0CBH,?D,?N*8+0C6H + ENDM +SETY MACRO ?N,?D + @CHK ?D + DB 0FDH,0CBH,?D,?N*8+0C6H + ENDM +RESX MACRO ?N,?D + @CHK ?D + DB 0DDH,0CBH,?D,?N*8+86H + ENDM +RESY MACRO ?N,?D + @CHK ?D + DB 0FDH,0CBH,?D,?N*8+86H + ENDM + +JR MACRO ?N + DB 18H,?N-$-1 + ENDM +JRC MACRO ?N + DB 38H,?N-$-1 + ENDM +JRNC MACRO ?N + DB 30H,?N-$-1 + ENDM +JRZ MACRO ?N + DB 28H,?N-$-1 + ENDM +JRNZ MACRO ?N + DB 20H,?N-$-1 + ENDM +DJNZ MACRO ?N + DB 10H,?N-$-1 + ENDM + +PCIX MACRO + DB 0DDH,0E9H + ENDM +PCIY MACRO + DB 0FDH,0E9H + ENDM + +RETI MACRO + DB 0EDH,4DH + ENDM +RETN MACRO + DB 0EDH,45H + ENDM + +INP MACRO ?R + DB 0EDH,?R*8+40H + ENDM +OUTP MACRO ?R + DB 0EDH,?R*8+41H + ENDM +INI MACRO + DB 0EDH,0A2H + ENDM +INIR MACRO + DB 0EDH,0B2H + ENDM +IND MACRO + DB 0EDH,0AAH + ENDM +INDR MACRO + DB 0EDH,0BAH + ENDM +OUTI MACRO + DB 0EDH,0A3H + ENDM +OUTIR MACRO + DB 0EDH,0B3H + ENDM +OUTD MACRO + DB 0EDH,0ABH + ENDM +OUTDR MACRO + DB 0EDH,0BBH + ENDM + + +RLCR MACRO ?R + DB 0CBH, 00H + ?R + ENDM +RLCX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 06H + ENDM +RLCY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 06H + ENDM +RALR MACRO ?R + DB 0CBH, 10H+?R + ENDM +RALX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 16H + ENDM +RALY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 16H + ENDM +RRCR MACRO ?R + DB 0CBH, 08H + ?R + ENDM +RRCX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 0EH + ENDM +RRCY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 0EH + ENDM +RARR MACRO ?R + DB 0CBH, 18H + ?R + ENDM +RARX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 1EH + ENDM +RARY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 1EH + ENDM +SLAR MACRO ?R + DB 0CBH, 20H + ?R + ENDM +SLAX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 26H + ENDM +SLAY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 26H + ENDM +SRAR MACRO ?R + DB 0CBH, 28H+?R + ENDM +SRAX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 2EH + ENDM +SRAY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 2EH + ENDM +SRLR MACRO ?R + DB 0CBH, 38H + ?R + ENDM +SRLX MACRO ?D + @CHK ?D + DB 0DDH, 0CBH, ?D, 3EH + ENDM +SRLY MACRO ?D + @CHK ?D + DB 0FDH, 0CBH, ?D, 3EH + ENDM +RLD MACRO + DB 0EDH, 6FH + ENDM +RRD MACRO + DB 0EDH, 67H + ENDM + \ No newline at end of file diff --git a/software/CPM/PLM80/COMMON.LIT b/software/CPM/PLM80/COMMON.LIT new file mode 100644 index 0000000..c40232f --- /dev/null +++ b/software/CPM/PLM80/COMMON.LIT @@ -0,0 +1,32 @@ +/* Some useful defines for the remote program */ + +declare lit literally 'literally'; +declare word lit 'address'; +declare pointer lit 'address'; +declare connection lit 'address'; + +declare cr lit '0dh', + lf lit '0ah', + TAB lit '09h', + SOH lit '01h', + STX lit '02h', + ETX lit '03h', + EOT lit '04h', + ACK lit '06h', + NAK lit '15h', + XON lit '11h', + XOF lit '13h', + CAN lit '18h', + SUB lit '1ah', + RUBOUT lit '7fh'; + +declare forever lit 'while 1'; + +declare false lit '0', + true lit 'not false'; + +declare read$only lit '1', + write$only lit '2', + read$write lit '3'; + +$list diff --git a/software/CPM/PLM80/CONV86 b/software/CPM/PLM80/CONV86 new file mode 100644 index 0000000..b4ee6ba Binary files /dev/null and b/software/CPM/PLM80/CONV86 differ diff --git a/software/CPM/PLM80/FPAL.LIB b/software/CPM/PLM80/FPAL.LIB new file mode 100644 index 0000000..eadd36e Binary files /dev/null and b/software/CPM/PLM80/FPAL.LIB differ diff --git a/software/CPM/PLM80/HEXOBJ b/software/CPM/PLM80/HEXOBJ new file mode 100644 index 0000000..136e296 Binary files /dev/null and b/software/CPM/PLM80/HEXOBJ differ diff --git a/software/CPM/PLM80/ISIS.DOC b/software/CPM/PLM80/ISIS.DOC new file mode 100644 index 0000000..b01e041 --- /dev/null +++ b/software/CPM/PLM80/ISIS.DOC @@ -0,0 +1,59 @@ + + + Instructions for ISIS environment V1.0 + ====================================== + +The ISIS environment is designed to allow 8080 based Intel tools to run on +an 8086 PCDOS based system. The ISIS environment does not support all ISIS +calls, but sufficient to run 8051 translators and utilities. (If the program +uses an unsupported ISIS call an error message is generated). + + +DOS instructions +---------------- + +Load the software(ISIS) onto the harddisk. If ISIS is installed in the DOS +search path it will be directly loadable by entering "ISIS". + +Before entering ISIS, logical names must be set to match any ISIS disk drives +used by the ISIS tools. This includes :F0: - the ISIS environment does NOT +default to the current drive. As with 8080 ISIS, filenames without a drive +prefix are directed to :F0:. + + +C>SET :F0:=\ISIS /* make sure there is no before the "=" */ +C>SET :F1:=\BITBUS + +C>ISIS /* invoke ISIS emulator */ +DOS ISIS Environment X003 +=ASM51 :F1:SAMP1.A51 /* enter ISIS commands */ +... +... +=EXIT /* return to DOS */ + + +The ISIS environment will also run under DOS in batch mode + +Command file (DEMO.CMD) contains: + +ASM51 :F1:SAMP1.A51 +ASM51 :F1:SAMP2.A51 +ASM51 :F1:SAMP3.A51 +RL51 :F1:SAMP1.OBJ, & +:F1:SAMP2.OBJ, & +:F1:SAMP3.OBJ TO :F1:SAMPLE +EXIT /* must include EXIT since all program + input must be in command file + otherwise DOS will wait forever */ + +To invoke the command file + +C>ISIS < DEMO.CMD /* This could be part of a batch job */ + + or will abort the ISIS environment. You will need to +enter also if the ISIS environment is at the prompt level. Also the +command "BREAK ON" should be included in the AUTOEXEC.BAT file to permit DOS +to recognise all the time (not just when performing DOS calls). + + +Known Bugs/Problems: None diff --git a/software/CPM/PLM80/ISIS.EXE b/software/CPM/PLM80/ISIS.EXE new file mode 100644 index 0000000..75b4e6d Binary files /dev/null and b/software/CPM/PLM80/ISIS.EXE differ diff --git a/software/CPM/PLM80/ISIS.EXT b/software/CPM/PLM80/ISIS.EXT new file mode 100644 index 0000000..6028c9a --- /dev/null +++ b/software/CPM/PLM80/ISIS.EXT @@ -0,0 +1,114 @@ +isis: procedure (type, parameter$ptr) external; + declare type byte, + parameter$ptr address; +end isis; + +open: procedure (conn$p, path$p, access, echo, status$p) external; + declare (conn$p, path$p, access, echo, status$p) address; +end open; + +close: procedure (conn, status$p) external; + declare (conn, status$p) address; +end close; + +read: procedure (conn, buff$p, count, actual$p, status$p) external; + declare (conn, buff$p, count, actual$p, status$p) address; +end read; + +write: procedure (conn, buff$p, count, status$p) external; + declare (conn, buff$p, count, status$p) address; +end write; + +seek: procedure (conn, mode, block$p, byte$p, status$p) external; + declare (conn, mode, block$p, byte$p, status$p) address; +end seek; + +rescan: procedure (conn, status$p) external; + declare (conn, status$p) address; +end rescan; + +spath: procedure (path$p, info$p, status$p) external; + declare (path$p, info$p, status$p) address; +end spath; + +delete: procedure (path$p, status$p) external; + declare (path$p, status$p) address; +end delete; + +rename: procedure (old$p, new$p, status$p) external; + declare (old$p, new$p, status$p) address; +end rename; + +attrib: procedure (path$p, attrib, on$off, status$p) external; + declare (path$p, attrib, on$off, status$p) address; +end attrib; + +consol: procedure (ci$p, co$p, status$p) external; + declare (ci$p, co$p, status$p) address; +end consol; + +load: procedure (path$p, load$offset, switch, entry$p, status$p) external; + declare (path$p, load$offset, switch, entry$p, status$p) address; +end load; + +whocon: procedure (conn, buff$p) external; + declare (conn, buff$p) address; +end whocon; + +error: procedure (error$num) external; + declare (error$num) address; +end error; + +de$time: procedure (dt$p, status$p) external; + declare (dt$p, status$p) address; +end de$time; + +filinf: procedure (file$table$p, mode, file$info$p, status$p) external; + declare (file$table$p, file$info$p, status$p) address, + mode byte; +end filinf; + +getd: procedure (did, conn$p, count, actual$p, table$p, status$p) external; + declare (did, conn$p, count, actual$p, table$p, status$p) address; +end getd; + +exit: procedure external; +end exit; + +ci: procedure byte external; +end ci; + +co: procedure (char) external; + declare (char) byte; +end co; + +ri: procedure byte external; +end ri; + +po: procedure (char) external; + declare (char) byte; +end po; + +lo: procedure (char) external; + declare (char) byte; +end lo; + +csts: procedure byte external; +end csts; + +iodef: procedure (type, entry) external; + declare type byte, + entry address; +end iodef; + +iochk: procedure byte external; +end iochk; + +ioset: procedure (value) external; + declare value byte; +end ioset; + +memck: procedure address external; +end memck; + +$list diff --git a/software/CPM/PLM80/IXREF b/software/CPM/PLM80/IXREF new file mode 100644 index 0000000..d7d1d30 Binary files /dev/null and b/software/CPM/PLM80/IXREF differ diff --git a/software/CPM/PLM80/LIB b/software/CPM/PLM80/LIB new file mode 100644 index 0000000..2913c75 Binary files /dev/null and b/software/CPM/PLM80/LIB differ diff --git a/software/CPM/PLM80/LINK b/software/CPM/PLM80/LINK new file mode 100644 index 0000000..f44e717 Binary files /dev/null and b/software/CPM/PLM80/LINK differ diff --git a/software/CPM/PLM80/LINK.OVL b/software/CPM/PLM80/LINK.OVL new file mode 100644 index 0000000..31aa7a2 Binary files /dev/null and b/software/CPM/PLM80/LINK.OVL differ diff --git a/software/CPM/PLM80/LOCATE b/software/CPM/PLM80/LOCATE new file mode 100644 index 0000000..0020ac7 Binary files /dev/null and b/software/CPM/PLM80/LOCATE differ diff --git a/software/CPM/PLM80/OBJHEX b/software/CPM/PLM80/OBJHEX new file mode 100644 index 0000000..3ebad01 Binary files /dev/null and b/software/CPM/PLM80/OBJHEX differ diff --git a/software/CPM/PLM80/PLM51.LIB b/software/CPM/PLM80/PLM51.LIB new file mode 100644 index 0000000..ea1038a Binary files /dev/null and b/software/CPM/PLM80/PLM51.LIB differ diff --git a/software/CPM/PLM80/PLM80 b/software/CPM/PLM80/PLM80 new file mode 100644 index 0000000..12872f5 Binary files /dev/null and b/software/CPM/PLM80/PLM80 differ diff --git a/software/CPM/PLM80/PLM80.COM b/software/CPM/PLM80/PLM80.COM new file mode 100644 index 0000000..12872f5 Binary files /dev/null and b/software/CPM/PLM80/PLM80.COM differ diff --git a/software/CPM/PLM80/PLM80.EXE b/software/CPM/PLM80/PLM80.EXE new file mode 100644 index 0000000..ea84ddf Binary files /dev/null and b/software/CPM/PLM80/PLM80.EXE differ diff --git a/software/CPM/PLM80/PLM80.LIB b/software/CPM/PLM80/PLM80.LIB new file mode 100644 index 0000000..ebb685a Binary files /dev/null and b/software/CPM/PLM80/PLM80.LIB differ diff --git a/software/CPM/PLM80/PLM80.OV0 b/software/CPM/PLM80/PLM80.OV0 new file mode 100644 index 0000000..19f0a5d Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV0 differ diff --git a/software/CPM/PLM80/PLM80.OV1 b/software/CPM/PLM80/PLM80.OV1 new file mode 100644 index 0000000..a5c0ad2 Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV1 differ diff --git a/software/CPM/PLM80/PLM80.OV2 b/software/CPM/PLM80/PLM80.OV2 new file mode 100644 index 0000000..35ada06 Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV2 differ diff --git a/software/CPM/PLM80/PLM80.OV3 b/software/CPM/PLM80/PLM80.OV3 new file mode 100644 index 0000000..9ee405f Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV3 differ diff --git a/software/CPM/PLM80/PLM80.OV4 b/software/CPM/PLM80/PLM80.OV4 new file mode 100644 index 0000000..d89058c Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV4 differ diff --git a/software/CPM/PLM80/PLM80.OV5 b/software/CPM/PLM80/PLM80.OV5 new file mode 100644 index 0000000..42d4e4e Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV5 differ diff --git a/software/CPM/PLM80/PLM80.OV6 b/software/CPM/PLM80/PLM80.OV6 new file mode 100644 index 0000000..7873ff3 Binary files /dev/null and b/software/CPM/PLM80/PLM80.OV6 differ diff --git a/software/CPM/PLM80/SUBMIT b/software/CPM/PLM80/SUBMIT new file mode 100644 index 0000000..d9a6e2f Binary files /dev/null and b/software/CPM/PLM80/SUBMIT differ diff --git a/software/CPM/PLM80/SYSTEM.LIB b/software/CPM/PLM80/SYSTEM.LIB new file mode 100644 index 0000000..c6e06ef Binary files /dev/null and b/software/CPM/PLM80/SYSTEM.LIB differ diff --git a/software/CPM/cpm3/Makefile b/software/CPM/cpm3/Makefile new file mode 100644 index 0000000..67a5bf9 --- /dev/null +++ b/software/CPM/cpm3/Makefile @@ -0,0 +1,320 @@ +# +# Unix Makefile for CP/M 3.1 +# +OBJS=mcd80a.obj mcd80f.obj parse.obj +# +HEXS=copysys.hex ccp3.hex ccpdate.hex date.hex device.hex dir.hex \ + dump.hex ed.hex erase.hex get.hex gencom.hex gencpm.hex help.hex \ + hexcom.hex patch.hex pip.hex put.hex rename.hex set.hex setdef.hex \ + show.hex submit.hex type.hex minhlp.hex + +OBJS=copysys.obj ccp3.obj ccpdate.obj date.obj device.obj dir.obj \ + dump.obj ed.obj erase.obj get.obj gencom.obj gencpm.obj help.obj \ + objcom.obj patch.obj pip.obj put.obj rename.obj set.obj setdef.obj \ + show.obj submit.obj type.obj minhlp.obj + +BLKS=date device dir disp dpb80 ed erase gencom gencpm get hexcom hexpat \ + help main80 minhlp pip put rename scan search set setdef show sort \ + submit timest type util + +MCOMS = copysys.com ccp.com date.com device.com dir.com dump.com ed.com \ + erase.com get.com gencom.com gencpm.com help.com hexcom.com patch.com \ + pip.com put.com rename.com set.com setdef.com show.com \ + submit.com type.com sid.com #save.com + +BDOS = resbdos3.spr bdos3.spr bnkbdos3.spr + +ZXCC = zxcc +THAMES = ./runthames + +MAC=mac.com +RMAC=rmac.com +LINK=drlink.com + +BINARIES= bdos3.spr date.com erase.com help.hlp README \ + setdef.com bnkbdos3.spr device.com gencom.com hexcom.com \ + rename.com show.com ccp.com dir.com gencpm.com \ + patch.com resbdos3.spr submit.com copysys.com dump.com \ + get.com pip.com save.com type.com cpmldr.rel \ + ed.com help.com put.com set.com sid.com + +SOURCES= assemble.txt disp.plm hexcom.asm parse.asm search.plm \ + bdos30.asm dpb80.plm hexcom.c patch.asm setbuf.plm \ + bios.bin dpb.lit hexpat.c pip.plm setdef.plm \ + bioskrnl.asm drvtbl.asm inpout.asm plibios3.asm set.plm \ + boot.asm dump.asm ldrlwr.asm plibios.asm show.plm \ + callvers.asm echovers.asm _libios3.asm plidio.asm sopt.dcl \ + ccp3.asm ed.plm _lidio.asm prs0mov.asm sopt.inc \ + ccp3org.asm drlink.com prs1asm.asm sort.plm \ + ccpdate.asm erase.plm loader3.asm prs2mon.asm submit.plm \ + chario.asm fcb.lit mac.com putf.asm subrsx.asm \ + comlit.lit fd1797sd.asm main80.plm put.plm timest.plm \ + conbdos.asm finfo.lit main.plm putrsx.asm type.plm \ + copyrt.lit format.lit makedate.lib random.asm _ump.asm \ + copysys.asm gencom.plm Makefile README util.plm \ + cpmbdos1.asm gencpm.plm making.txt rename.plm utl0mov.asm \ + cpmbdos2.asm getdef.plm mcd80a.asm resbdos.asm utl1hst.asm \ + cpmldr.asm getf.asm mcd80f.asm rmac.com utl2trc.asm \ + crdef.plm get.plm minhlp.plm save.asm vers.lit \ + date.plm getrsx.asm mon.plm scan.lit xfcb.lit \ + datmod.asm getrsx.lib move.asm scan.plm \ + device.plm help.dat newpip.plm scb.asm \ + dirlbl.asm help.plm _opysys.asm search.lit runthames + + +all: $(MCOMS) $(BDOS) cpmldr.rel help.hlp + +zip: cpm3src_unix.zip cpm3bin_unix.zip + +cpm3src_unix.zip: $(SOURCES) + zip $@ $(SOURCES) + +cpm3bin_unix.zip: $(BINARIES) + zip $@ $(BINARIES) + +############################################################################ +# +# Build tools +# +hexcom: hexcom.c + ${CC} -o hexcom hexcom.c + +hexpat: hexpat.c + ${CC} -o hexpat hexpat.c + +############################################################################## +# +# Help +# +help.hlp: help.dat minhlp.com + $(ZXCC) minhlp.com -[CREATE] +# + + +############################################################################## +# +# Specific build rules +# +# The redirection to CCPPHASE.* produces two lists of addresses (one in +# CCP3.COM and one in LOADER3.PRL) which should match. +# + +loader3.rel: loader3.asm + $(ZXCC) $(RMAC) loader3 >ccpphase.lst + +ccp3.hex: ccp3.asm + $(ZXCC) $(MAC) ccp3 >> ccpphase.lst + +ccp.com: loader3d.tmp hexpat ccpdate.hex + ./hexpat $< $@ < ccpdate.hex + +loader3d.tmp: loader3c.tmp hexpat ccp3.hex + ./hexpat $< $@ < ccp3.hex + +loader3c.tmp: loader3a.tmp loader3b.tmp + cat loader3a.tmp loader3b.tmp > $@ + +# Shave the header off loader3.prl to get the loader image +loader3a.tmp: loader3.prl + dd if=loader3.prl of=loader3a.tmp bs=128 skip=2 + +# This empty space will be overwritten by ccp3.hex +loader3b.tmp: + dd if=/dev/zero of=loader3b.tmp bs=128 count=19 + +dir.tra: dir.mod + $(THAMES) :F3:locate $< code\(0100h\) stacksize\(50\) map print\($@\) + +dir.mod: main80 scan search sort disp dpb80 util timest mcd80a.obj + $(THAMES) :F3:link mcd80a.obj,main80,scan,search,sort,disp,util,dpb80,timest,:F1:plm80.lib to dir.mod + +erase.mod: erase.obj parse.obj mcd80a.obj + $(THAMES) :F3:link mcd80a.obj,parse.obj,$<,:F1:plm80.lib to $@ + +gencom.mod: gencom.obj parse.obj mcd80a.obj + $(THAMES) :F3:link mcd80a.obj,parse.obj,$<,:F1:plm80.lib to $@ + +gencpm.mod: gencpm.obj setbuf.obj getdef.obj crdef.obj ldrlwr.obj \ + mcd80f.obj datmod.obj + $(THAMES) :F3:link mcd80f.obj,$<,setbuf.obj,getdef.obj,crdef.obj,ldrlwr.obj,datmod.obj,:F1:plm80.lib to $@ + +get.mod: get.obj mcd80a.obj parse.obj getf.obj + $(THAMES) :F3:link mcd80a.obj,$<,parse.obj,getf.obj,:F1:plm80.lib to $@ + +get.com: get.hex getrsx.rsx gencom.com hexcom + ./hexcom $@ <$< + cp getrsx.rsx get.rsx + $(ZXCC) gencom.com $@ get.rsx + +get.rsx: getrsx.rel + $(ZXCC) $(LINK) getrsx +-[OP] + mv -f getrsx.prl $@ + +pip.mod: pip.obj mcd80f.obj inpout.obj + $(THAMES) :F3:link mcd80f.obj,inpout.obj,$<,:F1:plm80.lib to $@ + +put.mod: put.obj mcd80a.obj parse.obj putf.obj + $(THAMES) :F3:link mcd80a.obj,$<,parse.obj,putf.obj,:F1:plm80.lib to $@ + +put.com: put.hex put.rsx gencom.com hexcom + ./hexcom $@ <$< + $(ZXCC) gencom.com $@ put.rsx + +put.rsx: putrsx.rel + $(ZXCC) $(LINK) putrsx +-[OP] + mv -f putrsx.prl $@ + +save.com: save.rsx gencom.com + rm -f $@ + $(ZXCC) gencom save +-[NULL] + +set.com: set.hex dirlbl.rsx gencom.com hexcom + ./hexcom $@ <$< + $(ZXCC) gencom.com $@ dirlbl.rsx + +sid.com: hexpat sid.spr prs0mov.hex + ./hexpat sid.spr $@ $@ + +cpmbdos.asm: cpmbdos2.asm conbdos.asm bdos30.asm makedate.lib + cat cpmbdos2.asm conbdos.asm bdos30.asm > $@ + +# Bits of DIR +main80: main80.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +scan: scan.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +search: search.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +sort: sort.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +disp: disp.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +dpb80: dpb80.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +util: util.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +timest: timest.plm + $(THAMES) :F1:plm80 $< debug pagewidth\(130\) optimize object\($@\) + +############################## +# +# SID +# +sid.spr: prs1asm.rel prs2mon.rel + $(ZXCC) $(LINK) sid.spr +-= +prs1asm +-, +prs2mon +-[OS] + +prs0mov.hex: prs0mov.asm makedate.lib + $(ZXCC) $(MAC) prs0mov + +prs1asm.rel: prs1asm.asm + $(ZXCC) $(RMAC) prs1asm + +prs2mon.rel: prs2mon.asm + $(ZXCC) $(RMAC) prs2mon + +############################################################################## +# +# Generic build rules +# + +%.obj: %.asm + $(THAMES) :F2:asm80 $< debug + + +########################################################################### +# +# COM files from hex files +# +%.com: %.hex hexcom + ./hexcom $@ < $< + +########################################################################### +# +# HEX files from asm source +# +%.hex: %.asm makedate.lib + $(ZXCC) $(MAC) `basename $< .asm` + +########################################################################### +# +# HEX files from PL/M source +# +%.hex: %.tra + $(THAMES) :F3:objhex `basename $< .tra` to $@ + +# The "%.tra" rule also builds "%", which is what objhex actually uses, but +# I couldn't get a bare % rule to work. +%.tra: %.mod + $(THAMES) :F3:locate $< code\(0100h\) stacksize\(100\) map print\($@\) + +%.mod: %.obj mcd80a.obj + $(THAMES) :F3:link mcd80a.obj,$<,:F1:plm80.lib to $@ + +%.obj: %.plm + $(THAMES) :F1:plm80 $< optimize debug + + +########################################################################### +# +# PRL and RSX files from .REL files +# +%.prl: %.rel + $(ZXCC) $(LINK) `basename $< .rel` +-[OP] + +%.spr: %.rel loader*.tmp + $(ZXCC) $(LINK) `basename $< .rel` +-[OS] + +%.rsx: %.rel + $(ZXCC) $(LINK) `basename $< .rel` +-[OP] + mv -f `basename $< .rel`.prl `basename $< .rel`.rsx + +%.rel: %.asm + $(ZXCC) $(RMAC) `basename $< .asm` + +# +# +# +clean: + rm -f $(MCOMS) $(HEXS) $(BLKS) *.lst *.rel *.sym *.tra *.rsx *.spr *.hex \ + *.mod *.obj loader*.tmp help.hlp diff --git a/software/CPM/cpm3/_libios3.asm b/software/CPM/cpm3/_libios3.asm new file mode 100644 index 0000000..ee0dfdb --- /dev/null +++ b/software/CPM/cpm3/_libios3.asm @@ -0,0 +1,152 @@ + name 'BIOSMOD' + title 'Direct BIOS Calls From PL/I-80 for CP/M 3.0' +; +;*********************************************************** +;* * +;* bios calls from pl/i for track, sector io * +;* * +;*********************************************************** + public settrk ;set track number + public setsec ;set sector number + public rdsec ;read sector + public wrsec ;write sector + public seldsk ;select disk & return the addr(DPH) + public sectrn ;translate sector # given translate table + public bstdma ;set dma + public bflush ;flush BIOS deblocking buffers +; +; + extrn ?boot ;system reboot entry point + extrn ?bdos ;bdos entry point +; +; utility functions +; +;*********************************************************** +;*********************************************************** +;* * +;* general purpose routines used upon entry * +;* * +;*********************************************************** +; +; +getp2: ;get single word value to DE + mov e,m + inx h + mov d,m + inx h + push h + xchg + mov e,m + inx h + mov d,m + pop h + ret +; +; +;*********************************************************** +;* * +;*********************************************************** +settrk: ;set track number 0-76, 0-65535 in BC + ;1-> track # + call getp2 + xchg + shld BCREG + mvi a,0ah + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +setsec: ;set sector number 1 - sectors per track + ;1-> sector # + call getp2 + xchg + shld BCREG + mvi a,0bh + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +rdsec: ;read current sector into sector at dma addr + ;returns 0 if no errors + ; 1 non-recoverable error + mvi a,0dh + jmp gobios +;*********************************************************** +;* * +;*********************************************************** +wrsec: ;writes contents of sector at dma addr to current sector + ;returns 0 errors occured + ; 1 non-recoverable error + call getp2 + xchg + shld BCREG + mvi a,0eh + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +; +seldsk: ; selects disk + + call getp2 + mov a,e + sta BCREG + mvi a,9 + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +; +sectrn: ;translate sector # + call getp2 + xchg + shld BCREG + xchg + call getp2 + xchg + shld DEREG + mvi a,10h + jmp gobios +; +bstdma: ;set dma + call getp2 + xchg + shld BCREG + mvi a,0ch + jmp gobios +; +bflush: ;flush bios buffers + mvi a,24 + jmp gobios +; +; +;*********************************************************** +;*********************************************************** +;*********************************************************** +;* * +;* call BDOS * +;* * +;*********************************************************** +; +; +gobios: + sta FUNC ;load BIOS function # + lxi h,FUNC + xchg ; address of BIOSPB in DE + mvi c,032h ; BDOS function 50 call + jmp ?bdos +; +; +BIOSPB: dw FUNC +FUNC: db 0 +AREG: db 0 +BCREG: dw 0 +DEREG: dw 0 +HLREG: dw 0 +; + end + diff --git a/software/CPM/cpm3/_lidio.asm b/software/CPM/cpm3/_lidio.asm new file mode 100644 index 0000000..3c430c7 --- /dev/null +++ b/software/CPM/cpm3/_lidio.asm @@ -0,0 +1,607 @@ + name 'DIOMOD' + title 'Direct CP/M Calls From PL/I-80' +; +;*********************************************************** +;* * +;* cp/m calls from pl/i for direct i/o * +;* * +;*********************************************************** + public memptr ;return pointer to base of free mem + public memsiz ;return size of memory in bytes + public memwds ;return size of memory in words + public dfcb0 ;return address of default fcb 0 + public dfcb1 ;return address of default fcb 1 + public dbuff ;return address of default buffer + public reboot ;system reboot (#0) + public rdcon ;read console character (#1) + public wrcon ;write console character(#2) + public rdrdr ;read reader character (#3) + public wrpun ;write punch character (#4) + public wrlst ;write list character (#5) + public coninp ;direct console input (#6a) + public conout ;direct console output (#6b) + public rdstat ;read console status (#6c) + public getio ;get io byte (#8) + public setio ;set i/o byte (#9) + public wrstr ;write string (#10) + public rdbuf ;read console buffer (#10) + public break ;get console status (#11) + public vers ;get version number (#12) + public reset ;reset disk system (#13) + public select ;select disk (#14) + public open ;open file (#15) + public close ;close file (#16) + public sear ;search for file (#17) + public searn ;search for next (#18) + public delete ;delete file (#19) + public rdseq ;read file sequential mode (#20) + public wrseq ;write file sequential mode (#21) + public make ;create file (#22) + public rename ;rename file (#23) + public logvec ;return login vector (#24) + public curdsk ;return current disk number (#25) + public setdma ;set DMA address (#26) + public allvec ;return address of alloc vector (#27) + public wpdisk ;write protect disk (#28) + public rovec ;return read/only vector (#29) + public filatt ;set file attributes (#30) + public getdpb ;get base of disk parm block (#31) + public getusr ;get user code (#32a) + public setusr ;set user code (#32b) + public rdran ;read random (#33) + public wrran ;write random (#34) + public filsiz ;random file size (#35) + public setrec ;set random record pos (#36) + public resdrv ;reset drive (#37) + public wrranz ;write random, zero fill (#40) +; +; + extrn ?begin ;beginning of free list + extrn ?boot ;system reboot entry point + extrn ?bdos ;bdos entry point + extrn ?dfcb0 ;default fcb 0 + extrn ?dfcb1 ;default fcb 1 + extrn ?dbuff ;default buffer +; +;*********************************************************** +;* * +;* equates for interface to cp/m bdos * +;* * +;*********************************************************** +cr equ 0dh ;carriage return +lf equ 0ah ;line feed +eof equ 1ah ;end of file +; +readc equ 1 ;read character from console +writc equ 2 ;write console character +rdrf equ 3 ;reader input +punf equ 4 ;punch output +listf equ 5 ;list output function +diof equ 6 ;direct i/o, version 2.0 +getiof equ 7 ;get i/o byte +setiof equ 8 ;set i/o byte +printf equ 9 ;print string function +rdconf equ 10 ;read console buffer +statf equ 11 ;return console status +versf equ 12 ;get version number +resetf equ 13 ;system reset +seldf equ 14 ;select disk function +openf equ 15 ;open file function +closef equ 16 ;close file +serchf equ 17 ;search for file +serchn equ 18 ;search next +deletf equ 19 ;delete file +readf equ 20 ;read next record +writf equ 21 ;write next record +makef equ 22 ;make file +renamf equ 23 ;rename file +loginf equ 24 ;get login vector +cdiskf equ 25 ;get current disk number +setdmf equ 26 ;set dma function +getalf equ 27 ;get allocation base +wrprof equ 28 ;write protect disk +getrof equ 29 ;get r/o vector +setatf equ 30 ;set file attributes +getdpf equ 31 ;get disk parameter block +userf equ 32 ;set/get user code +rdranf equ 33 ;read random +wrranf equ 34 ;write random +filszf equ 35 ;compute file size +setrcf equ 36 ;set random record position +rsdrvf equ 37 ;reset drive function +wrrnzf equ 40 ;write random zero fill +; +; utility functions +;*********************************************************** +;* * +;* general purpose routines used upon entry * +;* * +;*********************************************************** +; +getp1: ;get single byte parameter to register e + mov e,m ;low (addr) + inx h + mov d,m ;high(addr) + xchg ;hl = .char + mov e,m ;to register e + ret +; +getp2: ;get single word value to DE +getp2i: ;(equivalent to getp2) + call getp1 + inx h + mov d,m ;get high byte as well + ret +; +getver: ;get cp/m or mp/m version number + push h ;save possible data adr + mvi c,versf + call ?bdos + pop h ;recall data addr + ret +; +chkv20: ;check for version 2.0 or greater + call getver + cpi 20 + rnc ;return if > 2.0 +; error message and stop + jmp vererr ;version error +; +chkv22: ;check for version 2.2 or greater + call getver + cpi 22h + rnc ;return if >= 2.2 +vererr: + ;version error, report and terminate + lxi d,vermsg + mvi c,printf + call ?bdos ;write message + jmp ?boot ;and reboot +vermsg: db cr,lf,'Later CP/M or MP/M Version Required$' +; +;*********************************************************** +;* * +;*********************************************************** +memptr: ;return pointer to base of free storage + lhld ?begin + ret +; +;*********************************************************** +;* * +;*********************************************************** +memsiz: ;return size of free memory in bytes + lhld ?bdos+1 ;base of bdos + xchg ;de = .bdos + lhld ?begin ;beginning of free storage + mov a,e ;low(.bdos) + sub l ;-low(begin) + mov l,a ;back to l + mov a,d ;high(.bdos) + sbb h + mov h,a ;hl = mem size remaining + ret +; +;*********************************************************** +;* * +;*********************************************************** +memwds: ;return size of free memory in words + call memsiz ;hl = size in bytes + mov a,h ;high(size) + ora a ;cy = 0 + rar ;cy = ls bit + mov h,a ;back to h + mov a,l ;low(size) + rar ;include ls bit + mov l,a ;back to l + ret ;with wds in hl +; +;*********************************************************** +;* * +;*********************************************************** +dfcb0: ;return address of default fcb 0 + lxi h,?dfcb0 + ret +; +;*********************************************************** +;* * +;*********************************************************** +dfcb1: ;return address of default fcb 1 + lxi h,?dfcb1 + ret +; +;*********************************************************** +;* * +;*********************************************************** +dbuff: ;return address of default buffer + lxi h,?dbuff + ret +; +;*********************************************************** +;* * +;*********************************************************** +reboot: ;system reboot (#0) + jmp ?boot +; +;*********************************************************** +;* * +;*********************************************************** +rdcon: ;read console character (#1) + ;return character value to stack + mvi c,readc + jmp chrin ;common code to read char +; +;*********************************************************** +;* * +;*********************************************************** +wrcon: ;write console character(#2) + ;1->char(1) + mvi c,writc ;console write function + jmp chrout ;to write the character +; +;*********************************************************** +;* * +;*********************************************************** +rdrdr: ;read reader character (#3) + mvi c,rdrf ;reader function +chrin: + ;common code for character input + call ?bdos ;value returned to A + pop h ;return address + push psw ;character to stack + inx sp ;delete flags + mvi a,1 ;character length is 1 + pchl ;back to calling routine +; +;*********************************************************** +;* * +;*********************************************************** +wrpun: ;write punch character (#4) + ;1->char(1) + mvi c,punf ;punch output function + jmp chrout ;common code to write chr +; +;*********************************************************** +;* * +;*********************************************************** +wrlst: ;write list character (#5) + ;1->char(1) + mvi c,listf ;list output function +chrout: + ;common code to write character + ;1-> character to write + call getp1 ;output char to register e + jmp ?bdos ;to write and return +; +;*********************************************************** +;* * +;*********************************************************** +coninp: ;perform console input, char returned in stack + lxi h,chrstr ;return address + push h ;to stack for return + lhld ?boot+1 ;base of bios jmp vector + lxi d,2*3 ;offset to jmp conin + dad d + pchl ;return to chrstr +; +chrstr: ;create character string, length 1 + pop h ;recall return address + push psw ;save character + inx sp ;delete psw + mvi a,1 ;length to a + pchl ;return to caller +; +;*********************************************************** +;* * +;*********************************************************** +conout: ;direct console output + ;1->char(1) + call getp1 ;get parameter + mov c,e ;character to c + lhld ?boot+1 ;base of bios jmp + lxi d,3*3 ;console output offset + dad d ;hl = .jmp conout + pchl ;return through handler +; +;*********************************************************** +;* * +;*********************************************************** +rdstat: ;direct console status read + lxi h,rdsret ;read status return + push h ;return to rdsret + lhld ?boot+1 ;base of jmp vector + lxi d,1*3 ;offset to .jmp const + dad d ;hl = .jmp const + pchl +; +;*********************************************************** +;* * +;*********************************************************** +getio: ;get io byte (#8) + mvi c,getiof + jmp ?bdos ;value returned to A +; +;*********************************************************** +;* * +;*********************************************************** +setio: ;set i/o byte (#9) + ;1->i/o byte + call getp1 ;new i/o byte to E + mvi c,setiof + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrstr: ;write string (#10) + ;1->addr(string) + call getp2 ;get parameter value to DE + mvi c,printf ;print string function + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +rdbuf: ;read console buffer (#10) + ;1->addr(buff) + call getp2i ;DE = .buff + mvi c,rdconf ;read console function + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +break: ;get console status (#11) + mvi c,statf + call ?bdos ;return through bdos +; +rdsret: ;return clean true value + ora a ;zero? + rz ;return if so + mvi a,0ffh ;clean true value + ret +; +;*********************************************************** +;* * +;*********************************************************** +vers: ;get version number (#12) + mvi c,versf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +reset: ;reset disk system (#13) + mvi c,resetf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +select: ;select disk (#14) + ;1->fixed(7) drive number + call getp1 ;disk number to E + mvi c,seldf + jmp ?bdos ;return through bdos +;*********************************************************** +;* * +;*********************************************************** +open: ;open file (#15) + ;1-> addr(fcb) + call getp2i ;fcb address to de + mvi c,openf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +close: ;close file (#16) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,closef + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +sear: ;search for file (#17) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,serchf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +searn: ;search for next (#18) + mvi c,serchn ;search next function + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +delete: ;delete file (#19) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,deletf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +rdseq: ;read file sequential mode (#20) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,readf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrseq: ;write file sequential mode (#21) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,writf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +make: ;create file (#22) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,makef + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +rename: ;rename file (#23) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,renamf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +logvec: ;return login vector (#24) + mvi c,loginf + jmp ?bdos ;return through BDOS +; +;*********************************************************** +;* * +;*********************************************************** +curdsk: ;return current disk number (#25) + mvi c,cdiskf + jmp ?bdos ;return value in A +; +;*********************************************************** +;* * +;*********************************************************** +setdma: ;set DMA address (#26) + ;1-> pointer (dma address) + call getp2 ;dma address to DE + mvi c,setdmf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +allvec: ;return address of allocation vector (#27) + mvi c,getalf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wpdisk: ;write protect disk (#28) + call chkv20 ;must be 2.0 or greater + mvi c,wrprof + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +rovec: ;return read/only vector (#29) + call chkv20 ;must be 2.0 or greater + mvi c,getrof + jmp ?bdos ;value returned in HL +; +;*********************************************************** +;* * +;*********************************************************** +filatt: ;set file attributes (#30) + ;1-> addr(fcb) + call chkv20 ;must be 2.0 or greater + call getp2i ;.fcb to DE + mvi c,setatf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +getdpb: ;get base of current disk parm block (#31) + call chkv20 ;check for 2.0 or greater + mvi c,getdpf + jmp ?bdos ;addr returned in HL +; +;*********************************************************** +;* * +;*********************************************************** +getusr: ;get user code to register A + call chkv20 ;check for 2.0 or greater + mvi e,0ffh ;to get user code + mvi c,userf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +setusr: ;set user code + call chkv20 ;check for 2.0 or greater + call getp1 ;code to E + mvi c,userf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +rdran: ;read random (#33) + ;1-> addr(fcb) + call chkv20 ;check for 2.0 or greater + call getp2i ;.fcb to DE + mvi c,rdranf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrran: ;write random (#34) + ;1-> addr(fcb) + call chkv20 ;check for 2.0 or greater + call getp2i ;.fcb to DE + mvi c,wrranf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +filsiz: ;compute file size (#35) + call chkv20 ;must be 2.0 or greater + call getp2 ;.fcb to DE + mvi c,filszf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +setrec: ;set random record position (#36) + call chkv20 ;must be 2.0 or greater + call getp2 ;.fcb to DE + mvi c,setrcf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +resdrv: ;reset drive function (#37) + ;1->drive vector - bit(16) + call chkv22 ;must be 2.2 or greater + call getp2 ;drive reset vector to DE + mvi c,rsdrvf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrranz: ;write random, zero fill function + ;1-> addr(fcb) + call chkv22 ;must be 2.2 or greater + call getp2i ;.fcb to DE + mvi c,wrrnzf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** + end diff --git a/software/CPM/cpm3/_opysys.asm b/software/CPM/cpm3/_opysys.asm new file mode 100644 index 0000000..9b941ba --- /dev/null +++ b/software/CPM/cpm3/_opysys.asm @@ -0,0 +1,835 @@ + title 'Copysys - updated sysgen program 6/82' +; System generation program +VERS equ 30 ;version x.x for CP/M x.x +; +;********************************************************** +;* * +;* * +;* Copysys source code * +;* * +;* * +;********************************************************** +; +FALSE equ 0 +TRUE equ not FALSE +; +; +NSECTS equ 26 ;no. of sectors +NTRKS equ 2 ;no. of systems tracks +NDISKS equ 4 ;no. of disks drives +SECSIZ equ 128 ;size of sector +LOG2SEC equ 7 ;LOG2 128 +SKEW equ 2 ;skew sector factor +; +FCB equ 005Ch ;location of FCB +FCBCR equ FCB+32 ;current record location +TPA equ 0100h ;Transient Program Area +LOADP equ 1000h ;LOAD Point for system +BDOS equ 05h ;DOS entry point +BOOT equ 00h ;reboot for system +CONI equ 1h ;console input function +CONO equ 2h ;console output function +SELD equ 14 ;select a disk +OPENF equ 15 ;disk open function +CLOSEF equ 16 ;open a file +DWRITF equ 21 ;Write func +MAKEF equ 22 ;mae a file +DELTEF equ 19 ;delete a file +DREADF equ 20 ;disk read function +DRBIOS equ 50 ;Direct BIOS call function +EIGHTY equ 080h ;value of 80 +CTLC equ 'C'-'@' ;ConTroL C +Y equ 89 ;ASCII value of Y +; +MAXTRY equ 01 ;maximum number of tries +CR equ 0Dh ;Carriage Return +LF equ 0Ah ;Line Feed +STACKSIZE equ 016h ;size of local stack +; +WBOOT equ 01 ;address of warm boot +; +SELDSK equ 9 ;Bios func #9 SELect DiSK +SETTRK equ 10 ;BIOS func #10 SET TRacK +SETSEC equ 11 ;BIOS func #11 SET SECtor +SETDMA equ 12 ;BIOS func #12 SET DMA address +READF equ 13 ;BIOS func #13 READ selected sector +WRITF equ 14 ;BIOS func #14 WRITe selected sector + +; + org TPA ;Transient Program Area + jmp START + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0 + db 0,0,0 + db 'COPYRIGHT 1982, ' + db 'DIGITAL RESEARCH' + db '151282' + db 0,0,0,0 + db '654321' +; +; Translate table-sector numbers are translated here to decrease +; the systen tie for missed sectors when slow controllers are +; involved. Translate takes place according to the "SKEW" factor +; set above. +; +OST: db NTRKS ;operating system tracks +SPT: db NSECTS ;sectors per track +TRAN: +TRELT set 1 +TRBASE set 1 + rept NSECTS + db TRELT ;generate first/next sector +TRELT set TRELT+SKEW + if TRELT gt NSECTS +TRBASE set TRBASE+1 +TRELT set TRBASE + endif + endm +; +; Now leave space for extensions to translate table +; + if NSECTS lt 64 + rept 64-NSECTS + db 0 + endm + endif +; +; Utility subroutines +; +MLTBY3: +;multiply the contents of regE to get jmp address + mov a,e ;Acc = E + sui 1 + mov e,a ;get ready for multiply + add e + add e + mov e,a + ret ;back at it +; +SEL: + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz SEL2 +; + sta CREG ;CREG = selected register + lxi h,0000h + shld EREG ;for first time + + mvi a,SELDSK + sta BIOSFC ;store it in func space + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +SEL2: + mov c,a + lhld WBOOT + lxi d,SELDSK + call MLTBY3 + dad d + pchl +; +TRK: +; Set up track + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz TRK2 + +; + mvi a,00h + sta BREG ;zero out B register + mov a,c ;Acc = track # + sta CREG ;set up PB + mvi a,SETTRK ;settrk func # + sta BIOSFC + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +TRK2: + lhld WBOOT + lxi d,SETTRK + call MLTBY3 + dad d + pchl ;gone to set track +; +SEC: +; Set up sector number + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz SEC2 +; + mvi a,00h + sta BREG ;zero out BREG + mov a,c ; Acc = C + sta CREG ;CREG = sector # + mvi a,SETSEC + sta BIOSFC ;set up bios call + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +SEC2: + lhld WBOOT + lxi d,SETSEC + call MLTBY3 + dad d + pchl +; +DMA: +; Set DMA address to value of BC + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz DMA2 +; + mov a,b ; + sta BREG ; + mov a,c ;Set up the BC + sta CREG ;register pair + mvi a,SETDMA ; + sta BIOSFC ;set up bios # + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +DMA2: + lhld WBOOT + lxi d,SETDMA + call MLTBY3 + dad d + pchl +; +READ: +; Perform read operation + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz READ2 +; + mvi a,READF + sta BIOSFC + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +READ2: + lhld WBOOT + lxi d,READF + call MLTBY3 + dad d + pchl +; +WRITE: +; Perform write operation + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz WRITE2 +; + mvi a,WRITF + sta BIOSFC ;set up bios # + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +WRITE2: + lhld WBOOT + lxi d,WRITF + call MLTBY3 + dad d + pchl +; +MULTSEC: +; Multiply the sector # in rA by the sector size + mov l,a + mvi h,0 ;sector in hl + rept LOG2SEC + dad h + endm + ret ;with HL - sector*sectorsize +; +GETCHAR: +; Read console character to rA + mvi c,CONI + call BDOS +; Convert to upper case + cpi 'A' or 20h + rc + cpi ('Z' or 20h)+1 + rnc + ani 05Fh + ret +; +PUTCHAR: +; Write character from rA to console + mov e,a + mvi c,CONO + call BDOS + ret +; +CRLF: +; Send Carriage Return, Line Feed + mvi a,CR + call PUTCHAR + mvi a,LF + call PUTCHAR + ret +; + +CRMSG: +; Print message addressed by the HL until zero with leading CRLF + push d + call CRLF + pop d ;drop through to OUTMSG +OUTMSG: + mvi c,9 + jmp BDOS +; +SELCT: +; Select disk given by rA + mvi c,0Eh + jmp BDOS +; +DWRITE: +; Write for file copy + mvi c,DWRITF + jmp BDOS +; +DREAD: +; Disk read function + mvi c,DREADF + jmp BDOS +; +OPEN: +; File open function + mvi c,OPENF + jmp BDOS +; +CLOSE: + mvi c,CLOSEF + jmp BDOS +; +MAKE: + mvi c,MAKEF + jmp BDOS +; +DELETE: + mvi c,DELTEF + jmp BDOS +; +; +; +DSTDMA: + mvi c,26 + jmp BDOS +; +SOURCE: + lxi d,GETPRM ;ask user for source drive + call CRMSG + call GETCHAR ;obtain response + cpi CR ;is it CR? + jz DFLTDR ;skip if CR only + cpi CTLC ;isit ^C? + jz REBOOT +; + sui 'A' ;normalize drive # + cpi NDISKS ;valid drive? + jc GETC ;skip to GETC if so +; +; Invalid drive + call BADDISK ;tell user bad drive + jmp SOURCE ;try again +; +GETC: +; Select disk given by Acc. + adi 'A' + sta GDISK ;store source disk + sui 'A' + mov e,a ;move disk into E for select func + call SEL ;select the disk + jmp GETVER +; +DFLTDR: + mvi c,25 ;func 25 for current disk + call BDOS ;get curdsk + adi 'A' + sta GDISK + call CRLF + lxi d,VERGET + call OUTMSG + jmp VERCR +; +GETVER: +; Getsys set r/w to read and get the system + call CRLF + lxi d,VERGET ;verify source disk + call OUTMSG +VERCR: call GETCHAR + cpi CR + jnz REBOOT ;jmp only if not verified + call CRLF + ret +; +DESTIN: + lxi d,PUTPRM ;address of message + call CRMSG ;print it + call GETCHAR ;get answer + cpi CR + jz REBOOT ;all done + sui 'A' + cpi NDISKS ;valid disk + jc PUTC +; +; Invalid drive + call BADDISK ;tell user bad drive + jmp PUTSYS ;to try again +; +PUTC: +; Set disk fron rA + adi 'A' + sta PDISK ;message sent + sui 'A' + mov e,a ;disk # in E + call SEL ;select destination drive +; Put system, set r/w to write + lxi d,VERPUT ;verify dest prmpt + call CRMSG ;print it out + call GETCHAR ;retrieve answer + cpi CR + jnz REBOOT ;exit to system if error + call CRLF + ret +; +; +GETPUT: +; Get or put CP/M (rw = 0 for read, 1 for write) +; disk is already selected + lxi h,LOADP ;load point in RAM for DMA address + shld DMADDR +; +; +; + +; +; Clear track 00 + mvi a,-1 ; + sta TRACK +; +RWTRK: +; Read or write next track + lxi h,TRACK + inr m ;track = track+1 + lda OST ;# of OS tracks + cmp m ;=track # ? + jz ENDRW ;end of read/write +; +; Otherwise not done + mov c,m ;track number + call TRK ;set to track + mvi a,-1 ;counts 0,1,2,...,25 + sta SECTOR +; +RWSEC: +; Read or write a sector + lda SPT ;sectors per track + lxi h,SECTOR + inr m ;set to next sector + cmp m ;A=26 and M=0,1,..,25 + jz ENDTRK +; +; Read or write sector to or from current DMA address + lxi h,SECTOR + mov e,m ;sector number + mvi d,0 ;to DE + lxi h,TRAN + mov b,m ;tran(0) in B + dad d ;sector translated + mov c,m ;value to C ready for select + push b ;save tran(0) + call SEC + pop b ;recall tran(0),tran(sector) + mov a,c ;tran(sector) + sub b ;--tran(sector) + call MULTSEC ;*sector size + xchg ;to DE + lhld DMADDR ;base DMA + dad d + mov b,h + mov c,l ;to set BC for SEC call + call DMA ;dma address set from BC + xra a + sta RETRY ;to set zero retries +; +TRYSEC: +; Try to read or write current sector + lda RETRY + cpi MAXTRY + jc TRYOK +; +; Past MAXTRY, message and ignore + lxi d,ERRMSG + call OUTMSG + call GETCHAR + cpi CR + jnz REBOOT +; +; Typed a CR, ok to ignore + call CRLF + jmp RWSEC +; +TRYOK: +; Ok to tyr read write + inr a + sta RETRY + lda RW + ora a + jz TRYREAD +; +; Must be write + call WRITE + jmp CHKRW +TRYREAD: + call READ +CHKRW: + ora a + jz RWSEC ;zero flag if read/write ok +; +;Error, retry operation + jmp TRYSEC +; +; End of track +ENDTRK: + lda SPT ;sectors per track + call MULTSEC ;*secsize + xchg ; to DE + lhld DMADDR ;base dma for this track + dad d ;+spt*secsize + shld DMADDR ;ready for next track + jmp RWTRK ;for another track +; +ENDRW: +; End of read or write + ret +; +;******************* +;* +;* MAIN ROUTINE +;* +;* +;******************* +; +START: + + lxi sp,STACK + lxi d,SIGNON + call OUTMSG +; +;get version number to check compatability + mvi c,12 ;version check + call BDOS + mov a,l ;version in Acc + cpi 30h ;version 3 or newer? + jc OLDRVR ; + mvi a,TRUE + sta V3FLG ; + jmp FCBCHK +OLDRVR: + mvi a,FALSE + sta V3FLG +; + +; Check for default file liad instead of get +FCBCHK: lda FCB+1 ;blank if no file + cpi ' ' + jz GETSYS ;skip to system message + lxi d,FCB ;try to open it + call OPEN + inr a ;255 becomes 00 + jnz RDOK +; +; File not present + lxi d,NOFILE + call CRMSG + jmp REBOOT +; +;file present +RDOK: + xra a + sta FCBCR ;current record = 0 + lxi h,LOADP +RDINP: + push h + mov b,h + mov c,l + call DMA ;DMA address set + lxi d,FCB ;ready fr read + call DREAD + pop h ;recall + ora a ;00 if read ok + jnz PUTSYS ;assume eof if not +; More to read continue + lxi d,SECSIZ + dad d ;HL is new load address + jmp RDINP +; +GETSYS: + call SOURCE ;find out source drive +; + xra a ;zero out a + sta RW ;RW = 0 to signify read + call GETPUT ;get or read system + lxi d,DONE ;end message of get or read func + call OUTMSG ;print it out +; +; Put the system +PUTSYS: + call DESTIN ;get dest drive +; + lxi h,RW ;load address + mvi m,1 + call GETPUT ;to put system back on disk + lxi d,DONE + call OUTMSG ;print out end prompt +; +; FILE COPY FOR CPM.SYS +; +CPYCPM: +; Prompt the user for the source of CP/M3.SYS +; + lxi d,CPYMSG ;print copys prompt + call CRMSG ;print it + call GETCHAR ;obtain reply + cpi Y ;is it yes? + jnz REBOOT ;if not exit + ;else +; +; + mvi c,13 ;func # for reset + call BDOS ; + inr a + + lxi d,ERRMSG + cz FINIS +; + call SOURCE ;get source disk for CPM3.SYS +CNTNUE: + lda GDISK ;Acc = source disk + sui 'A' + mvi d,00h + mov e,a ;DE = selected disk + call SELCT +; now copy the FCBs + mvi c,36 ;for copy + lxi d,SFCB ;source file + lxi h,DFCB ;destination file +MFCB: + + ldax d + inx d ;ready next + mov m,a + inx h ;ready next dest + dcr c ;decrement coun + jnz MFCB +; + lda GDISK ;Acc = source disk + sui 40h ;correct disk + lxi h,SFCB + mov m,a ;SFCB has source disk # + lda PDISK ;get the dest. disk + lxi h,DFCB ; + sui 040h ;normalize disk + mov m,a +; + xra a ;zero out a + sta DFCBCR ;current rec = 0 +; +; Source and destination fcb's ready +; + lxi d,SFCB ; + call OPEN ;open the file + lxi d,NOFILE ;error messg + inr a ;255 becomes 0 + cz FINIS ;done if no file +; +; Source file is present and open + lxi d,LOADP ;get DMA address + xchg ;move address to HL regs + shld BEGIN ;save for begin of write +; + lda BEGIN ;get low byte of + mov l,a ;DMA address into L + lda BEGIN+1 ; + mov h,a ;into H also +COPY1: + xchg ;DE = address of DMA + call DSTDMA ; +; + lxi d,SFCB ; + call DREAD ;read next record + ora a ;end of file? + jnz EOF ;skip write if so +; + lda CRNREC + inr a ;bump it + sta CRNREC +; + lda BEGIN + mov l,a + lda BEGIN+1 + mov h,a + lxi d,EIGHTY + dad d ;add eighty to begin address + shld BEGIN + jmp COPY1 ;loop until EOF +; +EOF: + lxi d,DONE + call OUTMSG +; +COPY2: + call DESTIN ;get destination drive for CPM3.SYS + lxi d,DFCB ;set up dest FCB + xchg + lda PDISK + sui 040h ;normalize disk + mov m,a ;correct disk for dest + xchg ;DE = DFCB + call DELETE ;delete file if there +; + lxi d,DFCB ; + call MAKE ;make a new one + lxi d,NODIR + inr a ;check directory space + cz FINIS ;end if none +; + lxi d,LOADP + xchg + shld BEGIN +; + lda BEGIN + mov l,a + lda BEGIN+1 + mov h,a +LOOP2: + xchg + call DSTDMA + lxi d,DFCB + call DWRITE + lxi d,FSPACE + ora a + cnz FINIS + lda CRNREC + dcr a + sta CRNREC + cpi 0 + jz FNLMSG + lda BEGIN + mov l,a + lda BEGIN+1 + mov h,a + lxi d,EIGHTY + dad d + shld BEGIN + jmp LOOP2 +; Copy operation complete +FNLMSG: + lxi d,DFCB + mvi c,CLOSEF + call BDOS +; + lxi d,DONE +; +FINIS: +; Write message given by DE, reboot + call OUTMSG +; +REBOOT: + mvi c,13 + call BDOS + call CRLF + jmp BOOT +; +BADDISK: + lxi d,QDISK + call CRMSG + ret +;**************************** +;* +;* +;* DATA STRUCTURES +;* +;* +;**************************** +; +BIOSPB: +; BIOS Parameter Block +BIOSFC: db 0 ;BIOS function number +AREG: db 0 ;A register contents +CREG: db 0 ;C register contents +BREG: db 0 ;B register contents +EREG: db 0 ;E register contents +DREG: db 0 ;D register contents +HLREG: dw 0 ;HL register contents +; +SFCB: +DR: ds 1 +F1F8: db 'CPM3 ' +T1T3: db 'SYS' +EXT: db 0 +CS: db 0 +RS: db 0 +RCC: db 0 +D0D15: ds 16 +CCR: db 0 +R0R2: ds 3 +; +DFCB: ds 36 +DFCBCR equ DFCB+32 +; +; +V3FLG: db 0 ;flag for version # +TEMP: db 0 +SDISK: ds 1 ;selected disk +BEGIN: dw 0 +DFLAG: db 0 +TRACK: ds 1 ;current track +CRNREC: db 0 ;current rec count +SECTOR: ds 1 ;current sector +RW: ds 1 ;read if 0 write if 1 +DMADDR: ds 2 ;current DMA address +RETRY: ds 1 ;number of tries on this sector +SIGNON: db 'CP/M 3 COPYSYS - Version ' + db VERS/10+'0','.',VERS mod 10 +'0' + db '$' +GETPRM: db 'Source drive name (or return for default) $' +VERGET: db 'Source on ' +GDISK: ds 1 + db ' then type return $' +PUTPRM: db 'Destination drive name (or return to reboot) $' +VERPUT: db 'Destination on ' +PDISK: ds 1 + db ' then type return $' +CPYMSG: db 'Do you wish to copy CPM3.SYS? $' +DONE: db 'Function complete$' +; +; Error messages...... +; +QDISK: db 'ERROR: Invalid drive name (Use A, B, C, or D)$' +NOFILE: db 'ERROR: No source file on disk.$' +NODIR: db 'ERROR: No directory space.$' +FSPACE: db 'ERROR: Out of data space.$' +WRPROT: db 'ERROR: Write protected?$' +ERRMSG: db 'ERROR: Possible incompatible disk format.' + db CR,LF,' Type return to ignore.$' +CLSERR: db 'ERROR: Close operation failed.$' +; + ds STACKSIZE * 3 +STACK: + end diff --git a/software/CPM/cpm3/_ump.asm b/software/CPM/cpm3/_ump.asm new file mode 100644 index 0000000..81a4a12 --- /dev/null +++ b/software/CPM/cpm3/_ump.asm @@ -0,0 +1,208 @@ +; Dump program, reads input file and displays hex data +; + org 100h +bdos equ 0005h ;dos entry point +cons equ 1 ;read console +typef equ 2 ;type function +printf equ 9 ;buffer print entry +brkf equ 11 ;break key function (true if char ready) +openf equ 15 ;file open +readf equ 20 ;read function +; +fcb equ 5ch ;file control block address +buff equ 80h ;input disk buffer address +; +; non graphic characters +cr equ 0dh ;carriage return +lf equ 0ah ;line feed +; +; file control block definitions +fcbdn equ fcb+0 ;disk name +fcbfn equ fcb+1 ;file name +fcbft equ fcb+9 ;disk file type (3 characters) +fcbrl equ fcb+12 ;file's current reel number +fcbrc equ fcb+15 ;file's record count (0 to 128) +fcbcr equ fcb+32 ;current (next) record number (0 to 127) +fcbln equ fcb+33 ;fcb length +; +; set up stack + lxi h,0 + dad sp +; entry stack pointer in hl from the ccp + shld oldsp +; set sp to local stack area (restored at finis) + lxi sp,stktop +; read and print successive buffers + call setup ;set up input file + cpi 255 ;255 if file not present + jnz openok ;skip if open is ok +; +; file not there, give error message and return + lxi d,opnmsg + call err + jmp finis ;to return +; +openok: ;open operation ok, set buffer index to end + mvi a,80h + sta ibp ;set buffer pointer to 80h +; hl contains next address to print + lxi h,0 ;start with 0000 +; +gloop: + push h ;save line position + call gnb + pop h ;recall line position + jc finis ;carry set by gnb if end file + mov b,a +; print hex values +; check for line fold + mov a,l + ani 0fh ;check low 4 bits + jnz nonum +; print line number + call crlf +; +; check for break key + call break +; accum lsb = 1 if character ready + rrc ;into carry + jc finis ;don't print any more +; + mov a,h + call phex + mov a,l + call phex +nonum: + inx h ;to next line number + mvi a,' ' + call pchar + mov a,b + call phex + jmp gloop +; +finis: +; end of dump + call crlf + lhld oldsp + sphl +; stack pointer contains ccp's stack location + ret ;to the ccp +; +; +; subroutines +; +break: ;check break key (actually any key will do) + push h! push d! push b; environment saved + mvi c,brkf + call bdos + pop b! pop d! pop h; environment restored + ret +; +pchar: ;print a character + push h! push d! push b; saved + mvi c,typef + mov e,a + call bdos + pop b! pop d! pop h; restored + ret +; +crlf: + mvi a,cr + call pchar + mvi a,lf + call pchar + ret +; +; +pnib: ;print nibble in reg a + ani 0fh ;low 4 bits + cpi 10 + jnc p10 +; less than or equal to 9 + adi '0' + jmp prn +; +; greater or equal to 10 +p10: adi 'a' - 10 +prn: call pchar + ret +; +phex: ;print hex char in reg a + push psw + rrc + rrc + rrc + rrc + call pnib ;print nibble + pop psw + call pnib + ret +; +err: ;print error message +; d,e addresses message ending with "$" + mvi c,printf ;print buffer function + call bdos + ret +; +; +gnb: ;get next byte + lda ibp + cpi 80h + jnz g0 +; read another buffer +; +; + call diskr + ora a ;zero value if read ok + jz g0 ;for another byte +; end of data, return with carry set for eof + stc + ret +; +g0: ;read the byte at buff+reg a + mov e,a ;ls byte of buffer index + mvi d,0 ;double precision index to de + inr a ;index=index+1 + sta ibp ;back to memory +; pointer is incremented +; save the current file address + lxi h,buff + dad d +; absolute character address is in hl + mov a,m +; byte is in the accumulator + ora a ;reset carry bit + ret +; +setup: ;set up file +; open the file for input + xra a ;zero to accum + sta fcbcr ;clear current record +; + lxi d,fcb + mvi c,openf + call bdos +; 255 in accum if open error + ret +; +diskr: ;read disk file record + push h! push d! push b + lxi d,fcb + mvi c,readf + call bdos + pop b! pop d! pop h + ret +; +; fixed message area +signon: db 'file dump version 2.0$' +opnmsg: db cr,lf,'no input file present on disk$' + +; variable area +ibp: ds 2 ;input buffer pointer +oldsp: ds 2 ;entry sp value from ccp +; +; stack area + ds 64 ;reserve 32 level stack +stktop: +; + end diff --git a/software/CPM/cpm3/asm80/asm80 b/software/CPM/cpm3/asm80/asm80 new file mode 100644 index 0000000..343db52 Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80 differ diff --git a/software/CPM/cpm3/asm80/asm80.ov0 b/software/CPM/cpm3/asm80/asm80.ov0 new file mode 100644 index 0000000..5b38aa5 Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80.ov0 differ diff --git a/software/CPM/cpm3/asm80/asm80.ov1 b/software/CPM/cpm3/asm80/asm80.ov1 new file mode 100644 index 0000000..4b4cf91 Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80.ov1 differ diff --git a/software/CPM/cpm3/asm80/asm80.ov2 b/software/CPM/cpm3/asm80/asm80.ov2 new file mode 100644 index 0000000..da08650 Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80.ov2 differ diff --git a/software/CPM/cpm3/asm80/asm80.ov3 b/software/CPM/cpm3/asm80/asm80.ov3 new file mode 100644 index 0000000..75658d4 Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80.ov3 differ diff --git a/software/CPM/cpm3/asm80/asm80.ov4 b/software/CPM/cpm3/asm80/asm80.ov4 new file mode 100644 index 0000000..b6d9547 Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80.ov4 differ diff --git a/software/CPM/cpm3/asm80/asm80.ov5 b/software/CPM/cpm3/asm80/asm80.ov5 new file mode 100644 index 0000000..da48e7a Binary files /dev/null and b/software/CPM/cpm3/asm80/asm80.ov5 differ diff --git a/software/CPM/cpm3/asm80/asxref b/software/CPM/cpm3/asm80/asxref new file mode 100644 index 0000000..7d1740c Binary files /dev/null and b/software/CPM/cpm3/asm80/asxref differ diff --git a/software/CPM/cpm3/asm80/conv86 b/software/CPM/cpm3/asm80/conv86 new file mode 100644 index 0000000..b4ee6ba Binary files /dev/null and b/software/CPM/cpm3/asm80/conv86 differ diff --git a/software/CPM/cpm3/asm80/fpal.lib b/software/CPM/cpm3/asm80/fpal.lib new file mode 100644 index 0000000..eadd36e Binary files /dev/null and b/software/CPM/cpm3/asm80/fpal.lib differ diff --git a/software/CPM/cpm3/asm80/hexobj b/software/CPM/cpm3/asm80/hexobj new file mode 100644 index 0000000..136e296 Binary files /dev/null and b/software/CPM/cpm3/asm80/hexobj differ diff --git a/software/CPM/cpm3/asm80/isis.doc b/software/CPM/cpm3/asm80/isis.doc new file mode 100644 index 0000000..b01e041 --- /dev/null +++ b/software/CPM/cpm3/asm80/isis.doc @@ -0,0 +1,59 @@ + + + Instructions for ISIS environment V1.0 + ====================================== + +The ISIS environment is designed to allow 8080 based Intel tools to run on +an 8086 PCDOS based system. The ISIS environment does not support all ISIS +calls, but sufficient to run 8051 translators and utilities. (If the program +uses an unsupported ISIS call an error message is generated). + + +DOS instructions +---------------- + +Load the software(ISIS) onto the harddisk. If ISIS is installed in the DOS +search path it will be directly loadable by entering "ISIS". + +Before entering ISIS, logical names must be set to match any ISIS disk drives +used by the ISIS tools. This includes :F0: - the ISIS environment does NOT +default to the current drive. As with 8080 ISIS, filenames without a drive +prefix are directed to :F0:. + + +C>SET :F0:=\ISIS /* make sure there is no before the "=" */ +C>SET :F1:=\BITBUS + +C>ISIS /* invoke ISIS emulator */ +DOS ISIS Environment X003 +=ASM51 :F1:SAMP1.A51 /* enter ISIS commands */ +... +... +=EXIT /* return to DOS */ + + +The ISIS environment will also run under DOS in batch mode + +Command file (DEMO.CMD) contains: + +ASM51 :F1:SAMP1.A51 +ASM51 :F1:SAMP2.A51 +ASM51 :F1:SAMP3.A51 +RL51 :F1:SAMP1.OBJ, & +:F1:SAMP2.OBJ, & +:F1:SAMP3.OBJ TO :F1:SAMPLE +EXIT /* must include EXIT since all program + input must be in command file + otherwise DOS will wait forever */ + +To invoke the command file + +C>ISIS < DEMO.CMD /* This could be part of a batch job */ + + or will abort the ISIS environment. You will need to +enter also if the ISIS environment is at the prompt level. Also the +command "BREAK ON" should be included in the AUTOEXEC.BAT file to permit DOS +to recognise all the time (not just when performing DOS calls). + + +Known Bugs/Problems: None diff --git a/software/CPM/cpm3/asm80/isis.exe b/software/CPM/cpm3/asm80/isis.exe new file mode 100644 index 0000000..75b4e6d Binary files /dev/null and b/software/CPM/cpm3/asm80/isis.exe differ diff --git a/software/CPM/cpm3/asm80/ixref b/software/CPM/cpm3/asm80/ixref new file mode 100644 index 0000000..d7d1d30 Binary files /dev/null and b/software/CPM/cpm3/asm80/ixref differ diff --git a/software/CPM/cpm3/asm80/lib b/software/CPM/cpm3/asm80/lib new file mode 100644 index 0000000..2913c75 Binary files /dev/null and b/software/CPM/cpm3/asm80/lib differ diff --git a/software/CPM/cpm3/asm80/link b/software/CPM/cpm3/asm80/link new file mode 100644 index 0000000..f44e717 Binary files /dev/null and b/software/CPM/cpm3/asm80/link differ diff --git a/software/CPM/cpm3/asm80/link.ovl b/software/CPM/cpm3/asm80/link.ovl new file mode 100644 index 0000000..31aa7a2 Binary files /dev/null and b/software/CPM/cpm3/asm80/link.ovl differ diff --git a/software/CPM/cpm3/asm80/locate b/software/CPM/cpm3/asm80/locate new file mode 100644 index 0000000..0020ac7 Binary files /dev/null and b/software/CPM/cpm3/asm80/locate differ diff --git a/software/CPM/cpm3/asm80/objhex b/software/CPM/cpm3/asm80/objhex new file mode 100644 index 0000000..3ebad01 Binary files /dev/null and b/software/CPM/cpm3/asm80/objhex differ diff --git a/software/CPM/cpm3/asm80/plm51.lib b/software/CPM/cpm3/asm80/plm51.lib new file mode 100644 index 0000000..ea1038a Binary files /dev/null and b/software/CPM/cpm3/asm80/plm51.lib differ diff --git a/software/CPM/cpm3/asm80/plm80.lib b/software/CPM/cpm3/asm80/plm80.lib new file mode 100644 index 0000000..ebb685a Binary files /dev/null and b/software/CPM/cpm3/asm80/plm80.lib differ diff --git a/software/CPM/cpm3/asm80/submit b/software/CPM/cpm3/asm80/submit new file mode 100644 index 0000000..d9a6e2f Binary files /dev/null and b/software/CPM/cpm3/asm80/submit differ diff --git a/software/CPM/cpm3/asm80/system.lib b/software/CPM/cpm3/asm80/system.lib new file mode 100644 index 0000000..c6e06ef Binary files /dev/null and b/software/CPM/cpm3/asm80/system.lib differ diff --git a/software/CPM/cpm3/assemble.txt b/software/CPM/cpm3/assemble.txt new file mode 100644 index 0000000..7ac57bc --- /dev/null +++ b/software/CPM/cpm3/assemble.txt @@ -0,0 +1,20 @@ +Assembling CP/M 3 +================= + + The original CP/M 3 build process seems to have been written for a CP/M 3 +computer; it uses the MAC, RMAC, LINK, GENCOM and HEXCOM tools, which are +not readily available for other platforms in this day and age. + + HEXCOM.C (based on LOAD.C in ) serves +as a suitable replacement for HEXCOM. The command syntax is: + + HEXCOM comfile media changed + inr a! rnz + +if BANKED + ; Handle media changes as I/O errors for + ; permanent drives + call chksiz$eq$8000h! rz +endif + + ; BIOS says media change occurred + ; Is disk logged-in? + lhld dlog! call test$vector! mvi c,1! rz ; no - return error + call media$change + pop h ; Discard return address + ; Was this a flush operation (fx = 48)? + lda fx! cpi 48! rz ; yes + ; Is this a flush to another drive? + lxi h,adrive! lda seldsk! cmp m! jnz reset$relog + ; Bail out if fx = read, write, close, or search next + call chk$exit$fxs + ; Is this a directory read operation? + lda readf$sw! ora a! rnz ; yes + ; Error - directory write operation + mvi c,2! jmp goerr ; Return disk read/only error + +reset$relog: + ; Reset relog if flushing to another drive + xra a! sta relog! ret + +if BANKED + +chksiz$eq$8000h: + ; Return with Z flag set if drive permanent + ; with no checksum vector + lhld chksiz! mvi a,80h! cmp h! rnz + xra a! cmp l! ret + +endif + +seekdir: + ; Seek the record containing the current dir entry + +if MPM + lxi d,0ffffh ; mask = ffff + lhld dblk! mov a,h! ora l! jz seekdir1 + lda blkmsk! mov e,a! xra a! mov d,a ; mask = blkmsk + lda blkshf! mov c,a! xra a + call shl3bv ; ahl = shl(dblk,blkshf) +seekdir1: + push h! push a ; Save ahl +endif + + lhld dcnt ; directory counter to hl + mvi c,dskshf! call hlrotr ; value to hl + shld drec + +if MPM + +; arecord = shl(dblk,blkshf) + shr(dcnt,dskshf) & mask + + mov a,l! ana e! mov l,a ; dcnt = dcnt & mask + mov a,h! ana d! mov h,a + pop b! pop d! call bde$e$bde$p$hl + +else + mvi b,0! xchg +endif + +set$arecord: + lxi h,arecord + mov m,e! inx h! mov m,d! inx h! mov m,b + ret + +seek: + ; Seek the track given by arecord (actual record) + + lhld curtrka! mov c,m! inx h! mov b,m ; bc = curtrk + push b ; s0 = curtrk + lhld curreca! mov e,m! inx h! mov d,m + inx h! mov b,m ; bde = currec + lhld arecord! lda arecord+2! mov c,a ; chl = arecord +seek0: + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + push h ; Save low(arecord) + jnc seek1 ; if arecord >= currec then go to seek1 + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! xthl! dcx h! xthl ; curtrk = curtrk - 1 + jmp seek0 +seek1: + lhld sectpt! call bde$e$bde$p$hl ; currec = currec + sectpt + pop h ; Restore low(arecord) + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + jc seek2 ; if arecord < currec then go to seek2 + xthl! inx h! xthl ; curtrk = curtrk + 1 + push h ; save low (arecord) + jmp seek1 +seek2: + xthl! push h ; hl,s0 = curtrk, s1 = low(arecord) + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! push d! push b! push h ; hl,s0 = curtrk, + ; s1 = high(arecord,currec), s2 = low(currec), + ; s3 = low(arecord) + xchg! lhld offset! dad d + mov b,h! mov c,l! shld track + call settrkf ; call bios settrk routine + ; Store curtrk + pop d! lhld curtrka! mov m,e! inx h! mov m,d + ; Store currec + pop b! pop d! + lhld curreca! mov m,e! inx h! mov m,d + inx h! mov m,b ; currec = bde + pop b ; bc = low(arecord), de = low(currec) + mov a,c! sub e! mov l,a ; hl = bc - de + mov a,b + sbb d + mov h,a + call shr$physhf + mov b,h! mov c,l + + lhld tranv! xchg ; bc=sector#, de=.tran + call sectran ; hl = tran(sector) + mov c,l! mov b,h ; bc = tran(sector) + shld sector + call setsecf ; sector selected + lhld curdma! mov c,l! mov b,h! jmp setdmaf + ; ret +shr$physhf: + lda physhf! mov c,a! jmp hlrotr + +; file control block (fcb) constants + +empty equ 0e5h ; empty directory entry +lstrec equ 127 ; last record# on extent +recsiz equ 128 ; record size +fcblen equ 32 ; file control block size +dirrec equ recsiz/fcblen ; directory fcbs / record +dskshf equ 2 ; log2(dirrec) +dskmsk equ dirrec-1 +fcbshf equ 5 ; log2(fcblen) + +extnum equ 12 ; extent number field +maxext equ 31 ; largest extent number +ubytes equ 13 ; unfilled bytes field +modnum equ 14 ; data module number + +maxmod equ 64 ; largest module number + +fwfmsk equ 80h ; file write flag is high order modnum +namlen equ 15 ; name length +reccnt equ 15 ; record count field +dskmap equ 16 ; disk map field +lstfcb equ fcblen-1 +nxtrec equ fcblen +ranrec equ nxtrec+1; random record field (2 bytes) + +; reserved file indicators + +rofile equ 9 ; high order of first type char +invis equ 10 ; invisible file in dir command + +; utility functions for file access + +dm$position: + ; Compute disk map position for vrecord to hl + lxi h,blkshf! mov c,m ; shift count to c + lda vrecord ; current virtual record to a + dmpos0: + ora a! rar! dcr c! jnz dmpos0 + ; a = shr(vrecord,blkshf) = vrecord/2**(sect/block) + mov b,a ; Save it for later addition + mvi a,8! sub m ; 8-blkshf to accumulator + mov c,a ; extent shift count in register c + lda extval ; extent value ani extmsk + dmpos1: + ; blkshf = 3,4,5,6,7, c=5,4,3,2,1 + ; shift is 4,3,2,1,0 + dcr c! jz dmpos2 + ora a! ral! jmp dmpos1 + dmpos2: + ; Arrive here with a = shl(ext and extmsk,7-blkshf) + add b ; Add the previous shr(vrecord,blkshf) value + ; a is one of the following values, depending upon alloc + ; bks blkshf + ; 1k 3 v/8 + extval * 16 + ; 2k 4 v/16+ extval * 8 + ; 4k 5 v/32+ extval * 4 + ; 8k 6 v/64+ extval * 2 + ; 16k 7 v/128+extval * 1 + ret ; with dm$position in a + +getdma: + lhld info! lxi d,dskmap! dad d! ret + +getdm: + ; Return disk map value from position given by bc + call getdma + dad b ; Index by a single byte value + lda single ; single byte/map entry? + ora a! jz getdmd ; Get disk map single byte + mov l,m! mov h,b! ret ; with hl=00bb + getdmd: + dad b ; hl=.fcb(dm+i*2) + ; double precision value returned + mov a,m! inx h! mov h,m! mov l,a! ret + +index: + ; Compute disk block number from current fcb + call dm$position ; 0...15 in register a + sta dminx + mov c,a! mvi b,0! call getdm ; value to hl + shld arecord! mov a,l! ora h! ret + +atran: + ; Compute actual record address, assuming index called + +; arecord = shl(arecord,blkshf) + + lda blkshf! mov c,a + lhld arecord! xra a! call shl3bv + shld arecord! sta arecord+2 + + shld arecord1 ; Save low(arecord) + +; arecord = arecord or (vrecord and blkmsk) + + lda blkmsk! mov c,a! lda vrecord! ana c + mov b,a ; Save vrecord & blkmsk in reg b & blk$off + sta blk$off + lxi h,arecord! ora m! mov m,a! ret + +get$atts: + ; Get volatile attributes starting at f'5 + ; info locates fcb + lhld info + lxi d,8! dad d ; hl = .fcb(f'8) + mvi c,4 +get$atts$loop: + mov a,m! add a! push a + mov a,d! rar! mov d,a + pop a! rrc! mov m,a + dcx h! dcr c! jnz get$atts$loop + mov a,d! ret + +get$s1: + ; Get current s1 field to a + call getexta! inx h! mov a,m! ret + +get$rra: + ; Get current ran rec field address to hl + lhld info! lxi d,ranrec! dad d ; hl=.fcb(ranrec) + ret + +getexta: + ; Get current extent field address to hl + lhld info! lxi d,extnum! dad d ; hl=.fcb(extnum) + ret + +getrcnta: + ; Get reccnt address to hl + lhld info! lxi d,reccnt! dad d! ret + +getfcba: + ; Compute reccnt and nxtrec addresses for get/setfcb + call getrcnta! xchg ; de=.fcb(reccnt) + lxi h,(nxtrec-reccnt)! dad d ; hl=.fcb(nxtrec) + ret + +getfcb: + ; Set variables from currently addressed fcb + call getfcba ; addresses in de, hl + mov a,m! sta vrecord ; vrecord=fcb(nxtrec) + xchg! mov a,m! ora a! jnz getfcb0 + call get$dir$ext! mov c,a! call set$rc! mov a,m +getfcb0: + cpi 81h! jc getfcb1 + mvi a,80h +getfcb1: + sta rcount ; rcount=fcb(reccnt) or 80h + call getexta ; hl=.fcb(extnum) + lda extmsk ; extent mask to a + ana m ; fcb(extnum) and extmsk + sta extval + ret + +setfcb: + ; Place values back into current fcb + call getfcba ; addresses to de, hl + ; fcb(cr) = vrecord + lda vrecord! mov m,a + ; Is fx < 22? (sequential read or write) + lda fx! cpi 22! jnc $+4 ; no + ; fcb(cr) = fcb(cr) + 1 + inr m + xchg! mov a,m! cpi 80h! rnc ; dont reset fcb(rc) if > 7fh + lda rcount! mov m,a ; fcb(reccnt)=rcount + ret + +zero$ext$mod: + call getexta! mov m,d! inx h! inx h! mov m,d + ret + +zero: + mov m,b! inx h! dcr c! rz + jmp zero + +hlrotr: + ; hl rotate right by amount c + inr c ; in case zero + hlrotr0: dcr c! rz ; return when zero + mov a,h! ora a! rar! mov h,a ; high byte + mov a,l! rar! mov l,a ; low byte + jmp hlrotr0 + +compute$cs: + ; Compute checksum for current directory buffer + lhld buffa ; current directory buffer + lxi b,4 ; b = 0, c = 4 +compute$cs0: + mvi d,32 ; size of fcb + xra a ; clear checksum value +compute$cs1: + add m! inx h! dcr d + jnz compute$cs1 + xra b! mov b,a! dcr c + jnz compute$cs0 + ret ; with checksum in a + +if MPM + +compute$cs: + ; Compute checksum for current directory buffer + mvi c,recsiz ; size of directory buffer + lhld buffa ; current directory buffer + xra a ; Clear checksum value + computecs0: + add m! inx h! dcr c ; cs = cs+buff(recsiz-c) + jnz computecs0 + ret ; with checksum in a + +chksum$fcb: ; Compute checksum for fcb + ; Add 1st 12 bytes of fcb + curdsk + + ; high$ext + xfcb$read$only + bbh + lxi h,pdcnt! mov a,m + inx h! add m ; Add high$ext + inx h! add m ; Add xfcb$read$only + inx h! add m ; Add curdsk + adi 0bbh ; Add 0bbh to bias checksum + lhld info! mvi c,12! call computecs0 + ; Skip extnum + inx h + ; Add fcb(s1) + add m! inx h + ; Skip modnum + inx h + ; Skip fcb(reccnt) + ; Add disk map + inx h! mvi c,16! call computecs0 + ora a! ret ; Z flag set if checksum valid + +set$chksum$fcb: + call chksum$fcb! rz + mov b,a! call gets1 + cma! add b! cma + mov m,a! ret + +reset$chksum$fcb: + xra a! sta comp$fcb$cks + call chksum$fcb! rnz + call get$s1! inr m! ret + +endif + +check$fcb: + +if MPM + xra a! sta check$fcb4 +check$fcb1: + call chek$fcb! rz +check$fcb2: + + ani 0fh! jnz check$fcb3 + lda pdcnt! ora a! jz check$fcb3 + call set$sdcnt! sta dont$close + call close1 + lxi h,lret! inr m! jz check$fcb3 + mvi m,0! call pack$sdcnt! mvi b,5 + call search$olist! rz +check$fcb3: + + pop h ; Discard return address +check$fcb4: + nop + mvi a,10! jmp sta$ret + +set$fcb$cks$flag: + mvi a,0ffh! sta comp$fcb$cks! ret + +else + call gets1! lhld lsn$add + cmp m! cnz chk$media$fcb +endif + +chek$fcb: + lda high$ext + +if MPM + + ; if ext & 0110$0000b = 0110$0000b then + ; set fcb(0) to 0 (user 0) + + cpi 0110$0000b! jnz chek$fcb1 +else + ora a! rz +endif + + lhld info! xra a! mov m,a ; fcb(0) = 0 +chek$fcb1: + +if MPM + jmp chksum$fcb ; ret +else + ret + +chk$media$fcb: + ; fcb(s1) ~= DPH login sequence # field + ; Is fcb addr < bdosadd? + +if banked + lhld user$info +else + lhld info +endif + + xchg! lhld bdosadd! call subdh! jnc chk$media1 ; no + ; Is rlog(drive) true? + lhld rlog! call testvector! rz ; no +chk$media1: + ; Return invalid fcb error code + pop h! pop h +chk$media2: + mvi a,10! jmp sta$ret +endif + +hlrotl: + ; Rotate the mask in hl by amount in c + inr c ; may be zero + hlrotl0: dcr c! rz ; return if zero + dad h! jmp hlrotl0 + +set$dlog: + lxi d,dlog +set$cdisk: + ; Set a "1" value in curdsk position of bc + lda curdsk +set$cdisk1: + mov c,a ; Ready parameter for shift + lxi h,1 ; number to shift + call hlrotl ; hl = mask to integrate + ldax d! ora l! stax d! inx d + ldax d! ora h! stax d! ret + +nowrite: + ; Return true if dir checksum difference occurred + lhld rodsk + +test$vector: + lda curdsk +test$vector1: + mov c,a! call hlrotr + mov a,l! ani 1b! ret ; non zero if curdsk bit on + +check$rodir: + ; Check current directory element for read/only status + call getdptra ; address of element + +check$rofile: + ; Check current buff(dptr) or fcb(0) for r/o status + call ro$test + rnc ; Return if not set + jmp rof$error ; Exit to read only disk message + +ro$test: + lxi d,rofile! dad d + mov a,m! ral! ret ; carry set if r/o + +check$write: + ; Check for write protected disk + call nowrite! rz ; ok to write if not rodsk + jmp rod$error ; read only disk error + +getdptra: + ; Compute the address of a directory element at + ; positon dptr in the buffer + + lhld buffa! lda dptr +addh: + ; hl = hl + a + add l! mov l,a! rnc + ; overflow to h + inr h! ret + +getmodnum: + ; Compute the address of the module number + ; bring module number to accumulator + ; (high order bit is fwf (file write flag) + lhld info! lxi d,modnum! dad d ; hl=.fcb(modnum) + mov a,m! ret ; a=fcb(modnum) + +clrmodnum: + ; Clear the module number field for user open/make + call getmodnum! mvi m,0 ; fcb(modnum)=0 + ret + +clr$ext: + ; fcb ext = fcb ext & 1fh + call getexta! mov a,m! ani 0001$1111b! mov m,a! + ret + +setfwf: + call getmodnum ; hl=.fcb(modnum), a=fcb(modnum) + ; Set fwf (file write flag) to "1" + ori fwfmsk! mov m,a ; fcb(modnum)=fcb(modnum) or 80h + ; also returns non zero in accumulator + ret + +compcdr: + ; Return cy if cdrmax > dcnt + lhld dcnt! xchg ; de = directory counter + lhld cdrmaxa ; hl=.cdrmax + mov a,e! sub m ; low(dcnt) - low(cdrmax) + inx h ; hl = .cdrmax+1 + mov a,d! sbb m ; hig(dcnt) - hig(cdrmax) + ; condition dcnt - cdrmax produces cy if cdrmax>dcnt + ret + +setcdr: + ; if not (cdrmax > dcnt) then cdrmax = dcnt+1 + call compcdr + rc ; Return if cdrmax > dcnt + ; otherwise, hl = .cdrmax+1, de = dcnt + inx d! mov m,d! dcx h! mov m,e + ret + +subdh: + ; Compute hl = de - hl + mov a,e! sub l! mov l,a! mov a,d! sbb h! mov h,a + ret + +newchecksum: + mvi c,0feh ; Drop through to compute new checksum +checksum: + ; Compute current checksum record and update the + ; directory element if c=true, or check for = if not + ; drec < chksiz? + lhld drec! xchg! lhld chksiz + mov a,h! ani 7fh! mov h,a ; Mask off permanent drive bit + call subdh ; de-hl + rnc ; Skip checksum if past checksum vector size + ; drec < chksiz, so continue + push b ; Save init flag + call compute$cs ; Check sum value to a + lhld checka ; address of check sum vector + xchg + lhld drec + dad d ; hl = .check(drec) + pop b ; Recall true=0ffh or false=00 to c + inr c ; 0ffh produces zero flag + jz initial$cs + inr c ; 0feh produces zero flag + jz update$cs + +if MPM + inr c! jz test$dir$cs +endif + + ; not initializing, compare + cmp m ; compute$cs=check(drec)? + rz ; no message if ok + ; checksum error, are we beyond + ; the end of the disk? + call nowrite +;;; rnz ;[JCE] DRI Patch 13 + nop + +media$change: + call discard$data + +if MPM + call flush$file0 +else + mvi a,0ffh! sta relog! sta hashl + call set$rlog +endif + + ; Reset the drive + + call set$dlog! jmp reset37x + +if MPM + test$dir$cs: + cmp m! jnz flush$files + ret +endif + + initial$cs: + ; initializing the checksum + cmp m! mov m,a! rz + ; or 1 into login seq # if media change + lhld lsn$add! mvi a,1! ora m! mov m,a! ret + + update$cs: + ; updating the checksum + mov m,a! ret + +set$ro: + ; Set current disk to read/only + lda seldsk! lxi d,rodsk! call set$cdisk1 ; sets bit to 1 + ; high water mark in directory goes to max + lhld dirmax! inx h! xchg ; de = directory max + lhld cdrmaxa ; hl = .cdrmax + mov m,e! inx h! mov m,d ; cdrmax = dirmax + ret + +set$rlog: + ; rlog(seldsk) = true + lhld olog! call test$vector! rz + lxi d,rlog! jmp set$cdisk + +tst$log$fxs: + lda chksiz+1! ani 80h! rnz + lxi h,log$fxs +tst$log0: + lda fx! mov b,a +tst$log1: + mov a,m! cmp b! rz + inx h! ora a! jnz tst$log1 + inr a! ret + +test$media$flag: + lhld lsn$add! inx h! mov a,m! ora a! ret + +chk$exit$fxs: + lxi h,goback! push h + ; does fx = read or write function? + ; and is drive removable? + lxi h,rw$fxs! call tst$log0! jz chk$media2 ; yes + ; is fx = close or searchn function? + ; and is drive removable? + lxi h,sc$fxs! call tst$log0! jz lret$eq$ff ; yes + pop h! ret + +tst$relog: + lxi h,relog! mov a,m! ora a! rz + mvi m,0 +drv$relog: + call curselect + lxi h,0! shld dcnt! xra a! sta dptr + ret + +set$lsn: + lhld lsn$add! mov c,m + call gets1! mov m,c! ret + +discard$data$bcb: + lhld dtabcba! mvi c,4! jmp discard0 + +discard$data: + lhld dtabcba! jmp discard + +discard$dir: + lhld dirbcba + +discard: + mvi c,1 +discard0: + mov a,l! ana h! inr a! rz + +if BANKED + mov e,m! inx h! mov d,m! xchg +discard1: + push h! push b + lxi d,adrive! call compare + pop b! pop h! jnz discard2 + + mvi m,0ffh +discard2: + lxi d,13! dad d + mov e,m! inx h! mov d,m + xchg! mov a,l! ora h! rz + jmp discard1 +else + push h + lxi d,adrive! call compare + pop h! rnz + mvi m,0ffh! ret +endif + +get$buffa: + push d! lxi d,10! dad d + mov e,m! inx h! mov d,m + +if BANKED + inx h! mov a,m! sta buffer$bank +endif + + xchg! pop d! ret + +rddir: + ; Read a directory entry into the directory buffer + call seek$dir + mvi a,3! jmp wrdir0 + +seek$copy: +wrdir: + ; Write the current directory entry, set checksum + call check$write + call newchecksum ; Initialize entry + mvi a,5 +wrdir0: + lxi h,0! shld last$block + lhld dirbcba + +if BANKED + cpi 5! jnz $+6 + lhld curbcba +endif + + call deblock + +setdata: + ; Set data dma address + lhld dmaad! jmp setdma ; to complete the call + +setdir1: + call get$buffa + +setdma: + ; hl=.dma address to set (i.e., buffa or dmaad) + shld curdma! ret + +dir$to$user: + +if not MPM + ; Copy the directory entry to the user buffer + ; after call to search or searchn by user code + lhld buffa! xchg ; source is directory buffer + lhld xdmaad ; destination is user dma address + lxi b,recsiz ; copy entire record + call movef +endif + ; Set lret to dcnt & 3 if search successful + lxi h,lret! mov a,m! inr a! rz + lda dcnt! ani dskmsk! mov m,a! ret + +make$fcb$inv: ; Flag fcb as invalid + ; Reset fcb write flag + call setfwf + ; Set 1st two bytes of diskmap to ffh + inx h! inx h! mvi a,0ffh! mov m,a! inx h! mov m,a + ret + +chk$inv$fcb: ; Check for invalid fcb + call getdma! jmp test$ffff + +tst$inv$fcb: ; Test for invalid fcb + call chk$inv$fcb! rnz + pop h! mvi a,9! jmp sta$ret! ; lret = 9 + +end$of$dir: + ; Return zero flag if at end of directory, non zero + ; if not at end (end of dir if dcnt = 0ffffh) + lxi h,dcnt +test$ffff: + mov a,m ; may be 0ffh + inx h! cmp m ; low(dcnt) = high(dcnt)? + rnz ; non zero returned if different + ; high and low the same, = 0ffh? + inr a ; 0ffh becomes 00 if so + ret + +set$end$dir: + ; Set dcnt to the end of the directory + lxi h,enddir! shld dcnt! ret + +read$dir: + call r$dir! jmp r$dir1 + +r$dir: + ; Read next directory entry, with c=true if initializing + + lhld dirmax! xchg ; in preparation for subtract + lhld dcnt! inx h! shld dcnt ; dcnt=dcnt+1 + ; Continue while dirmax >= dcnt (dirmax-dcnt no cy) + call subdh ; de-hl + + jc set$end$dir + + read$dir0: + ; not at end of directory, seek next element + ; initialization flag is in c + lda dcnt! ani dskmsk ; low(dcnt) and dskmsk + mvi b,fcbshf ; to multiply by fcb size + read$dir1: + add a! dcr b! jnz read$dir1 + ; a = (low(dcnt) and dskmsk) shl fcbshf + sta dptr ; ready for next dir operation + ora a! rnz ; Return if not a new record + read$dir2: + push b ; Save initialization flag c + call rd$dir ; Read the directory record + pop b ; Recall initialization flag + lda relog! ora a! rnz + jmp checksum ; Checksum the directory elt + +r$dir2: + call read$dir2 +r$dir1: + lda relog! ora a! rz + call chk$exit$fxs + call tst$relog! jmp rd$dir + +getallocbit: + ; Given allocation vector position bc, return with byte + ; containing bc shifted so that the least significant + ; bit is in the low order accumulator position. hl is + ; the address of the byte for possible replacement in + ; memory upon return, and d contains the number of shifts + ; required to place the returned value back into position + mov a,c! ani 111b! inr a! mov e,a! mov d,a + ; d and e both contain the number of bit positions to shift + + mov h,b! mov l,c! mvi c,3 ; bc = bc shr 3 + call hlrotr ; hlrotr does not touch d and e + mov b,h! mov c,l + + lhld alloca ; base address of allocation vector + dad b! mov a,m ; byte to a, hl = .alloc(bc shr 3) + ; Now move the bit to the low order position of a + rotl: rlc! dcr e! jnz rotl! ret + +setallocbit: + ; bc is the bit position of alloc to set or reset. the + ; value of the bit is in register e. + push d! call getallocbit ; shifted val a, count in d + ani 1111$1110b ; mask low bit to zero (may be set) + pop b! ora c ; low bit of c is masked into a + ; jmp rotr ; to rotate back into proper position + ; ret + +rotr: + ; byte value from alloc is in register a, with shift count + ; in register c (to place bit back into position), and + ; target alloc position in registers hl, rotate and replace + rrc! dcr d! jnz rotr ; back into position + mov m,a ; back to alloc + ret + +copy$alv: + ; If Z flag set, copy 1st ALV to 2nd + ; Otherwise, copy 2nd ALV to 1st + +if not BANKED + lda bdos$flags! rlc! rlc! rc +endif + + push a + call get$nalbs! mov b,h! mov c,l + lhld alloca! mov d,h! mov e,l! dad b + pop a! jz movef + xchg! jmp movef + +scandm$ab: + ; Set/Reset 1st and 2nd ALV + push b! call scandm$a + pop b! ;jmp scandm$b + +scandm$b: + ; Set/Reset 2nd ALV + +if not BANKED + lda bdos$flags! ani 40h! rnz +endif + + push b! call get$nalbs + xchg! lhld alloca + pop b! push h! dad d! shld alloca + call scandm$a + pop h! shld alloca! ret + +scandm$a: + ; Set/Reset 1st ALV + ; Scan the disk map addressed by dptr for non-zero + ; entries, the allocation vector entry corresponding + ; to a non-zero entry is set to the value of c (0,1) + call getdptra ; hl = buffa + dptr + ; hl addresses the beginning of the directory entry + lxi d,dskmap! dad d ; hl now addresses the disk map + push b ; Save the 0/1 bit to set + mvi c,fcblen-dskmap+1 ; size of single byte disk map + 1 + scandm0: + ; Loop once for each disk map entry + pop d ; Recall bit parity + dcr c! rz ; all done scanning? + ; no, get next entry for scan + push d ; Replace bit parity + lda single! ora a! jz scandm1 + ; single byte scan operation + push b ; Save counter + push h ; Save map address + mov c,m! mvi b,0 ; bc=block# + jmp scandm2 + scandm1: + ; double byte scan operation + dcr c ; count for double byte + push b ; Save counter + mov c,m! inx h! mov b,m ; bc=block# + push h ; Save map address + scandm2: + ; Arrive here with bc=block#, e=0/1 + mov a,c! ora b ; Skip if = 0000 + jz scandm3 + lhld maxall ; Check invalid index + mov a,l! sub c! mov a,h! sbb b ; maxall - block# + cnc set$alloc$bit + ; bit set to 0/1 + scandm3: + pop h! inx h ; to next bit position + pop b ; Recall counter + jmp scandm0 ; for another item + +get$nalbs: ; Get # of allocation vector bytes + lhld maxall! mvi c,3 + ; number of bytes in allocation vector is (maxall/8)+1 + call hlrotr! inx h! ret + +if MPM + +test$dir: + call home + call set$end$dir +test$dir1: + mvi c,0feh! call read$dir + lda flushed! ora a! rnz + call end$of$dir! rz + jmp test$dir1 +endif + +initialize: + ; Initialize the current disk + ; lret = false ; set to true if $ file exists + ; Compute the length of the allocation vector - 2 + +if MPM + lhld tlog! call test$vector! jz initialize1 + lhld tlog! call remove$drive! shld tlog + xra a! sta flushed + call test$dir! rz +initialize1: +else + + call test$media$flag ! mvi m,0 +;;; call discard$data ;[JCE] DRI Patch 13 +;;; call discard$dir + +endif +;[JCE] DRI Patch 13 + +if BANKED +;;; ; Is drive permanent with no chksum vector? +;;; call chksiz$eq$8000h +;;; jnz initialize2 ; no +;;; ; Is this an initial login operation? +;;; ; register A = 0 +;;; lhld lsn$add +;;; cmp m +;;; mvi m,2 +;;; call test$media$flag +;;; mvi m,0 ; Reset media change flag + call chksiz$eq$8000h + jnz patch$13ff + lhld lsn$add + cmp m + nop + nop + jz patch$13ff + jmp patch$2d40 + +patch$13ff: + + call discard$data + call discard$dir + +initialize2: +else ;BANKED + call discard$data ;[JCE] DRI Patch 13 + call discard$dir + +endif + + call get$nalbs ; Get # of allocation vector bytes + mov b,h! mov c,l ; Count down bc til zero + lhld alloca ; base of allocation vector + ; Fill the allocation vector with zeros + initial0: + mvi m,0! inx h ; alloc(i)=0 + dcx b ; Count length down + mov a,b! ora c! jnz initial0 + + lhld drvlbla! mov m,a ; Zero out drive desc byte + + ; Set the reserved space for the directory + + lhld dirblk! xchg + lhld alloca ; hl=.alloc() + mov m,e! inx h! mov m,d ; sets reserved directory blks + ; allocation vector initialized, home disk + call home + ; cdrmax = 3 (scans at least one directory record) + lhld cdrmaxa! mvi m,4! inx h! mvi m,0 + + call set$end$dir ; dcnt = enddir + lhld hashtbla! shld arecord1 + + ; Read directory entries and check for allocated storage + + initial2: + mvi c,true! call read$dir + call end$of$dir +if BANKED + jz patch$2d6a ;[JCE] DRI Patch 13 +else + jz copy$alv +endif + ; not end of directory, valid entry? + call getdptra ; hl = buffa + dptr + xchg! lhld arecord1! mov a,h! ana l! inr a! xchg + ; is hashtbla ~= 0ffffh + cnz init$hash ; yes - call init$hash + mvi a,21h! cmp m + jz initial2 ; Skip date & time records + + mvi a,empty! cmp m + jz initial2 ; go get another item + + mvi a,20h! cmp m! jz drv$lbl + mvi a,10h! ana m! jnz initial3 + + ; Now scan the disk map for allocated blocks + + mvi c,1 ; set to allocated + call scandm$a + initial3: + call setcdr ; set cdrmax to dcnt + jmp initial2 ; for another entry + +drv$lbl: + lxi d,extnum! dad d! mov a,m + lhld drvlbla! mov m,a! jmp initial3 + +copy$dirloc: + ; Copy directory location to lret following + ; delete, rename, ... ops + + lda dirloc! jmp sta$ret + ; ret + +compext: + ; Compare extent# in a with that in c, return nonzero + ; if they do not match + push b ; Save c's original value + push psw! lda extmsk! cma! mov b,a + ; b has negated form of extent mask + mov a,c! ana b! mov c,a ; low bits removed from c + pop psw! ana b ; low bits removed from a + sub c! ani maxext ; Set flags + pop b ; Restore original values + ret + +get$dir$ext: + ; Compute directory extent from fcb + ; Scan fcb disk map backwards + call getfcba ; hl = .fcb(vrecord) + mvi c,16! mov b,c! inr c! push b + ; b=dskmap pos (rel to 0) +get$de0: + pop b + dcr c + xra a ; Compare to zero +get$de1: + dcx h! dcr b; Decr dskmap position + cmp m! jnz get$de2 ; fcb(dskmap(b)) ~= 0 + dcr c! jnz get$de1 + ; c = 0 -> all blocks = 0 in fcb disk map +get$de2: + mov a,c! sta dminx + lda single! ora a! mov a,b + jnz get$de3 + rar ; not single, divide blk idx by 2 +get$de3: + push b! push h ; Save dskmap position & count + mov l,a! mvi h,0 ; hl = non-zero blk idx + ; Compute ext offset from last non-zero + ; block index by shifting blk idx right + ; 7 - blkshf + lda blkshf! mov d,a! mvi a,7! sub d + mov c,a! call hlrotr! mov b,l + ; b = ext offset + lda extmsk! cmp b! pop h! jc get$de0 + ; Verify computed extent offset <= extmsk + call getexta! mov c,m + cma! ani maxext! ana c! ora b + ; dir ext = (fcb ext & (~ extmsk) & maxext) | ext offset + pop b ; Restore stack + ret ; a = directory extent + +searchi: + ; search initialization + lhld info! shld searcha ; searcha = info +searchi1: + mov a,c! sta searchl ; searchl = c + call set$hash + mvi a,0ffh! sta dirloc ; changed if actually found + ret + +search$namlen: + mvi c,namlen! jmp search +search$extnum: + mvi c,extnum +search: + ; Search for directory element of length c at info + call searchi +search1: ; entry point used by rename + call set$end$dir ; dcnt = enddir + call tst$log$fxs! cz home + ; (drop through to searchn) + +searchn: + ; Search for the next directory element, assuming + ; a previous call on search which sets searcha and + ; searchl + +if MPM + lxi h,user0$pass! xra a! cmp m! mov m,a! cnz swap +else + xra a! sta user0$pass +endif + + call search$hash! jnz search$fin + mvi c,false! call read$dir ; Read next dir element + call end$of$dir! jz search$fin + ; not end of directory, scan for match + lhld searcha! xchg ; de=beginning of user fcb + ldax d ; first character + cpi empty ; Keep scanning if empty + jz searchnext + ; not empty, may be end of logical directory + push d ; Save search address + call compcdr ; past logical end? + pop d ; Recall address + jnc search$fin ; artificial stop +searchnext: + call getdptra ; hl = buffa+dptr + lda searchl! mov c,a ; length of search to c + mvi b,0 ; b counts up, c counts down + + mov a,m! cpi empty! cz save$dcnt$pos1 + +if BANKED + xra a! sta save$xfcb + mov a,m! ani 1110$1111b! cmp m! jz search$loop + xchg! cmp m! xchg! jnz search$loop + lda find$xfcb! ora a! jz search$n + sta save$xfcb! jmp searchok +endif + + searchloop: + mov a,c! ora a! jz endsearch + ldax d! cpi '?'! jz searchok ; ? in user fcb + ; Scan next character if not ubytes + mov a,b! cpi ubytes! jz searchok + ; not the ubytes field, extent field? + cpi extnum ; may be extent field + jz searchext ; Skip to search extent + cpi modnum! ldax d! cz searchmod + sub m! ani 7fh ; Mask-out flags/extent modulus + jnz searchnm ; Skip if not matched + jmp searchok ; matched character + searchext: + ldax d + ; Attempt an extent # match + push b ; Save counters + +if MPM + push h + lhld sdcnt + inr h! jnz dont$save + lhld dcnt! shld sdcnt + lhld dblk! shld sdblk + dont$save: + pop h +endif + + mov c,m ; directory character to c + call compext ; Compare user/dir char + + mov b,a + lda user0pass! inr a! jz save$dcnt$pos2 + ; Disable search of user 0 if any fcb + ; is found under the current user # + xra a! sta search$user0 + mov a,b + + pop b ; Recall counters + ora a ; Set flag + jnz searchn ; Skip if no match + searchok: + ; current character matches + inx d! inx h! inr b! dcr c + jmp searchloop + endsearch: + ; entire name matches, return dir position + +if BANKED + lda save$xfcb! inr a! jnz endsearch1 + lda xdcnt+1! cpi 0feh! cz save$dcnt$pos0 + jmp searchn + endsearch1: +endif + + xra a! sta dirloc ; dirloc = 0 + sta lret ; lret = 0 + ; successful search - + ; return with zero flag reset + mov b,a! inr b! ret + searchmod: + ani 3fh! ret ; Mask off high 2 bits + search$fin: + ; end of directory, or empty name + + call save$dcnt$pos1 + + ; Set dcnt = 0ffffh + call set$end$dir ; may be artifical end + lret$eq$ff: + ; unsuccessful search - + ; return with zero flag set + ; lret,low(aret) = 0ffh + mvi a,255! mov b,a! inr b! jmp sta$ret + + searchnm: ; search no match routine + mov a,b! ora a! jnz searchn ; fcb(0)? + mov a,m! ora a! jnz searchn ; dir fcb(0)=0? + lda search$user0! ora a! jz searchn + sta user0$pass + +if MPM + call swap +endif + + jmp searchok + +if MPM + +swap: ; Swap dcnt,sdblk with sdcnt0,sdblk0 + push h! push d! push b + lxi d,sdcnt! lxi h,sdcnt0 + mvi b,4 +swap1: + ldax d! mov c,a! mov a,m + stax d! mov m,c + inx h! inx d! dcr b! jnz swap1 + pop b! pop d! pop h! + ret +endif + +save$dcnt$pos2: + ; Save directory position of matching fcb + ; under user 0 with matching extent # & modnum = 0 + ; a = 0 on entry + ora b! pop b! lxi b,searchn! push b! rnz + inx h! inx h! mov a,m! ora a! rnz + ; Call if user0pass = 0ffh & + ; dir fcb(extnum) = fcb(extnum) + ; dir fcb(modnum) = 0 +save$dcnt$pos0: + call save$dcnt$pos ; Return to searchn +save$dcnt$pos1: + ; Save directory position of first empty fcb + ; or the end of the directory + + push h + lhld xdcnt + inr h! jnz save$dcnt$pos$ret ; Return if h ~= 0ffh + + +save$dcnt$pos: + lhld dcnt! shld xdcnt + +if MPM + lhld dblk! shld xdblk +endif + +save$dcnt$pos$ret: + pop h! ret + +if BANKED + +init$xfcb$search: + mvi a,0ffh +init$xfcb$search1: + sta find$xfcb! mvi a,0feh! sta xdcnt+1! ret + +does$xfcb$exist: + lda xdcnt+1! cpi 0feh! rz + call set$dcnt$dblk + xra a! call init$xfcb$search1 + lhld searcha! mov a,m! ori 10h! mov m,a + mvi c,extnum! call searchi1! jmp searchn + +xdcnt$eq$dcnt: + lhld dcnt! shld xdcnt! ret + +restore$dir$fcb: + call set$dcnt$dblk + mvi c,namlen! call searchi! jmp searchn +endif + +delete: + ; Delete the currently addressed file + call get$atts + +if BANKED + sta attributes + ; Make search return matching fcbs and xfcbs +deletex: + mvi a,0feh! call init$xfcb$search1 +else + ; Return with aret = 0 for XFCB only delete + ; in non-banked systems + ral! rc +endif + +; Delete pass 1 - check r/o attributes and xfcb passwords + + call search$extnum! rz + + delete00: + jz delete1 + +if BANKED + ; Is addressed dir fcb an xfcb? + call getdptra! mov a,m! ani 10h! jnz delete01 ; yes + +if MPM + call tst$olist ; Verify fcb not open by someone else +endif + + ; Check r/o attribute if this is not an + ; xfcb only delete operation. + lda attributes! ral! cnc check$rodir +else + call check$rodir +endif + +if BANKED + ; Are xfcb passwords enabled? + call get$dir$mode! ral! jc delete02 ; no +endif + + ; Is this a wild card delete operation? + lhld info! call chk$wild! jz delete02 ; yes + ; Not wild & passwords inactive + ; Skip to pass 2 + jmp delete11 + +if BANKED + + delete01: + ; Check xfcb password if passwords enabled + call get$dir$mode! ral! jnc delete02 + call chk$xfcb$password! jz delete02 + call chk$pw$error! jmp deletex +endif + + delete02: + call searchn! jmp delete00 + +; Delete pass 2 - delete all matching fcbs and/or xfcbs. + +delete1: + call search$extnum + + delete10: + jz copy$dir$loc + delete11: + call getdptra + +if BANKED + ; Is addressed dir fcb an xfcb? + mov a,m! ani 10h! jnz delete12 ; yes +if MPM + push h + call chk$olist ; Delete olist item if present + pop h +endif + ; Is this delete operation xfcb only? + lda attributes! ani 80h! jnz delete13 ; yes +endif + + delete12: + ; Delete dir fcb or xfcb + ; if fcb free all alocated blocks. + + mvi m,empty + +if BANKED + + delete13: + push a ; Z flag set => free FCB blocks + ; Zero password mode byte in sfcb if sfcb exists + ; Does sfcb exist? + call get$dtba$8! ora a! jnz $+4 ; no + ; Zero mode byte + mov m,a +endif + + call wrdir! mvi c,0 + +if BANKED + pop a! cz scandm$ab +else + call scandm$ab +endif + + call fix$hash + call searchn! jmp delete10 + +get$block: + ; Given allocation vector position bc, find the zero bit + ; closest to this position by searching left and right. + ; if found, set the bit to one and return the bit position + ; in hl. if not found (i.e., we pass 0 on the left, or + ; maxall on the right), return 0000 in hl + mov d,b! mov e,c ; copy of starting position to de + righttst: + lhld maxall ; value of maximum allocation# + mov a,e! sub l! mov a,d! sbb h ; right=maxall? + jnc retblock0 ; return block 0000 if so + inx d! push b! push d ; left, right pushed + mov b,d! mov c,e ; ready right for call + call getallocbit + rar! jnc retblock ; Return block number if zero + pop d! pop b ; Restore left and right pointers + lefttst: + mov a,c! ora b! jz righttst ; Skip if left=0000 + ; left not at position zero, bit zero? + dcx b! push d! push b ; left,right pushed + call getallocbit + rar! jnc retblock ; return block number if zero + ; bit is one, so try the right + pop b! pop d ; left, right restored + jmp righttst + retblock: + ral! inr a ; bit back into position and set to 1 + ; d contains the number of shifts required to reposition + call rotr ; move bit back to position and store + pop h! pop d ; hl returned value, de discarded + ret + retblock0: + ; cannot find an available bit, return 0000 + mov a,c + ora b! jnz lefttst ; also at beginning + lxi h,0000h! ret + +copy$dir: + ; Copy fcb information starting at c for e bytes + ; into the currently addressed directory entry + mvi d,80h +copy$dir0: + call copy$dir2 + inr c +copy$dir1: + dcr c! jz seek$copy + mov a,m! ana b! push b + mov b,a! ldax d! ani 7fh! ora b! mov m,a + pop b! inx h! inx d! jmp copy$dir1 +copy$dir2: + push d ; Save length for later + mvi b,0 ; double index to bc + lhld info ; hl = source for data + dad b + inx h! mov a,m! sui '$'! cz set$submit$flag + dcx h! xchg ; de=.fcb(c), source for copy + call getdptra ; hl=.buff(dptr), destination + pop b ; de=source, hl=dest, c=length + ret + +set$submit$flag: + lxi d,ccp$flgs! ldax d! ori 1! stax d! ret + +check$wild: + ; Check for ? in file name or type + lhld info +check$wild0: ; entry point used by rename + call chk$wild! rnz + mvi a,9! jmp set$aret + +chk$wild: + mvi c,11 +chk$wild1: + inx h! mvi a,3fh! sub m! ani 7fh! rz + dcr c! jnz chk$wild1! ora a! ret + +copy$user$no: + lhld info! mov a,m! lxi b,dskmap + dad b! mov m,a! ret + +rename: + ; Rename the file described by the first half of + ; the currently addressed file control block. The + ; new name is contained in the last half of the + ; currently addressed file control block. The file + ; name and type are changed, but the reel number + ; is ignored. The user number is identical. + + ; Verify that the new file name does not exist. + ; Also verify that no wild chars exist in + ; either filename. + +if MPM + call getatts! sta attributes +endif + + ; Verify that no wild chars exist in 1st filename. + call check$wild + +if BANKED + ; Check password of file to be renamed. + call chk$password! cnz chk$pw$error + ; Setup search to scan for xfcbs. + call init$xfcb$search +endif + + ; Copy user number to 2nd filename + call copy$user$no + shld searcha + + ; Verify no wild chars exist in 2nd filename + call check$wild0 + + ; Verify new filename does not already exist + mvi c,extnum! lhld searcha! call searchi1! call search1 + jnz file$exists ; New filename exists + +if BANKED + ; If an xfcb exists for the new filename, delete it. + call does$xfcb$exist! cnz delete11 +endif + + call copy$user$no + +if BANKED + call init$xfcb$search +endif + + ; Search up to the extent field + call search$extnum + rz + call check$rodir ; may be r/o file + +if MPM + call chk$olist +endif + + ; Copy position 0 + rename0: + ; not end of directory, rename next element + mvi c,dskmap! mvi e,extnum! call copy$dir + ; element renamed, move to next + + call fix$hash + call searchn + jnz rename0 + rename1: + +if BANKED + call does$xfcb$exist! jz copy$dir$loc + call copy$user$no! jmp rename0 +else + jmp copy$dir$loc +endif + +indicators: + ; Set file indicators for current fcb + call get$atts ; Clear f5' through f8' + sta attributes + +if BANKED + call chk$password! cnz chk$pw$error +endif + + call search$extnum ; through file type + rz + +if MPM + call chk$olist +endif + + indic0: + ; not end of directory, continue to change + mvi c,0! mvi e,extnum ; Copy name + call copy$dir2! call move + lda attributes! ani 40h! jz indic1 + + ; If interface att f6' set, dir fcb(s1) = fcb(cr) + + push h! call getfcba! mov a,m + pop h! inx h! mov m,a + indic1: + call seek$copy + call searchn + jz copy$dir$loc + jmp indic0 + +open: + ; Search for the directory entry, copy to fcb +;;; call search$namlen ;[JCE] DRI Patch 13 + call patch$1e3e +open1: + rz ; Return with lret=255 if end + ; not end of directory, copy fcb information +open$copy: + call setfwf! mov e,a! push h! dcx h! dcx h + mov d,m! push d ; Save extent# & module# with fcb write flag set + call getdptra! xchg ; hl = .buff(dptr) + lhld info ; hl=.fcb(0) + mvi c,nxtrec ; length of move operation + call move ; from .buff(dptr) to .fcb(0) + ; Note that entire fcb is copied, including indicators + call get$dir$ext! mov c,a + ; Restore module # and extent # + pop d! pop h! mov m,e! dcx h! dcx h! mov m,d + ; hl = .user extent#, c = dir extent# + ; above move set fcb(reccnt) to dir(reccnt) + ; if fcb ext < dir ext then fcb(reccnt) = fcb(reccnt) | 128 + ; if fcb ext = dir ext then fcb(reccnt) = fcb(reccnt) + ; if fcb ext > dir ext then fcb(reccnt) = 0 + +set$rc: ; hl=.fcb(ext), c=dirext + mvi b,0 + xchg! lxi h,(reccnt-extnum)! dad d + ; Is fcb ext = dirext? + ldax d! sub c! jz set$rc2 ; yes + ; Is fcb ext > dirext? + mov a,b! jnc set$rc1 ; yes - fcb(rc) = 0 + ; fcb ext < dirext + ; fcb(rc) = 128 | fcb(rc) + mvi a,128! ora m + set$rc1: + mov m,a! ret + set$rc2: + ; fcb ext = dirext + mov a,m! ora a! rnz ; ret if fcb(rc) ~= 0 + set$rc3: + mvi m,0 ; required by function 99 + lda dminx! ora a! rz ; ret if no blks in fcb + mvi m,128! ret ; fcb(rc) = 128 + +mergezero: + ; hl = .fcb1(i), de = .fcb2(i), + ; if fcb1(i) = 0 then fcb1(i) := fcb2(i) + mov a,m! inx h! ora m! dcx h! rnz ; return if = 0000 + ldax d! mov m,a! inx d! inx h ; low byte copied + ldax d! mov m,a! dcx d! dcx h ; back to input form + ret + +restore$rc: + ; hl = .fcb(extnum) + ; if fcb(rc) > 80h then fcb(rc) = fcb(rc) & 7fh + push h + lxi d,(reccnt-extnum)! dad d + mov a,m! cpi 81h! jc restore$rc1 + ani 7fh! mov m,a +restore$rc1: + pop h! ret + +close: + ; Locate the directory element and re-write it + xra a! sta lret + +if MPM + sta dont$close +endif + + call nowrite! rnz ; Skip close if r/o disk + ; Check file write flag - 0 indicates written + call getmodnum ; fcb(modnum) in a + ani fwfmsk! rnz ; Return if bit remains set +close1: + call chk$inv$fcb! jz mergerr + +if MPM + call set$fcb$cks$flag +endif + +;;; call get$dir$ext + call patch$1dfd ;[JCE] DRI patch 7 + + mov c,a + mov b,m + push b + ; b = original extent, c = directory extent + ; Set fcb(ex) to directory extent + mov m,c + ; Recompute fcb(rc) + call restore$rc + ; Call set$rc if fcb ext > dir ext + mov a,c! cmp b! cc set$rc + call close$fcb + ; Restore original extent & reset fcb(rc) + call get$exta! pop b + mov c,m! mov m,b! jmp set$rc ; Reset fcb(rc) + +close$fcb: + ; Locate file + call search$namlen + rz ; Return if not found + ; Merge the disk map at info with that at buff(dptr) + lxi b,dskmap! call get$fcb$adds + mvi c,(fcblen-dskmap) ; length of single byte dm + merge0: + lda single! ora a! jz merged ; Skip to double + ; This is a single byte map + ; if fcb(i) = 0 then fcb(i) = buff(i) + ; if buff(i) = 0 then buff(i) = fcb(i) + ; if fcb(i) <> buff(i) then error + mov a,m! ora a! ldax d! jnz fcbnzero + ; fcb(i) = 0 + mov m,a ; fcb(i) = buff(i) + fcbnzero: + ora a! jnz buffnzero + ; buff(i) = 0 + mov a,m! stax d ; buff(i)=fcb(i) + buffnzero: + cmp m! jnz mergerr ; fcb(i) = buff(i)? + jmp dmset ; if merge ok + merged: + ; This is a double byte merge operation + call mergezero ; buff = fcb if buff 0000 + xchg! call mergezero! xchg ; fcb = buff if fcb 0000 + ; They should be identical at this point + ldax d! cmp m! jnz mergerr ; low same? + inx d! inx h ; to high byte + ldax d! cmp m! jnz mergerr ; high same? + ; merge operation ok for this pair + dcr c ; extra count for double byte + dmset: + inx d! inx h ; to next byte position + dcr c! jnz merge0 ; for more + ; end of disk map merge, check record count + ; de = .buff(dptr)+32, hl = .fcb(32) + + xchg! lxi b,-(fcblen-extnum)! dad b! push h + call get$dir$ext! pop d + + ; hl = .fcb(extnum), de = .buff(dptr+extnum) + + call compare$extents + + ; b=1 -> fcb(ext) ~= dir ext = buff(ext) + ; b=2 -> fcb(ext) = dir ext ~= buff(ext) + ; b=3 -> fcb(ext) = dir ext = buff(ext) + + ; fcb(ext), buff(ext) = dir ext + mov m,a! stax d! push b + + lxi b,(reccnt-extnum)! dad b! xchg! dad b + pop b + + ; hl = .buff(rc) , de = .fcb(rc) + + dcr b! jz mrg$rc1 ; fcb(rc) = buff(rc) + + dcr b! jz mrg$rc2 ; buff(rc) = fcb(rc) + + ldax d! cmp m! jc mrg$rc1 ; Take larger rc + ora a! jnz mrg$rc2 + call set$rc3 + + mrg$rc1: xchg + + mrg$rc2: ldax d! mov m,a + +if MPM + lda dont$close! ora a! rnz +endif + + ; Set t3' off indicating file update + call getdptra! lxi d,11! dad d + mov a,m! ani 7fh! mov m,a + call setfwf + mvi c,1! call scandm$b ; Set 2nd ALV vector + jmp seek$copy ; OK to "wrdir" here - 1.4 compat + ; ret + mergerr: + ; elements did not merge correctly + call make$fcb$inv + jmp lret$eq$ff + +compare$extents: + mvi b,1! cmp m! rnz + inr b! xchg! cmp m! xchg! rnz + inr b! ret + +set$xdcnt: + lxi h,0ffffh! shld xdcnt! ret + +set$dcnt$dblk: + lhld xdcnt +set$dcnt$dblk1: + mvi a,1111$1100b! ana l + mov l,a! dcx h! shld dcnt + +if MPM + lhld xdblk! shld dblk +endif + + ret + +if MPM + +sdcnt$eq$xdcnt: + lxi h,sdcnt! lxi d,xdcnt! mvi c,4 + jmp move +endif + +make: + ; Create a new file by creating a directory entry + ; then opening the file + +;;; lxi h,xdcnt ;[JCE] DRI Patch 13 + call patch$1e31 + + call test$ffff! cnz set$dcnt$dblk + + lhld info! push h ; Save fcb address, Look for E5 + lxi h,efcb! shld info ; info = .empty + mvi c,1 + + call searchi! call searchn + + ; zero flag set if no space + pop h ; Recall info address + shld info ; in case we return here + rz ; Return with error condition 255 if not found + +if BANKED + ; Return early if making an xfcb + lda make$xfcb! ora a! rnz +endif + + ; Clear the remainder of the fcb + ; Clear s1 byte + lxi d,13! dad d! mov m,d! inx h + ; Clear and save file write flag of modnum + mov a,m! push a! push h! ani 3fh! mov m,a! inx h + mvi a,1 + mvi c,fcblen-namlen ; number of bytes to fill + make0: + mov m,d! inx h! dcr c! jnz make0 + dcr a! mov c,d! cz get$dtba + ora a! mvi c,10! jz make0 + call setcdr ; may have extended the directory + ; Now copy entry to the directory + mvi c,0! lxi d,fcblen! call copy$dir0 + ; and restore the file write flag + pop h! pop a! mov m,a + ; and set the fcb write flag to "1" + call fix$hash + jmp setfwf + +open$reel: + ; Close the current extent, and open the next one + ; if possible. rmf is true if in read mode + +if BANKED + call reset$copy$cr$only +endif + + call getexta + mov a,m! mov c,a + inr c! call compext + jz open$reel3 + push h! push b + call close + pop b! pop h + lda lret! inr a! rz + mvi a,maxext! ana c! mov m,a ; Incr extent field + ; Advance to module & save + inx h! inx h! mov a,m! sta save$mod + jnz open$reel0 ; Jump if in same module + + open$mod: + ; Extent number overflow, go to next module + inr m ; fcb(modnum)=++1 + ; Module number incremented, check for overflow + + mov a,m! ani 3fh ; Mask high order bits + + jz open$r$err ; cannot overflow to zero + + ; otherwise, ok to continue with new module + open$reel0: + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + +;;; call search$namlen ;[JCE] DRI Patch 13 + call patch$1e3e ;Next extent found? + + jnz open$reel1 + ; end of file encountered + lda rmf! inr a ; 0ffh becomes 00 if read + jz open$r$err ; sets lret = 1 + ; Try to extend the current file + call make + ; cannot be end of directory + jz open$r$err ; with lret = 1 + +if MPM + call fix$olist$item + call set$fcb$cks$flag +endif + + jmp open$reel2 + open$reel1: + ; not end of file, open + call open$copy + +if MPM + call set$fcb$cks$flag +endif + + open$reel2: + +if not MPM + call set$lsn +endif + + call getfcb ; Set parameters + xra a! sta vrecord! jmp sta$ret ; lret = 0 + ; ret ; with lret = 0 + open$r$err: + ; Restore module and extent + call getmodnum! lda save$mod! mov m,a + dcx h! dcx h! mov a,m! dcr a! ani 1fh + mov m,a! jmp setlret1 ; lret = 1 + + open$reel3: + inr m ; fcb(ex) = fcb(ex) + 1 + call get$dir$ext! mov c,a + ; Is new extent beyond dir$ext? + cmp m! jnc open$reel4 ; no + dcr m ; fcb(ex) = fcb(ex) - 1 + ; Is this a read fx? + lda rmf! inr a! jz set$lret1 ; yes - Don't advance ext + inr m ; fcb(ex) = fcb(ex) + 1 + open$reel4: + call restore$rc + call set$rc! jmp open$reel2 + +seqdiskread: +diskread: ; (may enter from seqdiskread) + call tst$inv$fcb ; Check for valid fcb + mvi a,true! sta rmf ; read mode flag = true (open$reel) + +if MPM + sta dont$close +endif + + ; Read the next record from the current fcb + call getfcb ; sets parameters for the read +diskread0: + lda vrecord! lxi h,rcount! cmp m ; vrecord-rcount + ; Skip if rcount > vrecord + jc recordok + +if MPM + call test$disk$fcb! jnz diskread0 + lda vrecord +endif + + ; not enough records in the extent + ; record count must be 128 to continue + cpi 128 ; vrecord = 128? + jnz setlret1 ; Skip if vrecord<>128 + call open$reel ; Go to next extent if so + ; Check for open ok + lda lret! ora a! jnz setlret1 ; Stop at eof + recordok: + ; Arrive with fcb addressing a record to read + +if BANKED + call set$copy$cr$only +endif + + call index ; Z flag set if arecord = 0 + +if MPM + jnz recordok1 + call test$disk$fcb! jnz diskread0 +endif + + jz setlret1 ; Reading unwritten data + recordok1: + ; Record has been allocated, read it + call atran ; arecord now a disk address + call check$nprs + jc setfcb + jnz read$deblock + + call setdata + call seek ; to proper track,sector + +if BANKED + mvi a,1! call setbnkf +endif + + call rdbuff ; to dma address + jmp setfcb ; Replace parameter + +read$deblock: + lxi h,0! shld last$block + mvi a,1! call deblock$dta + jmp setfcb + +check$nprs: + ; + ; on exit, c flg -> no i/o operation + ; z flg & ~c flg -> direct(physical) i/o operation + ; ~z flg & ~c flg -> indirect(deblock) i/o operation + ; + ; Dir$cnt contains the number of 128 byte records + ; to transfer directly. This routine sets dir$cnt + ; when initiating a sequence of direct physical + ; i/o operations. Dir$cnt is decremented each + ; time check$nprs is called during such a sequence. + ; + ; Is direct transfer operation in progress? + lda blk$off! mov b,a + lda phy$msk! mov c,a! ana b! push a + lda dir$cnt! cpi 2! jc check$npr1 ; no + ; yes - Decrement direct record count + dcr a! sta dir$cnt + ; Are we at a new physical record? + pop a! stc! rnz ; no - ret with c flg set + ; Perform physical i/o operation + xra a! ret ; Return with z flag set and c flag reset +check$npr1: + ; Are we in mid-physical record? + pop a! jz check$npr11 ; no +check$npr1a: + ; Is phymsk = 0? + mov a,c! ora a! rz ; yes - Don't deblock +check$npr1b: + ; Deblocking required + ori 1! ret ; ret with z flg reset and c flg reset +check$npr11: + mov a,c! cma! mov d,a ; d = ~phy$msk + lxi h,vrecord + ; Is mult$num < 2? + lda mult$num! cpi 2! jc check$npr1a ; yes + add m! cpi 80h! jc check$npr2 + mvi a,80h +check$npr2: ; a = min(vrecord + mult$num),80h) = x + push b ; Save low(arecord) & blkmsk, phymsk + mov b,m! mvi m,7fh ; vrecord = 7f + push b ; Save vrecord + push h ; Save .vrecord + push a ; Save x + lda blkmsk! mov e,a! inr e! cma! ana b! mov b,a + ; b = vrecord & ~blkmsk + ; e = blkmsk + 1 + pop h ; h = x + ; Is this a read function? + lda rmf! ora a! jz check$npr21 ; no + ; Is rcount & ~phymsk < x? + lda rcount! ana d! cmp h! jc check$npr23 ; yes +check$npr21: + mov a,h ; a = x +check$npr23: + sub b ; a = a - vrecord & ~blkmsk + mov c,a ; c = max # of records from beginning of curr blk + ; Is c < blkmsk+1? + cmp e! jc check$npr8 ; yes + +if BANKED + push b ; c = max # of records + ; Compute maximum disk map position + call dm$position + mov b,a ; b = index of last block in extent + ; Does the last block # = the current block #? + lda dminx! cmp b! mov e,a! jz check$npr5 ; yes + ; Compute # of blocks in sequence + mov c,a! push b! mvi b,0 + call get$dm ; hl = current block # +check$npr4: + ; Get next block # + push h! inx b! call get$dm + pop d! inx d + ; Does next block # = previous block # + 1? + mov a,d! sub h! mov d,a + mov a,e! sub l! ora d! jz check$npr4 ; yes + ; Is next block # = 0? + mov a,h! ora l! jnz check$npr45 ; no + ; Is this a read function? + lda rmf! ora a! jnz check$npr45 ; no + ; Is next block # > maxall? + lhld maxall! mov a,l! sub e + mov a,h! sbb d! jc check$npr45 ; yes + ; Is next block # allocated? + push b! push d! mov b,d! mov c,e + call getallocbit! pop h! pop b + rar! jnc check$npr4 ; no - it will be later +check$npr45: + dcr c! pop d + ; Is max dm position less than c? + mov a,d! cmp c! jc check$npr5 ; yes + mov a,c ; no +check$npr5: ; a = index of last block + sub e! mov b,a! inr b ; b = # of consecutive blks + lda blkmsk! inr a! mov c,a +check$npr6: + dcr b! jz check$npr7 + add c! jmp check$npr6 +check$npr7: + pop b + mov b,c ; b = max # of records + mov c,a ; c = (# of consecutive blks)*(blkmsk+1) + lda rmf! ora a! jz check$npr8 + mov a,b! cmp c! jc check$npr9 +else + mov c,e ; multis-sector max = 1 block in non-banked systems +endif + +check$npr8: + mov a,c +check$npr9: + ; Restore vrecord + pop h! pop b! mov m,b + pop b + ; a = max # of consecutive records including current blk + ; b = low(arecord) & blkmsk + ; c = phymsk + ; Is mult$num > a - b + lxi h,mult$num! mov d,m + sub b! cmp d! jnc check$npr10 + mov d,a ; yes - use smaller value to compute dir$cnt +check$npr10: + ; Does this operation involve at least 1 physical record? + mov a,c! cma! ana d! sta dir$cnt! jz check$npr1b ; Deblocking required + ; Flush any pending buffers before doing multiple reads + push a! lda rmf! ora a! jz check$npr10a + call flushx! call setdata +check$npr10a: + pop a! mov h,a ; Save # of 128 byte records + ; Does this operation involve more than 1 physical record? + ; Register h contains number of 128 byte records + call shr$physhf! mov a,h + cpi 1! mov c,a! cnz mult$iof ; yes - Make bios call + xra a! ret ; Return with z flg set + +if MPM + +test$unlocked: + lda high$ext! ani 80h! ret + +test$disk$fcb: + call test$unlocked! rz + lda dont$close! ora a! rz + call close1 +test$disk$fcb1: + pop d + lxi h,lret! inr m! mvi a,11! jz sta$ret + mvi m,0 + push d + call getrcnta! mov a,m! sta rcount ; Reset rcount + xra a! sta dont$close + inr a! ret +endif + +reset$fwf: + call getmodnum ; hl=.fcb(modnum), a=fcb(modnum) + ; Reset the file write flag to mark as written fcb + ani (not fwfmsk) and 0ffh ; bit reset + mov m,a ; fcb(modnum) = fcb(modnum) and 7fh + ret + +set$filewf: + call getmodnum! ani 0100$0000b! push a + mov a,m! ori 0100$0000b! mov m,a! pop a! ret + +seqdiskwrite: +diskwrite: ; (may enter here from seqdiskwrite above) + mvi a,false! sta rmf ; read mode flag + ; Write record to currently selected file + + call check$write ; in case write protected + +if BANKED + lda xfcb$read$only! ora a + mvi a,3! jnz set$aret +endif + + lda high$ext + +if MPM + ani 0100$0000b +else + ora a +endif + + ; Z flag reset if r/o mode + mvi a,3! jnz set$aret + + lhld info ; hl = .fcb(0) + call check$rofile ; may be a read-only file + + call tst$inv$fcb ; Test for invalid fcb + + call update$stamp + + call getfcb ; to set local parameters + lda vrecord! cpi lstrec+1 ; vrecord-128 + jc diskwrite0 + call open$reel ; vrecord = 128, try to open next extent + lda lret! ora a! rnz ; no available fcb +disk$write0: + +if MPM + mvi a,0ffh! sta dont$close +disk$write1: + +endif + + ; Can write the next record, so continue + call index ; Z flag set if arecord = 0 + jz diskwrite2 + ; Was the last write operation for the same block & drive? + lxi h,adrive! lxi d,last$drive! mvi c,3 + call compare! jz diskwrite15 ; yes + ; no - force preread in blocking/deblocking + mvi a,0ffh! sta last$off +diskwrite15: + +if MPM + ; If file is unlocked, verify record is not locked + ; Record has to be allocated to be locked + call test$unlocked! jz not$unlocked + call atran! mov c,a + lda mult$cnt! mov b,a! push b + call test$lock! pop b + xra a! mov c,a! push b + jmp diskwr10 +not$unlocked: + inr a +endif + + mvi c,0 ; Marked as normal write operation for wrbuff + jmp diskwr1 +diskwrite2: + +if MPM + call test$disk$fcb! jnz diskwrite1 +endif + +if BANKED + call reset$copy$cr$only +endif + + ; not allocated + ; The argument to getblock is the starting + ; position for the disk search, and should be + ; the last allocated block for this file, or + ; the value 0 if no space has been allocated + call dm$position + sta dminx ; Save for later + lxi b,0000h ; May use block zero + ora a! jz nopblock ; Skip if no previous block + ; Previous block exists at a + mov c,a! dcx b ; Previous block # in bc + call getdm ; Previous block # to hl + mov b,h! mov c,l ; bc=prev block# + nopblock: + ; bc = 0000, or previous block # + call get$block ; block # to hl + ; Arrive here with block# or zero + mov a,l! ora h! jnz blockok + ; Cannot find a block to allocate + mvi a,2! jmp sta$ret ; lret=2 + blockok: + +if MPM + call set$fcb$cks$flag +endif + + ; allocated block number is in hl + shld arecord! shld last$block! xra a! sta last$off + lda adrive! sta lastdrive + xchg ; block number to de + lhld info! lxi b,dskmap! dad b ; hl=.fcb(dskmap) + lda single! ora a ; Set flags for single byte dm + lda dminx ; Recall dm index + jz allocwd ; Skip if allocating word + ; Allocating a byte value + call addh! mov m,e ; single byte alloc + jmp diskwru ; to continue + allocwd: + ; Allocate a word value + mov c,a! mvi b,0 ; double(dminx) + dad b! dad b ; hl=.fcb(dminx*2) + mov m,e! inx h! mov m,d ; double wd + diskwru: + ; disk write to previously unallocated block + mvi c,2 ; marked as unallocated write + diskwr1: + ; Continue the write operation of no allocation error + ; c = 0 if normal write, 2 if to prev unalloc block + push b ; Save write flag + call atran ; arecord set +diskwr10: + lda fx! cpi 40! jnz diskwr11 ; fx ~= wrt rndm zero fill + mov a,c! dcr a! dcr a! jnz diskwr11 ; old allocation + + ; write random zero fill + new block + + pop b! push a ; zero write flag + lhld arecord! push h + lxi h,phymsk! mov e,m! inr e! mov d,a! push d + lhld dirbcba + +if BANKED + mov e,m! inx h! mov d,m! xchg +fill00: + push h! call get$next$bcba! pop d! jnz fill00 + xchg +endif + + ; Force prereads in blocking/deblocking + ; Discard BCB + dcr a! sta last$off! mov m,a + call setdir1 ; Set dma to BCB buffer + ; Zero out BCB buffer + pop d! push d! xra a + fill0: + mov m,a! inx h! inr d! jp fill0 + mov d,a! dcr e! jnz fill0 + ; Write 1st physical record of block + lhld arecord1! mvi c,2 + fill1: + shld arecord! push b! call discard$data$bcb + call seek + +if BANKED + xra a! call setbnkf +endif + + pop b! call wrbuff + lhld arecord! pop d! push d + ; Continue writing until blkmsk & arecord = 0 + dad d! lda blkmsk! ana l! mvi c,0! jnz fill1 + ; Restore arecord + pop h! pop h! shld arecord + + call setdata ; Restore dma + diskwr11: + + pop d! lda vrecord! mov d,a ; Load and save vrecord + push d! call check$nprs + + jc dont$write + jz write + + mvi a,2 ; deblock write code + call deblock$dta + jmp dont$write +write: + call setdata + call seek + +if BANKED + mvi a,1! call setbnkf +endif + + ; Discard matching BCB if write is direct + call discard$data$bcb + + ; Set write flag to zero if arecord & blkmsk ~= 0 + + pop b! push b! lda arecord + lxi h,blkmsk! ana m! jz write0 + mvi c,0 +write0: + call wrbuff + +dont$write: + pop b ; c = 2 if a new block was allocated, 0 if not + ; Increment record count if rcount<=vrecord + mov a,b! lxi h,rcount! cmp m ; vrecord-rcount + jc diskwr2 + ; rcount <= vrecord + mov m,a! inr m ; rcount = vrecord+1 + +if MPM + call test$unlocked! jz write1 + + ; for unlocked files + ; rcount = rcount & (~ blkmsk) + blkmsk + 1 + + lda blkmsk! mov b,a! inr b! cma! mov c,a + mov a,m! dcr a! ana c! add b! mov m,a + write1: +endif + + mvi c,2 ; Mark as record count incremented + diskwr2: + ; a has vrecord, c=2 if new block or new record# + dcr c! dcr c! jnz noupdate + call reset$fwf + +if MPM + call test$unlocked! jz noupdate + lda rcount! call getrcnta! mov m,a + call close + call test$disk$fcb1 +endif + +noupdate: + ; Set file write flag if reset + call set$filewf + +if BANKED + jnz disk$write3 + ; Reset fcb file write flag to ensure t3' gets + ; reset by the close function + call reset$fwf + call reset$copy$cr$only + jmp setfcb +disk$write3: + call set$copy$cr$only +else + cz reset$fwf +endif + jmp setfcb ; Replace parameters + ; ret + +rseek: + ; Random access seek operation, c=0ffh if read mode + ; fcb is assumed to address an active file control block + ; (1st block of FCB = 0ffffh if previous bad seek) + push b ; Save r/w flag + lhld info! xchg ; de will hold base of fcb + lxi h,ranrec! dad d ; hl=.fcb(ranrec) + mov a,m! ani 7fh! push psw ; record number + mov a,m! ral ; cy=lsb of extent# + inx h! mov a,m! ral! ani 11111b ; a=ext# + mov c,a ; c holds extent number, record stacked + + mov a,m! ani 1111$0000b! inx h! ora m + rrc! rrc! rrc! rrc! mov b,a + ; b holds module # + + ; Check high byte of ran rec <= 3 + mov a,m + ani 1111$1100b! pop h! mvi l,6! mov a,h + + ; Produce error 6, seek past physical eod + jnz seekerr + + ; otherwise, high byte = 0, a = sought record + lxi h,nxtrec! dad d ; hl = .fcb(nxtrec) + mov m,a ; sought rec# stored away + + ; Arrive here with b=mod#, c=ext#, de=.fcb, rec stored + ; the r/w flag is still stacked. compare fcb values + + lda fx! cpi 99! jz rseek3 + ; Check module # first + push d! call chk$inv$fcb! pop d! jz ranclose + lxi h,modnum! dad d! mov a,b ; b=seek mod# + sub m! ani 3fh! jnz ranclose ; same? + ; Module matches, check extent + lxi h,extnum! dad d + mov a,m! cmp c! jz seekok2 ; extents equal + call compext! jnz ranclose + ; Extent is in same directory fcb + push b! call get$dir$ext! pop b + cmp c! jnc rseek2 ; jmp if dir$ext > ext + pop d! push d! inr e! jnz rseek2 ; jmp if write fx + inr e! pop d! jmp set$lret1 ; error - reading unwritten data + rseek2: + mov m,c ; fcb(ext) = c + mov c,a ; c = dir$ext + ; hl=.fcb(ext),c=dir ext + call restore$rc + call set$rc + jmp seekok1 + ranclose: + push b! push d ; Save seek mod#,ext#, .fcb + call close ; Current extent closed + pop d! pop b ; Recall parameters and fill + mvi l,3 ; Cannot close error #3 + lda lret! inr a! jz seekerr + rseek3: + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + + lxi h,extnum! dad d! push h + mov d,m! mov m,c ; fcb(extnum)=ext# + inx h! inx h! mov a,m! mov e,a! push d + ani 040h! ora b! mov m,a + ; fcb(modnum)=mod# + call open ; Is the file present? + lda lret! inr a! jnz seekok ; Open successful? + ; Cannot open the file, read mode? + pop d! pop h! pop b ; r/w flag to c (=0ffh if read) + push b! push h! push d ; Restore stack + mvi l,4 ; Seek to unwritten extent #4 + inr c ; becomes 00 if read operation + jz badseek ; Skip to error if read operation + ; Write operation, make new extent + call make + mvi l,5 ; cannot create new extent #5 + jz badseek ; no dir space + +if MPM + call fix$olist$item +endif + + ; file make operation successful + seekok: + pop b! pop b ; Discard top 2 stacked items + +if MPM + call set$fcb$cks$flag +else + call set$lsn +endif + + seekok1: + +if BANKED + call reset$copy$cr$only +endif + + seekok2: + pop b ; Discard r/w flag or .fcb(ext) + xra a! jmp sta$ret ; with zero set + badseek: + ; Restore fcb(ext) & fcb(mod) + pop d! xthl ; Save error flag + mov m,d! inx h! inx h! mov m,e + pop h ; Restore error flag + seekerr: + +if BANKED + call reset$copy$cr$only ; Z flag set + inr a ; Reset Z flag +endif + + pop b ; Discard r/w flag + mov a,l! jmp sta$ret ; lret=#, nonzero + +randiskread: + ; Random disk read operation + mvi c,true ; marked as read operation + call rseek + cz diskread ; if seek successful + ret + +randiskwrite: + ; Random disk write operation + mvi c,false ; marked as write operation + call rseek + cz diskwrite ; if seek successful + ret + +compute$rr: + ; Compute random record position for getfilesize/setrandom + xchg! dad d + ; de=.buf(dptr) or .fcb(0), hl = .f(nxtrec/reccnt) + mov c,m! mvi b,0 ; bc = 0000 0000 ?rrr rrrr + lxi h,extnum! dad d! mov a,m! rrc! ani 80h ; a=e000 0000 + add c! mov c,a! mvi a,0! adc b! mov b,a + ; bc = 0000 000? errrr rrrr + mov a,m! rrc! ani 0fh! add b! mov b,a + ; bc = 000? eeee errrr rrrr + lxi h,modnum! dad d! mov a,m ; a=xxmm mmmm + add a! add a! add a! add a ; cy=m a=mmmm 0000 + + ora a! add b! mov b,a! push psw ; Save carry + mov a,m! rar! rar! rar! rar! ani 0000$0011b ; a=0000 00mm + mov l,a! pop psw! mvi a,0! adc l ; Add carry + ret + +compare$rr: + mov e,a ; Save cy + mov a,c! sub m! mov d,a! inx h ; lst byte + mov a,b! sbb m! inx h ; middle byte + push a! ora d! mov d,a! pop a + mov a,e! sbb m ; carry if .fcb(ranrec) > directory + ret + +set$rr: + mov m,e! dcx h! mov m,b! dcx h! mov m,c! ret + +getfilesize: + ; Compute logical file size for current fcb + ; Zero the receiving ranrec field + call get$rra! push h ; Save position + mov m,d! inx h! mov m,d! inx h! mov m,d ; =00 00 00 + call search$extnum + getsize: + jz setsize + ; current fcb addressed by dptr + call getdptra! lxi d,reccnt ; ready for compute size + call compute$rr + ; a=0000 00mm bc = mmmm eeee errr rrrr + ; Compare with memory, larger? + pop h! push h ; Recall, replace .fcb(ranrec) + call compare$rr! cnc set$rr + call searchn + mvi a,0! sta aret + jmp getsize + setsize: + + pop h ; Discard .fcb(ranrec) + ret + +setrandom: + ; Set random record from the current file control block + xchg! lxi d,nxtrec ; Ready params for computesize + call compute$rr ; de=info, a=0000 00mm, bc=mmmm eeee errr rrrr + lxi h,ranrec! dad d ; hl = .fcb(ranrec) + mov m,c! inx h! mov m,b! inx h! mov m,a ; to ranrec + ret + +disk$select: + ; Select disk info for subsequent input or output ops + sta adrive +disk$select1: ; called by deblock + mov m,a ; curdsk = seldsk or adrive + mov d,a ; Save seldsk in register D for selectdisk call + lhld dlog! call test$vector ; test$vector does not modify DE + mov e,a! push d ; Send to seldsk, save for test below + call selectdisk! pop h ; Recall dlog vector + jnc sel$error ; returns with C flag set if select ok + ; Is the disk logged in? + dcr l ; reg l = 1 if so + ret + +tmpselect: + lxi h,seldsk! mov m,e + +curselect: + lda seldsk! lxi h,curdsk! cmp m! jnz select + cpi 0ffh! rnz ; return if seldsk ~= ffh + +select: + call disk$select + +if MPM + jnz select1 ; no + ; yes - drive previously logged in + lhld rlog! call test$vector + sta rem$drv! ret ; Set rem$drv & return +select1: + +else + rz ; yes - drive previously logged in +endif + + call initialize ; Log in the directory + + ; Increment login sequence # if odd + lhld lsn$add! mov a,m! ani 1! push a! add m! mov m,a + pop a! cnz set$rlog + + call set$dlog + +if MPM + lxi h,chksiz+1! mov a,m! ral! mvi a,0! jc select2 + lxi d,rlog! call set$cdisk ; rlog=set$cdisk(rlog) + mvi a,1 +select2: + sta rem$drv +endif + + ret + +reselectx: + xra a! sta high$ext + +if BANKED + sta xfcb$read$only +endif + + jmp reselect1 + +reselect: + ; Check current fcb to see if reselection necessary + lxi b,807fh + lhld info! lxi d,7! xchg! dad d + +if BANKED + ; xfcb$read$only = 80h & fcb(7) + mov a,m! ana b! sta xfcb$read$only + ; fcb(7) = fcb(7) & 7fh + mov a,m! ana c! mov m,a +endif + +if MPM + ; if fcb(8) & 80h + ; then fcb(8) = fcb(8) & 7fh, high$ext = 60h + ; else high$ext = fcb(ext) & 0e0h + inx h! lxi d,4 + mov a,m! ana c! cmp m! mov m,a! mvi a,60h! jnz reselect0 + dad d! mvi a,0e0h! ana m +reselect0: + sta high$ext +else + ; high$ext = 80h & fcb(8) + inx h! mov a,m! ana b! sta high$ext + ; fcb(8) = fcb(8) & 7fh + mov a,m! ana c! mov m,a +endif + + ; fcb(ext) = fcb(ext) & 1fh + call clr$ext +reselect1: + + lxi h,0 + +if BANKED + shld make$xfcb ; make$xfcb,find$xfcb = 0 +endif + shld xdcnt ; required by directory hashing + + xra a! sta search$user0 + dcr a! sta resel ; Mark possible reselect + lhld info! mov a,m ; drive select code + sta fcbdsk ; save drive code + ani 1$1111b ; non zero is auto drive select + dcr a ; Drive code normalized to 0..30, or 255 + sta linfo ; Save drive code + cpi 0ffh! jz noselect + ; auto select function, seldsk saved above + sta seldsk + noselect: + call curselect + ; Set user code + lda usrcode ; 0...15 + lhld info! mov m,a + noselect0: + ; Discard directory BCB's if drive is removable + ; and fx = 15,17,19,22,23,30 etc. + call tst$log$fxs! cz discard$dir + ; Check for media change on currently slected disk + call check$media + ; Check for media change on any other disks + jmp check$all$media + +check$media: + ; Check media if DPH media flag set. + ; Is DPH media flag set? + call test$media$flag! rz ; no + ; Test for media change by reading directory + ; to current high water mark or until media change + ; is detected. + ; First reset DPH media flag & discard directory BCB's + mvi m,0 + call discard$dir + lhld dcnt! push h + call home! call set$end$dir +check$media1: + mvi c,false! call r$dir + lxi h,relog! mov a,m! ora a! jz check$media2 + mvi m,0! pop h! lda fx! cpi 48! rz + call drv$relog! jmp chk$exit$fxs +check$media2: + call comp$cdr! jc check$media1 + pop h! shld dcnt! ret + +check$all$media: + ; This routine checks all logged-in drives for + ; a set DPH media flag and pending buffers. It reads + ; the directory for these drives to verify that media + ; has not changed. If media has changed, the drives + ; get reset (but not relogged-in). + ; Is SCB media flag set? + lxi h,media$flag! mov a,m! ora a! rz ; no + ; Reset SCB media flag + mvi m,0 + ; Test logged-in drives only + lhld dlog! mvi a,16 +chk$am1: + dcr a! dad h! jnc chk$am2 + ; A = drive # + ; Select drive + push a! push h! lxi h,curdsk! call disk$select + ; Does drive have pending data buffers? + call test$pending! cnz check$media ; yes + pop h! pop a +chk$am2: + ora a! jnz chk$am1 + jmp curselect + +test$pending: + ; On return, Z flag reset if buffer pending + + ; Does dta$bcba = 0ffffh + lhld dta$bcba! mov a,l! ana h! inr a! rz ; yes + +if BANKED + +test$p1: + ; Does bcb addr = 0? + mov e,m! inx h! mov d,m + mov a,e! ora d! rz ; yes - no pending buffers + lxi h,4 +else + lxi d,4 +endif + + ; Is buffer pending? + dad d! mov a,m! ora a ; A ~= 0 if so + +if BANKED + rnz ; yes + ; no - advance to next bcb + lxi h,13! dad d! jmp test$p1 +else + ret +endif + +get$dir$mode: + lhld drvlbla! mov a,m + +if not BANKED + ani 7fh ; Mask off password bit +endif + + ret + +if BANKED + +chk$password: + call get$dir$mode! ani 80h! rz + +chk$pw: ; Check password + call get$xfcb! rz ; a = xfcb options + jmp cmp$pw + +chk$pw$error: + ; Disable special searches + xra a! sta xdcnt+1 + ; pw$fcb = dir$xfcb + call getdptra! xchg + mvi c,12! lxi h,pw$fcb! push h + call move! ldax d! inx h! mov m,a! pop d + lhld info! mov a,m! stax d + ; push original info and xfcb password mode + ; info = .pw$fcb + push h! xchg! shld info + ; Does fcb(ext = 0, mod = 0) exist? + call search$namlen! jz chk$pwe2 ; no + ; Does sfcb exist for fcb ? + call get$dtba$8! ora a! jnz chk$pwe1 ; no + xchg! lxi h,pw$mode + ; Is sfcb password mode nonzero? + mov b,m! ldax d! mov m,a! ora a! jz chk$pwe2 ; no + ; Do password modes match? + xra b! ani 0e0h! jz chk$pwe1 ; yes + ; no - update xfcb to match sfcb + call get$xfcb! jz chk$pwe1 ; no xfcb (error) + lda pw$mode! mov m,a! call nowrite! cz seek$copy +chk$pwe1: + pop h! shld info + lda fx! cpi 15! rz! cpi 22! rz + +pw$error: ; password error + mvi a,7! jmp set$aret + +chk$pwe2: + xra a! sta pw$mode + call nowrite! jnz chk$pwe3 + ; Delete xfcb + call get$xfcb! push a + lhld info! mov a,m! ori 10h! mov m,a + pop a! cnz delete$10 +chk$pwe3: + ; Restore info + pop h! shld info! ret + +cmp$pw: ; Compare passwords + inx h! mov b,m + mov a,b! ora a! jnz cmp$pw2 + mov d,h! mov e,l! inx h! inx h + mvi c,9 +cmp$pw1: + inx h! mov a,m! dcr c! rz + ora a! jz cmp$pw1 + cpi 20h! jz cmp$pw1 + xchg +cmp$pw2: + lxi d,(23-ubytes)! dad d! xchg + lhld xdmaad! mvi c,8 +cmp$pw3: + ldax d! xra b! cmp m! jnz cmp$pw4 + dcx d! inx h! dcr c! jnz cmp$pw3 + ret +cmp$pw4: + dcx d! dcr c! jnz cmp$pw4 + inx d + +if MPM + call get$df$pwa! inr a! jnz cmp$pw5 + inr a! ret +cmp$pw5: + +else + lxi h,df$password +endif + + mvi c,8! jmp compare + +if MPM + +get$df$pwa: ; a = ff => no df pwa + call rlr! lxi b,console! dad b + mov a,m! cpi 16! mvi a,0ffh! rnc + mov a,m! add a! add a! add a + mvi h,0! mov l,a! lxi b,dfpassword! dad b + ret +endif + +set$pw: ; Set password in xfcb + push h ; Save .xfcb(ex) + lxi b,8 ; b = 0, c = 8 + lxi d,(23-extnum)! dad d + xchg! lhld xdmaad +set$pw0: + xra a! push a +set$pw1: + mov a,m! stax d! ora a! jz set$pw2 + cpi 20h! jz set$pw2 + inx sp! inx sp! push a +set$pw2: + add b! mov b,a + dcx d! inx h! dcr c! jnz set$pw1 + pop a! ora b! pop h! jnz set$pw3 + ; is fx = 100 (directory label)? + lda fx! cpi 100! jz set$pw3 ; yes + mvi m,0 ; zero xfcb(ex) - no password +set$pw3: + inx d! mvi c,8 +set$pw4: + ldax d! xra b! stax d! inx d! dcr c! jnz set$pw4 + inx h! ret + +get$xfcb: + lhld info! mov a,m! push a + ori 010h! mov m,a + call search$extnum! mvi a,0! sta lret + lhld info! pop b! mov m,b! rz +get$xfcb1: + call getdptra! xchg + lxi h,extnum! dad d! mov a,m! ani 0e0h! ori 1 + ret + +adjust$dmaad: + push h! lhld xdmaad! dad d + shld xdmaad! pop h! ret + +init$xfcb: + call setcdr ; may have extended the directory + lxi b,1014h ; b=10h, c=20 +init$xfcb0: + ; b = fcb(0) logical or mask + ; c = zero count + push b + call getdptra! xchg! lhld info! xchg + ; Zero extnum and modnum + ldax d! ora b! mov m,a! inx d! inx h + mvi c,11! call move! pop b! inr c +init$xfcb1: + dcr c! rz + mvi m,0! inx h! jmp init$xfcb1 + +chk$xfcb$password: + call get$xfcb1 +chk$xfcb$password1: + push h! call cmp$pw! pop h! ret + +endif + +stamp1: + mvi c,0! jmp stamp3 +stamp2: + mvi c,4 +stamp3: + call get$dtba! ora a! rnz + lxi d,seek$copy! push d +stamp4: + +if MPM + push h + call get$stamp$add! xchg + pop h +else + lxi d,stamp +endif + + push h! push d + mvi c,0! call timef ; does not modify hl,de + mvi c,4! call compare + mvi c,4! pop d! pop h! jnz move + pop h! ret + +stamp5: + call getdptra! dad b! lxi d,func$ret! push d + jmp stamp4 + +if BANKED + +get$dtba$8: + mvi c,8 +endif + +get$dtba: + ; c = offset of sfcb subfield (0,4,8) + ; Return with a = 0 if sfcb exists + + ; Does fcb occupy 4th item of sector? + lda dcnt! ani 3! cpi 3! rz ; yes + mov b,a + lhld buffa! lxi d,96! dad d + ; Does sfcb reside in 4th directory item? + mov a,m! sui 21h! rnz ; no + ; hl = hl + 10*lret + 1 + c + mov a,b! add a! mov e,a! add a! add a! add e + inr a! add c! mov e,a! dad d! xra a + ret + +qstamp: + ; Is fcb 1st logical fcb for file? + call qdirfcb1! rnz ; no +qstamp1: + ; Does directory label specify requested stamp? + lhld drvlbla! mov a,c! ana m! jnz nowrite ; yes - verify drive r/w + inr a! ret ; no - return with Z flag reset + +qdirfcb1: + ; Routine to determine if fcb is 1st directory fcb + ; for file + ; Is fcb(ext) & ~extmsk & 00011111b = 0? + lda extmsk! ori 1110$0000b! cma! mov b,a + call getexta! mov a,m! ana b! rnz ; no + ; is fcb(mod) & 0011$1111B = 0? + inx h! inx h! mov a,m! ani 3fh! ret ; Z flag set if zero + +update$stamp: + ; Is update stamping requested on drive? + mvi c,0010$0000b! call qstamp1! rnz ; no + ; Has file been written to since it was opened? + call getmodnum! ani 40h! rnz ; yes - update stamp performed + ; Search for 1st dir fcb + call getexta! mov b,m! mvi m,0! push h + inx h! inx h! mov c,m! mvi m,0! push b + ; Search from beginning of directory + call search$namlen + ; Perform update stamp if dir fcb 1 found + cnz stamp2 + xra a! sta lret + ; Restore fcb extent and module fields + pop b! pop h! mov m,b! inx h! inx h! mov m,c! ret + +if MPM + +pack$sdcnt: + +;packed$dcnt = dblk(low 15 bits) || dcnt(low 9 bits) + +; if sdblk = 0 then dblk = shr(sdcnt,blkshf+2) +; else dblk = sdblk +; dcnt = sdcnt & (blkmsk || '11'b) +; +; packed$dcnt format (24 bits) +; +; 12345678 12345678 12345678 +; 23456789 .......1 ........ sdcnt (low 9 bits) +; ........ 9abcdef. 12345678 sdblk (low 15 bits) +; + lhld sdblk! mov a,h! ora l! jnz pack$sdcnt1 + lda blkshf! adi 2! mov c,a! lhld sdcnt + call hlrotr +pack$sdcnt1: + dad h! xchg! lxi h,sdcnt! mvi b,1 + lda blkmsk! ral! ora b! ral! ora b + ana m! sta packed$dcnt + lda blkshf! cpi 7! jnz pack$sdcnt2 + inx h! mov a,m! ana b! jz pack$sdcnt2 + mov a,e! ora b! mov e,a +pack$sdcnt2: + xchg! shld packed$dcnt+1 + ret + +; olist element = link(2) || atts(1) || dcnt(3) || +; pdaddr(2) || opncnt(2) +; +; link = 0 -> end of list +; +; atts - 80 - open in locked mode +; 40 - open in unlocked mode +; 20 - open in read/only mode +; 10 - deleted item +; 0n - drive code (0-f) +; +; dcnt = packed sdcnt+sdblk +; pdaddr = process descriptor addr +; opncnt = # of open calls - # of close calls +; olist item freed by close when opncnt = 0 +; +; llist element = link(2) || drive(1) || arecord(3) || +; pdaddr(2) || .olist$item(2) +; +; link = 0 -> end of list +; +; drive - 0n - drive code (0-f) +; +; arecord = record number of locked record +; pdaddr = process descriptor addr +; .olist$item = address of file's olist item + +search$olist: + lxi h,open$root! jmp srch$list0 +search$llist: + lxi h,lock$root! jmp srch$list0 +searchn$list: + lhld cur$pos +srch$list0: + shld prv$pos + +; search$olist, search$llist, searchn$list conventions +; +; b = 0 -> return next item +; b = 1 -> search for matching drive +; b = 3 -> search for matching dcnt +; b = 5 -> search for matching dcnt + pdaddr +; if found then z flag is set +; prv$pos -> previous list element +; cur$pos -> found list element +; hl -> found list element +; else prv$pos -> list element to insert after +; +; olist and llist are maintained in drive order + +srch$list1: + mov e,m! inx h! mov d,m! xchg + mov a,l! ora h! jz srch$list3 + xra a! cmp b! jz srch$list6 + inx h! inx h! + lxi d,curdsk! mov a,m! ani 0fh! mov c,a + ldax d! sub c! jnz srch$list4 + mov a,b! dcr a! jz srch$list5 + mov c,b! push h + inx d! inx h! call compare + pop h! jz srch$list5 +srch$list2: + dcx h! dcx h + shld prv$pos! jmp srch$list1 +srch$list3: + inr a! ret +srch$list4: + jnc srch$list2 +srch$list5: + dcx h! dcx h +srch$list6: + shld cur$pos! ret + +delete$item: ; hl -> item to be deleted + di + push d! push h + mov e,m! inx h! mov d,m + lhld prv$pos! shld cur$pos + ; prv$pos.link = delete$item.link + mov m,e! inx h! mov m,d + + lhld free$root! xchg + ; free$root = .delete$item + pop h! shld free$root + ; delete$item.link = previous free$root + mov m,e! inx h! mov m,d + pop d! ei! ret + +create$item: ; hl -> new item if successful + ; z flag set if no free items + lhld free$root! mov a,l! ora h! rz + push d! push h! shld cur$pos + mov e,m! inx h! mov d,m + ; free$root = free$root.link + xchg! shld free$root + + lhld prv$pos + mov e,m! inx h! mov d,m + pop h + ; create$item.link = prv$pos.link + mov m,e! inx h! mov m,d! dcx h + xchg! lhld prv$pos + ; prv$pos.link = .create$item + mov m,e! inx h! mov m,d! xchg + pop d! ret + +set$olist$item: + ; a = attributes + ; hl = olist entry address + inx h! inx h + mov b,a! lxi d,curdsk! ldax d! ora b + mov m,a! inx h! inx d + mvi c,5! call move + xra a! mov m,a! inx h! mov m,a! ret + +set$sdcnt: + mvi a,0ffh! sta sdcnt+1! ret + +tst$olist: + mvi a,0c9h! sta chk$olist05! jmp chk$olist0 +chk$olist: + xra a! sta chk$olist05 +chk$olist0: + lxi d,dcnt! lxi h,sdcnt! mvi c,4! call move + call pack$sdcnt! mvi b,3! call search$olist! rnz + pop d ; pop return address + inx h! inx h + mov a,m! ani 80h! jz openx06 + dcx h! dcx h + push d! push h + call compare$pds! pop h! pop d! jnz openx06 + push d ; Restore return address +chk$olist05: + nop ; tst$olist changes this instr to ret + call delete$item! lda pdcnt +chk$olist1: + adi 16! jz chk$olist1 + sta pdcnt + + push a! call rlr + lxi b,pdcnt$off! dad b! pop a + mov m,a! ret + +remove$files: ; bc = pdaddr + lhld cur$pos! push h + lhld prv$pos! push h + mov d,b! mov e,c! lxi h,open$root! shld cur$pos +remove$file1: + mvi b,0! push d! call searchn$list! pop d! jnz remove$file2 + lxi b,6! call tst$tbl$lmt! jnz remove$file1 + inx h! inx h! mov a,m! ori 10h! mov m,a + sta deleted$files + jmp remove$file1 +remove$file2: + pop h! shld prv$pos + pop h! shld cur$pos + ret + +delete$files: + lxi h,open$root! shld cur$pos +delete$file1: + mvi b,0! call search$nlist! rnz + inx h! inx h! mov a,m! ani 10h! jz delete$file1 + dcx h! dcx h! call remove$locks! call delete$item + jmp delete$file1 + +flush$files: + lxi h,flushed! mov a,m! ora a! rnz + inr m +flush$file0: + lxi h,open$root! shld cur$pos +flush$file1: + mvi b,1! call searchn$list! rnz + push h! call remove$locks! call delete$item! pop h + lxi d,6! dad d! mov e,m! inx h! mov d,m + lxi h,pdcnt$off! dad d! mov a,m! ani 1! jnz flush$file1 + mov a,m! ori 1! mov m,a + lhld pdaddr! mvi c,2! call compare! jnz flush$file1 + lda pdcnt! adi 10h! sta pdcnt! jmp flush$file1 + +free$files: + ; free$mode = 1 - remove curdsk files for process + ; 0 - remove all files for process + lhld pdaddr! xchg! lxi h,open$root! shld curpos +free$files1: + lda free$mode! mov b,a + push d! call searchn$list! pop d! rnz + lxi b,6! call tst$tbl$lmt! jnz free$files1 + push h! inx h! inx h! inx h + call test$ffff! jnz free$files2 + call test$ffff! jz free$files3 +free$files2: + mvi a,0ffh! sta incr$pdcnt +free$files3: + pop h! call remove$locks! call delete$item + jmp free$files1 + +remove$locks: + shld file$id + inx h! inx h! mov a,m! ani 40h! jz remove$lock3 + push d! lhld prv$pos! push h + lhld file$id! xchg! lxi h,lock$root! shld cur$pos +remove$lock1: + mvi b,0! push d! call searchn$list! pop d + jnz remove$lock2 + lxi b,8! call tst$tbl$lmt! jnz remove$lock1 + call delete$item + jmp remove$lock1 +remove$lock2: + pop h! shld prv$pos! pop d +remove$lock3: + lhld file$id! ret + +tst$tbl$lmt: + push h! dad b + mov a,m! inx h! mov h,m + sub e! jnz tst$tbl$lmt1 + mov a,h! sub d +tst$tbl$lmt1: + pop h! ret + +create$olist$item: + mvi b,1! call search$olist + di + call create$item! lda attributes! call set$olist$item + ei + ret + +count$opens: + xra a! sta open$cnt + lhld pdaddr! xchg! lxi h,open$root! shld curpos +count$open1: + mvi b,0! push d! call searchn$list! pop d! jnz count$open2 + lxi b,6! call tst$tbl$lmt! jnz count$open1 + lda open$cnt! inr a! sta open$cnt + jmp count$open1 +count$open2: + lxi h,open$max! lda open$cnt! ret + +count$locks: + xra a! sta lock$cnt + xchg! lxi h,lock$root! shld cur$pos +count$lock1: + mvi b,0! push d! call searchn$list! pop d! rnz + lxi b,8! call tst$tbl$lmt! jnz count$lock1 + lda lock$cnt! inr a! sta lock$cnt + jmp count$lock1 + +check$free: + lda mult$cnt! mov e,a + mvi d,0! lxi h,free$root! shld cur$pos +check$free1: + mvi b,0! push d! call searchn$list! pop d! jnz check$free2 + inr d! mov a,d! sub e! jc check$free1 + ret +check$free2: + pop h! mvi a,14! jmp sta$ret + +lock: ; record lock and unlock + call reselect! call check$fcb + call test$unlocked + rz ; file not opened in unlocked mode + lhld xdmaad! mov e,m! inx h! mov d,m + xchg! inx h! inx h + mov a,m! mov b,a! lda curdsk! sub b + ani 0fh! jnz lock8 ; invalid file id + mov a,b! ani 40h! jz lock8 ; invalid file id + dcx h! dcx h! shld file$id + lda lock$unlock! inr a! jnz lock1 ; jmp if unlock + call count$locks + lda lock$cnt! mov b,a + lda mult$cnt! add b! mov b,a + lda lock$max! cmp b + mvi a,12! jc sta$ret ; too many locks by this process + call check$free +lock1: + call save$rr! lxi h,lock9! push h! lda mult$cnt +lock2: + push a! call get$lock$add + lda lock$unlock! inr a! jnz lock3 + call test$lock +lock3: + pop a! dcr a! jz lock4 + call incr$rr! jmp lock2 +lock4: + call reset$rr! lda mult$cnt +lock5: + push a! call get$lock$add + lda lock$unlock! inr a! jnz lock6 + call set$lock! jmp lock7 +lock6: + call free$lock +lock7: + pop a! dcr a! rz + call incr$rr! jmp lock5 +lock8: + mvi a,13! jmp sta$ret ; invalid file id +lock9: + call reset$rr! ret + +get$lock$add: + lxi h,0! dad sp! shld lock$sp + mvi a,0ffh! sta lock$shell + call rseek + xra a! sta lock$shell + call getfcb + lhld aret! mov a,l! ora a! jnz lock$err + call index! lxi h,1! jz lock$err + call atran! ret + +lock$perr: + xra a! sta lock$shell + xchg! lhld lock$sp! sphl! xchg +lock$err: + pop d ; Discard return address + pop b ; b = mult$cnt-# recs processed + lda mult$cnt! sub b + add a! add a! add a! add a + ora h! mov h,a! mov b,a + shld aret! ret + +test$lock: + call move$arecord + mvi b,3! call search$llist! rnz + call compare$pds! rz + lxi h,8! jmp lock$err + +set$lock: + call move$arecord + mvi b,1! call search$llist + di + call create$item + xra a! call set$olist$item + xchg! lhld file$id! xchg + mov m,d! dcx h! mov m,e + ei! ret + +free$lock: + call move$arecord + mvi b,5! call search$llist! rnz +free$lock0: + call delete$item + mvi b,5! call searchn$list! rnz + jmp free$lock0 + +compare$pds: + lxi d,6! dad d! xchg + lxi h,pdaddr! mvi c,2! jmp compare + + +move$arecord: + lxi d,arecord! lxi h,packed$dcnt + + +fix$olist$item: + lxi d,xdcnt! lxi h,sdcnt + ; Is xdblk,xdcnt < sdblk,sdcnt + mvi c,4! ora a! +fix$ol1: + ldax d! sbb m! inx h! inx d! dcr c! jnz fix$ol1 + rnc + ; yes - update olist entry + call swap! call sdcnt$eq$xdcnt + lxi h,open$root! shld cur$pos + ; Find file's olist entry +fix$ol2: + call swap! call pack$sdcnt! call swap + mvi b,3! call searchn$list! rnz + ; Update olist entry with new dcnt value + push h! call pack$sdcnt! pop h + inx h! inx h! inx h! lxi d,packed$dcnt + mvi c,3! call move! jmp fix$ol2 + +hl$eq$hl$and$de: + mov a,l! ana e! mov l,a + mov a,h! ana d! mov h,a + ret + +remove$drive: + xchg! lda curdsk! mov c,a! lxi h,1 + call hlrotl + mov a,l! cma! ana e! mov e,a + mov a,h! cma! ana d! mov d,a + xchg! ret + +diskreset: + lxi h,0! shld ntlog + xra a! sta set$ro$flag + lhld info +intrnldiskreset: + xchg! lhld open$root! mov a,h! ora l! rz + xchg! lda curdsk! push a! mvi b,0 +dskrst1: + mov a,l! rar! jc dskrst3 +dskrst2: + mvi c,1! call hlrotr! inr b + mov a,h! ora l! jnz dskrst1 + pop a! sta curdsk + lhld ntlog! xchg! lhld tlog + mov a,l! ora e! mov l,a + mov a,h! ora d! mov h,a! shld tlog + inr a! ret +dskrst3: + push b! push h! mov a,b! sta curdsk + lhld rlog! call test$vector1! push a + lhld rodsk! lda curdsk! call test$vector1! mov b,a + pop h! lda set$ro$flag! ora b! ora h! sta check$disk + lxi h,open$root! shld cur$pos +dskrst4: + mvi b,1! call searchn$list! jnz dskrst6 + lda check$disk! ora a! jz dskrst5 + push h! call compare$pds! jz dskrst45 + pop h! xra a! xchg! jmp dskrst6 +dskrst45: + lxi d,ntlog! call set$cdisk + pop h! jmp dskrst4 +dskrst5: + lhld info! call remove$drive! shld info + ori 1 +dskrst6: + pop h! pop b! jnz dskrst2 + + ; error - olist item exists for another process + ; for removable drive to be reset + pop a! sta curdsk! mov a,b! adi 41h ; a = ascii drive + lxi h,6! dad d! mov c,m! inx h! mov b,m ; bc = pdaddr + push psw! call test$error$mode! pop d! jnz dskrst7 + mov a,d + + push b! push psw + call rlr! lxi d,console! dad d! mov d,m ; d = console # + lxi b,deniedmsg! call xprint + pop psw! mov c,a! call conoutx + mvi c,':'! call conoutx + lxi b,cnsmsg! call xprint + pop h! push h! lxi b,console! dad b + mov a,m! adi '0'! mov c,a! call conoutx + lxi b,progmsg! call xprint + pop h! call dsplynm + +dskrst7: + pop h ; Remove return addr from diskreset + lxi h,0ffffh! shld aret ; Flag the error + ret + +deniedmsg: + db cr,lf,'disk reset denied, drive ',0 +cnsmsg: + db ' console ',0 +progmsg: + db ' program ',0 +endif + +; +; individual function handlers +; + +func12: + ; Return version number + +if MPM + lxi h,0100h+dvers! jmp sthl$ret +else + lda version! jmp sta$ret ; lret = dvers (high = 00) +endif + +func13: + +if MPM + lhld dlog! shld info + call diskreset! jz reset$all + call reset$37 + jmp func13$cont +reset$all: + + ; Reset disk system - initialize to disk 0 + lxi h,0! shld rodsk! shld dlog + + shld rlog! shld tlog +func13$cont: + mvi a,0ffh! sta curdsk +else + lxi h,0ffffh! call reset$37x +endif + xra a! sta olddsk ; Note that usrcode remains unchanged + +if MPM + xra a! call getmemseg ; a = mem seg tbl index + ora a! rz + inr a! rz + call rlradr! lxi b,msegtbl-rlros! dad b + add a! add a! mov e,a! mvi d,0! dad d + mov h,m! mvi l,80h + jmp intrnlsetdma +else + lxi h,tbuff! shld dmaad ; dmaad = tbuff + jmp setdata ; to data dma address +endif + +func14: + +if MPM + call tmpselect ; seldsk = reg e + call rlr! lxi b,diskselect! dad b + mov a,m! ani 0fh! rrc! rrc! rrc! rrc + mov b,a! lda seldsk! ora b! rrc! rrc! rrc! rrc + mov m,a! ret +else + call tmpselect ; seldsk = reg e + lda seldsk! sta olddsk! ret +endif + +func15: + ; Open file + call clrmodnum ; Clear the module number + +if MPM + call reselect + xra a! sta make$flag + call set$sdcnt + lxi h,open$file! push h + mvi a,0c9h! sta check$fcb4 + call check$fcb1 + pop h! lda high$ext! cpi 060h! jnz open$file + call home! call set$end$dir + jmp open$user$zero +open$file: + call set$sdcnt + call reset$chksum$fcb ; Set invalid check sum +else + call reselectx +endif + + call check$wild ; Check for wild chars in fcb + +if MPM + + call get$atts! ani 1100$0000b ; a = attributes + cpi 1100$0000b! jnz att$ok + ani 0100$0000b ; Mask off unlock mode +att$ok: + sta high$ext + mov b,a! ora a! rar! jnz att$set + mvi a,80h +att$set: + sta attributes! mov a,b + ani 80h! jnz call$open +endif + + lda usrcode! ora a! jz call$open + mvi a,0feh! sta xdcnt+1! inr a! sta search$user0 + +if MPM + sta sdcnt0+1 +endif + +call$open: + call open! call openx ; returns if unsuccessful, a = 0 + lxi h,search$user0! cmp m! rz + mov m,a! lda xdcnt+1! cpi 0feh! rz +; +; file exists under user 0 +; + +if MPM + call swap +endif + + call set$dcnt$dblk + +if MPM + mvi a,0110$0000b +else + mvi a,80h +endif + + sta high$ext +open$user$zero: + ; Set fcb user # to zero + lhld info! mvi m,0 + mvi c,namlen! call searchi! call searchn + call open1 ; Attempt reopen under user zero + call openx ; openx returns only if unsuccessful + ret +openx: + call end$of$dir! rz + call getfcba! mov a,m! inr a! jnz openxa + dcx d! dcx d! ldax d! mov m,a +openxa: + ; open successful + pop h ; Discard return address + ; Was file opened under user 0 after unsuccessful + ; attempt to open under user n? + +if MPM + lda high$ext! cpi 060h! jz openx00 ; yes + ; Was file opened in locked mode? + ora a! jnz openx0 ; no + ; does user = zero? + lhld info! ora m! jnz openx0 ; no + ; Does file have read/only attribute set? + call rotest! jnc openx0 ; no + ; Does file have system attribute set? + inx h! mov a,m! ral! jnc openx0 ; no + + ; Force open mode to read/only mode and set user 0 flag + ; if file opened in locked mode, user = 0, and + ; file has read/only and system attributes set + +openx00: + +else + lda high$ext! ral! jnc openx0 +endif + + ; Is file under user 0 a system file ? + +if MPM + mvi a,20h! sta attributes +endif + + lhld info! lxi d,10! dad d + mov a,m! ani 80h! jnz openx0 ; yes - open successful + ; open fails + sta high$ext! jmp lret$eq$ff +openx0: + +if MPM + call reset$chksum$fcb +else + call set$lsn +endif + +if BANKED + + ; Are passwords enabled on drive? + call get$dir$mode! ani 80h! jz openx1a ; no + ; Is this 1st dir fcb? + call qdirfcb1! jnz openx0a ; no + ; Does sfcb exist? + call get$dtba$8! ora a! jnz openx0a ; no + ; Is sfcb password mode read or write? + mov a,m! ani 0c0h! jz openx1a ; no + ; Does xfcb exist? + call xdcnt$eq$dcnt + call get$xfcb! jnz openx0b ; yes + ; no - set sfcb password mode to zero + call restore$dir$fcb! rz ; (error) + ; Does sfcb still exist? + call get$dtba$8! ora a! jnz openx1a ; no (error) + ; sfcb password mode = 0 + mov m,a + ; update sfcb + call nowrite! cz seek$copy + jmp openx1a +openx0a: + call xdcnt$eq$dcnt + ; Does xfcb exist? + call get$xfcb! jz openx1 ; no +openx0b: + ; yes - check password + call cmp$pw! jz openx1 + call chk$pw$error + lda pw$mode! ani 0c0h! jz openx1 + ani 80h! jnz pw$error + mvi a,080h! sta xfcb$read$only +openx1: + call restore$dir$fcb! rz ; (error) +openx1a: + call set$lsn + +if MPM + call pack$sdcnt + ; Is this file currently open? + mvi b,3! call search$olist! jz openx04 +openx01: + ; no - is olist full? + lhld free$root! mov a,l! ora h! jnz openx03 + ; yes - error +openx02: + mvi a,11! jmp set$aret +openx03: + ; Has process exceeded open file maximum? + call count$opens! sub m! jc openx035 + ; yes - error +openx034: + mvi a,10! jmp set$aret +openx035: + ; Create new olist element + call create$olist$item + jmp openx08 +openx04: + ; Do file attributes match? + inx h! inx h + lda attributes! ora m! cmp m! jnz openx06 + ; yes - is open mode locked? + ani 80h! jnz openx07 + ; no - has this file been opened by this process? + lhld prv$pos! shld cur$pos + mvi b,5! call searchn$list! jnz openx01 +openx05: + ; yes - increment open file count + lxi d,8! dad d! inr m! jnz openx08 + ; count overflow + inx h! inr m! jmp openx08 +openx06: + ; error - file opened by another process in imcompatible mode + mvi a,5! jmp set$aret +openx07: + ; Does this olist item belong to this process? + dcx h! dcx h! push h + call compare$pds + pop h! jnz openx06 ; no - error + jmp openx05 ; yes +openx08:; Wopen ok + ; Was file opened in unlocked mode? + lda attributes! ani 40h! jz openx09 ; no + ; yes - return .olist$item in ranrec field of fcb + call get$rra + lxi d,cur$pos! mvi c,2! call move +openx09: + call set$fcb$cks$flag + lda make$flag! ora a! rnz +endif +endif + + mvi c,0100$0000b +openx2: + call qstamp! cz stamp1 + lxi d,olog! jmp set$cdisk + +func16: + ; Close file + call reselect + +if MPM + call get$atts! sta attributes + lxi h,close00! push h + mvi a,0c9h! sta check$fcb4 + call check$fcb1! pop h + call set$sdcnt + call getmodnum! ani 80h! jnz close01 + call close! jmp close02 +close00: + mvi a,6! jmp set$aret +close01: + mvi a,0ffh! sta dont$close! call close1 +close02: +else + call set$lsn + call chek$fcb! call close +endif + + lda lret! inr a! rz + + jmp flush ; Flush buffers + +if MPM + lda attributes! ral! rc + call pack$sdcnt + ; Find olist item for this process & file + mvi b,5! call search$olist! jnz close03 + ; Decrement open count + push h! lxi d,8! dad d + mov a,m! sui 1! mov m,a! inx h + mov a,m! sbi 0! mov m,a! dcx h + ; Is open count = 0ffffh + call test$ffff! pop h! jnz close03 + ; yes - remove file's olist entry + shld file$id! call delete$item + call reset$chksum$fcb + ; if unlocked file, remove file's locktbl entries + call test$unlocked! jz close03 + lhld file$id! call remove$locks +close03: + ret + +endif + +func17: + ; Search for first occurrence of a file + xchg! xra a +csearch: + push a + mov a,m! cpi '?'! jnz csearch1 ; no reselect if ? + call curselect! call noselect0! mvi c,0! jmp csearch3 +csearch1: + call getexta! mov a,m! cpi '?'! jz csearch2 + call clr$ext! call clrmodnum +csearch2: + call reselectx + mvi c,namlen +csearch3: + pop a! push a! jz csearch4 + ; dcnt = dcnt & 0fch + lhld dcnt! push h! mvi a,0fch + ana l! mov l,a! shld dcnt + call rd$dir + pop h! shld dcnt +csearch4: + pop a + lxi h,dir$to$user + push h + jz search + lda searchl! mov c,a! call searchi! jmp searchn + +func18: + ; Search for next occurrence of a file name + +if BANKED + xchg! shld searcha +else + lhld searcha! shld info +endif + + ori 1! jmp csearch + +func19: + ; Delete a file +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + jmp delete + +func20: + ; Read a file + call reselect + call check$fcb + jmp seqdiskread + +func21: + ; Write a file + call reselect + call check$fcb + jmp seqdiskwrite + +func22: + ; Make a file + +if BANKED + call get$atts! sta attributes +endif + + call clr$ext + call clrmodnum ; fcb mod = 0 + call reselectx + +if MPM + call reset$chksum$fcb +endif + + call check$wild + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + + call open ; Verify file does not already exist + +if MPM + call reset$chksum$fcb +endif + + ; Does dir fcb for fcb exist? + ; ora a required to reset carry + call end$of$dir! ora a! jz makea0 ; no + ; Is dir$ext < fcb(ext)? + call get$dir$ext! cmp m! jnc file$exists ; no +makea0: + push a ; carry set if dir fcb already exists + +if MPM + lda attributes! ani 80h! rrc! jnz makex00 + mvi a,80h +makex00: + sta make$flag + lda sdcnt+1! inr a! jz makex01 + call pack$sdcnt + mvi b,3! call search$olist! jz make$x02 +makex01: + lhld free$root! mov a,l! ora h! jz openx02 + jmp makex03 +makex02: + inx h! inx h + lda makeflag! ana m! jz openx06 + dcx h! dcx h! call compare$pds! jz makex03 + lda makeflag! ral! jc openx06 +makex03: + +endif + +if BANKED + ; Is fcb 1st fcb for file? + call qdirfcb1! jz makex04 ; yes + ; no - does dir lbl require passwords? + call get$dir$mode! ani 80h! jz makex04 + ; no - does xfcb exist with mode 1 or 2 password? + call get$xfcb! jz makex04 + ; yes - check password + call chk$xfcb$password1! jz makex04 + ; Verify password error + call chk$pw$error + lda pw$mode! ani 0c0h! jnz pw$error +makex04: + +endif + + ; carry on stack indicates a make not required because + ; of extent folding + pop a! cnc make + +if MPM + call reset$chksum$fcb +endif + + ; end$of$dir call either applies to above make or open call + call end$of$dir! rz ; Return if make unsuccessful + +if not MPM + call set$lsn +endif + +if BANKED + + ; Are passwords activated by dir lbl? + call get$dir$mode! ani 80h! jz make3a + ; Did user set password attribute? + lda attributes! ani 40h! jz make3a + ; Is fcb file's 1st logical fcb? + call qdirfcb1! jnz make3a + ; yes - does xfcb already exist for file + call xdcnt$eq$dcnt + call get$xfcb! jnz make00 ; yes + ; Attempt to make xfcb + mvi a,0ffh! sta make$xfcb! call make! jnz make00 + ; xfcb make failed - delete fcb that was created above + call search$namlen + call delete10! jmp lret$eq$ff ; Return with a = 0ffh + +make00: + call init$xfcb ; Initialize xfcb + ; Get password mode from dma + 8 + xchg! lhld xdmaad! lxi b,8! dad b! xchg + ldax d! ani 0e0h! jnz make2 + mvi a,080h ; default password mode is read protect +make2: + sta pw$mode + ; Set xfcb password mode field + push a! call getxfcb1! pop a! mov m,a + ; Set xfcb password and password checksum + ; Fix hash table and write xfcb + call set$pw! mov m,b! call sdl3 + ; Return to fcb + call restore$dir$fcb! rz + ; Does sfcb exist? + mvi c,8! call getdtba! ora a! jnz make3a ; no + ; Place password mode in sfcb if sfcb exists + lda pw$mode! mov m,a! call seek$copy + call set$lsn +endif + +make3a: + mvi c,0101$0000b + +if MPM + call openx2 + lda make$flag! sta attributes + ani 40h! ral! sta high$ext + lda sdcnt+1! inr a! jnz makexx02 + call sdcnt$eq$xdcnt! call pack$sdcnt + jmp openx03 +makexx02: + call fix$olist$item! jmp openx1 + jmp set$fcb$cks$flag +else + call openx2 + mvi c,0010$0000b! call qstamp! rnz + call stamp2! jmp set$filewf +endif + +file$exists: + mvi a,8 +set$aret: + mov c,a! sta aret+1! call lret$eq$ff + +if MPM + call test$error$mode! jnz goback +else + jmp goerr1 +endif + +if MPM + mov a,c! sui 3 + mov l,a! mvi h,0! dad h + lxi d,xerr$list! dad d + mov e,m! inx h! mov d,m + xchg! jmp report$err +endif + +func23: + ; Rename a file +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + jmp rename + +func24: + ; Return the login vector + lhld dlog! jmp sthl$ret + +func25: + ; Return selected disk number + lda seldsk! jmp sta$ret + +func26: + +if MPM + ; Save dma address in process descriptor + lhld info +intrnlsetdma: + xchg + call rlr! lxi b,disksetdma! dad b + mov m,e! inx h! mov m,d +endif + + ; Set the subsequent dma address to info + xchg! shld dmaad ; dmaad = info + jmp setdata ; to data dma address + +func27: + ; Return the login vector address + call curselect + lhld alloca! jmp sthl$ret + +if MPM + +func28: + ; Write protect current disk + ; first check for open files on disk + mvi a,0ffh! sta set$ro$flag + lda seldsk! mov c,a! lxi h,0001h + call hlrotl! call intrnldiskreset + jmp set$ro +else + +func28: equ set$ro ; Write protect current disk + +endif + +func29: + ; Return r/o bit vector + lhld rodsk! jmp sthl$ret + +func30: + ; Set file indicators + call check$wild +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + call indicators + jmp copy$dirloc ; lret=dirloc + +func31: + ; Return address of disk parameter block + call curselect + lhld dpbaddr +sthl$ret: + shld aret! ret + +func32: + ; Set user code + lda linfo! cpi 0ffh! jnz setusrcode + ; Interrogate user code instead + lda usrcode! jmp sta$ret ; lret=usrcode + setusrcode: + ani 0fh! sta usrcode + +if MPM + push a + call rlr! lxi b,diskselect! dad b + pop b + mov a,m! ani 0f0h! ora b! mov m,a +endif + + ret + +func33: + ; Random disk read operation + call reselect + call check$fcb + jmp randiskread ; to perform the disk read + +func34: + ; Random disk write operation + call reselect + call check$fcb + jmp randiskwrite ; to perform the disk write + +func35: + ; Return file size (0-262,144) + call reselect + jmp getfilesize + +func36 equ setrandom ; Set random record + +func37: + ; Drive reset + +if MPM + call diskreset +reset$37: + lhld info +else + xchg +endif + +reset$37x: + mov a,l! cma! mov e,a! mov a,h! cma + lhld dlog! ana h! mov d,a! mov a,l! ana e + mov e,a! lhld rodsk! xchg! shld dlog + +if MPM + push h! call hl$eq$hl$and$de +else + mov a,l! ana e! mov l,a + mov a,h! ana d! mov h,a +endif + + shld rodsk + +if MPM + pop h! xchg! lhld rlog! call hl$eq$hl$and$de! shld rlog +endif + + ; Force select call in next curselect + mvi a,0ffh! sta curdsk! ret + +if MPM + +func38: + ; Access drive + + lxi h,packed$dcnt! mvi a,0ffh + mov m,a! inx h! mov m,a! inx h! mov m,a + xra a! xchg! lxi b,16 +acc$drv0: + dad h! adc b! dcr c! jnz acc$drv0 + ora a! rz + sta mult$cnt! dcr a! push a + call acc$drv02 + pop a! jmp openx02 ; insufficient free lock list items +acc$drv02: + call check$free! pop h ; Discard return addr, free space exists + call count$opens! pop b! add b! jc openx034 + sub m! jnc openx034 ; openmax exceeded + lhld info! lda curdsk! push a! mvi a,16 +acc$drv1: + dcr a! dad h! jc acc$drv2 +acc$drv15: + ora a! jnz acc$drv1 + pop a! sta curdsk! ret +acc$drv2: + push a! push h! sta curdsk + call create$olist$item + pop h! pop a! jmp acc$drv15 + +func39: + ; Free drive + lhld open$root! mov a,h! ora l! rz + xra a! sta incr$pdcnt! inr a! sta free$mode + lhld info! mov a,h! cmp l! jnz free$drv1 + inr a! jnz free$drv1 + sta free$mode! call free$files! jmp free$drv3 +free$drv1: + lda curdsk! push a! mvi a,16 +free$drv2: + dcr a! dad h! jc free$drv4 +free$drv25: + ora a! jnz free$drv2 + pop a! sta curdsk +free$drv3: + lda incr$pdcnt! ora a! rz + lda pdcnt! jmp chk$olist1 +free$drv4: + push a! push h! sta curdsk + call free$files + pop h! pop a! jmp free$drv25 +else + +func38 equ func$ret +func39 equ func$ret + +endif + +func40 equ func34 ; Write random with zero fill + +if MPM + +func41 equ func$ret ; Test & write +func42: ; Record lock + mvi a,0ffh! sta lock$unlock! jmp lock +func43: ; Record unlock + xra a! sta lock$unlock! jmp lock + +else + +func42 equ func$ret ; Record lock +func43 equ func$ret ; Record unlock + +endif + +func44: ; Set multi-sector count + mov a,e! ora a! jz lret$eq$ff + cpi 129! jnc lret$eq$ff + sta mult$cnt + +if MPM + mov d,a + call rlr! lxi b,mult$cnt$off! dad b + mov m,d +endif + + ret + +func45: ; Set bdos error mode + +if MPM + call rlr! lxi b,pname+4! dad b + call set$pflag + mov m,a! inx h + call set$pflag + mov m,a! ret + +set$pflag: + mov a,m! ani 7fh! inr e! rnz + ori 80h! ret +else + mov a,e! sta error$mode +endif + + ret + +func46: + ; Get free space + ; Perform temporary select of specified drive + call tmpselect + lhld alloca! xchg ; de = alloc vector addr + call get$nalbs ; Get # alloc blocks + ; hl = # of allocation vector bytes + ; Count # of true bits in allocation vector + lxi b,0 ; bc = true bit accumulator +gsp1: ldax d +gsp2: ora a! jz gsp4 +gsp3: rar! jnc gsp3 + inx b! jmp gsp2 +gsp4: inx d! dcx h + mov a,l! ora h! jnz gsp1 + ; hl = 0 when allocation vector processed + ; Compute maxall + 1 - bc + lhld maxall! inx h + mov a,l! sub c! mov l,a + mov a,h! sbb b! mov h,a + ; hl = # of available blocks on drive + lda blkshf! mov c,a! xra a + call shl3bv + ; ahl = # of available sectors on drive + ; Store ahl in beginning of current dma + xchg! lhld xdmaad! mov m,e! inx h + mov m,d! inx h! mov m,a! ret + +if MPM + +func47 equ func$ret + +else + +func47: ; Chain to program + lxi h,ccp$flgs! mov a,m! ori 80h! mov m,a + inr e! jnz rebootx1 + mov a,m! ori 40h! mov m,a + jmp rebootx1 +endif + +func48: ; Flush buffers + call check$all$media + call flushf + call diocomp +flush0: ; Function 98 entry point + lhld dlog! mvi a,16 +flush1: + dcr a! dad h! jnc flush5 + push a! push h! mov e,a! call tmpselect ; seldsk = e + lda fx! cpi 48! jz flush3 + ; Function 98 - reset allocation + ; Copy 2nd ALV over 1st ALV + call copy$alv +if BANKED + jmp patch$2d3a ;[JCE] DRI Patch 13 +else + jmp flush35 +endif + +flush3: + call flushx + ; if e = 0ffh then discard buffers after possible flush + lda linfo! inr a! jnz flush4 +flush35: + call discard$data +flush4: + pop h! pop a +flush5: + ora a! jnz flush1 + ret + +flush: + call flushf + call diocomp +flushx: + lda phymsk! ora a! rz + mvi a,4! jmp deblock$dta + +if MPM + +func49 equ func$ret + +else + +func49: ; Get/Set system control block + + xchg! mov a,m! cpi 99! rnc + xchg! lxi h,scb! add l! mov l,a + xchg! inx h! mov a,m! cpi 0feh! jnc func49$set + xchg! mov e,m! inx h! mov d,m! xchg + jmp sthl$ret +func49$set: + mov b,a! inx h! mov a,m! stax d! inr b! rz + inx h! inx d! mov a,m! stax d! ret +endif + +if MPM + +func50 equ func$ret + +else + +func50: ; Direct bios call + ; de -> function (1 byte) + ; a value (1 byte) + ; bc value (2 bytes) + ; de value (2 bytes) + ; hl value (2 bytes) + + lxi h,func50$ret! push h + xchg + +if BANKED + mov a,m! cpi 27! rz + cpi 12! jnz dir$bios1 + lxi d,dir$bios3! push d +dir$bios1: + cpi 9! jnz dir$bios2 + lxi d,dirbios4! push d +dir$bios2: + +endif + + push h! inx h! inx h + mov c,m! inx h! mov b,m! inx h + mov e,m! inx h! mov d,m! inx h + mov a,m! inx h! mov h,m! mov l,a + xthl! mov a,m! push h! mov l,a! add a! add l + + lxi h,bios + + add l! mov l,a! xthl + inx h! mov a,m! pop h! xthl! ret + +if BANKED + +dir$bios3: + mvi a,1! jmp setbnkf + +dir$bios4: + mov a,l! ora h! rz + xchg! lxi h,10! dad d! mvi m,0 ; Zero login sequence # + lhld common$base! call subdh! xchg! rnc + ; Copy DPH to common memory + xchg! lhld info! inx h! push h! lxi b,25 + call movef! pop h! ret +endif + +func50$ret: + +if BANKED + shld aret! mov b,a + lhld info! mov a,m + cpi 9! rz + cpi 16! rz + cpi 20! rz + cpi 22! rz + mov a,b! jmp sta$ret +else + xchg! lhld entsp! sphl! xchg! ret +endif +endif + +func98 equ flush0 ; Reset Allocation + +func99: ; Truncate file + call reselectx + call check$wild + +if BANKED + call chk$password! cnz chk$pw$error +endif + + mvi c,true! call rseek! jnz lret$eq$ff + ; compute dir$fcb size + call getdptra! lxi d,reccnt + call compute$rr ; cba = fcb size + ; Is random rec # >= dir$fcb size + call get$rra! call compare$rr + jc lret$eq$ff ; yes ( > ) + ora d! jz lret$eq$ff ; yes ( = ) + ; Perform truncate + call check$rodir ; may be r/o file + call wrdir ; verify BIOS can write to disk + call update$stamp ; Set update stamp + call search$extnum +trunc1: + jz copy$dirloc + ; is dirfcb < fcb? + call compare$mod$ext! jc trunc2 ; yes + ; remove dirfcb blocks from allocation vector + push a! mvi c,0! call scandm$ab! pop a + ; is dirfcb = fcb? + jz trunc3 ; yes + ; delete dirfcb + call getdptra! mvi m,empty! call fix$hash +trunc15: + call wrdir +trunc2: + call searchn + jmp trunc1 +trunc3: + call getfcb! call dm$position + call zero$dm + ; fcb(extnum) = dir$ext after blocks removed + call get$dir$ext! cmp m! mov m,a! push a + ; fcb(rc) = fcb(cr) + 1 + call getfcba! mov a,m! inr a! stax d + ; rc = 0 or 128 if dir$ext < fcb(extnum) + pop a! xchg! cnz set$rc3 + ; rc = 0 if no blocks remain in fcb + lda dminx! ora a! cz set$rc3 + lxi b,11! call get$fcb$adds! xchg + ; reset archive (t3') attribute bit + mov a,m! ani 7fh! mov m,a! inx h! inx d + ; dirfcb(extnum) = fcb(extnum) + ldax d! mov m,a + ; advance to .fcb(reccnt) & .dirfcb(reccnt) + inx h! mvi m,0! inx h! inx h + inx d! inx d! inx d + ; dirfcb_rc+dskmap = fcb_rc+dskmap + mvi c,17! call move + ; restore non-erased blkidxs in allocation vector + mvi c,1! call scandm$ab + jmp trunc15 + +get$fcb$adds: + call getdptra! dad b! xchg + lhld info! dad b! ret + +compare$mod$ext: + lxi b,modnum! call get$fcb$adds + mov a,m! ani 3fh! mov b,a + ; compare dirfcb(modnum) to fcb(modnum) + ldax d! cmp b! rnz ; dirfcb(modnum) ~= fcb(modnum) + dcx h! dcx h! dcx d! dcx d + ; compare dirfcb(extnum) to fcb(extnum) + ldax d! mov c,m! call compext! rz ; dirfcb(extnum) = fcb(extnum) + ldax d! cmp m! ret + +zero$dm: + inr a! lxi h,single! inr m! jz zero$dm1 + add a +zero$dm1: + dcr m + call getdma! mov c,a! mvi b,0! dad b + mvi a,16 +zero$dm2: + cmp c! rz + mov m,b! inx h! inr c! jmp zero$dm2 + +if BANKED + +func100: ; Set directory label + ; de -> .fcb + ; drive location + ; name & type fields user's discretion + ; extent field definition + ; bit 1 (80h): enable passwords on drive + ; bit 2 (40h): enable file access + ; bit 3 (20h): enable file update stamping + ; bit 4 (10h): enable file create stamping + ; bit 8 (01h): assign new password to dir lbl + call reselectx + lhld info! mvi m,21h! mvi c,1 + call search! jnz sdl0 + call getexta! mov a,m! ani 0111$0000b! jnz lret$eq$ff +sdl0: + ; Does dir lbl exist on drive? + lhld info! mvi m,20h! mvi c,1 + call set$xdcnt! call search! jnz sdl1 + ; no - make one + mvi a,0ffh! sta make$xfcb + call make! rz ; no dir space + call init$xfcb + lxi b,24! call stamp5! call stamp1 +sdl1: + ; Update date & time stamp + lxi b,28! call stamp5! call stamp2 + ; Verify password - new dir lbl falls through + call chk$xfcb$password! jnz pw$error + lxi b,0! call init$xfcb0 + ; Set dir lbl dta in extent field + ldax d! ori 1h! mov m,a + ; Low bit of dir lbl data set to indicate dir lbl exists + ; Update drive's dir lbl vector element + push h! lhld drvlbla! mov m,a! pop h +sdl2: + ; Assign new password to dir lbl or xfcb? + ldax d! ani 1! jz sdl3 + ; yes - new password field is in 2nd 8 bytes of dma + lxi d,8! call adjust$dmaad + call set$pw! mov m,b + lxi d,-8! call adjust$dmaad +sdl3: + call fix$hash + jmp seek$copy +else + +func100 equ lret$eq$ff +func103 equ lret$eq$ff + +endif + +func101: + ; Return directory label data + ; Perform temporary select of specified drive + call tmpselect + call get$dir$mode! jmp sta$ret + +func102: + ; Read file xfcb + call reselectx + call check$wild + call zero$ext$mod + call search$namlen! rz + call getdma! lxi b,8! call zero + push h! mvi c,0! call get$dtba! ora a! jnz rxfcb2 + pop d! xchg! mvi c,8 + +if BANKED + call move! ldax d! jmp rxfcb3 +else + jmp move +endif + +rxfcb2: + pop h! lxi b,8 + +if BANKED + call zero! call get$xfcb! rz + mov a,m +rxfcb3: + call getexta! mov m,a! ret +else + jmp zero +endif + +if BANKED + +func103: + ; Write or update file xfcb + call reselectx + ; Are passwords enabled in directory label? + call get$dir$mode! ral! jnc lret$eq$ff ; no + call check$wild + ; Save .fcb(ext) & ext + call getexta! mov b,m! push h! push b + ; Set extent & mod to zero + call zero$ext$mod + ; Does file's 1st fcb exist in directory? + call search$namlen + ; Restore extent + pop b! pop h! mov m,b! rz ; no + call set$xdcnt + ; Does sfcb exist? + call get$dtba$8! ora a! jz wxfcb5 ; yes + ; No - Does xfcb exist? + call get$xfcb! jnz wxfcb1 ; yes +wxfcb0: + ; no - does file exist in directory? + mvi a,0ffh! sta make$xfcb + call search$extnum! rz + ; yes - attempt to make xfcb for file + call make! rz ; no dir space + ; Initialize xfcb + call init$xfcb +wxfcb1: + ; Verify password - new xfcb falls through + call chk$xfcb$password! jnz pw$error + ; Set xfcb options data + push h! call getexta! pop d! xchg + mov a,m! ora a! jnz wxfcb2 + ldax d! ani 1! jnz wxfcb2 + call sdl3! jmp wxfcb4 +wxfcb2: + ldax d! ani 0e0h! jnz wxfcb3 + mvi a,80h +wxfcb3: + mov m,a! call sdl2 +wxfcb4: + call get$xfcb1! dcr a! sta pw$mode + call zero$ext$mod + call search$namlen! rz + call get$dtba$8! ora a! rnz + lda pw$mode! mov m,a! jmp seek$copy +wxfcb5: + ; Take sfcb's password mode over xfcb's mode + mov a,m! push a + call get$xfcb + ; does xfcb exist? + pop b! jz wxfcb0 ; no + ; Set xfcb's password mode to sfcb's mode + mov m,b! jmp wxfcb1 + +endif + +func104: ; Set current date and time + +if MPM + call get$stamp$add +else + lxi h,stamp +endif + call copy$stamp + mvi m,0! mvi c,0ffh! jmp timef + +func105: ; Get current date and time + + + +if MPM + call get$stamp$add +else + mvi c,0! call timef + lxi h,stamp +endif + + xchg + call copy$stamp + ldax d! jmp sta$ret + +copy$stamp: + mvi c,4! jmp move ; ret + +if MPM + +get$stamp$add: + call rlradr! lxi b,-5! dad b + ret +endif + +if BANKED + +func106: ; Set default password + +if MPM + call get$df$pwa! inr a! rz + lxi b,7! dad b +else + lxi h,df$password+7 +endif + xchg! lxi b,8! push h + jmp set$pw0 +else + +func106 equ func$ret + +endif + +func107: ; Return serial number + +if MPM + lhld sysdat! mvi l,181 +else + lxi h,serial +endif + + xchg! mvi c,6! jmp move + +func108: ; Get/Set program return code + + ; Is de = 0ffffh? + mov a,d! ana e! inr a + lhld clp$errcde! jz sthl$ret ; yes - return return code + xchg! shld clp$errcde! ret ; no - set return code + +goback0: + lxi h,0ffffh! shld aret +goback: + ; Arrive here at end of processing to return to user + lda resel! ora a! jz retmon + +if MPM + lda comp$fcb$cks! ora a! cnz set$chksum$fcb +endif + + lhld info! lda fcbdsk! mov m,a ; fcb(0)=fcbdsk +if BANKED + + ; fcb(7) = fcb(7) | xfcb$read$only + lxi d,7! dad d! lda xfcb$read$only! ora m! mov m,a + +endif +if MPM + ; if high$ext = 60h then fcb(8) = fcb(8) | 80h + ; else fcb(ext) = fcb(ext) | high$ext + + call getexta! lda high$ext! cpi 60h! jnz goback2 + lxi d,-4! dad d! mvi a,80h + goback2: + ora m! mov m,a +else + ; fcb(8) = fcb(8) | high$ext +if BANKED + inx h +else + lxi d,8! dad d +endif + lda high$ext! ora m! mov m,a +endif + +; return from the disk monitor + +retmon: + lhld entsp! sphl + lhld aret! mov a,l! mov b,h! ret +; +; data areas +; +efcb: db empty ; 0e5=available dir entry +rodsk: dw 0 ; read only disk vector +dlog: dw 0 ; logged-in disks + +if MPM + +rlog: dw 0 ; removeable logged-in disks +tlog: dw 0 ; removeable disk test login vector +ntlog: dw 0 ; new tlog vector +rem$drv: ds byte ; curdsk removable drive switch + ; 0 = permanent drive, 1 = removable drive +endif + +if not BANKED + +xdmaad equ $ +curdma ds word ; current dma address + +endif + +if not MPM + +buffa: ds word ; pointer to directory dma address + +endif + +; +; curtrka - alloca are set upon disk select +; (data must be adjacent, do not insert variables) +; (address of translate vector, not used) +cdrmaxa:ds word ; pointer to cur dir max value (2 bytes) +curtrka:ds word ; current track address (2) +curreca:ds word ; current record address (3) +drvlbla:ds word ; current drive label byte address (1) +lsn$add:ds word ; login sequence # address (1) + ; +1 -> bios media change flag (1) +dpbaddr:ds word ; current disk parameter block address +checka: ds word ; current checksum vector address +alloca: ds word ; current allocation vector address +dirbcba:ds word ; dir bcb list head +dtabcba:ds word ; data bcb list head +hash$tbla: + ds word ; directory hash table address + ds byte ; directory hash table bank + +addlist equ $-dpbaddr ; address list size + +; +; buffer control block format +; +; bcb format : drv(1) || rec(3) || pend(1) || sequence(1) || +; 0 1 4 5 +; +; track(2) || sector(2) || buffer$add(2) || +; 6 8 10 +; +; bank(1) || link(2) +; 12 13 +; + +; sectpt - offset obtained from disk parm block at dpbaddr +; (data must be adjacent, do not insert variables) +sectpt: ds word ; sectors per track +blkshf: ds byte ; block shift factor +blkmsk: ds byte ; block mask +extmsk: ds byte ; extent mask +maxall: ds word ; maximum allocation number +dirmax: ds word ; largest directory number +dirblk: ds word ; reserved allocation bits for directory +chksiz: ds word ; size of checksum vector +offset: ds word ; offset tracks at beginning +physhf: ds byte ; physical record shift +phymsk: ds byte ; physical record mask +dpblist equ $-sectpt ; size of area +; +; local variables +; +drec ds word ; directory record number +blk$off: ds byte ; record offset within block +last$off: ds byte ; last offset within new block +last$drive: ds byte ; drive of last new block +last$block: ds word ; last new block + +; The following two variables are initialized as a pair on entry + +dir$cnt: ds byte ; direct i/o count +mult$num: ds byte ; multi-sector number + +tranv: ds word ; address of translate vector +lock$unlock: +make$flag: +rmf: ds byte ; read mode flag for open$reel +incr$pdcnt: +dirloc: ds byte ; directory flag in rename, etc. +free$mode: +linfo: ds byte ; low(info) +dminx: ds byte ; local for diskwrite + +if MPM + +searchl:ds byte ; search length + +endif +if BANKED + +searcha:ds word ; search address + +endif + +if BANKED + +save$xfcb: + ds byte ; search xfcb save flag + +endif + +single: ds byte ; set true if single byte allocation map + +if MPM + +seldsk: ds byte ; currently selected disk + +endif + +seldsk: ds byte ; disk on entry to bdos +rcount: ds byte ; record count in current fcb +extval: ds byte ; extent number and extmsk +save$mod: + ds byte ; open$reel module save field + +vrecord:ds byte ; current virtual record + +if not MPM + +curdsk: db 0ffh ; current disk + +endif + +adrive: db 0ffh ; current blocking/deblocking disk +arecord:ds word ; current actual record + ds byte + +save$ranr: ds 3 ; random record save area +arecord1: ds word ; current actual block# * blkmsk +attributes: ds byte ; make attribute hold area +readf$sw: ds byte ; BIOS read/write switch + +;******** following variable order critical ***************** + +if MPM + +mult$cnt: ds byte ; multi-sector count +pdcnt: ds byte ; process descriptor count + +endif + +high$ext: ds byte ; fcb high ext bits + +if BANKED + +xfcb$read$only: ds byte ; xfcb read only flag + +endif +if MPM + +curdsk: db 0ffh ;current disk +packed$dcnt: ds 3 ; +pdaddr: ds word ; +;************************************************************ +cur$pos: ds word ; +prv$pos: ds word ; +sdcnt: ds word ; +sdblk: ds word ; +sdcnt0: ds word ; +sdblk0: ds word ; +dont$close: ds byte ; +open$cnt: ; mp/m temp variable for open +lock$cnt: ds word ; mp/m temp variable for lock +file$id: ds word ; mp/m temp variable for lock +deleted$files: ds byte +lock$shell: ds byte +lock$sp: ds word +set$ro$flag: ds byte +check$disk: ds byte +flushed: ds byte +fcb$cks$valid: ds byte +; mp/m variables * + +endif + +; local variables for directory access +dptr: ds byte ; directory pointer 0,1,2,3 + +save$hash: ds 4 ; hash code save area + +if BANKED + +copy$cr$init: ds byte ; copy$cr$only initialization value + +else + +hashmx: ds word ; cdrmax or dirmax +xdcnt: ds word ; empty directory dcnt + +endif + +if MPM + +xdcnt: ds word ; empty directory dcnt +xdblk: ds word ; empty directory block +dcnt: ds word ; directory counter 0,1,...,dirmax +dblk: ds word ; directory block index + +endif + +search$user0: ds byte ; search user 0 for file (open) + +user0$pass: ds byte ; search user 0 pass flag + +fcbdsk: ds byte ; disk named in fcb + +if MPM + +make$xfcb: ds 1 +find$xfcb: ds 1 + +endif + +log$fxs:db 15,16,17,19,22,23,30,35,99,100,102,103,0 +rw$fxs: db 20,21,33,34,40,41,0 +sc$fxs: db 16,18,0 + +if MPM + +comp$fcb$cks: ds byte ; compute fcb checksum flag + +endif +if BANKED + +pw$fcb: ds 12 ;1 | + db 0 ;2 | +pw$mode: db 0 ;3 |- Order critical + db 0 ;4 | + db 0 ;5 | + +df$password: ds 8 + +if MPM + ds 120 +endif +endif + +phy$off: ds byte +curbcba: ds word + +if BANKED + +lastbcba: ds word +rootbcba: ds word +emptybcba: ds word +seqbcba: ds word +buffer$bank: ds byte + +endif + +track: ds word +sector: ds word + +; ************************** +; Blocking/Deblocking Module +; ************************** + +deblock$dta: + lhld dtabcba + +if BANKED + cpi 4! jnz deblock +deblock$flush: + ; de = addr of 1st bcb + mov e,m! inx h! mov d,m + ; Search for dirty bcb with lowest track # + lxi h,0ffffh! shld track! xchg +deblock$flush1: + ; Does current drive own bcb? + lda adrive! cmp m! jnz deblock$flush2 ;no + ; Is bcb's buffer pending? + xchg! lxi h,4! dad d! mov a,m + xchg! inr a! jnz deblock$flush2 ; no + ; Is bcb(6) < track? + push h! inx d! inx d! xchg + mov e,m! inx h! mov d,m + ; Subdh computes hl = de - hl + lhld track! call subdh! pop h! jnc deblock$flush2 ; no + ; yes - track = bcb(6) , sector = addr(bcb) + xchg! shld track! xchg! shld sector +deblock$flush2: + ; Is this the last bcb? + call get$next$bcba! jnz deblock$flush1 ; no - hl = addr of next bcb + ; Does track = ffff? + lxi h,track! call test$ffff! rz ; yes - no bcb to flush + ; Flush bcb located by sector + lhld sector! xra a! mvi a,4! call deblock + lhld dtabcba! jmp deblock$flush ; Repeat until no bcb's to flush +endif + +deblock: + + ; BDOS Blocking/Deblocking routine + ; a = 1 -> read command + ; a = 2 -> write command + ; a = 3 -> locate command + ; a = 4 -> flush command + ; a = 5 -> directory update + + push a ; Save z flag and deblock fx + + ; phy$off = low(arecord) & phymsk + ; low(arecord) = low(arecord) & ~phymsk + call deblock8 + lda arecord! mov e,a! ana b! sta phy$off + mov a,e! ana c! sta arecord + +if BANKED + pop a! push a! cnz get$bcba +endif + + shld curbcba! call getbuffa! shld curdma + ; hl = curbcba, de = .adrive, c = 4 + call deblock9 + ; Is BCB discarded? + mov a,m! inr a! jz deblock2 ; yes + ; Is command flush? + pop a! push a! cpi 4! jnc deblock1 ; yes + ; Is referenced physical record already in buffer? + +;;; call compare ;[JCE] DRI patch 7 + call patch$1e0c + + jz deblock45 ; yes + xra a +deblock1: + ; Does buffer contain an updated record? + call deblock10 + cpi 5! jz deblock15 + mov a,m! ora a! jz deblock2 ; no +deblock15: + ; Reset record pending flag + mvi m,0 + ; Save arecord + lhld arecord! push h! lda arecord+2! push a + ; Flush physical record buffer + call deblock9 + xchg! call move + ; Select drive to be flushed + lxi h,curdsk! lda adrive! cmp m! cnz disk$select1 + ; Write record if drive logged-in + mvi a,1! cz deblock$io + ; Restore arecord + pop b! pop d! call set$arecord + ; Restore selected drive + call curselect +deblock2: + ; Is deblock command flush | dir write? + pop a! cpi 4! rnc ; yes - return + ; Is deblock command write? + push a! cpi 2! jnz deblock25 ; no + ; Is blk$off < last$off + lxi h,last$off + lda blk$off + cmp m + jnc deblock3 ; no +deblock25: + ; Discard BCB on read operations in case + ; I/O error occurs +;;; lhld curbcba ;[JCE] DRI Patch 7 + call patch$1e1c + mvi m,0ffh + ; Read physical record buffer + mvi a,2! jmp deblock35 +deblock3: + ; last$off = blk$off + 1 + inr a! mov m,a + ; Place track & sector in bcb + xra a +deblock35: + call deblock$io +deblock4: + call deblock9 ; phypfx = adrive || arecord + call move! mvi m,0 ; zero pending flag + +if BANKED + ; Zero logical record sequence + inx h! call set$bcb$seq +endif + +deblock45: + ; recadd = phybuffa + phy$off*80h + lda phy$off! inr a! lxi d,80h! lxi h,0ff80h +deblock5: + dad d! dcr a! jnz deblock5 + xchg! lhld curdma! dad d + ; If deblock command = locate then buffa = recadd; return + pop a! cpi 3! jnz deblock6 + shld buffa! ret +deblock6: + xchg! lhld dmaad! lxi b,80h + ; If deblock command = read + cpi 1 + +if BANKED + jnz deblock7 + ; then move to tpa + lda common$base+1! dcr a! cmp d! jc move$tpa + lda buffer$bank! mov c,a! mvi b,1! call deblock12 + lxi b,80h! jmp move$tpa +deblock7: + +else + jz move$tpa ; then move to dma +endif + + ; else move from dma + xchg + +if BANKED + lda common$base+1! dcr a! cmp h! jc deblock75 + lda buffer$bank! mov b,a! mvi c,1! call deblock12 + lxi b,80h +deblock75: + +endif + + call move$tpa + ; Set physical record pending flag for write command + call deblock10! mvi m,0ffh + ret + +deblock8: + lda phymsk! mov b,a! cma! mov c,a! ret + +deblock9: + lhld curbcba! lxi d,adrive! mvi c,4! ret + +deblock10: + lxi d,4 +deblock11: + lhld curbcba! dad d! ret + +if BANKED + +deblock12: + push h! push d! call xmovef + pop d! pop h! ret +endif + +deblock$io: + ; a = 0 -> seek only + ; a = 1 -> write + ; a = 2 -> read + push a! call seek + +if BANKED + lda buffer$bank! call setbnkf +endif + + mvi c,1 + pop a! dcr a + jz wrbuff + cp rdbuff + ; Move track & sector to bcb + call deblock10! inx h! inx h + lxi d,track! mvi c,4! jmp move + +if BANKED + +get$bcba: +;;; shld rootbcba ;[JCE] DRI Patch 13 + call patch$2d30 + lxi d,-13! dad d! shld lastbcba + call get$next$bcba! push h + ; Is there only 1 bcb in list? + call get$next$bcba! pop h! rz ; yes - return + xchg! lxi h,0! shld emptybcba! shld seqbcba + xchg +get$bcb1: + ; Does bcb contain requested record? + shld curbcba! call deblock9! call compare! jz get$bcb4 ; yes + ; Is bcb discarded? + lhld curbcba! mov a,m! inr a! jnz get$bcb11 ; no + xchg! lhld lastbcba! shld emptybcba! jmp get$bcb14 +get$bcb11: + ; Does bcb contain record from current disk? + lda adrive! cmp m! jnz get$bcb15 ; no + xchg! lxi h,5! dad d! lda phy$msk + ; Is phy$msk = 0? + ora a! jz get$bcb14 ; yes + ; Does bcb(5) [bcb sequence] = phymsk? + cmp m! jnz get$bcb14 ; no +;;; lhld seqbcba ;[JCE] DRI Patch 13 +;;; mov a,l +;;; ora h + lda patch$2d39 + ora a + nop + jnz get$bcb14 + lhld lastbcba! shld seqbcba +get$bcb14: + xchg +get$bcb15: + ; Advance to next bcb - list exhausted? + push h! call get$next$bcba! pop d! jz get$bcb2 ; yes + xchg! shld lastbcba! xchg! jmp get$bcb1 +get$bcb2: + ; Matching bcb not found + ; Was a sequentially accessed bcb encountered? +;;; lhld seqbcba ;[JCE] DRI Patch 13 + lhld emptybcba + + mov a,l! ora h! jnz get$bcb25 ; yes + ; Was a discarded bcb encountered? +;;; lhld emptybcba ;[JCE] DRI Patch 13 + lhld seqbcba + + mov a,l! ora h! jz get$bcb3 ; no +get$bcb25: + shld lastbcba +get$bcb3: + ; Insert selected bcb at head of list + lhld lastbcba! call get$next$bcba + shld curbcba! call get$next$bcba + xchg! call last$bcb$links$de + lhld rootbcba! mov e,m! inx h! mov d,m + lhld curbcba! lxi b,13! dad b + mov m,e! inx h! mov m,d + lhld curbcba! xchg! lhld rootbcba + mov m,e! inx h! mov m,d! xchg! ret +get$bcb4: + ; BCB matched arecord + lhld curbcba! lxi d,5! dad d + ; Does bcb(5) = phy$off? + lda phy$off! cmp m! jz get$bcb5 ; yes + ; Does bcb(5) + 1 = phy$off? + inr m! cmp m! jz get$bcb5 ; yes + call set$bcb$seq +get$bcb5: + ; Is bcb at head of list? + lhld curbcba! xchg! lhld rootbcba + mov a,m! inx h! mov l,m! mov h,a + call subdh! ora l! xchg! rz ; yes + jmp get$bcb3 ; no - insert bcb at head of list + +last$bcb$links$de: + lhld lastbcba! lxi b,13! dad b + mov m,e! inx h! mov m,d! ret + +get$next$bcba: + lxi b,13! dad b! mov e,m! inx h! mov d,m + xchg! mov a,h! ora l! ret + +set$bcb$seq: + lda phy$off! mov m,a! ora a! rz + lda phy$msk! inr a! mov m,a! ret + +endif + +if not MPM +if not BANKED + +patch$1dfd: ;[JCE] DRI Patch 7 + lda chksiz+1 + ral + jc get$dir$ext + mvi a,0ffh + sta patch$1e24 + jmp get$dir$ext + +patch$1e0c: + cpi 3 + jnz compare + lda patch$1e24 + inr a + jnz compare + pop h + jmp deblock25 + +patch$1e1c: + xra a + sta patch$1e24 + lhld curbcba + ret + +patch$1e24: + db 0 + +patch$1e25: + lxi h,0 + shld conbuffadd + shld ccp$conbuff + dcx h + dcx h + ret + +patch$1e31: ;Patch 13 + call check$write + lxi h,xdcnt + ret + +patch$1e38: + call reselectx + jmp check$write + +patch$1e3e: + call setfwf + jmp search$namlen + + ds 41 ;[JCE] Was 112 before patching +last: + org base + (((last-base)+255) and 0ff00h) - 112 + +olog: dw 0 +rlog: dw 0 + +patch$flgs: db 0,0,0,6 ;Patchlevel + dw base+6 + xra a! ret + +; System Control Block + +SCB: + +; Expansion Area - 6 bytes + +hashl: db 0 +hash: dw 0,0 +version: db 31h + +; Utilities Section - 8 bytes + +util$flgs: dw 0,0 +dspl$flgs: dw 0 + dw 0 + +; CLP Section - 4 bytes + +clp$flgs: dw 0 +clp$errcde: dw 0 + +; CCP Section - 8 bytes + +ccp$comlen: db 0 +ccp$curdrv: db 0 +ccp$curusr: db 0 +ccp$conbuff: dw 0 +ccp$flgs: dw 0 + db 0 + +; Device I/O Section - 32 bytes + +conwidth: db 0 +column: db 0 +conpage: db 0 +conline: db 0 +conbuffadd: dw 0 +conbufflen: dw 0 +conin$rflg: dw 0 +conout$rflg: dw 0 +auxin$rflg: dw 0 +auxout$rflg: dw 0 +lstout$rflg: dw 0 +page$mode: db 0 +pm$default: db 0 +ctlh$act: db 0 +rubout$act: db 0 +type$ahead: db 0 +contran: dw 0 +conmode: dw 0 + db 0 + db 0 +outdelim: db '$' +listcp db 0 +qflag: db 0 + +; BDOS Section - 42 bytes + +scbadd: dw scb +dmaad: dw 0080h +olddsk: db 0 +info: dw 0 +resel: db 0 +relog: db 0 +fx: db 0 +usrcode: db 0 +dcnt: dw 0 +searcha: dw 0 +searchl: db 0 +multcnt: db 1 +errormode: db 0 +searchchain: db 0,0ffh,0ffh,0ffh +temp$drive: db 0 +errdrv: db 0 + dw 0 +media$flag: db 0 + dw 0 +bdos$flags: db 0 +stamp: db 0ffh,0ffh,0ffh,0ffh,0ffh +commonbase: dw 0 +error: jmp error$sub +bdosadd: dw base+6 + +endif +endif + +; ************************ +; Directory Hashing Module +; ************************ + +; Hash format +; xxsuuuuu xxxxxxxx xxxxxxxx ssssssss +; x = hash code of fcb name field +; u = low 5 bits of fcb user field +; 1st bit is on for XFCB's +; s = shiftr(mod || ext,extshf) + +if not BANKED + +hashorg: + org base+(((hashorg-base)+255) and 0ff00h) +endif + +init$hash: + ; de = .hash table entry + ; hl = .dir fcb + push h! push d! call get$hash + ; Move computed hash to hash table entry + pop h! lxi d,hash! lxi b,4 + +if BANKED + lda hash$tbla+2! call move$out +else + call movef +endif + + ; Save next hash table entry address + shld arecord1 + ; Restore dir fcb address + pop h! ret + +set$hash: + ; Return if searchl = 0 + ora a! rz + ; Is searchl < 12 ? + cpi 12! jc set$hash2 ; yes - hashl = 0 + ; Is searchl = 12 ? + mvi a,2! jz set$hash1 ; yes - hashl = 2 + mvi a,3 ; hashl = 3 +set$hash1: + sta hashl + xchg + ; Is dir hashing invoked for drive? + call test$hash! rz ; no + xchg + lda fx + cpi 16! jz get$hash ; bdos fx = 16 + cpi 35! jz set$hash15 + cpi 20! jnc get$hash ; bdos fx = 20 or above +set$hash15: + mvi a,2! sta hashl ; bdos fx = 15,17,18,19, or 35 + ; if fcb wild then hashl = 0, hash = fcb(0) + ; else hashl = 2, hash = get$hash + push h! call chk$wild! pop h! jnz get$hash +set$hash2: + xra a! sta hashl + ; jmp get$hash + +get$hash: + ; hash(0) = fcb(0) + mov a,m! sta hash! inx h! xchg + ; Don't compute hash for dir lbl & sfcb's + lxi h,0! ani 20h! jnz get$hash6 + ; b = 11, c = 8, ahl = 0 + ; Compute fcb name hash (000000xx xxxxxxxxx xxxxxxxx) (ahl) + lxi b,0b08h +get$hash1: + ; Don't shift if fcb(8) + dcr c! push b! jz get$hash3 + ; Don't shift if fcb(6) + dcr c! dcr c! jz get$hash3 + ; ahl = ahl * 2 + dad h! adc a! push a! mov a,b + ; is b odd? + rar! jc get$hash4 ; yes + ; ahl = ahl * 2 for even fcb(i) + pop a! dad h! adc a +get$hash3: + push a +get$hash4: + ; a = fcb(i) & 7fh - 20h divided by 2 if even + ldax d! ani 7fh! sui 20h! rar! jnc get$hash5 + ral +get$hash5: + ; ahl = ahl + a + mov c,a! mvi b,0 + pop a! dad b! aci 0! pop b + ; advance to next fcb char + inx d! dcr b! jnz get$hash1 +get$hash6: + ; ahl = 000000xx xxxxxxxx xxxxxxxx + ; Store low 2 bytes of hash + shld hash+1! lxi h,hash + ; hash(0) = hash(0) (000uuuuu) | xx000000 + ani 3! rrc! rrc! ora m! mov m,a + ; Does fcb(0) = e5h, 20h, or 21h? + ani 20h! jnz get$hash9 ; yes + ; bc = 00000mmm mmmeeeee, m = module #, e = extent + ldax d! ani 1fh! mov c,a! inx d! inx d + ldax d! ani 3fh! rrc! rrc! rrc! mov d,a + ani 7! mov b,a! mov a,d! ani 0e0h! ora c! mov c,a + ; shift bc right by # of bits in extmsk + lda extmsk +get$hash7: + rar! jnc get$hash8 + push a + mov a,b! rar! mov b,a + mov a,c! rar! mov c,a + pop a! jmp get$hash7 +get$hash8: + ; hash(0) = hash(0) (xx0uuuuu) | 00s00000 + mov a,b! ani 1! rrc! rrc +get$hash9: + rrc! ora m! mov m,a + ; hash(3) = ssssssss + lxi d,3! dad d! mov m,c! ret + +test$hash: + lhld hash$tbla! mov a,l! ora h! inr a! ret + +search$hash: + ; Does hash table exist for drive? + call test$hash! rz ; no + ; Has dir hash search been disabled? + lda hashl! inr a! rz ; yes + ; Is searchl = 0? + lda searchl! ora a! rz ; yes + ; hashmx = cdrmaxa if searchl ~= 1 + ; dir$max if searchl = 1 + lhld cdrmaxa! mov e,m! inx h! mov d,m + xchg! dcr a! jnz search$h0 + lhld dir$max +search$h0: + shld hashmx + +if BANKED + ; call search$hash in resbdos, a = bank, hl = hash tbl addr + lda hash$tbla+2! lhld hash$tbla! call srch$hash + ; Was search successful? + jnz search$h1 ; no + ; Is directory read required? + lda rd$dir$flag! ora a! mvi c,0 + cnz r$dir2 ; yes if Z flag reset + ; Is function = 18? + lda fx! sui 18! rz ; Never reset dcnt for fx 18 + ; Was media change detected by above read? + lda hashl! inr a! cz setenddir ; yes + xra a! ret ; search$hash successful +search$h1: + ; Was search initiated from beginning of directory? + call end$of$dir! rnz ; no + ; Is bdos fx = 15,17,19,22,23,30? + call tst$log$fxs! rnz ; no + ; Disable hash & return successful + mvi a,0ffh! sta hashl + lhld cdrmaxa! mov e,m! inx h! mov d,m! xchg + dcx h! call set$dcnt$dblk1! xra a! ret +else + lhld hash$tbla! mov b,h! mov c,l + lhld hashmx! xchg + ; Return with Z flag set if dcnt = hashmx + lhld dcnt! push h! call subdh! pop d! ora l! rz + ; Push hashmx - dcnt (# of hashtbl entries to search) + ; Push dcnt + 1 + push h! inx d! xchg! push h + ; Compute .hash$tbl(dcnt) + dcx h! dad h! dad h! dad b +search$h1: + ; Advance hl to address of next hash$tbl entry + lxi d,4! dad d! lxi d,hash + ; Do hash u fields match? + ldax d! xra m! ani 1fh! jnz search$h3 ; no + ; Do hash's match? + call search$h6! jz search$h4 ; yes +search$h2: + xchg! pop h +search$h25: + ; de = .hash$tbl(dcnt), hl = dcnt + ; dcnt = dcnt + 1 + inx h! xthl + ; hl = # of hash$tbl entries to search + ; decrement & test for zero + ; Restore stack & hl to .hashtbl(dcnt) + dcx h! mov a,l! ora h! xthl! push h + ; Are we done? + xchg! jnz search$h1 ; no - keep searching + ; Search unsuccessful + pop h! pop h + ; Was search initiated from beginning of directory? + call end$of$dir! rnz ; no + ; Is fx = 15,17,19,22,23,30 & drive removeable? + call tst$log$fxs! rnz ; no + ; Disable hash & return successful + mvi a,0ffh! sta hashl + lhld cdrmaxa! mov e,m! inx h! mov d,m! xchg + dcx h! call set$dcnt$dblk1! xra a! ret + +search$h3: + ; Does xdcnt+1 = 0ffh? + lda xdcnt+1! inr a! jz search$h5 ; yes + ; Does xdcnt+1 = 0feh? + inr a! jnz search$h2 ; no - continue searching + ; Do hash's match? + call search$h6! jnz search$h2 ; no + ; xdcnt+1 = 0feh + ; Open user 0 search + ; Does hash u field = 0? + mov a,m! ani 1fh! jnz search$h2 ; no + ; Search successful +search$h4: + ; Successful search + ; Set dcnt to search$hash dcnt-1 + ; dcnt gets incremented by read$dir + ; Also discard search$hash loop count + lhld dcnt! xchg + pop h! dcx h! shld dcnt! pop b + ; Does dcnt&3 = 3? + mov a,l! ani 03h! cpi 03h! rz ; yes + ; Does old dcnt & new dcnt reside in same sector? + mov a,e! ani 0fch! mov e,a + mov a,l! ani 0fch! mov l,a + call subdh! ora l! rz ; yes + ; Read directory record + call read$dir2 + ; Has media change been detected? + lda hashl! inr a! cz setenddir ; dcnt = -1 if hashl = 0ffh + xra a! ret +search$h5: + ; xdcnt+1 = 0ffh + ; Make search to save dcnt of empty fcb + ; Is hash$tbl entry empty? + mov a,m! cpi 0f5h! jnz search$h2 ; no +search$h55: + ; xdcnt = dcnt + xchg! pop h! shld xdcnt! jmp search$h25 +search$h6: + ; hash compare routine + ; Is hashl = 0? + lda hashl! ora a! rz ; yes - hash compare successful + ; b = 0f0h if hashl = 3 + ; 0d0h if hashl = 2 + mov c,a! rrc! rrc! rrc! ori 1001$0000b! mov b,a + ; hash s field must be screened out of hash(0) + ; if hashl = 2 + ; Do hash(0) fields match? + ldax d! xra m! ana b! rnz ; no + ; Compare remainder of hash fields for hashl bytes + push h! inx h! inx d! call compare + pop h! ret +endif + +fix$hash: + call test$hash! rz + lxi h,save$hash! lxi d,hash! lxi b,4 + push h! push d! push b! call movef + lhld hash$tbla! push h + call get$dptra! call get$hash + lhld dcnt! dad h! dad h + pop d! dad d + pop b! pop d! push d! push b + +if BANKED + lda hash$tbla+2! call move$out +else + call movef +endif + + pop b! pop h! pop d! jmp movef + +if not MPM +if BANKED + +patch$1dfd: ;[JCE] DRI Patch 7 + lda chksiz+1 + ral + jc get$dir$ext + mvi a,0ffh + sta patch$1e24 + jmp get$dir$ext + +patch$1e0c: + cpi 3 + jnz compare + lda patch$1e24 + inr a + jnz compare + pop h + jmp deblock25 + +patch$1e1c: + xra a + sta patch$1e24 + lhld curbcba + ret + +patch$1e24: + db 0 + +patch$1e25: + lxi h,0 + shld conbuffadd + shld ccp$conbuff + dcx h + dcx h + ret + +patch$2d30: + shld rootbcba + sui 3 + sta patch$2d39 + ret + +patch$2d39: + db 0 + +patch$2d3a: + call patch$2d43 + jmp flush4 + +patch$2d40: + call copy$alv +patch$2d43: + lhld dtabcba + mov a,l + ana h + inr a + rz +patch$2d4a: + mov e,m + inx h + mov d,m + mov a,d + ora e + rz + lxi h,adrive + ldax d + cmp m + jnz patch$2d63 + lxi h,4 + dad d + mvi a,0ffh + cmp m + jnz patch$2d63 + stax d +patch$2d63: + lxi h,0dh + dad d + jmp patch$2d4a + +patch$2d6a: + call copy$alv + lhld lsn$add + mov a,m + ora a + rnz + mvi m,2 + ret + +patch$1e31: + call check$write + lxi h,xdcnt + ret + +patch$1e38: + call reselectx + jmp check$write + +patch$1e3e: + call setfwf + jmp search$namlen + +last: + + org (((last-base)+255) and 0ff00h) - 1 + db 0 + +endif ;BANKED + +else ;not MPM + + ds 192 +last: + org (((last-base)+255) and 0ff00h) - 192 + + ; bnkbdos patch area + + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0 + +free$root: dw $-$ +open$root: dw 0 +lock$root: dw 0 +lock$max: db 0 +open$max: db 0 + +; BIOS access table + +bios equ $ ; base of the bios jump table +bootf equ bios ; cold boot function +wbootf equ bootf+3 ; warm boot function +constf equ wbootf+3 ; console status function +coninf equ constf+3 ; console input function +conoutf equ coninf+3 ; console output function +listf equ conoutf+3 ; list output function +punchf equ listf+3 ; punch output function +readerf equ punchf+3 ; reader input function +homef equ readerf+3 ; disk home function +seldskf equ homef+3 ; select disk function +settrkf equ seldskf+3 ; set track function +setsecf equ settrkf+3 ; set sector function +setdmaf equ setsecf+3 ; set dma function +readf equ setdmaf+3 ; read disk function +writef equ readf+3 ; write disk function +liststf equ writef+3 ; list status function +sectran equ liststf+3 ; sector translate + +endif + + end diff --git a/software/CPM/cpm3/bioskrnl.asm b/software/CPM/cpm3/bioskrnl.asm new file mode 100644 index 0000000..5e72462 --- /dev/null +++ b/software/CPM/cpm3/bioskrnl.asm @@ -0,0 +1,653 @@ + title 'Root module of relocatable BIOS for CP/M 3.0' + + ; version 1.0 15 Sept 82 + +true equ -1 +false equ not true + +banked equ true + + +; Copyright (C), 1982 +; Digital Research, Inc +; P.O. Box 579 +; Pacific Grove, CA 93950 + + +; This is the invariant portion of the modular BIOS and is +; distributed as source for informational purposes only. +; All desired modifications should be performed by +; adding or changing externally defined modules. +; This allows producing "standard" I/O modules that +; can be combined to support a particular system +; configuration. + +cr equ 13 +lf equ 10 +bell equ 7 +ctlQ equ 'Q'-'@' +ctlS equ 'S'-'@' + +ccp equ 0100h ; Console Command Processor gets loaded into the TPA + + cseg ; GENCPM puts CSEG stuff in common memory + + + ; variables in system data page + + extrn @covec,@civec,@aovec,@aivec,@lovec ; I/O redirection vectors + extrn @mxtpa ; addr of system entry point + extrn @bnkbf ; 128 byte scratch buffer + + ; initialization + + extrn ?init ; general initialization and signon + extrn ?ldccp,?rlccp ; load & reload CCP for BOOT & WBOOT + + ; user defined character I/O routines + + extrn ?ci,?co,?cist,?cost ; each take device in + extrn ?cinit ; (re)initialize device in + extrn @ctbl ; physical character device table + + ; disk communication data items + + extrn @dtbl ; table of pointers to XDPHs + public @adrv,@rdrv,@trk,@sect ; parameters for disk I/O + public @dma,@dbnk,@cnt ; '' '' '' '' + + ; memory control + + public @cbnk ; current bank + extrn ?xmove,?move ; select move bank, and block move + extrn ?bank ; select CPU bank + + ; clock support + + extrn ?time ; signal time operation + + ; general utility routines + + public ?pmsg,?pdec ; print message, print number from 0 to 65535 + public ?pderr ; print BIOS disk error message header + + maclib modebaud ; define mode bits + + + ; External names for BIOS entry points + + public ?boot,?wboot,?const,?conin,?cono,?list,?auxo,?auxi + public ?home,?sldsk,?sttrk,?stsec,?stdma,?read,?write + public ?lists,?sctrn + public ?conos,?auxis,?auxos,?dvtbl,?devin,?drtbl + public ?mltio,?flush,?mov,?tim,?bnksl,?stbnk,?xmov + + + ; BIOS Jump vector. + + ; All BIOS routines are invoked by calling these + ; entry points. + +?boot: jmp boot ; initial entry on cold start +?wboot: jmp wboot ; reentry on program exit, warm start + +?const: jmp const ; return console input status +?conin: jmp conin ; return console input character +?cono: jmp conout ; send console output character +?list: jmp list ; send list output character +?auxo: jmp auxout ; send auxilliary output character +?auxi: jmp auxin ; return auxilliary input character + +?home: jmp home ; set disks to logical home +?sldsk: jmp seldsk ; select disk drive, return disk parameter info +?sttrk: jmp settrk ; set disk track +?stsec: jmp setsec ; set disk sector +?stdma: jmp setdma ; set disk I/O memory address +?read: jmp read ; read physical block(s) +?write: jmp write ; write physical block(s) + +?lists: jmp listst ; return list device status +?sctrn: jmp sectrn ; translate logical to physical sector + +?conos: jmp conost ; return console output status +?auxis: jmp auxist ; return aux input status +?auxos: jmp auxost ; return aux output status +?dvtbl: jmp devtbl ; return address of device def table +?devin: jmp ?cinit ; change baud rate of device + +?drtbl: jmp getdrv ; return address of disk drive table +?mltio: jmp multio ; set multiple record count for disk I/O +?flush: jmp flush ; flush BIOS maintained disk caching + +?mov: jmp ?move ; block move memory to memory +?tim: jmp ?time ; Signal Time and Date operation +?bnksl: jmp bnksel ; select bank for code execution and default DMA +?stbnk: jmp setbnk ; select different bank for disk I/O DMA operations. +?xmov: jmp ?xmove ; set source and destination banks for one operation + + jmp 0 ; reserved for future expansion + jmp 0 ; reserved for future expansion + jmp 0 ; reserved for future expansion + + + ; BOOT + ; Initial entry point for system startup. + + dseg ; this part can be banked + +boot: + lxi sp,boot$stack + mvi c,15 ; initialize all 16 character devices +c$init$loop: + push b ! call ?cinit ! pop b + dcr c ! jp c$init$loop + + call ?init ; perform any additional system initialization + ; and print signon message + + lxi b,16*256+0 ! lxi h,@dtbl ; init all 16 logical disk drives +d$init$loop: + push b ; save remaining count and abs drive + mov e,m ! inx h ! mov d,m ! inx h ; grab @drv entry + mov a,e ! ora d ! jz d$init$next ; if null, no drive + push h ; save @drv pointer + xchg ; XDPH address in + dcx h ! dcx h ! mov a,m ! sta @RDRV ; get relative drive code + mov a,c ! sta @ADRV ; get absolute drive code + dcx h ; point to init pointer + mov d,m ! dcx h ! mov e,m ; get init pointer + xchg ! call ipchl ; call init routine + pop h ; recover @drv pointer +d$init$next: + pop b ; recover counter and drive # + inr c ! dcr b ! jnz d$init$loop ; and loop for each drive + jmp boot$1 + + cseg ; following in resident memory + +boot$1: + call set$jumps + call ?ldccp ; fetch CCP for first time + jmp ccp + + + ; WBOOT + ; Entry for system restarts. + +wboot: + lxi sp,boot$stack + call set$jumps ; initialize page zero + call ?rlccp ; reload CCP + jmp ccp ; then reset jmp vectors and exit to ccp + + +set$jumps: + + if banked + mvi a,1 ! call ?bnksl + endif + + mvi a,JMP + sta 0 ! sta 5 ; set up jumps in page zero + lxi h,?wboot ! shld 1 ; BIOS warm start entry + lhld @MXTPA ! shld 6 ; BDOS system call entry + ret + + + ds 64 +boot$stack equ $ + + + ; DEVTBL + ; Return address of character device table + +devtbl: + lxi h,@ctbl ! ret + + + ; GETDRV + ; Return address of drive table + +getdrv: + lxi h,@dtbl ! ret + + + + ; CONOUT + ; Console Output. Send character in + ; to all selected devices + +conout: + + lhld @covec ; fetch console output bit vector + jmp out$scan + + + ; AUXOUT + ; Auxiliary Output. Send character in + ; to all selected devices + +auxout: + lhld @aovec ; fetch aux output bit vector + jmp out$scan + + + ; LIST + ; List Output. Send character in + ; to all selected devices. + +list: + lhld @lovec ; fetch list output bit vector + +out$scan: + mvi b,0 ; start with device 0 +co$next: + dad h ; shift out next bit + jnc not$out$device + push h ; save the vector + push b ; save the count and character +not$out$ready: + call coster ! ora a ! jz not$out$ready + pop b ! push b ; restore and resave the character and device + call ?co ; if device selected, print it + pop b ; recover count and character + pop h ; recover the rest of the vector +not$out$device: + inr b ; next device number + mov a,h ! ora l ; see if any devices left + jnz co$next ; and go find them... + ret + + + ; CONOST + ; Console Output Status. Return true if + ; all selected console output devices + ; are ready. + +conost: + lhld @covec ; get console output bit vector + jmp ost$scan + + + ; AUXOST + ; Auxiliary Output Status. Return true if + ; all selected auxiliary output devices + ; are ready. + +auxost: + lhld @aovec ; get aux output bit vector + jmp ost$scan + + + ; LISTST + ; List Output Status. Return true if + ; all selected list output devices + ; are ready. + +listst: + lhld @lovec ; get list output bit vector + +ost$scan: + mvi b,0 ; start with device 0 +cos$next: + dad h ; check next bit + push h ; save the vector + push b ; save the count + mvi a,0FFh ; assume device ready + cc coster ; check status for this device + pop b ; recover count + pop h ; recover bit vector + ora a ; see if device ready + rz ; if any not ready, return false + inr b ; drop device number + mov a,h ! ora l ; see if any more selected devices + jnz cos$next + ori 0FFh ; all selected were ready, return true + ret + +coster: ; check for output device ready, including optional + ; xon/xoff support + mov l,b ! mvi h,0 ; make device code 16 bits + push h ; save it in stack + dad h ! dad h ! dad h ; create offset into device characteristics tbl + lxi d,@ctbl+6 ! dad d ; make address of mode byte + mov a,m ! ani mb$xonxoff + pop h ; recover console number in + jz ?cost ; not a xon device, go get output status direct + lxi d,xofflist ! dad d ; make pointer to proper xon/xoff flag + call cist1 ; see if this keyboard has character + mov a,m ! cnz ci1 ; get flag or read key if any + cpi ctlq ! jnz not$q ; if its a ctl-Q, + mvi a,0FFh ; set the flag ready +not$q: + cpi ctls ! jnz not$s ; if its a ctl-S, + mvi a,00h ; clear the flag +not$s: + mov m,a ; save the flag + call cost1 ; get the actual output status, + ana m ; and mask with ctl-Q/ctl-S flag + ret ; return this as the status + +cist1: ; get input status with and saved + push b ! push h + call ?cist + pop h ! pop b + ora a + ret + +cost1: ; get output status, saving & + push b ! push h + call ?cost + pop h ! pop b + ora a + ret + +ci1: ; get input, saving & + push b ! push h + call ?ci + pop h ! pop b + ret + + + ; CONST + ; Console Input Status. Return true if + ; any selected console input device + ; has an available character. + +const: + lhld @civec ; get console input bit vector + jmp ist$scan + + + ; AUXIST + ; Auxiliary Input Status. Return true if + ; any selected auxiliary input device + ; has an available character. + +auxist: + lhld @aivec ; get aux input bit vector + +ist$scan: + mvi b,0 ; start with device 0 +cis$next: + dad h ; check next bit + mvi a,0 ; assume device not ready + cc cist1 ; check status for this device + ora a ! rnz ; if any ready, return true + inr b ; drop device number + mov a,h ! ora l ; see if any more selected devices + jnz cis$next + xra a ; all selected were not ready, return false + ret + + + ; CONIN + ; Console Input. Return character from first + ; ready console input device. + +conin: + lhld @civec + jmp in$scan + + + ; AUXIN + ; Auxiliary Input. Return character from first + ; ready auxiliary input device. + +auxin: + lhld @aivec + +in$scan: + push h ; save bit vector + mvi b,0 +ci$next: + dad h ; shift out next bit + mvi a,0 ; insure zero a (nonexistant device not ready). + cc cist1 ; see if the device has a character + ora a + jnz ci$rdy ; this device has a character + inr b ; else, next device + mov a,h ! ora l ; see if any more devices + jnz ci$next ; go look at them + pop h ; recover bit vector + jmp in$scan ; loop til we find a character + +ci$rdy: + pop h ; discard extra stack + jmp ?ci + + +; Utility Subroutines + + +ipchl: ; vectored CALL point + pchl + + +?pmsg: ; print message @ up to a null + ; saves & + push b + push d +pmsg$loop: + mov a,m ! ora a ! jz pmsg$exit + mov c,a ! push h + call ?cono ! pop h + inx h ! jmp pmsg$loop +pmsg$exit: + pop d + pop b + ret + +?pdec: ; print binary number 0-65535 from + lxi b,table10! lxi d,-10000 +next: + mvi a,'0'-1 +pdecl: + push h! inr a! dad d! jnc stoploop + inx sp! inx sp! jmp pdecl +stoploop: + push d! push b + mov c,a! call ?cono + pop b! pop d +nextdigit: + pop h + ldax b! mov e,a! inx b + ldax b! mov d,a! inx b + mov a,e! ora d! jnz next + ret + +table10: + dw -1000,-100,-10,-1,0 + +?pderr: + lxi h,drive$msg ! call ?pmsg ; error header + lda @adrv ! adi 'A' ! mov c,a ! call ?cono ; drive code + lxi h,track$msg ! call ?pmsg ; track header + lhld @trk ! call ?pdec ; track number + lxi h,sector$msg ! call ?pmsg ; sector header + lhld @sect ! call ?pdec ; sector number + ret + + + ; BNKSEL + ; Bank Select. Select CPU bank for further execution. + +bnksel: + sta @cbnk ; remember current bank + jmp ?bank ; and go exit through users + ; physical bank select routine + + +xofflist db -1,-1,-1,-1,-1,-1,-1,-1 ; ctl-s clears to zero + db -1,-1,-1,-1,-1,-1,-1,-1 + + + + dseg ; following resides in banked memory + + + +; Disk I/O interface routines + + + ; SELDSK + ; Select Disk Drive. Drive code in . + ; Invoke login procedure for drive + ; if this is first select. Return + ; address of disk parameter header + ; in + +seldsk: + mov a,c ! sta @adrv ; save drive select code + mov l,c ! mvi h,0 ! dad h ; create index from drive code + lxi b,@dtbl ! dad b ; get pointer to dispatch table + mov a,m ! inx h ! mov h,m ! mov l,a ; point at disk descriptor + ora h ! rz ; if no entry in table, no disk + mov a,e ! ani 1 ! jnz not$first$select ; examine login bit + push h ! xchg ; put pointer in stack & + lxi h,-2 ! dad d ! mov a,m ! sta @RDRV ; get relative drive + lxi h,-6 ! dad d ; find LOGIN addr + mov a,m ! inx h ! mov h,m ! mov l,a ; get address of LOGIN routine + call ipchl ; call LOGIN + pop h ; recover DPH pointer +not$first$select: + ret + + + ; HOME + ; Home selected drive. Treated as SETTRK(0). + +home: + lxi b,0 ; same as set track zero + + + ; SETTRK + ; Set Track. Saves track address from + ; in @TRK for further operations. + +settrk: + mov l,c ! mov h,b + shld @trk + ret + + + ; SETSEC + ; Set Sector. Saves sector number from + ; in @sect for further operations. + +setsec: + mov l,c ! mov h,b + shld @sect + ret + + + ; SETDMA + ; Set Disk Memory Address. Saves DMA address + ; from in @DMA and sets @DBNK to @CBNK + ; so that further disk operations take place + ; in current bank. + +setdma: + mov l,c ! mov h,b + shld @dma + + lda @cbnk ; default DMA bank is current bank + ; fall through to set DMA bank + + ; SETBNK + ; Set Disk Memory Bank. Saves bank number + ; in @DBNK for future disk data + ; transfers. + +setbnk: + sta @dbnk + ret + + + ; SECTRN + ; Sector Translate. Indexes skew table in + ; with sector in . Returns physical sector + ; in . If no skew table (=0) then + ; returns physical=logical. + +sectrn: + mov l,c ! mov h,b + mov a,d ! ora e ! rz + xchg ! dad b ! mov l,m ! mvi h,0 + ret + + + ; READ + ; Read physical record from currently selected drive. + ; Finds address of proper read routine from + ; extended disk parameter header (XDPH). + +read: + lhld @adrv ! mvi h,0 ! dad h ; get drive code and double it + lxi d,@dtbl ! dad d ; make address of table entry + mov a,m ! inx h ! mov h,m ! mov l,a ; fetch table entry + push h ; save address of table + lxi d,-8 ! dad d ; point to read routine address + jmp rw$common ; use common code + + + ; WRITE + ; Write physical sector from currently selected drive. + ; Finds address of proper write routine from + ; extended disk parameter header (XDPH). + +write: + lhld @adrv ! mvi h,0 ! dad h ; get drive code and double it + lxi d,@dtbl ! dad d ; make address of table entry + mov a,m ! inx h ! mov h,m ! mov l,a ; fetch table entry + push h ; save address of table + lxi d,-10 ! dad d ; point to write routine address + +rw$common: + mov a,m ! inx h ! mov h,m ! mov l,a ; get address of routine + pop d ; recover address of table + dcx d ! dcx d ; point to relative drive + ldax d ! sta @rdrv ; get relative drive code and post it + inx d ! inx d ; point to DPH again + pchl ; leap to driver + + + ; MULTIO + ; Set multiple sector count. Saves passed count in + ; @CNT + +multio: + sta @cnt ! ret + + + ; FLUSH + ; BIOS deblocking buffer flush. Not implemented. + +flush: + xra a ! ret ; return with no error + + + + ; error message components +drive$msg db cr,lf,bell,'BIOS Error on ',0 +track$msg db ': T-',0 +sector$msg db ', S-',0 + + + ; disk communication data items + +@adrv ds 1 ; currently selected disk drive +@rdrv ds 1 ; controller relative disk drive +@trk ds 2 ; current track number +@sect ds 2 ; current sector number +@dma ds 2 ; current DMA address +@cnt db 0 ; record count for multisector transfer +@dbnk db 0 ; bank for DMA operations + + + cseg ; common memory + +@cbnk db 0 ; bank for processor operations + + + end diff --git a/software/CPM/cpm3/boot.asm b/software/CPM/cpm3/boot.asm new file mode 100644 index 0000000..a1a175b --- /dev/null +++ b/software/CPM/cpm3/boot.asm @@ -0,0 +1,122 @@ + title 'Boot loader module for CP/M 3.0' + +true equ -1 +false equ not true + +banked equ true + + public ?init,?ldccp,?rlccp,?time + extrn ?pmsg,?conin + extrn @civec,@covec,@aivec,@aovec,@lovec + extrn @cbnk,?bnksl + + maclib ports + maclib z80 + +bdos equ 5 + + if banked +tpa$bank equ 1 + else +tpa$bank equ 0 + endif + + dseg ; init done from banked memory + +?init: + lxi h,08000h ! shld @civec ! shld @covec ; assign console to CRT: + lxi h,04000h ! shld @lovec ; assign printer to LPT: + lxi h,02000h ! shld @aivec ! shld @aovec ; assign AUX to CRT1: + lxi h,init$table ! call out$blocks ; set up misc hardware + lxi h,signon$msg ! call ?pmsg ; print signon message + ret + +out$blocks: + mov a,m ! ora a ! rz ! mov b,a + inx h ! mov c,m ! inx h + outir + jmp out$blocks + + + cseg ; boot loading most be done from resident memory + + ; This version of the boot loader loads the CCP from a file + ; called CCP.COM on the system drive (A:). + + +?ldccp: + ; First time, load the A:CCP.COM file into TPA + xra a ! sta ccp$fcb+15 ; zero extent + lxi h,0 ! shld fcb$nr ; start at beginning of file + lxi d,ccp$fcb ! call open ; open file containing CCP + inr a ! jz no$CCP ; error if no file... + lxi d,0100h ! call setdma ; start of TPA + lxi d,128 ! call setmulti ; allow up to 16k bytes + lxi d,ccp$fcb ! call read ; load the thing + ; now, + ; copy CCP to bank 0 for reloading + lxi h,0100h ! lxi b,0C80h ; clone 3K, just in case + lda @cbnk ! push psw ; save current bank +ld$1: + mvi a,tpa$bank ! call ?bnksl ; select TPA + mov a,m ! push psw ; get a byte + mvi a,2 ! call ?bnksl ; select extra bank + pop psw ! mov m,a ; save the byte + inx h ! dcx b ; bump pointer, drop count + mov a,b ! ora c ; test for done + jnz ld$1 + pop psw ! call ?bnksl ; restore original bank + ret + +no$CCP: ; here if we couldn't find the file + lxi h,ccp$msg ! call ?pmsg ; report this... + call ?conin ; get a response + jmp ?ldccp ; and try again + + +?rlccp: + lxi h,0100h ! lxi b,0C00h ; clone 3K +rl$1: + mvi a,2 ! call ?bnksl ; select extra bank + mov a,m ! push psw ; get a byte + mvi a,tpa$bank ! call ?bnksl ; select TPA + pop psw ! mov m,a ; save the byte + inx h ! dcx b ; bump pointer, drop count + mov a,b ! ora c ; test for done + jnz rl$1 + ret + + ; No external clock. +?time: + ret + + ; CP/M BDOS Function Interfaces + +open: + mvi c,15 ! jmp bdos ; open file control block + +setdma: + mvi c,26 ! jmp bdos ; set data transfer address + +setmulti: + mvi c,44 ! jmp bdos ; set record count + +read: + mvi c,20 ! jmp bdos ; read records + + +signon$msg db 13,10,13,10,'CP/M Version 3.0, sample BIOS',13,10,0 + +ccp$msg db 13,10,'BIOS Err on A: No CCP.COM file',0 + + +ccp$fcb db 1,'CCP ','COM',0,0,0,0 + ds 16 +fcb$nr db 0,0,0 + +init$table db 3,p$zpio$3a,0CFh,0FFh,07h ; set up config port + db 3,p$zpio$3b,0CFh,000h,07h ; set up bank port + db 1,p$bank$select,0 ; select bank 0 + db 0 ; end of init$table + + end diff --git a/software/CPM/cpm3/callvers.asm b/software/CPM/cpm3/callvers.asm new file mode 100644 index 0000000..add253f --- /dev/null +++ b/software/CPM/cpm3/callvers.asm @@ -0,0 +1,28 @@ + ; CALLVERS program + +bdos equ 5 ; entry point for BDOS +prtstr equ 9 ; print string function +vers equ 12 ; get version function +cr equ 0dh ; carriage return +lf equ 0ah ; line feed + + org 100h + mvi d,5 ; Perform 5 times +loop: push d ; save counter + mvi c,prtstr + lxi d,call$msg ; print call message + call bdos + mvi c,vers + call bdos ; try to get version # + ; CALLVERS will intercept + mov a,l + sta curvers + pop d + dcr d ; decrement counter + jnz loop + mvi c,0 + jmp bdos +call$msg: + db cr,lf,'**** CALLVERS **** $' +curvers db 0 + end diff --git a/software/CPM/cpm3/ccp3.asm b/software/CPM/cpm3/ccp3.asm new file mode 100644 index 0000000..e905e79 --- /dev/null +++ b/software/CPM/cpm3/ccp3.asm @@ -0,0 +1,2841 @@ +title 'CP/M 3 - Console Command Processor - November 1982' +; version 3.00 Nov 30 1982 - Doug Huskey + + +; Copyright (C) 1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, CA 93950 + +; Revised: John Elliott, 25-5-1998, to include DRI patches and multiple +; error checking ability: +; +; If the sequence +; COMMAND +; :C1 +; :C2 +; +; was executed under DRI's CCP, and COMMAND returned an error, +; then C1 would not be executed but C2 would. Under this CCP +; C2 would not be. +; +; **************************************************** +; ***** The following equates must be set to 100H *** +; ***** + the addresses specified in LOADER.PRN *** +; ***** *** +equ1 equ rsxstart ;does this adr match loader's? +equ2 equ fixchain ;does this adr match loader's? +equ3 equ fixchain1 ;does this adr match loader's? +equ4 equ fixchain2 ;does this adr match loader's? +equ5 equ rsx$chain ;does this adr match loader's? +equ6 equ reloc ;does this adr match loader's? +equ7 equ calcdest ;does this adr match loader's? +equ8 equ scbaddr ;does this adr match loader's? +equ9 equ banked ;does this adr match loader's? +equ10 equ rsxend ;does this adr match loader's? +equ11 equ ccporg ;does this adr match loader's? +equ12 equ ccpend ;This should be 0D80h + rsxstart equ 0100h + fixchain equ 01D0h + fixchain1 equ 01EBh + fixchain2 equ 01F0h + rsx$chain equ 0200h + reloc equ 02CAh + calcdest equ 030Fh + scbaddr equ 038Dh + banked equ 038Fh + rsxend equ 0394h + ccporg equ 0401h ;[JCE] was 041Ah, but reduced + ; to incorporate patches +; **************************************************** +; NOTE: THE ABOVE EQUATES MUST BE CORRECTED IF NECESSARY +; AND THE JUMP TO START AT THE BEGINNING OF THE LOADER +; MUST BE SET TO THE ORIGIN ADDRESS BELOW: + + org ccporg ;LOADER is at 100H to 3??H + +; (BE SURE THAT THIS LEAVES ENOUGH ROOM FOR THE LOADER BIT MAP) + + +; Conditional Assembly toggles: + +true equ 0ffffh +false equ 0h +newdir equ true +newera equ true ;confirm any ambiguous file name +dayfile equ true +prompts equ false +func152 equ true +multi equ true ;multiple command lines + ;also shares code with loader (100-2??h) +; +;************************************************************************ +; +; GLOBAL EQUATES +; +;************************************************************************ +; +; +; CP/M BASE PAGE +; +wstart equ 0 ;warm start entry point +defdrv equ 4 ;default user & disk +bdos equ 5 ;CP/M BDOS entry point +osbase equ bdos+1 ;base of CP/M BDOS +cmdrv equ 050h ;command drive +dfcb equ 05ch ;1st default fcb +dufcb equ dfcb-1 ;1st default fcb user number +pass0 equ 051h ;1st default fcb password addr +len0 equ 053h ;1st default fcb password length +dfcb1 equ 06ch ;2nd default fcb +dufcb1 equ dfcb1-1 ;2nd default fcb user number +pass1 equ 054h ;2nd default fcb password addr +len1 equ 056h ;2nd default fcb password length +buf equ 80h ;default buffer +tpa equ 100h ;transient program area + if multi +comlen equ 100h-19h ;maximum size of multiple command + ;RSX buffer with 16 byte header & + ;terminating zero + else +comlen equ tpa-buf + endif +; +; BDOS FUNCTIONS +; +vers equ 31h ;BDOS vers 3.1 +cinf equ 1 ;console input +coutf equ 2 ;console output +crawf equ 6 ;raw console input +pbuff equ 9 ;print buffer to console +rbuff equ 10 ;read buffer from console +cstatf equ 11 ;console status +resetf equ 13 ;disk system reset +self equ 14 ;select drive +openf equ 15 ;open file +closef equ 16 ;close file +searf equ 17 ;search first +searnf equ 18 ;search next +delf equ 19 ;delete file +readf equ 20 ;read file +makef equ 22 ;make file +renf equ 23 ;rename file +dmaf equ 26 ;set DMA address +userf equ 32 ;set/get user number +rreadf equ 33 ;read file +flushf equ 48 ;flush buffers +scbf equ 49 ;set/get SCB value +loadf equ 59 ;program load +allocf equ 98 ;reset allocation vector +trunf equ 99 ;read file +parsef equ 152 ;parse file +; +; ASCII characters +; +ctrlc: equ 'C'-40h +cr: equ 'M'-40h +lf: equ 'J'-40h +tab: equ 'I'-40h +eof: equ 'Z'-40h +; +; +; RSX MEMORY MANAGEMENT EQUATES +; +; RSX header equates +; +entry equ 06h ;RSX contain jump to start +nextadd equ 0bh ;address of next RXS in chain +prevadd equ 0ch ;address of previous RSX in chain +warmflg equ 0eh ;remove on wboot flag +endchain equ 18h ;end of RSX chain flag +; +; LOADER.RSX equates +; +module equ 100h ;module address +; +; COM file header equates +; +comsize equ tpa+1h ;size of the COM file +rsxoff equ tpa+10h ;offset of the RSX in COM file +rsxlen equ tpa+12h ;length of the RSX +; +; +; SYSTEM CONTROL BLOCK OFFSETS +; +pag$off equ 09ch +; +olog equ pag$off-0ch ; removeable media open vector +rlog equ pag$off-0ah ; removeable media login vector +bdosbase equ pag$off-004h ; real BDOS entry point +hashl equ pag$off+000h ; system variable +hash equ pag$off+001h ; hash code +bdos$version equ pag$off+005h ; BDOS version number +util$flgs equ pag$off+006h ; utility flags +dspl$flgs equ pag$off+00ah ; display flags +clp$flgs equ pag$off+00eh ; CLP flags +clp$drv equ pag$off+00fh ; submit file drive +prog$ret$code equ pag$off+010h ; program return code +multi$rsx$pg equ pag$off+012h ; multiple command buffer page +ccpdrv equ pag$off+013h ; ccp default drive +ccpusr equ pag$off+014h ; ccp default user number +ccpconbuf equ pag$off+015h ; ccp console buffer address +ccpflag1 equ pag$off+017h ; ccp flags byte 1 +ccpflag2 equ pag$off+018h ; ccp flags byte 2 +ccpflag3 equ pag$off+019h ; ccp flags byte 3 +conwidth equ pag$off+01ah ; console width +concolumn equ pag$off+01bh ; console column position +conpage equ pag$off+01ch ; console page length (lines) +conline equ pag$off+01dh ; current console line number +conbuffer equ pag$off+01eh ; console input buffer address +conbuffl equ pag$off+020h ; console input buffer length +conin$rflg equ pag$off+022h ; console input redirection flag +conout$rflg equ pag$off+024h ; console output redirection flag +auxin$rflg equ pag$off+026h ; auxillary input redirection flag +auxout$rflg equ pag$off+028h ; auxillary output redirection flag +listout$rflg equ pag$off+02ah ; list output redirection flag +page$mode equ pag$off+02ch ; page mode flag 0=on, 0ffH=off +page$def equ pag$off+02dh ; page mode default +ctlh$act equ pag$off+02eh ; ctl-h active +rubout$act equ pag$off+02fh ; rubout active (boolean) +type$ahead equ pag$off+030h ; type ahead active +contran equ pag$off+031h ; console translation subroutine +con$mode equ pag$off+033h ; console mode (raw/cooked) +ten$buffer equ pag$off+035h ; 128 byte buffer available + ; to banked BIOS +outdelim equ pag$off+037h ; output delimiter +listcp equ pag$off+038h ; list output flag (ctl-p) +q$flag equ pag$off+039h ; queue flag for type ahead +scbad equ pag$off+03ah ; system control block address +dmaad equ pag$off+03ch ; dma address +seldsk equ pag$off+03eh ; current disk +info equ pag$off+03fh ; BDOS variable "info" +resel equ pag$off+041h ; disk reselect flag +relog equ pag$off+042h ; relog flag +fx equ pag$off+043h ; function number +usrcode equ pag$off+044h ; current user number +dcnt equ pag$off+045h ; directory record number +searcha equ pag$off+047h ; fcb address for searchn function +searchl equ pag$off+049h ; scan length for search functions +multcnt equ pag$off+04ah ; multi-sector I/O count +errormode equ pag$off+04bh ; BDOS error mode +drv0 equ pag$off+04ch ; search chain - 1st drive +drv1 equ pag$off+04dh ; search chain - 2nd drive +drv2 equ pag$off+04eh ; search chain - 3rd drive +drv3 equ pag$off+04fh ; search chain - 4th drive +tempdrv equ pag$off+050h ; temporary file drive +patch$flag equ pag$off+051h ; patch flags +date equ pag$off+058h ; date stamp +com$base equ pag$off+05dh ; common memory base address +error equ pag$off+05fh ; error jump...all BDOS errors +top$tpa equ pag$off+062h ; top of user TPA (address at 6,7) +; +; CCP FLAG 1 BIT MASKS +; (used with getflg, setflg and resetflg routines) +; +chainflg equ 080h ; program chain (funct 49) +not$chainflg equ 03fh ; mask to reset chain flags +chainenv equ 040h ; preserve usr/drv for chained prog +comredirect equ 0b320h ; command line redirection active +menu equ 0b310h ; execute ccp.ovl for menu systems +echo equ 0b308h ; echo commands in batch mode +userparse equ 0b304h ; parse user numbers in commands +subfile equ 0b301h ; $$$.SUB file found or active +subfilemask equ subfile-0b300h +rsx$only$set equ 02h ; RSX only load (null COM file) +rsx$only$clr equ 0FDh ; reset RSX only flag +; +; CCP FLAG 2 BIT MASKS +; (used with getflg, setflg and resetflg routines) +; +ccp10 equ 0b4a0h ; CCP function 10 call (2 bits) +ccpsub equ 0b420h ; CCP present (for SUBMIT, PUT, GET) +ccpbdos equ 0b480h ; CCP present (for BDOS buffer save) +dskreset equ 20h ; CCP does disk reset on ^C from prompt +submit equ 0b440h ; input redirection active +submitflg equ 40h ; input redirection flag value +order equ 0b418h ; command order + ; 0 - COM only + ; 1 - COM,SUB + ; 2 - SUB,COM + ; 3 - reserved +datetime equ 0b404h ; display date & time of load +display equ 0b403h ; display filename & user/drive +filename equ 02h ; display filename loaded +location equ 01h ; display user & drive loaded from + +; +; CCP FLAG 3 BIT MASKS +; (used with getflg, setflg and resetflg routines) +; +rsxload equ 1h ; load RSX, don't fix chain +coldboot equ 2h ; try to exec profile.sub +; +; CONMODE BIT MASKS +; +ctlc$stat equ 0cf01h ;conmode CTL-C status + +; +; +;************************************************************************ +; +; Console Command Processor - Main Program +; +;************************************************************************ +; +; +; +start: +; + lxi sp,stack + lxi h,ccpret ;push CCPRET on stack, in case of + push h ; profile error we will go there + lxi d,scbadd + mvi c,scbf + call bdos + shld scbaddr ;save SCB address + mvi l,com$base+1 + mov a,m ;high byte of commonbase + sta banked ;save in loader + mvi l,bdosbase+1 ;HL addresses real BDOS page + mov a,m ;BDOS base in H + sta realdos ;save it for use in XCOM routine +; + lda osbase+1 ;is the LOADER in memory? + sub m ;compare link at 6 with real BDOS + jnz reset$alloc ;skip move if loader already present +; +; +movldr: + lxi b,rsxend-rsxstart ;length of loader RSX + call calcdest ;calculate destination and (bias+200h) + mov h,e ;set to zero + mov l,e +; lxi h,module-100h ;base of loader RSX (less 100h) + call reloc ;relocate loader + lhld osbase ;HL = BDOS entry, DE = LOADER base + mov l,e ;set L=0 + mvi c,6 + call move ;move the serial number down + mvi e,nextadd + call fixchain1 +; +; +reset$alloc: + mvi c,allocf + call bdos +; +; +; +;************************************************************************ +; +; INITIALIZE SYSTEM CONTROL BLOCK +; +;************************************************************************ +; +; +scbinit: + ; + ; # dir columns, page size & function 9 delimiter + ; + mvi b,conwidth + call getbyte + inr a ;get console width (rel 1) + rrc + rrc + rrc + rrc + ani 0fh ;divide by 16 + lxi d,dircols + stax d ;dircols = conwidth/16 + mvi l,conpage + mov a,m + dcr a ;subtract 1 for space before prompt + inx d + stax d ;pgsize = conpage + xra a + inx d + stax d ;line=0 + mvi a,'$' + inx d + stax d ;pgmode = nopage (>0) + mvi l,outdelim + mov m,a ;set function 9 delimiter + ; + ; multisector count, error mode, console mode + ; & BDOS version no. + ; + mvi l,multcnt + mvi m,1 ;set multisector I/O count = 1 + inx h ;.errormode + xra a + mov m,a ;set return error mode = 0 + mvi l,con$mode + mvi m,1 ;set ^C status mode + inx h + mov m,a ;zero 2nd conmode byte + mvi l,bdos$version + mvi m,vers ;set BDOS version no. + ; + ; disk reset check + ; + mvi l,ccpflag2 + mov a,m + ani dskreset ;^C at CCP prompt? + mvi c,resetf + push h + cnz bdos ;perform disk reset if so + pop h + ; + ; remove temporary RSXs (those with remove flag on) + ; +rsxck: + mvi l,ccpflag1 ;check CCP flag for RSX only load + mov a,m + ani rsx$only$set ;bit = 1 if only RSX has been loaded + push h + cz rsx$chain ;don't fix-up RSX chain if so + pop h + mov a,m + ani rsx$only$clr ;clear RSX only loader flag + mov m,a ;replace it + ; + ; chaining environment + ; + ani chain$env ;non-zero if we preserve programs + push h ;user & drive for next transient + ; + ; user number + ; + mvi l,ccpusr ; HL = .CCP USER (saved in SCB) + lxi b,usernum ; BC = .CCP'S DEFAULT USER + mov d,h + mvi e,usrcode ; DE = .BDOS USER CODE + ldax d + stax b ; usernum = bdos user number + mov a,m ; ccp user + jnz scb1 ; jump if chaining env preserved + stax b ; usernum = ccp default user +scb1: stax d ; bdos user = ccp default user + ; + ; transient program's current disk + ; + inx b ;.CHAINDSK + mvi e,seldsk ;.BDOS CURRENT DISK + ldax d + jnz scb2 ; jump if chaining env preserved + mvi a,0ffh +; cma ; make an invalid disk +scb2: stax b ; chaindsk = bdos disk (or invalid) + ; + ; current disk + ; + dcx h ;.CCP's DISK (saved in SCB) + inx b ;.CCP's CURRENT DISK + mov a,m + stax b + stax d ; BDOS current disk + ; + ; $$$.SUB drive + ; + mvi l,tempdrv + inx b ;.SUBFCB + mov a,m + stax b ; $$$.SUB drive = temporary drive + ; + ; check for program chain + ; + pop h ;HL =.ccpflag1 + mov a,m + ani chainflg ;is it a chain function (47) + jz ckboot ;jump if not + lxi h,buf +chain: lxi d,cbufl + mvi c,tpa-buf-1 + mov a,c + stax d + inx d + call move ;hl = source, de = dest, c = count + jmp ccpparse + ; + ; execute profile.sub ? + ; +ckboot: mvi l,ccpflag3 + mov a,m + ani coldboot ;is this a cold start + jnz ccpcr ;jump if not + mov a,m + ori coldboot ;set flag for next time + mov m,a + sta errflg ;set to ignore errors + lxi h,profile + jmp chain ;attempt to exec profile.sub +profile: + db 'PROFILE.S',0 +; +; +; +;************************************************************************ +; +; BUILT-IN COMMANDS (and errors) RETURN HERE +; +;************************************************************************ +; +; +ccpcr: + ; enter here on each command or error condition + call setccpflg + call crlf +ccpret: + lxi h,stack-2 ;reset stack in case of error + sphl ;preserve CCPRET on stack + xra a + sta line + lxi h,ccpret ;return for next builtin + push h + call setccpflg + dcx h ;.CCPFLAG1 + mov a,m + ani subfilemask ;check for $$$.SUB submit + jz prompt +; +; +; +;************************************************************************ +; +; $$$.SUB file processing +; +;************************************************************************ +; +; + lxi d,cbufl ;set DMA to command buffer + call setbuf + mvi c,openf + call sudos ;open it if flag on + mvi c,cstatf ;check for break if successful open + cz sudos ;^C typed? + jnz subclose ;delete $$$.SUB if break or open failed + lxi h,subrr2 + mov m,a ;zero high random record # + dcx h + mov m,a ;zero middle random record # + dcx h + push h + lda subrc + dcr a + mov m,a ;set to read last record of file + mvi c,rreadf + cp sudos + pop h + dcr m ;record count (truncate last record) + mvi c,delf + cm sudos + ora a ;error on read? + ; + ; +subclose: + push psw + mvi c,trunf ;truncate file (& close it) + call sudos + pop psw ;any errors ? + jz ccpparse ;parse command if not + ; + ; +subkill: + lxi b,subfile + call resetflg ;turn off submit flag + mvi c,delf + call sudos ;kill submit +; +; +; +;************************************************************************ +; +; GET NEXT COMMAND +; +;************************************************************************ +; +; + ; + ; prompt user + ; +prompt: + lda usernum + ora a + cnz pdb ;print user # if non-zero + call dirdrv1 +; +; [JCE] Allow Named Directory extensions to print their names +; + lxi d,rsxpb ;3 bytes + mvi c,3Ch ;2 bytes + call bdos ;3 bytes +; + mvi a,'>' + call putc + ; + if multi + ;move ccpconbuf addr to conbuffer addr + lxi d,ccpconbuf*256+conbuffer + call wordmov ;process multiple command, unless in submit + ora a ;non-zero => multiple commands active + push psw ;save A=high byte of ccpconbuf + lxi b,ccpbdos + cnz resetflg ;turn off BDOS flag if multiple commands + endif ;multi + call rcln ;get command line from console + call resetccpflg ;turn off BDOS, SUBMIT & GET ccp flags + if multi + pop psw ;D=high byte of ccpconbuf + cnz multisave ;save multiple command buffer + endif ;multi +; +; +; +;************************************************************************ +; +; PARSE COMMAND +; +;************************************************************************ +; +; +ccpparse: + ; + ; reset default page mode + ; (in case submit terminated) + ; + call subtest ;non-zero if submit is active + jnz get$pg$mode ;skip, if so +set$pg$mode: + mvi l,page$def + mov a,m ;pick up default + dcx h + mov m,a ;place in mode +get$pg$mode: + mvi l,page$mode + mov a,m + sta pgmode + ; + ;check for multiple commands + ;convert to upper case + ;reset ccp flag, in case entered from a CHAIN (or profile) + ; + call uc ;convert to upper case, ck if multiple command + rz ;get another line if null or comment + ; + ;transient or built-in command? + ; + lxi d,ufcb ;include user number byte in front of FCB + call gcmd ;parse command name + lda fcb+9 ;file type specified? + cpi ' ' + jnz ccpdisk2 ;execute from disk, if so + lxi h,ufcb ;user or drive specified? + mov a,m ;user number + inx h + ora m ;drive + inx h + mov a,m ;get 1st character of filename + jnz ccpdisk3 ;jump if so + ; + ;BUILT-IN HANDLER + ; +ccpbuiltin: + lxi h,ctbl ;search table of internal commands + lxi d,fcb+1 + lda fcb+3 + cpi ' '+1 ;is it shorter that 3 characters? + cnc tbls ;is it a built-in? + jnz ccpdisk0 ;load from disk if not + lda option ;[ in command line? + ora a ;options specified? + mov a,b ;built-in index from tbls + lhld parsep + shld errsav ;save beginning of command tail + lxi h,ptbl ;jump to processor if options not + jz tblj ;specified + cpi 4 + jc trycom + lxi h,fcb+4 + jnz ccpdisk0 ;if DIRS then look for DIR.COM + mvi m,' ' + ; + ;LOAD TRANSIENT (file type unspecified) + ; +ccpdisk0: + lxi b,order + call getflg ;0=COM 8=COM,SUB 16=SUB,COM + jz ccpdisk2 ;search for COM file only + mvi b,8 ;=> 2nd choice is SUB + sub b ;now a=0 (COM first) or 8 (SUB first) + jz ccpdisk1 ;search for COM first then SUB + mvi b,0 ;search for SUB first then COM + +ccpdisk1: + push b ;save 2nd type to try + call settype ; A = offset of type in type table + call exec ;try to execute, return if unsuccessful + pop psw ;try 2nd type + call settype + ; + ;LOAD TRANSIENT (file type specified) + ; +ccpdisk2: + call exec + jmp perror ;error if can't find it + ; + ;DRIVE SPECIFIED (check for change drives/users command) + ; +ccpdisk3: + cpi ' ' ;check for filename + jnz ccpdisk0 ;execute from disk if specified + call eoc ;error if not end of command + lda ufcb ;user specified? + sui 1 + jc ccpdrive + +ccpuser: + sta usernum ;CCP's user number + mvi b,ccpusr + call setbyte ;save it in SCB + call setuser ;set current user + +ccpdrive: + lda fcb ;drive specified? + dcr a + rm ;return if not + push psw + call select + pop psw + sta disk ;CCP's drive + mvi b,ccpdrv + jmp setbyte ;save it in SCB + +;; +; +;************************************************************************ +; +; BUILT-IN COMMANDS +; +;************************************************************************ +; +; +; Table of internal ccp commands +; +; +ctbl: db 'DIR ' + db 'TYPE ' + db 'ERASE ' + db 'RENAME ' + db 'DIRSYS ' + db 'USER ' + db 0 +; +ptbl: dw dir + dw type + dw era + dw ren + dw dirs + dw user +;; +;;----------------------------------------------------------------------- +;; +;; DIR Command +;; +;; DIR list directory of current default user/drive +;; DIR : list directory of user/drive +;; DIR list all files on the current default user/drive +;; with names that match +;; DIR : list all files on user/drive with names that +;; match +;; +;;----------------------------------------------------------------------- +;; +; + if newdir +dirdrv: + lda dfcb ;get disk number + endif ;newdir + +dirdrv0: + dcr a + jp dirdrv2 + +dirdrv1: + lda disk ;get current disk +dirdrv2: + adi 'A' + jmp pfc ;print it (save BC,DE) +; +; + if newdir +dir: + mvi c,0 ;flag for DIR (normal) + lxi d,sysfiles + jmp dirs1 +; +; +dirs: + mvi c,080h ;flag for DIRS (system) + lxi d,dirfiles + +dirs1: push d +; [JCE] Patch 15 + xra a ;Reset "anyfiles" before starting + sta anyfiles ; - it might not have been cleared + call direct + pop d ;de = .system files message + jz nofile ;jump if no files found + mov a,l ;A = number of columns + cmp b ;did we print any files? + cnc crlf ;print crlf if so + lxi h,anyfiles + dcr m + inr m + rz ;return if no files + ;except those requested + dcr m ;set to zero + jmp pmsgnl ;tell the operator other files exist +; +; +direct: + push b ;save DIR/DIRS flag + call sbuf80 ;set DMA = 80h + call gfn ;parse file name + lxi d,dfcb+1 + ldax d + cpi ' ' + mvi b,11 + cz setmatch ;use "????????.???" if none + call eoc ;make sure there's nothing else + call srchf ;search for first directory entry + pop b + rz ;if no files found +dir0: + lda dircols ;number of columns for dir + mov l,a + mov b,a + inr b ;set # names to print per line (+1) +dir1: + push h ;L=#cols, B=curent col, C=dir/dirs + lxi h,10 ;get byte with SYS bit + dad d + mov a,m + pop h + ani 80h ;look at SYS bit + cmp c ;DIR/DIRS flag in C + jz dir2 ;display, if modes agree + mvi a,1 ;set anyfiles true + sta anyfiles + jmp dir3 ;don't print anything +; +; display the filename +; +dir2: + dcr b + cz dirln ;sets no. of columns, puts crlf + mov a,b ;number left to print on line + cmp l ;is current col = number of cols + cz dirdrv ;display the drive, if so + mvi a,':' + call pfc ;print colon + call space + call pfn ;print file name + call space ;pad with space +dir3: + push b ;save current col(B), DIR/DIRS(C) + push h ;save number of columns(L) + call break ;drop out if keyboard struck + call srchn ;search for another match + pop h + pop b + jnz dir1 +direx: + inr a ;clear zero flag + ret + + else ;newdir + +dirs: ; display system files only + mvi a,0d2h ; JNC instruction + sta dir11 ; skip on non-system files +; +dir: ; display non-system files only + lxi h,ccpcr + push h ; push return address + call gfn ;parse file name + inx d + ldax d + cpi ' ' + mvi b,11 + cz setmatch ;use "????????.???" if none + call eoc ;make sure there's nothing else + call findone ;search for first directory entry + jz dir4 + mvi b,5 ;set # names to print per line +dir1: lxi h,10 ;get byte with SYS bit + dad d + mov a,m + ral ;look at SYS bit +dir11: jc dir3 ;don't print it if SYS bit set + mov a,b + push b +dir2: lxi h,9 ;get byte with R/O bit + dad d + mov a,m + ral ;look at R/O bit + mvi a,' ' ;print space if not R/O + jnc dir21 ;jump if not R/O + mvi a,'*' ;print star if R/O +dir21: call pfc ;print character + call pfn ;print file name + mvi a,13 ;figure out how much padding is needed + sub c +dir25: push psw + call space ;pad it out with spaces + pop psw + dcr a + jnz dir25 ;loop if more required + pop b + dcr b ;decrement # names left on line + jnz dir3 + call crlf ;go to new line + mvi b,5 ;set # names to print on new line +dir3: push b + call break ;drop out if keyboard struck + call srchn ;search for another match + pop b + jnz dir1 + +dir4: mvi a,0dah ;JC instruction + sta dir11 ;restore normal dir mode (skip system files) + jmp ccpcr + + endif ;newdir + +;; +;;----------------------------------------------------------------------- +;; +;; TYPE command +;; +;; TYPE Print the contents of text file on +;; the console. +;; +;;----------------------------------------------------------------------- +;; +type: lxi h,ccpcr + push h ;push return address + call getfn ;get and parse filename + mvi a,127 ;initialize buffer pointer + sta bufp + mvi c,openf + call sbdosf ;open file if a filename was typed +type1: call break ;exit if keyboard struck + call getb ;read byte from file + rnz ;exit if physical eof or read error + cpi eof ;check for eof character + rz ;exit if so + call putc ;print character on console + jmp type1 ;loop +; +;;----------------------------------------------------------------------- +;; +;; USER command +;; +;; USER Set the user number +;; +;;----------------------------------------------------------------------- +;; +user: + lxi d,unmsg ;Enter User #: + call getprm + call gdn ;convert to binary + rz ;return if nothing typed + jmp ccpuser ;set user number +; +;;----------------------------------------------------------------------- +;; +;; ERA command +;; +;; ERA Erase all file on the current user/drive +;; which match . +;; ERA : Erase all files on user/drive which +;; match . +;; +;;----------------------------------------------------------------------- +;; +era: call getfn ;get and parse filename + jz era1 + call ckafn ;is it ambiguous? + jnz era1 + lxi d,eramsg + call pmsg + lhld errorp + mvi c,' ' ;stop at exclamation mark or 0 + call pstrg ;echo command + lxi d,confirm + call getc + call crlf + mov a,l ;character in L after CRLF routine + ani 5fh ;convert to U/C + cpi 'Y' ;Y (yes) typed? + rnz ;return, if not + ora a ;reset zero flag +era1: mvi c,delf + jmp sbdosf + +;;----------------------------------------------------------------------- +;; +;; +;; REN command +;; +;;----------------------------------------------------------------------- +;; +ren: call gfn ;zero flag set if nothing entered + push psw + lxi h,16 + dad d + xchg + push d ;DE = .dfcb+16 + push h ;HL = .dfcb + mvi c,16 + call move ;DE = dest, HL = source + call gfn + pop h ;HL=.dfcb + pop d ;DE=.dfcb+16 + call drvok + mvi c,renf ;make rename call + pop psw ;zero flag set if nothing entered +; +;;----------------------------------------------------------------------- +;; +;; BUILT-IN COMMAND BDOS CALL & ERROR HANDLERS +;; +;;----------------------------------------------------------------------- +; +sbdosf: + push psw + cnz eoc ;make sure there's nothing else + pop psw + lxi d,dfcb + mvi b,0ffh + mvi h,1 ;execute disk command if we don't call + cnz bdosf ;call if something was entered + rnz ;return if successful + +ferror: + dcr h ;was it an extended error? + jm nofile + lhld errsav + shld parsep +trycom: call exec + call pfn + lxi d,required + jmp builtin$err +; +;;----------------------------------------------------------------------- +; +; +; check for drive conflict +; HL = FCB +; DE = FCB+16 +; +drvok: ldax d ;get byte from 2nd fcb + cmp m ;ok if they match + rz + ora a ;ok if 2nd is 0 + rz + inr m ;error if the 1st one's not 0 + dcr m + jnz perror + mov m,a ;copy from 2nd to 1st + ret +;;----------------------------------------------------------------------- +;; +;; check for ambiguous reference in file name/type +;; +;; entry: b = length of string to check (ckafn0) +;; de = fcb area to check (ckafn0) - 1 +;; exit: z = set if any ? in file reference (ambiguous) +;; z = clear if unambiguous file reference +;; +ckafn: + mvi b,11 ;check entire name and type +ckafn0: inx d + ldax d + cpi '?' ;is it an ambiguous file name +if newera + rz ;return true if any afn +else ;newera + rnz ;return true only if *.* +endif ;newera + dcr b + jnz ckafn0 +if newera + dcr b ;clear zero flag to return false +endif ;newera + ret ;remove above DCR to return true +;; +;;----------------------------------------------------------------------- +;; +;; get parameter (generally used to get a missing one) +;; +getprm: + call skps ;see if already there + rnz ;return if so +getp0: + if prompts + push d + lxi d,enter + call pmsg + pop d + endif + call pmsg ;print prompt + call rcln ;get response + jmp uc ;convert to upper case +; +;; +;;----------------------------------------------------------------------- + if not newdir +;; +;; search for first file, print "No File" if none +;; +findone: + call srchf + rnz ;found + endif ;not newdir +;;----------------------------------------------------------------------- + +nofile: + lxi d,nomsg ;tell user no file found +builtin$err: + call pmsgnl + jmp ccpret + +; +; +;************************************************************************ +; +; EXECUTE DISK RESIDENT COMMAND +; +;************************************************************************ +; +; +xfcb: db 0,'SUBMIT COM' ;processor fcb +; +; +; execute submit file (or any other processor) +; +xsub: ;DE = .fcb + ldax d + mvi b,clp$drv + call setbyte ;save submit file drive + lxi h,xfcb + mvi c,12 + call move ;copy processor into fcb + lxi h,cbufl ;set parser pointer back to beginning + mvi m,' ' + inx h ;move past blank + shld parsep +; execute SUBMIT.COM +; +; +; execute disk resident command (return if not found or error) +; +exec: + ;try to open and execute fcb + lxi d,fcb+9 + lxi h,typtbl + call tbls ;search for type in type table + rnz ;return if no match + lxi d,ufcb + ldax d ;check to see if user specified + ora a + rnz ;return if so + inx d + ldax d ;check if drive specified + mov c,a + push b ;save type (B) and drive (C) + mvi c,0 ;try only 1 open if drive specified + ora a + jnz exec1 ;try to open as specified + lxi b,(drv0-1)*256+4;try upto four opens from drv chain + lda disk + inr a + mov h,a ;save default disk in H + mvi l,1 ;allow only 1 match to default disk +exec0: inr b ;next drive to try in SCB drv chain + dcr c ;any more tries? + mov a,c + push h + cp getbyte + pop h + ora a + jm exec3 + jz exec01 ;jump if drive is 0 (default drive) + cmp h ;is it the default drive + jnz exec02 ;jump if not +exec01: mov a,h ;set drive explicitly + dcr l ;is it the 2nd reference + jm exec0 ;skip, if so +exec02: stax d ;put drive in FCB +exec1: push b ;save drive offset(B) & count(C) + push h + call opencom ;on default drive & user + pop h + pop b + jz exec0 ;try next if open unsuccessful +; +; successful open, now jump to processor +; +exec2: + if dayfile + lxi b,display + call getflg + jz exec21 + ldax d + call dirdrv0 + mvi a,':' + call pfc + push d + call pfn + pop d + push d + lxi h,8 + dad d + mov a,m + ani 80h + lxi d,userzero + cnz pmsg + call crlf + pop d + endif ;dayfile +exec21: pop psw ;recover saved command type + lxi h,xptbl +; +; table jump +; +; entry: hl = address of table of addresses +; a = entry # (0 thru n-1) +; +tblj: add a ;adjust for two byte entries + call addhla ;compute address of entry + push d + mov e,m ;fetch entry + inx h + mov d,m + xchg + pop d + pchl ;jump to it +; +typtbl: db 'COM ' + db 'SUB ' + db 'PRL ' + db 0 +; +xptbl: dw xcom + dw xsub + dw xcom + + +; +; unsuccessful attempt to open command file +; +exec3: pop b ;recover drive + mov a,c + stax d ;replace in fcb + ret +; +; +settype: + ;set file type specified from type table + ;a = offset (x2) of desired type (in bytes) + rrc + lxi h,typtbl + call addhla ;hl = type in type table + lxi d,fcb+9 + mvi c,3 + jmp move ;move type into fcb +; +; +; +; EXECUTE COM FILE +; +xcom: ;DE = .fcb + ; + ; set up FCB for loader to use + ; + lxi h,tpa + shld fcbrr ;set load address to 100h + lhld realdos-1 ;put fcb in the loader's stack + dcr h ;page below LOADER (or bottom RSX) + mvi l,0C0h ;offset for FCB in page below the BDOS + push h ;save for LOADER call + ldax d ;get drive from fcb(0) + sta cmdrv ;set command drive field in base page + xchg + mvi c,35 + call move ;now move FCB to the top of the TPA + ; + ; set up base page + ; + lxi h,errflg ;tell parser to ignore errors + inr m +xcom3: lhld parsep + dcx h ;backup over delimiter + lxi d,buf+1 + xchg + shld parsep ;set parser to 81h + call copy0 ;copy command tail to 81h with + ;terminating 0 (returns A=length) + sta buf ;put command tail length at 80h +xcom5: call gfn ;parse off first argument + shld pass0 + mov a,b + sta len0 + lxi d,dfcb1 + call gfn0 ;parse off second argument + shld pass1 + mov a,b + sta len1 +xcom7: lxi h,chaindsk ;.CHAINDSK + mov a,m + ora a + cp select + lda usernum + call setuser ;set default user, returns H=SCB + add a ;shift user to high nibble + add a + add a + add a + mvi l,seldsk + ora m ;put disk in low nibble + sta defdrv ;set location 4 + ; + ; initialize stack + ; +xcom8: pop d ;DE = .fcb + lhld realdos-1 ;base page of BDOS + xra a + mov l,a ;top of stack below BDOS + sphl ;change the stack pointer for CCP + mov h,a ;push warm start address on stack + push h ;for programs returning to the CCP + inr h ;Loader will return to TPA + push h ;after loading a transient program + ; + ; initialize fcb0(CR), console mode, program return code + ; & removable media open and login vectors + ; +xcom9: sta 7ch ;clear next record to read + mvi b,con$mode + call setbyte ;set to zero (turn off ^C status) + mvi l,olog + mov m,a ;zero removable open login vector + inx h + mov m,a + inx h + mov m,a ;zero removable media login vector + inx h + mov m,a + mvi l,ccpflag1 + mov a,m + ani chain$flg ;chaining? + jnz loader ;load program without clearing + mvi l,prog$ret$code ;the program return code + mov m,a ;A=0 + inx h + mov m,a ;set program return = 0000h + ; + ; call loader + ; +loader: + mov a,m ;reset chain flag if set, + ani not$chainflg ;has no effect if we fell through + mov m,a + mvi c,loadf ;use load RSX to load file + jmp bdos ;now load it +; +; +; +; +;************************************************************************ +; +; BDOS FUNCTION INTERFACE - Non FCB functions +; +;************************************************************************ +; +; +; +;;----------------------------------------------------------------------- +;; +;; +;; +;; print character on terminal +;; pause if screen is full +;; (BDOS function #2) +;; +;; entry: a = character (putc entry) +;; e = character (putc2 entry) +;; + +putc: cpi lf ;end of line? + jnz putc1 ;jump if not + lxi h,pgsize ;.pgsize + mov a,m ;check page size + inx h ;.line + inr m ;line=line+1 + sub m ;line=page? + jnz putc0 + mov m,a ;reset line=0 if so + inx h ;.pgmode + mov a,m ;is page mode off? + ora a ;page=0 if so + lxi d,more + cz getc ;wait for input if page mode on + cpi ctrlc + jz ccpcr + mvi e,cr + call putc2 ;print a cr +putc0: mvi a,lf ;print the end of line char +putc1: mov e,a +putc2: mvi c,coutf + jmp bdos + +;; +;;----------------------------------------------------------------------- +;; +;; get character from console +;; (BDOS function #1) +;; +getc: call pmsg +getc1: mvi c,cinf + jmp bdos +;; +;;----------------------------------------------------------------------- +;; +;; print message string on terminal +;; (BDOS function #9) +;; +pmsg: mvi c,pbuff + jmp bdos +;; +;;----------------------------------------------------------------------- +;; +;; read line from console +;; (calls BDOS function #10) +;; +;; exit: z = set if null line +;; +;; This function uses the buffer "cbuf" (see definition of +;; function 10 for a description of the buffer). All input +;; is converted to upper case after reading and the pointer +;; "parsep" is set to the begining of the first non-white +;; character string. +;; +rcln: lxi h,cbufmx ;get line from terminal + mvi m,comlen ;set maximum buffer size + xchg + mvi c,rbuff + call bdos + lxi h,cbufl ;terminate line with zero byte + mov a,m + inx h + call addhla + mvi m,0 ;put zero at the end + jmp crlf ;advance to next line +; +;; +;;----------------------------------------------------------------------- +;; +;; exit routine if keyboard struck +;; (calls BDOS function #11) +;; +;; Control is returned to the caller unless the console +;; keyboard has a character ready, in which case control +;; is transfer to the main program of the CCP. +;; +break: call break1 + rz + jmp ccpcr + +break1: mvi c,cstatf + call rw + rz + mvi c,cinf + jmp rw + + +;; +;;----------------------------------------------------------------------- +;; +;; set disk buffer address +;; (BDOS function #26) +;; +;; entry: de -> buffer ("setbuf" only) +;; +sbuf80: lxi d,buf +setbuf: mvi c,dmaf + jmp bdos +;; +;;----------------------------------------------------------------------- +;; +;; select disk +;; (BDOS function #14) +;; +;; entry: a = drive +;; +select: + mov e,a + mvi c,self + jmp bdos +; +;; +;;----------------------------------------------------------------------- +;; +;; set user number +;; (BDOS function #32) +;; +;; entry: a = user # +;; exit: H = SCB page +;; +setuser: + mvi b,usrcode + jmp set$byte +; +; +; +;************************************************************************ +; +; BDOS FUNCTION INTERFACE - Functions with a FCB Parameter +; +;************************************************************************ +; +; +;; +;; open file +;; (BDOS function #15) +;; +;; exit: z = set if file not found +;; +;; +opencom: ;open command file (SUB, COM or PRL) + lxi b,openf ;b=0 => return error mode of 0 + lxi d,fcb ;use internal FCB + +;; BDOS CALL ENTRY POINT (used by built-ins) +;; +;; entry: b = return error mode (must be 0 or 0ffh) +;; c = function no. +;; de = .fcb +;; exit: z = set if error +;; de = .fcb +;; +bdosf: lxi h,32 ;offset to current record + dad d ;HL = .current record + mvi m,0 ;set to zero for read/write + push b ;save function(C) & error mode(B) + push d ;save .fcb + ldax d ;was a disk specified? + ana b ;and with 0 or 0ffh + dcr a ;if so, select it in case + cp select ;of permanent error (if errmode = 0ffh) + lxi d,passwd + call setbuf ;set dma to password + pop d ;restore .fcb + pop b ;restore function(C) & error mode(B) + push d + lhld scbaddr + mvi l,errormode + mov m,b ;set error mode + push h ;save .errormode + call bdos + pop d ;.errormode + xra a + stax d ;reset error mode to 0 + lda disk + mvi e,seldsk + stax d ;reset current disk to default + push h ;save bdos return values + call sbuf80 + pop h ;bdos return + inr l ;set z flag if error + pop d ;restore .fcb + ret +;; +;;----------------------------------------------------------------------- +;; +;; close file +;; (BDOS function #16) +;; +;; exit: z = set if close error +;; +;;close: mvi c,closef +;; jmp oc +;; +;;----------------------------------------------------------------------- +;; +;; delete file +;; +;; exit: z = set if file not found +;; +;; The match any character "?" may be used without restriction +;; for this function. All matched files will be deleted. +;; +;; +;;delete: +;; mvi c,delf +;; jmp oc +;; +;;----------------------------------------------------------------------- +;; +;; create file +;; (BDOS function #22) +;; +;; exit: z = set if create error +;; +;;make: mvi c,makef +;; jmp oc +;;----------------------------------------------------------------------- +;; +;; search for first filename match (using "DFCB" and "BUF") +;; (BDOS function #17) +;; +;; exit: z = set if no match found +;; z = clear if match found +;; de -> directory entry in buffer +;; +srchf: mvi c,searf ;set search first function + jmp srch +;; +;;----------------------------------------------------------------------- +;; +;; search for next filename match (using "DFCB" and "BUF") +;; (BDOS function #18) +;; +;; exit: z = set if no match found +;; z = clear if match found +;; de -> directory entry in buffer +;; +srchn: mvi c,searnf ;set search next function +srch: lxi d,dfcb ;use default fcb + call bdos + inr a ;return if not found + rz + dcr a ;restore original return value + add a ;shift to compute buffer pos'n + add a + add a + add a + add a + lxi h,buf ;add to buffer start address + call addhla + xchg ;de -> entry in buffer + xra a ;may be needed to clear z flag + dcr a ;depending of value of "buf" + ret +;; +;;----------------------------------------------------------------------- +;; +;; read file +;; (BDOS function #20) +;; +;; entry: hl = buffer address (readb only) +;; exit z = set if read ok +;; +read: xra a ;clear getc pointer + sta bufp + mvi c,readf + lxi d,dfcb +rw: call bdos + ora a + ret +; +;; +;;----------------------------------------------------------------------- +;; +;; $$$.SUB interface +;; +;; entry: c = bdos function number +;; exit z = set if successful + +sudos: lxi d,subfcb + jmp rw +; +; +; +;************************************************************************ +; +; COMMAND LINE PARSING SUBROUTINES +; +;************************************************************************ +; +;------------------------------------------------------------------------ +; +; COMMAND LINE PREPARSER +; reset function 10 flag +; set up parser +; convert to upper case +; +; All input is converted to upper case and the pointer +; "parsep" is set to the begining of the first non-blank +; character string. If the line begins with a ; or :, it +; is treated specially: +; +; ; comment the line is ignored +; : conditional the line is ignored if a fatal +; error occured during the previous +; command, otherwise the : is +; ignored +; +; An exclamation point is used to separate multiple commands on a +; a line. Two adjacent exclaimation points translates into a single +; exclaimation point in the command tail for compatibility. +;------------------------------------------------------------------------ +; +; +uc: + call resetccpflg + xchg ;DE = .SCB + xra a + sta option ;zero option flag + lxi h,cbuf + call skps1 ;skip leading spaces/tabs + xchg + cpi ';' ;HL = .scb + rz + cpi '!' + jz uc0 + cpi ':' + jnz uc1 +; +;[JCE] this fragment rewritten not to trash the program return code when +; reading it. +; + mvi l,prog$ret$code + mov a,m ;[JCE] + inr a ;[JCE] + inr a ;[JCE] +;;; inr m +;;; inr m ;was ^C typed? (low byte 0FEh) + jz uc0 ;successful, if so + inx h + mov a,m ;[JCE] + inr a ;[JCE] +;;; inr m ;is high byte 0FFh? + rz ;skip command, if so +uc0: inx d ;skip over 1st character +uc1: xchg ;HL=.command line + shld parsep ;set parse pointer to beginning of line +uc3: mov a,m ;convert lower case to upper + cpi '[' + jnz uc4 + sta option ;'[' is the option delimiter => command option +uc4: cpi 'a' + jc uc5 + cpi 'z'+1 + jnc uc5 + sui 'a'-'A' + mov m,a +uc5: + if multi + cpi '!' + cz multistart ;HL=.char, A=char + endif ;multi + inx h ;advance to next character + ora a ;loop if not end of line + jnz uc3 +; +; skip spaces +; return with zero flag set if end of line +; +skps: lhld parsep ;get current position +skps1: shld parsep ;save position + shld errorp ;save position for error message + mov a,m + ora a ;return if end of command + rz + cpi ' ' + jz skps2 + cpi tab ;skip spaces & tabs + rnz +skps2: inx h ;advance past space/tab + jmp skps1 ;loop +; +;----------------------------------------------------------------------- +; +; MULTIPLE COMMANDS PER LINE HANDLER +; +;----------------------------------------------------------------------- + if multi + +multistart: + ; + ; A = current character in command line + ; HL = address of current character in command line + ; + ;double exclaimation points become one + mov e,l + mov d,h + inx d + ldax d + cpi '!' ;double exclaimation points + push psw + push h + cz copy0 ;convert to one, if so + pop h + pop psw + rz + ;we have a valid multiple command line + mvi m,0 ;terminate command line here + xchg + ;multiple commands not allowed in submits + ;NOTE: submit unravels multiple commands making the + ;following test unnecessary. However, with GET[system] + ;or CP/M 2.2 SUBMIT multiple commands will be posponed + ;until the entire submit completes... +; call subtest ;submit active +; mvi a,0 +; rnz ;return with A=0, if so + ;set up the RSX buffer + lhld osbase ;get high byte of TPA address + dcr h ;subtract 1 page for buffer + mvi l,endchain ;HL = RSX buffer base-1 + mov m,a ;set end of chain flag to 0 + push h ;save it +multi0: inx h + inx d + ldax d ;get character from cbuf + mov m,a ;place in RSX + cpi '!' + jnz multi1 + mvi m,cr ;change exclaimation point to cr +multi1: ora a + jnz multi0 + mvi m,cr ;end last command with cr + inx h + mov m,a ;terminate with a zero + ;set up RSX prefix + mvi l,6 ;entry point + mvi m,jmp ;put a jump instruction there + inx h + mvi m,9 ;make it a jump to base+9 (RSX exit) + inx h + mov m,h + inx h ;HL = RSX exit point + mvi m,jmp ;put a jump instruction there + mvi l,warmflg ;HL = remove on warm start flag + mov m,a ;set (0) for RSX to remain resident + mov l,a ;set low byte to 0 for fixchain + xchg ;DE = RSX base + call fixchain ;add the RSX to the chain + ;save buffer address + lhld scbaddr + mvi l,ccpconbuf ;save buffer address in CCP conbuf field + pop d ;DE = RSX base + inx d + mov m,e + inx h + mov m,d + mvi l,multi$rsx$pg + mov m,d ;save the RSX base + xra a ;zero in a to fall out of uc + ret + ; + ; + ; save the BDOS conbuffer address and + ; terminate RSX if necessary. + ; +multisave: + lxi d,conbuffer*256+ccpconbuf + call wordmov ;first copy conbuffer in case SUBMIT + ora a ;and/or GET are active + lxi d,conbuffl*256+ccpconbuf + cz wordmov ;if conbuff is zero then conbufl has the + push h ;next address + call break1 + pop h ;H = SCB page + mvi l,ccpconbuf + jnz multiend + mov e,m + inx h + mov d,m ;DE = next conbuffer address + inr m + dcr m ;is high byte zero? + dcx h ;HL = .ccpconbuf + jz multiend ;remove multicmd RSX if so + ldax d ;check for terminating zero + ora a + rnz ;return if not + ; + ; we have exhausted all the commands +multiend: + ; HL = .ccpconbuf + xra a + mov m,a ;set buffer to zero + inx h + mov m,a + mvi l,multi$rsx$pg + mov h,m + mvi l,0eh ;HL=RSX remove on warmstart flag + dcr m ;set to true for removal + jmp rsx$chain ;remove the multicmd rsx buffer + + endif ;multi +;; +;************************************************************************ +; +; FILE NAME PARSER +; +;************************************************************************ +; +; +; +; get file name (read in if none present) +; +; +;; The file-name parser in this CCP implements +;; a user/drive specification as an extension of the normal +;; CP/M drive selection feature. The syntax of the +;; user/drive specification is given below. Note that a +;; colon must follow the user/drive specification. +;; +;; : is an alphabetic character A-P specifing one +;; of the CP/M disk drives. +;; +;; : is a decimal number 0-15 specifying one of the +;; user areas. +;; +;; : A specification of both user area and drive. +;; +;; : Synonymous with above. +;; +;; Note that the user specification cannot be included +;; in the parameters of transient programs or precede a file +;; name. The above syntax is parsed by gcmd (get command). +;; +;; ************************************************************ + +getfn: + if prompts + lxi d,fnmsg +getfn0: + call getprm + endif ;prompts +gfn: lxi d,dfcb +gfn0: call skps ;sets zero flag if eol + push psw + call gfn2 + pop psw + ret + ; + ; BDOS FUNCTION 152 INTERFACE + ; + ;entry: DE = .FCB + ; HL = .buffer + ;flags/A reg preserved + ;exit: DE = .FCB + ; + ; +gfn2: shld parsep + shld errorp + push d ;save .fcb + lxi d,pfncb + mvi c,parsef +if func152 + call bdos +else ;func152 + call parse +endif ;func152 + pop d ;.fcb + mov a,h + ora l ;end of command? (HL = 0) + mov b,m ;get delimiter + inx h ;move past delimiter + jnz gfn3 + lxi h,zero+2 ;set HL = .0 +gfn3: mov a,h + ora l ;parse error? (HL = 0ffffh) + jnz gfn4 + lxi h,zero+2 + call perror +gfn4: mov a,b + cpi '.' + jnz gfn6 + dcx h +gfn6: shld parsep ;update parse pointer +gfnpwd: mvi c,16 + lxi h,pfcb + push d + call move + lxi d,passwd ;HL = .disk map in pfcb + mvi c,10 + call move ;copy to passwd + pop d ;HL = .password len + mov a,m +zero: lxi h,0 ;must be an "lxi h,0" + ora a ;is there a password? + mov b,a + jz gfn8 + lhld errorp ;HL = .filename +gfn7: mov a,m + cpi ';' + inx h + jnz gfn7 +gfn8: ret ;B = len, HL = .password + +; +; PARSE CP/M 3 COMMAND +; entry: DE = .UFCB (user no. byte in front of FCB) +; PARSEP = .command line +gcmd: + push d + xra a + stax d ;clear user byte + inx d + stax d ;clear drive byte + inx d + call skps ;skip leading spaces +; +; Begin by looking for user/drive-spec. If none if found, +; fall through to main file-name parsing section. If one is found +; then branch to the section that handles them. If an error occurs +; in the user/drive spec; treat it as a filename for compatibility +; with CP/M 2.2. (e.g. STAT VAL: etc.) +; + lhld parsep ;get pointer to current parser position + pop d + push d ;DE = .UFCB + mvi b,4 ;maximum length of user/drive spec +gcmd1: mov a,m ;get byte + cpi ':' ;end of user/drive-spec? + jz gcmd2 ;parse user/drive if so + ora a ;end of command? + jz gcmd8 ;parse filename (Func 152), if so + cpi 9 ;[JCE] Patch 12, bug in "P B:" type commands + jz gcmd8 ;[JCE] + cpi ' ' ;[JCE] + jz gcmd8 ;[JCE] + dcr b ;maximum user/drive spec length exceeded? + inx h + jnz gcmd1 ;loop if not + ; + ; Parse filename, type and password + ; +gcmd8: + pop d + xra a + stax d ;set user = default + lhld parsep +gcmd9: inx d ;past user number byte + ldax d ;A=drive + push psw + call gfn2 ;BDOS function 152 interface + pop psw + stax d + ret + ; + ; Parse the user/drive-spec + ; +gcmd2: + lhld parsep ;get pointer to beginning of spec + mov a,m ;get character +gcmd3: cpi '0' ;check for user number + jc gcmd4 ;jump if not numeric + cpi '9'+1 + jnc gcmd4 + call gdns ;get the user # (returned in B) + pop d + push d + ldax d ;see if we already have a user # + ora a + jnz gcmd8 ;skip if we do + mov a,b ;A = specified user number + inr a ;save it as the user-spec + stax d + jmp gcmd5 +gcmd4: cpi 'A' ;check for drive-spec + jc gcmd8 ;skip if not a valid drive character + cpi 'P'+1 + jnc gcmd8 + pop d + push d + inx d + ldax d ;see if we already have a drive + ora a + jnz gcmd8 ;skip if so + mov a,m + sui '@' ;convert to a drive-spec + stax d + inx h +gcmd5: mov a,m ;get next character + cpi ':' ;end of user/drive-spec? + jnz gcmd3 ;loop if not + inx h + pop d ;.ufcb + jmp gcmd9 ;parse the file name + + +; +;************************************************************************ +; +; TEMPORARY PARSE CODE +; +;************************************************************************ +; +if not func152 +; version 3.0b Oct 08 1982 - Doug Huskey +; +; + +passwords equ true + +parse: ; DE->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks (left justified) + ; 9-11 => type, converted to upper case, + ; padded with blanks (left justified) + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if DE locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; + xchg + mov e,m ;get first parameter + inx h + mov d,m + push d ;save .filename + inx h + mov e,m ;get second parameter + inx h + mov d,m + pop h ;DE=.fcb HL=.filename + xchg +parse0: + push h ;save .fcb + xra a + mov m,a ;clear drive byte + inx h + lxi b,20h*256+11 + call pad ;pad name and type w/ blanks + lxi b,4 + call pad ;EXT, S1, S2, RC = 0 + lxi b,20h*256+8 + call pad ;pad password field w/ blanks + lxi b,12 + call pad + call skip +; +; check for drive +; + ldax d + cpi ':' ;is this a drive? + dcx d + pop h + push h ;HL = .fcb + jnz parse$name +; +; Parse the drive-spec +; +parsedrv: + ldax d ;get character + ani 5fh ;convert to upper case + sui 'A' + jc perr1 + cpi 16 + jnc perr1 + inx d + inx d ;past the ':' + inr a ;set drive relative to 1 + mov m,a ;store the drive in FCB(0) +; +; Parse the file-name +; +parse$name: + inx h ;HL = .fcb(1) + call delim + jz parse$ok +if passwords + lxi b,7*256 +else ;passwords + mvi b,7 +endif ;passwords +parse6: ldax d ;get a character + cpi '.' ;file-type next? + jz parse$type ;branch to file-type processing + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse6 ;loop if not end of name + jmp parse$ok +; +; Parse the file-type +; +parse$type: + inx d ;advance past dot + pop h + push h ;HL =.fcb + lxi b,9 + dad b ;HL =.fcb(9) +if passwords + lxi b,2*256 +else ;passwords + mvi b,2 +endif ;passwords +parse8: ldax d + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse8 ;loop if not end of type +; +parse$ok: + pop b + push d + call skip + call delim + pop h + rnz + lxi h,0 + ora a + rz + cpi cr + rz + xchg + ret +; +; handle parser error +; +perr: + pop b ;throw away return addr +perr1: + pop b + lxi h,0ffffh + ret +; +if passwords +; +; Parse the password +; +parsepw: + inx d + pop h + push h + lxi b,16 + dad b + lxi b,7*256+1 +parsepw1: + call gfc + jnz parsepw1 + mvi a,7 + sub b + pop h + push h + lxi b,26 + dad b + mov m,a + ldax d ;delimiter in A + jmp parse$ok +else +; +; skip over password +; +parsepw: + inx d + call delim + jnz parsepw + jmp parse$ok +endif ;passwords +; +; get next character of name, type or password +; +gfc: call delim ;check for end of filename + rz ;return if so + cpi ' ' ;check for control characters + inx d + jc perr ;error if control characters encountered + inr b ;error if too big for field + dcr b + jm perr +if passwords + inr c + dcr c + jnz gfc1 +endif + cpi '*' ;trap "match rest of field" character + jz setwild +gfc1: mov m,a ;put character in fcb + inx h + dcr b ;decrement field size counter + ora a ;clear zero flag + ret +;; +setwild: + mvi m,'?' ;set match one character + inx h + dcr b + jp setwild + ret +; +; skip spaces +; +skip0: inx d +skip: ldax d + cpi ' ' ;skip spaces & tabs + jz skip0 + cpi tab + jz skip0 + ret +; +; check for delimiter +; +; entry: A = character +; exit: z = set if char is a delimiter +; +delimiters: db cr,tab,' .,:;[]=<>|',0 + +delim: ldax d ;get character + push h + lxi h,delimiters +delim1: cmp m ;is char in table + jz delim2 + inr m + dcr m ;end of table? (0) + inx h + jnz delim1 + ora a ;reset zero flag +delim2: pop h + rz + ; + ; not a delimiter, convert to upper case + ; + cpi 'a' + rc + cpi 'z'+1 + jnc delim3 + ani 05fh +delim3: ani 07fh + ret ;return with zero set if so +; +; pad with blanks +; +pad: mov m,b + inx h + dcr c + jnz pad + ret +; +endif +; +; +;************************************************************************ +; +; SUBROUTINES +; +;************************************************************************ +; + if multi +; +; copy SCB memory word +; d = source offset e = destination offset +; +wordmov: + lhld scbaddr + mov l,d + mov d,h + mvi c,2 +; + endif ;multi +; +; copy memory bytes +; de = destination hl = source c = count +; +move: + mov a,m + stax d ;move byte to destination + inx h + inx d ;advance pointers + dcr c ;loop if non-zero + jnz move + ret +; +; copy memory bytes with terminating zero +; hl = destination de = source +; returns c=length + +copy0: mvi c,0 +copy1: ldax d + mov m,a + ora a + mov a,c + rz + inx h + inx d + inx b + jmp copy1 + +;; +;;----------------------------------------------------------------------- +;; +;; get byte from file +;; +;; exit: z = set if byte gotten +;; a = byte read +;; z = clear if error or eof +;; a = return value of bdos read call +;; +getb: xra a ;clear accumulator + lxi h,bufp ;advance buffer pointer + inr m + cm read ;read sector if buffer empty + ora a + rnz ;return if read error or eof + lda bufp ;compute pointer into buffer + lxi h,buf + call addhla + xra a ;set zero flag + mov a,m ;get byte + ret +;; +;;----------------------------------------------------------------------- +;; +;; +;; system control block flag routines +;; +;; entry: c = bit mask (1 bit on) +;; b = scb byte offset +;; +subtest: + lxi b,submit +getflg: +; return flag value +; exit: zero flag set if flag reset +; c = bit mask +; hl = flag byte address +; + lhld scbaddr + mov l,b + mov a,m + ana c ; a = bit + ret +; +setccpflg: + lxi b,ccp10 + +; +setflg: +; set flag on (bit = 1) +; + call getflg + mov a,c + ora m + mov m,a + ret +; +resetccpflg: + lxi b,ccp10 +; +resetflg: +; reset flag off (bit = 0) +; + call getflg + mov a,c + cma + ana m + mov m,a + ret +;; +;; +;; SET/GET SCB BYTE +;; +;; entry: A = byte ("setbyte" only) +;; B = SCB byte offset from page +;; +;; exit: A = byte ("getbyte" only) +;; +setbyte: + lhld scbaddr + mov l,b + mov m,a + ret +; +getbyte: + lhld scbaddr + mov l,b + mov a,m + ret +; + + + +;;----------------------------------------------------------------------- +;; +;; +;; print message followed by newline +;; +;; entry: de -> message string +;; +pmsgnl: call pmsg +; +; print crlf +; +dirln: mov b,l ;number of columns for DIR +crlf: mvi a,cr + call pfc + mvi a,lf + jmp pfc +;; +;;----------------------------------------------------------------------- +;; +;; print decimal byte +;; +pdb: sui 10 + jc pdb2 + mvi e,'0' +pdb1: inr e + sui 10 + jnc pdb1 + push psw + call putc2 + pop psw +pdb2: adi 10+'0' + jmp putc +;;----------------------------------------------------------------------- +;; +;; +;; print string terminated by 0 or char in c +;; +pstrg: mov a,m ;get character + ora a + rz + cmp c + rz + call pfc ;print character + inx h ;advance pointer + jmp pstrg ;loop +;; +;;----------------------------------------------------------------------- +;; +;; check for end of command (error if extraneous parameters) +;; +eoc: call skps + rz +; +; handle parser error +; +perror: + lxi h,errflg + mov a,m + ora a ;ignore error???? + mvi m,0 ;clear error flag + rnz ;yes...just return to CCPRET + lhld errorp ;get pointer to what we're parsing + mvi c,' ' + call pstrg +perr2: mvi a,'?' ;print question mark + call putc + jmp ccpcr +; +;;----------------------------------------------------------------------- +;; +;; +;; print error message and exit processor +;; +;; entry: bc -> error message +;; +;;msgerr: push b +;; call crlf +;; pop d +;; jmp pmsgnl +;; +;;----------------------------------------------------------------------- +;; +;; get decimal number (0 <= N <= 255) +;; +;; exit: a = number +;; +gdn: call skps ;skip initial spaces + lhld parsep ;get pointer to current character + shld errorp ;save in case of parsing error + rz ;return if end of command + mov a,m ;get it + cpi '0' ;error if non-numeric + jc perror + cpi '9'+1 + jnc perror + call gdns ;convert number + shld parsep ;save new position + ori 1 ;clear zero and carry flags + mov a,b + ret +; +gdns: mvi b,0 +gdns1: mov a,m + sui '0' + rc + cpi 10 + rnc + push psw + mov a,b ;multiply current accumulator by 10 + add a + add a + add b + add a + mov b,a + pop psw + inx h ;advance to next character + add b ;add it in to the current accumulation + mov b,a + cpi 16 + jc gdns1 ;loop unless >=16 + jmp perror ;error if invalid user number +;; +;;----------------------------------------------------------------------- +;; +;; print file name +;; + if newdir +pfn: inx d ;point to file name + mvi h,8 ;set # characters to print, clear # printed + call pfn1 ;print name field + call space + mvi h,3 ;set # characters to print +pfn1: ldax d ;get character + ani 7fh + call pfc ;print it if not + inx d ;advance pointer + dcr h ;loop if more to print + jnz pfn1 + ret +; +space: mvi a,' ' +; +pfc: push b + push d + push h + call putc + pop h + pop d + pop b + ret + + else + +pfn: inx d ;point to file name + lxi b,8*256 ;set # characters to print, clear # printed + call pfn1 ;print name field + ldax d ;see if there's a type + ani 7fh + cpi ' ' + rz ;return if not + mvi a,'.' ;print dot + call pfc + mvi b,3 ;set # characters to print +pfn1: ldax d ;get character + ani 7fh + cpi ' ' ;is it a space? + cnz pfc ;print it if not + inx d ;advance pointer + dcr b ;loop if more to print + jnz pfn1 + ret +; +space: mvi a,' ' +; +pfc: inr c ;increment # characters printed + push b + push d + call putc + pop d + pop b + ret + endif +;; +;;----------------------------------------------------------------------- +;; +;; add a to hl +;; +addhla: add l + mov l,a + rnc + inr h + ret +;; +;;----------------------------------------------------------------------- +;; +;; set match-any string into fcb +;; +;; entry: de -> fcb area +;; b = # bytes to set +;; +setmatch: + mvi a,'?' ;set match one character +setm1: stax d ;fill rest of field with match one + inx d + dcr b ;loop if more to fill + jnz setm1 + ora a + ret +;; +;;----------------------------------------------------------------------- +;; +;; table search +;; +;; Search table of strings separated by spaces and terminated +;; by 0. Accept abbreviations, but set string = matched string +;; on exit so that we don't try to execute abbreviation. +;; +;; entry: de -> string to search for +;; hl -> table of strings to match (terminate table with 0) +;; exit: z = set if match found +;; a = entry # (0 thru n-1) +;; z = not set if no match found +;; +tbls: lxi b,0ffh ;clear entry & entry length counters +tbls0: push d ;save match string addr + push h ;save table string addr +tbls1: ldax d ;compare bytes + ani 7fh ;kill upper bit (so SYS + R/O match) + cpi ' '+1 ;end of search string? + jc tbls2 ;skip compare, if so + cmp m + jnz tbls3 ;jump if no match +tbls2: inx d ;advance string pointer + inr c ;increment entry length counter + mvi a,' ' + cmp m + inx h ;advance table pointer + jnz tbls1 ;continue with this entry if more + pop h ;HL = matched string in table + pop d ;DE = string address + call move ; C = length of string in table + mov a,b ;return current entry counter value + ret +; +tbls3: mvi a,' ' ;advance hl past current string +tbls4: cmp m + inx h + jnz tbls4 + pop d ;throw away last table address + pop d ;DE = string address + inr b ;increment entry counter + mvi c,0ffh + mov a,m ;check for end of table + sui 1 + jnc tbls0 ;loop if more entries to test + ret +; +;************************************************************************ +;************************************************************************ +; +;************************************************************************ +; +; DATA AREA +; +;************************************************************************ +; ;Note uninitialized data placed at the end (DS) +; +; + if prompts +enter: db 'Enter $' +unmsg: db 'User #: $' +fnmsg: db 'File: $' + else +unmsg: db 'Enter User #: $' + endif +nomsg: db 'No File$' +required: + db ' required$' +eramsg: + db 'ERASE $' +confirm: + db ' (Y/N)? $' +more: db cr,lf,cr,lf,'Press RETURN to Continue $' + if dayfile +userzero db ' (User 0)$' + endif +; +; +; + if newdir +anyfiles: db 0 ;flag for SYS or DIR files exist +dirfiles: db 'NON-' +sysfiles: db 'SYSTEM FILE(S) EXIST$' + endif + +rsxpb: db 41h ;Function for Named Directory RSXs +errflg: db 0 ;parse error flag + if multi +multibufl: + dw 0 ;multiple commands buffer length + endif +scbadd: db scbad-pag$off,0 + ;********** CAUTION FOLLOWING DATA MUST BE IN THIS ORDER ********* +pfncb: ;BDOS func 152 (parse filename) +parsep: dw 0 ;pointer to current position in command +pfnfcb: dw pfcb ;.fcb for func 152 +usernum: ;CCP current user + db 0 +chaindsk: + db 0 ;transient's current disk +disk: db 0 ;CCP current disk +subfcb: db 1,'$$$ SUB',0 +ccpend: ;end of file (on disk) + ds 1 +submod: ds 1 +subrc: ds 1 + ds 16 +subcr: ds 1 +subrr: ds 2 +subrr2: ds 1 + +dircols: + ds 1 ;number of columns for DIR/DIRS +pgsize: ds 1 ;console page size +line: ds 1 ;console line # +pgmode: ds 1 ;console page mode + ;***************************************************************** +errorp: ds 2 ;pointer to beginning of current param. +errsav: ds 2 ;pointer to built-in command tail +bufp: ds 1 ;buffer pointer for getb +realdos: + ds 1 ;base page of BDOS +; +option: ds 1 ;'[' in line? +passwd: ds 10 ;password +ufcb: ds 1 ;user number (must procede fcb) +FCB: + ds 1 ; drive code + ds 8 ; file name + ds 3 ; file type + ds 4 ; control info + ds 16 ; disk map +fcbcr: ds 1 ; current record +fcbrr: ds 2 ; random record +pfcb: ds 36 ; fcb for parsing +; +; +; +; +; command line buffer +; +cbufmx: ds 1 +cbufl: ds 1 +cbuf: ds comlen + ds 50h +stack: +ccptop: ;top page of CCP + end + diff --git a/software/CPM/cpm3/ccp3org.asm b/software/CPM/cpm3/ccp3org.asm new file mode 100644 index 0000000..b8ab245 --- /dev/null +++ b/software/CPM/cpm3/ccp3org.asm @@ -0,0 +1,2807 @@ +title 'CP/M 3 - Console Command Processor - November 1982' +; version 3.00 Nov 30 1982 - Doug Huskey + + +; Copyright (C) 1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, CA 93950 + +; Revised: (date/name of person modifying this source) + +; **************************************************** +; ***** The following equates must be set to 100H *** +; ***** + the addresses specified in LOADER.PRN *** +; ***** *** +equ1 equ rsxstart ;does this adr match loader's? +equ2 equ fixchain ;does this adr match loader's? +equ3 equ fixchain1 ;does this adr match loader's? +equ4 equ fixchain2 ;does this adr match loader's? +equ5 equ rsx$chain ;does this adr match loader's? +equ6 equ reloc ;does this adr match loader's? +equ7 equ calcdest ;does this adr match loader's? +equ8 equ scbaddr ;does this adr match loader's? +equ9 equ banked ;does this adr match loader's? +equ10 equ rsxend ;does this adr match loader's? +equ11 equ ccporg ;does this adr match loader's? +equ12 equ ccpend ;This should be 0D80h + rsxstart equ 0100h + fixchain equ 01D0h + fixchain1 equ 01EBh + fixchain2 equ 01F0h + rsx$chain equ 0200h + reloc equ 02CAh + calcdest equ 030Fh + scbaddr equ 038Dh + banked equ 038Fh + rsxend equ 0394h + ccporg equ 041Ah +; **************************************************** +; NOTE: THE ABOVE EQUATES MUST BE CORRECTED IF NECESSARY +; AND THE JUMP TO START AT THE BEGINNING OF THE LOADER +; MUST BE SET TO THE ORIGIN ADDRESS BELOW: + + org ccporg ;LOADER is at 100H to 3??H + +; (BE SURE THAT THIS LEAVES ENOUGH ROOM FOR THE LOADER BIT MAP) + + +; Conditional Assembly toggles: + +true equ 0ffffh +false equ 0h +newdir equ true +newera equ true ;confirm any ambiguous file name +dayfile equ true +prompts equ false +func152 equ true +multi equ true ;multiple command lines + ;also shares code with loader (100-2??h) +; +;************************************************************************ +; +; GLOBAL EQUATES +; +;************************************************************************ +; +; +; CP/M BASE PAGE +; +wstart equ 0 ;warm start entry point +defdrv equ 4 ;default user & disk +bdos equ 5 ;CP/M BDOS entry point +osbase equ bdos+1 ;base of CP/M BDOS +cmdrv equ 050h ;command drive +dfcb equ 05ch ;1st default fcb +dufcb equ dfcb-1 ;1st default fcb user number +pass0 equ 051h ;1st default fcb password addr +len0 equ 053h ;1st default fcb password length +dfcb1 equ 06ch ;2nd default fcb +dufcb1 equ dfcb1-1 ;2nd default fcb user number +pass1 equ 054h ;2nd default fcb password addr +len1 equ 056h ;2nd default fcb password length +buf equ 80h ;default buffer +tpa equ 100h ;transient program area + if multi +comlen equ 100h-19h ;maximum size of multiple command + ;RSX buffer with 16 byte header & + ;terminating zero + else +comlen equ tpa-buf + endif +; +; BDOS FUNCTIONS +; +vers equ 31h ;BDOS vers 3.1 +cinf equ 1 ;console input +coutf equ 2 ;console output +crawf equ 6 ;raw console input +pbuff equ 9 ;print buffer to console +rbuff equ 10 ;read buffer from console +cstatf equ 11 ;console status +resetf equ 13 ;disk system reset +self equ 14 ;select drive +openf equ 15 ;open file +closef equ 16 ;close file +searf equ 17 ;search first +searnf equ 18 ;search next +delf equ 19 ;delete file +readf equ 20 ;read file +makef equ 22 ;make file +renf equ 23 ;rename file +dmaf equ 26 ;set DMA address +userf equ 32 ;set/get user number +rreadf equ 33 ;read file +flushf equ 48 ;flush buffers +scbf equ 49 ;set/get SCB value +loadf equ 59 ;program load +allocf equ 98 ;reset allocation vector +trunf equ 99 ;read file +parsef equ 152 ;parse file +; +; ASCII characters +; +ctrlc: equ 'C'-40h +cr: equ 'M'-40h +lf: equ 'J'-40h +tab: equ 'I'-40h +eof: equ 'Z'-40h +; +; +; RSX MEMORY MANAGEMENT EQUATES +; +; RSX header equates +; +entry equ 06h ;RSX contain jump to start +nextadd equ 0bh ;address of next RXS in chain +prevadd equ 0ch ;address of previous RSX in chain +warmflg equ 0eh ;remove on wboot flag +endchain equ 18h ;end of RSX chain flag +; +; LOADER.RSX equates +; +module equ 100h ;module address +; +; COM file header equates +; +comsize equ tpa+1h ;size of the COM file +rsxoff equ tpa+10h ;offset of the RSX in COM file +rsxlen equ tpa+12h ;length of the RSX +; +; +; SYSTEM CONTROL BLOCK OFFSETS +; +pag$off equ 09ch +; +olog equ pag$off-0ch ; removeable media open vector +rlog equ pag$off-0ah ; removeable media login vector +bdosbase equ pag$off-004h ; real BDOS entry point +hashl equ pag$off+000h ; system variable +hash equ pag$off+001h ; hash code +bdos$version equ pag$off+005h ; BDOS version number +util$flgs equ pag$off+006h ; utility flags +dspl$flgs equ pag$off+00ah ; display flags +clp$flgs equ pag$off+00eh ; CLP flags +clp$drv equ pag$off+00fh ; submit file drive +prog$ret$code equ pag$off+010h ; program return code +multi$rsx$pg equ pag$off+012h ; multiple command buffer page +ccpdrv equ pag$off+013h ; ccp default drive +ccpusr equ pag$off+014h ; ccp default user number +ccpconbuf equ pag$off+015h ; ccp console buffer address +ccpflag1 equ pag$off+017h ; ccp flags byte 1 +ccpflag2 equ pag$off+018h ; ccp flags byte 2 +ccpflag3 equ pag$off+019h ; ccp flags byte 3 +conwidth equ pag$off+01ah ; console width +concolumn equ pag$off+01bh ; console column position +conpage equ pag$off+01ch ; console page length (lines) +conline equ pag$off+01dh ; current console line number +conbuffer equ pag$off+01eh ; console input buffer address +conbuffl equ pag$off+020h ; console input buffer length +conin$rflg equ pag$off+022h ; console input redirection flag +conout$rflg equ pag$off+024h ; console output redirection flag +auxin$rflg equ pag$off+026h ; auxillary input redirection flag +auxout$rflg equ pag$off+028h ; auxillary output redirection flag +listout$rflg equ pag$off+02ah ; list output redirection flag +page$mode equ pag$off+02ch ; page mode flag 0=on, 0ffH=off +page$def equ pag$off+02dh ; page mode default +ctlh$act equ pag$off+02eh ; ctl-h active +rubout$act equ pag$off+02fh ; rubout active (boolean) +type$ahead equ pag$off+030h ; type ahead active +contran equ pag$off+031h ; console translation subroutine +con$mode equ pag$off+033h ; console mode (raw/cooked) +ten$buffer equ pag$off+035h ; 128 byte buffer available + ; to banked BIOS +outdelim equ pag$off+037h ; output delimiter +listcp equ pag$off+038h ; list output flag (ctl-p) +q$flag equ pag$off+039h ; queue flag for type ahead +scbad equ pag$off+03ah ; system control block address +dmaad equ pag$off+03ch ; dma address +seldsk equ pag$off+03eh ; current disk +info equ pag$off+03fh ; BDOS variable "info" +resel equ pag$off+041h ; disk reselect flag +relog equ pag$off+042h ; relog flag +fx equ pag$off+043h ; function number +usrcode equ pag$off+044h ; current user number +dcnt equ pag$off+045h ; directory record number +searcha equ pag$off+047h ; fcb address for searchn function +searchl equ pag$off+049h ; scan length for search functions +multcnt equ pag$off+04ah ; multi-sector I/O count +errormode equ pag$off+04bh ; BDOS error mode +drv0 equ pag$off+04ch ; search chain - 1st drive +drv1 equ pag$off+04dh ; search chain - 2nd drive +drv2 equ pag$off+04eh ; search chain - 3rd drive +drv3 equ pag$off+04fh ; search chain - 4th drive +tempdrv equ pag$off+050h ; temporary file drive +patch$flag equ pag$off+051h ; patch flags +date equ pag$off+058h ; date stamp +com$base equ pag$off+05dh ; common memory base address +error equ pag$off+05fh ; error jump...all BDOS errors +top$tpa equ pag$off+062h ; top of user TPA (address at 6,7) +; +; CCP FLAG 1 BIT MASKS +; (used with getflg, setflg and resetflg routines) +; +chainflg equ 080h ; program chain (funct 49) +not$chainflg equ 03fh ; mask to reset chain flags +chainenv equ 040h ; preserve usr/drv for chained prog +comredirect equ 0b320h ; command line redirection active +menu equ 0b310h ; execute ccp.ovl for menu systems +echo equ 0b308h ; echo commands in batch mode +userparse equ 0b304h ; parse user numbers in commands +subfile equ 0b301h ; $$$.SUB file found or active +subfilemask equ subfile-0b300h +rsx$only$set equ 02h ; RSX only load (null COM file) +rsx$only$clr equ 0FDh ; reset RSX only flag +; +; CCP FLAG 2 BIT MASKS +; (used with getflg, setflg and resetflg routines) +; +ccp10 equ 0b4a0h ; CCP function 10 call (2 bits) +ccpsub equ 0b420h ; CCP present (for SUBMIT, PUT, GET) +ccpbdos equ 0b480h ; CCP present (for BDOS buffer save) +dskreset equ 20h ; CCP does disk reset on ^C from prompt +submit equ 0b440h ; input redirection active +submitflg equ 40h ; input redirection flag value +order equ 0b418h ; command order + ; 0 - COM only + ; 1 - COM,SUB + ; 2 - SUB,COM + ; 3 - reserved +datetime equ 0b404h ; display date & time of load +display equ 0b403h ; display filename & user/drive +filename equ 02h ; display filename loaded +location equ 01h ; display user & drive loaded from + +; +; CCP FLAG 3 BIT MASKS +; (used with getflg, setflg and resetflg routines) +; +rsxload equ 1h ; load RSX, don't fix chain +coldboot equ 2h ; try to exec profile.sub +; +; CONMODE BIT MASKS +; +ctlc$stat equ 0cf01h ;conmode CTL-C status + +; +; +;************************************************************************ +; +; Console Command Processor - Main Program +; +;************************************************************************ +; +; +; +start: +; + lxi sp,stack + lxi h,ccpret ;push CCPRET on stack, in case of + push h ; profile error we will go there + lxi d,scbadd + mvi c,scbf + call bdos + shld scbaddr ;save SCB address + mvi l,com$base+1 + mov a,m ;high byte of commonbase + sta banked ;save in loader + mvi l,bdosbase+1 ;HL addresses real BDOS page + mov a,m ;BDOS base in H + sta realdos ;save it for use in XCOM routine +; + lda osbase+1 ;is the LOADER in memory? + sub m ;compare link at 6 with real BDOS + jnz reset$alloc ;skip move if loader already present +; +; +movldr: + lxi b,rsxend-rsxstart ;length of loader RSX + call calcdest ;calculate destination and (bias+200h) + mov h,e ;set to zero + mov l,e +; lxi h,module-100h ;base of loader RSX (less 100h) + call reloc ;relocate loader + lhld osbase ;HL = BDOS entry, DE = LOADER base + mov l,e ;set L=0 + mvi c,6 + call move ;move the serial number down + mvi e,nextadd + call fixchain1 +; +; +reset$alloc: + mvi c,allocf + call bdos +; +; +; +;************************************************************************ +; +; INITIALIZE SYSTEM CONTROL BLOCK +; +;************************************************************************ +; +; +scbinit: + ; + ; # dir columns, page size & function 9 delimiter + ; + mvi b,conwidth + call getbyte + inr a ;get console width (rel 1) + rrc + rrc + rrc + rrc + ani 0fh ;divide by 16 + lxi d,dircols + stax d ;dircols = conwidth/16 + mvi l,conpage + mov a,m + dcr a ;subtract 1 for space before prompt + inx d + stax d ;pgsize = conpage + xra a + inx d + stax d ;line=0 + mvi a,'$' + inx d + stax d ;pgmode = nopage (>0) + mvi l,outdelim + mov m,a ;set function 9 delimiter + ; + ; multisector count, error mode, console mode + ; & BDOS version no. + ; + mvi l,multcnt + mvi m,1 ;set multisector I/O count = 1 + inx h ;.errormode + xra a + mov m,a ;set return error mode = 0 + mvi l,con$mode + mvi m,1 ;set ^C status mode + inx h + mov m,a ;zero 2nd conmode byte + mvi l,bdos$version + mvi m,vers ;set BDOS version no. + ; + ; disk reset check + ; + mvi l,ccpflag2 + mov a,m + ani dskreset ;^C at CCP prompt? + mvi c,resetf + push h + cnz bdos ;perform disk reset if so + pop h + ; + ; remove temporary RSXs (those with remove flag on) + ; +rsxck: + mvi l,ccpflag1 ;check CCP flag for RSX only load + mov a,m + ani rsx$only$set ;bit = 1 if only RSX has been loaded + push h + cz rsx$chain ;don't fix-up RSX chain if so + pop h + mov a,m + ani rsx$only$clr ;clear RSX only loader flag + mov m,a ;replace it + ; + ; chaining environment + ; + ani chain$env ;non-zero if we preserve programs + push h ;user & drive for next transient + ; + ; user number + ; + mvi l,ccpusr ; HL = .CCP USER (saved in SCB) + lxi b,usernum ; BC = .CCP'S DEFAULT USER + mov d,h + mvi e,usrcode ; DE = .BDOS USER CODE + ldax d + stax b ; usernum = bdos user number + mov a,m ; ccp user + jnz scb1 ; jump if chaining env preserved + stax b ; usernum = ccp default user +scb1: stax d ; bdos user = ccp default user + ; + ; transient program's current disk + ; + inx b ;.CHAINDSK + mvi e,seldsk ;.BDOS CURRENT DISK + ldax d + jnz scb2 ; jump if chaining env preserved + mvi a,0ffh +; cma ; make an invalid disk +scb2: stax b ; chaindsk = bdos disk (or invalid) + ; + ; current disk + ; + dcx h ;.CCP's DISK (saved in SCB) + inx b ;.CCP's CURRENT DISK + mov a,m + stax b + stax d ; BDOS current disk + ; + ; $$$.SUB drive + ; + mvi l,tempdrv + inx b ;.SUBFCB + mov a,m + stax b ; $$$.SUB drive = temporary drive + ; + ; check for program chain + ; + pop h ;HL =.ccpflag1 + mov a,m + ani chainflg ;is it a chain function (47) + jz ckboot ;jump if not + lxi h,buf +chain: lxi d,cbufl + mvi c,tpa-buf-1 + mov a,c + stax d + inx d + call move ;hl = source, de = dest, c = count + jmp ccpparse + ; + ; execute profile.sub ? + ; +ckboot: mvi l,ccpflag3 + mov a,m + ani coldboot ;is this a cold start + jnz ccpcr ;jump if not + mov a,m + ori coldboot ;set flag for next time + mov m,a + sta errflg ;set to ignore errors + lxi h,profile + jmp chain ;attempt to exec profile.sub +profile: + db 'PROFILE.S',0 +; +; +; +;************************************************************************ +; +; BUILT-IN COMMANDS (and errors) RETURN HERE +; +;************************************************************************ +; +; +ccpcr: + ; enter here on each command or error condition + call setccpflg + call crlf +ccpret: + lxi h,stack-2 ;reset stack in case of error + sphl ;preserve CCPRET on stack + xra a + sta line + lxi h,ccpret ;return for next builtin + push h + call setccpflg + dcx h ;.CCPFLAG1 + mov a,m + ani subfilemask ;check for $$$.SUB submit + jz prompt +; +; +; +;************************************************************************ +; +; $$$.SUB file processing +; +;************************************************************************ +; +; + lxi d,cbufl ;set DMA to command buffer + call setbuf + mvi c,openf + call sudos ;open it if flag on + mvi c,cstatf ;check for break if successful open + cz sudos ;^C typed? + jnz subclose ;delete $$$.SUB if break or open failed + lxi h,subrr2 + mov m,a ;zero high random record # + dcx h + mov m,a ;zero middle random record # + dcx h + push h + lda subrc + dcr a + mov m,a ;set to read last record of file + mvi c,rreadf + cp sudos + pop h + dcr m ;record count (truncate last record) + mvi c,delf + cm sudos + ora a ;error on read? + ; + ; +subclose: + push psw + mvi c,trunf ;truncate file (& close it) + call sudos + pop psw ;any errors ? + jz ccpparse ;parse command if not + ; + ; +subkill: + lxi b,subfile + call resetflg ;turn off submit flag + mvi c,delf + call sudos ;kill submit +; +; +; +;************************************************************************ +; +; GET NEXT COMMAND +; +;************************************************************************ +; +; + ; + ; prompt user + ; +prompt: + lda usernum + ora a + cnz pdb ;print user # if non-zero + call dirdrv1 + mvi a,'>' + call putc + ; + if multi + ;move ccpconbuf addr to conbuffer addr + lxi d,ccpconbuf*256+conbuffer + call wordmov ;process multiple command, unless in submit + ora a ;non-zero => multiple commands active + push psw ;save A=high byte of ccpconbuf + lxi b,ccpbdos + cnz resetflg ;turn off BDOS flag if multiple commands + endif + call rcln ;get command line from console + call resetccpflg ;turn off BDOS, SUBMIT & GET ccp flags + if multi + pop psw ;D=high byte of ccpconbuf + cnz multisave ;save multiple command buffer + endif +; +; +; +;************************************************************************ +; +; PARSE COMMAND +; +;************************************************************************ +; +; +ccpparse: + ; + ; reset default page mode + ; (in case submit terminated) + ; + call subtest ;non-zero if submit is active + jnz get$pg$mode ;skip, if so +set$pg$mode: + mvi l,page$def + mov a,m ;pick up default + dcx h + mov m,a ;place in mode +get$pg$mode: + mvi l,page$mode + mov a,m + sta pgmode + ; + ;check for multiple commands + ;convert to upper case + ;reset ccp flag, in case entered from a CHAIN (or profile) + ; + call uc ;convert to upper case, ck if multiple command + rz ;get another line if null or comment + ; + ;transient or built-in command? + ; + lxi d,ufcb ;include user number byte in front of FCB + call gcmd ;parse command name + lda fcb+9 ;file type specified? + cpi ' ' + jnz ccpdisk2 ;execute from disk, if so + lxi h,ufcb ;user or drive specified? + mov a,m ;user number + inx h + ora m ;drive + inx h + mov a,m ;get 1st character of filename + jnz ccpdisk3 ;jump if so + ; + ;BUILT-IN HANDLER + ; +ccpbuiltin: + lxi h,ctbl ;search table of internal commands + lxi d,fcb+1 + lda fcb+3 + cpi ' '+1 ;is it shorter that 3 characters? + cnc tbls ;is it a built-in? + jnz ccpdisk0 ;load from disk if not + lda option ;[ in command line? + ora a ;options specified? + mov a,b ;built-in index from tbls + lhld parsep + shld errsav ;save beginning of command tail + lxi h,ptbl ;jump to processor if options not + jz tblj ;specified + cpi 4 + jc trycom + lxi h,fcb+4 + jnz ccpdisk0 ;if DIRS then look for DIR.COM + mvi m,' ' + ; + ;LOAD TRANSIENT (file type unspecified) + ; +ccpdisk0: + lxi b,order + call getflg ;0=COM 8=COM,SUB 16=SUB,COM + jz ccpdisk2 ;search for COM file only + mvi b,8 ;=> 2nd choice is SUB + sub b ;now a=0 (COM first) or 8 (SUB first) + jz ccpdisk1 ;search for COM first then SUB + mvi b,0 ;search for SUB first then COM + +ccpdisk1: + push b ;save 2nd type to try + call settype ; A = offset of type in type table + call exec ;try to execute, return if unsuccessful + pop psw ;try 2nd type + call settype + ; + ;LOAD TRANSIENT (file type specified) + ; +ccpdisk2: + call exec + jmp perror ;error if can't find it + ; + ;DRIVE SPECIFIED (check for change drives/users command) + ; +ccpdisk3: + cpi ' ' ;check for filename + jnz ccpdisk0 ;execute from disk if specified + call eoc ;error if not end of command + lda ufcb ;user specified? + sui 1 + jc ccpdrive + +ccpuser: + sta usernum ;CCP's user number + mvi b,ccpusr + call setbyte ;save it in SCB + call setuser ;set current user + +ccpdrive: + lda fcb ;drive specified? + dcr a + rm ;return if not + push psw + call select + pop psw + sta disk ;CCP's drive + mvi b,ccpdrv + jmp setbyte ;save it in SCB + +;; +; +;************************************************************************ +; +; BUILT-IN COMMANDS +; +;************************************************************************ +; +; +; Table of internal ccp commands +; +; +ctbl: db 'DIR ' + db 'TYPE ' + db 'ERASE ' + db 'RENAME ' + db 'DIRSYS ' + db 'USER ' + db 0 +; +ptbl: dw dir + dw type + dw era + dw ren + dw dirs + dw user +;; +;;----------------------------------------------------------------------- +;; +;; DIR Command +;; +;; DIR list directory of current default user/drive +;; DIR : list directory of user/drive +;; DIR list all files on the current default user/drive +;; with names that match +;; DIR : list all files on user/drive with names that +;; match +;; +;;----------------------------------------------------------------------- +;; +; + if newdir +dirdrv: + lda dfcb ;get disk number + endif + +dirdrv0: + dcr a + jp dirdrv2 + +dirdrv1: + lda disk ;get current disk +dirdrv2: + adi 'A' + jmp pfc ;print it (save BC,DE) +; +; + if newdir +dir: + mvi c,0 ;flag for DIR (normal) + lxi d,sysfiles + jmp dirs1 +; +; +dirs: + mvi c,080h ;flag for DIRS (system) + lxi d,dirfiles + +dirs1: push d + call direct + pop d ;de = .system files message + jz nofile ;jump if no files found + mov a,l ;A = number of columns + cmp b ;did we print any files? + cnc crlf ;print crlf if so + lxi h,anyfiles + dcr m + inr m + rz ;return if no files + ;except those requested + dcr m ;set to zero + jmp pmsgnl ;tell the operator other files exist +; +; +direct: + push b ;save DIR/DIRS flag + call sbuf80 ;set DMA = 80h + call gfn ;parse file name + lxi d,dfcb+1 + ldax d + cpi ' ' + mvi b,11 + cz setmatch ;use "????????.???" if none + call eoc ;make sure there's nothing else + call srchf ;search for first directory entry + pop b + rz ;if no files found +dir0: + lda dircols ;number of columns for dir + mov l,a + mov b,a + inr b ;set # names to print per line (+1) +dir1: + push h ;L=#cols, B=curent col, C=dir/dirs + lxi h,10 ;get byte with SYS bit + dad d + mov a,m + pop h + ani 80h ;look at SYS bit + cmp c ;DIR/DIRS flag in C + jz dir2 ;display, if modes agree + mvi a,1 ;set anyfiles true + sta anyfiles + jmp dir3 ;don't print anything +; +; display the filename +; +dir2: + dcr b + cz dirln ;sets no. of columns, puts crlf + mov a,b ;number left to print on line + cmp l ;is current col = number of cols + cz dirdrv ;display the drive, if so + mvi a,':' + call pfc ;print colon + call space + call pfn ;print file name + call space ;pad with space +dir3: + push b ;save current col(B), DIR/DIRS(C) + push h ;save number of columns(L) + call break ;drop out if keyboard struck + call srchn ;search for another match + pop h + pop b + jnz dir1 +direx: + inr a ;clear zero flag + ret + + else + +dirs: ; display system files only + mvi a,0d2h ; JNC instruction + sta dir11 ; skip on non-system files +; +dir: ; display non-system files only + lxi h,ccpcr + push h ; push return address + call gfn ;parse file name + inx d + ldax d + cpi ' ' + mvi b,11 + cz setmatch ;use "????????.???" if none + call eoc ;make sure there's nothing else + call findone ;search for first directory entry + jz dir4 + mvi b,5 ;set # names to print per line +dir1: lxi h,10 ;get byte with SYS bit + dad d + mov a,m + ral ;look at SYS bit +dir11: jc dir3 ;don't print it if SYS bit set + mov a,b + push b +dir2: lxi h,9 ;get byte with R/O bit + dad d + mov a,m + ral ;look at R/O bit + mvi a,' ' ;print space if not R/O + jnc dir21 ;jump if not R/O + mvi a,'*' ;print star if R/O +dir21: call pfc ;print character + call pfn ;print file name + mvi a,13 ;figure out how much padding is needed + sub c +dir25: push psw + call space ;pad it out with spaces + pop psw + dcr a + jnz dir25 ;loop if more required + pop b + dcr b ;decrement # names left on line + jnz dir3 + call crlf ;go to new line + mvi b,5 ;set # names to print on new line +dir3: push b + call break ;drop out if keyboard struck + call srchn ;search for another match + pop b + jnz dir1 + +dir4: mvi a,0dah ;JC instruction + sta dir11 ;restore normal dir mode (skip system files) + jmp ccpcr + + endif + +;; +;;----------------------------------------------------------------------- +;; +;; TYPE command +;; +;; TYPE Print the contents of text file on +;; the console. +;; +;;----------------------------------------------------------------------- +;; +type: lxi h,ccpcr + push h ;push return address + call getfn ;get and parse filename + mvi a,127 ;initialize buffer pointer + sta bufp + mvi c,openf + call sbdosf ;open file if a filename was typed +type1: call break ;exit if keyboard struck + call getb ;read byte from file + rnz ;exit if physical eof or read error + cpi eof ;check for eof character + rz ;exit if so + call putc ;print character on console + jmp type1 ;loop +; +;;----------------------------------------------------------------------- +;; +;; USER command +;; +;; USER Set the user number +;; +;;----------------------------------------------------------------------- +;; +user: + lxi d,unmsg ;Enter User #: + call getprm + call gdn ;convert to binary + rz ;return if nothing typed + jmp ccpuser ;set user number +; +;;----------------------------------------------------------------------- +;; +;; ERA command +;; +;; ERA Erase all file on the current user/drive +;; which match . +;; ERA : Erase all files on user/drive which +;; match . +;; +;;----------------------------------------------------------------------- +;; +era: call getfn ;get and parse filename + jz era1 + call ckafn ;is it ambiguous? + jnz era1 + lxi d,eramsg + call pmsg + lhld errorp + mvi c,' ' ;stop at exclamation mark or 0 + call pstrg ;echo command + lxi d,confirm + call getc + call crlf + mov a,l ;character in L after CRLF routine + ani 5fh ;convert to U/C + cpi 'Y' ;Y (yes) typed? + rnz ;return, if not + ora a ;reset zero flag +era1: mvi c,delf + jmp sbdosf + +;;----------------------------------------------------------------------- +;; +;; +;; REN command +;; +;;----------------------------------------------------------------------- +;; +ren: call gfn ;zero flag set if nothing entered + push psw + lxi h,16 + dad d + xchg + push d ;DE = .dfcb+16 + push h ;HL = .dfcb + mvi c,16 + call move ;DE = dest, HL = source + call gfn + pop h ;HL=.dfcb + pop d ;DE=.dfcb+16 + call drvok + mvi c,renf ;make rename call + pop psw ;zero flag set if nothing entered +; +;;----------------------------------------------------------------------- +;; +;; BUILT-IN COMMAND BDOS CALL & ERROR HANDLERS +;; +;;----------------------------------------------------------------------- +; +sbdosf: + push psw + cnz eoc ;make sure there's nothing else + pop psw + lxi d,dfcb + mvi b,0ffh + mvi h,1 ;execute disk command if we don't call + cnz bdosf ;call if something was entered + rnz ;return if successful + +ferror: + dcr h ;was it an extended error? + jm nofile + lhld errsav + shld parsep +trycom: call exec + call pfn + lxi d,required + jmp builtin$err +; +;;----------------------------------------------------------------------- +; +; +; check for drive conflict +; HL = FCB +; DE = FCB+16 +; +drvok: ldax d ;get byte from 2nd fcb + cmp m ;ok if they match + rz + ora a ;ok if 2nd is 0 + rz + inr m ;error if the 1st one's not 0 + dcr m + jnz perror + mov m,a ;copy from 2nd to 1st + ret +;;----------------------------------------------------------------------- +;; +;; check for ambiguous reference in file name/type +;; +;; entry: b = length of string to check (ckafn0) +;; de = fcb area to check (ckafn0) - 1 +;; exit: z = set if any ? in file reference (ambiguous) +;; z = clear if unambiguous file reference +;; +ckafn: + mvi b,11 ;check entire name and type +ckafn0: inx d + ldax d + cpi '?' ;is it an ambiguous file name +if newera + rz ;return true if any afn +else + rnz ;return true only if *.* +endif + dcr b + jnz ckafn0 +if newera + dcr b ;clear zero flag to return false +endif + ret ;remove above DCR to return true +;; +;;----------------------------------------------------------------------- +;; +;; get parameter (generally used to get a missing one) +;; +getprm: + call skps ;see if already there + rnz ;return if so +getp0: + if prompts + push d + lxi d,enter + call pmsg + pop d + endif + call pmsg ;print prompt + call rcln ;get response + jmp uc ;convert to upper case +; +;; +;;----------------------------------------------------------------------- + if not newdir +;; +;; search for first file, print "No File" if none +;; +findone: + call srchf + rnz ;found + endif +;;----------------------------------------------------------------------- + +nofile: + lxi d,nomsg ;tell user no file found +builtin$err: + call pmsgnl + jmp ccpret + +; +; +;************************************************************************ +; +; EXECUTE DISK RESIDENT COMMAND +; +;************************************************************************ +; +; +xfcb: db 0,'SUBMIT COM' ;processor fcb +; +; +; execute submit file (or any other processor) +; +xsub: ;DE = .fcb + ldax d + mvi b,clp$drv + call setbyte ;save submit file drive + lxi h,xfcb + mvi c,12 + call move ;copy processor into fcb + lxi h,cbufl ;set parser pointer back to beginning + mvi m,' ' + inx h ;move past blank + shld parsep +; execute SUBMIT.COM +; +; +; execute disk resident command (return if not found or error) +; +exec: + ;try to open and execute fcb + lxi d,fcb+9 + lxi h,typtbl + call tbls ;search for type in type table + rnz ;return if no match + lxi d,ufcb + ldax d ;check to see if user specified + ora a + rnz ;return if so + inx d + ldax d ;check if drive specified + mov c,a + push b ;save type (B) and drive (C) + mvi c,0 ;try only 1 open if drive specified + ora a + jnz exec1 ;try to open as specified + lxi b,(drv0-1)*256+4;try upto four opens from drv chain + lda disk + inr a + mov h,a ;save default disk in H + mvi l,1 ;allow only 1 match to default disk +exec0: inr b ;next drive to try in SCB drv chain + dcr c ;any more tries? + mov a,c + push h + cp getbyte + pop h + ora a + jm exec3 + jz exec01 ;jump if drive is 0 (default drive) + cmp h ;is it the default drive + jnz exec02 ;jump if not +exec01: mov a,h ;set drive explicitly + dcr l ;is it the 2nd reference + jm exec0 ;skip, if so +exec02: stax d ;put drive in FCB +exec1: push b ;save drive offset(B) & count(C) + push h + call opencom ;on default drive & user + pop h + pop b + jz exec0 ;try next if open unsuccessful +; +; successful open, now jump to processor +; +exec2: + if dayfile + lxi b,display + call getflg + jz exec21 + ldax d + call dirdrv0 + mvi a,':' + call pfc + push d + call pfn + pop d + push d + lxi h,8 + dad d + mov a,m + ani 80h + lxi d,userzero + cnz pmsg + call crlf + pop d + endif +exec21: pop psw ;recover saved command type + lxi h,xptbl +; +; table jump +; +; entry: hl = address of table of addresses +; a = entry # (0 thru n-1) +; +tblj: add a ;adjust for two byte entries + call addhla ;compute address of entry + push d + mov e,m ;fetch entry + inx h + mov d,m + xchg + pop d + pchl ;jump to it +; +typtbl: db 'COM ' + db 'SUB ' + db 'PRL ' + db 0 +; +xptbl: dw xcom + dw xsub + dw xcom + + +; +; unsuccessful attempt to open command file +; +exec3: pop b ;recover drive + mov a,c + stax d ;replace in fcb + ret +; +; +settype: + ;set file type specified from type table + ;a = offset (x2) of desired type (in bytes) + rrc + lxi h,typtbl + call addhla ;hl = type in type table + lxi d,fcb+9 + mvi c,3 + jmp move ;move type into fcb +; +; +; +; EXECUTE COM FILE +; +xcom: ;DE = .fcb + ; + ; set up FCB for loader to use + ; + lxi h,tpa + shld fcbrr ;set load address to 100h + lhld realdos-1 ;put fcb in the loader's stack + dcr h ;page below LOADER (or bottom RSX) + mvi l,0C0h ;offset for FCB in page below the BDOS + push h ;save for LOADER call + ldax d ;get drive from fcb(0) + sta cmdrv ;set command drive field in base page + xchg + mvi c,35 + call move ;now move FCB to the top of the TPA + ; + ; set up base page + ; + lxi h,errflg ;tell parser to ignore errors + inr m +xcom3: lhld parsep + dcx h ;backup over delimiter + lxi d,buf+1 + xchg + shld parsep ;set parser to 81h + call copy0 ;copy command tail to 81h with + ;terminating 0 (returns A=length) + sta buf ;put command tail length at 80h +xcom5: call gfn ;parse off first argument + shld pass0 + mov a,b + sta len0 + lxi d,dfcb1 + call gfn0 ;parse off second argument + shld pass1 + mov a,b + sta len1 +xcom7: lxi h,chaindsk ;.CHAINDSK + mov a,m + ora a + cp select + lda usernum + call setuser ;set default user, returns H=SCB + add a ;shift user to high nibble + add a + add a + add a + mvi l,seldsk + ora m ;put disk in low nibble + sta defdrv ;set location 4 + ; + ; initialize stack + ; +xcom8: pop d ;DE = .fcb + lhld realdos-1 ;base page of BDOS + xra a + mov l,a ;top of stack below BDOS + sphl ;change the stack pointer for CCP + mov h,a ;push warm start address on stack + push h ;for programs returning to the CCP + inr h ;Loader will return to TPA + push h ;after loading a transient program + ; + ; initialize fcb0(CR), console mode, program return code + ; & removable media open and login vectors + ; +xcom9: sta 7ch ;clear next record to read + mvi b,con$mode + call setbyte ;set to zero (turn off ^C status) + mvi l,olog + mov m,a ;zero removable open login vector + inx h + mov m,a + inx h + mov m,a ;zero removable media login vector + inx h + mov m,a + mvi l,ccpflag1 + mov a,m + ani chain$flg ;chaining? + jnz loader ;load program without clearing + mvi l,prog$ret$code ;the program return code + mov m,a ;A=0 + inx h + mov m,a ;set program return = 0000h + ; + ; call loader + ; +loader: + mov a,m ;reset chain flag if set, + ani not$chainflg ;has no effect if we fell through + mov m,a + mvi c,loadf ;use load RSX to load file + jmp bdos ;now load it +; +; +; +; +;************************************************************************ +; +; BDOS FUNCTION INTERFACE - Non FCB functions +; +;************************************************************************ +; +; +; +;;----------------------------------------------------------------------- +;; +;; +;; +;; print character on terminal +;; pause if screen is full +;; (BDOS function #2) +;; +;; entry: a = character (putc entry) +;; e = character (putc2 entry) +;; + +putc: cpi lf ;end of line? + jnz putc1 ;jump if not + lxi h,pgsize ;.pgsize + mov a,m ;check page size + inx h ;.line + inr m ;line=line+1 + sub m ;line=page? + jnz putc0 + mov m,a ;reset line=0 if so + inx h ;.pgmode + mov a,m ;is page mode off? + ora a ;page=0 if so + lxi d,more + cz getc ;wait for input if page mode on + cpi ctrlc + jz ccpcr + mvi e,cr + call putc2 ;print a cr +putc0: mvi a,lf ;print the end of line char +putc1: mov e,a +putc2: mvi c,coutf + jmp bdos + +;; +;;----------------------------------------------------------------------- +;; +;; get character from console +;; (BDOS function #1) +;; +getc: call pmsg +getc1: mvi c,cinf + jmp bdos +;; +;;----------------------------------------------------------------------- +;; +;; print message string on terminal +;; (BDOS function #9) +;; +pmsg: mvi c,pbuff + jmp bdos +;; +;;----------------------------------------------------------------------- +;; +;; read line from console +;; (calls BDOS function #10) +;; +;; exit: z = set if null line +;; +;; This function uses the buffer "cbuf" (see definition of +;; function 10 for a description of the buffer). All input +;; is converted to upper case after reading and the pointer +;; "parsep" is set to the begining of the first non-white +;; character string. +;; +rcln: lxi h,cbufmx ;get line from terminal + mvi m,comlen ;set maximum buffer size + xchg + mvi c,rbuff + call bdos + lxi h,cbufl ;terminate line with zero byte + mov a,m + inx h + call addhla + mvi m,0 ;put zero at the end + jmp crlf ;advance to next line +; +;; +;;----------------------------------------------------------------------- +;; +;; exit routine if keyboard struck +;; (calls BDOS function #11) +;; +;; Control is returned to the caller unless the console +;; keyboard has a character ready, in which case control +;; is transfer to the main program of the CCP. +;; +break: call break1 + rz + jmp ccpcr + +break1: mvi c,cstatf + call rw + rz + mvi c,cinf + jmp rw + + +;; +;;----------------------------------------------------------------------- +;; +;; set disk buffer address +;; (BDOS function #26) +;; +;; entry: de -> buffer ("setbuf" only) +;; +sbuf80: lxi d,buf +setbuf: mvi c,dmaf + jmp bdos +;; +;;----------------------------------------------------------------------- +;; +;; select disk +;; (BDOS function #14) +;; +;; entry: a = drive +;; +select: + mov e,a + mvi c,self + jmp bdos +; +;; +;;----------------------------------------------------------------------- +;; +;; set user number +;; (BDOS function #32) +;; +;; entry: a = user # +;; exit: H = SCB page +;; +setuser: + mvi b,usrcode + jmp set$byte +; +; +; +;************************************************************************ +; +; BDOS FUNCTION INTERFACE - Functions with a FCB Parameter +; +;************************************************************************ +; +; +;; +;; open file +;; (BDOS function #15) +;; +;; exit: z = set if file not found +;; +;; +opencom: ;open command file (SUB, COM or PRL) + lxi b,openf ;b=0 => return error mode of 0 + lxi d,fcb ;use internal FCB + +;; BDOS CALL ENTRY POINT (used by built-ins) +;; +;; entry: b = return error mode (must be 0 or 0ffh) +;; c = function no. +;; de = .fcb +;; exit: z = set if error +;; de = .fcb +;; +bdosf: lxi h,32 ;offset to current record + dad d ;HL = .current record + mvi m,0 ;set to zero for read/write + push b ;save function(C) & error mode(B) + push d ;save .fcb + ldax d ;was a disk specified? + ana b ;and with 0 or 0ffh + dcr a ;if so, select it in case + cp select ;of permanent error (if errmode = 0ffh) + lxi d,passwd + call setbuf ;set dma to password + pop d ;restore .fcb + pop b ;restore function(C) & error mode(B) + push d + lhld scbaddr + mvi l,errormode + mov m,b ;set error mode + push h ;save .errormode + call bdos + pop d ;.errormode + xra a + stax d ;reset error mode to 0 + lda disk + mvi e,seldsk + stax d ;reset current disk to default + push h ;save bdos return values + call sbuf80 + pop h ;bdos return + inr l ;set z flag if error + pop d ;restore .fcb + ret +;; +;;----------------------------------------------------------------------- +;; +;; close file +;; (BDOS function #16) +;; +;; exit: z = set if close error +;; +;;close: mvi c,closef +;; jmp oc +;; +;;----------------------------------------------------------------------- +;; +;; delete file +;; +;; exit: z = set if file not found +;; +;; The match any character "?" may be used without restriction +;; for this function. All matched files will be deleted. +;; +;; +;;delete: +;; mvi c,delf +;; jmp oc +;; +;;----------------------------------------------------------------------- +;; +;; create file +;; (BDOS function #22) +;; +;; exit: z = set if create error +;; +;;make: mvi c,makef +;; jmp oc +;;----------------------------------------------------------------------- +;; +;; search for first filename match (using "DFCB" and "BUF") +;; (BDOS function #17) +;; +;; exit: z = set if no match found +;; z = clear if match found +;; de -> directory entry in buffer +;; +srchf: mvi c,searf ;set search first function + jmp srch +;; +;;----------------------------------------------------------------------- +;; +;; search for next filename match (using "DFCB" and "BUF") +;; (BDOS function #18) +;; +;; exit: z = set if no match found +;; z = clear if match found +;; de -> directory entry in buffer +;; +srchn: mvi c,searnf ;set search next function +srch: lxi d,dfcb ;use default fcb + call bdos + inr a ;return if not found + rz + dcr a ;restore original return value + add a ;shift to compute buffer pos'n + add a + add a + add a + add a + lxi h,buf ;add to buffer start address + call addhla + xchg ;de -> entry in buffer + xra a ;may be needed to clear z flag + dcr a ;depending of value of "buf" + ret +;; +;;----------------------------------------------------------------------- +;; +;; read file +;; (BDOS function #20) +;; +;; entry: hl = buffer address (readb only) +;; exit z = set if read ok +;; +read: xra a ;clear getc pointer + sta bufp + mvi c,readf + lxi d,dfcb +rw: call bdos + ora a + ret +; +;; +;;----------------------------------------------------------------------- +;; +;; $$$.SUB interface +;; +;; entry: c = bdos function number +;; exit z = set if successful + +sudos: lxi d,subfcb + jmp rw +; +; +; +;************************************************************************ +; +; COMMAND LINE PARSING SUBROUTINES +; +;************************************************************************ +; +;------------------------------------------------------------------------ +; +; COMMAND LINE PREPARSER +; reset function 10 flag +; set up parser +; convert to upper case +; +; All input is converted to upper case and the pointer +; "parsep" is set to the begining of the first non-blank +; character string. If the line begins with a ; or :, it +; is treated specially: +; +; ; comment the line is ignored +; : conditional the line is ignored if a fatal +; error occured during the previous +; command, otherwise the : is +; ignored +; +; An exclamation point is used to separate multiple commands on a +; a line. Two adjacent exclaimation points translates into a single +; exclaimation point in the command tail for compatibility. +;------------------------------------------------------------------------ +; +; +uc: + call resetccpflg + xchg ;DE = .SCB + xra a + sta option ;zero option flag + lxi h,cbuf + call skps1 ;skip leading spaces/tabs + xchg + cpi ';' ;HL = .scb + rz + cpi '!' + jz uc0 + cpi ':' + jnz uc1 + mvi l,prog$ret$code + inr m + inr m ;was ^C typed? (low byte 0FEh) + jz uc0 ;successful, if so + inx h + inr m ;is high byte 0FFh? + rz ;skip command, if so +uc0: inx d ;skip over 1st character +uc1: xchg ;HL=.command line + shld parsep ;set parse pointer to beginning of line +uc3: mov a,m ;convert lower case to upper + cpi '[' + jnz uc4 + sta option ;'[' is the option delimiter => command option +uc4: cpi 'a' + jc uc5 + cpi 'z'+1 + jnc uc5 + sui 'a'-'A' + mov m,a +uc5: + if multi + cpi '!' + cz multistart ;HL=.char, A=char + endif + inx h ;advance to next character + ora a ;loop if not end of line + jnz uc3 +; +; skip spaces +; return with zero flag set if end of line +; +skps: lhld parsep ;get current position +skps1: shld parsep ;save position + shld errorp ;save position for error message + mov a,m + ora a ;return if end of command + rz + cpi ' ' + jz skps2 + cpi tab ;skip spaces & tabs + rnz +skps2: inx h ;advance past space/tab + jmp skps1 ;loop +; +;----------------------------------------------------------------------- +; +; MULTIPLE COMMANDS PER LINE HANDLER +; +;----------------------------------------------------------------------- + if multi + +multistart: + ; + ; A = current character in command line + ; HL = address of current character in command line + ; + ;double exclaimation points become one + mov e,l + mov d,h + inx d + ldax d + cpi '!' ;double exclaimation points + push psw + push h + cz copy0 ;convert to one, if so + pop h + pop psw + rz + ;we have a valid multiple command line + mvi m,0 ;terminate command line here + xchg + ;multiple commands not allowed in submits + ;NOTE: submit unravels multiple commands making the + ;following test unnecessary. However, with GET[system] + ;or CP/M 2.2 SUBMIT multiple commands will be posponed + ;until the entire submit completes... +; call subtest ;submit active +; mvi a,0 +; rnz ;return with A=0, if so + ;set up the RSX buffer + lhld osbase ;get high byte of TPA address + dcr h ;subtract 1 page for buffer + mvi l,endchain ;HL = RSX buffer base-1 + mov m,a ;set end of chain flag to 0 + push h ;save it +multi0: inx h + inx d + ldax d ;get character from cbuf + mov m,a ;place in RSX + cpi '!' + jnz multi1 + mvi m,cr ;change exclaimation point to cr +multi1: ora a + jnz multi0 + mvi m,cr ;end last command with cr + inx h + mov m,a ;terminate with a zero + ;set up RSX prefix + mvi l,6 ;entry point + mvi m,jmp ;put a jump instruction there + inx h + mvi m,9 ;make it a jump to base+9 (RSX exit) + inx h + mov m,h + inx h ;HL = RSX exit point + mvi m,jmp ;put a jump instruction there + mvi l,warmflg ;HL = remove on warm start flag + mov m,a ;set (0) for RSX to remain resident + mov l,a ;set low byte to 0 for fixchain + xchg ;DE = RSX base + call fixchain ;add the RSX to the chain + ;save buffer address + lhld scbaddr + mvi l,ccpconbuf ;save buffer address in CCP conbuf field + pop d ;DE = RSX base + inx d + mov m,e + inx h + mov m,d + mvi l,multi$rsx$pg + mov m,d ;save the RSX base + xra a ;zero in a to fall out of uc + ret + ; + ; + ; save the BDOS conbuffer address and + ; terminate RSX if necessary. + ; +multisave: + lxi d,conbuffer*256+ccpconbuf + call wordmov ;first copy conbuffer in case SUBMIT + ora a ;and/or GET are active + lxi d,conbuffl*256+ccpconbuf + cz wordmov ;if conbuff is zero then conbufl has the + push h ;next address + call break1 + pop h ;H = SCB page + mvi l,ccpconbuf + jnz multiend + mov e,m + inx h + mov d,m ;DE = next conbuffer address + inr m + dcr m ;is high byte zero? + dcx h ;HL = .ccpconbuf + jz multiend ;remove multicmd RSX if so + ldax d ;check for terminating zero + ora a + rnz ;return if not + ; + ; we have exhausted all the commands +multiend: + ; HL = .ccpconbuf + xra a + mov m,a ;set buffer to zero + inx h + mov m,a + mvi l,multi$rsx$pg + mov h,m + mvi l,0eh ;HL=RSX remove on warmstart flag + dcr m ;set to true for removal + jmp rsx$chain ;remove the multicmd rsx buffer + + endif +;; +;************************************************************************ +; +; FILE NAME PARSER +; +;************************************************************************ +; +; +; +; get file name (read in if none present) +; +; +;; The file-name parser in this CCP implements +;; a user/drive specification as an extension of the normal +;; CP/M drive selection feature. The syntax of the +;; user/drive specification is given below. Note that a +;; colon must follow the user/drive specification. +;; +;; : is an alphabetic character A-P specifing one +;; of the CP/M disk drives. +;; +;; : is a decimal number 0-15 specifying one of the +;; user areas. +;; +;; : A specification of both user area and drive. +;; +;; : Synonymous with above. +;; +;; Note that the user specification cannot be included +;; in the parameters of transient programs or precede a file +;; name. The above syntax is parsed by gcmd (get command). +;; +;; ************************************************************ + +getfn: + if prompts + lxi d,fnmsg +getfn0: + call getprm + endif +gfn: lxi d,dfcb +gfn0: call skps ;sets zero flag if eol + push psw + call gfn2 + pop psw + ret + ; + ; BDOS FUNCTION 152 INTERFACE + ; + ;entry: DE = .FCB + ; HL = .buffer + ;flags/A reg preserved + ;exit: DE = .FCB + ; + ; +gfn2: shld parsep + shld errorp + push d ;save .fcb + lxi d,pfncb + mvi c,parsef +if func152 + call bdos +else + call parse +endif + pop d ;.fcb + mov a,h + ora l ;end of command? (HL = 0) + mov b,m ;get delimiter + inx h ;move past delimiter + jnz gfn3 + lxi h,zero+2 ;set HL = .0 +gfn3: mov a,h + ora l ;parse error? (HL = 0ffffh) + jnz gfn4 + lxi h,zero+2 + call perror +gfn4: mov a,b + cpi '.' + jnz gfn6 + dcx h +gfn6: shld parsep ;update parse pointer +gfnpwd: mvi c,16 + lxi h,pfcb + push d + call move + lxi d,passwd ;HL = .disk map in pfcb + mvi c,10 + call move ;copy to passwd + pop d ;HL = .password len + mov a,m +zero: lxi h,0 ;must be an "lxi h,0" + ora a ;is there a password? + mov b,a + jz gfn8 + lhld errorp ;HL = .filename +gfn7: mov a,m + cpi ';' + inx h + jnz gfn7 +gfn8: ret ;B = len, HL = .password + +; +; PARSE CP/M 3 COMMAND +; entry: DE = .UFCB (user no. byte in front of FCB) +; PARSEP = .command line +gcmd: + push d + xra a + stax d ;clear user byte + inx d + stax d ;clear drive byte + inx d + call skps ;skip leading spaces +; +; Begin by looking for user/drive-spec. If none if found, +; fall through to main file-name parsing section. If one is found +; then branch to the section that handles them. If an error occurs +; in the user/drive spec; treat it as a filename for compatibility +; with CP/M 2.2. (e.g. STAT VAL: etc.) +; + lhld parsep ;get pointer to current parser position + pop d + push d ;DE = .UFCB + mvi b,4 ;maximum length of user/drive spec +gcmd1: mov a,m ;get byte + cpi ':' ;end of user/drive-spec? + jz gcmd2 ;parse user/drive if so + ora a ;end of command? + jz gcmd8 ;parse filename (Func 152), if so + dcr b ;maximum user/drive spec length exceeded? + inx h + jnz gcmd1 ;loop if not + ; + ; Parse filename, type and password + ; +gcmd8: + pop d + xra a + stax d ;set user = default + lhld parsep +gcmd9: inx d ;past user number byte + ldax d ;A=drive + push psw + call gfn2 ;BDOS function 152 interface + pop psw + stax d + ret + ; + ; Parse the user/drive-spec + ; +gcmd2: + lhld parsep ;get pointer to beginning of spec + mov a,m ;get character +gcmd3: cpi '0' ;check for user number + jc gcmd4 ;jump if not numeric + cpi '9'+1 + jnc gcmd4 + call gdns ;get the user # (returned in B) + pop d + push d + ldax d ;see if we already have a user # + ora a + jnz gcmd8 ;skip if we do + mov a,b ;A = specified user number + inr a ;save it as the user-spec + stax d + jmp gcmd5 +gcmd4: cpi 'A' ;check for drive-spec + jc gcmd8 ;skip if not a valid drive character + cpi 'P'+1 + jnc gcmd8 + pop d + push d + inx d + ldax d ;see if we already have a drive + ora a + jnz gcmd8 ;skip if so + mov a,m + sui '@' ;convert to a drive-spec + stax d + inx h +gcmd5: mov a,m ;get next character + cpi ':' ;end of user/drive-spec? + jnz gcmd3 ;loop if not + inx h + pop d ;.ufcb + jmp gcmd9 ;parse the file name + + +; +;************************************************************************ +; +; TEMPORARY PARSE CODE +; +;************************************************************************ +; +if not func152 +; version 3.0b Oct 08 1982 - Doug Huskey +; +; + +passwords equ true + +parse: ; DE->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks (left justified) + ; 9-11 => type, converted to upper case, + ; padded with blanks (left justified) + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if DE locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; + xchg + mov e,m ;get first parameter + inx h + mov d,m + push d ;save .filename + inx h + mov e,m ;get second parameter + inx h + mov d,m + pop h ;DE=.fcb HL=.filename + xchg +parse0: + push h ;save .fcb + xra a + mov m,a ;clear drive byte + inx h + lxi b,20h*256+11 + call pad ;pad name and type w/ blanks + lxi b,4 + call pad ;EXT, S1, S2, RC = 0 + lxi b,20h*256+8 + call pad ;pad password field w/ blanks + lxi b,12 + call pad + call skip +; +; check for drive +; + ldax d + cpi ':' ;is this a drive? + dcx d + pop h + push h ;HL = .fcb + jnz parse$name +; +; Parse the drive-spec +; +parsedrv: + ldax d ;get character + ani 5fh ;convert to upper case + sui 'A' + jc perr1 + cpi 16 + jnc perr1 + inx d + inx d ;past the ':' + inr a ;set drive relative to 1 + mov m,a ;store the drive in FCB(0) +; +; Parse the file-name +; +parse$name: + inx h ;HL = .fcb(1) + call delim + jz parse$ok +if passwords + lxi b,7*256 +else + mvi b,7 +endif +parse6: ldax d ;get a character + cpi '.' ;file-type next? + jz parse$type ;branch to file-type processing + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse6 ;loop if not end of name + jmp parse$ok +; +; Parse the file-type +; +parse$type: + inx d ;advance past dot + pop h + push h ;HL =.fcb + lxi b,9 + dad b ;HL =.fcb(9) +if passwords + lxi b,2*256 +else + mvi b,2 +endif +parse8: ldax d + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse8 ;loop if not end of type +; +parse$ok: + pop b + push d + call skip + call delim + pop h + rnz + lxi h,0 + ora a + rz + cpi cr + rz + xchg + ret +; +; handle parser error +; +perr: + pop b ;throw away return addr +perr1: + pop b + lxi h,0ffffh + ret +; +if passwords +; +; Parse the password +; +parsepw: + inx d + pop h + push h + lxi b,16 + dad b + lxi b,7*256+1 +parsepw1: + call gfc + jnz parsepw1 + mvi a,7 + sub b + pop h + push h + lxi b,26 + dad b + mov m,a + ldax d ;delimiter in A + jmp parse$ok +else +; +; skip over password +; +parsepw: + inx d + call delim + jnz parsepw + jmp parse$ok +endif +; +; get next character of name, type or password +; +gfc: call delim ;check for end of filename + rz ;return if so + cpi ' ' ;check for control characters + inx d + jc perr ;error if control characters encountered + inr b ;error if too big for field + dcr b + jm perr +if passwords + inr c + dcr c + jnz gfc1 +endif + cpi '*' ;trap "match rest of field" character + jz setwild +gfc1: mov m,a ;put character in fcb + inx h + dcr b ;decrement field size counter + ora a ;clear zero flag + ret +;; +setwild: + mvi m,'?' ;set match one character + inx h + dcr b + jp setwild + ret +; +; skip spaces +; +skip0: inx d +skip: ldax d + cpi ' ' ;skip spaces & tabs + jz skip0 + cpi tab + jz skip0 + ret +; +; check for delimiter +; +; entry: A = character +; exit: z = set if char is a delimiter +; +delimiters: db cr,tab,' .,:;[]=<>|',0 + +delim: ldax d ;get character + push h + lxi h,delimiters +delim1: cmp m ;is char in table + jz delim2 + inr m + dcr m ;end of table? (0) + inx h + jnz delim1 + ora a ;reset zero flag +delim2: pop h + rz + ; + ; not a delimiter, convert to upper case + ; + cpi 'a' + rc + cpi 'z'+1 + jnc delim3 + ani 05fh +delim3: ani 07fh + ret ;return with zero set if so +; +; pad with blanks +; +pad: mov m,b + inx h + dcr c + jnz pad + ret +; +endif +; +; +;************************************************************************ +; +; SUBROUTINES +; +;************************************************************************ +; + if multi +; +; copy SCB memory word +; d = source offset e = destination offset +; +wordmov: + lhld scbaddr + mov l,d + mov d,h + mvi c,2 +; + endif +; +; copy memory bytes +; de = destination hl = source c = count +; +move: + mov a,m + stax d ;move byte to destination + inx h + inx d ;advance pointers + dcr c ;loop if non-zero + jnz move + ret +; +; copy memory bytes with terminating zero +; hl = destination de = source +; returns c=length + +copy0: mvi c,0 +copy1: ldax d + mov m,a + ora a + mov a,c + rz + inx h + inx d + inx b + jmp copy1 + +;; +;;----------------------------------------------------------------------- +;; +;; get byte from file +;; +;; exit: z = set if byte gotten +;; a = byte read +;; z = clear if error or eof +;; a = return value of bdos read call +;; +getb: xra a ;clear accumulator + lxi h,bufp ;advance buffer pointer + inr m + cm read ;read sector if buffer empty + ora a + rnz ;return if read error or eof + lda bufp ;compute pointer into buffer + lxi h,buf + call addhla + xra a ;set zero flag + mov a,m ;get byte + ret +;; +;;----------------------------------------------------------------------- +;; +;; +;; system control block flag routines +;; +;; entry: c = bit mask (1 bit on) +;; b = scb byte offset +;; +subtest: + lxi b,submit +getflg: +; return flag value +; exit: zero flag set if flag reset +; c = bit mask +; hl = flag byte address +; + lhld scbaddr + mov l,b + mov a,m + ana c ; a = bit + ret +; +setccpflg: + lxi b,ccp10 + +; +setflg: +; set flag on (bit = 1) +; + call getflg + mov a,c + ora m + mov m,a + ret +; +resetccpflg: + lxi b,ccp10 +; +resetflg: +; reset flag off (bit = 0) +; + call getflg + mov a,c + cma + ana m + mov m,a + ret +;; +;; +;; SET/GET SCB BYTE +;; +;; entry: A = byte ("setbyte" only) +;; B = SCB byte offset from page +;; +;; exit: A = byte ("getbyte" only) +;; +setbyte: + lhld scbaddr + mov l,b + mov m,a + ret +; +getbyte: + lhld scbaddr + mov l,b + mov a,m + ret +; + + + +;;----------------------------------------------------------------------- +;; +;; +;; print message followed by newline +;; +;; entry: de -> message string +;; +pmsgnl: call pmsg +; +; print crlf +; +dirln: mov b,l ;number of columns for DIR +crlf: mvi a,cr + call pfc + mvi a,lf + jmp pfc +;; +;;----------------------------------------------------------------------- +;; +;; print decimal byte +;; +pdb: sui 10 + jc pdb2 + mvi e,'0' +pdb1: inr e + sui 10 + jnc pdb1 + push psw + call putc2 + pop psw +pdb2: adi 10+'0' + jmp putc +;;----------------------------------------------------------------------- +;; +;; +;; print string terminated by 0 or char in c +;; +pstrg: mov a,m ;get character + ora a + rz + cmp c + rz + call pfc ;print character + inx h ;advance pointer + jmp pstrg ;loop +;; +;;----------------------------------------------------------------------- +;; +;; check for end of command (error if extraneous parameters) +;; +eoc: call skps + rz +; +; handle parser error +; +perror: + lxi h,errflg + mov a,m + ora a ;ignore error???? + mvi m,0 ;clear error flag + rnz ;yes...just return to CCPRET + lhld errorp ;get pointer to what we're parsing + mvi c,' ' + call pstrg +perr2: mvi a,'?' ;print question mark + call putc + jmp ccpcr +; +;;----------------------------------------------------------------------- +;; +;; +;; print error message and exit processor +;; +;; entry: bc -> error message +;; +;;msgerr: push b +;; call crlf +;; pop d +;; jmp pmsgnl +;; +;;----------------------------------------------------------------------- +;; +;; get decimal number (0 <= N <= 255) +;; +;; exit: a = number +;; +gdn: call skps ;skip initial spaces + lhld parsep ;get pointer to current character + shld errorp ;save in case of parsing error + rz ;return if end of command + mov a,m ;get it + cpi '0' ;error if non-numeric + jc perror + cpi '9'+1 + jnc perror + call gdns ;convert number + shld parsep ;save new position + ori 1 ;clear zero and carry flags + mov a,b + ret +; +gdns: mvi b,0 +gdns1: mov a,m + sui '0' + rc + cpi 10 + rnc + push psw + mov a,b ;multiply current accumulator by 10 + add a + add a + add b + add a + mov b,a + pop psw + inx h ;advance to next character + add b ;add it in to the current accumulation + mov b,a + cpi 16 + jc gdns1 ;loop unless >=16 + jmp perror ;error if invalid user number +;; +;;----------------------------------------------------------------------- +;; +;; print file name +;; + if newdir +pfn: inx d ;point to file name + mvi h,8 ;set # characters to print, clear # printed + call pfn1 ;print name field + call space + mvi h,3 ;set # characters to print +pfn1: ldax d ;get character + ani 7fh + call pfc ;print it if not + inx d ;advance pointer + dcr h ;loop if more to print + jnz pfn1 + ret +; +space: mvi a,' ' +; +pfc: push b + push d + push h + call putc + pop h + pop d + pop b + ret + + else + +pfn: inx d ;point to file name + lxi b,8*256 ;set # characters to print, clear # printed + call pfn1 ;print name field + ldax d ;see if there's a type + ani 7fh + cpi ' ' + rz ;return if not + mvi a,'.' ;print dot + call pfc + mvi b,3 ;set # characters to print +pfn1: ldax d ;get character + ani 7fh + cpi ' ' ;is it a space? + cnz pfc ;print it if not + inx d ;advance pointer + dcr b ;loop if more to print + jnz pfn1 + ret +; +space: mvi a,' ' +; +pfc: inr c ;increment # characters printed + push b + push d + call putc + pop d + pop b + ret + endif +;; +;;----------------------------------------------------------------------- +;; +;; add a to hl +;; +addhla: add l + mov l,a + rnc + inr h + ret +;; +;;----------------------------------------------------------------------- +;; +;; set match-any string into fcb +;; +;; entry: de -> fcb area +;; b = # bytes to set +;; +setmatch: + mvi a,'?' ;set match one character +setm1: stax d ;fill rest of field with match one + inx d + dcr b ;loop if more to fill + jnz setm1 + ora a + ret +;; +;;----------------------------------------------------------------------- +;; +;; table search +;; +;; Search table of strings separated by spaces and terminated +;; by 0. Accept abbreviations, but set string = matched string +;; on exit so that we don't try to execute abbreviation. +;; +;; entry: de -> string to search for +;; hl -> table of strings to match (terminate table with 0) +;; exit: z = set if match found +;; a = entry # (0 thru n-1) +;; z = not set if no match found +;; +tbls: lxi b,0ffh ;clear entry & entry length counters +tbls0: push d ;save match string addr + push h ;save table string addr +tbls1: ldax d ;compare bytes + ani 7fh ;kill upper bit (so SYS + R/O match) + cpi ' '+1 ;end of search string? + jc tbls2 ;skip compare, if so + cmp m + jnz tbls3 ;jump if no match +tbls2: inx d ;advance string pointer + inr c ;increment entry length counter + mvi a,' ' + cmp m + inx h ;advance table pointer + jnz tbls1 ;continue with this entry if more + pop h ;HL = matched string in table + pop d ;DE = string address + call move ; C = length of string in table + mov a,b ;return current entry counter value + ret +; +tbls3: mvi a,' ' ;advance hl past current string +tbls4: cmp m + inx h + jnz tbls4 + pop d ;throw away last table address + pop d ;DE = string address + inr b ;increment entry counter + mvi c,0ffh + mov a,m ;check for end of table + sui 1 + jnc tbls0 ;loop if more entries to test + ret +; +;************************************************************************ +;************************************************************************ +; +;************************************************************************ +; +; DATA AREA +; +;************************************************************************ +; ;Note uninitialized data placed at the end (DS) +; +; + if prompts +enter: db 'Enter $' +unmsg: db 'User #: $' +fnmsg: db 'File: $' + else +unmsg: db 'Enter User #: $' + endif +nomsg: db 'No File$' +required: + db ' required$' +eramsg: + db 'ERASE $' +confirm: + db ' (Y/N)? $' +more: db cr,lf,cr,lf,'Press RETURN to Continue $' + if dayfile +userzero db ' (User 0)$' + endif +; +; +; + if newdir +anyfiles: db 0 ;flag for SYS or DIR files exist +dirfiles: db 'NON-' +sysfiles: db 'SYSTEM FILE(S) EXIST$' + endif + +errflg: db 0 ;parse error flag + if multi +multibufl: + dw 0 ;multiple commands buffer length + endif +scbadd: db scbad-pag$off,0 + ;********** CAUTION FOLLOWING DATA MUST BE IN THIS ORDER ********* +pfncb: ;BDOS func 152 (parse filename) +parsep: dw 0 ;pointer to current position in command +pfnfcb: dw pfcb ;.fcb for func 152 +usernum: ;CCP current user + db 0 +chaindsk: + db 0 ;transient's current disk +disk: db 0 ;CCP current disk +subfcb: db 1,'$$$ SUB',0 +ccpend: ;end of file (on disk) + ds 1 +submod: ds 1 +subrc: ds 1 + ds 16 +subcr: ds 1 +subrr: ds 2 +subrr2: ds 1 + +dircols: + ds 1 ;number of columns for DIR/DIRS +pgsize: ds 1 ;console page size +line: ds 1 ;console line # +pgmode: ds 1 ;console page mode + ;***************************************************************** +errorp: ds 2 ;pointer to beginning of current param. +errsav: ds 2 ;pointer to built-in command tail +bufp: ds 1 ;buffer pointer for getb +realdos: + ds 1 ;base page of BDOS +; +option: ds 1 ;'[' in line? +passwd: ds 10 ;password +ufcb: ds 1 ;user number (must procede fcb) +FCB: + ds 1 ; drive code + ds 8 ; file name + ds 3 ; file type + ds 4 ; control info + ds 16 ; disk map +fcbcr: ds 1 ; current record +fcbrr: ds 2 ; random record +pfcb: ds 36 ; fcb for parsing +; +; +; +; +; command line buffer +; +cbufmx: ds 1 +cbufl: ds 1 +cbuf: ds comlen + ds 50h +stack: +ccptop: ;top page of CCP + end + + \ No newline at end of file diff --git a/software/CPM/cpm3/ccpdate.asm b/software/CPM/cpm3/ccpdate.asm new file mode 100644 index 0000000..d401785 --- /dev/null +++ b/software/CPM/cpm3/ccpdate.asm @@ -0,0 +1,8 @@ + org 368h + + maclib makedate + db ' ' + @BDATE ;[JCE] Copyright & build date now in MAKEDATE.LIB + db ' ' + @SCOPY + diff --git a/software/CPM/cpm3/chario.asm b/software/CPM/cpm3/chario.asm new file mode 100644 index 0000000..0ac6754 --- /dev/null +++ b/software/CPM/cpm3/chario.asm @@ -0,0 +1,175 @@ + title 'Character I/O handler for z80 chip based system' + +; Character I/O for the Modular CP/M 3 BIOS + + ; limitations: + + ; baud rates 19200,7200,3600,1800 and 134 + ; are approximations. + + ; 9600 is the maximum baud rate that is likely + ; to work. + + ; baud rates 50, 75, and 110 are not supported + + + public ?cinit,?ci,?co,?cist,?cost + public @ctbl + + maclib Z80 ; define Z80 op codes + maclib ports ; define port addresses + maclib modebaud ; define mode bits and baud equates + +max$devices equ 6 + + cseg + +?cinit: + mov a,c ! cpi max$devices ! jz cent$init ; init parallel printer + rnc ; invalid device + mov l,c ! mvi h,0 ; make 16 bits from device number + push h ; save device in stack + dad h ! dad h ! dad h ; *8 + lxi d,@ctbl+7 ! dad d ! mov l,m ; get baud rate + mov a,l ! cpi baud$600 ; see if baud > 300 + mvi a,44h ! jnc hi$speed ; if >= 600, use *16 mode + mvi a,0C4h ; else, use *64 mode +hi$speed: + sta sio$reg$4 + mvi h,0 ! lxi d,speed$table ! dad d ; point to counter entry + mov a,m ! sta speed ; get and save ctc count + pop h ; recover + lxi d,data$ports ! dad d ; point at SIO port address + mov a,m ! inr a ! sta sio$port ; get and save port + lxi d,baud$ports-data$ports ! dad d ; offset to baud rate port + mov a,m ! sta ctc$port ; get and save + lxi h,serial$init$tbl + jmp stream$out + +cent$init: + lxi h,pio$init$tbl + +stream$out: + mov a,m ! ora a ! rz + mov b,a ! inx h ! mov c,m ! inx h + outir + jmp stream$out + + +?ci: ; character input + + mov a,b ! cpi 6 ! jnc null$input ; can't read from centronics +ci1: + call ?cist ! jz ci1 ; wait for character ready + dcr c ! inp a ; get data + ani 7Fh ; mask parity + ret + +null$input: + mvi a,1Ah ; return a ctl-Z for no device + ret + +?cist: ; character input status + + mov a,b ! cpi 6 ! jnc null$status ; can't read from centronics + mov l,b ! mvi h,0 ; make device number 16 bits + lxi d,data$ports ! dad d ; make pointer to port address + mov c,m ! inr c ; get SIO status port + inp a ; read from status port + ani 1 ; isolate RxRdy + rz ; return with zero + ori 0FFh + ret + +null$status: + xra a ! ret + +?co: ; character output + mov a,b ! cpi 6 ! jz centronics$out + jnc null$output + mov a,c ! push psw ; save character from + push b ; save device number +co$spin: + call ?cost ! jz co$spin ; wait for TxEmpty + pop h ! mov l,h ! mvi h,0 ; get device number in + lxi d,data$ports ! dad d ; make address of port address + mov c,m ; get port address + pop psw ! outp a ; send data +null$output: + ret + +centronics$out: + in p$centstat ! ani 20h ! jnz centronics$out + mov a,c ! out p$centdata ; give printer data + in p$centstat ! ori 1 ! out p$centstat ; set strobe + ani 7Eh ! out p$centstat ; clear strobe + ret + +?cost: ; character output status + mov a,b ! cpi 6 ! jz cent$stat + jnc null$status + mov l,b ! mvi h,0 + lxi d,data$ports ! dad d + mov c,m ! inr c + inp a ; get input status + ani 4 ! rz ; test transmitter empty + ori 0FFh ! ret ; return true if ready + + +cent$stat: + in p$centstat ! cma + ani 20h ! rz + ori 0FFh ! ret + +baud$ports: ; CTC ports by physical device number + db p$baud$con1,p$baud$lpt1,p$baud$con2,p$baud$con34 + db p$baud$con34,p$baud$lpt2 + +data$ports: ; serial base ports by physical device number + db p$crt$data,p$lpt$data,p$con2data,p$con3data + db p$con4data,p$lpt2data + + +@ctbl db 'CRT ' ; device 0, CRT port 0 + db mb$in$out+mb$serial+mb$softbaud + db baud$9600 + db 'LPT ' ; device 1, LPT port 0 + db mb$in$out+mb$serial+mb$softbaud+mb$xonxoff + db baud$9600 + db 'CRT1 ' ; device 2, CRT port 1 + db mb$in$out+mb$serial+mb$softbaud + db baud$9600 + db 'CRT2 ' ; device 3, CRT port 2 + db mb$in$out+mb$serial+mb$softbaud + db baud$9600 + db 'CRT3 ' ; device 4, CRT port 3 + db mb$in$out+mb$serial+mb$softbaud + db baud$9600 + db 'VAX ' ; device 5, LPT port 1 used for VAX interface + db mb$in$out+mb$serial+mb$softbaud + db baud$9600 + db 'CEN ' ; device 6, Centronics parallel printer + db mb$output + db baud$none + db 0 ; table terminator + + +speed$table db 0,255,255,255,233,208,104,208,104,69,52,35,26,17,13,7 + +serial$init$tbl + db 2 ; two bytes to CTC +ctc$port ds 1 ; port address of CTC + db 47h ; CTC mode byte +speed ds 1 ; baud multiplier + db 7 ; 7 bytes to SIO +sio$port ds 1 ; port address of SIO + db 18h,3,0E1h,4 +sio$reg$4 ds 1 + db 5,0EAh + db 0 ; terminator + +pio$init$tbl db 2,p$zpio$2b,0Fh,07h + db 3,p$zpio$2a,0CFh,0F8h,07h + db 0 + + end diff --git a/software/CPM/cpm3/comlit.lit b/software/CPM/cpm3/comlit.lit new file mode 100644 index 0000000..d36e91d --- /dev/null +++ b/software/CPM/cpm3/comlit.lit @@ -0,0 +1,16 @@ +declare + lit literally 'literally', + dcl lit 'declare', + true lit '0ffh', + false lit '0', + boolean lit 'byte', + forever lit 'while true', + cr lit '13', + lf lit '10', + tab lit '9', + ctrlc lit '3', + ff lit '12', + date$flag$offset lit '0ch', /* [JCE] UK dates? */ + page$len$offset lit '1ch', + nopage$mode$offset lit '2Ch', + sectorlen lit '128'; diff --git a/software/CPM/cpm3/conbdos.asm b/software/CPM/cpm3/conbdos.asm new file mode 100644 index 0000000..0de381e --- /dev/null +++ b/software/CPM/cpm3/conbdos.asm @@ -0,0 +1,908 @@ + title 'CP/M Bdos Interface, Bdos, Version 3.0 Nov, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** C o n s o l e P o r t i o n ** +;** ** +;***************************************************************** +;***************************************************************** +; +; November 1982 +; +; +; Console handlers +; +conin: + ;read console character to A + lxi h,kbchar! mov a,m! mvi m,0! ora a! rnz + ;no previous keyboard character ready + jmp coninf ;get character externally + ;ret +; +conech: + LXI H,STA$RET! PUSH H +CONECH0: + ;read character with echo + call conin! call echoc! JC CONECH1 ;echo character? + ;character must be echoed before return + push psw! mov c,a! call tabout! pop psw + RET +CONECH1: + CALL TEST$CTLS$MODE! RNZ + CPI CTLS! JNZ CONECH2 + CALL CONBRK2! JMP CONECH0 +CONECH2: + CPI CTLQ! JZ CONECH0 + CPI CTLP! JZ CONECH0 + RET +; +echoc: + ;echo character if graphic + ;cr, lf, tab, or backspace + cpi cr! rz ;carriage return? + cpi lf! rz ;line feed? + cpi tab! rz ;tab? + cpi ctlh! rz ;backspace? + cpi ' '! ret ;carry set if not graphic +; +CONSTX: + LDA KBCHAR! ORA A! JNZ CONB1 + CALL CONSTF! ANI 1! RET +; +if BANKED + +SET$CTLS$MODE: + ;SET CTLS STATUS OR INPUT FLAG FOR QUEUE MANAGER + LXI H,QFLAG! MVI M,40H! XTHL! PCHL + +endif +; +TEST$CTLS$MODE: + ;RETURN WITH Z FLAG RESET IF CTL-S CTL-Q CHECKING DISABLED + MOV B,A! LDA CONMODE! ANI 2! MOV A,B! RET +; +conbrk: ;check for character ready + CALL TEST$CTLS$MODE! JNZ CONSTX + lda kbchar! ora a! jnz CONBRK1 ;skip if active kbchar + ;no active kbchar, check external break + ;DOES BIOS HAVE TYPE AHEAD? +if BANKED + LDA TYPE$AHEAD! INR A! JZ CONSTX ;YES +endif + ;CONBRKX CALLED BY CONOUT + + CONBRKX: + ;HAS CTL-S INTERCEPT BEEN DISABLED? + CALL TEST$CTLS$MODE! RNZ ;YES + ;DOES KBCHAR CONTAIN CTL-S? + LDA KBCHAR! CPI CTLS! JZ CONBRK1 ;YES +if BANKED + CALL SET$CTLS$MODE +endif + ;IS A CHARACTER READY FOR INPUT? + call constf +if BANKED + POP H! MVI M,0 +endif + ani 1! rz ;NO + ;character ready, read it +if BANKED + CALL SET$CTLS$MODE +endif + call coninf +if BANKED + POP H! MVI M,0 +endif + CONBRK1: + cpi ctls! jnz conb0 ;check stop screen function + ;DOES KBCHAR CONTAIN A CTL-S? + LXI H,KBCHAR! CMP M! JNZ CONBRK2 ;NO + MVI M,0 ; KBCHAR = 0 + ;found ctls, read next character + CONBRK2: + +if BANKED + CALL SET$CTLS$MODE +endif + call coninf ;to A +if BANKED + POP H! MVI M,0 +endif + cpi ctlc! JNZ CONBRK3 + LDA CONMODE! ANI 08H! JZ REBOOTX + XRA A + CONBRK3: + SUI CTLQ! RZ ; RETURN WITH A = ZERO IF CTLQ + INR A! CALL CONB3! JMP CONBRK2 + conb0: + LXI H,KBCHAR + + MOV B,A + ;IS CONMODE(1) TRUE? + LDA CONMODE! RAR! JNC $+7 ;NO + ;DOES KBCHAR = CTLC? + MVI A,CTLC! CMP M! RZ ;YES - RETURN + MOV A,B + + CPI CTLQ! JZ CONB2 + CPI CTLP! JZ CONB2 + ;character in accum, save it + MOV M,A + conb1: + ;return with true set in accumulator + mvi a,1! ret + CONB2: + XRA A! MOV M,A! RET + CONB3: + CZ TOGGLE$LISTCP + MVI C,7! CNZ CONOUTF + RET +; +TOGGLE$LISTCP: + ; IS PRINTER ECHO DISABLED? + LDA CONMODE! ANI 14H! JNZ TOGGLE$L1 ;YES + LXI H,LISTCP! MVI A,1! XRA M! ANI 1 + MOV M,A! RET +TOGGLE$L1: + XRA A! RET +; +QCONOUTF: + ;DOES FX = INPUT? + LDA FX! DCR A! JZ CONOUTF ;YES + ;IS ESCAPE SEQUENCE DECODING IN EFFECT? + MOV A,B +;;; ANI 8 ;[JCE] DRI Patch 13 + ANI 10h + JNZ SCONOUTF ;YES + JMP CONOUTF +; +conout: + ;compute character position/write console char from C + ;compcol = true if computing column position + lda compcol! ora a! jnz compout + ;write the character, then compute the column + ;write console character from C + ;B ~= 0 -> ESCAPE SEQUENCE DECODING + LDA CONMODE! ANI 14H! MOV B,A + push b + ;CALL CONBRKX FOR OUTPUT FUNCTIONS ONLY + LDA FX! DCR A! CNZ CONBRKX + pop b! push b ;recall/save character + call QCONOUTF ;externally, to console + pop b + ;SKIP ECHO WHEN CONMODE & 14H ~= 0 + MOV A,B! ORA A! JNZ COMPOUT + push b ;recall/save character + ;may be copying to the list device + lda listcp! ora a! cnz listf ;to printer, if so + pop b ;recall the character + compout: + mov a,c ;recall the character + ;and compute column position + lxi h,column ;A = char, HL = .column + cpi rubout! rz ;no column change if nulls + inr m ;column = column + 1 + cpi ' '! rnc ;return if graphic + ;not graphic, reset column position + dcr m ;column = column - 1 + mov a,m! ora a! rz ;return if at zero + ;not at zero, may be backspace or end line + mov a,c ;character back to A + cpi ctlh! jnz notbacksp + ;backspace character + dcr m ;column = column - 1 + ret + notbacksp: + ;not a backspace character, eol? + cpi cr! rnz ;return if not + ;end of line, column = 0 + mvi m,0 ;column = 0 + ret +; +ctlout: + ;send C character with possible preceding up-arrow + mov a,c! call echoc ;cy if not graphic (or special case) + jnc tabout ;skip if graphic, tab, cr, lf, or ctlh + ;send preceding up arrow + push psw! mvi c,ctl! call conout ;up arrow + pop psw! ori 40h ;becomes graphic letter + mov c,a ;ready to print +if BANKED + call chk$column! rz +endif + ;(drop through to tabout) +; +tabout: + ;IS FX AN INPUT FUNCTION? + LDA FX! DCR A! JZ TABOUT1 ;YES - ALWAYS EXPAND TABS FOR ECHO + ;HAS TAB EXPANSION BEEN DISABLED OR + ;ESCAPE SEQUENCE DECODING BEEN ENABLED? + LDA CONMODE! ANI 14H! JNZ CONOUT ;YES +TABOUT1: + ;expand tabs to console + mov a,c! cpi tab! jnz conout ;direct to conout if not + ;tab encountered, move to next tab position + tab0: + +if BANKED + lda fx! cpi 1! jnz tab1 + call chk$column! rz + tab1: +endif + + mvi c,' '! call conout ;another blank + lda column! ani 111b ;column mod 8 = 0 ? + jnz tab0 ;back for another if not + ret +; +; +backup: + ;back-up one screen position + call pctlh + +if BANKED + lda comchr! cpi ctla! rz +endif + + mvi c,' '! call conoutf +; (drop through to pctlh) ; +pctlh: + ;send ctlh to console without affecting column count + mvi c,ctlh! jmp conoutf + ;ret +; +crlfp: + ;print #, cr, lf for ctlx, ctlu, ctlr functions + ;then move to strtcol (starting column) + mvi c,'#'! call conout + call crlf + ;column = 0, move to position strtcol + crlfp0: + lda column! lxi h,strtcol + cmp m! rnc ;stop when column reaches strtcol + mvi c,' '! call conout ;print blank + jmp crlfp0 +;; +; +crlf: + ;carriage return line feed sequence + mvi c,cr! call conout! mvi c,lf! jmp conout + ;ret +; +print: + ;print message until M(BC) = '$' + LXI H,OUTDELIM + ldax b! CMP M! rz ;stop on $ + ;more to print + inx b! push b! mov c,a ;char to C + call tabout ;another character printed + pop b! jmp print +; +QCONIN: + +if BANKED + lhld apos! mov a,m! sta ctla$sw +endif + ;IS BUFFER ADDRESS = 0? + LHLD CONBUFFADD! MOV A,L! ORA H! JZ CONIN ;YES + ;IS CHARACTER IN BUFFER < 5? + +if BANKED + call qconinx ; mov a,m with bank 1 switched in +else + MOV A,M +endif + + INX H + ORA A! JNZ QCONIN1 ; NO + LXI H,0 +QCONIN1: + SHLD CONBUFFADD! SHLD CONBUFFLEN! RNZ ; NO + JMP CONIN + +if BANKED + +chk$column: + lda conwidth! mov e,a! lda column! cmp e! ret +; +expand: + xchg! lhld apos! xchg +expand1: + ldax d! ora a! rz + inx d! inx h! mov m,a! inr b! jmp expand1 +; +copy$xbuff: + mov a,b! ora a! rz + push b! mov c,b! push h! xchg! inx d + lxi h,xbuff + call move + mvi m,0! shld xpos + pop h! pop b! ret +; +copy$cbuff: + lda ccpflgs+1! ral! rnc + lxi h,xbuff! lxi d,cbuff! inr c! jnz copy$cbuff1 + xchg! mov a,b! ora a! rz + sta cbuff$len + push d! lxi b,copy$cbuff2! push b + mov b,a +copy$cbuff1: + inr b! mov c,b! jmp move +copy$cbuff2: + pop h! dcx h! mvi m,0! ret +; +save$col: + lda column! sta save$column! ret +; +clear$right: + lda column! lxi h,ctla$column! cmp m! rnc + mvi c,20h! call conout! jmp clear$right +; +reverse: + lda save$column! lxi h,column! cmp m! rnc + mvi c,ctlh! call conout! jmp reverse +; +chk$buffer$size: + push b! push h + lhld apos! mvi e,0 +cbs1: + mov a,m! ora a! jz cbs2 + inr e! inx h! jmp cbs1 +cbs2: + mov a,b! add e! cmp c + push a! mvi c,7! cnc conoutf + pop a! pop h! pop b! rc + pop d! pop d! jmp readnx +; +refresh: + lda ctla$sw! ora a! rz + lda comchr! cpi ctla! rz + cpi ctlf! rz + cpi ctlw! rz +refresh0: + push h! push b + call save$col + lhld apos +refresh1: + mov a,m! ora a! jz refresh2 + mov c,a! call chk$column! jc refresh05 + mov a,e! sta column! jmp refresh2 +refresh05: + push h! call ctlout + pop h! inx h! jmp refresh1 +refresh2: + lda column! sta new$ctla$col +refresh3: + call clear$right + call reverse + lda new$ctla$col! sta ctla$column + pop b! pop h! ret +; +init$apos: + lxi h,aposi! shld apos + xra a! sta ctla$sw + ret +; +init$xpos: + lxi h,xbuff! shld xpos! ret +; +set$ctla$column: + lxi h,ctla$sw! mov a,m! ora a! rnz + inr m! lda column! sta ctla$column! ret +; +readi: + call chk$column! cnc crlf + lda cbuff$len! mov b,a + mvi c,0! call copy$cbuff +else + +readi: + MOV A,D! ORA E! JNZ READ + LHLD DMAAD! SHLD INFO + INX H! INX H! SHLD CONBUFFADD +endif + +read: ;read to info address (max length, current length, buffer) + +if BANKED + call init$xpos + call init$apos +readx: + call refresh + xra a! sta ctlw$sw +readx1: + +endif + + MVI A,1! STA FX + lda column! sta strtcol ;save start for ctl-x, ctl-h + lhld info! mov c,m! inx h! push h + XRA A! MOV B,A! STA SAVEPOS + CMP C! JNZ $+4 + INR C + ;B = current buffer length, + ;C = maximum buffer length, + ;HL= next to fill - 1 + readnx: + ;read next character, BC, HL active + push b! push h ;blen, cmax, HL saved + readn0: + +if BANKED + lda ctlw$sw! ora a! cz qconin +nxtline: + sta comchr +else + CALL QCONIN ;next char in A +endif + + ;ani 7fh ;mask parity bit + pop h! pop b ;reactivate counters + cpi cr! jz readen ;end of line? + cpi lf! jz readen ;also end of line + +if BANKED + cpi ctlf! jnz not$ctlf + do$ctlf: + call chk$column! dcr e! cmp e! jnc readnx + do$ctlf0: + xchg! lhld apos! mov a,m! ora a! jz ctlw$l15 + inx h! shld apos! xchg! jmp notr + not$ctlf: + cpi ctlw! jnz not$ctlw + do$ctlw: + xchg! lhld apos! mov a,m! ora a! jz ctlw$l1 + xchg! call chk$column! dcr e! cmp e! xchg! jc ctlw$l0 + xchg! call refresh0! xchg! jmp ctlw$l13 + ctlw$l0: + lhld apos! mov a,m + inx h! shld apos! jmp ctlw$l3 + ctlw$l1: + lxi h,ctla$sw! mov a,m! mvi m,0 + ora a! jz ctlw$l2 + ctlw$l13: + lxi h,ctlw$sw! mvi m,0 + ctlw$l15: + xchg! jmp readnx + ctlw$l2: + lda ctlw$sw! ora a! jnz ctlw$l25 + mov a,b! ora a! jnz ctlw$l15 + call init$xpos + ctlw$l25: + lhld xpos! mov a,m! ora a + sta ctlw$sw! jz ctlw$l15 + inx h! shld xpos + ctlw$l3: + lxi h,ctlw$sw! mvi m,ctlw + xchg! jmp notr + not$ctlw: + cpi ctla! jnz not$ctla + do$ctla: + ;do we have any characters to back over? + lda strtcol! mov d,a! lda column! cmp d + jz readnx + sta compcol ;COL > 0 + mov a,b! ora a! jz linelen + ;characters remain in buffer, backup one + dcr b ;remove one character + ;compcol > 0 marks repeat as length compute + ;backup one position in xbuff + push h + call set$ctla$column + pop d + lhld apos! dcx h + shld apos! ldax d! mov m,a! xchg! jmp linelen + not$ctla: + cpi ctlb! jnz not$ctlb + do$ctlb: + lda save$pos! cmp b! jnz ctlb$l0 + mvi a,ctlw! sta ctla$sw + sta comchr! jmp do$ctlw + ctlb$l0: + xchg! lhld apos! inr b + ctlb$l1: + dcr b! lda save$pos! cmp b! jz ctlb$l2 + dcx h! ldax d! mov m,a! dcx d! jmp ctlb$l1 + ctlb$l2: + shld apos + push b! push d + call set$ctla$column + ctlb$l3: + lda column! mov b,a + lda strtcol! cmp b! jz read$n0 + mvi c,ctlh! call conout! jmp ctlb$l3 + not$ctlb: + cpi ctlk! jnz not$ctlk + xchg! lxi h,aposi! shld apos + xchg! call refresh + jmp readnx + not$ctlk: + cpi ctlg! jnz not$ctlg + lda ctla$sw! ora a! jz readnx + jmp do$ctlf0 + not$ctlg: +endif + + cpi ctlh! jnz noth ;backspace? + LDA CTLH$ACT! INR A! JZ DO$RUBOUT + DO$CTLH: + ;do we have any characters to back over? + LDA STRTCOL! MOV D,A! LDA COLUMN! CMP D + jz readnx + STA COMPCOL ;COL > 0 + MOV A,B! ORA A! JZ $+4 + ;characters remain in buffer, backup one + dcr b ;remove one character + ;compcol > 0 marks repeat as length compute + jmp linelen ;uses same code as repeat + noth: + ;not a backspace + cpi rubout! jnz notrub ;rubout char? + LDA RUBOUT$ACT! INR A! JZ DO$CTLH + DO$RUBOUT: +if BANKED + mvi a,rubout! sta comchr + lda ctla$sw! ora a! jnz do$ctlh +endif + ;rubout encountered, rubout if possible + mov a,b! ora a! jz readnx ;skip if len=0 + ;buffer has characters, resend last char + mov a,m! dcr b! dcx h ;A = last char + ;blen=blen-1, next to fill - 1 decremented + jmp rdech1 ;act like this is an echo + notrub: + ;not a rubout character, check end line + cpi ctle! jnz note ;physical end line? + ;yes, save active counters and force eol + push b! MOV A,B! STA SAVE$POS + push h +if BANKED + lda ctla$sw! ora a! cnz clear$right +endif + call crlf +if BANKED + call refresh +endif + xra a! sta strtcol ;start position = 00 + jmp readn0 ;for another character + note: + ;not end of line, list toggle? + cpi ctlp! jnz notp ;skip if not ctlp + ;list toggle - change parity + push h ;save next to fill - 1 + PUSH B + XRA A! CALL CONB3 + POP B + pop h! jmp readnx ;for another char + notp: + ;not a ctlp, line delete? + cpi ctlx! jnz notx + pop h ;discard start position + ;loop while column > strtcol + backx: + lda strtcol! lxi h,column +if BANKED + cmp m! jc backx1 + lhld apos! mov a,m! ora a! jnz readx + jmp read + backx1: +else + cmp m! jnc read ;start again +endif + dcr m ;column = column - 1 + call backup ;one position + jmp backx + notx: + ;not a control x, control u? + ;not control-X, control-U? + cpi ctlu! jnz notu ;skip if not +if BANKED + xthl! call copy$xbuff! xthl +endif + ;delete line (ctlu) + do$ctlu: + call crlfp ;physical eol + pop h ;discard starting position + jmp read ;to start all over + notu: + ;not line delete, repeat line? + cpi ctlr! jnz notr + XRA A! STA SAVEPOS +if BANKED + xchg! call init$apos! xchg + mov a,b! ora a! jz do$ctlu + xchg! lhld apos! inr b + ctlr$l1: + dcr b! jz ctlr$l2 + dcx h! ldax d! mov m,a! dcx d + jmp ctlr$l1 + ctlr$l2: + shld apos! push b! push d + call crlfp! mvi a,ctlw! sta ctlw$sw + sta ctla$sw! jmp readn0 +endif + linelen: + ;repeat line, or compute line len (ctlh) + ;if compcol > 0 + push b! call crlfp ;save line length + pop b! pop h! push h! push b + ;bcur, cmax active, beginning buff at HL + rep0: + mov a,b! ora a! jz rep1 ;count len to 00 + inx h! mov c,m ;next to print + DCR B + POP D! PUSH D! MOV A,D! SUB B! MOV D,A + push b! push h ;count length down + LDA SAVEPOS! CMP D! CC CTLOUT + pop h! pop b ;recall remaining count + jmp rep0 ;for the next character + rep1: + ;end of repeat, recall lengths + ;original BC still remains pushed + push h ;save next to fill + lda compcol! ora a ;>0 if computing length + jz readn0 ;for another char if so + ;column position computed for ctlh + lxi h,column! sub m ;diff > 0 + sta compcol ;count down below + ;move back compcol-column spaces + backsp: + ;move back one more space + call backup ;one space + lxi h,compcol! dcr m + jnz backsp +if BANKED + call refresh +endif + jmp readn0 ;for next character + notr: + ;not a ctlr, place into buffer + ;IS BUFFER FULL? + PUSH A + MOV A,B! CMP C! JC RDECH0 ;NO + ;DISCARD CHARACTER AND RING BELL + POP A! PUSH B! PUSH H + MVI C,7! CALL CONOUTF! JMP READN0 + RDECH0: + +if BANKED + lda comchr! cpi ctlg! jz rdech05 + lda ctla$sw! ora a! cnz chk$buffer$size + rdech05: +endif + + POP A + inx h! mov m,a ;character filled to mem + inr b ;blen = blen + 1 + rdech1: + ;look for a random control character + push b! push h ;active values saved + mov c,a ;ready to print +if BANKED + call save$col +endif + call ctlout ;may be up-arrow C + pop h! pop b +if BANKED + lda comchr! cpi ctlg! jz do$ctlh + cpi rubout! jz rdech2 + call refresh + rdech2: +endif + LDA CONMODE! ANI 08H +;;; JNZ NOTC ;[JCE] DRI Patch 13 + jnz patch$064b + + mov a,m ;recall char + cpi ctlc ;set flags for reboot test +patch$064b: mov a,b ;move length to A + jnz notc ;skip if not a control c + cpi 1 ;control C, must be length 1 + jz REBOOTX ;reboot if blen = 1 + ;length not one, so skip reboot + notc: + ;not reboot, are we at end of buffer? +if BANKED + cmp c! jnc buffer$full +else + jmp readnx ;go for another if not +endif + +if BANKED + push b! push h + call chk$column! jc readn0 + lda ctla$sw! ora a! jz do$new$line + lda comchr! cpi ctlw! jz back$one + cpi ctlf! jz back$one + + do$newline: + mvi a,ctle! jmp nxtline + + back$one: + ;back up to previous character + pop h! pop b + dcr b! xchg + lhld apos! dcx h! shld apos + ldax d! mov m,a! xchg! dcx h + push b! push h! call reverse + ;disable ctlb or ctlw + xra a! sta ctlw$sw! jmp readn0 + + buffer$full: + xra a! sta ctlw$sw! jmp readnx +endif + readen: + ;end of read operation, store blen +if BANKED + call expand +endif + pop h! mov m,b ;M(current len) = B +if BANKED + push b + call copy$xbuff + pop b + mvi c,0ffh! call copy$cbuff +endif + LXI H,0! SHLD CONBUFFADD + mvi c,cr! jmp conout ;return carriage + ;ret +; +func1 equ CONECH + ;return console character with echo +; +func2: equ tabout + ;write console character with tab expansion +; +func3: + ;return reader character + call readerf + jmp sta$ret +; +;func4: equated to punchf + ;write punch character +; +;func5: equated to listf + ;write list character + ;write to list device +; +func6: + ;direct console i/o - read if 0ffh + mov a,c! inr a! jz dirinp ;0ffh => 00h, means input mode + inr a! JZ DIRSTAT ;0feh => direct STATUS function + INR A! JZ DIRINP1 ;0fdh => direct input, no status + JMP CONOUTF + DIRSTAT: + ;0feH in C for status + CALL CONSTX! JNZ LRET$EQ$FF! JMP STA$RET + dirinp: + CALL CONSTX ;status check + ora a! RZ ;skip, return 00 if not ready + ;character is ready, get it + dirinp1: + call CONIN ;to A + jmp sta$ret +; +func7: + call auxinstf + jmp sta$ret +; +func8: + call auxoutstf + jmp sta$ret +; +func9: + ;write line until $ encountered + xchg ;was lhld info + mov c,l! mov b,h ;BC=string address + jmp print ;out to console + +func10 equ readi + ;read a buffered console line + +func11: + ;IS CONMODE(1) TRUE? + LDA CONMODE! RAR! JNC NORMAL$STATUS ;NO + ;CTL-C ONLY STATUS CHECK +if BANKED + LXI H,QFLAG! MVI M,80H! PUSH H +endif + LXI H,CTLC$STAT$RET! PUSH H + ;DOES KBCHAR = CTL-C? + LDA KBCHAR! CPI CTLC! JZ CONB1 ;YES + ;IS THERE A READY CHARACTER? + CALL CONSTF! ORA A! RZ ;NO + ;IS THE READY CHARACTER A CTL-C? + CALL CONINF! CPI CTLC! JZ CONB0 ;YES + STA KBCHAR! XRA A! RET + +CTLC$STAT$RET: + +if BANKED + CALL STA$RET + POP H! MVI M,0! RET +else + JMP STA$RET +endif + +NORMAL$STATUS: + ;check console status + call conbrk + ;(drop through to sta$ret) +sta$ret: + ;store the A register to aret + sta aret +func$ret: ; + ret ;jmp goback (pop stack for non cp/m functions) +; +setlret1: + ;set lret = 1 + mvi a,1! jmp sta$ret ; +; +FUNC109: ;GET/SET CONSOLE MODE + ;DOES DE = 0FFFFH? + MOV A,D! ANA E! INR A + LHLD CONMODE! JZ STHL$RET ;YES - RETURN CONSOLE MODE + XCHG! SHLD CONMODE! RET ;NO - SET CONSOLE MODE +; +FUNC110: ;GET/SET FUNCTION 9 DELIMITER + LXI H,OUT$DELIM + ;DOES DE = 0FFFFH? + MOV A,D! ANA E! INR A + MOV A,M! JZ STA$RET ;YES - RETURN DELIMITER + MOV M,E! RET ;NO - SET DELIMITER +; +FUNC111: ;PRINT BLOCK TO CONSOLE +FUNC112: ;LIST BLOCK + XCHG! MOV E,M! INX H! MOV D,M! INX H + MOV C,M! INX H! MOV B,M! XCHG + ;HL = ADDR OF STRING + ;BC = LENGTH OF STRING +BLK$OUT: + MOV A,B! ORA C! RZ + PUSH B! PUSH H! MOV C,M + LDA FX! CPI 111! JZ BLK$OUT1 + CALL LISTF! JMP BLK$OUT2 +BLK$OUT1: + CALL TABOUT +BLK$OUT2: + POP H! INX H! POP B! DCX B + JMP BLK$OUT + +SCONOUTF EQU CONOUTF + +; +; data areas +; +compcol:db 0 ;true if computing column position +strtcol:db 0 ;starting column position after read + +if not BANKED + +kbchar: db 0 ;initial key char = 00 + +endif + +SAVEPOS:DB 0 ;POSITION IN BUFFER CORRESPONDING TO + ;BEGINNING OF LINE +if BANKED + +comchr: db 0 +cbuff$len: db 0 +cbuff: ds 256 + db 0 +xbuff: db 0 + ds 354 +aposi: db 0 +xpos: dw 0 +apos: dw 0 +ctla$sw: db 0 +ctlw$sw: db 0 +save$column: db 0 +ctla$column: db 0 +new$ctla$col: db 0 + +endif + +; end of BDOS Console module diff --git a/software/CPM/cpm3/copyrt.lit b/software/CPM/cpm3/copyrt.lit new file mode 100644 index 0000000..d73288d --- /dev/null +++ b/software/CPM/cpm3/copyrt.lit @@ -0,0 +1,8 @@ + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + diff --git a/software/CPM/cpm3/copysys.asm b/software/CPM/cpm3/copysys.asm new file mode 100644 index 0000000..c70ff59 --- /dev/null +++ b/software/CPM/cpm3/copysys.asm @@ -0,0 +1,837 @@ + title 'Copysys - updated sysgen program 6/82' +; System generation program +VERS equ 30 ;version x.x for CP/M x.x +; +;********************************************************** +;* * +;* * +;* Copysys source code * +;* * +;* * +;********************************************************** +; +FALSE equ 0 +TRUE equ not FALSE +; +; +NSECTS equ 26 ;no. of sectors +NTRKS equ 2 ;no. of systems tracks +NDISKS equ 4 ;no. of disks drives +SECSIZ equ 128 ;size of sector +LOG2SEC equ 7 ;LOG2 128 +SKEW equ 2 ;skew sector factor +; +FCB equ 005Ch ;location of FCB +FCBCR equ FCB+32 ;current record location +TPA equ 0100h ;Transient Program Area +LOADP equ 1000h ;LOAD Point for system +BDOS equ 05h ;DOS entry point +BOOT equ 00h ;reboot for system +CONI equ 1h ;console input function +CONO equ 2h ;console output function +SELD equ 14 ;select a disk +OPENF equ 15 ;disk open function +CLOSEF equ 16 ;open a file +DWRITF equ 21 ;Write func +MAKEF equ 22 ;mae a file +DELTEF equ 19 ;delete a file +DREADF equ 20 ;disk read function +DRBIOS equ 50 ;Direct BIOS call function +EIGHTY equ 080h ;value of 80 +CTLC equ 'C'-'@' ;ConTroL C +Y equ 89 ;ASCII value of Y +; +MAXTRY equ 01 ;maximum number of tries +CR equ 0Dh ;Carriage Return +LF equ 0Ah ;Line Feed +STACKSIZE equ 016h ;size of local stack +; +WBOOT equ 01 ;address of warm boot +; +SELDSK equ 9 ;Bios func #9 SELect DiSK +SETTRK equ 10 ;BIOS func #10 SET TRacK +SETSEC equ 11 ;BIOS func #11 SET SECtor +SETDMA equ 12 ;BIOS func #12 SET DMA address +READF equ 13 ;BIOS func #13 READ selected sector +WRITF equ 14 ;BIOS func #14 WRITe selected sector + +; + org TPA ;Transient Program Area + jmp START + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0 + db 0,0,0 + + maclib makedate + @LCOPY + @BDATE + db 0,0,0,0 + db '654321' +; +; Translate table-sector numbers are translated here to decrease +; the systen tie for missed sectors when slow controllers are +; involved. Translate takes place according to the "SKEW" factor +; set above. +; +OST: db NTRKS ;operating system tracks +SPT: db NSECTS ;sectors per track +TRAN: +TRELT set 1 +TRBASE set 1 + rept NSECTS + db TRELT ;generate first/next sector +TRELT set TRELT+SKEW + if TRELT gt NSECTS +TRBASE set TRBASE+1 +TRELT set TRBASE + endif + endm +; +; Now leave space for extensions to translate table +; + if NSECTS lt 64 + rept 64-NSECTS + db 0 + endm + endif +; +; Utility subroutines +; +MLTBY3: +;multiply the contents of regE to get jmp address + mov a,e ;Acc = E + sui 1 + mov e,a ;get ready for multiply + add e + add e + mov e,a + ret ;back at it +; +SEL: + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz SEL2 +; + sta CREG ;CREG = selected register + lxi h,0000h + shld EREG ;for first time + + mvi a,SELDSK + sta BIOSFC ;store it in func space + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +SEL2: + mov c,a + lhld WBOOT + lxi d,SELDSK + call MLTBY3 + dad d + pchl +; +TRK: +; Set up track + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz TRK2 + +; + mvi a,00h + sta BREG ;zero out B register + mov a,c ;Acc = track # + sta CREG ;set up PB + mvi a,SETTRK ;settrk func # + sta BIOSFC + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +TRK2: + lhld WBOOT + lxi d,SETTRK + call MLTBY3 + dad d + pchl ;gone to set track +; +SEC: +; Set up sector number + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz SEC2 +; + mvi a,00h + sta BREG ;zero out BREG + mov a,c ; Acc = C + sta CREG ;CREG = sector # + mvi a,SETSEC + sta BIOSFC ;set up bios call + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +SEC2: + lhld WBOOT + lxi d,SETSEC + call MLTBY3 + dad d + pchl +; +DMA: +; Set DMA address to value of BC + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz DMA2 +; + mov a,b ; + sta BREG ; + mov a,c ;Set up the BC + sta CREG ;register pair + mvi a,SETDMA ; + sta BIOSFC ;set up bios # + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +DMA2: + lhld WBOOT + lxi d,SETDMA + call MLTBY3 + dad d + pchl +; +READ: +; Perform read operation + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz READ2 +; + mvi a,READF + sta BIOSFC + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +READ2: + lhld WBOOT + lxi d,READF + call MLTBY3 + dad d + pchl +; +WRITE: +; Perform write operation + sta TEMP + lda V3FLG + cpi TRUE + lda TEMP + jnz WRITE2 +; + mvi a,WRITF + sta BIOSFC ;set up bios # + mvi c,DRBIOS + lxi d,BIOSPB + jmp BDOS +WRITE2: + lhld WBOOT + lxi d,WRITF + call MLTBY3 + dad d + pchl +; +MULTSEC: +; Multiply the sector # in rA by the sector size + mov l,a + mvi h,0 ;sector in hl + rept LOG2SEC + dad h + endm + ret ;with HL - sector*sectorsize +; +GETCHAR: +; Read console character to rA + mvi c,CONI + call BDOS +; Convert to upper case + cpi 'A' or 20h + rc + cpi ('Z' or 20h)+1 + rnc + ani 05Fh + ret +; +PUTCHAR: +; Write character from rA to console + mov e,a + mvi c,CONO + call BDOS + ret +; +CRLF: +; Send Carriage Return, Line Feed + mvi a,CR + call PUTCHAR + mvi a,LF + call PUTCHAR + ret +; + +CRMSG: +; Print message addressed by the HL until zero with leading CRLF + push d + call CRLF + pop d ;drop through to OUTMSG +OUTMSG: + mvi c,9 + jmp BDOS +; +SELCT: +; Select disk given by rA + mvi c,0Eh + jmp BDOS +; +DWRITE: +; Write for file copy + mvi c,DWRITF + jmp BDOS +; +DREAD: +; Disk read function + mvi c,DREADF + jmp BDOS +; +OPEN: +; File open function + mvi c,OPENF + jmp BDOS +; +CLOSE: + mvi c,CLOSEF + jmp BDOS +; +MAKE: + mvi c,MAKEF + jmp BDOS +; +DELETE: + mvi c,DELTEF + jmp BDOS +; +; +; +DSTDMA: + mvi c,26 + jmp BDOS +; +SOURCE: + lxi d,GETPRM ;ask user for source drive + call CRMSG + call GETCHAR ;obtain response + cpi CR ;is it CR? + jz DFLTDR ;skip if CR only + cpi CTLC ;isit ^C? + jz REBOOT +; + sui 'A' ;normalize drive # + cpi NDISKS ;valid drive? + jc GETC ;skip to GETC if so +; +; Invalid drive + call BADDISK ;tell user bad drive + jmp SOURCE ;try again +; +GETC: +; Select disk given by Acc. + adi 'A' + sta GDISK ;store source disk + sui 'A' + mov e,a ;move disk into E for select func + call SEL ;select the disk + jmp GETVER +; +DFLTDR: + mvi c,25 ;func 25 for current disk + call BDOS ;get curdsk + adi 'A' + sta GDISK + call CRLF + lxi d,VERGET + call OUTMSG + jmp VERCR +; +GETVER: +; Getsys set r/w to read and get the system + call CRLF + lxi d,VERGET ;verify source disk + call OUTMSG +VERCR: call GETCHAR + cpi CR + jnz REBOOT ;jmp only if not verified + call CRLF + ret +; +DESTIN: + lxi d,PUTPRM ;address of message + call CRMSG ;print it + call GETCHAR ;get answer + cpi CR + jz REBOOT ;all done + sui 'A' + cpi NDISKS ;valid disk + jc PUTC +; +; Invalid drive + call BADDISK ;tell user bad drive + jmp PUTSYS ;to try again +; +PUTC: +; Set disk fron rA + adi 'A' + sta PDISK ;message sent + sui 'A' + mov e,a ;disk # in E + call SEL ;select destination drive +; Put system, set r/w to write + lxi d,VERPUT ;verify dest prmpt + call CRMSG ;print it out + call GETCHAR ;retrieve answer + cpi CR + jnz REBOOT ;exit to system if error + call CRLF + ret +; +; +GETPUT: +; Get or put CP/M (rw = 0 for read, 1 for write) +; disk is already selected + lxi h,LOADP ;load point in RAM for DMA address + shld DMADDR +; +; +; + +; +; Clear track 00 + mvi a,-1 ; + sta TRACK +; +RWTRK: +; Read or write next track + lxi h,TRACK + inr m ;track = track+1 + lda OST ;# of OS tracks + cmp m ;=track # ? + jz ENDRW ;end of read/write +; +; Otherwise not done + mov c,m ;track number + call TRK ;set to track + mvi a,-1 ;counts 0,1,2,...,25 + sta SECTOR +; +RWSEC: +; Read or write a sector + lda SPT ;sectors per track + lxi h,SECTOR + inr m ;set to next sector + cmp m ;A=26 and M=0,1,..,25 + jz ENDTRK +; +; Read or write sector to or from current DMA address + lxi h,SECTOR + mov e,m ;sector number + mvi d,0 ;to DE + lxi h,TRAN + mov b,m ;tran(0) in B + dad d ;sector translated + mov c,m ;value to C ready for select + push b ;save tran(0) + call SEC + pop b ;recall tran(0),tran(sector) + mov a,c ;tran(sector) + sub b ;--tran(sector) + call MULTSEC ;*sector size + xchg ;to DE + lhld DMADDR ;base DMA + dad d + mov b,h + mov c,l ;to set BC for SEC call + call DMA ;dma address set from BC + xra a + sta RETRY ;to set zero retries +; +TRYSEC: +; Try to read or write current sector + lda RETRY + cpi MAXTRY + jc TRYOK +; +; Past MAXTRY, message and ignore + lxi d,ERRMSG + call OUTMSG + call GETCHAR + cpi CR + jnz REBOOT +; +; Typed a CR, ok to ignore + call CRLF + jmp RWSEC +; +TRYOK: +; Ok to tyr read write + inr a + sta RETRY + lda RW + ora a + jz TRYREAD +; +; Must be write + call WRITE + jmp CHKRW +TRYREAD: + call READ +CHKRW: + ora a + jz RWSEC ;zero flag if read/write ok +; +;Error, retry operation + jmp TRYSEC +; +; End of track +ENDTRK: + lda SPT ;sectors per track + call MULTSEC ;*secsize + xchg ; to DE + lhld DMADDR ;base dma for this track + dad d ;+spt*secsize + shld DMADDR ;ready for next track + jmp RWTRK ;for another track +; +ENDRW: +; End of read or write + ret +; +;******************* +;* +;* MAIN ROUTINE +;* +;* +;******************* +; +START: + + lxi sp,STACK + lxi d,SIGNON + call OUTMSG +; +;get version number to check compatability + mvi c,12 ;version check + call BDOS + mov a,l ;version in Acc + cpi 30h ;version 3 or newer? + jc OLDRVR ; + mvi a,TRUE + sta V3FLG ; + jmp FCBCHK +OLDRVR: + mvi a,FALSE + sta V3FLG +; + +; Check for default file liad instead of get +FCBCHK: lda FCB+1 ;blank if no file + cpi ' ' + jz GETSYS ;skip to system message + lxi d,FCB ;try to open it + call OPEN + inr a ;255 becomes 00 + jnz RDOK +; +; File not present + lxi d,NOFILE + call CRMSG + jmp REBOOT +; +;file present +RDOK: + xra a + sta FCBCR ;current record = 0 + lxi h,LOADP +RDINP: + push h + mov b,h + mov c,l + call DMA ;DMA address set + lxi d,FCB ;ready fr read + call DREAD + pop h ;recall + ora a ;00 if read ok + jnz PUTSYS ;assume eof if not +; More to read continue + lxi d,SECSIZ + dad d ;HL is new load address + jmp RDINP +; +GETSYS: + call SOURCE ;find out source drive +; + xra a ;zero out a + sta RW ;RW = 0 to signify read + call GETPUT ;get or read system + lxi d,DONE ;end message of get or read func + call OUTMSG ;print it out +; +; Put the system +PUTSYS: + call DESTIN ;get dest drive +; + lxi h,RW ;load address + mvi m,1 + call GETPUT ;to put system back on disk + lxi d,DONE + call OUTMSG ;print out end prompt +; +; FILE COPY FOR CPM.SYS +; +CPYCPM: +; Prompt the user for the source of CP/M3.SYS +; + lxi d,CPYMSG ;print copys prompt + call CRMSG ;print it + call GETCHAR ;obtain reply + cpi Y ;is it yes? + jnz REBOOT ;if not exit + ;else +; +; + mvi c,13 ;func # for reset + call BDOS ; + inr a + + lxi d,ERRMSG + cz FINIS +; + call SOURCE ;get source disk for CPM3.SYS +CNTNUE: + lda GDISK ;Acc = source disk + sui 'A' + mvi d,00h + mov e,a ;DE = selected disk + call SELCT +; now copy the FCBs + mvi c,36 ;for copy + lxi d,SFCB ;source file + lxi h,DFCB ;destination file +MFCB: + + ldax d + inx d ;ready next + mov m,a + inx h ;ready next dest + dcr c ;decrement coun + jnz MFCB +; + lda GDISK ;Acc = source disk + sui 40h ;correct disk + lxi h,SFCB + mov m,a ;SFCB has source disk # + lda PDISK ;get the dest. disk + lxi h,DFCB ; + sui 040h ;normalize disk + mov m,a +; + xra a ;zero out a + sta DFCBCR ;current rec = 0 +; +; Source and destination fcb's ready +; + lxi d,SFCB ; + call OPEN ;open the file + lxi d,NOFILE ;error messg + inr a ;255 becomes 0 + cz FINIS ;done if no file +; +; Source file is present and open + lxi d,LOADP ;get DMA address + xchg ;move address to HL regs + shld BEGIN ;save for begin of write +; + lda BEGIN ;get low byte of + mov l,a ;DMA address into L + lda BEGIN+1 ; + mov h,a ;into H also +COPY1: + xchg ;DE = address of DMA + call DSTDMA ; +; + lxi d,SFCB ; + call DREAD ;read next record + ora a ;end of file? + jnz EOF ;skip write if so +; + lda CRNREC + inr a ;bump it + sta CRNREC +; + lda BEGIN + mov l,a + lda BEGIN+1 + mov h,a + lxi d,EIGHTY + dad d ;add eighty to begin address + shld BEGIN + jmp COPY1 ;loop until EOF +; +EOF: + lxi d,DONE + call OUTMSG +; +COPY2: + call DESTIN ;get destination drive for CPM3.SYS + lxi d,DFCB ;set up dest FCB + xchg + lda PDISK + sui 040h ;normalize disk + mov m,a ;correct disk for dest + xchg ;DE = DFCB + call DELETE ;delete file if there +; + lxi d,DFCB ; + call MAKE ;make a new one + lxi d,NODIR + inr a ;check directory space + cz FINIS ;end if none +; + lxi d,LOADP + xchg + shld BEGIN +; + lda BEGIN + mov l,a + lda BEGIN+1 + mov h,a +LOOP2: + xchg + call DSTDMA + lxi d,DFCB + call DWRITE + lxi d,FSPACE + ora a + cnz FINIS + lda CRNREC + dcr a + sta CRNREC + cpi 0 + jz FNLMSG + lda BEGIN + mov l,a + lda BEGIN+1 + mov h,a + lxi d,EIGHTY + dad d + shld BEGIN + jmp LOOP2 +; Copy operation complete +FNLMSG: + lxi d,DFCB + mvi c,CLOSEF + call BDOS +; + lxi d,DONE +; +FINIS: +; Write message given by DE, reboot + call OUTMSG +; +REBOOT: + mvi c,13 + call BDOS + call CRLF + jmp BOOT +; +BADDISK: + lxi d,QDISK + call CRMSG + ret +;**************************** +;* +;* +;* DATA STRUCTURES +;* +;* +;**************************** +; +BIOSPB: +; BIOS Parameter Block +BIOSFC: db 0 ;BIOS function number +AREG: db 0 ;A register contents +CREG: db 0 ;C register contents +BREG: db 0 ;B register contents +EREG: db 0 ;E register contents +DREG: db 0 ;D register contents +HLREG: dw 0 ;HL register contents +; +SFCB: +DR: ds 1 +F1F8: db 'CPM3 ' +T1T3: db 'SYS' +EXT: db 0 +CS: db 0 +RS: db 0 +RCC: db 0 +D0D15: ds 16 +CCR: db 0 +R0R2: ds 3 +; +DFCB: ds 36 +DFCBCR equ DFCB+32 +; +; +V3FLG: db 0 ;flag for version # +TEMP: db 0 +SDISK: ds 1 ;selected disk +BEGIN: dw 0 +DFLAG: db 0 +TRACK: ds 1 ;current track +CRNREC: db 0 ;current rec count +SECTOR: ds 1 ;current sector +RW: ds 1 ;read if 0 write if 1 +DMADDR: ds 2 ;current DMA address +RETRY: ds 1 ;number of tries on this sector +SIGNON: db 'CP/M 3 COPYSYS - Version ' + db VERS/10+'0','.',VERS mod 10 +'0' + db '$' +GETPRM: db 'Source drive name (or return for default) $' +VERGET: db 'Source on ' +GDISK: ds 1 + db ' then type return $' +PUTPRM: db 'Destination drive name (or return to reboot) $' +VERPUT: db 'Destination on ' +PDISK: ds 1 + db ' then type return $' +CPYMSG: db 'Do you wish to copy CPM3.SYS? $' +DONE: db 'Function complete$' +; +; Error messages...... +; +QDISK: db 'ERROR: Invalid drive name (Use A, B, C, or D)$' +NOFILE: db 'ERROR: No source file on disk.$' +NODIR: db 'ERROR: No directory space.$' +FSPACE: db 'ERROR: Out of data space.$' +WRPROT: db 'ERROR: Write protected?$' +ERRMSG: db 'ERROR: Possible incompatible disk format.' + db CR,LF,' Type return to ignore.$' +CLSERR: db 'ERROR: Close operation failed.$' +; + ds STACKSIZE * 3 +STACK: + end + \ No newline at end of file diff --git a/software/CPM/cpm3/cpmbdos.asm b/software/CPM/cpm3/cpmbdos.asm new file mode 100644 index 0000000..9c6c5c9 --- /dev/null +++ b/software/CPM/cpm3/cpmbdos.asm @@ -0,0 +1,7900 @@ + title 'CP/M BDOS Interface, BDOS, Version 3.0 Dec, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** I n t e r f a c e M o d u l e ** +;** ** +;***************************************************************** +;***************************************************************** +; +; Copyright (c) 1978, 1979, 1980, 1981, 1982 +; Digital Research +; Box 579, Pacific Grove +; California +; +; December 1982 +; +on equ 0ffffh +off equ 00000h +MPM equ off +BANKED equ on + +; +; equates for non graphic characters +; + +ctla equ 01h ; control a +ctlb equ 02h ; control b +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlf equ 06h ; control f +ctlg equ 07h ; control g +ctlh equ 08h ; backspace +ctlk equ 0bh ; control k +ctlp equ 10h ; prnt toggle +ctlq equ 11h ; start screen +ctlr equ 12h ; repeat line +ctls equ 13h ; stop screen +ctlu equ 15h ; line delete +ctlw equ 17h ; control w +ctlx equ 18h ; =ctl-u +ctlz equ 1ah ; end of file +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow + + org 0000h +base equ $ + +; Base page definitions + +bnkbdos$pg equ base+0fc00h +resbdos$pg equ base+0fd00h +scb$pg equ base+0fb00h +bios$pg equ base+0ff00h + +; Bios equates + +bios equ bios$pg +bootf equ bios$pg ; 00. cold boot function + +if BANKED + +wbootf equ scb$pg+68h ; 01. warm boot function +constf equ scb$pg+6eh ; 02. console status function +coninf equ scb$pg+74h ; 03. console input function +conoutf equ scb$pg+7ah ; 04. console output function +listf equ scb$pg+80h ; 05. list output function + +else + +wbootf equ bios$pg+3 ; 01. warm boot function +constf equ bios$pg+6 ; 02. console status function +coninf equ bios$pg+9 ; 03. console input function +conoutf equ bios$pg+12 ; 04. console output function +listf equ bios$pg+15 ; 05. list output function + +endif + +punchf equ bios$pg+18 ; 06. punch output function +readerf equ bios$pg+21 ; 07. reader input function +homef equ bios$pg+24 ; 08. disk home function +seldskf equ bios$pg+27 ; 09. select disk function +settrkf equ bios$pg+30 ; 10. set track function +setsecf equ bios$pg+33 ; 11. set sector function +setdmaf equ bios$pg+36 ; 12. set dma function +readf equ bios$pg+39 ; 13. read disk function +writef equ bios$pg+42 ; 14. write disk function +liststf equ bios$pg+45 ; 15. list status function +sectran equ bios$pg+48 ; 16. sector translate +conoutstf equ bios$pg+51 ; 17. console output status function +auxinstf equ bios$pg+54 ; 18. aux input status function +auxoutstf equ bios$pg+57 ; 19. aux output status function +devtblf equ bios$pg+60 ; 20. retunr device table address fx +devinitf equ bios$pg+63 ; 21. initialize device function +drvtblf equ bios$pg+66 ; 22. return drive table address +multiof equ bios$pg+69 ; 23. multiple i/o function +flushf equ bios$pg+72 ; 24. flush function +movef equ bios$pg+75 ; 25. memory move function +timef equ bios$pg+78 ; 26. system get/set time function +selmemf equ bios$pg+81 ; 27. select memory function +setbnkf equ bios$pg+84 ; 28. set dma bank function +xmovef equ bios$pg+87 ; 29. extended move function + +if BANKED + +; System Control Block equates + +olog equ scb$pg+090h +rlog equ scb$pg+092h + +SCB equ scb$pg+09ch + +; Expansion Area - 6 bytes + +hashl equ scb$pg+09ch +hash equ scb$pg+09dh +version equ scb$pg+0a1h + +; Utilities Section - 8 bytes + +util$flgs equ scb$pg+0a2h +dspl$flgs equ scb$pg+0a6h + +; CLP Section - 4 bytes + +clp$flgs equ scb$pg+0aah +clp$errcde equ scb$pg+0ach + +; CCP Section - 8 bytes + +ccp$comlen equ scb$pg+0aeh +ccp$curdrv equ scb$pg+0afh +ccp$curusr equ scb$pg+0b0h +ccp$conbuff equ scb$pg+0b1h +ccp$flgs equ scb$pg+0b3h + +; Device I/O Section - 32 bytes + +conwidth equ scb$pg+0b6h +column equ scb$pg+0b7h +conpage equ scb$pg+0b8h +conline equ scb$pg+0b9h +conbuffadd equ scb$pg+0bah +conbufflen equ scb$pg+0bch +conin$rflg equ scb$pg+0beh +conout$rflg equ scb$pg+0c0h +auxin$rflg equ scb$pg+0c2h +auxout$rflg equ scb$pg+0c4h +lstout$rflg equ scb$pg+0c6h +page$mode equ scb$pg+0c8h +pm$default equ scb$pg+0c9h +ctlh$act equ scb$pg+0cah +rubout$act equ scb$pg+0cbh +type$ahead equ scb$pg+0cch +contran equ scb$pg+0cdh +conmode equ scb$pg+0cfh +outdelim equ scb$pg+0d3h +listcp equ scb$pg+0d4h +qflag equ scb$pg+0d5h + +; BDOS Section - 42 bytes + +scbadd equ scb$pg+0d6h +dmaad equ scb$pg+0d8h +olddsk equ scb$pg+0dah +info equ scb$pg+0dbh +resel equ scb$pg+0ddh +relog equ scb$pg+0deh +fx equ scb$pg+0dfh +usrcode equ scb$pg+0e0h +dcnt equ scb$pg+0e1h +;searcha equ scb$pg+0e3h +searchl equ scb$pg+0e5h +multcnt equ scb$pg+0e6h +errormode equ scb$pg+0e7h +searchchain equ scb$pg+0e8h +temp$drive equ scb$pg+0ech +errdrv equ scb$pg+0edh +media$flag equ scb$pg+0f0h +bdos$flags equ scb$pg+0f3h +stamp equ scb$pg+0f4h +commonbase equ scb$pg+0f9h +error equ scb$pg+0fbh ;jmp error$sub +bdosadd equ scb$pg+0feh + +; Resbdos equates + +resbdos equ resbdos$pg +move$out equ resbdos$pg+9 ; a=bank #, hl=dest, de=srce +move$tpa equ resbdos$pg+0ch ; a=bank #, hl=dest, de=srce +srch$hash equ resbdos$pg+0fh ; a=bank #, hl=hash table addr +hashmx equ resbdos$pg+12h ; max hash search dcnt +rd$dir$flag equ resbdos$pg+14h ; directory read flag +make$xfcb equ resbdos$pg+15h ; make function flag +find$xfcb equ resbdos$pg+16h ; search function flag +xdcnt equ resbdos$pg+17h ; dcnt save for empty fcb, + ; user 0 fcb, or xfcb +xdmaad equ resbdos$pg+19h ; resbdos dma copy area addr +curdma equ resbdos$pg+1bh ; current dma +copy$cr$only equ resbdos$pg+1dh ; dont restore fcb flag +user$info equ resbdos$pg+1eh ; user fcb address +kbchar equ resbdos$pg+20h ; conbdos look ahead char +qconinx equ resbdos$pg+21h ; qconin mov a,m routine + +ELSE + +move$out equ movef +move$tpa equ movef + +ENDIF + +; +serial: db '654321' +; +; Enter here from the user's program with function number in c, +; and information address in d,e +; + +bdose: ; Arrive here from user programs + xchg! shld info! xchg ; info=de, de=info + + mov a,c! sta fx! cpi 14! jc bdose2 + lxi h,0! shld dircnt ; dircnt,multnum = 0 + lda olddsk! sta seldsk ; Set seldsk + +if BANKED + dcr a! sta copy$cr$init +ENDIF + + ; If mult$cnt ~= 1 then read or write commands + ; are handled by the shell + lda mult$cnt! dcr a! jz bdose2 + lxi h,mult$fxs +bdose1: + mov a,m! ora a! jz bdose2 + cmp c! jz shell + inx h! jmp bdose1 +bdose2: + mov a,e! sta linfo ; linfo = low(info) - don't equ + lxi h,0! shld aret ; Return value defaults to 0000 + shld resel ; resel,relog = 0 + ; Save user's stack pointer, set to local stack + dad sp! shld entsp ; entsp = stackptr + +if not BANKED + lxi sp,lstack ; local stack setup +ENDIF + + lxi h,goback ; Return here after all functions + push h ; jmp goback equivalent to ret + mov a,c! cpi nfuncs! jnc high$fxs ; Skip if invalid # + mov c,e ; possible output character to c + lxi h,functab! jmp bdos$jmp + ; look for functions 98 -> +high$fxs: + cpi 128! jnc test$152 + sui 98! jc lret$eq$ff ; Skip if function < 98 + cpi nfuncs2! jnc lret$eq$ff + lxi h,functab2 +bdos$jmp: + mov e,a! mvi d,0 ; de=func, hl=.ciotab + dad d! dad d! mov e,m! inx h! mov d,m ; de=functab(func) + lhld info ; info in de for later xchg + xchg! pchl ; dispatched + +; CAUTION: In banked systems only, +; error$sub is referenced indirectly by the SCB ERROR +; field in RESBDOS as (0fc7ch). This value is converted +; to the actual address of error$sub by GENSYS. If the offset +; of error$sub is changed, the SCB ERROR value must also +; be changed. + +; +; error subroutine +; + +error$sub: + mvi b,0! push b! dcr c + lxi h,errtbl! dad b! dad b + mov e,m! inx h! mov d,m! xchg + call errflg + pop b! lda error$mode! ora a! rnz + jmp reboote + +mult$fxs: db 20,21,33,34,40,0 + + maclib makedate +if BANKED + @LCOPY + @BDATE + ds 5 +else + @SCOPY + @BDATE + + ; 31 level stack + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h +lstack: + +endif + +; dispatch table for functions + +functab: + dw rebootx1, func1, func2, func3 + dw punchf, listf, func6, func7 + dw func8, func9, func10, func11 +diskf equ ($-functab)/2 ; disk funcs + dw func12,func13,func14,func15 + dw func16,func17,func18,func19 + dw func20,func21,func22,func23 + dw func24,func25,func26,func27 + dw func28,func29,func30,func31 + dw func32,func33,func34,func35 + dw func36,func37,func38,func39 + dw func40,lret$eq$ff,func42,func43 + dw func44,func45,func46,func47 + dw func48,func49,func50 +nfuncs equ ($-functab)/2 + +functab2: + dw func98,func99 + dw func100,func101,func102,func103 + dw func104,func105,func106,func107 + dw func108,func109,func110,func111 + dw func112 + +nfuncs2 equ ($-functab2)/2 + +errtbl: + dw permsg + dw rodmsg + dw rofmsg + dw selmsg + dw 0 + dw 0 + dw passmsg + dw fxstsmsg + dw wildmsg + +test$152: + cpi 152! rnz + +; +; PARSE version 3.0b Oct 08 1982 - Doug Huskey +; +; + ; DE->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks (left justified) + ; 9-11 => type, converted to upper case, + ; padded with blanks (left justified) + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 24-25 => 0000h + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if DE locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; + lxi h,sthl$ret + push h + lhld info + mov e,m ;get first parameter + inx h + mov d,m + push d ;save .filename + inx h + mov e,m ;get second parameter + inx h + mov d,m + pop h ;DE=.fcb HL=.filename + xchg +parse0: + push h ;save .fcb + xra a + mov m,a ;clear drive byte + inx h + lxi b,20h*256+11 + call pad ;pad name and type w/ blanks + lxi b,4 + call pad ;EXT, S1, S2, RC = 0 + lxi b,20h*256+8 + call pad ;pad password field w/ blanks + lxi b,12 + call pad ;zero 2nd 1/2 of map, cr, r0 - r2 +; +; skip spaces +; + call skps +; +; check for drive +; + ldax d + cpi ':' ;is this a drive? + dcx d + pop h + push h ;HL = .fcb + jnz parse$name +; +; Parse the drive-spec +; +parsedrv: + call delim + jz parse$ok + sui 'A' + jc perror1 + cpi 16 + jnc perror1 + inx d + inx d ;past the ':' + inr a ;set drive relative to 1 + mov m,a ;store the drive in FCB(0) +; +; Parse the file-name +; +parse$name: + inx h ;HL = .fcb(1) + call delim + jz parse$ok + lxi b,7*256 + +parse6: ldax d ;get a character + cpi '.' ;file-type next? + jz parse$type ;branch to file-type processing + cpi ';' + jz parse$pw + call gfc ;process one character + jnz parse6 ;loop if not end of name + jmp parse$ok +; +; Parse the file-type +; +parse$type: + inx d ;advance past dot + pop h + push h ;HL =.fcb + lxi b,9 + dad b ;HL =.fcb(9) + lxi b,2*256 + +parse8: ldax d + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse8 ;loop if not end of type +; +parse$ok: + pop b + push d + call skps ;skip trailing blanks and tabs + dcx d + call delim ;is next nonblank char a delim? + pop h + rnz ;no + lxi h,0 + ora a + rz ;return zero if delim = 0 + cpi cr + rz ;return zero if delim = cr + xchg + ret +; +; handle parser error +; +perror: + pop b ;throw away return addr +perror1: + pop b + lxi h,0ffffh + ret +; +; Parse the password +; +parsepw: + inx d + pop h + push h + lxi b,16 + dad b + lxi b,7*256+1 +parsepw1: + call gfc + jnz parsepw1 + mvi a,7 + sub b + pop h + push h + lxi b,26 + dad b + mov m,a + ldax d ;delimiter in A + jmp parse$ok +; +; get next character of name, type or password +; +gfc: call delim ;check for end of filename + rz ;return if so + cpi ' ' ;check for control characters + inx d + jc perror ;error if control characters encountered + inr b ;error if too big for field + dcr b + jm perror + inr c + dcr c + jnz gfc1 + cpi '*' ;trap "match rest of field" character + jz setmatch +gfc1: mov m,a ;put character in fcb + inx h + dcr b ;decrement field size counter + ora a ;clear zero flag + ret +;; +setmatch: + mvi m,'?' ;set match one character + inx h + dcr b + jp setmatch + ret +; +; check for delimiter +; +; entry: A = character +; exit: z = set if char is a delimiter +; +delimiters: db cr,tab,' .,:;[]=<>|',0 + +delim: ldax d ;get character + push h + lxi h,delimiters +delim1: cmp m ;is char in table + jz delim2 + inr m + dcr m ;end of table? (0) + inx h + jnz delim1 + ora a ;reset zero flag +delim2: pop h + rz + ; + ; not a delimiter, convert to upper case + ; + cpi 'a' + rc + cpi 'z'+1 + jnc delim3 + ani 05fh +delim3: ani 07fh + ret ;return with zero set if so +; +; pad with blanks or zeros +; +pad: mov m,b + inx h + dcr c + jnz pad + ret +; +; skip blanks and tabs +; +skps: ldax d + inx d + cpi ' ' ;skip spaces & tabs + jz skps + cpi tab + jz skps + ret +; +; end of PARSE +; + +errflg: + ; report error to console, message address in hl + push h! call crlf ; stack mssg address, new line + lda adrive! adi 'A'! sta dskerr ; current disk name + lxi b,dskmsg + +if BANKED + call zprint ; the error message +else + call print +endif + + pop b + +if BANKED + lda bdos$flags! ral! jnc zprint + call zprint ; error message tail + lda fx! mvi b,30h + lxi h,pr$fx1 + cpi 100! jc errflg1 + mvi m,31h! inx h! sui 100 +errflg1: + sui 10! jc errflg2 + inr b! jmp errflg1 +errflg2: + mov m,b! inx h! adi 3ah! mov m,a + inx h! mvi m,20h + lxi h,pr$fcb! mvi m,0 + lda resel! ora a! jz errflg3 + mvi m,20h! push d + lhld info! inx h! xchg! lxi h,pr$fcb1 + mvi c,8! call move! mvi m,'.'! inx h + mvi c,3! call move! pop d +errflg3: + call crlf + lxi b,pr$fx! jmp zprint + +zprint: + ldax b! ora a! rz + push b! mov c,a + call tabout + pop b! inx b! jmp zprint + +pr$fx: db 'BDOS Function = ' +pr$fx1: db ' ' +pr$fcb: db ' File = ' +pr$fcb1:ds 12 + db 0 + +else + jmp print +endif + +reboote: + lxi h,0fffdh! jmp rebootx0 ; BDOS error +rebootx: +;;; lxi h,0fffeh ; CTL-C error + call patch$1e25 ;[JCE] DRI Patch 13 +rebootx0: + shld clp$errcde +rebootx1: + jmp wbootf + +entsp: ds 2 ; entry stack pointer + +shell: + lxi h,0! dad sp! shld shell$sp + +if not BANKED + lxi sp,shell$stk +endif + + lxi h,shell$rtn! push h + call save$rr! call save$dma + lda mult$cnt +mult$io: + push a! sta mult$num! call cbdos + ora a! jnz shell$err + lda fx! cpi 33! cnc incr$rr + call adv$dma + pop a! dcr a! jnz mult$io + mov h,a! mov l,a! ret + +shell$sp: dw 0 + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + +shell$stk: ; shell has 5 level stack +hold$dma: dw 0 + +cbdos: + lda fx! mov c,a +cbdos1: + lhld info! xchg! jmp bdose2 + +adv$dma: + lhld dmaad! lxi d,80h! dad d! jmp reset$dma1 + +save$dma: + lhld dmaad! shld hold$dma! ret + +reset$dma: + lhld hold$dma +reset$dma1: + shld dmaad! jmp setdma + +shell$err: + pop b! inr a! rz + lda mult$cnt! sub b! mov h,a! ret + +shell$rtn: + push h! lda fx! cpi 33! cnc reset$rr + call reset$dma + pop d! lhld shell$sp! sphl! xchg + mov a,l! mov b,h! ret + + page + + + title 'CP/M Bdos Interface, Bdos, Version 3.0 Nov, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** C o n s o l e P o r t i o n ** +;** ** +;***************************************************************** +;***************************************************************** +; +; November 1982 +; +; +; Console handlers +; +conin: + ;read console character to A + lxi h,kbchar! mov a,m! mvi m,0! ora a! rnz + ;no previous keyboard character ready + jmp coninf ;get character externally + ;ret +; +conech: + LXI H,STA$RET! PUSH H +CONECH0: + ;read character with echo + call conin! call echoc! JC CONECH1 ;echo character? + ;character must be echoed before return + push psw! mov c,a! call tabout! pop psw + RET +CONECH1: + CALL TEST$CTLS$MODE! RNZ + CPI CTLS! JNZ CONECH2 + CALL CONBRK2! JMP CONECH0 +CONECH2: + CPI CTLQ! JZ CONECH0 + CPI CTLP! JZ CONECH0 + RET +; +echoc: + ;echo character if graphic + ;cr, lf, tab, or backspace + cpi cr! rz ;carriage return? + cpi lf! rz ;line feed? + cpi tab! rz ;tab? + cpi ctlh! rz ;backspace? + cpi ' '! ret ;carry set if not graphic +; +CONSTX: + LDA KBCHAR! ORA A! JNZ CONB1 + CALL CONSTF! ANI 1! RET +; +if BANKED + +SET$CTLS$MODE: + ;SET CTLS STATUS OR INPUT FLAG FOR QUEUE MANAGER + LXI H,QFLAG! MVI M,40H! XTHL! PCHL + +endif +; +TEST$CTLS$MODE: + ;RETURN WITH Z FLAG RESET IF CTL-S CTL-Q CHECKING DISABLED + MOV B,A! LDA CONMODE! ANI 2! MOV A,B! RET +; +conbrk: ;check for character ready + CALL TEST$CTLS$MODE! JNZ CONSTX + lda kbchar! ora a! jnz CONBRK1 ;skip if active kbchar + ;no active kbchar, check external break + ;DOES BIOS HAVE TYPE AHEAD? +if BANKED + LDA TYPE$AHEAD! INR A! JZ CONSTX ;YES +endif + ;CONBRKX CALLED BY CONOUT + + CONBRKX: + ;HAS CTL-S INTERCEPT BEEN DISABLED? + CALL TEST$CTLS$MODE! RNZ ;YES + ;DOES KBCHAR CONTAIN CTL-S? + LDA KBCHAR! CPI CTLS! JZ CONBRK1 ;YES +if BANKED + CALL SET$CTLS$MODE +endif + ;IS A CHARACTER READY FOR INPUT? + call constf +if BANKED + POP H! MVI M,0 +endif + ani 1! rz ;NO + ;character ready, read it +if BANKED + CALL SET$CTLS$MODE +endif + call coninf +if BANKED + POP H! MVI M,0 +endif + CONBRK1: + cpi ctls! jnz conb0 ;check stop screen function + ;DOES KBCHAR CONTAIN A CTL-S? + LXI H,KBCHAR! CMP M! JNZ CONBRK2 ;NO + MVI M,0 ; KBCHAR = 0 + ;found ctls, read next character + CONBRK2: + +if BANKED + CALL SET$CTLS$MODE +endif + call coninf ;to A +if BANKED + POP H! MVI M,0 +endif + cpi ctlc! JNZ CONBRK3 + LDA CONMODE! ANI 08H! JZ REBOOTX + XRA A + CONBRK3: + SUI CTLQ! RZ ; RETURN WITH A = ZERO IF CTLQ + INR A! CALL CONB3! JMP CONBRK2 + conb0: + LXI H,KBCHAR + + MOV B,A + ;IS CONMODE(1) TRUE? + LDA CONMODE! RAR! JNC $+7 ;NO + ;DOES KBCHAR = CTLC? + MVI A,CTLC! CMP M! RZ ;YES - RETURN + MOV A,B + + CPI CTLQ! JZ CONB2 + CPI CTLP! JZ CONB2 + ;character in accum, save it + MOV M,A + conb1: + ;return with true set in accumulator + mvi a,1! ret + CONB2: + XRA A! MOV M,A! RET + CONB3: + CZ TOGGLE$LISTCP + MVI C,7! CNZ CONOUTF + RET +; +TOGGLE$LISTCP: + ; IS PRINTER ECHO DISABLED? + LDA CONMODE! ANI 14H! JNZ TOGGLE$L1 ;YES + LXI H,LISTCP! MVI A,1! XRA M! ANI 1 + MOV M,A! RET +TOGGLE$L1: + XRA A! RET +; +QCONOUTF: + ;DOES FX = INPUT? + LDA FX! DCR A! JZ CONOUTF ;YES + ;IS ESCAPE SEQUENCE DECODING IN EFFECT? + MOV A,B +;;; ANI 8 ;[JCE] DRI Patch 13 + ANI 10h + JNZ SCONOUTF ;YES + JMP CONOUTF +; +conout: + ;compute character position/write console char from C + ;compcol = true if computing column position + lda compcol! ora a! jnz compout + ;write the character, then compute the column + ;write console character from C + ;B ~= 0 -> ESCAPE SEQUENCE DECODING + LDA CONMODE! ANI 14H! MOV B,A + push b + ;CALL CONBRKX FOR OUTPUT FUNCTIONS ONLY + LDA FX! DCR A! CNZ CONBRKX + pop b! push b ;recall/save character + call QCONOUTF ;externally, to console + pop b + ;SKIP ECHO WHEN CONMODE & 14H ~= 0 + MOV A,B! ORA A! JNZ COMPOUT + push b ;recall/save character + ;may be copying to the list device + lda listcp! ora a! cnz listf ;to printer, if so + pop b ;recall the character + compout: + mov a,c ;recall the character + ;and compute column position + lxi h,column ;A = char, HL = .column + cpi rubout! rz ;no column change if nulls + inr m ;column = column + 1 + cpi ' '! rnc ;return if graphic + ;not graphic, reset column position + dcr m ;column = column - 1 + mov a,m! ora a! rz ;return if at zero + ;not at zero, may be backspace or end line + mov a,c ;character back to A + cpi ctlh! jnz notbacksp + ;backspace character + dcr m ;column = column - 1 + ret + notbacksp: + ;not a backspace character, eol? + cpi cr! rnz ;return if not + ;end of line, column = 0 + mvi m,0 ;column = 0 + ret +; +ctlout: + ;send C character with possible preceding up-arrow + mov a,c! call echoc ;cy if not graphic (or special case) + jnc tabout ;skip if graphic, tab, cr, lf, or ctlh + ;send preceding up arrow + push psw! mvi c,ctl! call conout ;up arrow + pop psw! ori 40h ;becomes graphic letter + mov c,a ;ready to print +if BANKED + call chk$column! rz +endif + ;(drop through to tabout) +; +tabout: + ;IS FX AN INPUT FUNCTION? + LDA FX! DCR A! JZ TABOUT1 ;YES - ALWAYS EXPAND TABS FOR ECHO + ;HAS TAB EXPANSION BEEN DISABLED OR + ;ESCAPE SEQUENCE DECODING BEEN ENABLED? + LDA CONMODE! ANI 14H! JNZ CONOUT ;YES +TABOUT1: + ;expand tabs to console + mov a,c! cpi tab! jnz conout ;direct to conout if not + ;tab encountered, move to next tab position + tab0: + +if BANKED + lda fx! cpi 1! jnz tab1 + call chk$column! rz + tab1: +endif + + mvi c,' '! call conout ;another blank + lda column! ani 111b ;column mod 8 = 0 ? + jnz tab0 ;back for another if not + ret +; +; +backup: + ;back-up one screen position + call pctlh + +if BANKED + lda comchr! cpi ctla! rz +endif + + mvi c,' '! call conoutf +; (drop through to pctlh) ; +pctlh: + ;send ctlh to console without affecting column count + mvi c,ctlh! jmp conoutf + ;ret +; +crlfp: + ;print #, cr, lf for ctlx, ctlu, ctlr functions + ;then move to strtcol (starting column) + mvi c,'#'! call conout + call crlf + ;column = 0, move to position strtcol + crlfp0: + lda column! lxi h,strtcol + cmp m! rnc ;stop when column reaches strtcol + mvi c,' '! call conout ;print blank + jmp crlfp0 +;; +; +crlf: + ;carriage return line feed sequence + mvi c,cr! call conout! mvi c,lf! jmp conout + ;ret +; +print: + ;print message until M(BC) = '$' + LXI H,OUTDELIM + ldax b! CMP M! rz ;stop on $ + ;more to print + inx b! push b! mov c,a ;char to C + call tabout ;another character printed + pop b! jmp print +; +QCONIN: + +if BANKED + lhld apos! mov a,m! sta ctla$sw +endif + ;IS BUFFER ADDRESS = 0? + LHLD CONBUFFADD! MOV A,L! ORA H! JZ CONIN ;YES + ;IS CHARACTER IN BUFFER < 5? + +if BANKED + call qconinx ; mov a,m with bank 1 switched in +else + MOV A,M +endif + + INX H + ORA A! JNZ QCONIN1 ; NO + LXI H,0 +QCONIN1: + SHLD CONBUFFADD! SHLD CONBUFFLEN! RNZ ; NO + JMP CONIN + +if BANKED + +chk$column: + lda conwidth! mov e,a! lda column! cmp e! ret +; +expand: + xchg! lhld apos! xchg +expand1: + ldax d! ora a! rz + inx d! inx h! mov m,a! inr b! jmp expand1 +; +copy$xbuff: + mov a,b! ora a! rz + push b! mov c,b! push h! xchg! inx d + lxi h,xbuff + call move + mvi m,0! shld xpos + pop h! pop b! ret +; +copy$cbuff: + lda ccpflgs+1! ral! rnc + lxi h,xbuff! lxi d,cbuff! inr c! jnz copy$cbuff1 + xchg! mov a,b! ora a! rz + sta cbuff$len + push d! lxi b,copy$cbuff2! push b + mov b,a +copy$cbuff1: + inr b! mov c,b! jmp move +copy$cbuff2: + pop h! dcx h! mvi m,0! ret +; +save$col: + lda column! sta save$column! ret +; +clear$right: + lda column! lxi h,ctla$column! cmp m! rnc + mvi c,20h! call conout! jmp clear$right +; +reverse: + lda save$column! lxi h,column! cmp m! rnc + mvi c,ctlh! call conout! jmp reverse +; +chk$buffer$size: + push b! push h + lhld apos! mvi e,0 +cbs1: + mov a,m! ora a! jz cbs2 + inr e! inx h! jmp cbs1 +cbs2: + mov a,b! add e! cmp c + push a! mvi c,7! cnc conoutf + pop a! pop h! pop b! rc + pop d! pop d! jmp readnx +; +refresh: + lda ctla$sw! ora a! rz + lda comchr! cpi ctla! rz + cpi ctlf! rz + cpi ctlw! rz +refresh0: + push h! push b + call save$col + lhld apos +refresh1: + mov a,m! ora a! jz refresh2 + mov c,a! call chk$column! jc refresh05 + mov a,e! sta column! jmp refresh2 +refresh05: + push h! call ctlout + pop h! inx h! jmp refresh1 +refresh2: + lda column! sta new$ctla$col +refresh3: + call clear$right + call reverse + lda new$ctla$col! sta ctla$column + pop b! pop h! ret +; +init$apos: + lxi h,aposi! shld apos + xra a! sta ctla$sw + ret +; +init$xpos: + lxi h,xbuff! shld xpos! ret +; +set$ctla$column: + lxi h,ctla$sw! mov a,m! ora a! rnz + inr m! lda column! sta ctla$column! ret +; +readi: + call chk$column! cnc crlf + lda cbuff$len! mov b,a + mvi c,0! call copy$cbuff +else + +readi: + MOV A,D! ORA E! JNZ READ + LHLD DMAAD! SHLD INFO + INX H! INX H! SHLD CONBUFFADD +endif + +read: ;read to info address (max length, current length, buffer) + +if BANKED + call init$xpos + call init$apos +readx: + call refresh + xra a! sta ctlw$sw +readx1: + +endif + + MVI A,1! STA FX + lda column! sta strtcol ;save start for ctl-x, ctl-h + lhld info! mov c,m! inx h! push h + XRA A! MOV B,A! STA SAVEPOS + CMP C! JNZ $+4 + INR C + ;B = current buffer length, + ;C = maximum buffer length, + ;HL= next to fill - 1 + readnx: + ;read next character, BC, HL active + push b! push h ;blen, cmax, HL saved + readn0: + +if BANKED + lda ctlw$sw! ora a! cz qconin +nxtline: + sta comchr +else + CALL QCONIN ;next char in A +endif + + ;ani 7fh ;mask parity bit + pop h! pop b ;reactivate counters + cpi cr! jz readen ;end of line? + cpi lf! jz readen ;also end of line + +if BANKED + cpi ctlf! jnz not$ctlf + do$ctlf: + call chk$column! dcr e! cmp e! jnc readnx + do$ctlf0: + xchg! lhld apos! mov a,m! ora a! jz ctlw$l15 + inx h! shld apos! xchg! jmp notr + not$ctlf: + cpi ctlw! jnz not$ctlw + do$ctlw: + xchg! lhld apos! mov a,m! ora a! jz ctlw$l1 + xchg! call chk$column! dcr e! cmp e! xchg! jc ctlw$l0 + xchg! call refresh0! xchg! jmp ctlw$l13 + ctlw$l0: + lhld apos! mov a,m + inx h! shld apos! jmp ctlw$l3 + ctlw$l1: + lxi h,ctla$sw! mov a,m! mvi m,0 + ora a! jz ctlw$l2 + ctlw$l13: + lxi h,ctlw$sw! mvi m,0 + ctlw$l15: + xchg! jmp readnx + ctlw$l2: + lda ctlw$sw! ora a! jnz ctlw$l25 + mov a,b! ora a! jnz ctlw$l15 + call init$xpos + ctlw$l25: + lhld xpos! mov a,m! ora a + sta ctlw$sw! jz ctlw$l15 + inx h! shld xpos + ctlw$l3: + lxi h,ctlw$sw! mvi m,ctlw + xchg! jmp notr + not$ctlw: + cpi ctla! jnz not$ctla + do$ctla: + ;do we have any characters to back over? + lda strtcol! mov d,a! lda column! cmp d + jz readnx + sta compcol ;COL > 0 + mov a,b! ora a! jz linelen + ;characters remain in buffer, backup one + dcr b ;remove one character + ;compcol > 0 marks repeat as length compute + ;backup one position in xbuff + push h + call set$ctla$column + pop d + lhld apos! dcx h + shld apos! ldax d! mov m,a! xchg! jmp linelen + not$ctla: + cpi ctlb! jnz not$ctlb + do$ctlb: + lda save$pos! cmp b! jnz ctlb$l0 + mvi a,ctlw! sta ctla$sw + sta comchr! jmp do$ctlw + ctlb$l0: + xchg! lhld apos! inr b + ctlb$l1: + dcr b! lda save$pos! cmp b! jz ctlb$l2 + dcx h! ldax d! mov m,a! dcx d! jmp ctlb$l1 + ctlb$l2: + shld apos + push b! push d + call set$ctla$column + ctlb$l3: + lda column! mov b,a + lda strtcol! cmp b! jz read$n0 + mvi c,ctlh! call conout! jmp ctlb$l3 + not$ctlb: + cpi ctlk! jnz not$ctlk + xchg! lxi h,aposi! shld apos + xchg! call refresh + jmp readnx + not$ctlk: + cpi ctlg! jnz not$ctlg + lda ctla$sw! ora a! jz readnx + jmp do$ctlf0 + not$ctlg: +endif + + cpi ctlh! jnz noth ;backspace? + LDA CTLH$ACT! INR A! JZ DO$RUBOUT + DO$CTLH: + ;do we have any characters to back over? + LDA STRTCOL! MOV D,A! LDA COLUMN! CMP D + jz readnx + STA COMPCOL ;COL > 0 + MOV A,B! ORA A! JZ $+4 + ;characters remain in buffer, backup one + dcr b ;remove one character + ;compcol > 0 marks repeat as length compute + jmp linelen ;uses same code as repeat + noth: + ;not a backspace + cpi rubout! jnz notrub ;rubout char? + LDA RUBOUT$ACT! INR A! JZ DO$CTLH + DO$RUBOUT: +if BANKED + mvi a,rubout! sta comchr + lda ctla$sw! ora a! jnz do$ctlh +endif + ;rubout encountered, rubout if possible + mov a,b! ora a! jz readnx ;skip if len=0 + ;buffer has characters, resend last char + mov a,m! dcr b! dcx h ;A = last char + ;blen=blen-1, next to fill - 1 decremented + jmp rdech1 ;act like this is an echo + notrub: + ;not a rubout character, check end line + cpi ctle! jnz note ;physical end line? + ;yes, save active counters and force eol + push b! MOV A,B! STA SAVE$POS + push h +if BANKED + lda ctla$sw! ora a! cnz clear$right +endif + call crlf +if BANKED + call refresh +endif + xra a! sta strtcol ;start position = 00 + jmp readn0 ;for another character + note: + ;not end of line, list toggle? + cpi ctlp! jnz notp ;skip if not ctlp + ;list toggle - change parity + push h ;save next to fill - 1 + PUSH B + XRA A! CALL CONB3 + POP B + pop h! jmp readnx ;for another char + notp: + ;not a ctlp, line delete? + cpi ctlx! jnz notx + pop h ;discard start position + ;loop while column > strtcol + backx: + lda strtcol! lxi h,column +if BANKED + cmp m! jc backx1 + lhld apos! mov a,m! ora a! jnz readx + jmp read + backx1: +else + cmp m! jnc read ;start again +endif + dcr m ;column = column - 1 + call backup ;one position + jmp backx + notx: + ;not a control x, control u? + ;not control-X, control-U? + cpi ctlu! jnz notu ;skip if not +if BANKED + xthl! call copy$xbuff! xthl +endif + ;delete line (ctlu) + do$ctlu: + call crlfp ;physical eol + pop h ;discard starting position + jmp read ;to start all over + notu: + ;not line delete, repeat line? + cpi ctlr! jnz notr + XRA A! STA SAVEPOS +if BANKED + xchg! call init$apos! xchg + mov a,b! ora a! jz do$ctlu + xchg! lhld apos! inr b + ctlr$l1: + dcr b! jz ctlr$l2 + dcx h! ldax d! mov m,a! dcx d + jmp ctlr$l1 + ctlr$l2: + shld apos! push b! push d + call crlfp! mvi a,ctlw! sta ctlw$sw + sta ctla$sw! jmp readn0 +endif + linelen: + ;repeat line, or compute line len (ctlh) + ;if compcol > 0 + push b! call crlfp ;save line length + pop b! pop h! push h! push b + ;bcur, cmax active, beginning buff at HL + rep0: + mov a,b! ora a! jz rep1 ;count len to 00 + inx h! mov c,m ;next to print + DCR B + POP D! PUSH D! MOV A,D! SUB B! MOV D,A + push b! push h ;count length down + LDA SAVEPOS! CMP D! CC CTLOUT + pop h! pop b ;recall remaining count + jmp rep0 ;for the next character + rep1: + ;end of repeat, recall lengths + ;original BC still remains pushed + push h ;save next to fill + lda compcol! ora a ;>0 if computing length + jz readn0 ;for another char if so + ;column position computed for ctlh + lxi h,column! sub m ;diff > 0 + sta compcol ;count down below + ;move back compcol-column spaces + backsp: + ;move back one more space + call backup ;one space + lxi h,compcol! dcr m + jnz backsp +if BANKED + call refresh +endif + jmp readn0 ;for next character + notr: + ;not a ctlr, place into buffer + ;IS BUFFER FULL? + PUSH A + MOV A,B! CMP C! JC RDECH0 ;NO + ;DISCARD CHARACTER AND RING BELL + POP A! PUSH B! PUSH H + MVI C,7! CALL CONOUTF! JMP READN0 + RDECH0: + +if BANKED + lda comchr! cpi ctlg! jz rdech05 + lda ctla$sw! ora a! cnz chk$buffer$size + rdech05: +endif + + POP A + inx h! mov m,a ;character filled to mem + inr b ;blen = blen + 1 + rdech1: + ;look for a random control character + push b! push h ;active values saved + mov c,a ;ready to print +if BANKED + call save$col +endif + call ctlout ;may be up-arrow C + pop h! pop b +if BANKED + lda comchr! cpi ctlg! jz do$ctlh + cpi rubout! jz rdech2 + call refresh + rdech2: +endif + LDA CONMODE! ANI 08H +;;; JNZ NOTC ;[JCE] DRI Patch 13 + jnz patch$064b + + mov a,m ;recall char + cpi ctlc ;set flags for reboot test +patch$064b: mov a,b ;move length to A + jnz notc ;skip if not a control c + cpi 1 ;control C, must be length 1 + jz REBOOTX ;reboot if blen = 1 + ;length not one, so skip reboot + notc: + ;not reboot, are we at end of buffer? +if BANKED + cmp c! jnc buffer$full +else + jmp readnx ;go for another if not +endif + +if BANKED + push b! push h + call chk$column! jc readn0 + lda ctla$sw! ora a! jz do$new$line + lda comchr! cpi ctlw! jz back$one + cpi ctlf! jz back$one + + do$newline: + mvi a,ctle! jmp nxtline + + back$one: + ;back up to previous character + pop h! pop b + dcr b! xchg + lhld apos! dcx h! shld apos + ldax d! mov m,a! xchg! dcx h + push b! push h! call reverse + ;disable ctlb or ctlw + xra a! sta ctlw$sw! jmp readn0 + + buffer$full: + xra a! sta ctlw$sw! jmp readnx +endif + readen: + ;end of read operation, store blen +if BANKED + call expand +endif + pop h! mov m,b ;M(current len) = B +if BANKED + push b + call copy$xbuff + pop b + mvi c,0ffh! call copy$cbuff +endif + LXI H,0! SHLD CONBUFFADD + mvi c,cr! jmp conout ;return carriage + ;ret +; +func1 equ CONECH + ;return console character with echo +; +func2: equ tabout + ;write console character with tab expansion +; +func3: + ;return reader character + call readerf + jmp sta$ret +; +;func4: equated to punchf + ;write punch character +; +;func5: equated to listf + ;write list character + ;write to list device +; +func6: + ;direct console i/o - read if 0ffh + mov a,c! inr a! jz dirinp ;0ffh => 00h, means input mode + inr a! JZ DIRSTAT ;0feh => direct STATUS function + INR A! JZ DIRINP1 ;0fdh => direct input, no status + JMP CONOUTF + DIRSTAT: + ;0feH in C for status + CALL CONSTX! JNZ LRET$EQ$FF! JMP STA$RET + dirinp: + CALL CONSTX ;status check + ora a! RZ ;skip, return 00 if not ready + ;character is ready, get it + dirinp1: + call CONIN ;to A + jmp sta$ret +; +func7: + call auxinstf + jmp sta$ret +; +func8: + call auxoutstf + jmp sta$ret +; +func9: + ;write line until $ encountered + xchg ;was lhld info + mov c,l! mov b,h ;BC=string address + jmp print ;out to console + +func10 equ readi + ;read a buffered console line + +func11: + ;IS CONMODE(1) TRUE? + LDA CONMODE! RAR! JNC NORMAL$STATUS ;NO + ;CTL-C ONLY STATUS CHECK +if BANKED + LXI H,QFLAG! MVI M,80H! PUSH H +endif + LXI H,CTLC$STAT$RET! PUSH H + ;DOES KBCHAR = CTL-C? + LDA KBCHAR! CPI CTLC! JZ CONB1 ;YES + ;IS THERE A READY CHARACTER? + CALL CONSTF! ORA A! RZ ;NO + ;IS THE READY CHARACTER A CTL-C? + CALL CONINF! CPI CTLC! JZ CONB0 ;YES + STA KBCHAR! XRA A! RET + +CTLC$STAT$RET: + +if BANKED + CALL STA$RET + POP H! MVI M,0! RET +else + JMP STA$RET +endif + +NORMAL$STATUS: + ;check console status + call conbrk + ;(drop through to sta$ret) +sta$ret: + ;store the A register to aret + sta aret +func$ret: ; + ret ;jmp goback (pop stack for non cp/m functions) +; +setlret1: + ;set lret = 1 + mvi a,1! jmp sta$ret ; +; +FUNC109: ;GET/SET CONSOLE MODE + ;DOES DE = 0FFFFH? + MOV A,D! ANA E! INR A + LHLD CONMODE! JZ STHL$RET ;YES - RETURN CONSOLE MODE + XCHG! SHLD CONMODE! RET ;NO - SET CONSOLE MODE +; +FUNC110: ;GET/SET FUNCTION 9 DELIMITER + LXI H,OUT$DELIM + ;DOES DE = 0FFFFH? + MOV A,D! ANA E! INR A + MOV A,M! JZ STA$RET ;YES - RETURN DELIMITER + MOV M,E! RET ;NO - SET DELIMITER +; +FUNC111: ;PRINT BLOCK TO CONSOLE +FUNC112: ;LIST BLOCK + XCHG! MOV E,M! INX H! MOV D,M! INX H + MOV C,M! INX H! MOV B,M! XCHG + ;HL = ADDR OF STRING + ;BC = LENGTH OF STRING +BLK$OUT: + MOV A,B! ORA C! RZ + PUSH B! PUSH H! MOV C,M + LDA FX! CPI 111! JZ BLK$OUT1 + CALL LISTF! JMP BLK$OUT2 +BLK$OUT1: + CALL TABOUT +BLK$OUT2: + POP H! INX H! POP B! DCX B + JMP BLK$OUT + +SCONOUTF EQU CONOUTF + +; +; data areas +; +compcol:db 0 ;true if computing column position +strtcol:db 0 ;starting column position after read + +if not BANKED + +kbchar: db 0 ;initial key char = 00 + +endif + +SAVEPOS:DB 0 ;POSITION IN BUFFER CORRESPONDING TO + ;BEGINNING OF LINE +if BANKED + +comchr: db 0 +cbuff$len: db 0 +cbuff: ds 256 + db 0 +xbuff: db 0 + ds 354 +aposi: db 0 +xpos: dw 0 +apos: dw 0 +ctla$sw: db 0 +ctlw$sw: db 0 +save$column: db 0 +ctla$column: db 0 +new$ctla$col: db 0 + +endif + +; end of BDOS Console module +; +;********************************************************************** +;***************************************************************** +; +; Error Messages + +if BANKED + +md equ 0 + +else + +md equ 24h + +endif + +dskmsg: db 'CP/M Error On ' +dskerr: db ' : ',md +permsg: db 'Disk I/O',md +selmsg: db 'Invalid Drive',md +rofmsg: db 'Read/Only File',md +rodmsg: db 'Read/Only Disk',md + +if not MPM + +passmsg: + +if BANKED + db 'Password Error',md +endif + +fxstsmsg: + db 'File Exists',md + +wildmsg: + db '? in Filename',md + +endif +if MPM + +setlret1: + mvi a,1 +sta$ret: + sta aret +func$ret: + ret +entsp: ds 2 + +endif + +;***************************************************************** +;***************************************************************** +; +; common values shared between bdosi and bdos + +if MPM + +usrcode:db 0 ; current user number + +endif + +aret: ds 2 ; address value to return +lret equ aret ; low(aret) + +;***************************************************************** +;***************************************************************** +;** ** +;** b a s i c d i s k o p e r a t i n g s y s t e m ** +;** ** +;***************************************************************** +;***************************************************************** + +; literal constants + +true equ 0ffh ; constant true +false equ 000h ; constant false +enddir equ 0ffffh ; end of directory +byte equ 1 ; number of bytes for "byte" type +word equ 2 ; number of bytes for "word" type + +; fixed addresses in low memory + +tfcb equ 005ch ; default fcb location +tbuff equ 0080h ; default buffer location + +; error message handlers + +rod$error: + ; report read/only disk error + mvi c,2! jmp goerr + +rof$error: + ; report read/only file error + mvi c,3! jmp goerr + +sel$error: + ; report select error + mvi c,4 + ; Invalidate curdsk to force select call + ; at next curselect call + mvi a,0ffh! sta curdsk + +goerr: + ; hl = .errorhandler, call subroutine + mov h,c! mvi l,0ffh! shld aret + +if MPM + call test$error$mode! jnz rtn$phy$errs + mov a,c! lxi h,pererr-2! jmp bdos$jmp +else + +goerr1: + lda adrive! sta errdrv + lda error$mode! inr a! cnz error +endif + +rtn$phy$errs: + +if MPM + lda lock$shell! ora a! jnz lock$perr +endif + + ; Return 0ffffh if fx = 27 or 31 + + lda fx + cpi 27! jz goback0 + cpi 31! jz goback0 + jmp goback + +if MPM + +test$error$mode: + lxi d,pname+4 +test$error$mode1: + call rlr! dad d + mov a,m! ani 80h! ret +endif + +if BANKED + +set$copy$cr$only: + lda copy$cr$init! sta copy$cr$only! ret + +reset$copy$cr$only: + xra a! sta copy$cr$init! sta copy$cr$only! ret + +endif + +bde$e$bde$m$hl: + mov a,e! sub l! mov e,a + mov a,d! sbb h! mov d,a + rnc! dcr b! ret + +bde$e$bde$p$hl: + mov a,e! add l! mov e,a + mov a,d! adc h! mov d,a + rnc! inr b! ret + +shl3bv: + inr c +shl3bv1: + dcr c! rz + dad h! adc a! jmp shl3bv1 + +incr$rr: + call get$rra + inr m! rnz + inx h! inr m! rnz + inx h! inr m! ret + +save$rr: + call save$rr2! xchg +save$rr1: + mvi c,3! jmp move ; ret +save$rr2: + call get$rra! lxi d,save$ranr! ret + +reset$rr: + call save$rr2! jmp save$rr1 ; ret + +compare: + ldax d! cmp m! rnz + inx h! inx d! dcr c! rz + jmp compare + +; +; local subroutines for bios interface +; + +move: + ; Move data length of length c from source de to + ; destination given by hl + inr c ; in case it is zero + move0: + dcr c! rz ; more to move + ldax d! mov m,a ; one byte moved + inx d! inx h ; to next byte + jmp move0 + +selectdisk: + ; Select the disk drive given by register D, and fill + ; the base addresses curtrka - alloca, then fill + ; the values of the disk parameter block + mov c,d ; current disk# to c + ; lsb of e = 0 if not yet logged - in + call seldskf ; hl filled by call + ; hl = 0000 if error, otherwise disk headers + mov a,h! ora l! rz ; Return with C flag reset if select error + ; Disk header block address in hl + mov e,m! inx h! mov d,m! inx h ; de=.tran + shld cdrmaxa! inx h! inx h ; .cdrmax + shld curtrka! inx h! inx h ; hl=.currec + shld curreca! inx h! inx h ; hl=.buffa + inx h! shld drvlbla! inx h + shld lsn$add! inx h! inx h + ; de still contains .tran + xchg! shld tranv ; .tran vector + lxi h,dpbaddr ; de= source for move, hl=dest + mvi c,addlist! call move ; addlist filled + ; Now fill the disk parameter block + lhld dpbaddr! xchg ; de is source + lxi h,sectpt ; hl is destination + mvi c,dpblist! call move ; data filled + ; Now set single/double map mode + lhld maxall ; largest allocation number + mov a,h ; 00 indicates < 255 + lxi h,single! mvi m,true ; Assume a=00 + ora a! jz retselect + ; high order of maxall not zero, use double dm + mvi m,false + retselect: + ; C flag set indicates successful select + stc! ret + +home: + ; Move to home position, then offset to start of dir + call homef + xra a ; constant zero to accumulator + lhld curtrka! mov m,a! inx h! mov m,a ; curtrk=0000 + lhld curreca! mov m,a! inx h! mov m,a ; currec=0000 + inx h! mov m,a ; currec high byte=00 + +if MPM + lxi h,0! shld dblk ; dblk = 0000 +endif + + ret + +rdbuff: + ; Read buffer and check condition + mvi a,1! sta readf$sw + call readf ; current drive, track, sector, dma + jmp diocomp ; Check for i/o errors + +wrbuff: + ; Write buffer and check condition + ; write type (wrtype) is in register c + xra a! sta readf$sw + call writef ; current drive, track, sector, dma +diocomp: ; Check for disk errors + ora a! rz + mov c,a + call chk$media$flag + mov a,c + cpi 3! jc goerr + mvi c,1! jmp goerr + +chk$media$flag: + ; A = 0ffh -> media changed + inr a! rnz + +if BANKED + ; Handle media changes as I/O errors for + ; permanent drives + call chksiz$eq$8000h! rz +endif + + ; BIOS says media change occurred + ; Is disk logged-in? + lhld dlog! call test$vector! mvi c,1! rz ; no - return error + call media$change + pop h ; Discard return address + ; Was this a flush operation (fx = 48)? + lda fx! cpi 48! rz ; yes + ; Is this a flush to another drive? + lxi h,adrive! lda seldsk! cmp m! jnz reset$relog + ; Bail out if fx = read, write, close, or search next + call chk$exit$fxs + ; Is this a directory read operation? + lda readf$sw! ora a! rnz ; yes + ; Error - directory write operation + mvi c,2! jmp goerr ; Return disk read/only error + +reset$relog: + ; Reset relog if flushing to another drive + xra a! sta relog! ret + +if BANKED + +chksiz$eq$8000h: + ; Return with Z flag set if drive permanent + ; with no checksum vector + lhld chksiz! mvi a,80h! cmp h! rnz + xra a! cmp l! ret + +endif + +seekdir: + ; Seek the record containing the current dir entry + +if MPM + lxi d,0ffffh ; mask = ffff + lhld dblk! mov a,h! ora l! jz seekdir1 + lda blkmsk! mov e,a! xra a! mov d,a ; mask = blkmsk + lda blkshf! mov c,a! xra a + call shl3bv ; ahl = shl(dblk,blkshf) +seekdir1: + push h! push a ; Save ahl +endif + + lhld dcnt ; directory counter to hl + mvi c,dskshf! call hlrotr ; value to hl + shld drec + +if MPM + +; arecord = shl(dblk,blkshf) + shr(dcnt,dskshf) & mask + + mov a,l! ana e! mov l,a ; dcnt = dcnt & mask + mov a,h! ana d! mov h,a + pop b! pop d! call bde$e$bde$p$hl + +else + mvi b,0! xchg +endif + +set$arecord: + lxi h,arecord + mov m,e! inx h! mov m,d! inx h! mov m,b + ret + +seek: + ; Seek the track given by arecord (actual record) + + lhld curtrka! mov c,m! inx h! mov b,m ; bc = curtrk + push b ; s0 = curtrk + lhld curreca! mov e,m! inx h! mov d,m + inx h! mov b,m ; bde = currec + lhld arecord! lda arecord+2! mov c,a ; chl = arecord +seek0: + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + push h ; Save low(arecord) + jnc seek1 ; if arecord >= currec then go to seek1 + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! xthl! dcx h! xthl ; curtrk = curtrk - 1 + jmp seek0 +seek1: + lhld sectpt! call bde$e$bde$p$hl ; currec = currec + sectpt + pop h ; Restore low(arecord) + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + jc seek2 ; if arecord < currec then go to seek2 + xthl! inx h! xthl ; curtrk = curtrk + 1 + push h ; save low (arecord) + jmp seek1 +seek2: + xthl! push h ; hl,s0 = curtrk, s1 = low(arecord) + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! push d! push b! push h ; hl,s0 = curtrk, + ; s1 = high(arecord,currec), s2 = low(currec), + ; s3 = low(arecord) + xchg! lhld offset! dad d + mov b,h! mov c,l! shld track + call settrkf ; call bios settrk routine + ; Store curtrk + pop d! lhld curtrka! mov m,e! inx h! mov m,d + ; Store currec + pop b! pop d! + lhld curreca! mov m,e! inx h! mov m,d + inx h! mov m,b ; currec = bde + pop b ; bc = low(arecord), de = low(currec) + mov a,c! sub e! mov l,a ; hl = bc - de + mov a,b + sbb d + mov h,a + call shr$physhf + mov b,h! mov c,l + + lhld tranv! xchg ; bc=sector#, de=.tran + call sectran ; hl = tran(sector) + mov c,l! mov b,h ; bc = tran(sector) + shld sector + call setsecf ; sector selected + lhld curdma! mov c,l! mov b,h! jmp setdmaf + ; ret +shr$physhf: + lda physhf! mov c,a! jmp hlrotr + +; file control block (fcb) constants + +empty equ 0e5h ; empty directory entry +lstrec equ 127 ; last record# on extent +recsiz equ 128 ; record size +fcblen equ 32 ; file control block size +dirrec equ recsiz/fcblen ; directory fcbs / record +dskshf equ 2 ; log2(dirrec) +dskmsk equ dirrec-1 +fcbshf equ 5 ; log2(fcblen) + +extnum equ 12 ; extent number field +maxext equ 31 ; largest extent number +ubytes equ 13 ; unfilled bytes field +modnum equ 14 ; data module number + +maxmod equ 64 ; largest module number + +fwfmsk equ 80h ; file write flag is high order modnum +namlen equ 15 ; name length +reccnt equ 15 ; record count field +dskmap equ 16 ; disk map field +lstfcb equ fcblen-1 +nxtrec equ fcblen +ranrec equ nxtrec+1; random record field (2 bytes) + +; reserved file indicators + +rofile equ 9 ; high order of first type char +invis equ 10 ; invisible file in dir command + +; utility functions for file access + +dm$position: + ; Compute disk map position for vrecord to hl + lxi h,blkshf! mov c,m ; shift count to c + lda vrecord ; current virtual record to a + dmpos0: + ora a! rar! dcr c! jnz dmpos0 + ; a = shr(vrecord,blkshf) = vrecord/2**(sect/block) + mov b,a ; Save it for later addition + mvi a,8! sub m ; 8-blkshf to accumulator + mov c,a ; extent shift count in register c + lda extval ; extent value ani extmsk + dmpos1: + ; blkshf = 3,4,5,6,7, c=5,4,3,2,1 + ; shift is 4,3,2,1,0 + dcr c! jz dmpos2 + ora a! ral! jmp dmpos1 + dmpos2: + ; Arrive here with a = shl(ext and extmsk,7-blkshf) + add b ; Add the previous shr(vrecord,blkshf) value + ; a is one of the following values, depending upon alloc + ; bks blkshf + ; 1k 3 v/8 + extval * 16 + ; 2k 4 v/16+ extval * 8 + ; 4k 5 v/32+ extval * 4 + ; 8k 6 v/64+ extval * 2 + ; 16k 7 v/128+extval * 1 + ret ; with dm$position in a + +getdma: + lhld info! lxi d,dskmap! dad d! ret + +getdm: + ; Return disk map value from position given by bc + call getdma + dad b ; Index by a single byte value + lda single ; single byte/map entry? + ora a! jz getdmd ; Get disk map single byte + mov l,m! mov h,b! ret ; with hl=00bb + getdmd: + dad b ; hl=.fcb(dm+i*2) + ; double precision value returned + mov a,m! inx h! mov h,m! mov l,a! ret + +index: + ; Compute disk block number from current fcb + call dm$position ; 0...15 in register a + sta dminx + mov c,a! mvi b,0! call getdm ; value to hl + shld arecord! mov a,l! ora h! ret + +atran: + ; Compute actual record address, assuming index called + +; arecord = shl(arecord,blkshf) + + lda blkshf! mov c,a + lhld arecord! xra a! call shl3bv + shld arecord! sta arecord+2 + + shld arecord1 ; Save low(arecord) + +; arecord = arecord or (vrecord and blkmsk) + + lda blkmsk! mov c,a! lda vrecord! ana c + mov b,a ; Save vrecord & blkmsk in reg b & blk$off + sta blk$off + lxi h,arecord! ora m! mov m,a! ret + +get$atts: + ; Get volatile attributes starting at f'5 + ; info locates fcb + lhld info + lxi d,8! dad d ; hl = .fcb(f'8) + mvi c,4 +get$atts$loop: + mov a,m! add a! push a + mov a,d! rar! mov d,a + pop a! rrc! mov m,a + dcx h! dcr c! jnz get$atts$loop + mov a,d! ret + +get$s1: + ; Get current s1 field to a + call getexta! inx h! mov a,m! ret + +get$rra: + ; Get current ran rec field address to hl + lhld info! lxi d,ranrec! dad d ; hl=.fcb(ranrec) + ret + +getexta: + ; Get current extent field address to hl + lhld info! lxi d,extnum! dad d ; hl=.fcb(extnum) + ret + +getrcnta: + ; Get reccnt address to hl + lhld info! lxi d,reccnt! dad d! ret + +getfcba: + ; Compute reccnt and nxtrec addresses for get/setfcb + call getrcnta! xchg ; de=.fcb(reccnt) + lxi h,(nxtrec-reccnt)! dad d ; hl=.fcb(nxtrec) + ret + +getfcb: + ; Set variables from currently addressed fcb + call getfcba ; addresses in de, hl + mov a,m! sta vrecord ; vrecord=fcb(nxtrec) + xchg! mov a,m! ora a! jnz getfcb0 + call get$dir$ext! mov c,a! call set$rc! mov a,m +getfcb0: + cpi 81h! jc getfcb1 + mvi a,80h +getfcb1: + sta rcount ; rcount=fcb(reccnt) or 80h + call getexta ; hl=.fcb(extnum) + lda extmsk ; extent mask to a + ana m ; fcb(extnum) and extmsk + sta extval + ret + +setfcb: + ; Place values back into current fcb + call getfcba ; addresses to de, hl + ; fcb(cr) = vrecord + lda vrecord! mov m,a + ; Is fx < 22? (sequential read or write) + lda fx! cpi 22! jnc $+4 ; no + ; fcb(cr) = fcb(cr) + 1 + inr m + xchg! mov a,m! cpi 80h! rnc ; dont reset fcb(rc) if > 7fh + lda rcount! mov m,a ; fcb(reccnt)=rcount + ret + +zero$ext$mod: + call getexta! mov m,d! inx h! inx h! mov m,d + ret + +zero: + mov m,b! inx h! dcr c! rz + jmp zero + +hlrotr: + ; hl rotate right by amount c + inr c ; in case zero + hlrotr0: dcr c! rz ; return when zero + mov a,h! ora a! rar! mov h,a ; high byte + mov a,l! rar! mov l,a ; low byte + jmp hlrotr0 + +compute$cs: + ; Compute checksum for current directory buffer + lhld buffa ; current directory buffer + lxi b,4 ; b = 0, c = 4 +compute$cs0: + mvi d,32 ; size of fcb + xra a ; clear checksum value +compute$cs1: + add m! inx h! dcr d + jnz compute$cs1 + xra b! mov b,a! dcr c + jnz compute$cs0 + ret ; with checksum in a + +if MPM + +compute$cs: + ; Compute checksum for current directory buffer + mvi c,recsiz ; size of directory buffer + lhld buffa ; current directory buffer + xra a ; Clear checksum value + computecs0: + add m! inx h! dcr c ; cs = cs+buff(recsiz-c) + jnz computecs0 + ret ; with checksum in a + +chksum$fcb: ; Compute checksum for fcb + ; Add 1st 12 bytes of fcb + curdsk + + ; high$ext + xfcb$read$only + bbh + lxi h,pdcnt! mov a,m + inx h! add m ; Add high$ext + inx h! add m ; Add xfcb$read$only + inx h! add m ; Add curdsk + adi 0bbh ; Add 0bbh to bias checksum + lhld info! mvi c,12! call computecs0 + ; Skip extnum + inx h + ; Add fcb(s1) + add m! inx h + ; Skip modnum + inx h + ; Skip fcb(reccnt) + ; Add disk map + inx h! mvi c,16! call computecs0 + ora a! ret ; Z flag set if checksum valid + +set$chksum$fcb: + call chksum$fcb! rz + mov b,a! call gets1 + cma! add b! cma + mov m,a! ret + +reset$chksum$fcb: + xra a! sta comp$fcb$cks + call chksum$fcb! rnz + call get$s1! inr m! ret + +endif + +check$fcb: + +if MPM + xra a! sta check$fcb4 +check$fcb1: + call chek$fcb! rz +check$fcb2: + + ani 0fh! jnz check$fcb3 + lda pdcnt! ora a! jz check$fcb3 + call set$sdcnt! sta dont$close + call close1 + lxi h,lret! inr m! jz check$fcb3 + mvi m,0! call pack$sdcnt! mvi b,5 + call search$olist! rz +check$fcb3: + + pop h ; Discard return address +check$fcb4: + nop + mvi a,10! jmp sta$ret + +set$fcb$cks$flag: + mvi a,0ffh! sta comp$fcb$cks! ret + +else + call gets1! lhld lsn$add + cmp m! cnz chk$media$fcb +endif + +chek$fcb: + lda high$ext + +if MPM + + ; if ext & 0110$0000b = 0110$0000b then + ; set fcb(0) to 0 (user 0) + + cpi 0110$0000b! jnz chek$fcb1 +else + ora a! rz +endif + + lhld info! xra a! mov m,a ; fcb(0) = 0 +chek$fcb1: + +if MPM + jmp chksum$fcb ; ret +else + ret + +chk$media$fcb: + ; fcb(s1) ~= DPH login sequence # field + ; Is fcb addr < bdosadd? + +if banked + lhld user$info +else + lhld info +endif + + xchg! lhld bdosadd! call subdh! jnc chk$media1 ; no + ; Is rlog(drive) true? + lhld rlog! call testvector! rz ; no +chk$media1: + ; Return invalid fcb error code + pop h! pop h +chk$media2: + mvi a,10! jmp sta$ret +endif + +hlrotl: + ; Rotate the mask in hl by amount in c + inr c ; may be zero + hlrotl0: dcr c! rz ; return if zero + dad h! jmp hlrotl0 + +set$dlog: + lxi d,dlog +set$cdisk: + ; Set a "1" value in curdsk position of bc + lda curdsk +set$cdisk1: + mov c,a ; Ready parameter for shift + lxi h,1 ; number to shift + call hlrotl ; hl = mask to integrate + ldax d! ora l! stax d! inx d + ldax d! ora h! stax d! ret + +nowrite: + ; Return true if dir checksum difference occurred + lhld rodsk + +test$vector: + lda curdsk +test$vector1: + mov c,a! call hlrotr + mov a,l! ani 1b! ret ; non zero if curdsk bit on + +check$rodir: + ; Check current directory element for read/only status + call getdptra ; address of element + +check$rofile: + ; Check current buff(dptr) or fcb(0) for r/o status + call ro$test + rnc ; Return if not set + jmp rof$error ; Exit to read only disk message + +ro$test: + lxi d,rofile! dad d + mov a,m! ral! ret ; carry set if r/o + +check$write: + ; Check for write protected disk + call nowrite! rz ; ok to write if not rodsk + jmp rod$error ; read only disk error + +getdptra: + ; Compute the address of a directory element at + ; positon dptr in the buffer + + lhld buffa! lda dptr +addh: + ; hl = hl + a + add l! mov l,a! rnc + ; overflow to h + inr h! ret + +getmodnum: + ; Compute the address of the module number + ; bring module number to accumulator + ; (high order bit is fwf (file write flag) + lhld info! lxi d,modnum! dad d ; hl=.fcb(modnum) + mov a,m! ret ; a=fcb(modnum) + +clrmodnum: + ; Clear the module number field for user open/make + call getmodnum! mvi m,0 ; fcb(modnum)=0 + ret + +clr$ext: + ; fcb ext = fcb ext & 1fh + call getexta! mov a,m! ani 0001$1111b! mov m,a! + ret + +setfwf: + call getmodnum ; hl=.fcb(modnum), a=fcb(modnum) + ; Set fwf (file write flag) to "1" + ori fwfmsk! mov m,a ; fcb(modnum)=fcb(modnum) or 80h + ; also returns non zero in accumulator + ret + +compcdr: + ; Return cy if cdrmax > dcnt + lhld dcnt! xchg ; de = directory counter + lhld cdrmaxa ; hl=.cdrmax + mov a,e! sub m ; low(dcnt) - low(cdrmax) + inx h ; hl = .cdrmax+1 + mov a,d! sbb m ; hig(dcnt) - hig(cdrmax) + ; condition dcnt - cdrmax produces cy if cdrmax>dcnt + ret + +setcdr: + ; if not (cdrmax > dcnt) then cdrmax = dcnt+1 + call compcdr + rc ; Return if cdrmax > dcnt + ; otherwise, hl = .cdrmax+1, de = dcnt + inx d! mov m,d! dcx h! mov m,e + ret + +subdh: + ; Compute hl = de - hl + mov a,e! sub l! mov l,a! mov a,d! sbb h! mov h,a + ret + +newchecksum: + mvi c,0feh ; Drop through to compute new checksum +checksum: + ; Compute current checksum record and update the + ; directory element if c=true, or check for = if not + ; drec < chksiz? + lhld drec! xchg! lhld chksiz + mov a,h! ani 7fh! mov h,a ; Mask off permanent drive bit + call subdh ; de-hl + rnc ; Skip checksum if past checksum vector size + ; drec < chksiz, so continue + push b ; Save init flag + call compute$cs ; Check sum value to a + lhld checka ; address of check sum vector + xchg + lhld drec + dad d ; hl = .check(drec) + pop b ; Recall true=0ffh or false=00 to c + inr c ; 0ffh produces zero flag + jz initial$cs + inr c ; 0feh produces zero flag + jz update$cs + +if MPM + inr c! jz test$dir$cs +endif + + ; not initializing, compare + cmp m ; compute$cs=check(drec)? + rz ; no message if ok + ; checksum error, are we beyond + ; the end of the disk? + call nowrite +;;; rnz ;[JCE] DRI Patch 13 + nop + +media$change: + call discard$data + +if MPM + call flush$file0 +else + mvi a,0ffh! sta relog! sta hashl + call set$rlog +endif + + ; Reset the drive + + call set$dlog! jmp reset37x + +if MPM + test$dir$cs: + cmp m! jnz flush$files + ret +endif + + initial$cs: + ; initializing the checksum + cmp m! mov m,a! rz + ; or 1 into login seq # if media change + lhld lsn$add! mvi a,1! ora m! mov m,a! ret + + update$cs: + ; updating the checksum + mov m,a! ret + +set$ro: + ; Set current disk to read/only + lda seldsk! lxi d,rodsk! call set$cdisk1 ; sets bit to 1 + ; high water mark in directory goes to max + lhld dirmax! inx h! xchg ; de = directory max + lhld cdrmaxa ; hl = .cdrmax + mov m,e! inx h! mov m,d ; cdrmax = dirmax + ret + +set$rlog: + ; rlog(seldsk) = true + lhld olog! call test$vector! rz + lxi d,rlog! jmp set$cdisk + +tst$log$fxs: + lda chksiz+1! ani 80h! rnz + lxi h,log$fxs +tst$log0: + lda fx! mov b,a +tst$log1: + mov a,m! cmp b! rz + inx h! ora a! jnz tst$log1 + inr a! ret + +test$media$flag: + lhld lsn$add! inx h! mov a,m! ora a! ret + +chk$exit$fxs: + lxi h,goback! push h + ; does fx = read or write function? + ; and is drive removable? + lxi h,rw$fxs! call tst$log0! jz chk$media2 ; yes + ; is fx = close or searchn function? + ; and is drive removable? + lxi h,sc$fxs! call tst$log0! jz lret$eq$ff ; yes + pop h! ret + +tst$relog: + lxi h,relog! mov a,m! ora a! rz + mvi m,0 +drv$relog: + call curselect + lxi h,0! shld dcnt! xra a! sta dptr + ret + +set$lsn: + lhld lsn$add! mov c,m + call gets1! mov m,c! ret + +discard$data$bcb: + lhld dtabcba! mvi c,4! jmp discard0 + +discard$data: + lhld dtabcba! jmp discard + +discard$dir: + lhld dirbcba + +discard: + mvi c,1 +discard0: + mov a,l! ana h! inr a! rz + +if BANKED + mov e,m! inx h! mov d,m! xchg +discard1: + push h! push b + lxi d,adrive! call compare + pop b! pop h! jnz discard2 + + mvi m,0ffh +discard2: + lxi d,13! dad d + mov e,m! inx h! mov d,m + xchg! mov a,l! ora h! rz + jmp discard1 +else + push h + lxi d,adrive! call compare + pop h! rnz + mvi m,0ffh! ret +endif + +get$buffa: + push d! lxi d,10! dad d + mov e,m! inx h! mov d,m + +if BANKED + inx h! mov a,m! sta buffer$bank +endif + + xchg! pop d! ret + +rddir: + ; Read a directory entry into the directory buffer + call seek$dir + mvi a,3! jmp wrdir0 + +seek$copy: +wrdir: + ; Write the current directory entry, set checksum + call check$write + call newchecksum ; Initialize entry + mvi a,5 +wrdir0: + lxi h,0! shld last$block + lhld dirbcba + +if BANKED + cpi 5! jnz $+6 + lhld curbcba +endif + + call deblock + +setdata: + ; Set data dma address + lhld dmaad! jmp setdma ; to complete the call + +setdir1: + call get$buffa + +setdma: + ; hl=.dma address to set (i.e., buffa or dmaad) + shld curdma! ret + +dir$to$user: + +if not MPM + ; Copy the directory entry to the user buffer + ; after call to search or searchn by user code + lhld buffa! xchg ; source is directory buffer + lhld xdmaad ; destination is user dma address + lxi b,recsiz ; copy entire record + call movef +endif + ; Set lret to dcnt & 3 if search successful + lxi h,lret! mov a,m! inr a! rz + lda dcnt! ani dskmsk! mov m,a! ret + +make$fcb$inv: ; Flag fcb as invalid + ; Reset fcb write flag + call setfwf + ; Set 1st two bytes of diskmap to ffh + inx h! inx h! mvi a,0ffh! mov m,a! inx h! mov m,a + ret + +chk$inv$fcb: ; Check for invalid fcb + call getdma! jmp test$ffff + +tst$inv$fcb: ; Test for invalid fcb + call chk$inv$fcb! rnz + pop h! mvi a,9! jmp sta$ret! ; lret = 9 + +end$of$dir: + ; Return zero flag if at end of directory, non zero + ; if not at end (end of dir if dcnt = 0ffffh) + lxi h,dcnt +test$ffff: + mov a,m ; may be 0ffh + inx h! cmp m ; low(dcnt) = high(dcnt)? + rnz ; non zero returned if different + ; high and low the same, = 0ffh? + inr a ; 0ffh becomes 00 if so + ret + +set$end$dir: + ; Set dcnt to the end of the directory + lxi h,enddir! shld dcnt! ret + +read$dir: + call r$dir! jmp r$dir1 + +r$dir: + ; Read next directory entry, with c=true if initializing + + lhld dirmax! xchg ; in preparation for subtract + lhld dcnt! inx h! shld dcnt ; dcnt=dcnt+1 + ; Continue while dirmax >= dcnt (dirmax-dcnt no cy) + call subdh ; de-hl + + jc set$end$dir + + read$dir0: + ; not at end of directory, seek next element + ; initialization flag is in c + lda dcnt! ani dskmsk ; low(dcnt) and dskmsk + mvi b,fcbshf ; to multiply by fcb size + read$dir1: + add a! dcr b! jnz read$dir1 + ; a = (low(dcnt) and dskmsk) shl fcbshf + sta dptr ; ready for next dir operation + ora a! rnz ; Return if not a new record + read$dir2: + push b ; Save initialization flag c + call rd$dir ; Read the directory record + pop b ; Recall initialization flag + lda relog! ora a! rnz + jmp checksum ; Checksum the directory elt + +r$dir2: + call read$dir2 +r$dir1: + lda relog! ora a! rz + call chk$exit$fxs + call tst$relog! jmp rd$dir + +getallocbit: + ; Given allocation vector position bc, return with byte + ; containing bc shifted so that the least significant + ; bit is in the low order accumulator position. hl is + ; the address of the byte for possible replacement in + ; memory upon return, and d contains the number of shifts + ; required to place the returned value back into position + mov a,c! ani 111b! inr a! mov e,a! mov d,a + ; d and e both contain the number of bit positions to shift + + mov h,b! mov l,c! mvi c,3 ; bc = bc shr 3 + call hlrotr ; hlrotr does not touch d and e + mov b,h! mov c,l + + lhld alloca ; base address of allocation vector + dad b! mov a,m ; byte to a, hl = .alloc(bc shr 3) + ; Now move the bit to the low order position of a + rotl: rlc! dcr e! jnz rotl! ret + +setallocbit: + ; bc is the bit position of alloc to set or reset. the + ; value of the bit is in register e. + push d! call getallocbit ; shifted val a, count in d + ani 1111$1110b ; mask low bit to zero (may be set) + pop b! ora c ; low bit of c is masked into a + ; jmp rotr ; to rotate back into proper position + ; ret + +rotr: + ; byte value from alloc is in register a, with shift count + ; in register c (to place bit back into position), and + ; target alloc position in registers hl, rotate and replace + rrc! dcr d! jnz rotr ; back into position + mov m,a ; back to alloc + ret + +copy$alv: + ; If Z flag set, copy 1st ALV to 2nd + ; Otherwise, copy 2nd ALV to 1st + +if not BANKED + lda bdos$flags! rlc! rlc! rc +endif + + push a + call get$nalbs! mov b,h! mov c,l + lhld alloca! mov d,h! mov e,l! dad b + pop a! jz movef + xchg! jmp movef + +scandm$ab: + ; Set/Reset 1st and 2nd ALV + push b! call scandm$a + pop b! ;jmp scandm$b + +scandm$b: + ; Set/Reset 2nd ALV + +if not BANKED + lda bdos$flags! ani 40h! rnz +endif + + push b! call get$nalbs + xchg! lhld alloca + pop b! push h! dad d! shld alloca + call scandm$a + pop h! shld alloca! ret + +scandm$a: + ; Set/Reset 1st ALV + ; Scan the disk map addressed by dptr for non-zero + ; entries, the allocation vector entry corresponding + ; to a non-zero entry is set to the value of c (0,1) + call getdptra ; hl = buffa + dptr + ; hl addresses the beginning of the directory entry + lxi d,dskmap! dad d ; hl now addresses the disk map + push b ; Save the 0/1 bit to set + mvi c,fcblen-dskmap+1 ; size of single byte disk map + 1 + scandm0: + ; Loop once for each disk map entry + pop d ; Recall bit parity + dcr c! rz ; all done scanning? + ; no, get next entry for scan + push d ; Replace bit parity + lda single! ora a! jz scandm1 + ; single byte scan operation + push b ; Save counter + push h ; Save map address + mov c,m! mvi b,0 ; bc=block# + jmp scandm2 + scandm1: + ; double byte scan operation + dcr c ; count for double byte + push b ; Save counter + mov c,m! inx h! mov b,m ; bc=block# + push h ; Save map address + scandm2: + ; Arrive here with bc=block#, e=0/1 + mov a,c! ora b ; Skip if = 0000 + jz scandm3 + lhld maxall ; Check invalid index + mov a,l! sub c! mov a,h! sbb b ; maxall - block# + cnc set$alloc$bit + ; bit set to 0/1 + scandm3: + pop h! inx h ; to next bit position + pop b ; Recall counter + jmp scandm0 ; for another item + +get$nalbs: ; Get # of allocation vector bytes + lhld maxall! mvi c,3 + ; number of bytes in allocation vector is (maxall/8)+1 + call hlrotr! inx h! ret + +if MPM + +test$dir: + call home + call set$end$dir +test$dir1: + mvi c,0feh! call read$dir + lda flushed! ora a! rnz + call end$of$dir! rz + jmp test$dir1 +endif + +initialize: + ; Initialize the current disk + ; lret = false ; set to true if $ file exists + ; Compute the length of the allocation vector - 2 + +if MPM + lhld tlog! call test$vector! jz initialize1 + lhld tlog! call remove$drive! shld tlog + xra a! sta flushed + call test$dir! rz +initialize1: +else + + call test$media$flag ! mvi m,0 +;;; call discard$data ;[JCE] DRI Patch 13 +;;; call discard$dir + +endif +;[JCE] DRI Patch 13 + +if BANKED +;;; ; Is drive permanent with no chksum vector? +;;; call chksiz$eq$8000h +;;; jnz initialize2 ; no +;;; ; Is this an initial login operation? +;;; ; register A = 0 +;;; lhld lsn$add +;;; cmp m +;;; mvi m,2 +;;; call test$media$flag +;;; mvi m,0 ; Reset media change flag + call chksiz$eq$8000h + jnz patch$13ff + lhld lsn$add + cmp m + nop + nop + jz patch$13ff + jmp patch$2d40 + +patch$13ff: + + call discard$data + call discard$dir + +initialize2: +else ;BANKED + call discard$data ;[JCE] DRI Patch 13 + call discard$dir + +endif + + call get$nalbs ; Get # of allocation vector bytes + mov b,h! mov c,l ; Count down bc til zero + lhld alloca ; base of allocation vector + ; Fill the allocation vector with zeros + initial0: + mvi m,0! inx h ; alloc(i)=0 + dcx b ; Count length down + mov a,b! ora c! jnz initial0 + + lhld drvlbla! mov m,a ; Zero out drive desc byte + + ; Set the reserved space for the directory + + lhld dirblk! xchg + lhld alloca ; hl=.alloc() + mov m,e! inx h! mov m,d ; sets reserved directory blks + ; allocation vector initialized, home disk + call home + ; cdrmax = 3 (scans at least one directory record) + lhld cdrmaxa! mvi m,4! inx h! mvi m,0 + + call set$end$dir ; dcnt = enddir + lhld hashtbla! shld arecord1 + + ; Read directory entries and check for allocated storage + + initial2: + mvi c,true! call read$dir + call end$of$dir +if BANKED + jz patch$2d6a ;[JCE] DRI Patch 13 +else + jz copy$alv +endif + ; not end of directory, valid entry? + call getdptra ; hl = buffa + dptr + xchg! lhld arecord1! mov a,h! ana l! inr a! xchg + ; is hashtbla ~= 0ffffh + cnz init$hash ; yes - call init$hash + mvi a,21h! cmp m + jz initial2 ; Skip date & time records + + mvi a,empty! cmp m + jz initial2 ; go get another item + + mvi a,20h! cmp m! jz drv$lbl + mvi a,10h! ana m! jnz initial3 + + ; Now scan the disk map for allocated blocks + + mvi c,1 ; set to allocated + call scandm$a + initial3: + call setcdr ; set cdrmax to dcnt + jmp initial2 ; for another entry + +drv$lbl: + lxi d,extnum! dad d! mov a,m + lhld drvlbla! mov m,a! jmp initial3 + +copy$dirloc: + ; Copy directory location to lret following + ; delete, rename, ... ops + + lda dirloc! jmp sta$ret + ; ret + +compext: + ; Compare extent# in a with that in c, return nonzero + ; if they do not match + push b ; Save c's original value + push psw! lda extmsk! cma! mov b,a + ; b has negated form of extent mask + mov a,c! ana b! mov c,a ; low bits removed from c + pop psw! ana b ; low bits removed from a + sub c! ani maxext ; Set flags + pop b ; Restore original values + ret + +get$dir$ext: + ; Compute directory extent from fcb + ; Scan fcb disk map backwards + call getfcba ; hl = .fcb(vrecord) + mvi c,16! mov b,c! inr c! push b + ; b=dskmap pos (rel to 0) +get$de0: + pop b + dcr c + xra a ; Compare to zero +get$de1: + dcx h! dcr b; Decr dskmap position + cmp m! jnz get$de2 ; fcb(dskmap(b)) ~= 0 + dcr c! jnz get$de1 + ; c = 0 -> all blocks = 0 in fcb disk map +get$de2: + mov a,c! sta dminx + lda single! ora a! mov a,b + jnz get$de3 + rar ; not single, divide blk idx by 2 +get$de3: + push b! push h ; Save dskmap position & count + mov l,a! mvi h,0 ; hl = non-zero blk idx + ; Compute ext offset from last non-zero + ; block index by shifting blk idx right + ; 7 - blkshf + lda blkshf! mov d,a! mvi a,7! sub d + mov c,a! call hlrotr! mov b,l + ; b = ext offset + lda extmsk! cmp b! pop h! jc get$de0 + ; Verify computed extent offset <= extmsk + call getexta! mov c,m + cma! ani maxext! ana c! ora b + ; dir ext = (fcb ext & (~ extmsk) & maxext) | ext offset + pop b ; Restore stack + ret ; a = directory extent + +searchi: + ; search initialization + lhld info! shld searcha ; searcha = info +searchi1: + mov a,c! sta searchl ; searchl = c + call set$hash + mvi a,0ffh! sta dirloc ; changed if actually found + ret + +search$namlen: + mvi c,namlen! jmp search +search$extnum: + mvi c,extnum +search: + ; Search for directory element of length c at info + call searchi +search1: ; entry point used by rename + call set$end$dir ; dcnt = enddir + call tst$log$fxs! cz home + ; (drop through to searchn) + +searchn: + ; Search for the next directory element, assuming + ; a previous call on search which sets searcha and + ; searchl + +if MPM + lxi h,user0$pass! xra a! cmp m! mov m,a! cnz swap +else + xra a! sta user0$pass +endif + + call search$hash! jnz search$fin + mvi c,false! call read$dir ; Read next dir element + call end$of$dir! jz search$fin + ; not end of directory, scan for match + lhld searcha! xchg ; de=beginning of user fcb + ldax d ; first character + cpi empty ; Keep scanning if empty + jz searchnext + ; not empty, may be end of logical directory + push d ; Save search address + call compcdr ; past logical end? + pop d ; Recall address + jnc search$fin ; artificial stop +searchnext: + call getdptra ; hl = buffa+dptr + lda searchl! mov c,a ; length of search to c + mvi b,0 ; b counts up, c counts down + + mov a,m! cpi empty! cz save$dcnt$pos1 + +if BANKED + xra a! sta save$xfcb + mov a,m! ani 1110$1111b! cmp m! jz search$loop + xchg! cmp m! xchg! jnz search$loop + lda find$xfcb! ora a! jz search$n + sta save$xfcb! jmp searchok +endif + + searchloop: + mov a,c! ora a! jz endsearch + ldax d! cpi '?'! jz searchok ; ? in user fcb + ; Scan next character if not ubytes + mov a,b! cpi ubytes! jz searchok + ; not the ubytes field, extent field? + cpi extnum ; may be extent field + jz searchext ; Skip to search extent + cpi modnum! ldax d! cz searchmod + sub m! ani 7fh ; Mask-out flags/extent modulus + jnz searchnm ; Skip if not matched + jmp searchok ; matched character + searchext: + ldax d + ; Attempt an extent # match + push b ; Save counters + +if MPM + push h + lhld sdcnt + inr h! jnz dont$save + lhld dcnt! shld sdcnt + lhld dblk! shld sdblk + dont$save: + pop h +endif + + mov c,m ; directory character to c + call compext ; Compare user/dir char + + mov b,a + lda user0pass! inr a! jz save$dcnt$pos2 + ; Disable search of user 0 if any fcb + ; is found under the current user # + xra a! sta search$user0 + mov a,b + + pop b ; Recall counters + ora a ; Set flag + jnz searchn ; Skip if no match + searchok: + ; current character matches + inx d! inx h! inr b! dcr c + jmp searchloop + endsearch: + ; entire name matches, return dir position + +if BANKED + lda save$xfcb! inr a! jnz endsearch1 + lda xdcnt+1! cpi 0feh! cz save$dcnt$pos0 + jmp searchn + endsearch1: +endif + + xra a! sta dirloc ; dirloc = 0 + sta lret ; lret = 0 + ; successful search - + ; return with zero flag reset + mov b,a! inr b! ret + searchmod: + ani 3fh! ret ; Mask off high 2 bits + search$fin: + ; end of directory, or empty name + + call save$dcnt$pos1 + + ; Set dcnt = 0ffffh + call set$end$dir ; may be artifical end + lret$eq$ff: + ; unsuccessful search - + ; return with zero flag set + ; lret,low(aret) = 0ffh + mvi a,255! mov b,a! inr b! jmp sta$ret + + searchnm: ; search no match routine + mov a,b! ora a! jnz searchn ; fcb(0)? + mov a,m! ora a! jnz searchn ; dir fcb(0)=0? + lda search$user0! ora a! jz searchn + sta user0$pass + +if MPM + call swap +endif + + jmp searchok + +if MPM + +swap: ; Swap dcnt,sdblk with sdcnt0,sdblk0 + push h! push d! push b + lxi d,sdcnt! lxi h,sdcnt0 + mvi b,4 +swap1: + ldax d! mov c,a! mov a,m + stax d! mov m,c + inx h! inx d! dcr b! jnz swap1 + pop b! pop d! pop h! + ret +endif + +save$dcnt$pos2: + ; Save directory position of matching fcb + ; under user 0 with matching extent # & modnum = 0 + ; a = 0 on entry + ora b! pop b! lxi b,searchn! push b! rnz + inx h! inx h! mov a,m! ora a! rnz + ; Call if user0pass = 0ffh & + ; dir fcb(extnum) = fcb(extnum) + ; dir fcb(modnum) = 0 +save$dcnt$pos0: + call save$dcnt$pos ; Return to searchn +save$dcnt$pos1: + ; Save directory position of first empty fcb + ; or the end of the directory + + push h + lhld xdcnt + inr h! jnz save$dcnt$pos$ret ; Return if h ~= 0ffh + + +save$dcnt$pos: + lhld dcnt! shld xdcnt + +if MPM + lhld dblk! shld xdblk +endif + +save$dcnt$pos$ret: + pop h! ret + +if BANKED + +init$xfcb$search: + mvi a,0ffh +init$xfcb$search1: + sta find$xfcb! mvi a,0feh! sta xdcnt+1! ret + +does$xfcb$exist: + lda xdcnt+1! cpi 0feh! rz + call set$dcnt$dblk + xra a! call init$xfcb$search1 + lhld searcha! mov a,m! ori 10h! mov m,a + mvi c,extnum! call searchi1! jmp searchn + +xdcnt$eq$dcnt: + lhld dcnt! shld xdcnt! ret + +restore$dir$fcb: + call set$dcnt$dblk + mvi c,namlen! call searchi! jmp searchn +endif + +delete: + ; Delete the currently addressed file + call get$atts + +if BANKED + sta attributes + ; Make search return matching fcbs and xfcbs +deletex: + mvi a,0feh! call init$xfcb$search1 +else + ; Return with aret = 0 for XFCB only delete + ; in non-banked systems + ral! rc +endif + +; Delete pass 1 - check r/o attributes and xfcb passwords + + call search$extnum! rz + + delete00: + jz delete1 + +if BANKED + ; Is addressed dir fcb an xfcb? + call getdptra! mov a,m! ani 10h! jnz delete01 ; yes + +if MPM + call tst$olist ; Verify fcb not open by someone else +endif + + ; Check r/o attribute if this is not an + ; xfcb only delete operation. + lda attributes! ral! cnc check$rodir +else + call check$rodir +endif + +if BANKED + ; Are xfcb passwords enabled? + call get$dir$mode! ral! jc delete02 ; no +endif + + ; Is this a wild card delete operation? + lhld info! call chk$wild! jz delete02 ; yes + ; Not wild & passwords inactive + ; Skip to pass 2 + jmp delete11 + +if BANKED + + delete01: + ; Check xfcb password if passwords enabled + call get$dir$mode! ral! jnc delete02 + call chk$xfcb$password! jz delete02 + call chk$pw$error! jmp deletex +endif + + delete02: + call searchn! jmp delete00 + +; Delete pass 2 - delete all matching fcbs and/or xfcbs. + +delete1: + call search$extnum + + delete10: + jz copy$dir$loc + delete11: + call getdptra + +if BANKED + ; Is addressed dir fcb an xfcb? + mov a,m! ani 10h! jnz delete12 ; yes +if MPM + push h + call chk$olist ; Delete olist item if present + pop h +endif + ; Is this delete operation xfcb only? + lda attributes! ani 80h! jnz delete13 ; yes +endif + + delete12: + ; Delete dir fcb or xfcb + ; if fcb free all alocated blocks. + + mvi m,empty + +if BANKED + + delete13: + push a ; Z flag set => free FCB blocks + ; Zero password mode byte in sfcb if sfcb exists + ; Does sfcb exist? + call get$dtba$8! ora a! jnz $+4 ; no + ; Zero mode byte + mov m,a +endif + + call wrdir! mvi c,0 + +if BANKED + pop a! cz scandm$ab +else + call scandm$ab +endif + + call fix$hash + call searchn! jmp delete10 + +get$block: + ; Given allocation vector position bc, find the zero bit + ; closest to this position by searching left and right. + ; if found, set the bit to one and return the bit position + ; in hl. if not found (i.e., we pass 0 on the left, or + ; maxall on the right), return 0000 in hl + mov d,b! mov e,c ; copy of starting position to de + righttst: + lhld maxall ; value of maximum allocation# + mov a,e! sub l! mov a,d! sbb h ; right=maxall? + jnc retblock0 ; return block 0000 if so + inx d! push b! push d ; left, right pushed + mov b,d! mov c,e ; ready right for call + call getallocbit + rar! jnc retblock ; Return block number if zero + pop d! pop b ; Restore left and right pointers + lefttst: + mov a,c! ora b! jz righttst ; Skip if left=0000 + ; left not at position zero, bit zero? + dcx b! push d! push b ; left,right pushed + call getallocbit + rar! jnc retblock ; return block number if zero + ; bit is one, so try the right + pop b! pop d ; left, right restored + jmp righttst + retblock: + ral! inr a ; bit back into position and set to 1 + ; d contains the number of shifts required to reposition + call rotr ; move bit back to position and store + pop h! pop d ; hl returned value, de discarded + ret + retblock0: + ; cannot find an available bit, return 0000 + mov a,c + ora b! jnz lefttst ; also at beginning + lxi h,0000h! ret + +copy$dir: + ; Copy fcb information starting at c for e bytes + ; into the currently addressed directory entry + mvi d,80h +copy$dir0: + call copy$dir2 + inr c +copy$dir1: + dcr c! jz seek$copy + mov a,m! ana b! push b + mov b,a! ldax d! ani 7fh! ora b! mov m,a + pop b! inx h! inx d! jmp copy$dir1 +copy$dir2: + push d ; Save length for later + mvi b,0 ; double index to bc + lhld info ; hl = source for data + dad b + inx h! mov a,m! sui '$'! cz set$submit$flag + dcx h! xchg ; de=.fcb(c), source for copy + call getdptra ; hl=.buff(dptr), destination + pop b ; de=source, hl=dest, c=length + ret + +set$submit$flag: + lxi d,ccp$flgs! ldax d! ori 1! stax d! ret + +check$wild: + ; Check for ? in file name or type + lhld info +check$wild0: ; entry point used by rename + call chk$wild! rnz + mvi a,9! jmp set$aret + +chk$wild: + mvi c,11 +chk$wild1: + inx h! mvi a,3fh! sub m! ani 7fh! rz + dcr c! jnz chk$wild1! ora a! ret + +copy$user$no: + lhld info! mov a,m! lxi b,dskmap + dad b! mov m,a! ret + +rename: + ; Rename the file described by the first half of + ; the currently addressed file control block. The + ; new name is contained in the last half of the + ; currently addressed file control block. The file + ; name and type are changed, but the reel number + ; is ignored. The user number is identical. + + ; Verify that the new file name does not exist. + ; Also verify that no wild chars exist in + ; either filename. + +if MPM + call getatts! sta attributes +endif + + ; Verify that no wild chars exist in 1st filename. + call check$wild + +if BANKED + ; Check password of file to be renamed. + call chk$password! cnz chk$pw$error + ; Setup search to scan for xfcbs. + call init$xfcb$search +endif + + ; Copy user number to 2nd filename + call copy$user$no + shld searcha + + ; Verify no wild chars exist in 2nd filename + call check$wild0 + + ; Verify new filename does not already exist + mvi c,extnum! lhld searcha! call searchi1! call search1 + jnz file$exists ; New filename exists + +if BANKED + ; If an xfcb exists for the new filename, delete it. + call does$xfcb$exist! cnz delete11 +endif + + call copy$user$no + +if BANKED + call init$xfcb$search +endif + + ; Search up to the extent field + call search$extnum + rz + call check$rodir ; may be r/o file + +if MPM + call chk$olist +endif + + ; Copy position 0 + rename0: + ; not end of directory, rename next element + mvi c,dskmap! mvi e,extnum! call copy$dir + ; element renamed, move to next + + call fix$hash + call searchn + jnz rename0 + rename1: + +if BANKED + call does$xfcb$exist! jz copy$dir$loc + call copy$user$no! jmp rename0 +else + jmp copy$dir$loc +endif + +indicators: + ; Set file indicators for current fcb + call get$atts ; Clear f5' through f8' + sta attributes + +if BANKED + call chk$password! cnz chk$pw$error +endif + + call search$extnum ; through file type + rz + +if MPM + call chk$olist +endif + + indic0: + ; not end of directory, continue to change + mvi c,0! mvi e,extnum ; Copy name + call copy$dir2! call move + lda attributes! ani 40h! jz indic1 + + ; If interface att f6' set, dir fcb(s1) = fcb(cr) + + push h! call getfcba! mov a,m + pop h! inx h! mov m,a + indic1: + call seek$copy + call searchn + jz copy$dir$loc + jmp indic0 + +open: + ; Search for the directory entry, copy to fcb +;;; call search$namlen ;[JCE] DRI Patch 13 + call patch$1e3e +open1: + rz ; Return with lret=255 if end + ; not end of directory, copy fcb information +open$copy: + call setfwf! mov e,a! push h! dcx h! dcx h + mov d,m! push d ; Save extent# & module# with fcb write flag set + call getdptra! xchg ; hl = .buff(dptr) + lhld info ; hl=.fcb(0) + mvi c,nxtrec ; length of move operation + call move ; from .buff(dptr) to .fcb(0) + ; Note that entire fcb is copied, including indicators + call get$dir$ext! mov c,a + ; Restore module # and extent # + pop d! pop h! mov m,e! dcx h! dcx h! mov m,d + ; hl = .user extent#, c = dir extent# + ; above move set fcb(reccnt) to dir(reccnt) + ; if fcb ext < dir ext then fcb(reccnt) = fcb(reccnt) | 128 + ; if fcb ext = dir ext then fcb(reccnt) = fcb(reccnt) + ; if fcb ext > dir ext then fcb(reccnt) = 0 + +set$rc: ; hl=.fcb(ext), c=dirext + mvi b,0 + xchg! lxi h,(reccnt-extnum)! dad d + ; Is fcb ext = dirext? + ldax d! sub c! jz set$rc2 ; yes + ; Is fcb ext > dirext? + mov a,b! jnc set$rc1 ; yes - fcb(rc) = 0 + ; fcb ext < dirext + ; fcb(rc) = 128 | fcb(rc) + mvi a,128! ora m + set$rc1: + mov m,a! ret + set$rc2: + ; fcb ext = dirext + mov a,m! ora a! rnz ; ret if fcb(rc) ~= 0 + set$rc3: + mvi m,0 ; required by function 99 + lda dminx! ora a! rz ; ret if no blks in fcb + mvi m,128! ret ; fcb(rc) = 128 + +mergezero: + ; hl = .fcb1(i), de = .fcb2(i), + ; if fcb1(i) = 0 then fcb1(i) := fcb2(i) + mov a,m! inx h! ora m! dcx h! rnz ; return if = 0000 + ldax d! mov m,a! inx d! inx h ; low byte copied + ldax d! mov m,a! dcx d! dcx h ; back to input form + ret + +restore$rc: + ; hl = .fcb(extnum) + ; if fcb(rc) > 80h then fcb(rc) = fcb(rc) & 7fh + push h + lxi d,(reccnt-extnum)! dad d + mov a,m! cpi 81h! jc restore$rc1 + ani 7fh! mov m,a +restore$rc1: + pop h! ret + +close: + ; Locate the directory element and re-write it + xra a! sta lret + +if MPM + sta dont$close +endif + + call nowrite! rnz ; Skip close if r/o disk + ; Check file write flag - 0 indicates written + call getmodnum ; fcb(modnum) in a + ani fwfmsk! rnz ; Return if bit remains set +close1: + call chk$inv$fcb! jz mergerr + +if MPM + call set$fcb$cks$flag +endif + +;;; call get$dir$ext + call patch$1dfd ;[JCE] DRI patch 7 + + mov c,a + mov b,m + push b + ; b = original extent, c = directory extent + ; Set fcb(ex) to directory extent + mov m,c + ; Recompute fcb(rc) + call restore$rc + ; Call set$rc if fcb ext > dir ext + mov a,c! cmp b! cc set$rc + call close$fcb + ; Restore original extent & reset fcb(rc) + call get$exta! pop b + mov c,m! mov m,b! jmp set$rc ; Reset fcb(rc) + +close$fcb: + ; Locate file + call search$namlen + rz ; Return if not found + ; Merge the disk map at info with that at buff(dptr) + lxi b,dskmap! call get$fcb$adds + mvi c,(fcblen-dskmap) ; length of single byte dm + merge0: + lda single! ora a! jz merged ; Skip to double + ; This is a single byte map + ; if fcb(i) = 0 then fcb(i) = buff(i) + ; if buff(i) = 0 then buff(i) = fcb(i) + ; if fcb(i) <> buff(i) then error + mov a,m! ora a! ldax d! jnz fcbnzero + ; fcb(i) = 0 + mov m,a ; fcb(i) = buff(i) + fcbnzero: + ora a! jnz buffnzero + ; buff(i) = 0 + mov a,m! stax d ; buff(i)=fcb(i) + buffnzero: + cmp m! jnz mergerr ; fcb(i) = buff(i)? + jmp dmset ; if merge ok + merged: + ; This is a double byte merge operation + call mergezero ; buff = fcb if buff 0000 + xchg! call mergezero! xchg ; fcb = buff if fcb 0000 + ; They should be identical at this point + ldax d! cmp m! jnz mergerr ; low same? + inx d! inx h ; to high byte + ldax d! cmp m! jnz mergerr ; high same? + ; merge operation ok for this pair + dcr c ; extra count for double byte + dmset: + inx d! inx h ; to next byte position + dcr c! jnz merge0 ; for more + ; end of disk map merge, check record count + ; de = .buff(dptr)+32, hl = .fcb(32) + + xchg! lxi b,-(fcblen-extnum)! dad b! push h + call get$dir$ext! pop d + + ; hl = .fcb(extnum), de = .buff(dptr+extnum) + + call compare$extents + + ; b=1 -> fcb(ext) ~= dir ext = buff(ext) + ; b=2 -> fcb(ext) = dir ext ~= buff(ext) + ; b=3 -> fcb(ext) = dir ext = buff(ext) + + ; fcb(ext), buff(ext) = dir ext + mov m,a! stax d! push b + + lxi b,(reccnt-extnum)! dad b! xchg! dad b + pop b + + ; hl = .buff(rc) , de = .fcb(rc) + + dcr b! jz mrg$rc1 ; fcb(rc) = buff(rc) + + dcr b! jz mrg$rc2 ; buff(rc) = fcb(rc) + + ldax d! cmp m! jc mrg$rc1 ; Take larger rc + ora a! jnz mrg$rc2 + call set$rc3 + + mrg$rc1: xchg + + mrg$rc2: ldax d! mov m,a + +if MPM + lda dont$close! ora a! rnz +endif + + ; Set t3' off indicating file update + call getdptra! lxi d,11! dad d + mov a,m! ani 7fh! mov m,a + call setfwf + mvi c,1! call scandm$b ; Set 2nd ALV vector + jmp seek$copy ; OK to "wrdir" here - 1.4 compat + ; ret + mergerr: + ; elements did not merge correctly + call make$fcb$inv + jmp lret$eq$ff + +compare$extents: + mvi b,1! cmp m! rnz + inr b! xchg! cmp m! xchg! rnz + inr b! ret + +set$xdcnt: + lxi h,0ffffh! shld xdcnt! ret + +set$dcnt$dblk: + lhld xdcnt +set$dcnt$dblk1: + mvi a,1111$1100b! ana l + mov l,a! dcx h! shld dcnt + +if MPM + lhld xdblk! shld dblk +endif + + ret + +if MPM + +sdcnt$eq$xdcnt: + lxi h,sdcnt! lxi d,xdcnt! mvi c,4 + jmp move +endif + +make: + ; Create a new file by creating a directory entry + ; then opening the file + +;;; lxi h,xdcnt ;[JCE] DRI Patch 13 + call patch$1e31 + + call test$ffff! cnz set$dcnt$dblk + + lhld info! push h ; Save fcb address, Look for E5 + lxi h,efcb! shld info ; info = .empty + mvi c,1 + + call searchi! call searchn + + ; zero flag set if no space + pop h ; Recall info address + shld info ; in case we return here + rz ; Return with error condition 255 if not found + +if BANKED + ; Return early if making an xfcb + lda make$xfcb! ora a! rnz +endif + + ; Clear the remainder of the fcb + ; Clear s1 byte + lxi d,13! dad d! mov m,d! inx h + ; Clear and save file write flag of modnum + mov a,m! push a! push h! ani 3fh! mov m,a! inx h + mvi a,1 + mvi c,fcblen-namlen ; number of bytes to fill + make0: + mov m,d! inx h! dcr c! jnz make0 + dcr a! mov c,d! cz get$dtba + ora a! mvi c,10! jz make0 + call setcdr ; may have extended the directory + ; Now copy entry to the directory + mvi c,0! lxi d,fcblen! call copy$dir0 + ; and restore the file write flag + pop h! pop a! mov m,a + ; and set the fcb write flag to "1" + call fix$hash + jmp setfwf + +open$reel: + ; Close the current extent, and open the next one + ; if possible. rmf is true if in read mode + +if BANKED + call reset$copy$cr$only +endif + + call getexta + mov a,m! mov c,a + inr c! call compext + jz open$reel3 + push h! push b + call close + pop b! pop h + lda lret! inr a! rz + mvi a,maxext! ana c! mov m,a ; Incr extent field + ; Advance to module & save + inx h! inx h! mov a,m! sta save$mod + jnz open$reel0 ; Jump if in same module + + open$mod: + ; Extent number overflow, go to next module + inr m ; fcb(modnum)=++1 + ; Module number incremented, check for overflow + + mov a,m! ani 3fh ; Mask high order bits + + jz open$r$err ; cannot overflow to zero + + ; otherwise, ok to continue with new module + open$reel0: + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + +;;; call search$namlen ;[JCE] DRI Patch 13 + call patch$1e3e ;Next extent found? + + jnz open$reel1 + ; end of file encountered + lda rmf! inr a ; 0ffh becomes 00 if read + jz open$r$err ; sets lret = 1 + ; Try to extend the current file + call make + ; cannot be end of directory + jz open$r$err ; with lret = 1 + +if MPM + call fix$olist$item + call set$fcb$cks$flag +endif + + jmp open$reel2 + open$reel1: + ; not end of file, open + call open$copy + +if MPM + call set$fcb$cks$flag +endif + + open$reel2: + +if not MPM + call set$lsn +endif + + call getfcb ; Set parameters + xra a! sta vrecord! jmp sta$ret ; lret = 0 + ; ret ; with lret = 0 + open$r$err: + ; Restore module and extent + call getmodnum! lda save$mod! mov m,a + dcx h! dcx h! mov a,m! dcr a! ani 1fh + mov m,a! jmp setlret1 ; lret = 1 + + open$reel3: + inr m ; fcb(ex) = fcb(ex) + 1 + call get$dir$ext! mov c,a + ; Is new extent beyond dir$ext? + cmp m! jnc open$reel4 ; no + dcr m ; fcb(ex) = fcb(ex) - 1 + ; Is this a read fx? + lda rmf! inr a! jz set$lret1 ; yes - Don't advance ext + inr m ; fcb(ex) = fcb(ex) + 1 + open$reel4: + call restore$rc + call set$rc! jmp open$reel2 + +seqdiskread: +diskread: ; (may enter from seqdiskread) + call tst$inv$fcb ; Check for valid fcb + mvi a,true! sta rmf ; read mode flag = true (open$reel) + +if MPM + sta dont$close +endif + + ; Read the next record from the current fcb + call getfcb ; sets parameters for the read +diskread0: + lda vrecord! lxi h,rcount! cmp m ; vrecord-rcount + ; Skip if rcount > vrecord + jc recordok + +if MPM + call test$disk$fcb! jnz diskread0 + lda vrecord +endif + + ; not enough records in the extent + ; record count must be 128 to continue + cpi 128 ; vrecord = 128? + jnz setlret1 ; Skip if vrecord<>128 + call open$reel ; Go to next extent if so + ; Check for open ok + lda lret! ora a! jnz setlret1 ; Stop at eof + recordok: + ; Arrive with fcb addressing a record to read + +if BANKED + call set$copy$cr$only +endif + + call index ; Z flag set if arecord = 0 + +if MPM + jnz recordok1 + call test$disk$fcb! jnz diskread0 +endif + + jz setlret1 ; Reading unwritten data + recordok1: + ; Record has been allocated, read it + call atran ; arecord now a disk address + call check$nprs + jc setfcb + jnz read$deblock + + call setdata + call seek ; to proper track,sector + +if BANKED + mvi a,1! call setbnkf +endif + + call rdbuff ; to dma address + jmp setfcb ; Replace parameter + +read$deblock: + lxi h,0! shld last$block + mvi a,1! call deblock$dta + jmp setfcb + +check$nprs: + ; + ; on exit, c flg -> no i/o operation + ; z flg & ~c flg -> direct(physical) i/o operation + ; ~z flg & ~c flg -> indirect(deblock) i/o operation + ; + ; Dir$cnt contains the number of 128 byte records + ; to transfer directly. This routine sets dir$cnt + ; when initiating a sequence of direct physical + ; i/o operations. Dir$cnt is decremented each + ; time check$nprs is called during such a sequence. + ; + ; Is direct transfer operation in progress? + lda blk$off! mov b,a + lda phy$msk! mov c,a! ana b! push a + lda dir$cnt! cpi 2! jc check$npr1 ; no + ; yes - Decrement direct record count + dcr a! sta dir$cnt + ; Are we at a new physical record? + pop a! stc! rnz ; no - ret with c flg set + ; Perform physical i/o operation + xra a! ret ; Return with z flag set and c flag reset +check$npr1: + ; Are we in mid-physical record? + pop a! jz check$npr11 ; no +check$npr1a: + ; Is phymsk = 0? + mov a,c! ora a! rz ; yes - Don't deblock +check$npr1b: + ; Deblocking required + ori 1! ret ; ret with z flg reset and c flg reset +check$npr11: + mov a,c! cma! mov d,a ; d = ~phy$msk + lxi h,vrecord + ; Is mult$num < 2? + lda mult$num! cpi 2! jc check$npr1a ; yes + add m! cpi 80h! jc check$npr2 + mvi a,80h +check$npr2: ; a = min(vrecord + mult$num),80h) = x + push b ; Save low(arecord) & blkmsk, phymsk + mov b,m! mvi m,7fh ; vrecord = 7f + push b ; Save vrecord + push h ; Save .vrecord + push a ; Save x + lda blkmsk! mov e,a! inr e! cma! ana b! mov b,a + ; b = vrecord & ~blkmsk + ; e = blkmsk + 1 + pop h ; h = x + ; Is this a read function? + lda rmf! ora a! jz check$npr21 ; no + ; Is rcount & ~phymsk < x? + lda rcount! ana d! cmp h! jc check$npr23 ; yes +check$npr21: + mov a,h ; a = x +check$npr23: + sub b ; a = a - vrecord & ~blkmsk + mov c,a ; c = max # of records from beginning of curr blk + ; Is c < blkmsk+1? + cmp e! jc check$npr8 ; yes + +if BANKED + push b ; c = max # of records + ; Compute maximum disk map position + call dm$position + mov b,a ; b = index of last block in extent + ; Does the last block # = the current block #? + lda dminx! cmp b! mov e,a! jz check$npr5 ; yes + ; Compute # of blocks in sequence + mov c,a! push b! mvi b,0 + call get$dm ; hl = current block # +check$npr4: + ; Get next block # + push h! inx b! call get$dm + pop d! inx d + ; Does next block # = previous block # + 1? + mov a,d! sub h! mov d,a + mov a,e! sub l! ora d! jz check$npr4 ; yes + ; Is next block # = 0? + mov a,h! ora l! jnz check$npr45 ; no + ; Is this a read function? + lda rmf! ora a! jnz check$npr45 ; no + ; Is next block # > maxall? + lhld maxall! mov a,l! sub e + mov a,h! sbb d! jc check$npr45 ; yes + ; Is next block # allocated? + push b! push d! mov b,d! mov c,e + call getallocbit! pop h! pop b + rar! jnc check$npr4 ; no - it will be later +check$npr45: + dcr c! pop d + ; Is max dm position less than c? + mov a,d! cmp c! jc check$npr5 ; yes + mov a,c ; no +check$npr5: ; a = index of last block + sub e! mov b,a! inr b ; b = # of consecutive blks + lda blkmsk! inr a! mov c,a +check$npr6: + dcr b! jz check$npr7 + add c! jmp check$npr6 +check$npr7: + pop b + mov b,c ; b = max # of records + mov c,a ; c = (# of consecutive blks)*(blkmsk+1) + lda rmf! ora a! jz check$npr8 + mov a,b! cmp c! jc check$npr9 +else + mov c,e ; multis-sector max = 1 block in non-banked systems +endif + +check$npr8: + mov a,c +check$npr9: + ; Restore vrecord + pop h! pop b! mov m,b + pop b + ; a = max # of consecutive records including current blk + ; b = low(arecord) & blkmsk + ; c = phymsk + ; Is mult$num > a - b + lxi h,mult$num! mov d,m + sub b! cmp d! jnc check$npr10 + mov d,a ; yes - use smaller value to compute dir$cnt +check$npr10: + ; Does this operation involve at least 1 physical record? + mov a,c! cma! ana d! sta dir$cnt! jz check$npr1b ; Deblocking required + ; Flush any pending buffers before doing multiple reads + push a! lda rmf! ora a! jz check$npr10a + call flushx! call setdata +check$npr10a: + pop a! mov h,a ; Save # of 128 byte records + ; Does this operation involve more than 1 physical record? + ; Register h contains number of 128 byte records + call shr$physhf! mov a,h + cpi 1! mov c,a! cnz mult$iof ; yes - Make bios call + xra a! ret ; Return with z flg set + +if MPM + +test$unlocked: + lda high$ext! ani 80h! ret + +test$disk$fcb: + call test$unlocked! rz + lda dont$close! ora a! rz + call close1 +test$disk$fcb1: + pop d + lxi h,lret! inr m! mvi a,11! jz sta$ret + mvi m,0 + push d + call getrcnta! mov a,m! sta rcount ; Reset rcount + xra a! sta dont$close + inr a! ret +endif + +reset$fwf: + call getmodnum ; hl=.fcb(modnum), a=fcb(modnum) + ; Reset the file write flag to mark as written fcb + ani (not fwfmsk) and 0ffh ; bit reset + mov m,a ; fcb(modnum) = fcb(modnum) and 7fh + ret + +set$filewf: + call getmodnum! ani 0100$0000b! push a + mov a,m! ori 0100$0000b! mov m,a! pop a! ret + +seqdiskwrite: +diskwrite: ; (may enter here from seqdiskwrite above) + mvi a,false! sta rmf ; read mode flag + ; Write record to currently selected file + + call check$write ; in case write protected + +if BANKED + lda xfcb$read$only! ora a + mvi a,3! jnz set$aret +endif + + lda high$ext + +if MPM + ani 0100$0000b +else + ora a +endif + + ; Z flag reset if r/o mode + mvi a,3! jnz set$aret + + lhld info ; hl = .fcb(0) + call check$rofile ; may be a read-only file + + call tst$inv$fcb ; Test for invalid fcb + + call update$stamp + + call getfcb ; to set local parameters + lda vrecord! cpi lstrec+1 ; vrecord-128 + jc diskwrite0 + call open$reel ; vrecord = 128, try to open next extent + lda lret! ora a! rnz ; no available fcb +disk$write0: + +if MPM + mvi a,0ffh! sta dont$close +disk$write1: + +endif + + ; Can write the next record, so continue + call index ; Z flag set if arecord = 0 + jz diskwrite2 + ; Was the last write operation for the same block & drive? + lxi h,adrive! lxi d,last$drive! mvi c,3 + call compare! jz diskwrite15 ; yes + ; no - force preread in blocking/deblocking + mvi a,0ffh! sta last$off +diskwrite15: + +if MPM + ; If file is unlocked, verify record is not locked + ; Record has to be allocated to be locked + call test$unlocked! jz not$unlocked + call atran! mov c,a + lda mult$cnt! mov b,a! push b + call test$lock! pop b + xra a! mov c,a! push b + jmp diskwr10 +not$unlocked: + inr a +endif + + mvi c,0 ; Marked as normal write operation for wrbuff + jmp diskwr1 +diskwrite2: + +if MPM + call test$disk$fcb! jnz diskwrite1 +endif + +if BANKED + call reset$copy$cr$only +endif + + ; not allocated + ; The argument to getblock is the starting + ; position for the disk search, and should be + ; the last allocated block for this file, or + ; the value 0 if no space has been allocated + call dm$position + sta dminx ; Save for later + lxi b,0000h ; May use block zero + ora a! jz nopblock ; Skip if no previous block + ; Previous block exists at a + mov c,a! dcx b ; Previous block # in bc + call getdm ; Previous block # to hl + mov b,h! mov c,l ; bc=prev block# + nopblock: + ; bc = 0000, or previous block # + call get$block ; block # to hl + ; Arrive here with block# or zero + mov a,l! ora h! jnz blockok + ; Cannot find a block to allocate + mvi a,2! jmp sta$ret ; lret=2 + blockok: + +if MPM + call set$fcb$cks$flag +endif + + ; allocated block number is in hl + shld arecord! shld last$block! xra a! sta last$off + lda adrive! sta lastdrive + xchg ; block number to de + lhld info! lxi b,dskmap! dad b ; hl=.fcb(dskmap) + lda single! ora a ; Set flags for single byte dm + lda dminx ; Recall dm index + jz allocwd ; Skip if allocating word + ; Allocating a byte value + call addh! mov m,e ; single byte alloc + jmp diskwru ; to continue + allocwd: + ; Allocate a word value + mov c,a! mvi b,0 ; double(dminx) + dad b! dad b ; hl=.fcb(dminx*2) + mov m,e! inx h! mov m,d ; double wd + diskwru: + ; disk write to previously unallocated block + mvi c,2 ; marked as unallocated write + diskwr1: + ; Continue the write operation of no allocation error + ; c = 0 if normal write, 2 if to prev unalloc block + push b ; Save write flag + call atran ; arecord set +diskwr10: + lda fx! cpi 40! jnz diskwr11 ; fx ~= wrt rndm zero fill + mov a,c! dcr a! dcr a! jnz diskwr11 ; old allocation + + ; write random zero fill + new block + + pop b! push a ; zero write flag + lhld arecord! push h + lxi h,phymsk! mov e,m! inr e! mov d,a! push d + lhld dirbcba + +if BANKED + mov e,m! inx h! mov d,m! xchg +fill00: + push h! call get$next$bcba! pop d! jnz fill00 + xchg +endif + + ; Force prereads in blocking/deblocking + ; Discard BCB + dcr a! sta last$off! mov m,a + call setdir1 ; Set dma to BCB buffer + ; Zero out BCB buffer + pop d! push d! xra a + fill0: + mov m,a! inx h! inr d! jp fill0 + mov d,a! dcr e! jnz fill0 + ; Write 1st physical record of block + lhld arecord1! mvi c,2 + fill1: + shld arecord! push b! call discard$data$bcb + call seek + +if BANKED + xra a! call setbnkf +endif + + pop b! call wrbuff + lhld arecord! pop d! push d + ; Continue writing until blkmsk & arecord = 0 + dad d! lda blkmsk! ana l! mvi c,0! jnz fill1 + ; Restore arecord + pop h! pop h! shld arecord + + call setdata ; Restore dma + diskwr11: + + pop d! lda vrecord! mov d,a ; Load and save vrecord + push d! call check$nprs + + jc dont$write + jz write + + mvi a,2 ; deblock write code + call deblock$dta + jmp dont$write +write: + call setdata + call seek + +if BANKED + mvi a,1! call setbnkf +endif + + ; Discard matching BCB if write is direct + call discard$data$bcb + + ; Set write flag to zero if arecord & blkmsk ~= 0 + + pop b! push b! lda arecord + lxi h,blkmsk! ana m! jz write0 + mvi c,0 +write0: + call wrbuff + +dont$write: + pop b ; c = 2 if a new block was allocated, 0 if not + ; Increment record count if rcount<=vrecord + mov a,b! lxi h,rcount! cmp m ; vrecord-rcount + jc diskwr2 + ; rcount <= vrecord + mov m,a! inr m ; rcount = vrecord+1 + +if MPM + call test$unlocked! jz write1 + + ; for unlocked files + ; rcount = rcount & (~ blkmsk) + blkmsk + 1 + + lda blkmsk! mov b,a! inr b! cma! mov c,a + mov a,m! dcr a! ana c! add b! mov m,a + write1: +endif + + mvi c,2 ; Mark as record count incremented + diskwr2: + ; a has vrecord, c=2 if new block or new record# + dcr c! dcr c! jnz noupdate + call reset$fwf + +if MPM + call test$unlocked! jz noupdate + lda rcount! call getrcnta! mov m,a + call close + call test$disk$fcb1 +endif + +noupdate: + ; Set file write flag if reset + call set$filewf + +if BANKED + jnz disk$write3 + ; Reset fcb file write flag to ensure t3' gets + ; reset by the close function + call reset$fwf + call reset$copy$cr$only + jmp setfcb +disk$write3: + call set$copy$cr$only +else + cz reset$fwf +endif + jmp setfcb ; Replace parameters + ; ret + +rseek: + ; Random access seek operation, c=0ffh if read mode + ; fcb is assumed to address an active file control block + ; (1st block of FCB = 0ffffh if previous bad seek) + push b ; Save r/w flag + lhld info! xchg ; de will hold base of fcb + lxi h,ranrec! dad d ; hl=.fcb(ranrec) + mov a,m! ani 7fh! push psw ; record number + mov a,m! ral ; cy=lsb of extent# + inx h! mov a,m! ral! ani 11111b ; a=ext# + mov c,a ; c holds extent number, record stacked + + mov a,m! ani 1111$0000b! inx h! ora m + rrc! rrc! rrc! rrc! mov b,a + ; b holds module # + + ; Check high byte of ran rec <= 3 + mov a,m + ani 1111$1100b! pop h! mvi l,6! mov a,h + + ; Produce error 6, seek past physical eod + jnz seekerr + + ; otherwise, high byte = 0, a = sought record + lxi h,nxtrec! dad d ; hl = .fcb(nxtrec) + mov m,a ; sought rec# stored away + + ; Arrive here with b=mod#, c=ext#, de=.fcb, rec stored + ; the r/w flag is still stacked. compare fcb values + + lda fx! cpi 99! jz rseek3 + ; Check module # first + push d! call chk$inv$fcb! pop d! jz ranclose + lxi h,modnum! dad d! mov a,b ; b=seek mod# + sub m! ani 3fh! jnz ranclose ; same? + ; Module matches, check extent + lxi h,extnum! dad d + mov a,m! cmp c! jz seekok2 ; extents equal + call compext! jnz ranclose + ; Extent is in same directory fcb + push b! call get$dir$ext! pop b + cmp c! jnc rseek2 ; jmp if dir$ext > ext + pop d! push d! inr e! jnz rseek2 ; jmp if write fx + inr e! pop d! jmp set$lret1 ; error - reading unwritten data + rseek2: + mov m,c ; fcb(ext) = c + mov c,a ; c = dir$ext + ; hl=.fcb(ext),c=dir ext + call restore$rc + call set$rc + jmp seekok1 + ranclose: + push b! push d ; Save seek mod#,ext#, .fcb + call close ; Current extent closed + pop d! pop b ; Recall parameters and fill + mvi l,3 ; Cannot close error #3 + lda lret! inr a! jz seekerr + rseek3: + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + + lxi h,extnum! dad d! push h + mov d,m! mov m,c ; fcb(extnum)=ext# + inx h! inx h! mov a,m! mov e,a! push d + ani 040h! ora b! mov m,a + ; fcb(modnum)=mod# + call open ; Is the file present? + lda lret! inr a! jnz seekok ; Open successful? + ; Cannot open the file, read mode? + pop d! pop h! pop b ; r/w flag to c (=0ffh if read) + push b! push h! push d ; Restore stack + mvi l,4 ; Seek to unwritten extent #4 + inr c ; becomes 00 if read operation + jz badseek ; Skip to error if read operation + ; Write operation, make new extent + call make + mvi l,5 ; cannot create new extent #5 + jz badseek ; no dir space + +if MPM + call fix$olist$item +endif + + ; file make operation successful + seekok: + pop b! pop b ; Discard top 2 stacked items + +if MPM + call set$fcb$cks$flag +else + call set$lsn +endif + + seekok1: + +if BANKED + call reset$copy$cr$only +endif + + seekok2: + pop b ; Discard r/w flag or .fcb(ext) + xra a! jmp sta$ret ; with zero set + badseek: + ; Restore fcb(ext) & fcb(mod) + pop d! xthl ; Save error flag + mov m,d! inx h! inx h! mov m,e + pop h ; Restore error flag + seekerr: + +if BANKED + call reset$copy$cr$only ; Z flag set + inr a ; Reset Z flag +endif + + pop b ; Discard r/w flag + mov a,l! jmp sta$ret ; lret=#, nonzero + +randiskread: + ; Random disk read operation + mvi c,true ; marked as read operation + call rseek + cz diskread ; if seek successful + ret + +randiskwrite: + ; Random disk write operation + mvi c,false ; marked as write operation + call rseek + cz diskwrite ; if seek successful + ret + +compute$rr: + ; Compute random record position for getfilesize/setrandom + xchg! dad d + ; de=.buf(dptr) or .fcb(0), hl = .f(nxtrec/reccnt) + mov c,m! mvi b,0 ; bc = 0000 0000 ?rrr rrrr + lxi h,extnum! dad d! mov a,m! rrc! ani 80h ; a=e000 0000 + add c! mov c,a! mvi a,0! adc b! mov b,a + ; bc = 0000 000? errrr rrrr + mov a,m! rrc! ani 0fh! add b! mov b,a + ; bc = 000? eeee errrr rrrr + lxi h,modnum! dad d! mov a,m ; a=xxmm mmmm + add a! add a! add a! add a ; cy=m a=mmmm 0000 + + ora a! add b! mov b,a! push psw ; Save carry + mov a,m! rar! rar! rar! rar! ani 0000$0011b ; a=0000 00mm + mov l,a! pop psw! mvi a,0! adc l ; Add carry + ret + +compare$rr: + mov e,a ; Save cy + mov a,c! sub m! mov d,a! inx h ; lst byte + mov a,b! sbb m! inx h ; middle byte + push a! ora d! mov d,a! pop a + mov a,e! sbb m ; carry if .fcb(ranrec) > directory + ret + +set$rr: + mov m,e! dcx h! mov m,b! dcx h! mov m,c! ret + +getfilesize: + ; Compute logical file size for current fcb + ; Zero the receiving ranrec field + call get$rra! push h ; Save position + mov m,d! inx h! mov m,d! inx h! mov m,d ; =00 00 00 + call search$extnum + getsize: + jz setsize + ; current fcb addressed by dptr + call getdptra! lxi d,reccnt ; ready for compute size + call compute$rr + ; a=0000 00mm bc = mmmm eeee errr rrrr + ; Compare with memory, larger? + pop h! push h ; Recall, replace .fcb(ranrec) + call compare$rr! cnc set$rr + call searchn + mvi a,0! sta aret + jmp getsize + setsize: + + pop h ; Discard .fcb(ranrec) + ret + +setrandom: + ; Set random record from the current file control block + xchg! lxi d,nxtrec ; Ready params for computesize + call compute$rr ; de=info, a=0000 00mm, bc=mmmm eeee errr rrrr + lxi h,ranrec! dad d ; hl = .fcb(ranrec) + mov m,c! inx h! mov m,b! inx h! mov m,a ; to ranrec + ret + +disk$select: + ; Select disk info for subsequent input or output ops + sta adrive +disk$select1: ; called by deblock + mov m,a ; curdsk = seldsk or adrive + mov d,a ; Save seldsk in register D for selectdisk call + lhld dlog! call test$vector ; test$vector does not modify DE + mov e,a! push d ; Send to seldsk, save for test below + call selectdisk! pop h ; Recall dlog vector + jnc sel$error ; returns with C flag set if select ok + ; Is the disk logged in? + dcr l ; reg l = 1 if so + ret + +tmpselect: + lxi h,seldsk! mov m,e + +curselect: + lda seldsk! lxi h,curdsk! cmp m! jnz select + cpi 0ffh! rnz ; return if seldsk ~= ffh + +select: + call disk$select + +if MPM + jnz select1 ; no + ; yes - drive previously logged in + lhld rlog! call test$vector + sta rem$drv! ret ; Set rem$drv & return +select1: + +else + rz ; yes - drive previously logged in +endif + + call initialize ; Log in the directory + + ; Increment login sequence # if odd + lhld lsn$add! mov a,m! ani 1! push a! add m! mov m,a + pop a! cnz set$rlog + + call set$dlog + +if MPM + lxi h,chksiz+1! mov a,m! ral! mvi a,0! jc select2 + lxi d,rlog! call set$cdisk ; rlog=set$cdisk(rlog) + mvi a,1 +select2: + sta rem$drv +endif + + ret + +reselectx: + xra a! sta high$ext + +if BANKED + sta xfcb$read$only +endif + + jmp reselect1 + +reselect: + ; Check current fcb to see if reselection necessary + lxi b,807fh + lhld info! lxi d,7! xchg! dad d + +if BANKED + ; xfcb$read$only = 80h & fcb(7) + mov a,m! ana b! sta xfcb$read$only + ; fcb(7) = fcb(7) & 7fh + mov a,m! ana c! mov m,a +endif + +if MPM + ; if fcb(8) & 80h + ; then fcb(8) = fcb(8) & 7fh, high$ext = 60h + ; else high$ext = fcb(ext) & 0e0h + inx h! lxi d,4 + mov a,m! ana c! cmp m! mov m,a! mvi a,60h! jnz reselect0 + dad d! mvi a,0e0h! ana m +reselect0: + sta high$ext +else + ; high$ext = 80h & fcb(8) + inx h! mov a,m! ana b! sta high$ext + ; fcb(8) = fcb(8) & 7fh + mov a,m! ana c! mov m,a +endif + + ; fcb(ext) = fcb(ext) & 1fh + call clr$ext +reselect1: + + lxi h,0 + +if BANKED + shld make$xfcb ; make$xfcb,find$xfcb = 0 +endif + shld xdcnt ; required by directory hashing + + xra a! sta search$user0 + dcr a! sta resel ; Mark possible reselect + lhld info! mov a,m ; drive select code + sta fcbdsk ; save drive code + ani 1$1111b ; non zero is auto drive select + dcr a ; Drive code normalized to 0..30, or 255 + sta linfo ; Save drive code + cpi 0ffh! jz noselect + ; auto select function, seldsk saved above + sta seldsk + noselect: + call curselect + ; Set user code + lda usrcode ; 0...15 + lhld info! mov m,a + noselect0: + ; Discard directory BCB's if drive is removable + ; and fx = 15,17,19,22,23,30 etc. + call tst$log$fxs! cz discard$dir + ; Check for media change on currently slected disk + call check$media + ; Check for media change on any other disks + jmp check$all$media + +check$media: + ; Check media if DPH media flag set. + ; Is DPH media flag set? + call test$media$flag! rz ; no + ; Test for media change by reading directory + ; to current high water mark or until media change + ; is detected. + ; First reset DPH media flag & discard directory BCB's + mvi m,0 + call discard$dir + lhld dcnt! push h + call home! call set$end$dir +check$media1: + mvi c,false! call r$dir + lxi h,relog! mov a,m! ora a! jz check$media2 + mvi m,0! pop h! lda fx! cpi 48! rz + call drv$relog! jmp chk$exit$fxs +check$media2: + call comp$cdr! jc check$media1 + pop h! shld dcnt! ret + +check$all$media: + ; This routine checks all logged-in drives for + ; a set DPH media flag and pending buffers. It reads + ; the directory for these drives to verify that media + ; has not changed. If media has changed, the drives + ; get reset (but not relogged-in). + ; Is SCB media flag set? + lxi h,media$flag! mov a,m! ora a! rz ; no + ; Reset SCB media flag + mvi m,0 + ; Test logged-in drives only + lhld dlog! mvi a,16 +chk$am1: + dcr a! dad h! jnc chk$am2 + ; A = drive # + ; Select drive + push a! push h! lxi h,curdsk! call disk$select + ; Does drive have pending data buffers? + call test$pending! cnz check$media ; yes + pop h! pop a +chk$am2: + ora a! jnz chk$am1 + jmp curselect + +test$pending: + ; On return, Z flag reset if buffer pending + + ; Does dta$bcba = 0ffffh + lhld dta$bcba! mov a,l! ana h! inr a! rz ; yes + +if BANKED + +test$p1: + ; Does bcb addr = 0? + mov e,m! inx h! mov d,m + mov a,e! ora d! rz ; yes - no pending buffers + lxi h,4 +else + lxi d,4 +endif + + ; Is buffer pending? + dad d! mov a,m! ora a ; A ~= 0 if so + +if BANKED + rnz ; yes + ; no - advance to next bcb + lxi h,13! dad d! jmp test$p1 +else + ret +endif + +get$dir$mode: + lhld drvlbla! mov a,m + +if not BANKED + ani 7fh ; Mask off password bit +endif + + ret + +if BANKED + +chk$password: + call get$dir$mode! ani 80h! rz + +chk$pw: ; Check password + call get$xfcb! rz ; a = xfcb options + jmp cmp$pw + +chk$pw$error: + ; Disable special searches + xra a! sta xdcnt+1 + ; pw$fcb = dir$xfcb + call getdptra! xchg + mvi c,12! lxi h,pw$fcb! push h + call move! ldax d! inx h! mov m,a! pop d + lhld info! mov a,m! stax d + ; push original info and xfcb password mode + ; info = .pw$fcb + push h! xchg! shld info + ; Does fcb(ext = 0, mod = 0) exist? + call search$namlen! jz chk$pwe2 ; no + ; Does sfcb exist for fcb ? + call get$dtba$8! ora a! jnz chk$pwe1 ; no + xchg! lxi h,pw$mode + ; Is sfcb password mode nonzero? + mov b,m! ldax d! mov m,a! ora a! jz chk$pwe2 ; no + ; Do password modes match? + xra b! ani 0e0h! jz chk$pwe1 ; yes + ; no - update xfcb to match sfcb + call get$xfcb! jz chk$pwe1 ; no xfcb (error) + lda pw$mode! mov m,a! call nowrite! cz seek$copy +chk$pwe1: + pop h! shld info + lda fx! cpi 15! rz! cpi 22! rz + +pw$error: ; password error + mvi a,7! jmp set$aret + +chk$pwe2: + xra a! sta pw$mode + call nowrite! jnz chk$pwe3 + ; Delete xfcb + call get$xfcb! push a + lhld info! mov a,m! ori 10h! mov m,a + pop a! cnz delete$10 +chk$pwe3: + ; Restore info + pop h! shld info! ret + +cmp$pw: ; Compare passwords + inx h! mov b,m + mov a,b! ora a! jnz cmp$pw2 + mov d,h! mov e,l! inx h! inx h + mvi c,9 +cmp$pw1: + inx h! mov a,m! dcr c! rz + ora a! jz cmp$pw1 + cpi 20h! jz cmp$pw1 + xchg +cmp$pw2: + lxi d,(23-ubytes)! dad d! xchg + lhld xdmaad! mvi c,8 +cmp$pw3: + ldax d! xra b! cmp m! jnz cmp$pw4 + dcx d! inx h! dcr c! jnz cmp$pw3 + ret +cmp$pw4: + dcx d! dcr c! jnz cmp$pw4 + inx d + +if MPM + call get$df$pwa! inr a! jnz cmp$pw5 + inr a! ret +cmp$pw5: + +else + lxi h,df$password +endif + + mvi c,8! jmp compare + +if MPM + +get$df$pwa: ; a = ff => no df pwa + call rlr! lxi b,console! dad b + mov a,m! cpi 16! mvi a,0ffh! rnc + mov a,m! add a! add a! add a + mvi h,0! mov l,a! lxi b,dfpassword! dad b + ret +endif + +set$pw: ; Set password in xfcb + push h ; Save .xfcb(ex) + lxi b,8 ; b = 0, c = 8 + lxi d,(23-extnum)! dad d + xchg! lhld xdmaad +set$pw0: + xra a! push a +set$pw1: + mov a,m! stax d! ora a! jz set$pw2 + cpi 20h! jz set$pw2 + inx sp! inx sp! push a +set$pw2: + add b! mov b,a + dcx d! inx h! dcr c! jnz set$pw1 + pop a! ora b! pop h! jnz set$pw3 + ; is fx = 100 (directory label)? + lda fx! cpi 100! jz set$pw3 ; yes + mvi m,0 ; zero xfcb(ex) - no password +set$pw3: + inx d! mvi c,8 +set$pw4: + ldax d! xra b! stax d! inx d! dcr c! jnz set$pw4 + inx h! ret + +get$xfcb: + lhld info! mov a,m! push a + ori 010h! mov m,a + call search$extnum! mvi a,0! sta lret + lhld info! pop b! mov m,b! rz +get$xfcb1: + call getdptra! xchg + lxi h,extnum! dad d! mov a,m! ani 0e0h! ori 1 + ret + +adjust$dmaad: + push h! lhld xdmaad! dad d + shld xdmaad! pop h! ret + +init$xfcb: + call setcdr ; may have extended the directory + lxi b,1014h ; b=10h, c=20 +init$xfcb0: + ; b = fcb(0) logical or mask + ; c = zero count + push b + call getdptra! xchg! lhld info! xchg + ; Zero extnum and modnum + ldax d! ora b! mov m,a! inx d! inx h + mvi c,11! call move! pop b! inr c +init$xfcb1: + dcr c! rz + mvi m,0! inx h! jmp init$xfcb1 + +chk$xfcb$password: + call get$xfcb1 +chk$xfcb$password1: + push h! call cmp$pw! pop h! ret + +endif + +stamp1: + mvi c,0! jmp stamp3 +stamp2: + mvi c,4 +stamp3: + call get$dtba! ora a! rnz + lxi d,seek$copy! push d +stamp4: + +if MPM + push h + call get$stamp$add! xchg + pop h +else + lxi d,stamp +endif + + push h! push d + mvi c,0! call timef ; does not modify hl,de + mvi c,4! call compare + mvi c,4! pop d! pop h! jnz move + pop h! ret + +stamp5: + call getdptra! dad b! lxi d,func$ret! push d + jmp stamp4 + +if BANKED + +get$dtba$8: + mvi c,8 +endif + +get$dtba: + ; c = offset of sfcb subfield (0,4,8) + ; Return with a = 0 if sfcb exists + + ; Does fcb occupy 4th item of sector? + lda dcnt! ani 3! cpi 3! rz ; yes + mov b,a + lhld buffa! lxi d,96! dad d + ; Does sfcb reside in 4th directory item? + mov a,m! sui 21h! rnz ; no + ; hl = hl + 10*lret + 1 + c + mov a,b! add a! mov e,a! add a! add a! add e + inr a! add c! mov e,a! dad d! xra a + ret + +qstamp: + ; Is fcb 1st logical fcb for file? + call qdirfcb1! rnz ; no +qstamp1: + ; Does directory label specify requested stamp? + lhld drvlbla! mov a,c! ana m! jnz nowrite ; yes - verify drive r/w + inr a! ret ; no - return with Z flag reset + +qdirfcb1: + ; Routine to determine if fcb is 1st directory fcb + ; for file + ; Is fcb(ext) & ~extmsk & 00011111b = 0? + lda extmsk! ori 1110$0000b! cma! mov b,a + call getexta! mov a,m! ana b! rnz ; no + ; is fcb(mod) & 0011$1111B = 0? + inx h! inx h! mov a,m! ani 3fh! ret ; Z flag set if zero + +update$stamp: + ; Is update stamping requested on drive? + mvi c,0010$0000b! call qstamp1! rnz ; no + ; Has file been written to since it was opened? + call getmodnum! ani 40h! rnz ; yes - update stamp performed + ; Search for 1st dir fcb + call getexta! mov b,m! mvi m,0! push h + inx h! inx h! mov c,m! mvi m,0! push b + ; Search from beginning of directory + call search$namlen + ; Perform update stamp if dir fcb 1 found + cnz stamp2 + xra a! sta lret + ; Restore fcb extent and module fields + pop b! pop h! mov m,b! inx h! inx h! mov m,c! ret + +if MPM + +pack$sdcnt: + +;packed$dcnt = dblk(low 15 bits) || dcnt(low 9 bits) + +; if sdblk = 0 then dblk = shr(sdcnt,blkshf+2) +; else dblk = sdblk +; dcnt = sdcnt & (blkmsk || '11'b) +; +; packed$dcnt format (24 bits) +; +; 12345678 12345678 12345678 +; 23456789 .......1 ........ sdcnt (low 9 bits) +; ........ 9abcdef. 12345678 sdblk (low 15 bits) +; + lhld sdblk! mov a,h! ora l! jnz pack$sdcnt1 + lda blkshf! adi 2! mov c,a! lhld sdcnt + call hlrotr +pack$sdcnt1: + dad h! xchg! lxi h,sdcnt! mvi b,1 + lda blkmsk! ral! ora b! ral! ora b + ana m! sta packed$dcnt + lda blkshf! cpi 7! jnz pack$sdcnt2 + inx h! mov a,m! ana b! jz pack$sdcnt2 + mov a,e! ora b! mov e,a +pack$sdcnt2: + xchg! shld packed$dcnt+1 + ret + +; olist element = link(2) || atts(1) || dcnt(3) || +; pdaddr(2) || opncnt(2) +; +; link = 0 -> end of list +; +; atts - 80 - open in locked mode +; 40 - open in unlocked mode +; 20 - open in read/only mode +; 10 - deleted item +; 0n - drive code (0-f) +; +; dcnt = packed sdcnt+sdblk +; pdaddr = process descriptor addr +; opncnt = # of open calls - # of close calls +; olist item freed by close when opncnt = 0 +; +; llist element = link(2) || drive(1) || arecord(3) || +; pdaddr(2) || .olist$item(2) +; +; link = 0 -> end of list +; +; drive - 0n - drive code (0-f) +; +; arecord = record number of locked record +; pdaddr = process descriptor addr +; .olist$item = address of file's olist item + +search$olist: + lxi h,open$root! jmp srch$list0 +search$llist: + lxi h,lock$root! jmp srch$list0 +searchn$list: + lhld cur$pos +srch$list0: + shld prv$pos + +; search$olist, search$llist, searchn$list conventions +; +; b = 0 -> return next item +; b = 1 -> search for matching drive +; b = 3 -> search for matching dcnt +; b = 5 -> search for matching dcnt + pdaddr +; if found then z flag is set +; prv$pos -> previous list element +; cur$pos -> found list element +; hl -> found list element +; else prv$pos -> list element to insert after +; +; olist and llist are maintained in drive order + +srch$list1: + mov e,m! inx h! mov d,m! xchg + mov a,l! ora h! jz srch$list3 + xra a! cmp b! jz srch$list6 + inx h! inx h! + lxi d,curdsk! mov a,m! ani 0fh! mov c,a + ldax d! sub c! jnz srch$list4 + mov a,b! dcr a! jz srch$list5 + mov c,b! push h + inx d! inx h! call compare + pop h! jz srch$list5 +srch$list2: + dcx h! dcx h + shld prv$pos! jmp srch$list1 +srch$list3: + inr a! ret +srch$list4: + jnc srch$list2 +srch$list5: + dcx h! dcx h +srch$list6: + shld cur$pos! ret + +delete$item: ; hl -> item to be deleted + di + push d! push h + mov e,m! inx h! mov d,m + lhld prv$pos! shld cur$pos + ; prv$pos.link = delete$item.link + mov m,e! inx h! mov m,d + + lhld free$root! xchg + ; free$root = .delete$item + pop h! shld free$root + ; delete$item.link = previous free$root + mov m,e! inx h! mov m,d + pop d! ei! ret + +create$item: ; hl -> new item if successful + ; z flag set if no free items + lhld free$root! mov a,l! ora h! rz + push d! push h! shld cur$pos + mov e,m! inx h! mov d,m + ; free$root = free$root.link + xchg! shld free$root + + lhld prv$pos + mov e,m! inx h! mov d,m + pop h + ; create$item.link = prv$pos.link + mov m,e! inx h! mov m,d! dcx h + xchg! lhld prv$pos + ; prv$pos.link = .create$item + mov m,e! inx h! mov m,d! xchg + pop d! ret + +set$olist$item: + ; a = attributes + ; hl = olist entry address + inx h! inx h + mov b,a! lxi d,curdsk! ldax d! ora b + mov m,a! inx h! inx d + mvi c,5! call move + xra a! mov m,a! inx h! mov m,a! ret + +set$sdcnt: + mvi a,0ffh! sta sdcnt+1! ret + +tst$olist: + mvi a,0c9h! sta chk$olist05! jmp chk$olist0 +chk$olist: + xra a! sta chk$olist05 +chk$olist0: + lxi d,dcnt! lxi h,sdcnt! mvi c,4! call move + call pack$sdcnt! mvi b,3! call search$olist! rnz + pop d ; pop return address + inx h! inx h + mov a,m! ani 80h! jz openx06 + dcx h! dcx h + push d! push h + call compare$pds! pop h! pop d! jnz openx06 + push d ; Restore return address +chk$olist05: + nop ; tst$olist changes this instr to ret + call delete$item! lda pdcnt +chk$olist1: + adi 16! jz chk$olist1 + sta pdcnt + + push a! call rlr + lxi b,pdcnt$off! dad b! pop a + mov m,a! ret + +remove$files: ; bc = pdaddr + lhld cur$pos! push h + lhld prv$pos! push h + mov d,b! mov e,c! lxi h,open$root! shld cur$pos +remove$file1: + mvi b,0! push d! call searchn$list! pop d! jnz remove$file2 + lxi b,6! call tst$tbl$lmt! jnz remove$file1 + inx h! inx h! mov a,m! ori 10h! mov m,a + sta deleted$files + jmp remove$file1 +remove$file2: + pop h! shld prv$pos + pop h! shld cur$pos + ret + +delete$files: + lxi h,open$root! shld cur$pos +delete$file1: + mvi b,0! call search$nlist! rnz + inx h! inx h! mov a,m! ani 10h! jz delete$file1 + dcx h! dcx h! call remove$locks! call delete$item + jmp delete$file1 + +flush$files: + lxi h,flushed! mov a,m! ora a! rnz + inr m +flush$file0: + lxi h,open$root! shld cur$pos +flush$file1: + mvi b,1! call searchn$list! rnz + push h! call remove$locks! call delete$item! pop h + lxi d,6! dad d! mov e,m! inx h! mov d,m + lxi h,pdcnt$off! dad d! mov a,m! ani 1! jnz flush$file1 + mov a,m! ori 1! mov m,a + lhld pdaddr! mvi c,2! call compare! jnz flush$file1 + lda pdcnt! adi 10h! sta pdcnt! jmp flush$file1 + +free$files: + ; free$mode = 1 - remove curdsk files for process + ; 0 - remove all files for process + lhld pdaddr! xchg! lxi h,open$root! shld curpos +free$files1: + lda free$mode! mov b,a + push d! call searchn$list! pop d! rnz + lxi b,6! call tst$tbl$lmt! jnz free$files1 + push h! inx h! inx h! inx h + call test$ffff! jnz free$files2 + call test$ffff! jz free$files3 +free$files2: + mvi a,0ffh! sta incr$pdcnt +free$files3: + pop h! call remove$locks! call delete$item + jmp free$files1 + +remove$locks: + shld file$id + inx h! inx h! mov a,m! ani 40h! jz remove$lock3 + push d! lhld prv$pos! push h + lhld file$id! xchg! lxi h,lock$root! shld cur$pos +remove$lock1: + mvi b,0! push d! call searchn$list! pop d + jnz remove$lock2 + lxi b,8! call tst$tbl$lmt! jnz remove$lock1 + call delete$item + jmp remove$lock1 +remove$lock2: + pop h! shld prv$pos! pop d +remove$lock3: + lhld file$id! ret + +tst$tbl$lmt: + push h! dad b + mov a,m! inx h! mov h,m + sub e! jnz tst$tbl$lmt1 + mov a,h! sub d +tst$tbl$lmt1: + pop h! ret + +create$olist$item: + mvi b,1! call search$olist + di + call create$item! lda attributes! call set$olist$item + ei + ret + +count$opens: + xra a! sta open$cnt + lhld pdaddr! xchg! lxi h,open$root! shld curpos +count$open1: + mvi b,0! push d! call searchn$list! pop d! jnz count$open2 + lxi b,6! call tst$tbl$lmt! jnz count$open1 + lda open$cnt! inr a! sta open$cnt + jmp count$open1 +count$open2: + lxi h,open$max! lda open$cnt! ret + +count$locks: + xra a! sta lock$cnt + xchg! lxi h,lock$root! shld cur$pos +count$lock1: + mvi b,0! push d! call searchn$list! pop d! rnz + lxi b,8! call tst$tbl$lmt! jnz count$lock1 + lda lock$cnt! inr a! sta lock$cnt + jmp count$lock1 + +check$free: + lda mult$cnt! mov e,a + mvi d,0! lxi h,free$root! shld cur$pos +check$free1: + mvi b,0! push d! call searchn$list! pop d! jnz check$free2 + inr d! mov a,d! sub e! jc check$free1 + ret +check$free2: + pop h! mvi a,14! jmp sta$ret + +lock: ; record lock and unlock + call reselect! call check$fcb + call test$unlocked + rz ; file not opened in unlocked mode + lhld xdmaad! mov e,m! inx h! mov d,m + xchg! inx h! inx h + mov a,m! mov b,a! lda curdsk! sub b + ani 0fh! jnz lock8 ; invalid file id + mov a,b! ani 40h! jz lock8 ; invalid file id + dcx h! dcx h! shld file$id + lda lock$unlock! inr a! jnz lock1 ; jmp if unlock + call count$locks + lda lock$cnt! mov b,a + lda mult$cnt! add b! mov b,a + lda lock$max! cmp b + mvi a,12! jc sta$ret ; too many locks by this process + call check$free +lock1: + call save$rr! lxi h,lock9! push h! lda mult$cnt +lock2: + push a! call get$lock$add + lda lock$unlock! inr a! jnz lock3 + call test$lock +lock3: + pop a! dcr a! jz lock4 + call incr$rr! jmp lock2 +lock4: + call reset$rr! lda mult$cnt +lock5: + push a! call get$lock$add + lda lock$unlock! inr a! jnz lock6 + call set$lock! jmp lock7 +lock6: + call free$lock +lock7: + pop a! dcr a! rz + call incr$rr! jmp lock5 +lock8: + mvi a,13! jmp sta$ret ; invalid file id +lock9: + call reset$rr! ret + +get$lock$add: + lxi h,0! dad sp! shld lock$sp + mvi a,0ffh! sta lock$shell + call rseek + xra a! sta lock$shell + call getfcb + lhld aret! mov a,l! ora a! jnz lock$err + call index! lxi h,1! jz lock$err + call atran! ret + +lock$perr: + xra a! sta lock$shell + xchg! lhld lock$sp! sphl! xchg +lock$err: + pop d ; Discard return address + pop b ; b = mult$cnt-# recs processed + lda mult$cnt! sub b + add a! add a! add a! add a + ora h! mov h,a! mov b,a + shld aret! ret + +test$lock: + call move$arecord + mvi b,3! call search$llist! rnz + call compare$pds! rz + lxi h,8! jmp lock$err + +set$lock: + call move$arecord + mvi b,1! call search$llist + di + call create$item + xra a! call set$olist$item + xchg! lhld file$id! xchg + mov m,d! dcx h! mov m,e + ei! ret + +free$lock: + call move$arecord + mvi b,5! call search$llist! rnz +free$lock0: + call delete$item + mvi b,5! call searchn$list! rnz + jmp free$lock0 + +compare$pds: + lxi d,6! dad d! xchg + lxi h,pdaddr! mvi c,2! jmp compare + + +move$arecord: + lxi d,arecord! lxi h,packed$dcnt + + +fix$olist$item: + lxi d,xdcnt! lxi h,sdcnt + ; Is xdblk,xdcnt < sdblk,sdcnt + mvi c,4! ora a! +fix$ol1: + ldax d! sbb m! inx h! inx d! dcr c! jnz fix$ol1 + rnc + ; yes - update olist entry + call swap! call sdcnt$eq$xdcnt + lxi h,open$root! shld cur$pos + ; Find file's olist entry +fix$ol2: + call swap! call pack$sdcnt! call swap + mvi b,3! call searchn$list! rnz + ; Update olist entry with new dcnt value + push h! call pack$sdcnt! pop h + inx h! inx h! inx h! lxi d,packed$dcnt + mvi c,3! call move! jmp fix$ol2 + +hl$eq$hl$and$de: + mov a,l! ana e! mov l,a + mov a,h! ana d! mov h,a + ret + +remove$drive: + xchg! lda curdsk! mov c,a! lxi h,1 + call hlrotl + mov a,l! cma! ana e! mov e,a + mov a,h! cma! ana d! mov d,a + xchg! ret + +diskreset: + lxi h,0! shld ntlog + xra a! sta set$ro$flag + lhld info +intrnldiskreset: + xchg! lhld open$root! mov a,h! ora l! rz + xchg! lda curdsk! push a! mvi b,0 +dskrst1: + mov a,l! rar! jc dskrst3 +dskrst2: + mvi c,1! call hlrotr! inr b + mov a,h! ora l! jnz dskrst1 + pop a! sta curdsk + lhld ntlog! xchg! lhld tlog + mov a,l! ora e! mov l,a + mov a,h! ora d! mov h,a! shld tlog + inr a! ret +dskrst3: + push b! push h! mov a,b! sta curdsk + lhld rlog! call test$vector1! push a + lhld rodsk! lda curdsk! call test$vector1! mov b,a + pop h! lda set$ro$flag! ora b! ora h! sta check$disk + lxi h,open$root! shld cur$pos +dskrst4: + mvi b,1! call searchn$list! jnz dskrst6 + lda check$disk! ora a! jz dskrst5 + push h! call compare$pds! jz dskrst45 + pop h! xra a! xchg! jmp dskrst6 +dskrst45: + lxi d,ntlog! call set$cdisk + pop h! jmp dskrst4 +dskrst5: + lhld info! call remove$drive! shld info + ori 1 +dskrst6: + pop h! pop b! jnz dskrst2 + + ; error - olist item exists for another process + ; for removable drive to be reset + pop a! sta curdsk! mov a,b! adi 41h ; a = ascii drive + lxi h,6! dad d! mov c,m! inx h! mov b,m ; bc = pdaddr + push psw! call test$error$mode! pop d! jnz dskrst7 + mov a,d + + push b! push psw + call rlr! lxi d,console! dad d! mov d,m ; d = console # + lxi b,deniedmsg! call xprint + pop psw! mov c,a! call conoutx + mvi c,':'! call conoutx + lxi b,cnsmsg! call xprint + pop h! push h! lxi b,console! dad b + mov a,m! adi '0'! mov c,a! call conoutx + lxi b,progmsg! call xprint + pop h! call dsplynm + +dskrst7: + pop h ; Remove return addr from diskreset + lxi h,0ffffh! shld aret ; Flag the error + ret + +deniedmsg: + db cr,lf,'disk reset denied, drive ',0 +cnsmsg: + db ' console ',0 +progmsg: + db ' program ',0 +endif + +; +; individual function handlers +; + +func12: + ; Return version number + +if MPM + lxi h,0100h+dvers! jmp sthl$ret +else + lda version! jmp sta$ret ; lret = dvers (high = 00) +endif + +func13: + +if MPM + lhld dlog! shld info + call diskreset! jz reset$all + call reset$37 + jmp func13$cont +reset$all: + + ; Reset disk system - initialize to disk 0 + lxi h,0! shld rodsk! shld dlog + + shld rlog! shld tlog +func13$cont: + mvi a,0ffh! sta curdsk +else + lxi h,0ffffh! call reset$37x +endif + xra a! sta olddsk ; Note that usrcode remains unchanged + +if MPM + xra a! call getmemseg ; a = mem seg tbl index + ora a! rz + inr a! rz + call rlradr! lxi b,msegtbl-rlros! dad b + add a! add a! mov e,a! mvi d,0! dad d + mov h,m! mvi l,80h + jmp intrnlsetdma +else + lxi h,tbuff! shld dmaad ; dmaad = tbuff + jmp setdata ; to data dma address +endif + +func14: + +if MPM + call tmpselect ; seldsk = reg e + call rlr! lxi b,diskselect! dad b + mov a,m! ani 0fh! rrc! rrc! rrc! rrc + mov b,a! lda seldsk! ora b! rrc! rrc! rrc! rrc + mov m,a! ret +else + call tmpselect ; seldsk = reg e + lda seldsk! sta olddsk! ret +endif + +func15: + ; Open file + call clrmodnum ; Clear the module number + +if MPM + call reselect + xra a! sta make$flag + call set$sdcnt + lxi h,open$file! push h + mvi a,0c9h! sta check$fcb4 + call check$fcb1 + pop h! lda high$ext! cpi 060h! jnz open$file + call home! call set$end$dir + jmp open$user$zero +open$file: + call set$sdcnt + call reset$chksum$fcb ; Set invalid check sum +else + call reselectx +endif + + call check$wild ; Check for wild chars in fcb + +if MPM + + call get$atts! ani 1100$0000b ; a = attributes + cpi 1100$0000b! jnz att$ok + ani 0100$0000b ; Mask off unlock mode +att$ok: + sta high$ext + mov b,a! ora a! rar! jnz att$set + mvi a,80h +att$set: + sta attributes! mov a,b + ani 80h! jnz call$open +endif + + lda usrcode! ora a! jz call$open + mvi a,0feh! sta xdcnt+1! inr a! sta search$user0 + +if MPM + sta sdcnt0+1 +endif + +call$open: + call open! call openx ; returns if unsuccessful, a = 0 + lxi h,search$user0! cmp m! rz + mov m,a! lda xdcnt+1! cpi 0feh! rz +; +; file exists under user 0 +; + +if MPM + call swap +endif + + call set$dcnt$dblk + +if MPM + mvi a,0110$0000b +else + mvi a,80h +endif + + sta high$ext +open$user$zero: + ; Set fcb user # to zero + lhld info! mvi m,0 + mvi c,namlen! call searchi! call searchn + call open1 ; Attempt reopen under user zero + call openx ; openx returns only if unsuccessful + ret +openx: + call end$of$dir! rz + call getfcba! mov a,m! inr a! jnz openxa + dcx d! dcx d! ldax d! mov m,a +openxa: + ; open successful + pop h ; Discard return address + ; Was file opened under user 0 after unsuccessful + ; attempt to open under user n? + +if MPM + lda high$ext! cpi 060h! jz openx00 ; yes + ; Was file opened in locked mode? + ora a! jnz openx0 ; no + ; does user = zero? + lhld info! ora m! jnz openx0 ; no + ; Does file have read/only attribute set? + call rotest! jnc openx0 ; no + ; Does file have system attribute set? + inx h! mov a,m! ral! jnc openx0 ; no + + ; Force open mode to read/only mode and set user 0 flag + ; if file opened in locked mode, user = 0, and + ; file has read/only and system attributes set + +openx00: + +else + lda high$ext! ral! jnc openx0 +endif + + ; Is file under user 0 a system file ? + +if MPM + mvi a,20h! sta attributes +endif + + lhld info! lxi d,10! dad d + mov a,m! ani 80h! jnz openx0 ; yes - open successful + ; open fails + sta high$ext! jmp lret$eq$ff +openx0: + +if MPM + call reset$chksum$fcb +else + call set$lsn +endif + +if BANKED + + ; Are passwords enabled on drive? + call get$dir$mode! ani 80h! jz openx1a ; no + ; Is this 1st dir fcb? + call qdirfcb1! jnz openx0a ; no + ; Does sfcb exist? + call get$dtba$8! ora a! jnz openx0a ; no + ; Is sfcb password mode read or write? + mov a,m! ani 0c0h! jz openx1a ; no + ; Does xfcb exist? + call xdcnt$eq$dcnt + call get$xfcb! jnz openx0b ; yes + ; no - set sfcb password mode to zero + call restore$dir$fcb! rz ; (error) + ; Does sfcb still exist? + call get$dtba$8! ora a! jnz openx1a ; no (error) + ; sfcb password mode = 0 + mov m,a + ; update sfcb + call nowrite! cz seek$copy + jmp openx1a +openx0a: + call xdcnt$eq$dcnt + ; Does xfcb exist? + call get$xfcb! jz openx1 ; no +openx0b: + ; yes - check password + call cmp$pw! jz openx1 + call chk$pw$error + lda pw$mode! ani 0c0h! jz openx1 + ani 80h! jnz pw$error + mvi a,080h! sta xfcb$read$only +openx1: + call restore$dir$fcb! rz ; (error) +openx1a: + call set$lsn + +if MPM + call pack$sdcnt + ; Is this file currently open? + mvi b,3! call search$olist! jz openx04 +openx01: + ; no - is olist full? + lhld free$root! mov a,l! ora h! jnz openx03 + ; yes - error +openx02: + mvi a,11! jmp set$aret +openx03: + ; Has process exceeded open file maximum? + call count$opens! sub m! jc openx035 + ; yes - error +openx034: + mvi a,10! jmp set$aret +openx035: + ; Create new olist element + call create$olist$item + jmp openx08 +openx04: + ; Do file attributes match? + inx h! inx h + lda attributes! ora m! cmp m! jnz openx06 + ; yes - is open mode locked? + ani 80h! jnz openx07 + ; no - has this file been opened by this process? + lhld prv$pos! shld cur$pos + mvi b,5! call searchn$list! jnz openx01 +openx05: + ; yes - increment open file count + lxi d,8! dad d! inr m! jnz openx08 + ; count overflow + inx h! inr m! jmp openx08 +openx06: + ; error - file opened by another process in imcompatible mode + mvi a,5! jmp set$aret +openx07: + ; Does this olist item belong to this process? + dcx h! dcx h! push h + call compare$pds + pop h! jnz openx06 ; no - error + jmp openx05 ; yes +openx08:; Wopen ok + ; Was file opened in unlocked mode? + lda attributes! ani 40h! jz openx09 ; no + ; yes - return .olist$item in ranrec field of fcb + call get$rra + lxi d,cur$pos! mvi c,2! call move +openx09: + call set$fcb$cks$flag + lda make$flag! ora a! rnz +endif +endif + + mvi c,0100$0000b +openx2: + call qstamp! cz stamp1 + lxi d,olog! jmp set$cdisk + +func16: + ; Close file + call reselect + +if MPM + call get$atts! sta attributes + lxi h,close00! push h + mvi a,0c9h! sta check$fcb4 + call check$fcb1! pop h + call set$sdcnt + call getmodnum! ani 80h! jnz close01 + call close! jmp close02 +close00: + mvi a,6! jmp set$aret +close01: + mvi a,0ffh! sta dont$close! call close1 +close02: +else + call set$lsn + call chek$fcb! call close +endif + + lda lret! inr a! rz + + jmp flush ; Flush buffers + +if MPM + lda attributes! ral! rc + call pack$sdcnt + ; Find olist item for this process & file + mvi b,5! call search$olist! jnz close03 + ; Decrement open count + push h! lxi d,8! dad d + mov a,m! sui 1! mov m,a! inx h + mov a,m! sbi 0! mov m,a! dcx h + ; Is open count = 0ffffh + call test$ffff! pop h! jnz close03 + ; yes - remove file's olist entry + shld file$id! call delete$item + call reset$chksum$fcb + ; if unlocked file, remove file's locktbl entries + call test$unlocked! jz close03 + lhld file$id! call remove$locks +close03: + ret + +endif + +func17: + ; Search for first occurrence of a file + xchg! xra a +csearch: + push a + mov a,m! cpi '?'! jnz csearch1 ; no reselect if ? + call curselect! call noselect0! mvi c,0! jmp csearch3 +csearch1: + call getexta! mov a,m! cpi '?'! jz csearch2 + call clr$ext! call clrmodnum +csearch2: + call reselectx + mvi c,namlen +csearch3: + pop a! push a! jz csearch4 + ; dcnt = dcnt & 0fch + lhld dcnt! push h! mvi a,0fch + ana l! mov l,a! shld dcnt + call rd$dir + pop h! shld dcnt +csearch4: + pop a + lxi h,dir$to$user + push h + jz search + lda searchl! mov c,a! call searchi! jmp searchn + +func18: + ; Search for next occurrence of a file name + +if BANKED + xchg! shld searcha +else + lhld searcha! shld info +endif + + ori 1! jmp csearch + +func19: + ; Delete a file +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + jmp delete + +func20: + ; Read a file + call reselect + call check$fcb + jmp seqdiskread + +func21: + ; Write a file + call reselect + call check$fcb + jmp seqdiskwrite + +func22: + ; Make a file + +if BANKED + call get$atts! sta attributes +endif + + call clr$ext + call clrmodnum ; fcb mod = 0 + call reselectx + +if MPM + call reset$chksum$fcb +endif + + call check$wild + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + + call open ; Verify file does not already exist + +if MPM + call reset$chksum$fcb +endif + + ; Does dir fcb for fcb exist? + ; ora a required to reset carry + call end$of$dir! ora a! jz makea0 ; no + ; Is dir$ext < fcb(ext)? + call get$dir$ext! cmp m! jnc file$exists ; no +makea0: + push a ; carry set if dir fcb already exists + +if MPM + lda attributes! ani 80h! rrc! jnz makex00 + mvi a,80h +makex00: + sta make$flag + lda sdcnt+1! inr a! jz makex01 + call pack$sdcnt + mvi b,3! call search$olist! jz make$x02 +makex01: + lhld free$root! mov a,l! ora h! jz openx02 + jmp makex03 +makex02: + inx h! inx h + lda makeflag! ana m! jz openx06 + dcx h! dcx h! call compare$pds! jz makex03 + lda makeflag! ral! jc openx06 +makex03: + +endif + +if BANKED + ; Is fcb 1st fcb for file? + call qdirfcb1! jz makex04 ; yes + ; no - does dir lbl require passwords? + call get$dir$mode! ani 80h! jz makex04 + ; no - does xfcb exist with mode 1 or 2 password? + call get$xfcb! jz makex04 + ; yes - check password + call chk$xfcb$password1! jz makex04 + ; Verify password error + call chk$pw$error + lda pw$mode! ani 0c0h! jnz pw$error +makex04: + +endif + + ; carry on stack indicates a make not required because + ; of extent folding + pop a! cnc make + +if MPM + call reset$chksum$fcb +endif + + ; end$of$dir call either applies to above make or open call + call end$of$dir! rz ; Return if make unsuccessful + +if not MPM + call set$lsn +endif + +if BANKED + + ; Are passwords activated by dir lbl? + call get$dir$mode! ani 80h! jz make3a + ; Did user set password attribute? + lda attributes! ani 40h! jz make3a + ; Is fcb file's 1st logical fcb? + call qdirfcb1! jnz make3a + ; yes - does xfcb already exist for file + call xdcnt$eq$dcnt + call get$xfcb! jnz make00 ; yes + ; Attempt to make xfcb + mvi a,0ffh! sta make$xfcb! call make! jnz make00 + ; xfcb make failed - delete fcb that was created above + call search$namlen + call delete10! jmp lret$eq$ff ; Return with a = 0ffh + +make00: + call init$xfcb ; Initialize xfcb + ; Get password mode from dma + 8 + xchg! lhld xdmaad! lxi b,8! dad b! xchg + ldax d! ani 0e0h! jnz make2 + mvi a,080h ; default password mode is read protect +make2: + sta pw$mode + ; Set xfcb password mode field + push a! call getxfcb1! pop a! mov m,a + ; Set xfcb password and password checksum + ; Fix hash table and write xfcb + call set$pw! mov m,b! call sdl3 + ; Return to fcb + call restore$dir$fcb! rz + ; Does sfcb exist? + mvi c,8! call getdtba! ora a! jnz make3a ; no + ; Place password mode in sfcb if sfcb exists + lda pw$mode! mov m,a! call seek$copy + call set$lsn +endif + +make3a: + mvi c,0101$0000b + +if MPM + call openx2 + lda make$flag! sta attributes + ani 40h! ral! sta high$ext + lda sdcnt+1! inr a! jnz makexx02 + call sdcnt$eq$xdcnt! call pack$sdcnt + jmp openx03 +makexx02: + call fix$olist$item! jmp openx1 + jmp set$fcb$cks$flag +else + call openx2 + mvi c,0010$0000b! call qstamp! rnz + call stamp2! jmp set$filewf +endif + +file$exists: + mvi a,8 +set$aret: + mov c,a! sta aret+1! call lret$eq$ff + +if MPM + call test$error$mode! jnz goback +else + jmp goerr1 +endif + +if MPM + mov a,c! sui 3 + mov l,a! mvi h,0! dad h + lxi d,xerr$list! dad d + mov e,m! inx h! mov d,m + xchg! jmp report$err +endif + +func23: + ; Rename a file +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + jmp rename + +func24: + ; Return the login vector + lhld dlog! jmp sthl$ret + +func25: + ; Return selected disk number + lda seldsk! jmp sta$ret + +func26: + +if MPM + ; Save dma address in process descriptor + lhld info +intrnlsetdma: + xchg + call rlr! lxi b,disksetdma! dad b + mov m,e! inx h! mov m,d +endif + + ; Set the subsequent dma address to info + xchg! shld dmaad ; dmaad = info + jmp setdata ; to data dma address + +func27: + ; Return the login vector address + call curselect + lhld alloca! jmp sthl$ret + +if MPM + +func28: + ; Write protect current disk + ; first check for open files on disk + mvi a,0ffh! sta set$ro$flag + lda seldsk! mov c,a! lxi h,0001h + call hlrotl! call intrnldiskreset + jmp set$ro +else + +func28: equ set$ro ; Write protect current disk + +endif + +func29: + ; Return r/o bit vector + lhld rodsk! jmp sthl$ret + +func30: + ; Set file indicators + call check$wild +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + call indicators + jmp copy$dirloc ; lret=dirloc + +func31: + ; Return address of disk parameter block + call curselect + lhld dpbaddr +sthl$ret: + shld aret! ret + +func32: + ; Set user code + lda linfo! cpi 0ffh! jnz setusrcode + ; Interrogate user code instead + lda usrcode! jmp sta$ret ; lret=usrcode + setusrcode: + ani 0fh! sta usrcode + +if MPM + push a + call rlr! lxi b,diskselect! dad b + pop b + mov a,m! ani 0f0h! ora b! mov m,a +endif + + ret + +func33: + ; Random disk read operation + call reselect + call check$fcb + jmp randiskread ; to perform the disk read + +func34: + ; Random disk write operation + call reselect + call check$fcb + jmp randiskwrite ; to perform the disk write + +func35: + ; Return file size (0-262,144) + call reselect + jmp getfilesize + +func36 equ setrandom ; Set random record + +func37: + ; Drive reset + +if MPM + call diskreset +reset$37: + lhld info +else + xchg +endif + +reset$37x: + mov a,l! cma! mov e,a! mov a,h! cma + lhld dlog! ana h! mov d,a! mov a,l! ana e + mov e,a! lhld rodsk! xchg! shld dlog + +if MPM + push h! call hl$eq$hl$and$de +else + mov a,l! ana e! mov l,a + mov a,h! ana d! mov h,a +endif + + shld rodsk + +if MPM + pop h! xchg! lhld rlog! call hl$eq$hl$and$de! shld rlog +endif + + ; Force select call in next curselect + mvi a,0ffh! sta curdsk! ret + +if MPM + +func38: + ; Access drive + + lxi h,packed$dcnt! mvi a,0ffh + mov m,a! inx h! mov m,a! inx h! mov m,a + xra a! xchg! lxi b,16 +acc$drv0: + dad h! adc b! dcr c! jnz acc$drv0 + ora a! rz + sta mult$cnt! dcr a! push a + call acc$drv02 + pop a! jmp openx02 ; insufficient free lock list items +acc$drv02: + call check$free! pop h ; Discard return addr, free space exists + call count$opens! pop b! add b! jc openx034 + sub m! jnc openx034 ; openmax exceeded + lhld info! lda curdsk! push a! mvi a,16 +acc$drv1: + dcr a! dad h! jc acc$drv2 +acc$drv15: + ora a! jnz acc$drv1 + pop a! sta curdsk! ret +acc$drv2: + push a! push h! sta curdsk + call create$olist$item + pop h! pop a! jmp acc$drv15 + +func39: + ; Free drive + lhld open$root! mov a,h! ora l! rz + xra a! sta incr$pdcnt! inr a! sta free$mode + lhld info! mov a,h! cmp l! jnz free$drv1 + inr a! jnz free$drv1 + sta free$mode! call free$files! jmp free$drv3 +free$drv1: + lda curdsk! push a! mvi a,16 +free$drv2: + dcr a! dad h! jc free$drv4 +free$drv25: + ora a! jnz free$drv2 + pop a! sta curdsk +free$drv3: + lda incr$pdcnt! ora a! rz + lda pdcnt! jmp chk$olist1 +free$drv4: + push a! push h! sta curdsk + call free$files + pop h! pop a! jmp free$drv25 +else + +func38 equ func$ret +func39 equ func$ret + +endif + +func40 equ func34 ; Write random with zero fill + +if MPM + +func41 equ func$ret ; Test & write +func42: ; Record lock + mvi a,0ffh! sta lock$unlock! jmp lock +func43: ; Record unlock + xra a! sta lock$unlock! jmp lock + +else + +func42 equ func$ret ; Record lock +func43 equ func$ret ; Record unlock + +endif + +func44: ; Set multi-sector count + mov a,e! ora a! jz lret$eq$ff + cpi 129! jnc lret$eq$ff + sta mult$cnt + +if MPM + mov d,a + call rlr! lxi b,mult$cnt$off! dad b + mov m,d +endif + + ret + +func45: ; Set bdos error mode + +if MPM + call rlr! lxi b,pname+4! dad b + call set$pflag + mov m,a! inx h + call set$pflag + mov m,a! ret + +set$pflag: + mov a,m! ani 7fh! inr e! rnz + ori 80h! ret +else + mov a,e! sta error$mode +endif + + ret + +func46: + ; Get free space + ; Perform temporary select of specified drive + call tmpselect + lhld alloca! xchg ; de = alloc vector addr + call get$nalbs ; Get # alloc blocks + ; hl = # of allocation vector bytes + ; Count # of true bits in allocation vector + lxi b,0 ; bc = true bit accumulator +gsp1: ldax d +gsp2: ora a! jz gsp4 +gsp3: rar! jnc gsp3 + inx b! jmp gsp2 +gsp4: inx d! dcx h + mov a,l! ora h! jnz gsp1 + ; hl = 0 when allocation vector processed + ; Compute maxall + 1 - bc + lhld maxall! inx h + mov a,l! sub c! mov l,a + mov a,h! sbb b! mov h,a + ; hl = # of available blocks on drive + lda blkshf! mov c,a! xra a + call shl3bv + ; ahl = # of available sectors on drive + ; Store ahl in beginning of current dma + xchg! lhld xdmaad! mov m,e! inx h + mov m,d! inx h! mov m,a! ret + +if MPM + +func47 equ func$ret + +else + +func47: ; Chain to program + lxi h,ccp$flgs! mov a,m! ori 80h! mov m,a + inr e! jnz rebootx1 + mov a,m! ori 40h! mov m,a + jmp rebootx1 +endif + +func48: ; Flush buffers + call check$all$media + call flushf + call diocomp +flush0: ; Function 98 entry point + lhld dlog! mvi a,16 +flush1: + dcr a! dad h! jnc flush5 + push a! push h! mov e,a! call tmpselect ; seldsk = e + lda fx! cpi 48! jz flush3 + ; Function 98 - reset allocation + ; Copy 2nd ALV over 1st ALV + call copy$alv +if BANKED + jmp patch$2d3a ;[JCE] DRI Patch 13 +else + jmp flush35 +endif + +flush3: + call flushx + ; if e = 0ffh then discard buffers after possible flush + lda linfo! inr a! jnz flush4 +flush35: + call discard$data +flush4: + pop h! pop a +flush5: + ora a! jnz flush1 + ret + +flush: + call flushf + call diocomp +flushx: + lda phymsk! ora a! rz + mvi a,4! jmp deblock$dta + +if MPM + +func49 equ func$ret + +else + +func49: ; Get/Set system control block + + xchg! mov a,m! cpi 99! rnc + xchg! lxi h,scb! add l! mov l,a + xchg! inx h! mov a,m! cpi 0feh! jnc func49$set + xchg! mov e,m! inx h! mov d,m! xchg + jmp sthl$ret +func49$set: + mov b,a! inx h! mov a,m! stax d! inr b! rz + inx h! inx d! mov a,m! stax d! ret +endif + +if MPM + +func50 equ func$ret + +else + +func50: ; Direct bios call + ; de -> function (1 byte) + ; a value (1 byte) + ; bc value (2 bytes) + ; de value (2 bytes) + ; hl value (2 bytes) + + lxi h,func50$ret! push h + xchg + +if BANKED + mov a,m! cpi 27! rz + cpi 12! jnz dir$bios1 + lxi d,dir$bios3! push d +dir$bios1: + cpi 9! jnz dir$bios2 + lxi d,dirbios4! push d +dir$bios2: + +endif + + push h! inx h! inx h + mov c,m! inx h! mov b,m! inx h + mov e,m! inx h! mov d,m! inx h + mov a,m! inx h! mov h,m! mov l,a + xthl! mov a,m! push h! mov l,a! add a! add l + + lxi h,bios + + add l! mov l,a! xthl + inx h! mov a,m! pop h! xthl! ret + +if BANKED + +dir$bios3: + mvi a,1! jmp setbnkf + +dir$bios4: + mov a,l! ora h! rz + xchg! lxi h,10! dad d! mvi m,0 ; Zero login sequence # + lhld common$base! call subdh! xchg! rnc + ; Copy DPH to common memory + xchg! lhld info! inx h! push h! lxi b,25 + call movef! pop h! ret +endif + +func50$ret: + +if BANKED + shld aret! mov b,a + lhld info! mov a,m + cpi 9! rz + cpi 16! rz + cpi 20! rz + cpi 22! rz + mov a,b! jmp sta$ret +else + xchg! lhld entsp! sphl! xchg! ret +endif +endif + +func98 equ flush0 ; Reset Allocation + +func99: ; Truncate file + call reselectx + call check$wild + +if BANKED + call chk$password! cnz chk$pw$error +endif + + mvi c,true! call rseek! jnz lret$eq$ff + ; compute dir$fcb size + call getdptra! lxi d,reccnt + call compute$rr ; cba = fcb size + ; Is random rec # >= dir$fcb size + call get$rra! call compare$rr + jc lret$eq$ff ; yes ( > ) + ora d! jz lret$eq$ff ; yes ( = ) + ; Perform truncate + call check$rodir ; may be r/o file + call wrdir ; verify BIOS can write to disk + call update$stamp ; Set update stamp + call search$extnum +trunc1: + jz copy$dirloc + ; is dirfcb < fcb? + call compare$mod$ext! jc trunc2 ; yes + ; remove dirfcb blocks from allocation vector + push a! mvi c,0! call scandm$ab! pop a + ; is dirfcb = fcb? + jz trunc3 ; yes + ; delete dirfcb + call getdptra! mvi m,empty! call fix$hash +trunc15: + call wrdir +trunc2: + call searchn + jmp trunc1 +trunc3: + call getfcb! call dm$position + call zero$dm + ; fcb(extnum) = dir$ext after blocks removed + call get$dir$ext! cmp m! mov m,a! push a + ; fcb(rc) = fcb(cr) + 1 + call getfcba! mov a,m! inr a! stax d + ; rc = 0 or 128 if dir$ext < fcb(extnum) + pop a! xchg! cnz set$rc3 + ; rc = 0 if no blocks remain in fcb + lda dminx! ora a! cz set$rc3 + lxi b,11! call get$fcb$adds! xchg + ; reset archive (t3') attribute bit + mov a,m! ani 7fh! mov m,a! inx h! inx d + ; dirfcb(extnum) = fcb(extnum) + ldax d! mov m,a + ; advance to .fcb(reccnt) & .dirfcb(reccnt) + inx h! mvi m,0! inx h! inx h + inx d! inx d! inx d + ; dirfcb_rc+dskmap = fcb_rc+dskmap + mvi c,17! call move + ; restore non-erased blkidxs in allocation vector + mvi c,1! call scandm$ab + jmp trunc15 + +get$fcb$adds: + call getdptra! dad b! xchg + lhld info! dad b! ret + +compare$mod$ext: + lxi b,modnum! call get$fcb$adds + mov a,m! ani 3fh! mov b,a + ; compare dirfcb(modnum) to fcb(modnum) + ldax d! cmp b! rnz ; dirfcb(modnum) ~= fcb(modnum) + dcx h! dcx h! dcx d! dcx d + ; compare dirfcb(extnum) to fcb(extnum) + ldax d! mov c,m! call compext! rz ; dirfcb(extnum) = fcb(extnum) + ldax d! cmp m! ret + +zero$dm: + inr a! lxi h,single! inr m! jz zero$dm1 + add a +zero$dm1: + dcr m + call getdma! mov c,a! mvi b,0! dad b + mvi a,16 +zero$dm2: + cmp c! rz + mov m,b! inx h! inr c! jmp zero$dm2 + +if BANKED + +func100: ; Set directory label + ; de -> .fcb + ; drive location + ; name & type fields user's discretion + ; extent field definition + ; bit 1 (80h): enable passwords on drive + ; bit 2 (40h): enable file access + ; bit 3 (20h): enable file update stamping + ; bit 4 (10h): enable file create stamping + ; bit 8 (01h): assign new password to dir lbl + call reselectx + lhld info! mvi m,21h! mvi c,1 + call search! jnz sdl0 + call getexta! mov a,m! ani 0111$0000b! jnz lret$eq$ff +sdl0: + ; Does dir lbl exist on drive? + lhld info! mvi m,20h! mvi c,1 + call set$xdcnt! call search! jnz sdl1 + ; no - make one + mvi a,0ffh! sta make$xfcb + call make! rz ; no dir space + call init$xfcb + lxi b,24! call stamp5! call stamp1 +sdl1: + ; Update date & time stamp + lxi b,28! call stamp5! call stamp2 + ; Verify password - new dir lbl falls through + call chk$xfcb$password! jnz pw$error + lxi b,0! call init$xfcb0 + ; Set dir lbl dta in extent field + ldax d! ori 1h! mov m,a + ; Low bit of dir lbl data set to indicate dir lbl exists + ; Update drive's dir lbl vector element + push h! lhld drvlbla! mov m,a! pop h +sdl2: + ; Assign new password to dir lbl or xfcb? + ldax d! ani 1! jz sdl3 + ; yes - new password field is in 2nd 8 bytes of dma + lxi d,8! call adjust$dmaad + call set$pw! mov m,b + lxi d,-8! call adjust$dmaad +sdl3: + call fix$hash + jmp seek$copy +else + +func100 equ lret$eq$ff +func103 equ lret$eq$ff + +endif + +func101: + ; Return directory label data + ; Perform temporary select of specified drive + call tmpselect + call get$dir$mode! jmp sta$ret + +func102: + ; Read file xfcb + call reselectx + call check$wild + call zero$ext$mod + call search$namlen! rz + call getdma! lxi b,8! call zero + push h! mvi c,0! call get$dtba! ora a! jnz rxfcb2 + pop d! xchg! mvi c,8 + +if BANKED + call move! ldax d! jmp rxfcb3 +else + jmp move +endif + +rxfcb2: + pop h! lxi b,8 + +if BANKED + call zero! call get$xfcb! rz + mov a,m +rxfcb3: + call getexta! mov m,a! ret +else + jmp zero +endif + +if BANKED + +func103: + ; Write or update file xfcb + call reselectx + ; Are passwords enabled in directory label? + call get$dir$mode! ral! jnc lret$eq$ff ; no + call check$wild + ; Save .fcb(ext) & ext + call getexta! mov b,m! push h! push b + ; Set extent & mod to zero + call zero$ext$mod + ; Does file's 1st fcb exist in directory? + call search$namlen + ; Restore extent + pop b! pop h! mov m,b! rz ; no + call set$xdcnt + ; Does sfcb exist? + call get$dtba$8! ora a! jz wxfcb5 ; yes + ; No - Does xfcb exist? + call get$xfcb! jnz wxfcb1 ; yes +wxfcb0: + ; no - does file exist in directory? + mvi a,0ffh! sta make$xfcb + call search$extnum! rz + ; yes - attempt to make xfcb for file + call make! rz ; no dir space + ; Initialize xfcb + call init$xfcb +wxfcb1: + ; Verify password - new xfcb falls through + call chk$xfcb$password! jnz pw$error + ; Set xfcb options data + push h! call getexta! pop d! xchg + mov a,m! ora a! jnz wxfcb2 + ldax d! ani 1! jnz wxfcb2 + call sdl3! jmp wxfcb4 +wxfcb2: + ldax d! ani 0e0h! jnz wxfcb3 + mvi a,80h +wxfcb3: + mov m,a! call sdl2 +wxfcb4: + call get$xfcb1! dcr a! sta pw$mode + call zero$ext$mod + call search$namlen! rz + call get$dtba$8! ora a! rnz + lda pw$mode! mov m,a! jmp seek$copy +wxfcb5: + ; Take sfcb's password mode over xfcb's mode + mov a,m! push a + call get$xfcb + ; does xfcb exist? + pop b! jz wxfcb0 ; no + ; Set xfcb's password mode to sfcb's mode + mov m,b! jmp wxfcb1 + +endif + +func104: ; Set current date and time + +if MPM + call get$stamp$add +else + lxi h,stamp +endif + call copy$stamp + mvi m,0! mvi c,0ffh! jmp timef + +func105: ; Get current date and time + + + +if MPM + call get$stamp$add +else + mvi c,0! call timef + lxi h,stamp +endif + + xchg + call copy$stamp + ldax d! jmp sta$ret + +copy$stamp: + mvi c,4! jmp move ; ret + +if MPM + +get$stamp$add: + call rlradr! lxi b,-5! dad b + ret +endif + +if BANKED + +func106: ; Set default password + +if MPM + call get$df$pwa! inr a! rz + lxi b,7! dad b +else + lxi h,df$password+7 +endif + xchg! lxi b,8! push h + jmp set$pw0 +else + +func106 equ func$ret + +endif + +func107: ; Return serial number + +if MPM + lhld sysdat! mvi l,181 +else + lxi h,serial +endif + + xchg! mvi c,6! jmp move + +func108: ; Get/Set program return code + + ; Is de = 0ffffh? + mov a,d! ana e! inr a + lhld clp$errcde! jz sthl$ret ; yes - return return code + xchg! shld clp$errcde! ret ; no - set return code + +goback0: + lxi h,0ffffh! shld aret +goback: + ; Arrive here at end of processing to return to user + lda resel! ora a! jz retmon + +if MPM + lda comp$fcb$cks! ora a! cnz set$chksum$fcb +endif + + lhld info! lda fcbdsk! mov m,a ; fcb(0)=fcbdsk +if BANKED + + ; fcb(7) = fcb(7) | xfcb$read$only + lxi d,7! dad d! lda xfcb$read$only! ora m! mov m,a + +endif +if MPM + ; if high$ext = 60h then fcb(8) = fcb(8) | 80h + ; else fcb(ext) = fcb(ext) | high$ext + + call getexta! lda high$ext! cpi 60h! jnz goback2 + lxi d,-4! dad d! mvi a,80h + goback2: + ora m! mov m,a +else + ; fcb(8) = fcb(8) | high$ext +if BANKED + inx h +else + lxi d,8! dad d +endif + lda high$ext! ora m! mov m,a +endif + +; return from the disk monitor + +retmon: + lhld entsp! sphl + lhld aret! mov a,l! mov b,h! ret +; +; data areas +; +efcb: db empty ; 0e5=available dir entry +rodsk: dw 0 ; read only disk vector +dlog: dw 0 ; logged-in disks + +if MPM + +rlog: dw 0 ; removeable logged-in disks +tlog: dw 0 ; removeable disk test login vector +ntlog: dw 0 ; new tlog vector +rem$drv: ds byte ; curdsk removable drive switch + ; 0 = permanent drive, 1 = removable drive +endif + +if not BANKED + +xdmaad equ $ +curdma ds word ; current dma address + +endif + +if not MPM + +buffa: ds word ; pointer to directory dma address + +endif + +; +; curtrka - alloca are set upon disk select +; (data must be adjacent, do not insert variables) +; (address of translate vector, not used) +cdrmaxa:ds word ; pointer to cur dir max value (2 bytes) +curtrka:ds word ; current track address (2) +curreca:ds word ; current record address (3) +drvlbla:ds word ; current drive label byte address (1) +lsn$add:ds word ; login sequence # address (1) + ; +1 -> bios media change flag (1) +dpbaddr:ds word ; current disk parameter block address +checka: ds word ; current checksum vector address +alloca: ds word ; current allocation vector address +dirbcba:ds word ; dir bcb list head +dtabcba:ds word ; data bcb list head +hash$tbla: + ds word ; directory hash table address + ds byte ; directory hash table bank + +addlist equ $-dpbaddr ; address list size + +; +; buffer control block format +; +; bcb format : drv(1) || rec(3) || pend(1) || sequence(1) || +; 0 1 4 5 +; +; track(2) || sector(2) || buffer$add(2) || +; 6 8 10 +; +; bank(1) || link(2) +; 12 13 +; + +; sectpt - offset obtained from disk parm block at dpbaddr +; (data must be adjacent, do not insert variables) +sectpt: ds word ; sectors per track +blkshf: ds byte ; block shift factor +blkmsk: ds byte ; block mask +extmsk: ds byte ; extent mask +maxall: ds word ; maximum allocation number +dirmax: ds word ; largest directory number +dirblk: ds word ; reserved allocation bits for directory +chksiz: ds word ; size of checksum vector +offset: ds word ; offset tracks at beginning +physhf: ds byte ; physical record shift +phymsk: ds byte ; physical record mask +dpblist equ $-sectpt ; size of area +; +; local variables +; +drec ds word ; directory record number +blk$off: ds byte ; record offset within block +last$off: ds byte ; last offset within new block +last$drive: ds byte ; drive of last new block +last$block: ds word ; last new block + +; The following two variables are initialized as a pair on entry + +dir$cnt: ds byte ; direct i/o count +mult$num: ds byte ; multi-sector number + +tranv: ds word ; address of translate vector +lock$unlock: +make$flag: +rmf: ds byte ; read mode flag for open$reel +incr$pdcnt: +dirloc: ds byte ; directory flag in rename, etc. +free$mode: +linfo: ds byte ; low(info) +dminx: ds byte ; local for diskwrite + +if MPM + +searchl:ds byte ; search length + +endif +if BANKED + +searcha:ds word ; search address + +endif + +if BANKED + +save$xfcb: + ds byte ; search xfcb save flag + +endif + +single: ds byte ; set true if single byte allocation map + +if MPM + +seldsk: ds byte ; currently selected disk + +endif + +seldsk: ds byte ; disk on entry to bdos +rcount: ds byte ; record count in current fcb +extval: ds byte ; extent number and extmsk +save$mod: + ds byte ; open$reel module save field + +vrecord:ds byte ; current virtual record + +if not MPM + +curdsk: db 0ffh ; current disk + +endif + +adrive: db 0ffh ; current blocking/deblocking disk +arecord:ds word ; current actual record + ds byte + +save$ranr: ds 3 ; random record save area +arecord1: ds word ; current actual block# * blkmsk +attributes: ds byte ; make attribute hold area +readf$sw: ds byte ; BIOS read/write switch + +;******** following variable order critical ***************** + +if MPM + +mult$cnt: ds byte ; multi-sector count +pdcnt: ds byte ; process descriptor count + +endif + +high$ext: ds byte ; fcb high ext bits + +if BANKED + +xfcb$read$only: ds byte ; xfcb read only flag + +endif +if MPM + +curdsk: db 0ffh ;current disk +packed$dcnt: ds 3 ; +pdaddr: ds word ; +;************************************************************ +cur$pos: ds word ; +prv$pos: ds word ; +sdcnt: ds word ; +sdblk: ds word ; +sdcnt0: ds word ; +sdblk0: ds word ; +dont$close: ds byte ; +open$cnt: ; mp/m temp variable for open +lock$cnt: ds word ; mp/m temp variable for lock +file$id: ds word ; mp/m temp variable for lock +deleted$files: ds byte +lock$shell: ds byte +lock$sp: ds word +set$ro$flag: ds byte +check$disk: ds byte +flushed: ds byte +fcb$cks$valid: ds byte +; mp/m variables * + +endif + +; local variables for directory access +dptr: ds byte ; directory pointer 0,1,2,3 + +save$hash: ds 4 ; hash code save area + +if BANKED + +copy$cr$init: ds byte ; copy$cr$only initialization value + +else + +hashmx: ds word ; cdrmax or dirmax +xdcnt: ds word ; empty directory dcnt + +endif + +if MPM + +xdcnt: ds word ; empty directory dcnt +xdblk: ds word ; empty directory block +dcnt: ds word ; directory counter 0,1,...,dirmax +dblk: ds word ; directory block index + +endif + +search$user0: ds byte ; search user 0 for file (open) + +user0$pass: ds byte ; search user 0 pass flag + +fcbdsk: ds byte ; disk named in fcb + +if MPM + +make$xfcb: ds 1 +find$xfcb: ds 1 + +endif + +log$fxs:db 15,16,17,19,22,23,30,35,99,100,102,103,0 +rw$fxs: db 20,21,33,34,40,41,0 +sc$fxs: db 16,18,0 + +if MPM + +comp$fcb$cks: ds byte ; compute fcb checksum flag + +endif +if BANKED + +pw$fcb: ds 12 ;1 | + db 0 ;2 | +pw$mode: db 0 ;3 |- Order critical + db 0 ;4 | + db 0 ;5 | + +df$password: ds 8 + +if MPM + ds 120 +endif +endif + +phy$off: ds byte +curbcba: ds word + +if BANKED + +lastbcba: ds word +rootbcba: ds word +emptybcba: ds word +seqbcba: ds word +buffer$bank: ds byte + +endif + +track: ds word +sector: ds word + +; ************************** +; Blocking/Deblocking Module +; ************************** + +deblock$dta: + lhld dtabcba + +if BANKED + cpi 4! jnz deblock +deblock$flush: + ; de = addr of 1st bcb + mov e,m! inx h! mov d,m + ; Search for dirty bcb with lowest track # + lxi h,0ffffh! shld track! xchg +deblock$flush1: + ; Does current drive own bcb? + lda adrive! cmp m! jnz deblock$flush2 ;no + ; Is bcb's buffer pending? + xchg! lxi h,4! dad d! mov a,m + xchg! inr a! jnz deblock$flush2 ; no + ; Is bcb(6) < track? + push h! inx d! inx d! xchg + mov e,m! inx h! mov d,m + ; Subdh computes hl = de - hl + lhld track! call subdh! pop h! jnc deblock$flush2 ; no + ; yes - track = bcb(6) , sector = addr(bcb) + xchg! shld track! xchg! shld sector +deblock$flush2: + ; Is this the last bcb? + call get$next$bcba! jnz deblock$flush1 ; no - hl = addr of next bcb + ; Does track = ffff? + lxi h,track! call test$ffff! rz ; yes - no bcb to flush + ; Flush bcb located by sector + lhld sector! xra a! mvi a,4! call deblock + lhld dtabcba! jmp deblock$flush ; Repeat until no bcb's to flush +endif + +deblock: + + ; BDOS Blocking/Deblocking routine + ; a = 1 -> read command + ; a = 2 -> write command + ; a = 3 -> locate command + ; a = 4 -> flush command + ; a = 5 -> directory update + + push a ; Save z flag and deblock fx + + ; phy$off = low(arecord) & phymsk + ; low(arecord) = low(arecord) & ~phymsk + call deblock8 + lda arecord! mov e,a! ana b! sta phy$off + mov a,e! ana c! sta arecord + +if BANKED + pop a! push a! cnz get$bcba +endif + + shld curbcba! call getbuffa! shld curdma + ; hl = curbcba, de = .adrive, c = 4 + call deblock9 + ; Is BCB discarded? + mov a,m! inr a! jz deblock2 ; yes + ; Is command flush? + pop a! push a! cpi 4! jnc deblock1 ; yes + ; Is referenced physical record already in buffer? + +;;; call compare ;[JCE] DRI patch 7 + call patch$1e0c + + jz deblock45 ; yes + xra a +deblock1: + ; Does buffer contain an updated record? + call deblock10 + cpi 5! jz deblock15 + mov a,m! ora a! jz deblock2 ; no +deblock15: + ; Reset record pending flag + mvi m,0 + ; Save arecord + lhld arecord! push h! lda arecord+2! push a + ; Flush physical record buffer + call deblock9 + xchg! call move + ; Select drive to be flushed + lxi h,curdsk! lda adrive! cmp m! cnz disk$select1 + ; Write record if drive logged-in + mvi a,1! cz deblock$io + ; Restore arecord + pop b! pop d! call set$arecord + ; Restore selected drive + call curselect +deblock2: + ; Is deblock command flush | dir write? + pop a! cpi 4! rnc ; yes - return + ; Is deblock command write? + push a! cpi 2! jnz deblock25 ; no + ; Is blk$off < last$off + lxi h,last$off + lda blk$off + cmp m + jnc deblock3 ; no +deblock25: + ; Discard BCB on read operations in case + ; I/O error occurs +;;; lhld curbcba ;[JCE] DRI Patch 7 + call patch$1e1c + mvi m,0ffh + ; Read physical record buffer + mvi a,2! jmp deblock35 +deblock3: + ; last$off = blk$off + 1 + inr a! mov m,a + ; Place track & sector in bcb + xra a +deblock35: + call deblock$io +deblock4: + call deblock9 ; phypfx = adrive || arecord + call move! mvi m,0 ; zero pending flag + +if BANKED + ; Zero logical record sequence + inx h! call set$bcb$seq +endif + +deblock45: + ; recadd = phybuffa + phy$off*80h + lda phy$off! inr a! lxi d,80h! lxi h,0ff80h +deblock5: + dad d! dcr a! jnz deblock5 + xchg! lhld curdma! dad d + ; If deblock command = locate then buffa = recadd; return + pop a! cpi 3! jnz deblock6 + shld buffa! ret +deblock6: + xchg! lhld dmaad! lxi b,80h + ; If deblock command = read + cpi 1 + +if BANKED + jnz deblock7 + ; then move to tpa + lda common$base+1! dcr a! cmp d! jc move$tpa + lda buffer$bank! mov c,a! mvi b,1! call deblock12 + lxi b,80h! jmp move$tpa +deblock7: + +else + jz move$tpa ; then move to dma +endif + + ; else move from dma + xchg + +if BANKED + lda common$base+1! dcr a! cmp h! jc deblock75 + lda buffer$bank! mov b,a! mvi c,1! call deblock12 + lxi b,80h +deblock75: + +endif + + call move$tpa + ; Set physical record pending flag for write command + call deblock10! mvi m,0ffh + ret + +deblock8: + lda phymsk! mov b,a! cma! mov c,a! ret + +deblock9: + lhld curbcba! lxi d,adrive! mvi c,4! ret + +deblock10: + lxi d,4 +deblock11: + lhld curbcba! dad d! ret + +if BANKED + +deblock12: + push h! push d! call xmovef + pop d! pop h! ret +endif + +deblock$io: + ; a = 0 -> seek only + ; a = 1 -> write + ; a = 2 -> read + push a! call seek + +if BANKED + lda buffer$bank! call setbnkf +endif + + mvi c,1 + pop a! dcr a + jz wrbuff + cp rdbuff + ; Move track & sector to bcb + call deblock10! inx h! inx h + lxi d,track! mvi c,4! jmp move + +if BANKED + +get$bcba: +;;; shld rootbcba ;[JCE] DRI Patch 13 + call patch$2d30 + lxi d,-13! dad d! shld lastbcba + call get$next$bcba! push h + ; Is there only 1 bcb in list? + call get$next$bcba! pop h! rz ; yes - return + xchg! lxi h,0! shld emptybcba! shld seqbcba + xchg +get$bcb1: + ; Does bcb contain requested record? + shld curbcba! call deblock9! call compare! jz get$bcb4 ; yes + ; Is bcb discarded? + lhld curbcba! mov a,m! inr a! jnz get$bcb11 ; no + xchg! lhld lastbcba! shld emptybcba! jmp get$bcb14 +get$bcb11: + ; Does bcb contain record from current disk? + lda adrive! cmp m! jnz get$bcb15 ; no + xchg! lxi h,5! dad d! lda phy$msk + ; Is phy$msk = 0? + ora a! jz get$bcb14 ; yes + ; Does bcb(5) [bcb sequence] = phymsk? + cmp m! jnz get$bcb14 ; no +;;; lhld seqbcba ;[JCE] DRI Patch 13 +;;; mov a,l +;;; ora h + lda patch$2d39 + ora a + nop + jnz get$bcb14 + lhld lastbcba! shld seqbcba +get$bcb14: + xchg +get$bcb15: + ; Advance to next bcb - list exhausted? + push h! call get$next$bcba! pop d! jz get$bcb2 ; yes + xchg! shld lastbcba! xchg! jmp get$bcb1 +get$bcb2: + ; Matching bcb not found + ; Was a sequentially accessed bcb encountered? +;;; lhld seqbcba ;[JCE] DRI Patch 13 + lhld emptybcba + + mov a,l! ora h! jnz get$bcb25 ; yes + ; Was a discarded bcb encountered? +;;; lhld emptybcba ;[JCE] DRI Patch 13 + lhld seqbcba + + mov a,l! ora h! jz get$bcb3 ; no +get$bcb25: + shld lastbcba +get$bcb3: + ; Insert selected bcb at head of list + lhld lastbcba! call get$next$bcba + shld curbcba! call get$next$bcba + xchg! call last$bcb$links$de + lhld rootbcba! mov e,m! inx h! mov d,m + lhld curbcba! lxi b,13! dad b + mov m,e! inx h! mov m,d + lhld curbcba! xchg! lhld rootbcba + mov m,e! inx h! mov m,d! xchg! ret +get$bcb4: + ; BCB matched arecord + lhld curbcba! lxi d,5! dad d + ; Does bcb(5) = phy$off? + lda phy$off! cmp m! jz get$bcb5 ; yes + ; Does bcb(5) + 1 = phy$off? + inr m! cmp m! jz get$bcb5 ; yes + call set$bcb$seq +get$bcb5: + ; Is bcb at head of list? + lhld curbcba! xchg! lhld rootbcba + mov a,m! inx h! mov l,m! mov h,a + call subdh! ora l! xchg! rz ; yes + jmp get$bcb3 ; no - insert bcb at head of list + +last$bcb$links$de: + lhld lastbcba! lxi b,13! dad b + mov m,e! inx h! mov m,d! ret + +get$next$bcba: + lxi b,13! dad b! mov e,m! inx h! mov d,m + xchg! mov a,h! ora l! ret + +set$bcb$seq: + lda phy$off! mov m,a! ora a! rz + lda phy$msk! inr a! mov m,a! ret + +endif + +if not MPM +if not BANKED + +patch$1dfd: ;[JCE] DRI Patch 7 + lda chksiz+1 + ral + jc get$dir$ext + mvi a,0ffh + sta patch$1e24 + jmp get$dir$ext + +patch$1e0c: + cpi 3 + jnz compare + lda patch$1e24 + inr a + jnz compare + pop h + jmp deblock25 + +patch$1e1c: + xra a + sta patch$1e24 + lhld curbcba + ret + +patch$1e24: + db 0 + +patch$1e25: + lxi h,0 + shld conbuffadd + shld ccp$conbuff + dcx h + dcx h + ret + +patch$1e31: ;Patch 13 + call check$write + lxi h,xdcnt + ret + +patch$1e38: + call reselectx + jmp check$write + +patch$1e3e: + call setfwf + jmp search$namlen + + ds 41 ;[JCE] Was 112 before patching +last: + org base + (((last-base)+255) and 0ff00h) - 112 + +olog: dw 0 +rlog: dw 0 + +patch$flgs: db 0,0,0,6 ;Patchlevel + dw base+6 + xra a! ret + +; System Control Block + +SCB: + +; Expansion Area - 6 bytes + +hashl: db 0 +hash: dw 0,0 +version: db 31h + +; Utilities Section - 8 bytes + +util$flgs: dw 0,0 +dspl$flgs: dw 0 + dw 0 + +; CLP Section - 4 bytes + +clp$flgs: dw 0 +clp$errcde: dw 0 + +; CCP Section - 8 bytes + +ccp$comlen: db 0 +ccp$curdrv: db 0 +ccp$curusr: db 0 +ccp$conbuff: dw 0 +ccp$flgs: dw 0 + db 0 + +; Device I/O Section - 32 bytes + +conwidth: db 0 +column: db 0 +conpage: db 0 +conline: db 0 +conbuffadd: dw 0 +conbufflen: dw 0 +conin$rflg: dw 0 +conout$rflg: dw 0 +auxin$rflg: dw 0 +auxout$rflg: dw 0 +lstout$rflg: dw 0 +page$mode: db 0 +pm$default: db 0 +ctlh$act: db 0 +rubout$act: db 0 +type$ahead: db 0 +contran: dw 0 +conmode: dw 0 + db 0 + db 0 +outdelim: db '$' +listcp db 0 +qflag: db 0 + +; BDOS Section - 42 bytes + +scbadd: dw scb +dmaad: dw 0080h +olddsk: db 0 +info: dw 0 +resel: db 0 +relog: db 0 +fx: db 0 +usrcode: db 0 +dcnt: dw 0 +searcha: dw 0 +searchl: db 0 +multcnt: db 1 +errormode: db 0 +searchchain: db 0,0ffh,0ffh,0ffh +temp$drive: db 0 +errdrv: db 0 + dw 0 +media$flag: db 0 + dw 0 +bdos$flags: db 0 +stamp: db 0ffh,0ffh,0ffh,0ffh,0ffh +commonbase: dw 0 +error: jmp error$sub +bdosadd: dw base+6 + +endif +endif + +; ************************ +; Directory Hashing Module +; ************************ + +; Hash format +; xxsuuuuu xxxxxxxx xxxxxxxx ssssssss +; x = hash code of fcb name field +; u = low 5 bits of fcb user field +; 1st bit is on for XFCB's +; s = shiftr(mod || ext,extshf) + +if not BANKED + +hashorg: + org base+(((hashorg-base)+255) and 0ff00h) +endif + +init$hash: + ; de = .hash table entry + ; hl = .dir fcb + push h! push d! call get$hash + ; Move computed hash to hash table entry + pop h! lxi d,hash! lxi b,4 + +if BANKED + lda hash$tbla+2! call move$out +else + call movef +endif + + ; Save next hash table entry address + shld arecord1 + ; Restore dir fcb address + pop h! ret + +set$hash: + ; Return if searchl = 0 + ora a! rz + ; Is searchl < 12 ? + cpi 12! jc set$hash2 ; yes - hashl = 0 + ; Is searchl = 12 ? + mvi a,2! jz set$hash1 ; yes - hashl = 2 + mvi a,3 ; hashl = 3 +set$hash1: + sta hashl + xchg + ; Is dir hashing invoked for drive? + call test$hash! rz ; no + xchg + lda fx + cpi 16! jz get$hash ; bdos fx = 16 + cpi 35! jz set$hash15 + cpi 20! jnc get$hash ; bdos fx = 20 or above +set$hash15: + mvi a,2! sta hashl ; bdos fx = 15,17,18,19, or 35 + ; if fcb wild then hashl = 0, hash = fcb(0) + ; else hashl = 2, hash = get$hash + push h! call chk$wild! pop h! jnz get$hash +set$hash2: + xra a! sta hashl + ; jmp get$hash + +get$hash: + ; hash(0) = fcb(0) + mov a,m! sta hash! inx h! xchg + ; Don't compute hash for dir lbl & sfcb's + lxi h,0! ani 20h! jnz get$hash6 + ; b = 11, c = 8, ahl = 0 + ; Compute fcb name hash (000000xx xxxxxxxxx xxxxxxxx) (ahl) + lxi b,0b08h +get$hash1: + ; Don't shift if fcb(8) + dcr c! push b! jz get$hash3 + ; Don't shift if fcb(6) + dcr c! dcr c! jz get$hash3 + ; ahl = ahl * 2 + dad h! adc a! push a! mov a,b + ; is b odd? + rar! jc get$hash4 ; yes + ; ahl = ahl * 2 for even fcb(i) + pop a! dad h! adc a +get$hash3: + push a +get$hash4: + ; a = fcb(i) & 7fh - 20h divided by 2 if even + ldax d! ani 7fh! sui 20h! rar! jnc get$hash5 + ral +get$hash5: + ; ahl = ahl + a + mov c,a! mvi b,0 + pop a! dad b! aci 0! pop b + ; advance to next fcb char + inx d! dcr b! jnz get$hash1 +get$hash6: + ; ahl = 000000xx xxxxxxxx xxxxxxxx + ; Store low 2 bytes of hash + shld hash+1! lxi h,hash + ; hash(0) = hash(0) (000uuuuu) | xx000000 + ani 3! rrc! rrc! ora m! mov m,a + ; Does fcb(0) = e5h, 20h, or 21h? + ani 20h! jnz get$hash9 ; yes + ; bc = 00000mmm mmmeeeee, m = module #, e = extent + ldax d! ani 1fh! mov c,a! inx d! inx d + ldax d! ani 3fh! rrc! rrc! rrc! mov d,a + ani 7! mov b,a! mov a,d! ani 0e0h! ora c! mov c,a + ; shift bc right by # of bits in extmsk + lda extmsk +get$hash7: + rar! jnc get$hash8 + push a + mov a,b! rar! mov b,a + mov a,c! rar! mov c,a + pop a! jmp get$hash7 +get$hash8: + ; hash(0) = hash(0) (xx0uuuuu) | 00s00000 + mov a,b! ani 1! rrc! rrc +get$hash9: + rrc! ora m! mov m,a + ; hash(3) = ssssssss + lxi d,3! dad d! mov m,c! ret + +test$hash: + lhld hash$tbla! mov a,l! ora h! inr a! ret + +search$hash: + ; Does hash table exist for drive? + call test$hash! rz ; no + ; Has dir hash search been disabled? + lda hashl! inr a! rz ; yes + ; Is searchl = 0? + lda searchl! ora a! rz ; yes + ; hashmx = cdrmaxa if searchl ~= 1 + ; dir$max if searchl = 1 + lhld cdrmaxa! mov e,m! inx h! mov d,m + xchg! dcr a! jnz search$h0 + lhld dir$max +search$h0: + shld hashmx + +if BANKED + ; call search$hash in resbdos, a = bank, hl = hash tbl addr + lda hash$tbla+2! lhld hash$tbla! call srch$hash + ; Was search successful? + jnz search$h1 ; no + ; Is directory read required? + lda rd$dir$flag! ora a! mvi c,0 + cnz r$dir2 ; yes if Z flag reset + ; Is function = 18? + lda fx! sui 18! rz ; Never reset dcnt for fx 18 + ; Was media change detected by above read? + lda hashl! inr a! cz setenddir ; yes + xra a! ret ; search$hash successful +search$h1: + ; Was search initiated from beginning of directory? + call end$of$dir! rnz ; no + ; Is bdos fx = 15,17,19,22,23,30? + call tst$log$fxs! rnz ; no + ; Disable hash & return successful + mvi a,0ffh! sta hashl + lhld cdrmaxa! mov e,m! inx h! mov d,m! xchg + dcx h! call set$dcnt$dblk1! xra a! ret +else + lhld hash$tbla! mov b,h! mov c,l + lhld hashmx! xchg + ; Return with Z flag set if dcnt = hashmx + lhld dcnt! push h! call subdh! pop d! ora l! rz + ; Push hashmx - dcnt (# of hashtbl entries to search) + ; Push dcnt + 1 + push h! inx d! xchg! push h + ; Compute .hash$tbl(dcnt) + dcx h! dad h! dad h! dad b +search$h1: + ; Advance hl to address of next hash$tbl entry + lxi d,4! dad d! lxi d,hash + ; Do hash u fields match? + ldax d! xra m! ani 1fh! jnz search$h3 ; no + ; Do hash's match? + call search$h6! jz search$h4 ; yes +search$h2: + xchg! pop h +search$h25: + ; de = .hash$tbl(dcnt), hl = dcnt + ; dcnt = dcnt + 1 + inx h! xthl + ; hl = # of hash$tbl entries to search + ; decrement & test for zero + ; Restore stack & hl to .hashtbl(dcnt) + dcx h! mov a,l! ora h! xthl! push h + ; Are we done? + xchg! jnz search$h1 ; no - keep searching + ; Search unsuccessful + pop h! pop h + ; Was search initiated from beginning of directory? + call end$of$dir! rnz ; no + ; Is fx = 15,17,19,22,23,30 & drive removeable? + call tst$log$fxs! rnz ; no + ; Disable hash & return successful + mvi a,0ffh! sta hashl + lhld cdrmaxa! mov e,m! inx h! mov d,m! xchg + dcx h! call set$dcnt$dblk1! xra a! ret + +search$h3: + ; Does xdcnt+1 = 0ffh? + lda xdcnt+1! inr a! jz search$h5 ; yes + ; Does xdcnt+1 = 0feh? + inr a! jnz search$h2 ; no - continue searching + ; Do hash's match? + call search$h6! jnz search$h2 ; no + ; xdcnt+1 = 0feh + ; Open user 0 search + ; Does hash u field = 0? + mov a,m! ani 1fh! jnz search$h2 ; no + ; Search successful +search$h4: + ; Successful search + ; Set dcnt to search$hash dcnt-1 + ; dcnt gets incremented by read$dir + ; Also discard search$hash loop count + lhld dcnt! xchg + pop h! dcx h! shld dcnt! pop b + ; Does dcnt&3 = 3? + mov a,l! ani 03h! cpi 03h! rz ; yes + ; Does old dcnt & new dcnt reside in same sector? + mov a,e! ani 0fch! mov e,a + mov a,l! ani 0fch! mov l,a + call subdh! ora l! rz ; yes + ; Read directory record + call read$dir2 + ; Has media change been detected? + lda hashl! inr a! cz setenddir ; dcnt = -1 if hashl = 0ffh + xra a! ret +search$h5: + ; xdcnt+1 = 0ffh + ; Make search to save dcnt of empty fcb + ; Is hash$tbl entry empty? + mov a,m! cpi 0f5h! jnz search$h2 ; no +search$h55: + ; xdcnt = dcnt + xchg! pop h! shld xdcnt! jmp search$h25 +search$h6: + ; hash compare routine + ; Is hashl = 0? + lda hashl! ora a! rz ; yes - hash compare successful + ; b = 0f0h if hashl = 3 + ; 0d0h if hashl = 2 + mov c,a! rrc! rrc! rrc! ori 1001$0000b! mov b,a + ; hash s field must be screened out of hash(0) + ; if hashl = 2 + ; Do hash(0) fields match? + ldax d! xra m! ana b! rnz ; no + ; Compare remainder of hash fields for hashl bytes + push h! inx h! inx d! call compare + pop h! ret +endif + +fix$hash: + call test$hash! rz + lxi h,save$hash! lxi d,hash! lxi b,4 + push h! push d! push b! call movef + lhld hash$tbla! push h + call get$dptra! call get$hash + lhld dcnt! dad h! dad h + pop d! dad d + pop b! pop d! push d! push b + +if BANKED + lda hash$tbla+2! call move$out +else + call movef +endif + + pop b! pop h! pop d! jmp movef + +if not MPM +if BANKED + +patch$1dfd: ;[JCE] DRI Patch 7 + lda chksiz+1 + ral + jc get$dir$ext + mvi a,0ffh + sta patch$1e24 + jmp get$dir$ext + +patch$1e0c: + cpi 3 + jnz compare + lda patch$1e24 + inr a + jnz compare + pop h + jmp deblock25 + +patch$1e1c: + xra a + sta patch$1e24 + lhld curbcba + ret + +patch$1e24: + db 0 + +patch$1e25: + lxi h,0 + shld conbuffadd + shld ccp$conbuff + dcx h + dcx h + ret + +patch$2d30: + shld rootbcba + sui 3 + sta patch$2d39 + ret + +patch$2d39: + db 0 + +patch$2d3a: + call patch$2d43 + jmp flush4 + +patch$2d40: + call copy$alv +patch$2d43: + lhld dtabcba + mov a,l + ana h + inr a + rz +patch$2d4a: + mov e,m + inx h + mov d,m + mov a,d + ora e + rz + lxi h,adrive + ldax d + cmp m + jnz patch$2d63 + lxi h,4 + dad d + mvi a,0ffh + cmp m + jnz patch$2d63 + stax d +patch$2d63: + lxi h,0dh + dad d + jmp patch$2d4a + +patch$2d6a: + call copy$alv + lhld lsn$add + mov a,m + ora a + rnz + mvi m,2 + ret + +patch$1e31: + call check$write + lxi h,xdcnt + ret + +patch$1e38: + call reselectx + jmp check$write + +patch$1e3e: + call setfwf + jmp search$namlen + +last: + + org (((last-base)+255) and 0ff00h) - 1 + db 0 + +endif ;BANKED + +else ;not MPM + + ds 192 +last: + org (((last-base)+255) and 0ff00h) - 192 + + ; bnkbdos patch area + + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0 + +free$root: dw $-$ +open$root: dw 0 +lock$root: dw 0 +lock$max: db 0 +open$max: db 0 + +; BIOS access table + +bios equ $ ; base of the bios jump table +bootf equ bios ; cold boot function +wbootf equ bootf+3 ; warm boot function +constf equ wbootf+3 ; console status function +coninf equ constf+3 ; console input function +conoutf equ coninf+3 ; console output function +listf equ conoutf+3 ; list output function +punchf equ listf+3 ; punch output function +readerf equ punchf+3 ; reader input function +homef equ readerf+3 ; disk home function +seldskf equ homef+3 ; select disk function +settrkf equ seldskf+3 ; set track function +setsecf equ settrkf+3 ; set sector function +setdmaf equ setsecf+3 ; set dma function +readf equ setdmaf+3 ; read disk function +writef equ readf+3 ; write disk function +liststf equ writef+3 ; list status function +sectran equ liststf+3 ; sector translate + +endif + + end diff --git a/software/CPM/cpm3/cpmbdos1.asm b/software/CPM/cpm3/cpmbdos1.asm new file mode 100644 index 0000000..13692bd --- /dev/null +++ b/software/CPM/cpm3/cpmbdos1.asm @@ -0,0 +1,711 @@ + title 'CP/M BDOS Interface, BDOS, Version 3.0 Dec, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** I n t e r f a c e M o d u l e ** +;** ** +;***************************************************************** +;***************************************************************** +; +; Copyright (c) 1978, 1979, 1980, 1981, 1982 +; Digital Research +; Box 579, Pacific Grove +; California +; +; December 1982 +; +on equ 0ffffh +off equ 00000h +MPM equ off +BANKED equ off + +; +; equates for non graphic characters +; + +ctla equ 01h ; control a +ctlb equ 02h ; control b +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlf equ 06h ; control f +ctlg equ 07h ; control g +ctlh equ 08h ; backspace +ctlk equ 0bh ; control k +ctlp equ 10h ; prnt toggle +ctlq equ 11h ; start screen +ctlr equ 12h ; repeat line +ctls equ 13h ; stop screen +ctlu equ 15h ; line delete +ctlw equ 17h ; control w +ctlx equ 18h ; =ctl-u +ctlz equ 1ah ; end of file +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow + + org 0000h +base equ $ + +; Base page definitions + +bnkbdos$pg equ base+0fc00h +resbdos$pg equ base+0fd00h +scb$pg equ base+0fb00h +bios$pg equ base+0ff00h + +; Bios equates + +bios equ bios$pg +bootf equ bios$pg ; 00. cold boot function + +if BANKED + +wbootf equ scb$pg+68h ; 01. warm boot function +constf equ scb$pg+6eh ; 02. console status function +coninf equ scb$pg+74h ; 03. console input function +conoutf equ scb$pg+7ah ; 04. console output function +listf equ scb$pg+80h ; 05. list output function + +else + +wbootf equ bios$pg+3 ; 01. warm boot function +constf equ bios$pg+6 ; 02. console status function +coninf equ bios$pg+9 ; 03. console input function +conoutf equ bios$pg+12 ; 04. console output function +listf equ bios$pg+15 ; 05. list output function + +endif + +punchf equ bios$pg+18 ; 06. punch output function +readerf equ bios$pg+21 ; 07. reader input function +homef equ bios$pg+24 ; 08. disk home function +seldskf equ bios$pg+27 ; 09. select disk function +settrkf equ bios$pg+30 ; 10. set track function +setsecf equ bios$pg+33 ; 11. set sector function +setdmaf equ bios$pg+36 ; 12. set dma function +readf equ bios$pg+39 ; 13. read disk function +writef equ bios$pg+42 ; 14. write disk function +liststf equ bios$pg+45 ; 15. list status function +sectran equ bios$pg+48 ; 16. sector translate +conoutstf equ bios$pg+51 ; 17. console output status function +auxinstf equ bios$pg+54 ; 18. aux input status function +auxoutstf equ bios$pg+57 ; 19. aux output status function +devtblf equ bios$pg+60 ; 20. retunr device table address fx +devinitf equ bios$pg+63 ; 21. initialize device function +drvtblf equ bios$pg+66 ; 22. return drive table address +multiof equ bios$pg+69 ; 23. multiple i/o function +flushf equ bios$pg+72 ; 24. flush function +movef equ bios$pg+75 ; 25. memory move function +timef equ bios$pg+78 ; 26. system get/set time function +selmemf equ bios$pg+81 ; 27. select memory function +setbnkf equ bios$pg+84 ; 28. set dma bank function +xmovef equ bios$pg+87 ; 29. extended move function + +if BANKED + +; System Control Block equates + +olog equ scb$pg+090h +rlog equ scb$pg+092h + +SCB equ scb$pg+09ch + +; Expansion Area - 6 bytes + +hashl equ scb$pg+09ch +hash equ scb$pg+09dh +version equ scb$pg+0a1h + +; Utilities Section - 8 bytes + +util$flgs equ scb$pg+0a2h +dspl$flgs equ scb$pg+0a6h + +; CLP Section - 4 bytes + +clp$flgs equ scb$pg+0aah +clp$errcde equ scb$pg+0ach + +; CCP Section - 8 bytes + +ccp$comlen equ scb$pg+0aeh +ccp$curdrv equ scb$pg+0afh +ccp$curusr equ scb$pg+0b0h +ccp$conbuff equ scb$pg+0b1h +ccp$flgs equ scb$pg+0b3h + +; Device I/O Section - 32 bytes + +conwidth equ scb$pg+0b6h +column equ scb$pg+0b7h +conpage equ scb$pg+0b8h +conline equ scb$pg+0b9h +conbuffadd equ scb$pg+0bah +conbufflen equ scb$pg+0bch +conin$rflg equ scb$pg+0beh +conout$rflg equ scb$pg+0c0h +auxin$rflg equ scb$pg+0c2h +auxout$rflg equ scb$pg+0c4h +lstout$rflg equ scb$pg+0c6h +page$mode equ scb$pg+0c8h +pm$default equ scb$pg+0c9h +ctlh$act equ scb$pg+0cah +rubout$act equ scb$pg+0cbh +type$ahead equ scb$pg+0cch +contran equ scb$pg+0cdh +conmode equ scb$pg+0cfh +outdelim equ scb$pg+0d3h +listcp equ scb$pg+0d4h +qflag equ scb$pg+0d5h + +; BDOS Section - 42 bytes + +scbadd equ scb$pg+0d6h +dmaad equ scb$pg+0d8h +olddsk equ scb$pg+0dah +info equ scb$pg+0dbh +resel equ scb$pg+0ddh +relog equ scb$pg+0deh +fx equ scb$pg+0dfh +usrcode equ scb$pg+0e0h +dcnt equ scb$pg+0e1h +;searcha equ scb$pg+0e3h +searchl equ scb$pg+0e5h +multcnt equ scb$pg+0e6h +errormode equ scb$pg+0e7h +searchchain equ scb$pg+0e8h +temp$drive equ scb$pg+0ech +errdrv equ scb$pg+0edh +media$flag equ scb$pg+0f0h +bdos$flags equ scb$pg+0f3h +stamp equ scb$pg+0f4h +commonbase equ scb$pg+0f9h +error equ scb$pg+0fbh ;jmp error$sub +bdosadd equ scb$pg+0feh + +; Resbdos equates + +resbdos equ resbdos$pg +move$out equ resbdos$pg+9 ; a=bank #, hl=dest, de=srce +move$tpa equ resbdos$pg+0ch ; a=bank #, hl=dest, de=srce +srch$hash equ resbdos$pg+0fh ; a=bank #, hl=hash table addr +hashmx equ resbdos$pg+12h ; max hash search dcnt +rd$dir$flag equ resbdos$pg+14h ; directory read flag +make$xfcb equ resbdos$pg+15h ; make function flag +find$xfcb equ resbdos$pg+16h ; search function flag +xdcnt equ resbdos$pg+17h ; dcnt save for empty fcb, + ; user 0 fcb, or xfcb +xdmaad equ resbdos$pg+19h ; resbdos dma copy area addr +curdma equ resbdos$pg+1bh ; current dma +copy$cr$only equ resbdos$pg+1dh ; dont restore fcb flag +user$info equ resbdos$pg+1eh ; user fcb address +kbchar equ resbdos$pg+20h ; conbdos look ahead char +qconinx equ resbdos$pg+21h ; qconin mov a,m routine + +ELSE + +move$out equ movef +move$tpa equ movef + +ENDIF + +; +serial: db '654321' +; +; Enter here from the user's program with function number in c, +; and information address in d,e +; + +bdose: ; Arrive here from user programs + xchg! shld info! xchg ; info=de, de=info + + mov a,c! sta fx! cpi 14! jc bdose2 + lxi h,0! shld dircnt ; dircnt,multnum = 0 + lda olddsk! sta seldsk ; Set seldsk + +if BANKED + dcr a! sta copy$cr$init +ENDIF + + ; If mult$cnt ~= 1 then read or write commands + ; are handled by the shell + lda mult$cnt! dcr a! jz bdose2 + lxi h,mult$fxs +bdose1: + mov a,m! ora a! jz bdose2 + cmp c! jz shell + inx h! jmp bdose1 +bdose2: + mov a,e! sta linfo ; linfo = low(info) - don't equ + lxi h,0! shld aret ; Return value defaults to 0000 + shld resel ; resel,relog = 0 + ; Save user's stack pointer, set to local stack + dad sp! shld entsp ; entsp = stackptr + +if not BANKED + lxi sp,lstack ; local stack setup +ENDIF + + lxi h,goback ; Return here after all functions + push h ; jmp goback equivalent to ret + mov a,c! cpi nfuncs! jnc high$fxs ; Skip if invalid # + mov c,e ; possible output character to c + lxi h,functab! jmp bdos$jmp + ; look for functions 98 -> +high$fxs: + cpi 128! jnc test$152 + sui 98! jc lret$eq$ff ; Skip if function < 98 + cpi nfuncs2! jnc lret$eq$ff + lxi h,functab2 +bdos$jmp: + mov e,a! mvi d,0 ; de=func, hl=.ciotab + dad d! dad d! mov e,m! inx h! mov d,m ; de=functab(func) + lhld info ; info in de for later xchg + xchg! pchl ; dispatched + +; CAUTION: In banked systems only, +; error$sub is referenced indirectly by the SCB ERROR +; field in RESBDOS as (0fc7ch). This value is converted +; to the actual address of error$sub by GENSYS. If the offset +; of error$sub is changed, the SCB ERROR value must also +; be changed. + +; +; error subroutine +; + +error$sub: + mvi b,0! push b! dcr c + lxi h,errtbl! dad b! dad b + mov e,m! inx h! mov d,m! xchg + call errflg + pop b! lda error$mode! ora a! rnz + jmp reboote + +mult$fxs: db 20,21,33,34,40,0 + + maclib makedate +if BANKED + @LCOPY + @BDATE +else + @SCOPY + @BDATE + + ; 31 level stack + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h +lstack: + +endif + +; dispatch table for functions + +functab: + dw rebootx1, func1, func2, func3 + dw punchf, listf, func6, func7 + dw func8, func9, func10, func11 +diskf equ ($-functab)/2 ; disk funcs + dw func12,func13,func14,func15 + dw func16,func17,func18,func19 + dw func20,func21,func22,func23 + dw func24,func25,func26,func27 + dw func28,func29,func30,func31 + dw func32,func33,func34,func35 + dw func36,func37,func38,func39 + dw func40,lret$eq$ff,func42,func43 + dw func44,func45,func46,func47 + dw func48,func49,func50 +nfuncs equ ($-functab)/2 + +functab2: + dw func98,func99 + dw func100,func101,func102,func103 + dw func104,func105,func106,func107 + dw func108,func109,func110,func111 + dw func112 + +nfuncs2 equ ($-functab2)/2 + +errtbl: + dw permsg + dw rodmsg + dw rofmsg + dw selmsg + dw 0 + dw 0 + dw passmsg + dw fxstsmsg + dw wildmsg + +test$152: + cpi 152! rnz + +; +; PARSE version 3.0b Oct 08 1982 - Doug Huskey +; +; + ; DE->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks (left justified) + ; 9-11 => type, converted to upper case, + ; padded with blanks (left justified) + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 24-25 => 0000h + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if DE locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; + lxi h,sthl$ret + push h + lhld info + mov e,m ;get first parameter + inx h + mov d,m + push d ;save .filename + inx h + mov e,m ;get second parameter + inx h + mov d,m + pop h ;DE=.fcb HL=.filename + xchg +parse0: + push h ;save .fcb + xra a + mov m,a ;clear drive byte + inx h + lxi b,20h*256+11 + call pad ;pad name and type w/ blanks + lxi b,4 + call pad ;EXT, S1, S2, RC = 0 + lxi b,20h*256+8 + call pad ;pad password field w/ blanks + lxi b,12 + call pad ;zero 2nd 1/2 of map, cr, r0 - r2 +; +; skip spaces +; + call skps +; +; check for drive +; + ldax d + cpi ':' ;is this a drive? + dcx d + pop h + push h ;HL = .fcb + jnz parse$name +; +; Parse the drive-spec +; +parsedrv: + call delim + jz parse$ok + sui 'A' + jc perror1 + cpi 16 + jnc perror1 + inx d + inx d ;past the ':' + inr a ;set drive relative to 1 + mov m,a ;store the drive in FCB(0) +; +; Parse the file-name +; +parse$name: + inx h ;HL = .fcb(1) + call delim + jz parse$ok + lxi b,7*256 + +parse6: ldax d ;get a character + cpi '.' ;file-type next? + jz parse$type ;branch to file-type processing + cpi ';' + jz parse$pw + call gfc ;process one character + jnz parse6 ;loop if not end of name + jmp parse$ok +; +; Parse the file-type +; +parse$type: + inx d ;advance past dot + pop h + push h ;HL =.fcb + lxi b,9 + dad b ;HL =.fcb(9) + lxi b,2*256 + +parse8: ldax d + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse8 ;loop if not end of type +; +parse$ok: + pop b + push d + call skps ;skip trailing blanks and tabs + dcx d + call delim ;is next nonblank char a delim? + pop h + rnz ;no + lxi h,0 + ora a + rz ;return zero if delim = 0 + cpi cr + rz ;return zero if delim = cr + xchg + ret +; +; handle parser error +; +perror: + pop b ;throw away return addr +perror1: + pop b + lxi h,0ffffh + ret +; +; Parse the password +; +parsepw: + inx d + pop h + push h + lxi b,16 + dad b + lxi b,7*256+1 +parsepw1: + call gfc + jnz parsepw1 + mvi a,7 + sub b + pop h + push h + lxi b,26 + dad b + mov m,a + ldax d ;delimiter in A + jmp parse$ok +; +; get next character of name, type or password +; +gfc: call delim ;check for end of filename + rz ;return if so + cpi ' ' ;check for control characters + inx d + jc perror ;error if control characters encountered + inr b ;error if too big for field + dcr b + jm perror + inr c + dcr c + jnz gfc1 + cpi '*' ;trap "match rest of field" character + jz setmatch +gfc1: mov m,a ;put character in fcb + inx h + dcr b ;decrement field size counter + ora a ;clear zero flag + ret +;; +setmatch: + mvi m,'?' ;set match one character + inx h + dcr b + jp setmatch + ret +; +; check for delimiter +; +; entry: A = character +; exit: z = set if char is a delimiter +; +delimiters: db cr,tab,' .,:;[]=<>|',0 + +delim: ldax d ;get character + push h + lxi h,delimiters +delim1: cmp m ;is char in table + jz delim2 + inr m + dcr m ;end of table? (0) + inx h + jnz delim1 + ora a ;reset zero flag +delim2: pop h + rz + ; + ; not a delimiter, convert to upper case + ; + cpi 'a' + rc + cpi 'z'+1 + jnc delim3 + ani 05fh +delim3: ani 07fh + ret ;return with zero set if so +; +; pad with blanks or zeros +; +pad: mov m,b + inx h + dcr c + jnz pad + ret +; +; skip blanks and tabs +; +skps: ldax d + inx d + cpi ' ' ;skip spaces & tabs + jz skps + cpi tab + jz skps + ret +; +; end of PARSE +; + +errflg: + ; report error to console, message address in hl + push h! call crlf ; stack mssg address, new line + lda adrive! adi 'A'! sta dskerr ; current disk name + lxi b,dskmsg + +if BANKED + call zprint ; the error message +else + call print +endif + + pop b + +if BANKED + lda bdos$flags! ral! jnc zprint + call zprint ; error message tail + lda fx! mvi b,30h + lxi h,pr$fx1 + cpi 100! jc errflg1 + mvi m,31h! inx h! sui 100 +errflg1: + sui 10! jc errflg2 + inr b! jmp errflg1 +errflg2: + mov m,b! inx h! adi 3ah! mov m,a + inx h! mvi m,20h + lxi h,pr$fcb! mvi m,0 + lda resel! ora a! jz errflg3 + mvi m,20h! push d + lhld info! inx h! xchg! lxi h,pr$fcb1 + mvi c,8! call move! mvi m,'.'! inx h + mvi c,3! call move! pop d +errflg3: + call crlf + lxi b,pr$fx! jmp zprint + +zprint: + ldax b! ora a! rz + push b! mov c,a + call tabout + pop b! inx b! jmp zprint + +pr$fx: db 'BDOS Function = ' +pr$fx1: db ' ' +pr$fcb: db ' File = ' +pr$fcb1:ds 12 + db 0 + +else + jmp print +endif + +reboote: + lxi h,0fffdh! jmp rebootx0 ; BDOS error +rebootx: +;;; lxi h,0fffeh ; CTL-C error + call patch$1e25 ;[JCE] DRI patch 13 +rebootx0: + shld clp$errcde +rebootx1: + jmp wbootf + +entsp: ds 2 ; entry stack pointer + +shell: + lxi h,0! dad sp! shld shell$sp + +if not BANKED + lxi sp,shell$stk +endif + + lxi h,shell$rtn! push h + call save$rr! call save$dma + lda mult$cnt +mult$io: + push a! sta mult$num! call cbdos + ora a! jnz shell$err + lda fx! cpi 33! cnc incr$rr + call adv$dma + pop a! dcr a! jnz mult$io + mov h,a! mov l,a! ret + +shell$sp: dw 0 + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + +shell$stk: ; shell has 5 level stack +hold$dma: dw 0 + +cbdos: + lda fx! mov c,a +cbdos1: + lhld info! xchg! jmp bdose2 + +adv$dma: + lhld dmaad! lxi d,80h! dad d! jmp reset$dma1 + +save$dma: + lhld dmaad! shld hold$dma! ret + +reset$dma: + lhld hold$dma +reset$dma1: + shld dmaad! jmp setdma + +shell$err: + pop b! inr a! rz + lda mult$cnt! sub b! mov h,a! ret + +shell$rtn: + push h! lda fx! cpi 33! cnc reset$rr + call reset$dma + pop d! lhld shell$sp! sphl! xchg + mov a,l! mov b,h! ret + + page + + diff --git a/software/CPM/cpm3/cpmbdos2.asm b/software/CPM/cpm3/cpmbdos2.asm new file mode 100644 index 0000000..8451c08 --- /dev/null +++ b/software/CPM/cpm3/cpmbdos2.asm @@ -0,0 +1,712 @@ + title 'CP/M BDOS Interface, BDOS, Version 3.0 Dec, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** I n t e r f a c e M o d u l e ** +;** ** +;***************************************************************** +;***************************************************************** +; +; Copyright (c) 1978, 1979, 1980, 1981, 1982 +; Digital Research +; Box 579, Pacific Grove +; California +; +; December 1982 +; +on equ 0ffffh +off equ 00000h +MPM equ off +BANKED equ on + +; +; equates for non graphic characters +; + +ctla equ 01h ; control a +ctlb equ 02h ; control b +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlf equ 06h ; control f +ctlg equ 07h ; control g +ctlh equ 08h ; backspace +ctlk equ 0bh ; control k +ctlp equ 10h ; prnt toggle +ctlq equ 11h ; start screen +ctlr equ 12h ; repeat line +ctls equ 13h ; stop screen +ctlu equ 15h ; line delete +ctlw equ 17h ; control w +ctlx equ 18h ; =ctl-u +ctlz equ 1ah ; end of file +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow + + org 0000h +base equ $ + +; Base page definitions + +bnkbdos$pg equ base+0fc00h +resbdos$pg equ base+0fd00h +scb$pg equ base+0fb00h +bios$pg equ base+0ff00h + +; Bios equates + +bios equ bios$pg +bootf equ bios$pg ; 00. cold boot function + +if BANKED + +wbootf equ scb$pg+68h ; 01. warm boot function +constf equ scb$pg+6eh ; 02. console status function +coninf equ scb$pg+74h ; 03. console input function +conoutf equ scb$pg+7ah ; 04. console output function +listf equ scb$pg+80h ; 05. list output function + +else + +wbootf equ bios$pg+3 ; 01. warm boot function +constf equ bios$pg+6 ; 02. console status function +coninf equ bios$pg+9 ; 03. console input function +conoutf equ bios$pg+12 ; 04. console output function +listf equ bios$pg+15 ; 05. list output function + +endif + +punchf equ bios$pg+18 ; 06. punch output function +readerf equ bios$pg+21 ; 07. reader input function +homef equ bios$pg+24 ; 08. disk home function +seldskf equ bios$pg+27 ; 09. select disk function +settrkf equ bios$pg+30 ; 10. set track function +setsecf equ bios$pg+33 ; 11. set sector function +setdmaf equ bios$pg+36 ; 12. set dma function +readf equ bios$pg+39 ; 13. read disk function +writef equ bios$pg+42 ; 14. write disk function +liststf equ bios$pg+45 ; 15. list status function +sectran equ bios$pg+48 ; 16. sector translate +conoutstf equ bios$pg+51 ; 17. console output status function +auxinstf equ bios$pg+54 ; 18. aux input status function +auxoutstf equ bios$pg+57 ; 19. aux output status function +devtblf equ bios$pg+60 ; 20. retunr device table address fx +devinitf equ bios$pg+63 ; 21. initialize device function +drvtblf equ bios$pg+66 ; 22. return drive table address +multiof equ bios$pg+69 ; 23. multiple i/o function +flushf equ bios$pg+72 ; 24. flush function +movef equ bios$pg+75 ; 25. memory move function +timef equ bios$pg+78 ; 26. system get/set time function +selmemf equ bios$pg+81 ; 27. select memory function +setbnkf equ bios$pg+84 ; 28. set dma bank function +xmovef equ bios$pg+87 ; 29. extended move function + +if BANKED + +; System Control Block equates + +olog equ scb$pg+090h +rlog equ scb$pg+092h + +SCB equ scb$pg+09ch + +; Expansion Area - 6 bytes + +hashl equ scb$pg+09ch +hash equ scb$pg+09dh +version equ scb$pg+0a1h + +; Utilities Section - 8 bytes + +util$flgs equ scb$pg+0a2h +dspl$flgs equ scb$pg+0a6h + +; CLP Section - 4 bytes + +clp$flgs equ scb$pg+0aah +clp$errcde equ scb$pg+0ach + +; CCP Section - 8 bytes + +ccp$comlen equ scb$pg+0aeh +ccp$curdrv equ scb$pg+0afh +ccp$curusr equ scb$pg+0b0h +ccp$conbuff equ scb$pg+0b1h +ccp$flgs equ scb$pg+0b3h + +; Device I/O Section - 32 bytes + +conwidth equ scb$pg+0b6h +column equ scb$pg+0b7h +conpage equ scb$pg+0b8h +conline equ scb$pg+0b9h +conbuffadd equ scb$pg+0bah +conbufflen equ scb$pg+0bch +conin$rflg equ scb$pg+0beh +conout$rflg equ scb$pg+0c0h +auxin$rflg equ scb$pg+0c2h +auxout$rflg equ scb$pg+0c4h +lstout$rflg equ scb$pg+0c6h +page$mode equ scb$pg+0c8h +pm$default equ scb$pg+0c9h +ctlh$act equ scb$pg+0cah +rubout$act equ scb$pg+0cbh +type$ahead equ scb$pg+0cch +contran equ scb$pg+0cdh +conmode equ scb$pg+0cfh +outdelim equ scb$pg+0d3h +listcp equ scb$pg+0d4h +qflag equ scb$pg+0d5h + +; BDOS Section - 42 bytes + +scbadd equ scb$pg+0d6h +dmaad equ scb$pg+0d8h +olddsk equ scb$pg+0dah +info equ scb$pg+0dbh +resel equ scb$pg+0ddh +relog equ scb$pg+0deh +fx equ scb$pg+0dfh +usrcode equ scb$pg+0e0h +dcnt equ scb$pg+0e1h +;searcha equ scb$pg+0e3h +searchl equ scb$pg+0e5h +multcnt equ scb$pg+0e6h +errormode equ scb$pg+0e7h +searchchain equ scb$pg+0e8h +temp$drive equ scb$pg+0ech +errdrv equ scb$pg+0edh +media$flag equ scb$pg+0f0h +bdos$flags equ scb$pg+0f3h +stamp equ scb$pg+0f4h +commonbase equ scb$pg+0f9h +error equ scb$pg+0fbh ;jmp error$sub +bdosadd equ scb$pg+0feh + +; Resbdos equates + +resbdos equ resbdos$pg +move$out equ resbdos$pg+9 ; a=bank #, hl=dest, de=srce +move$tpa equ resbdos$pg+0ch ; a=bank #, hl=dest, de=srce +srch$hash equ resbdos$pg+0fh ; a=bank #, hl=hash table addr +hashmx equ resbdos$pg+12h ; max hash search dcnt +rd$dir$flag equ resbdos$pg+14h ; directory read flag +make$xfcb equ resbdos$pg+15h ; make function flag +find$xfcb equ resbdos$pg+16h ; search function flag +xdcnt equ resbdos$pg+17h ; dcnt save for empty fcb, + ; user 0 fcb, or xfcb +xdmaad equ resbdos$pg+19h ; resbdos dma copy area addr +curdma equ resbdos$pg+1bh ; current dma +copy$cr$only equ resbdos$pg+1dh ; dont restore fcb flag +user$info equ resbdos$pg+1eh ; user fcb address +kbchar equ resbdos$pg+20h ; conbdos look ahead char +qconinx equ resbdos$pg+21h ; qconin mov a,m routine + +ELSE + +move$out equ movef +move$tpa equ movef + +ENDIF + +; +serial: db '654321' +; +; Enter here from the user's program with function number in c, +; and information address in d,e +; + +bdose: ; Arrive here from user programs + xchg! shld info! xchg ; info=de, de=info + + mov a,c! sta fx! cpi 14! jc bdose2 + lxi h,0! shld dircnt ; dircnt,multnum = 0 + lda olddsk! sta seldsk ; Set seldsk + +if BANKED + dcr a! sta copy$cr$init +ENDIF + + ; If mult$cnt ~= 1 then read or write commands + ; are handled by the shell + lda mult$cnt! dcr a! jz bdose2 + lxi h,mult$fxs +bdose1: + mov a,m! ora a! jz bdose2 + cmp c! jz shell + inx h! jmp bdose1 +bdose2: + mov a,e! sta linfo ; linfo = low(info) - don't equ + lxi h,0! shld aret ; Return value defaults to 0000 + shld resel ; resel,relog = 0 + ; Save user's stack pointer, set to local stack + dad sp! shld entsp ; entsp = stackptr + +if not BANKED + lxi sp,lstack ; local stack setup +ENDIF + + lxi h,goback ; Return here after all functions + push h ; jmp goback equivalent to ret + mov a,c! cpi nfuncs! jnc high$fxs ; Skip if invalid # + mov c,e ; possible output character to c + lxi h,functab! jmp bdos$jmp + ; look for functions 98 -> +high$fxs: + cpi 128! jnc test$152 + sui 98! jc lret$eq$ff ; Skip if function < 98 + cpi nfuncs2! jnc lret$eq$ff + lxi h,functab2 +bdos$jmp: + mov e,a! mvi d,0 ; de=func, hl=.ciotab + dad d! dad d! mov e,m! inx h! mov d,m ; de=functab(func) + lhld info ; info in de for later xchg + xchg! pchl ; dispatched + +; CAUTION: In banked systems only, +; error$sub is referenced indirectly by the SCB ERROR +; field in RESBDOS as (0fc7ch). This value is converted +; to the actual address of error$sub by GENSYS. If the offset +; of error$sub is changed, the SCB ERROR value must also +; be changed. + +; +; error subroutine +; + +error$sub: + mvi b,0! push b! dcr c + lxi h,errtbl! dad b! dad b + mov e,m! inx h! mov d,m! xchg + call errflg + pop b! lda error$mode! ora a! rnz + jmp reboote + +mult$fxs: db 20,21,33,34,40,0 + + maclib makedate +if BANKED + @LCOPY + @BDATE + ds 5 +else + @SCOPY + @BDATE + + ; 31 level stack + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h +lstack: + +endif + +; dispatch table for functions + +functab: + dw rebootx1, func1, func2, func3 + dw punchf, listf, func6, func7 + dw func8, func9, func10, func11 +diskf equ ($-functab)/2 ; disk funcs + dw func12,func13,func14,func15 + dw func16,func17,func18,func19 + dw func20,func21,func22,func23 + dw func24,func25,func26,func27 + dw func28,func29,func30,func31 + dw func32,func33,func34,func35 + dw func36,func37,func38,func39 + dw func40,lret$eq$ff,func42,func43 + dw func44,func45,func46,func47 + dw func48,func49,func50 +nfuncs equ ($-functab)/2 + +functab2: + dw func98,func99 + dw func100,func101,func102,func103 + dw func104,func105,func106,func107 + dw func108,func109,func110,func111 + dw func112 + +nfuncs2 equ ($-functab2)/2 + +errtbl: + dw permsg + dw rodmsg + dw rofmsg + dw selmsg + dw 0 + dw 0 + dw passmsg + dw fxstsmsg + dw wildmsg + +test$152: + cpi 152! rnz + +; +; PARSE version 3.0b Oct 08 1982 - Doug Huskey +; +; + ; DE->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks (left justified) + ; 9-11 => type, converted to upper case, + ; padded with blanks (left justified) + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 24-25 => 0000h + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if DE locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; + lxi h,sthl$ret + push h + lhld info + mov e,m ;get first parameter + inx h + mov d,m + push d ;save .filename + inx h + mov e,m ;get second parameter + inx h + mov d,m + pop h ;DE=.fcb HL=.filename + xchg +parse0: + push h ;save .fcb + xra a + mov m,a ;clear drive byte + inx h + lxi b,20h*256+11 + call pad ;pad name and type w/ blanks + lxi b,4 + call pad ;EXT, S1, S2, RC = 0 + lxi b,20h*256+8 + call pad ;pad password field w/ blanks + lxi b,12 + call pad ;zero 2nd 1/2 of map, cr, r0 - r2 +; +; skip spaces +; + call skps +; +; check for drive +; + ldax d + cpi ':' ;is this a drive? + dcx d + pop h + push h ;HL = .fcb + jnz parse$name +; +; Parse the drive-spec +; +parsedrv: + call delim + jz parse$ok + sui 'A' + jc perror1 + cpi 16 + jnc perror1 + inx d + inx d ;past the ':' + inr a ;set drive relative to 1 + mov m,a ;store the drive in FCB(0) +; +; Parse the file-name +; +parse$name: + inx h ;HL = .fcb(1) + call delim + jz parse$ok + lxi b,7*256 + +parse6: ldax d ;get a character + cpi '.' ;file-type next? + jz parse$type ;branch to file-type processing + cpi ';' + jz parse$pw + call gfc ;process one character + jnz parse6 ;loop if not end of name + jmp parse$ok +; +; Parse the file-type +; +parse$type: + inx d ;advance past dot + pop h + push h ;HL =.fcb + lxi b,9 + dad b ;HL =.fcb(9) + lxi b,2*256 + +parse8: ldax d + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse8 ;loop if not end of type +; +parse$ok: + pop b + push d + call skps ;skip trailing blanks and tabs + dcx d + call delim ;is next nonblank char a delim? + pop h + rnz ;no + lxi h,0 + ora a + rz ;return zero if delim = 0 + cpi cr + rz ;return zero if delim = cr + xchg + ret +; +; handle parser error +; +perror: + pop b ;throw away return addr +perror1: + pop b + lxi h,0ffffh + ret +; +; Parse the password +; +parsepw: + inx d + pop h + push h + lxi b,16 + dad b + lxi b,7*256+1 +parsepw1: + call gfc + jnz parsepw1 + mvi a,7 + sub b + pop h + push h + lxi b,26 + dad b + mov m,a + ldax d ;delimiter in A + jmp parse$ok +; +; get next character of name, type or password +; +gfc: call delim ;check for end of filename + rz ;return if so + cpi ' ' ;check for control characters + inx d + jc perror ;error if control characters encountered + inr b ;error if too big for field + dcr b + jm perror + inr c + dcr c + jnz gfc1 + cpi '*' ;trap "match rest of field" character + jz setmatch +gfc1: mov m,a ;put character in fcb + inx h + dcr b ;decrement field size counter + ora a ;clear zero flag + ret +;; +setmatch: + mvi m,'?' ;set match one character + inx h + dcr b + jp setmatch + ret +; +; check for delimiter +; +; entry: A = character +; exit: z = set if char is a delimiter +; +delimiters: db cr,tab,' .,:;[]=<>|',0 + +delim: ldax d ;get character + push h + lxi h,delimiters +delim1: cmp m ;is char in table + jz delim2 + inr m + dcr m ;end of table? (0) + inx h + jnz delim1 + ora a ;reset zero flag +delim2: pop h + rz + ; + ; not a delimiter, convert to upper case + ; + cpi 'a' + rc + cpi 'z'+1 + jnc delim3 + ani 05fh +delim3: ani 07fh + ret ;return with zero set if so +; +; pad with blanks or zeros +; +pad: mov m,b + inx h + dcr c + jnz pad + ret +; +; skip blanks and tabs +; +skps: ldax d + inx d + cpi ' ' ;skip spaces & tabs + jz skps + cpi tab + jz skps + ret +; +; end of PARSE +; + +errflg: + ; report error to console, message address in hl + push h! call crlf ; stack mssg address, new line + lda adrive! adi 'A'! sta dskerr ; current disk name + lxi b,dskmsg + +if BANKED + call zprint ; the error message +else + call print +endif + + pop b + +if BANKED + lda bdos$flags! ral! jnc zprint + call zprint ; error message tail + lda fx! mvi b,30h + lxi h,pr$fx1 + cpi 100! jc errflg1 + mvi m,31h! inx h! sui 100 +errflg1: + sui 10! jc errflg2 + inr b! jmp errflg1 +errflg2: + mov m,b! inx h! adi 3ah! mov m,a + inx h! mvi m,20h + lxi h,pr$fcb! mvi m,0 + lda resel! ora a! jz errflg3 + mvi m,20h! push d + lhld info! inx h! xchg! lxi h,pr$fcb1 + mvi c,8! call move! mvi m,'.'! inx h + mvi c,3! call move! pop d +errflg3: + call crlf + lxi b,pr$fx! jmp zprint + +zprint: + ldax b! ora a! rz + push b! mov c,a + call tabout + pop b! inx b! jmp zprint + +pr$fx: db 'BDOS Function = ' +pr$fx1: db ' ' +pr$fcb: db ' File = ' +pr$fcb1:ds 12 + db 0 + +else + jmp print +endif + +reboote: + lxi h,0fffdh! jmp rebootx0 ; BDOS error +rebootx: +;;; lxi h,0fffeh ; CTL-C error + call patch$1e25 ;[JCE] DRI Patch 13 +rebootx0: + shld clp$errcde +rebootx1: + jmp wbootf + +entsp: ds 2 ; entry stack pointer + +shell: + lxi h,0! dad sp! shld shell$sp + +if not BANKED + lxi sp,shell$stk +endif + + lxi h,shell$rtn! push h + call save$rr! call save$dma + lda mult$cnt +mult$io: + push a! sta mult$num! call cbdos + ora a! jnz shell$err + lda fx! cpi 33! cnc incr$rr + call adv$dma + pop a! dcr a! jnz mult$io + mov h,a! mov l,a! ret + +shell$sp: dw 0 + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + +shell$stk: ; shell has 5 level stack +hold$dma: dw 0 + +cbdos: + lda fx! mov c,a +cbdos1: + lhld info! xchg! jmp bdose2 + +adv$dma: + lhld dmaad! lxi d,80h! dad d! jmp reset$dma1 + +save$dma: + lhld dmaad! shld hold$dma! ret + +reset$dma: + lhld hold$dma +reset$dma1: + shld dmaad! jmp setdma + +shell$err: + pop b! inr a! rz + lda mult$cnt! sub b! mov h,a! ret + +shell$rtn: + push h! lda fx! cpi 33! cnc reset$rr + call reset$dma + pop d! lhld shell$sp! sphl! xchg + mov a,l! mov b,h! ret + + page + + diff --git a/software/CPM/cpm3/cpmbdosx.asm b/software/CPM/cpm3/cpmbdosx.asm new file mode 100644 index 0000000..9e64392 --- /dev/null +++ b/software/CPM/cpm3/cpmbdosx.asm @@ -0,0 +1,7899 @@ + title 'CP/M BDOS Interface, BDOS, Version 3.0 Dec, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** I n t e r f a c e M o d u l e ** +;** ** +;***************************************************************** +;***************************************************************** +; +; Copyright (c) 1978, 1979, 1980, 1981, 1982 +; Digital Research +; Box 579, Pacific Grove +; California +; +; December 1982 +; +on equ 0ffffh +off equ 00000h +MPM equ off +BANKED equ off + +; +; equates for non graphic characters +; + +ctla equ 01h ; control a +ctlb equ 02h ; control b +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlf equ 06h ; control f +ctlg equ 07h ; control g +ctlh equ 08h ; backspace +ctlk equ 0bh ; control k +ctlp equ 10h ; prnt toggle +ctlq equ 11h ; start screen +ctlr equ 12h ; repeat line +ctls equ 13h ; stop screen +ctlu equ 15h ; line delete +ctlw equ 17h ; control w +ctlx equ 18h ; =ctl-u +ctlz equ 1ah ; end of file +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow + + org 0000h +base equ $ + +; Base page definitions + +bnkbdos$pg equ base+0fc00h +resbdos$pg equ base+0fd00h +scb$pg equ base+0fb00h +bios$pg equ base+0ff00h + +; Bios equates + +bios equ bios$pg +bootf equ bios$pg ; 00. cold boot function + +if BANKED + +wbootf equ scb$pg+68h ; 01. warm boot function +constf equ scb$pg+6eh ; 02. console status function +coninf equ scb$pg+74h ; 03. console input function +conoutf equ scb$pg+7ah ; 04. console output function +listf equ scb$pg+80h ; 05. list output function + +else + +wbootf equ bios$pg+3 ; 01. warm boot function +constf equ bios$pg+6 ; 02. console status function +coninf equ bios$pg+9 ; 03. console input function +conoutf equ bios$pg+12 ; 04. console output function +listf equ bios$pg+15 ; 05. list output function + +endif + +punchf equ bios$pg+18 ; 06. punch output function +readerf equ bios$pg+21 ; 07. reader input function +homef equ bios$pg+24 ; 08. disk home function +seldskf equ bios$pg+27 ; 09. select disk function +settrkf equ bios$pg+30 ; 10. set track function +setsecf equ bios$pg+33 ; 11. set sector function +setdmaf equ bios$pg+36 ; 12. set dma function +readf equ bios$pg+39 ; 13. read disk function +writef equ bios$pg+42 ; 14. write disk function +liststf equ bios$pg+45 ; 15. list status function +sectran equ bios$pg+48 ; 16. sector translate +conoutstf equ bios$pg+51 ; 17. console output status function +auxinstf equ bios$pg+54 ; 18. aux input status function +auxoutstf equ bios$pg+57 ; 19. aux output status function +devtblf equ bios$pg+60 ; 20. retunr device table address fx +devinitf equ bios$pg+63 ; 21. initialize device function +drvtblf equ bios$pg+66 ; 22. return drive table address +multiof equ bios$pg+69 ; 23. multiple i/o function +flushf equ bios$pg+72 ; 24. flush function +movef equ bios$pg+75 ; 25. memory move function +timef equ bios$pg+78 ; 26. system get/set time function +selmemf equ bios$pg+81 ; 27. select memory function +setbnkf equ bios$pg+84 ; 28. set dma bank function +xmovef equ bios$pg+87 ; 29. extended move function + +if BANKED + +; System Control Block equates + +olog equ scb$pg+090h +rlog equ scb$pg+092h + +SCB equ scb$pg+09ch + +; Expansion Area - 6 bytes + +hashl equ scb$pg+09ch +hash equ scb$pg+09dh +version equ scb$pg+0a1h + +; Utilities Section - 8 bytes + +util$flgs equ scb$pg+0a2h +dspl$flgs equ scb$pg+0a6h + +; CLP Section - 4 bytes + +clp$flgs equ scb$pg+0aah +clp$errcde equ scb$pg+0ach + +; CCP Section - 8 bytes + +ccp$comlen equ scb$pg+0aeh +ccp$curdrv equ scb$pg+0afh +ccp$curusr equ scb$pg+0b0h +ccp$conbuff equ scb$pg+0b1h +ccp$flgs equ scb$pg+0b3h + +; Device I/O Section - 32 bytes + +conwidth equ scb$pg+0b6h +column equ scb$pg+0b7h +conpage equ scb$pg+0b8h +conline equ scb$pg+0b9h +conbuffadd equ scb$pg+0bah +conbufflen equ scb$pg+0bch +conin$rflg equ scb$pg+0beh +conout$rflg equ scb$pg+0c0h +auxin$rflg equ scb$pg+0c2h +auxout$rflg equ scb$pg+0c4h +lstout$rflg equ scb$pg+0c6h +page$mode equ scb$pg+0c8h +pm$default equ scb$pg+0c9h +ctlh$act equ scb$pg+0cah +rubout$act equ scb$pg+0cbh +type$ahead equ scb$pg+0cch +contran equ scb$pg+0cdh +conmode equ scb$pg+0cfh +outdelim equ scb$pg+0d3h +listcp equ scb$pg+0d4h +qflag equ scb$pg+0d5h + +; BDOS Section - 42 bytes + +scbadd equ scb$pg+0d6h +dmaad equ scb$pg+0d8h +olddsk equ scb$pg+0dah +info equ scb$pg+0dbh +resel equ scb$pg+0ddh +relog equ scb$pg+0deh +fx equ scb$pg+0dfh +usrcode equ scb$pg+0e0h +dcnt equ scb$pg+0e1h +;searcha equ scb$pg+0e3h +searchl equ scb$pg+0e5h +multcnt equ scb$pg+0e6h +errormode equ scb$pg+0e7h +searchchain equ scb$pg+0e8h +temp$drive equ scb$pg+0ech +errdrv equ scb$pg+0edh +media$flag equ scb$pg+0f0h +bdos$flags equ scb$pg+0f3h +stamp equ scb$pg+0f4h +commonbase equ scb$pg+0f9h +error equ scb$pg+0fbh ;jmp error$sub +bdosadd equ scb$pg+0feh + +; Resbdos equates + +resbdos equ resbdos$pg +move$out equ resbdos$pg+9 ; a=bank #, hl=dest, de=srce +move$tpa equ resbdos$pg+0ch ; a=bank #, hl=dest, de=srce +srch$hash equ resbdos$pg+0fh ; a=bank #, hl=hash table addr +hashmx equ resbdos$pg+12h ; max hash search dcnt +rd$dir$flag equ resbdos$pg+14h ; directory read flag +make$xfcb equ resbdos$pg+15h ; make function flag +find$xfcb equ resbdos$pg+16h ; search function flag +xdcnt equ resbdos$pg+17h ; dcnt save for empty fcb, + ; user 0 fcb, or xfcb +xdmaad equ resbdos$pg+19h ; resbdos dma copy area addr +curdma equ resbdos$pg+1bh ; current dma +copy$cr$only equ resbdos$pg+1dh ; dont restore fcb flag +user$info equ resbdos$pg+1eh ; user fcb address +kbchar equ resbdos$pg+20h ; conbdos look ahead char +qconinx equ resbdos$pg+21h ; qconin mov a,m routine + +ELSE + +move$out equ movef +move$tpa equ movef + +ENDIF + +; +serial: db '654321' +; +; Enter here from the user's program with function number in c, +; and information address in d,e +; + +bdose: ; Arrive here from user programs + xchg! shld info! xchg ; info=de, de=info + + mov a,c! sta fx! cpi 14! jc bdose2 + lxi h,0! shld dircnt ; dircnt,multnum = 0 + lda olddsk! sta seldsk ; Set seldsk + +if BANKED + dcr a! sta copy$cr$init +ENDIF + + ; If mult$cnt ~= 1 then read or write commands + ; are handled by the shell + lda mult$cnt! dcr a! jz bdose2 + lxi h,mult$fxs +bdose1: + mov a,m! ora a! jz bdose2 + cmp c! jz shell + inx h! jmp bdose1 +bdose2: + mov a,e! sta linfo ; linfo = low(info) - don't equ + lxi h,0! shld aret ; Return value defaults to 0000 + shld resel ; resel,relog = 0 + ; Save user's stack pointer, set to local stack + dad sp! shld entsp ; entsp = stackptr + +if not BANKED + lxi sp,lstack ; local stack setup +ENDIF + + lxi h,goback ; Return here after all functions + push h ; jmp goback equivalent to ret + mov a,c! cpi nfuncs! jnc high$fxs ; Skip if invalid # + mov c,e ; possible output character to c + lxi h,functab! jmp bdos$jmp + ; look for functions 98 -> +high$fxs: + cpi 128! jnc test$152 + sui 98! jc lret$eq$ff ; Skip if function < 98 + cpi nfuncs2! jnc lret$eq$ff + lxi h,functab2 +bdos$jmp: + mov e,a! mvi d,0 ; de=func, hl=.ciotab + dad d! dad d! mov e,m! inx h! mov d,m ; de=functab(func) + lhld info ; info in de for later xchg + xchg! pchl ; dispatched + +; CAUTION: In banked systems only, +; error$sub is referenced indirectly by the SCB ERROR +; field in RESBDOS as (0fc7ch). This value is converted +; to the actual address of error$sub by GENSYS. If the offset +; of error$sub is changed, the SCB ERROR value must also +; be changed. + +; +; error subroutine +; + +error$sub: + mvi b,0! push b! dcr c + lxi h,errtbl! dad b! dad b + mov e,m! inx h! mov d,m! xchg + call errflg + pop b! lda error$mode! ora a! rnz + jmp reboote + +mult$fxs: db 20,21,33,34,40,0 + + maclib makedate +if BANKED + @LCOPY + @BDATE +else + @SCOPY + @BDATE + + ; 31 level stack + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h +lstack: + +endif + +; dispatch table for functions + +functab: + dw rebootx1, func1, func2, func3 + dw punchf, listf, func6, func7 + dw func8, func9, func10, func11 +diskf equ ($-functab)/2 ; disk funcs + dw func12,func13,func14,func15 + dw func16,func17,func18,func19 + dw func20,func21,func22,func23 + dw func24,func25,func26,func27 + dw func28,func29,func30,func31 + dw func32,func33,func34,func35 + dw func36,func37,func38,func39 + dw func40,lret$eq$ff,func42,func43 + dw func44,func45,func46,func47 + dw func48,func49,func50 +nfuncs equ ($-functab)/2 + +functab2: + dw func98,func99 + dw func100,func101,func102,func103 + dw func104,func105,func106,func107 + dw func108,func109,func110,func111 + dw func112 + +nfuncs2 equ ($-functab2)/2 + +errtbl: + dw permsg + dw rodmsg + dw rofmsg + dw selmsg + dw 0 + dw 0 + dw passmsg + dw fxstsmsg + dw wildmsg + +test$152: + cpi 152! rnz + +; +; PARSE version 3.0b Oct 08 1982 - Doug Huskey +; +; + ; DE->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks (left justified) + ; 9-11 => type, converted to upper case, + ; padded with blanks (left justified) + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 24-25 => 0000h + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if DE locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; + lxi h,sthl$ret + push h + lhld info + mov e,m ;get first parameter + inx h + mov d,m + push d ;save .filename + inx h + mov e,m ;get second parameter + inx h + mov d,m + pop h ;DE=.fcb HL=.filename + xchg +parse0: + push h ;save .fcb + xra a + mov m,a ;clear drive byte + inx h + lxi b,20h*256+11 + call pad ;pad name and type w/ blanks + lxi b,4 + call pad ;EXT, S1, S2, RC = 0 + lxi b,20h*256+8 + call pad ;pad password field w/ blanks + lxi b,12 + call pad ;zero 2nd 1/2 of map, cr, r0 - r2 +; +; skip spaces +; + call skps +; +; check for drive +; + ldax d + cpi ':' ;is this a drive? + dcx d + pop h + push h ;HL = .fcb + jnz parse$name +; +; Parse the drive-spec +; +parsedrv: + call delim + jz parse$ok + sui 'A' + jc perror1 + cpi 16 + jnc perror1 + inx d + inx d ;past the ':' + inr a ;set drive relative to 1 + mov m,a ;store the drive in FCB(0) +; +; Parse the file-name +; +parse$name: + inx h ;HL = .fcb(1) + call delim + jz parse$ok + lxi b,7*256 + +parse6: ldax d ;get a character + cpi '.' ;file-type next? + jz parse$type ;branch to file-type processing + cpi ';' + jz parse$pw + call gfc ;process one character + jnz parse6 ;loop if not end of name + jmp parse$ok +; +; Parse the file-type +; +parse$type: + inx d ;advance past dot + pop h + push h ;HL =.fcb + lxi b,9 + dad b ;HL =.fcb(9) + lxi b,2*256 + +parse8: ldax d + cpi ';' + jz parsepw + call gfc ;process one character + jnz parse8 ;loop if not end of type +; +parse$ok: + pop b + push d + call skps ;skip trailing blanks and tabs + dcx d + call delim ;is next nonblank char a delim? + pop h + rnz ;no + lxi h,0 + ora a + rz ;return zero if delim = 0 + cpi cr + rz ;return zero if delim = cr + xchg + ret +; +; handle parser error +; +perror: + pop b ;throw away return addr +perror1: + pop b + lxi h,0ffffh + ret +; +; Parse the password +; +parsepw: + inx d + pop h + push h + lxi b,16 + dad b + lxi b,7*256+1 +parsepw1: + call gfc + jnz parsepw1 + mvi a,7 + sub b + pop h + push h + lxi b,26 + dad b + mov m,a + ldax d ;delimiter in A + jmp parse$ok +; +; get next character of name, type or password +; +gfc: call delim ;check for end of filename + rz ;return if so + cpi ' ' ;check for control characters + inx d + jc perror ;error if control characters encountered + inr b ;error if too big for field + dcr b + jm perror + inr c + dcr c + jnz gfc1 + cpi '*' ;trap "match rest of field" character + jz setmatch +gfc1: mov m,a ;put character in fcb + inx h + dcr b ;decrement field size counter + ora a ;clear zero flag + ret +;; +setmatch: + mvi m,'?' ;set match one character + inx h + dcr b + jp setmatch + ret +; +; check for delimiter +; +; entry: A = character +; exit: z = set if char is a delimiter +; +delimiters: db cr,tab,' .,:;[]=<>|',0 + +delim: ldax d ;get character + push h + lxi h,delimiters +delim1: cmp m ;is char in table + jz delim2 + inr m + dcr m ;end of table? (0) + inx h + jnz delim1 + ora a ;reset zero flag +delim2: pop h + rz + ; + ; not a delimiter, convert to upper case + ; + cpi 'a' + rc + cpi 'z'+1 + jnc delim3 + ani 05fh +delim3: ani 07fh + ret ;return with zero set if so +; +; pad with blanks or zeros +; +pad: mov m,b + inx h + dcr c + jnz pad + ret +; +; skip blanks and tabs +; +skps: ldax d + inx d + cpi ' ' ;skip spaces & tabs + jz skps + cpi tab + jz skps + ret +; +; end of PARSE +; + +errflg: + ; report error to console, message address in hl + push h! call crlf ; stack mssg address, new line + lda adrive! adi 'A'! sta dskerr ; current disk name + lxi b,dskmsg + +if BANKED + call zprint ; the error message +else + call print +endif + + pop b + +if BANKED + lda bdos$flags! ral! jnc zprint + call zprint ; error message tail + lda fx! mvi b,30h + lxi h,pr$fx1 + cpi 100! jc errflg1 + mvi m,31h! inx h! sui 100 +errflg1: + sui 10! jc errflg2 + inr b! jmp errflg1 +errflg2: + mov m,b! inx h! adi 3ah! mov m,a + inx h! mvi m,20h + lxi h,pr$fcb! mvi m,0 + lda resel! ora a! jz errflg3 + mvi m,20h! push d + lhld info! inx h! xchg! lxi h,pr$fcb1 + mvi c,8! call move! mvi m,'.'! inx h + mvi c,3! call move! pop d +errflg3: + call crlf + lxi b,pr$fx! jmp zprint + +zprint: + ldax b! ora a! rz + push b! mov c,a + call tabout + pop b! inx b! jmp zprint + +pr$fx: db 'BDOS Function = ' +pr$fx1: db ' ' +pr$fcb: db ' File = ' +pr$fcb1:ds 12 + db 0 + +else + jmp print +endif + +reboote: + lxi h,0fffdh! jmp rebootx0 ; BDOS error +rebootx: +;;; lxi h,0fffeh ; CTL-C error + call patch$1e25 ;[JCE] DRI patch 13 +rebootx0: + shld clp$errcde +rebootx1: + jmp wbootf + +entsp: ds 2 ; entry stack pointer + +shell: + lxi h,0! dad sp! shld shell$sp + +if not BANKED + lxi sp,shell$stk +endif + + lxi h,shell$rtn! push h + call save$rr! call save$dma + lda mult$cnt +mult$io: + push a! sta mult$num! call cbdos + ora a! jnz shell$err + lda fx! cpi 33! cnc incr$rr + call adv$dma + pop a! dcr a! jnz mult$io + mov h,a! mov l,a! ret + +shell$sp: dw 0 + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + +shell$stk: ; shell has 5 level stack +hold$dma: dw 0 + +cbdos: + lda fx! mov c,a +cbdos1: + lhld info! xchg! jmp bdose2 + +adv$dma: + lhld dmaad! lxi d,80h! dad d! jmp reset$dma1 + +save$dma: + lhld dmaad! shld hold$dma! ret + +reset$dma: + lhld hold$dma +reset$dma1: + shld dmaad! jmp setdma + +shell$err: + pop b! inr a! rz + lda mult$cnt! sub b! mov h,a! ret + +shell$rtn: + push h! lda fx! cpi 33! cnc reset$rr + call reset$dma + pop d! lhld shell$sp! sphl! xchg + mov a,l! mov b,h! ret + + page + + + title 'CP/M Bdos Interface, Bdos, Version 3.0 Nov, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** C o n s o l e P o r t i o n ** +;** ** +;***************************************************************** +;***************************************************************** +; +; November 1982 +; +; +; Console handlers +; +conin: + ;read console character to A + lxi h,kbchar! mov a,m! mvi m,0! ora a! rnz + ;no previous keyboard character ready + jmp coninf ;get character externally + ;ret +; +conech: + LXI H,STA$RET! PUSH H +CONECH0: + ;read character with echo + call conin! call echoc! JC CONECH1 ;echo character? + ;character must be echoed before return + push psw! mov c,a! call tabout! pop psw + RET +CONECH1: + CALL TEST$CTLS$MODE! RNZ + CPI CTLS! JNZ CONECH2 + CALL CONBRK2! JMP CONECH0 +CONECH2: + CPI CTLQ! JZ CONECH0 + CPI CTLP! JZ CONECH0 + RET +; +echoc: + ;echo character if graphic + ;cr, lf, tab, or backspace + cpi cr! rz ;carriage return? + cpi lf! rz ;line feed? + cpi tab! rz ;tab? + cpi ctlh! rz ;backspace? + cpi ' '! ret ;carry set if not graphic +; +CONSTX: + LDA KBCHAR! ORA A! JNZ CONB1 + CALL CONSTF! ANI 1! RET +; +if BANKED + +SET$CTLS$MODE: + ;SET CTLS STATUS OR INPUT FLAG FOR QUEUE MANAGER + LXI H,QFLAG! MVI M,40H! XTHL! PCHL + +endif +; +TEST$CTLS$MODE: + ;RETURN WITH Z FLAG RESET IF CTL-S CTL-Q CHECKING DISABLED + MOV B,A! LDA CONMODE! ANI 2! MOV A,B! RET +; +conbrk: ;check for character ready + CALL TEST$CTLS$MODE! JNZ CONSTX + lda kbchar! ora a! jnz CONBRK1 ;skip if active kbchar + ;no active kbchar, check external break + ;DOES BIOS HAVE TYPE AHEAD? +if BANKED + LDA TYPE$AHEAD! INR A! JZ CONSTX ;YES +endif + ;CONBRKX CALLED BY CONOUT + + CONBRKX: + ;HAS CTL-S INTERCEPT BEEN DISABLED? + CALL TEST$CTLS$MODE! RNZ ;YES + ;DOES KBCHAR CONTAIN CTL-S? + LDA KBCHAR! CPI CTLS! JZ CONBRK1 ;YES +if BANKED + CALL SET$CTLS$MODE +endif + ;IS A CHARACTER READY FOR INPUT? + call constf +if BANKED + POP H! MVI M,0 +endif + ani 1! rz ;NO + ;character ready, read it +if BANKED + CALL SET$CTLS$MODE +endif + call coninf +if BANKED + POP H! MVI M,0 +endif + CONBRK1: + cpi ctls! jnz conb0 ;check stop screen function + ;DOES KBCHAR CONTAIN A CTL-S? + LXI H,KBCHAR! CMP M! JNZ CONBRK2 ;NO + MVI M,0 ; KBCHAR = 0 + ;found ctls, read next character + CONBRK2: + +if BANKED + CALL SET$CTLS$MODE +endif + call coninf ;to A +if BANKED + POP H! MVI M,0 +endif + cpi ctlc! JNZ CONBRK3 + LDA CONMODE! ANI 08H! JZ REBOOTX + XRA A + CONBRK3: + SUI CTLQ! RZ ; RETURN WITH A = ZERO IF CTLQ + INR A! CALL CONB3! JMP CONBRK2 + conb0: + LXI H,KBCHAR + + MOV B,A + ;IS CONMODE(1) TRUE? + LDA CONMODE! RAR! JNC $+7 ;NO + ;DOES KBCHAR = CTLC? + MVI A,CTLC! CMP M! RZ ;YES - RETURN + MOV A,B + + CPI CTLQ! JZ CONB2 + CPI CTLP! JZ CONB2 + ;character in accum, save it + MOV M,A + conb1: + ;return with true set in accumulator + mvi a,1! ret + CONB2: + XRA A! MOV M,A! RET + CONB3: + CZ TOGGLE$LISTCP + MVI C,7! CNZ CONOUTF + RET +; +TOGGLE$LISTCP: + ; IS PRINTER ECHO DISABLED? + LDA CONMODE! ANI 14H! JNZ TOGGLE$L1 ;YES + LXI H,LISTCP! MVI A,1! XRA M! ANI 1 + MOV M,A! RET +TOGGLE$L1: + XRA A! RET +; +QCONOUTF: + ;DOES FX = INPUT? + LDA FX! DCR A! JZ CONOUTF ;YES + ;IS ESCAPE SEQUENCE DECODING IN EFFECT? + MOV A,B +;;; ANI 8 ;[JCE] DRI Patch 13 + ANI 10h + JNZ SCONOUTF ;YES + JMP CONOUTF +; +conout: + ;compute character position/write console char from C + ;compcol = true if computing column position + lda compcol! ora a! jnz compout + ;write the character, then compute the column + ;write console character from C + ;B ~= 0 -> ESCAPE SEQUENCE DECODING + LDA CONMODE! ANI 14H! MOV B,A + push b + ;CALL CONBRKX FOR OUTPUT FUNCTIONS ONLY + LDA FX! DCR A! CNZ CONBRKX + pop b! push b ;recall/save character + call QCONOUTF ;externally, to console + pop b + ;SKIP ECHO WHEN CONMODE & 14H ~= 0 + MOV A,B! ORA A! JNZ COMPOUT + push b ;recall/save character + ;may be copying to the list device + lda listcp! ora a! cnz listf ;to printer, if so + pop b ;recall the character + compout: + mov a,c ;recall the character + ;and compute column position + lxi h,column ;A = char, HL = .column + cpi rubout! rz ;no column change if nulls + inr m ;column = column + 1 + cpi ' '! rnc ;return if graphic + ;not graphic, reset column position + dcr m ;column = column - 1 + mov a,m! ora a! rz ;return if at zero + ;not at zero, may be backspace or end line + mov a,c ;character back to A + cpi ctlh! jnz notbacksp + ;backspace character + dcr m ;column = column - 1 + ret + notbacksp: + ;not a backspace character, eol? + cpi cr! rnz ;return if not + ;end of line, column = 0 + mvi m,0 ;column = 0 + ret +; +ctlout: + ;send C character with possible preceding up-arrow + mov a,c! call echoc ;cy if not graphic (or special case) + jnc tabout ;skip if graphic, tab, cr, lf, or ctlh + ;send preceding up arrow + push psw! mvi c,ctl! call conout ;up arrow + pop psw! ori 40h ;becomes graphic letter + mov c,a ;ready to print +if BANKED + call chk$column! rz +endif + ;(drop through to tabout) +; +tabout: + ;IS FX AN INPUT FUNCTION? + LDA FX! DCR A! JZ TABOUT1 ;YES - ALWAYS EXPAND TABS FOR ECHO + ;HAS TAB EXPANSION BEEN DISABLED OR + ;ESCAPE SEQUENCE DECODING BEEN ENABLED? + LDA CONMODE! ANI 14H! JNZ CONOUT ;YES +TABOUT1: + ;expand tabs to console + mov a,c! cpi tab! jnz conout ;direct to conout if not + ;tab encountered, move to next tab position + tab0: + +if BANKED + lda fx! cpi 1! jnz tab1 + call chk$column! rz + tab1: +endif + + mvi c,' '! call conout ;another blank + lda column! ani 111b ;column mod 8 = 0 ? + jnz tab0 ;back for another if not + ret +; +; +backup: + ;back-up one screen position + call pctlh + +if BANKED + lda comchr! cpi ctla! rz +endif + + mvi c,' '! call conoutf +; (drop through to pctlh) ; +pctlh: + ;send ctlh to console without affecting column count + mvi c,ctlh! jmp conoutf + ;ret +; +crlfp: + ;print #, cr, lf for ctlx, ctlu, ctlr functions + ;then move to strtcol (starting column) + mvi c,'#'! call conout + call crlf + ;column = 0, move to position strtcol + crlfp0: + lda column! lxi h,strtcol + cmp m! rnc ;stop when column reaches strtcol + mvi c,' '! call conout ;print blank + jmp crlfp0 +;; +; +crlf: + ;carriage return line feed sequence + mvi c,cr! call conout! mvi c,lf! jmp conout + ;ret +; +print: + ;print message until M(BC) = '$' + LXI H,OUTDELIM + ldax b! CMP M! rz ;stop on $ + ;more to print + inx b! push b! mov c,a ;char to C + call tabout ;another character printed + pop b! jmp print +; +QCONIN: + +if BANKED + lhld apos! mov a,m! sta ctla$sw +endif + ;IS BUFFER ADDRESS = 0? + LHLD CONBUFFADD! MOV A,L! ORA H! JZ CONIN ;YES + ;IS CHARACTER IN BUFFER < 5? + +if BANKED + call qconinx ; mov a,m with bank 1 switched in +else + MOV A,M +endif + + INX H + ORA A! JNZ QCONIN1 ; NO + LXI H,0 +QCONIN1: + SHLD CONBUFFADD! SHLD CONBUFFLEN! RNZ ; NO + JMP CONIN + +if BANKED + +chk$column: + lda conwidth! mov e,a! lda column! cmp e! ret +; +expand: + xchg! lhld apos! xchg +expand1: + ldax d! ora a! rz + inx d! inx h! mov m,a! inr b! jmp expand1 +; +copy$xbuff: + mov a,b! ora a! rz + push b! mov c,b! push h! xchg! inx d + lxi h,xbuff + call move + mvi m,0! shld xpos + pop h! pop b! ret +; +copy$cbuff: + lda ccpflgs+1! ral! rnc + lxi h,xbuff! lxi d,cbuff! inr c! jnz copy$cbuff1 + xchg! mov a,b! ora a! rz + sta cbuff$len + push d! lxi b,copy$cbuff2! push b + mov b,a +copy$cbuff1: + inr b! mov c,b! jmp move +copy$cbuff2: + pop h! dcx h! mvi m,0! ret +; +save$col: + lda column! sta save$column! ret +; +clear$right: + lda column! lxi h,ctla$column! cmp m! rnc + mvi c,20h! call conout! jmp clear$right +; +reverse: + lda save$column! lxi h,column! cmp m! rnc + mvi c,ctlh! call conout! jmp reverse +; +chk$buffer$size: + push b! push h + lhld apos! mvi e,0 +cbs1: + mov a,m! ora a! jz cbs2 + inr e! inx h! jmp cbs1 +cbs2: + mov a,b! add e! cmp c + push a! mvi c,7! cnc conoutf + pop a! pop h! pop b! rc + pop d! pop d! jmp readnx +; +refresh: + lda ctla$sw! ora a! rz + lda comchr! cpi ctla! rz + cpi ctlf! rz + cpi ctlw! rz +refresh0: + push h! push b + call save$col + lhld apos +refresh1: + mov a,m! ora a! jz refresh2 + mov c,a! call chk$column! jc refresh05 + mov a,e! sta column! jmp refresh2 +refresh05: + push h! call ctlout + pop h! inx h! jmp refresh1 +refresh2: + lda column! sta new$ctla$col +refresh3: + call clear$right + call reverse + lda new$ctla$col! sta ctla$column + pop b! pop h! ret +; +init$apos: + lxi h,aposi! shld apos + xra a! sta ctla$sw + ret +; +init$xpos: + lxi h,xbuff! shld xpos! ret +; +set$ctla$column: + lxi h,ctla$sw! mov a,m! ora a! rnz + inr m! lda column! sta ctla$column! ret +; +readi: + call chk$column! cnc crlf + lda cbuff$len! mov b,a + mvi c,0! call copy$cbuff +else + +readi: + MOV A,D! ORA E! JNZ READ + LHLD DMAAD! SHLD INFO + INX H! INX H! SHLD CONBUFFADD +endif + +read: ;read to info address (max length, current length, buffer) + +if BANKED + call init$xpos + call init$apos +readx: + call refresh + xra a! sta ctlw$sw +readx1: + +endif + + MVI A,1! STA FX + lda column! sta strtcol ;save start for ctl-x, ctl-h + lhld info! mov c,m! inx h! push h + XRA A! MOV B,A! STA SAVEPOS + CMP C! JNZ $+4 + INR C + ;B = current buffer length, + ;C = maximum buffer length, + ;HL= next to fill - 1 + readnx: + ;read next character, BC, HL active + push b! push h ;blen, cmax, HL saved + readn0: + +if BANKED + lda ctlw$sw! ora a! cz qconin +nxtline: + sta comchr +else + CALL QCONIN ;next char in A +endif + + ;ani 7fh ;mask parity bit + pop h! pop b ;reactivate counters + cpi cr! jz readen ;end of line? + cpi lf! jz readen ;also end of line + +if BANKED + cpi ctlf! jnz not$ctlf + do$ctlf: + call chk$column! dcr e! cmp e! jnc readnx + do$ctlf0: + xchg! lhld apos! mov a,m! ora a! jz ctlw$l15 + inx h! shld apos! xchg! jmp notr + not$ctlf: + cpi ctlw! jnz not$ctlw + do$ctlw: + xchg! lhld apos! mov a,m! ora a! jz ctlw$l1 + xchg! call chk$column! dcr e! cmp e! xchg! jc ctlw$l0 + xchg! call refresh0! xchg! jmp ctlw$l13 + ctlw$l0: + lhld apos! mov a,m + inx h! shld apos! jmp ctlw$l3 + ctlw$l1: + lxi h,ctla$sw! mov a,m! mvi m,0 + ora a! jz ctlw$l2 + ctlw$l13: + lxi h,ctlw$sw! mvi m,0 + ctlw$l15: + xchg! jmp readnx + ctlw$l2: + lda ctlw$sw! ora a! jnz ctlw$l25 + mov a,b! ora a! jnz ctlw$l15 + call init$xpos + ctlw$l25: + lhld xpos! mov a,m! ora a + sta ctlw$sw! jz ctlw$l15 + inx h! shld xpos + ctlw$l3: + lxi h,ctlw$sw! mvi m,ctlw + xchg! jmp notr + not$ctlw: + cpi ctla! jnz not$ctla + do$ctla: + ;do we have any characters to back over? + lda strtcol! mov d,a! lda column! cmp d + jz readnx + sta compcol ;COL > 0 + mov a,b! ora a! jz linelen + ;characters remain in buffer, backup one + dcr b ;remove one character + ;compcol > 0 marks repeat as length compute + ;backup one position in xbuff + push h + call set$ctla$column + pop d + lhld apos! dcx h + shld apos! ldax d! mov m,a! xchg! jmp linelen + not$ctla: + cpi ctlb! jnz not$ctlb + do$ctlb: + lda save$pos! cmp b! jnz ctlb$l0 + mvi a,ctlw! sta ctla$sw + sta comchr! jmp do$ctlw + ctlb$l0: + xchg! lhld apos! inr b + ctlb$l1: + dcr b! lda save$pos! cmp b! jz ctlb$l2 + dcx h! ldax d! mov m,a! dcx d! jmp ctlb$l1 + ctlb$l2: + shld apos + push b! push d + call set$ctla$column + ctlb$l3: + lda column! mov b,a + lda strtcol! cmp b! jz read$n0 + mvi c,ctlh! call conout! jmp ctlb$l3 + not$ctlb: + cpi ctlk! jnz not$ctlk + xchg! lxi h,aposi! shld apos + xchg! call refresh + jmp readnx + not$ctlk: + cpi ctlg! jnz not$ctlg + lda ctla$sw! ora a! jz readnx + jmp do$ctlf0 + not$ctlg: +endif + + cpi ctlh! jnz noth ;backspace? + LDA CTLH$ACT! INR A! JZ DO$RUBOUT + DO$CTLH: + ;do we have any characters to back over? + LDA STRTCOL! MOV D,A! LDA COLUMN! CMP D + jz readnx + STA COMPCOL ;COL > 0 + MOV A,B! ORA A! JZ $+4 + ;characters remain in buffer, backup one + dcr b ;remove one character + ;compcol > 0 marks repeat as length compute + jmp linelen ;uses same code as repeat + noth: + ;not a backspace + cpi rubout! jnz notrub ;rubout char? + LDA RUBOUT$ACT! INR A! JZ DO$CTLH + DO$RUBOUT: +if BANKED + mvi a,rubout! sta comchr + lda ctla$sw! ora a! jnz do$ctlh +endif + ;rubout encountered, rubout if possible + mov a,b! ora a! jz readnx ;skip if len=0 + ;buffer has characters, resend last char + mov a,m! dcr b! dcx h ;A = last char + ;blen=blen-1, next to fill - 1 decremented + jmp rdech1 ;act like this is an echo + notrub: + ;not a rubout character, check end line + cpi ctle! jnz note ;physical end line? + ;yes, save active counters and force eol + push b! MOV A,B! STA SAVE$POS + push h +if BANKED + lda ctla$sw! ora a! cnz clear$right +endif + call crlf +if BANKED + call refresh +endif + xra a! sta strtcol ;start position = 00 + jmp readn0 ;for another character + note: + ;not end of line, list toggle? + cpi ctlp! jnz notp ;skip if not ctlp + ;list toggle - change parity + push h ;save next to fill - 1 + PUSH B + XRA A! CALL CONB3 + POP B + pop h! jmp readnx ;for another char + notp: + ;not a ctlp, line delete? + cpi ctlx! jnz notx + pop h ;discard start position + ;loop while column > strtcol + backx: + lda strtcol! lxi h,column +if BANKED + cmp m! jc backx1 + lhld apos! mov a,m! ora a! jnz readx + jmp read + backx1: +else + cmp m! jnc read ;start again +endif + dcr m ;column = column - 1 + call backup ;one position + jmp backx + notx: + ;not a control x, control u? + ;not control-X, control-U? + cpi ctlu! jnz notu ;skip if not +if BANKED + xthl! call copy$xbuff! xthl +endif + ;delete line (ctlu) + do$ctlu: + call crlfp ;physical eol + pop h ;discard starting position + jmp read ;to start all over + notu: + ;not line delete, repeat line? + cpi ctlr! jnz notr + XRA A! STA SAVEPOS +if BANKED + xchg! call init$apos! xchg + mov a,b! ora a! jz do$ctlu + xchg! lhld apos! inr b + ctlr$l1: + dcr b! jz ctlr$l2 + dcx h! ldax d! mov m,a! dcx d + jmp ctlr$l1 + ctlr$l2: + shld apos! push b! push d + call crlfp! mvi a,ctlw! sta ctlw$sw + sta ctla$sw! jmp readn0 +endif + linelen: + ;repeat line, or compute line len (ctlh) + ;if compcol > 0 + push b! call crlfp ;save line length + pop b! pop h! push h! push b + ;bcur, cmax active, beginning buff at HL + rep0: + mov a,b! ora a! jz rep1 ;count len to 00 + inx h! mov c,m ;next to print + DCR B + POP D! PUSH D! MOV A,D! SUB B! MOV D,A + push b! push h ;count length down + LDA SAVEPOS! CMP D! CC CTLOUT + pop h! pop b ;recall remaining count + jmp rep0 ;for the next character + rep1: + ;end of repeat, recall lengths + ;original BC still remains pushed + push h ;save next to fill + lda compcol! ora a ;>0 if computing length + jz readn0 ;for another char if so + ;column position computed for ctlh + lxi h,column! sub m ;diff > 0 + sta compcol ;count down below + ;move back compcol-column spaces + backsp: + ;move back one more space + call backup ;one space + lxi h,compcol! dcr m + jnz backsp +if BANKED + call refresh +endif + jmp readn0 ;for next character + notr: + ;not a ctlr, place into buffer + ;IS BUFFER FULL? + PUSH A + MOV A,B! CMP C! JC RDECH0 ;NO + ;DISCARD CHARACTER AND RING BELL + POP A! PUSH B! PUSH H + MVI C,7! CALL CONOUTF! JMP READN0 + RDECH0: + +if BANKED + lda comchr! cpi ctlg! jz rdech05 + lda ctla$sw! ora a! cnz chk$buffer$size + rdech05: +endif + + POP A + inx h! mov m,a ;character filled to mem + inr b ;blen = blen + 1 + rdech1: + ;look for a random control character + push b! push h ;active values saved + mov c,a ;ready to print +if BANKED + call save$col +endif + call ctlout ;may be up-arrow C + pop h! pop b +if BANKED + lda comchr! cpi ctlg! jz do$ctlh + cpi rubout! jz rdech2 + call refresh + rdech2: +endif + LDA CONMODE! ANI 08H +;;; JNZ NOTC ;[JCE] DRI Patch 13 + jnz patch$064b + + mov a,m ;recall char + cpi ctlc ;set flags for reboot test +patch$064b: mov a,b ;move length to A + jnz notc ;skip if not a control c + cpi 1 ;control C, must be length 1 + jz REBOOTX ;reboot if blen = 1 + ;length not one, so skip reboot + notc: + ;not reboot, are we at end of buffer? +if BANKED + cmp c! jnc buffer$full +else + jmp readnx ;go for another if not +endif + +if BANKED + push b! push h + call chk$column! jc readn0 + lda ctla$sw! ora a! jz do$new$line + lda comchr! cpi ctlw! jz back$one + cpi ctlf! jz back$one + + do$newline: + mvi a,ctle! jmp nxtline + + back$one: + ;back up to previous character + pop h! pop b + dcr b! xchg + lhld apos! dcx h! shld apos + ldax d! mov m,a! xchg! dcx h + push b! push h! call reverse + ;disable ctlb or ctlw + xra a! sta ctlw$sw! jmp readn0 + + buffer$full: + xra a! sta ctlw$sw! jmp readnx +endif + readen: + ;end of read operation, store blen +if BANKED + call expand +endif + pop h! mov m,b ;M(current len) = B +if BANKED + push b + call copy$xbuff + pop b + mvi c,0ffh! call copy$cbuff +endif + LXI H,0! SHLD CONBUFFADD + mvi c,cr! jmp conout ;return carriage + ;ret +; +func1 equ CONECH + ;return console character with echo +; +func2: equ tabout + ;write console character with tab expansion +; +func3: + ;return reader character + call readerf + jmp sta$ret +; +;func4: equated to punchf + ;write punch character +; +;func5: equated to listf + ;write list character + ;write to list device +; +func6: + ;direct console i/o - read if 0ffh + mov a,c! inr a! jz dirinp ;0ffh => 00h, means input mode + inr a! JZ DIRSTAT ;0feh => direct STATUS function + INR A! JZ DIRINP1 ;0fdh => direct input, no status + JMP CONOUTF + DIRSTAT: + ;0feH in C for status + CALL CONSTX! JNZ LRET$EQ$FF! JMP STA$RET + dirinp: + CALL CONSTX ;status check + ora a! RZ ;skip, return 00 if not ready + ;character is ready, get it + dirinp1: + call CONIN ;to A + jmp sta$ret +; +func7: + call auxinstf + jmp sta$ret +; +func8: + call auxoutstf + jmp sta$ret +; +func9: + ;write line until $ encountered + xchg ;was lhld info + mov c,l! mov b,h ;BC=string address + jmp print ;out to console + +func10 equ readi + ;read a buffered console line + +func11: + ;IS CONMODE(1) TRUE? + LDA CONMODE! RAR! JNC NORMAL$STATUS ;NO + ;CTL-C ONLY STATUS CHECK +if BANKED + LXI H,QFLAG! MVI M,80H! PUSH H +endif + LXI H,CTLC$STAT$RET! PUSH H + ;DOES KBCHAR = CTL-C? + LDA KBCHAR! CPI CTLC! JZ CONB1 ;YES + ;IS THERE A READY CHARACTER? + CALL CONSTF! ORA A! RZ ;NO + ;IS THE READY CHARACTER A CTL-C? + CALL CONINF! CPI CTLC! JZ CONB0 ;YES + STA KBCHAR! XRA A! RET + +CTLC$STAT$RET: + +if BANKED + CALL STA$RET + POP H! MVI M,0! RET +else + JMP STA$RET +endif + +NORMAL$STATUS: + ;check console status + call conbrk + ;(drop through to sta$ret) +sta$ret: + ;store the A register to aret + sta aret +func$ret: ; + ret ;jmp goback (pop stack for non cp/m functions) +; +setlret1: + ;set lret = 1 + mvi a,1! jmp sta$ret ; +; +FUNC109: ;GET/SET CONSOLE MODE + ;DOES DE = 0FFFFH? + MOV A,D! ANA E! INR A + LHLD CONMODE! JZ STHL$RET ;YES - RETURN CONSOLE MODE + XCHG! SHLD CONMODE! RET ;NO - SET CONSOLE MODE +; +FUNC110: ;GET/SET FUNCTION 9 DELIMITER + LXI H,OUT$DELIM + ;DOES DE = 0FFFFH? + MOV A,D! ANA E! INR A + MOV A,M! JZ STA$RET ;YES - RETURN DELIMITER + MOV M,E! RET ;NO - SET DELIMITER +; +FUNC111: ;PRINT BLOCK TO CONSOLE +FUNC112: ;LIST BLOCK + XCHG! MOV E,M! INX H! MOV D,M! INX H + MOV C,M! INX H! MOV B,M! XCHG + ;HL = ADDR OF STRING + ;BC = LENGTH OF STRING +BLK$OUT: + MOV A,B! ORA C! RZ + PUSH B! PUSH H! MOV C,M + LDA FX! CPI 111! JZ BLK$OUT1 + CALL LISTF! JMP BLK$OUT2 +BLK$OUT1: + CALL TABOUT +BLK$OUT2: + POP H! INX H! POP B! DCX B + JMP BLK$OUT + +SCONOUTF EQU CONOUTF + +; +; data areas +; +compcol:db 0 ;true if computing column position +strtcol:db 0 ;starting column position after read + +if not BANKED + +kbchar: db 0 ;initial key char = 00 + +endif + +SAVEPOS:DB 0 ;POSITION IN BUFFER CORRESPONDING TO + ;BEGINNING OF LINE +if BANKED + +comchr: db 0 +cbuff$len: db 0 +cbuff: ds 256 + db 0 +xbuff: db 0 + ds 354 +aposi: db 0 +xpos: dw 0 +apos: dw 0 +ctla$sw: db 0 +ctlw$sw: db 0 +save$column: db 0 +ctla$column: db 0 +new$ctla$col: db 0 + +endif + +; end of BDOS Console module +; +;********************************************************************** +;***************************************************************** +; +; Error Messages + +if BANKED + +md equ 0 + +else + +md equ 24h + +endif + +dskmsg: db 'CP/M Error On ' +dskerr: db ' : ',md +permsg: db 'Disk I/O',md +selmsg: db 'Invalid Drive',md +rofmsg: db 'Read/Only File',md +rodmsg: db 'Read/Only Disk',md + +if not MPM + +passmsg: + +if BANKED + db 'Password Error',md +endif + +fxstsmsg: + db 'File Exists',md + +wildmsg: + db '? in Filename',md + +endif +if MPM + +setlret1: + mvi a,1 +sta$ret: + sta aret +func$ret: + ret +entsp: ds 2 + +endif + +;***************************************************************** +;***************************************************************** +; +; common values shared between bdosi and bdos + +if MPM + +usrcode:db 0 ; current user number + +endif + +aret: ds 2 ; address value to return +lret equ aret ; low(aret) + +;***************************************************************** +;***************************************************************** +;** ** +;** b a s i c d i s k o p e r a t i n g s y s t e m ** +;** ** +;***************************************************************** +;***************************************************************** + +; literal constants + +true equ 0ffh ; constant true +false equ 000h ; constant false +enddir equ 0ffffh ; end of directory +byte equ 1 ; number of bytes for "byte" type +word equ 2 ; number of bytes for "word" type + +; fixed addresses in low memory + +tfcb equ 005ch ; default fcb location +tbuff equ 0080h ; default buffer location + +; error message handlers + +rod$error: + ; report read/only disk error + mvi c,2! jmp goerr + +rof$error: + ; report read/only file error + mvi c,3! jmp goerr + +sel$error: + ; report select error + mvi c,4 + ; Invalidate curdsk to force select call + ; at next curselect call + mvi a,0ffh! sta curdsk + +goerr: + ; hl = .errorhandler, call subroutine + mov h,c! mvi l,0ffh! shld aret + +if MPM + call test$error$mode! jnz rtn$phy$errs + mov a,c! lxi h,pererr-2! jmp bdos$jmp +else + +goerr1: + lda adrive! sta errdrv + lda error$mode! inr a! cnz error +endif + +rtn$phy$errs: + +if MPM + lda lock$shell! ora a! jnz lock$perr +endif + + ; Return 0ffffh if fx = 27 or 31 + + lda fx + cpi 27! jz goback0 + cpi 31! jz goback0 + jmp goback + +if MPM + +test$error$mode: + lxi d,pname+4 +test$error$mode1: + call rlr! dad d + mov a,m! ani 80h! ret +endif + +if BANKED + +set$copy$cr$only: + lda copy$cr$init! sta copy$cr$only! ret + +reset$copy$cr$only: + xra a! sta copy$cr$init! sta copy$cr$only! ret + +endif + +bde$e$bde$m$hl: + mov a,e! sub l! mov e,a + mov a,d! sbb h! mov d,a + rnc! dcr b! ret + +bde$e$bde$p$hl: + mov a,e! add l! mov e,a + mov a,d! adc h! mov d,a + rnc! inr b! ret + +shl3bv: + inr c +shl3bv1: + dcr c! rz + dad h! adc a! jmp shl3bv1 + +incr$rr: + call get$rra + inr m! rnz + inx h! inr m! rnz + inx h! inr m! ret + +save$rr: + call save$rr2! xchg +save$rr1: + mvi c,3! jmp move ; ret +save$rr2: + call get$rra! lxi d,save$ranr! ret + +reset$rr: + call save$rr2! jmp save$rr1 ; ret + +compare: + ldax d! cmp m! rnz + inx h! inx d! dcr c! rz + jmp compare + +; +; local subroutines for bios interface +; + +move: + ; Move data length of length c from source de to + ; destination given by hl + inr c ; in case it is zero + move0: + dcr c! rz ; more to move + ldax d! mov m,a ; one byte moved + inx d! inx h ; to next byte + jmp move0 + +selectdisk: + ; Select the disk drive given by register D, and fill + ; the base addresses curtrka - alloca, then fill + ; the values of the disk parameter block + mov c,d ; current disk# to c + ; lsb of e = 0 if not yet logged - in + call seldskf ; hl filled by call + ; hl = 0000 if error, otherwise disk headers + mov a,h! ora l! rz ; Return with C flag reset if select error + ; Disk header block address in hl + mov e,m! inx h! mov d,m! inx h ; de=.tran + shld cdrmaxa! inx h! inx h ; .cdrmax + shld curtrka! inx h! inx h ; hl=.currec + shld curreca! inx h! inx h ; hl=.buffa + inx h! shld drvlbla! inx h + shld lsn$add! inx h! inx h + ; de still contains .tran + xchg! shld tranv ; .tran vector + lxi h,dpbaddr ; de= source for move, hl=dest + mvi c,addlist! call move ; addlist filled + ; Now fill the disk parameter block + lhld dpbaddr! xchg ; de is source + lxi h,sectpt ; hl is destination + mvi c,dpblist! call move ; data filled + ; Now set single/double map mode + lhld maxall ; largest allocation number + mov a,h ; 00 indicates < 255 + lxi h,single! mvi m,true ; Assume a=00 + ora a! jz retselect + ; high order of maxall not zero, use double dm + mvi m,false + retselect: + ; C flag set indicates successful select + stc! ret + +home: + ; Move to home position, then offset to start of dir + call homef + xra a ; constant zero to accumulator + lhld curtrka! mov m,a! inx h! mov m,a ; curtrk=0000 + lhld curreca! mov m,a! inx h! mov m,a ; currec=0000 + inx h! mov m,a ; currec high byte=00 + +if MPM + lxi h,0! shld dblk ; dblk = 0000 +endif + + ret + +rdbuff: + ; Read buffer and check condition + mvi a,1! sta readf$sw + call readf ; current drive, track, sector, dma + jmp diocomp ; Check for i/o errors + +wrbuff: + ; Write buffer and check condition + ; write type (wrtype) is in register c + xra a! sta readf$sw + call writef ; current drive, track, sector, dma +diocomp: ; Check for disk errors + ora a! rz + mov c,a + call chk$media$flag + mov a,c + cpi 3! jc goerr + mvi c,1! jmp goerr + +chk$media$flag: + ; A = 0ffh -> media changed + inr a! rnz + +if BANKED + ; Handle media changes as I/O errors for + ; permanent drives + call chksiz$eq$8000h! rz +endif + + ; BIOS says media change occurred + ; Is disk logged-in? + lhld dlog! call test$vector! mvi c,1! rz ; no - return error + call media$change + pop h ; Discard return address + ; Was this a flush operation (fx = 48)? + lda fx! cpi 48! rz ; yes + ; Is this a flush to another drive? + lxi h,adrive! lda seldsk! cmp m! jnz reset$relog + ; Bail out if fx = read, write, close, or search next + call chk$exit$fxs + ; Is this a directory read operation? + lda readf$sw! ora a! rnz ; yes + ; Error - directory write operation + mvi c,2! jmp goerr ; Return disk read/only error + +reset$relog: + ; Reset relog if flushing to another drive + xra a! sta relog! ret + +if BANKED + +chksiz$eq$8000h: + ; Return with Z flag set if drive permanent + ; with no checksum vector + lhld chksiz! mvi a,80h! cmp h! rnz + xra a! cmp l! ret + +endif + +seekdir: + ; Seek the record containing the current dir entry + +if MPM + lxi d,0ffffh ; mask = ffff + lhld dblk! mov a,h! ora l! jz seekdir1 + lda blkmsk! mov e,a! xra a! mov d,a ; mask = blkmsk + lda blkshf! mov c,a! xra a + call shl3bv ; ahl = shl(dblk,blkshf) +seekdir1: + push h! push a ; Save ahl +endif + + lhld dcnt ; directory counter to hl + mvi c,dskshf! call hlrotr ; value to hl + shld drec + +if MPM + +; arecord = shl(dblk,blkshf) + shr(dcnt,dskshf) & mask + + mov a,l! ana e! mov l,a ; dcnt = dcnt & mask + mov a,h! ana d! mov h,a + pop b! pop d! call bde$e$bde$p$hl + +else + mvi b,0! xchg +endif + +set$arecord: + lxi h,arecord + mov m,e! inx h! mov m,d! inx h! mov m,b + ret + +seek: + ; Seek the track given by arecord (actual record) + + lhld curtrka! mov c,m! inx h! mov b,m ; bc = curtrk + push b ; s0 = curtrk + lhld curreca! mov e,m! inx h! mov d,m + inx h! mov b,m ; bde = currec + lhld arecord! lda arecord+2! mov c,a ; chl = arecord +seek0: + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + push h ; Save low(arecord) + jnc seek1 ; if arecord >= currec then go to seek1 + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! xthl! dcx h! xthl ; curtrk = curtrk - 1 + jmp seek0 +seek1: + lhld sectpt! call bde$e$bde$p$hl ; currec = currec + sectpt + pop h ; Restore low(arecord) + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + jc seek2 ; if arecord < currec then go to seek2 + xthl! inx h! xthl ; curtrk = curtrk + 1 + push h ; save low (arecord) + jmp seek1 +seek2: + xthl! push h ; hl,s0 = curtrk, s1 = low(arecord) + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! push d! push b! push h ; hl,s0 = curtrk, + ; s1 = high(arecord,currec), s2 = low(currec), + ; s3 = low(arecord) + xchg! lhld offset! dad d + mov b,h! mov c,l! shld track + call settrkf ; call bios settrk routine + ; Store curtrk + pop d! lhld curtrka! mov m,e! inx h! mov m,d + ; Store currec + pop b! pop d! + lhld curreca! mov m,e! inx h! mov m,d + inx h! mov m,b ; currec = bde + pop b ; bc = low(arecord), de = low(currec) + mov a,c! sub e! mov l,a ; hl = bc - de + mov a,b + sbb d + mov h,a + call shr$physhf + mov b,h! mov c,l + + lhld tranv! xchg ; bc=sector#, de=.tran + call sectran ; hl = tran(sector) + mov c,l! mov b,h ; bc = tran(sector) + shld sector + call setsecf ; sector selected + lhld curdma! mov c,l! mov b,h! jmp setdmaf + ; ret +shr$physhf: + lda physhf! mov c,a! jmp hlrotr + +; file control block (fcb) constants + +empty equ 0e5h ; empty directory entry +lstrec equ 127 ; last record# on extent +recsiz equ 128 ; record size +fcblen equ 32 ; file control block size +dirrec equ recsiz/fcblen ; directory fcbs / record +dskshf equ 2 ; log2(dirrec) +dskmsk equ dirrec-1 +fcbshf equ 5 ; log2(fcblen) + +extnum equ 12 ; extent number field +maxext equ 31 ; largest extent number +ubytes equ 13 ; unfilled bytes field +modnum equ 14 ; data module number + +maxmod equ 64 ; largest module number + +fwfmsk equ 80h ; file write flag is high order modnum +namlen equ 15 ; name length +reccnt equ 15 ; record count field +dskmap equ 16 ; disk map field +lstfcb equ fcblen-1 +nxtrec equ fcblen +ranrec equ nxtrec+1; random record field (2 bytes) + +; reserved file indicators + +rofile equ 9 ; high order of first type char +invis equ 10 ; invisible file in dir command + +; utility functions for file access + +dm$position: + ; Compute disk map position for vrecord to hl + lxi h,blkshf! mov c,m ; shift count to c + lda vrecord ; current virtual record to a + dmpos0: + ora a! rar! dcr c! jnz dmpos0 + ; a = shr(vrecord,blkshf) = vrecord/2**(sect/block) + mov b,a ; Save it for later addition + mvi a,8! sub m ; 8-blkshf to accumulator + mov c,a ; extent shift count in register c + lda extval ; extent value ani extmsk + dmpos1: + ; blkshf = 3,4,5,6,7, c=5,4,3,2,1 + ; shift is 4,3,2,1,0 + dcr c! jz dmpos2 + ora a! ral! jmp dmpos1 + dmpos2: + ; Arrive here with a = shl(ext and extmsk,7-blkshf) + add b ; Add the previous shr(vrecord,blkshf) value + ; a is one of the following values, depending upon alloc + ; bks blkshf + ; 1k 3 v/8 + extval * 16 + ; 2k 4 v/16+ extval * 8 + ; 4k 5 v/32+ extval * 4 + ; 8k 6 v/64+ extval * 2 + ; 16k 7 v/128+extval * 1 + ret ; with dm$position in a + +getdma: + lhld info! lxi d,dskmap! dad d! ret + +getdm: + ; Return disk map value from position given by bc + call getdma + dad b ; Index by a single byte value + lda single ; single byte/map entry? + ora a! jz getdmd ; Get disk map single byte + mov l,m! mov h,b! ret ; with hl=00bb + getdmd: + dad b ; hl=.fcb(dm+i*2) + ; double precision value returned + mov a,m! inx h! mov h,m! mov l,a! ret + +index: + ; Compute disk block number from current fcb + call dm$position ; 0...15 in register a + sta dminx + mov c,a! mvi b,0! call getdm ; value to hl + shld arecord! mov a,l! ora h! ret + +atran: + ; Compute actual record address, assuming index called + +; arecord = shl(arecord,blkshf) + + lda blkshf! mov c,a + lhld arecord! xra a! call shl3bv + shld arecord! sta arecord+2 + + shld arecord1 ; Save low(arecord) + +; arecord = arecord or (vrecord and blkmsk) + + lda blkmsk! mov c,a! lda vrecord! ana c + mov b,a ; Save vrecord & blkmsk in reg b & blk$off + sta blk$off + lxi h,arecord! ora m! mov m,a! ret + +get$atts: + ; Get volatile attributes starting at f'5 + ; info locates fcb + lhld info + lxi d,8! dad d ; hl = .fcb(f'8) + mvi c,4 +get$atts$loop: + mov a,m! add a! push a + mov a,d! rar! mov d,a + pop a! rrc! mov m,a + dcx h! dcr c! jnz get$atts$loop + mov a,d! ret + +get$s1: + ; Get current s1 field to a + call getexta! inx h! mov a,m! ret + +get$rra: + ; Get current ran rec field address to hl + lhld info! lxi d,ranrec! dad d ; hl=.fcb(ranrec) + ret + +getexta: + ; Get current extent field address to hl + lhld info! lxi d,extnum! dad d ; hl=.fcb(extnum) + ret + +getrcnta: + ; Get reccnt address to hl + lhld info! lxi d,reccnt! dad d! ret + +getfcba: + ; Compute reccnt and nxtrec addresses for get/setfcb + call getrcnta! xchg ; de=.fcb(reccnt) + lxi h,(nxtrec-reccnt)! dad d ; hl=.fcb(nxtrec) + ret + +getfcb: + ; Set variables from currently addressed fcb + call getfcba ; addresses in de, hl + mov a,m! sta vrecord ; vrecord=fcb(nxtrec) + xchg! mov a,m! ora a! jnz getfcb0 + call get$dir$ext! mov c,a! call set$rc! mov a,m +getfcb0: + cpi 81h! jc getfcb1 + mvi a,80h +getfcb1: + sta rcount ; rcount=fcb(reccnt) or 80h + call getexta ; hl=.fcb(extnum) + lda extmsk ; extent mask to a + ana m ; fcb(extnum) and extmsk + sta extval + ret + +setfcb: + ; Place values back into current fcb + call getfcba ; addresses to de, hl + ; fcb(cr) = vrecord + lda vrecord! mov m,a + ; Is fx < 22? (sequential read or write) + lda fx! cpi 22! jnc $+4 ; no + ; fcb(cr) = fcb(cr) + 1 + inr m + xchg! mov a,m! cpi 80h! rnc ; dont reset fcb(rc) if > 7fh + lda rcount! mov m,a ; fcb(reccnt)=rcount + ret + +zero$ext$mod: + call getexta! mov m,d! inx h! inx h! mov m,d + ret + +zero: + mov m,b! inx h! dcr c! rz + jmp zero + +hlrotr: + ; hl rotate right by amount c + inr c ; in case zero + hlrotr0: dcr c! rz ; return when zero + mov a,h! ora a! rar! mov h,a ; high byte + mov a,l! rar! mov l,a ; low byte + jmp hlrotr0 + +compute$cs: + ; Compute checksum for current directory buffer + lhld buffa ; current directory buffer + lxi b,4 ; b = 0, c = 4 +compute$cs0: + mvi d,32 ; size of fcb + xra a ; clear checksum value +compute$cs1: + add m! inx h! dcr d + jnz compute$cs1 + xra b! mov b,a! dcr c + jnz compute$cs0 + ret ; with checksum in a + +if MPM + +compute$cs: + ; Compute checksum for current directory buffer + mvi c,recsiz ; size of directory buffer + lhld buffa ; current directory buffer + xra a ; Clear checksum value + computecs0: + add m! inx h! dcr c ; cs = cs+buff(recsiz-c) + jnz computecs0 + ret ; with checksum in a + +chksum$fcb: ; Compute checksum for fcb + ; Add 1st 12 bytes of fcb + curdsk + + ; high$ext + xfcb$read$only + bbh + lxi h,pdcnt! mov a,m + inx h! add m ; Add high$ext + inx h! add m ; Add xfcb$read$only + inx h! add m ; Add curdsk + adi 0bbh ; Add 0bbh to bias checksum + lhld info! mvi c,12! call computecs0 + ; Skip extnum + inx h + ; Add fcb(s1) + add m! inx h + ; Skip modnum + inx h + ; Skip fcb(reccnt) + ; Add disk map + inx h! mvi c,16! call computecs0 + ora a! ret ; Z flag set if checksum valid + +set$chksum$fcb: + call chksum$fcb! rz + mov b,a! call gets1 + cma! add b! cma + mov m,a! ret + +reset$chksum$fcb: + xra a! sta comp$fcb$cks + call chksum$fcb! rnz + call get$s1! inr m! ret + +endif + +check$fcb: + +if MPM + xra a! sta check$fcb4 +check$fcb1: + call chek$fcb! rz +check$fcb2: + + ani 0fh! jnz check$fcb3 + lda pdcnt! ora a! jz check$fcb3 + call set$sdcnt! sta dont$close + call close1 + lxi h,lret! inr m! jz check$fcb3 + mvi m,0! call pack$sdcnt! mvi b,5 + call search$olist! rz +check$fcb3: + + pop h ; Discard return address +check$fcb4: + nop + mvi a,10! jmp sta$ret + +set$fcb$cks$flag: + mvi a,0ffh! sta comp$fcb$cks! ret + +else + call gets1! lhld lsn$add + cmp m! cnz chk$media$fcb +endif + +chek$fcb: + lda high$ext + +if MPM + + ; if ext & 0110$0000b = 0110$0000b then + ; set fcb(0) to 0 (user 0) + + cpi 0110$0000b! jnz chek$fcb1 +else + ora a! rz +endif + + lhld info! xra a! mov m,a ; fcb(0) = 0 +chek$fcb1: + +if MPM + jmp chksum$fcb ; ret +else + ret + +chk$media$fcb: + ; fcb(s1) ~= DPH login sequence # field + ; Is fcb addr < bdosadd? + +if banked + lhld user$info +else + lhld info +endif + + xchg! lhld bdosadd! call subdh! jnc chk$media1 ; no + ; Is rlog(drive) true? + lhld rlog! call testvector! rz ; no +chk$media1: + ; Return invalid fcb error code + pop h! pop h +chk$media2: + mvi a,10! jmp sta$ret +endif + +hlrotl: + ; Rotate the mask in hl by amount in c + inr c ; may be zero + hlrotl0: dcr c! rz ; return if zero + dad h! jmp hlrotl0 + +set$dlog: + lxi d,dlog +set$cdisk: + ; Set a "1" value in curdsk position of bc + lda curdsk +set$cdisk1: + mov c,a ; Ready parameter for shift + lxi h,1 ; number to shift + call hlrotl ; hl = mask to integrate + ldax d! ora l! stax d! inx d + ldax d! ora h! stax d! ret + +nowrite: + ; Return true if dir checksum difference occurred + lhld rodsk + +test$vector: + lda curdsk +test$vector1: + mov c,a! call hlrotr + mov a,l! ani 1b! ret ; non zero if curdsk bit on + +check$rodir: + ; Check current directory element for read/only status + call getdptra ; address of element + +check$rofile: + ; Check current buff(dptr) or fcb(0) for r/o status + call ro$test + rnc ; Return if not set + jmp rof$error ; Exit to read only disk message + +ro$test: + lxi d,rofile! dad d + mov a,m! ral! ret ; carry set if r/o + +check$write: + ; Check for write protected disk + call nowrite! rz ; ok to write if not rodsk + jmp rod$error ; read only disk error + +getdptra: + ; Compute the address of a directory element at + ; positon dptr in the buffer + + lhld buffa! lda dptr +addh: + ; hl = hl + a + add l! mov l,a! rnc + ; overflow to h + inr h! ret + +getmodnum: + ; Compute the address of the module number + ; bring module number to accumulator + ; (high order bit is fwf (file write flag) + lhld info! lxi d,modnum! dad d ; hl=.fcb(modnum) + mov a,m! ret ; a=fcb(modnum) + +clrmodnum: + ; Clear the module number field for user open/make + call getmodnum! mvi m,0 ; fcb(modnum)=0 + ret + +clr$ext: + ; fcb ext = fcb ext & 1fh + call getexta! mov a,m! ani 0001$1111b! mov m,a! + ret + +setfwf: + call getmodnum ; hl=.fcb(modnum), a=fcb(modnum) + ; Set fwf (file write flag) to "1" + ori fwfmsk! mov m,a ; fcb(modnum)=fcb(modnum) or 80h + ; also returns non zero in accumulator + ret + +compcdr: + ; Return cy if cdrmax > dcnt + lhld dcnt! xchg ; de = directory counter + lhld cdrmaxa ; hl=.cdrmax + mov a,e! sub m ; low(dcnt) - low(cdrmax) + inx h ; hl = .cdrmax+1 + mov a,d! sbb m ; hig(dcnt) - hig(cdrmax) + ; condition dcnt - cdrmax produces cy if cdrmax>dcnt + ret + +setcdr: + ; if not (cdrmax > dcnt) then cdrmax = dcnt+1 + call compcdr + rc ; Return if cdrmax > dcnt + ; otherwise, hl = .cdrmax+1, de = dcnt + inx d! mov m,d! dcx h! mov m,e + ret + +subdh: + ; Compute hl = de - hl + mov a,e! sub l! mov l,a! mov a,d! sbb h! mov h,a + ret + +newchecksum: + mvi c,0feh ; Drop through to compute new checksum +checksum: + ; Compute current checksum record and update the + ; directory element if c=true, or check for = if not + ; drec < chksiz? + lhld drec! xchg! lhld chksiz + mov a,h! ani 7fh! mov h,a ; Mask off permanent drive bit + call subdh ; de-hl + rnc ; Skip checksum if past checksum vector size + ; drec < chksiz, so continue + push b ; Save init flag + call compute$cs ; Check sum value to a + lhld checka ; address of check sum vector + xchg + lhld drec + dad d ; hl = .check(drec) + pop b ; Recall true=0ffh or false=00 to c + inr c ; 0ffh produces zero flag + jz initial$cs + inr c ; 0feh produces zero flag + jz update$cs + +if MPM + inr c! jz test$dir$cs +endif + + ; not initializing, compare + cmp m ; compute$cs=check(drec)? + rz ; no message if ok + ; checksum error, are we beyond + ; the end of the disk? + call nowrite +;;; rnz ;[JCE] DRI Patch 13 + nop + +media$change: + call discard$data + +if MPM + call flush$file0 +else + mvi a,0ffh! sta relog! sta hashl + call set$rlog +endif + + ; Reset the drive + + call set$dlog! jmp reset37x + +if MPM + test$dir$cs: + cmp m! jnz flush$files + ret +endif + + initial$cs: + ; initializing the checksum + cmp m! mov m,a! rz + ; or 1 into login seq # if media change + lhld lsn$add! mvi a,1! ora m! mov m,a! ret + + update$cs: + ; updating the checksum + mov m,a! ret + +set$ro: + ; Set current disk to read/only + lda seldsk! lxi d,rodsk! call set$cdisk1 ; sets bit to 1 + ; high water mark in directory goes to max + lhld dirmax! inx h! xchg ; de = directory max + lhld cdrmaxa ; hl = .cdrmax + mov m,e! inx h! mov m,d ; cdrmax = dirmax + ret + +set$rlog: + ; rlog(seldsk) = true + lhld olog! call test$vector! rz + lxi d,rlog! jmp set$cdisk + +tst$log$fxs: + lda chksiz+1! ani 80h! rnz + lxi h,log$fxs +tst$log0: + lda fx! mov b,a +tst$log1: + mov a,m! cmp b! rz + inx h! ora a! jnz tst$log1 + inr a! ret + +test$media$flag: + lhld lsn$add! inx h! mov a,m! ora a! ret + +chk$exit$fxs: + lxi h,goback! push h + ; does fx = read or write function? + ; and is drive removable? + lxi h,rw$fxs! call tst$log0! jz chk$media2 ; yes + ; is fx = close or searchn function? + ; and is drive removable? + lxi h,sc$fxs! call tst$log0! jz lret$eq$ff ; yes + pop h! ret + +tst$relog: + lxi h,relog! mov a,m! ora a! rz + mvi m,0 +drv$relog: + call curselect + lxi h,0! shld dcnt! xra a! sta dptr + ret + +set$lsn: + lhld lsn$add! mov c,m + call gets1! mov m,c! ret + +discard$data$bcb: + lhld dtabcba! mvi c,4! jmp discard0 + +discard$data: + lhld dtabcba! jmp discard + +discard$dir: + lhld dirbcba + +discard: + mvi c,1 +discard0: + mov a,l! ana h! inr a! rz + +if BANKED + mov e,m! inx h! mov d,m! xchg +discard1: + push h! push b + lxi d,adrive! call compare + pop b! pop h! jnz discard2 + + mvi m,0ffh +discard2: + lxi d,13! dad d + mov e,m! inx h! mov d,m + xchg! mov a,l! ora h! rz + jmp discard1 +else + push h + lxi d,adrive! call compare + pop h! rnz + mvi m,0ffh! ret +endif + +get$buffa: + push d! lxi d,10! dad d + mov e,m! inx h! mov d,m + +if BANKED + inx h! mov a,m! sta buffer$bank +endif + + xchg! pop d! ret + +rddir: + ; Read a directory entry into the directory buffer + call seek$dir + mvi a,3! jmp wrdir0 + +seek$copy: +wrdir: + ; Write the current directory entry, set checksum + call check$write + call newchecksum ; Initialize entry + mvi a,5 +wrdir0: + lxi h,0! shld last$block + lhld dirbcba + +if BANKED + cpi 5! jnz $+6 + lhld curbcba +endif + + call deblock + +setdata: + ; Set data dma address + lhld dmaad! jmp setdma ; to complete the call + +setdir1: + call get$buffa + +setdma: + ; hl=.dma address to set (i.e., buffa or dmaad) + shld curdma! ret + +dir$to$user: + +if not MPM + ; Copy the directory entry to the user buffer + ; after call to search or searchn by user code + lhld buffa! xchg ; source is directory buffer + lhld xdmaad ; destination is user dma address + lxi b,recsiz ; copy entire record + call movef +endif + ; Set lret to dcnt & 3 if search successful + lxi h,lret! mov a,m! inr a! rz + lda dcnt! ani dskmsk! mov m,a! ret + +make$fcb$inv: ; Flag fcb as invalid + ; Reset fcb write flag + call setfwf + ; Set 1st two bytes of diskmap to ffh + inx h! inx h! mvi a,0ffh! mov m,a! inx h! mov m,a + ret + +chk$inv$fcb: ; Check for invalid fcb + call getdma! jmp test$ffff + +tst$inv$fcb: ; Test for invalid fcb + call chk$inv$fcb! rnz + pop h! mvi a,9! jmp sta$ret! ; lret = 9 + +end$of$dir: + ; Return zero flag if at end of directory, non zero + ; if not at end (end of dir if dcnt = 0ffffh) + lxi h,dcnt +test$ffff: + mov a,m ; may be 0ffh + inx h! cmp m ; low(dcnt) = high(dcnt)? + rnz ; non zero returned if different + ; high and low the same, = 0ffh? + inr a ; 0ffh becomes 00 if so + ret + +set$end$dir: + ; Set dcnt to the end of the directory + lxi h,enddir! shld dcnt! ret + +read$dir: + call r$dir! jmp r$dir1 + +r$dir: + ; Read next directory entry, with c=true if initializing + + lhld dirmax! xchg ; in preparation for subtract + lhld dcnt! inx h! shld dcnt ; dcnt=dcnt+1 + ; Continue while dirmax >= dcnt (dirmax-dcnt no cy) + call subdh ; de-hl + + jc set$end$dir + + read$dir0: + ; not at end of directory, seek next element + ; initialization flag is in c + lda dcnt! ani dskmsk ; low(dcnt) and dskmsk + mvi b,fcbshf ; to multiply by fcb size + read$dir1: + add a! dcr b! jnz read$dir1 + ; a = (low(dcnt) and dskmsk) shl fcbshf + sta dptr ; ready for next dir operation + ora a! rnz ; Return if not a new record + read$dir2: + push b ; Save initialization flag c + call rd$dir ; Read the directory record + pop b ; Recall initialization flag + lda relog! ora a! rnz + jmp checksum ; Checksum the directory elt + +r$dir2: + call read$dir2 +r$dir1: + lda relog! ora a! rz + call chk$exit$fxs + call tst$relog! jmp rd$dir + +getallocbit: + ; Given allocation vector position bc, return with byte + ; containing bc shifted so that the least significant + ; bit is in the low order accumulator position. hl is + ; the address of the byte for possible replacement in + ; memory upon return, and d contains the number of shifts + ; required to place the returned value back into position + mov a,c! ani 111b! inr a! mov e,a! mov d,a + ; d and e both contain the number of bit positions to shift + + mov h,b! mov l,c! mvi c,3 ; bc = bc shr 3 + call hlrotr ; hlrotr does not touch d and e + mov b,h! mov c,l + + lhld alloca ; base address of allocation vector + dad b! mov a,m ; byte to a, hl = .alloc(bc shr 3) + ; Now move the bit to the low order position of a + rotl: rlc! dcr e! jnz rotl! ret + +setallocbit: + ; bc is the bit position of alloc to set or reset. the + ; value of the bit is in register e. + push d! call getallocbit ; shifted val a, count in d + ani 1111$1110b ; mask low bit to zero (may be set) + pop b! ora c ; low bit of c is masked into a + ; jmp rotr ; to rotate back into proper position + ; ret + +rotr: + ; byte value from alloc is in register a, with shift count + ; in register c (to place bit back into position), and + ; target alloc position in registers hl, rotate and replace + rrc! dcr d! jnz rotr ; back into position + mov m,a ; back to alloc + ret + +copy$alv: + ; If Z flag set, copy 1st ALV to 2nd + ; Otherwise, copy 2nd ALV to 1st + +if not BANKED + lda bdos$flags! rlc! rlc! rc +endif + + push a + call get$nalbs! mov b,h! mov c,l + lhld alloca! mov d,h! mov e,l! dad b + pop a! jz movef + xchg! jmp movef + +scandm$ab: + ; Set/Reset 1st and 2nd ALV + push b! call scandm$a + pop b! ;jmp scandm$b + +scandm$b: + ; Set/Reset 2nd ALV + +if not BANKED + lda bdos$flags! ani 40h! rnz +endif + + push b! call get$nalbs + xchg! lhld alloca + pop b! push h! dad d! shld alloca + call scandm$a + pop h! shld alloca! ret + +scandm$a: + ; Set/Reset 1st ALV + ; Scan the disk map addressed by dptr for non-zero + ; entries, the allocation vector entry corresponding + ; to a non-zero entry is set to the value of c (0,1) + call getdptra ; hl = buffa + dptr + ; hl addresses the beginning of the directory entry + lxi d,dskmap! dad d ; hl now addresses the disk map + push b ; Save the 0/1 bit to set + mvi c,fcblen-dskmap+1 ; size of single byte disk map + 1 + scandm0: + ; Loop once for each disk map entry + pop d ; Recall bit parity + dcr c! rz ; all done scanning? + ; no, get next entry for scan + push d ; Replace bit parity + lda single! ora a! jz scandm1 + ; single byte scan operation + push b ; Save counter + push h ; Save map address + mov c,m! mvi b,0 ; bc=block# + jmp scandm2 + scandm1: + ; double byte scan operation + dcr c ; count for double byte + push b ; Save counter + mov c,m! inx h! mov b,m ; bc=block# + push h ; Save map address + scandm2: + ; Arrive here with bc=block#, e=0/1 + mov a,c! ora b ; Skip if = 0000 + jz scandm3 + lhld maxall ; Check invalid index + mov a,l! sub c! mov a,h! sbb b ; maxall - block# + cnc set$alloc$bit + ; bit set to 0/1 + scandm3: + pop h! inx h ; to next bit position + pop b ; Recall counter + jmp scandm0 ; for another item + +get$nalbs: ; Get # of allocation vector bytes + lhld maxall! mvi c,3 + ; number of bytes in allocation vector is (maxall/8)+1 + call hlrotr! inx h! ret + +if MPM + +test$dir: + call home + call set$end$dir +test$dir1: + mvi c,0feh! call read$dir + lda flushed! ora a! rnz + call end$of$dir! rz + jmp test$dir1 +endif + +initialize: + ; Initialize the current disk + ; lret = false ; set to true if $ file exists + ; Compute the length of the allocation vector - 2 + +if MPM + lhld tlog! call test$vector! jz initialize1 + lhld tlog! call remove$drive! shld tlog + xra a! sta flushed + call test$dir! rz +initialize1: +else + + call test$media$flag ! mvi m,0 +;;; call discard$data ;[JCE] DRI Patch 13 +;;; call discard$dir + +endif +;[JCE] DRI Patch 13 + +if BANKED +;;; ; Is drive permanent with no chksum vector? +;;; call chksiz$eq$8000h +;;; jnz initialize2 ; no +;;; ; Is this an initial login operation? +;;; ; register A = 0 +;;; lhld lsn$add +;;; cmp m +;;; mvi m,2 +;;; call test$media$flag +;;; mvi m,0 ; Reset media change flag + call chksiz$eq$8000h + jnz patch$13ff + lhld lsn$add + cmp m + nop + nop + jz patch$13ff + jmp patch$2d40 + +patch$13ff: + + call discard$data + call discard$dir + +initialize2: +else ;BANKED + call discard$data ;[JCE] DRI Patch 13 + call discard$dir + +endif + + call get$nalbs ; Get # of allocation vector bytes + mov b,h! mov c,l ; Count down bc til zero + lhld alloca ; base of allocation vector + ; Fill the allocation vector with zeros + initial0: + mvi m,0! inx h ; alloc(i)=0 + dcx b ; Count length down + mov a,b! ora c! jnz initial0 + + lhld drvlbla! mov m,a ; Zero out drive desc byte + + ; Set the reserved space for the directory + + lhld dirblk! xchg + lhld alloca ; hl=.alloc() + mov m,e! inx h! mov m,d ; sets reserved directory blks + ; allocation vector initialized, home disk + call home + ; cdrmax = 3 (scans at least one directory record) + lhld cdrmaxa! mvi m,4! inx h! mvi m,0 + + call set$end$dir ; dcnt = enddir + lhld hashtbla! shld arecord1 + + ; Read directory entries and check for allocated storage + + initial2: + mvi c,true! call read$dir + call end$of$dir +if BANKED + jz patch$2d6a ;[JCE] DRI Patch 13 +else + jz copy$alv +endif + ; not end of directory, valid entry? + call getdptra ; hl = buffa + dptr + xchg! lhld arecord1! mov a,h! ana l! inr a! xchg + ; is hashtbla ~= 0ffffh + cnz init$hash ; yes - call init$hash + mvi a,21h! cmp m + jz initial2 ; Skip date & time records + + mvi a,empty! cmp m + jz initial2 ; go get another item + + mvi a,20h! cmp m! jz drv$lbl + mvi a,10h! ana m! jnz initial3 + + ; Now scan the disk map for allocated blocks + + mvi c,1 ; set to allocated + call scandm$a + initial3: + call setcdr ; set cdrmax to dcnt + jmp initial2 ; for another entry + +drv$lbl: + lxi d,extnum! dad d! mov a,m + lhld drvlbla! mov m,a! jmp initial3 + +copy$dirloc: + ; Copy directory location to lret following + ; delete, rename, ... ops + + lda dirloc! jmp sta$ret + ; ret + +compext: + ; Compare extent# in a with that in c, return nonzero + ; if they do not match + push b ; Save c's original value + push psw! lda extmsk! cma! mov b,a + ; b has negated form of extent mask + mov a,c! ana b! mov c,a ; low bits removed from c + pop psw! ana b ; low bits removed from a + sub c! ani maxext ; Set flags + pop b ; Restore original values + ret + +get$dir$ext: + ; Compute directory extent from fcb + ; Scan fcb disk map backwards + call getfcba ; hl = .fcb(vrecord) + mvi c,16! mov b,c! inr c! push b + ; b=dskmap pos (rel to 0) +get$de0: + pop b + dcr c + xra a ; Compare to zero +get$de1: + dcx h! dcr b; Decr dskmap position + cmp m! jnz get$de2 ; fcb(dskmap(b)) ~= 0 + dcr c! jnz get$de1 + ; c = 0 -> all blocks = 0 in fcb disk map +get$de2: + mov a,c! sta dminx + lda single! ora a! mov a,b + jnz get$de3 + rar ; not single, divide blk idx by 2 +get$de3: + push b! push h ; Save dskmap position & count + mov l,a! mvi h,0 ; hl = non-zero blk idx + ; Compute ext offset from last non-zero + ; block index by shifting blk idx right + ; 7 - blkshf + lda blkshf! mov d,a! mvi a,7! sub d + mov c,a! call hlrotr! mov b,l + ; b = ext offset + lda extmsk! cmp b! pop h! jc get$de0 + ; Verify computed extent offset <= extmsk + call getexta! mov c,m + cma! ani maxext! ana c! ora b + ; dir ext = (fcb ext & (~ extmsk) & maxext) | ext offset + pop b ; Restore stack + ret ; a = directory extent + +searchi: + ; search initialization + lhld info! shld searcha ; searcha = info +searchi1: + mov a,c! sta searchl ; searchl = c + call set$hash + mvi a,0ffh! sta dirloc ; changed if actually found + ret + +search$namlen: + mvi c,namlen! jmp search +search$extnum: + mvi c,extnum +search: + ; Search for directory element of length c at info + call searchi +search1: ; entry point used by rename + call set$end$dir ; dcnt = enddir + call tst$log$fxs! cz home + ; (drop through to searchn) + +searchn: + ; Search for the next directory element, assuming + ; a previous call on search which sets searcha and + ; searchl + +if MPM + lxi h,user0$pass! xra a! cmp m! mov m,a! cnz swap +else + xra a! sta user0$pass +endif + + call search$hash! jnz search$fin + mvi c,false! call read$dir ; Read next dir element + call end$of$dir! jz search$fin + ; not end of directory, scan for match + lhld searcha! xchg ; de=beginning of user fcb + ldax d ; first character + cpi empty ; Keep scanning if empty + jz searchnext + ; not empty, may be end of logical directory + push d ; Save search address + call compcdr ; past logical end? + pop d ; Recall address + jnc search$fin ; artificial stop +searchnext: + call getdptra ; hl = buffa+dptr + lda searchl! mov c,a ; length of search to c + mvi b,0 ; b counts up, c counts down + + mov a,m! cpi empty! cz save$dcnt$pos1 + +if BANKED + xra a! sta save$xfcb + mov a,m! ani 1110$1111b! cmp m! jz search$loop + xchg! cmp m! xchg! jnz search$loop + lda find$xfcb! ora a! jz search$n + sta save$xfcb! jmp searchok +endif + + searchloop: + mov a,c! ora a! jz endsearch + ldax d! cpi '?'! jz searchok ; ? in user fcb + ; Scan next character if not ubytes + mov a,b! cpi ubytes! jz searchok + ; not the ubytes field, extent field? + cpi extnum ; may be extent field + jz searchext ; Skip to search extent + cpi modnum! ldax d! cz searchmod + sub m! ani 7fh ; Mask-out flags/extent modulus + jnz searchnm ; Skip if not matched + jmp searchok ; matched character + searchext: + ldax d + ; Attempt an extent # match + push b ; Save counters + +if MPM + push h + lhld sdcnt + inr h! jnz dont$save + lhld dcnt! shld sdcnt + lhld dblk! shld sdblk + dont$save: + pop h +endif + + mov c,m ; directory character to c + call compext ; Compare user/dir char + + mov b,a + lda user0pass! inr a! jz save$dcnt$pos2 + ; Disable search of user 0 if any fcb + ; is found under the current user # + xra a! sta search$user0 + mov a,b + + pop b ; Recall counters + ora a ; Set flag + jnz searchn ; Skip if no match + searchok: + ; current character matches + inx d! inx h! inr b! dcr c + jmp searchloop + endsearch: + ; entire name matches, return dir position + +if BANKED + lda save$xfcb! inr a! jnz endsearch1 + lda xdcnt+1! cpi 0feh! cz save$dcnt$pos0 + jmp searchn + endsearch1: +endif + + xra a! sta dirloc ; dirloc = 0 + sta lret ; lret = 0 + ; successful search - + ; return with zero flag reset + mov b,a! inr b! ret + searchmod: + ani 3fh! ret ; Mask off high 2 bits + search$fin: + ; end of directory, or empty name + + call save$dcnt$pos1 + + ; Set dcnt = 0ffffh + call set$end$dir ; may be artifical end + lret$eq$ff: + ; unsuccessful search - + ; return with zero flag set + ; lret,low(aret) = 0ffh + mvi a,255! mov b,a! inr b! jmp sta$ret + + searchnm: ; search no match routine + mov a,b! ora a! jnz searchn ; fcb(0)? + mov a,m! ora a! jnz searchn ; dir fcb(0)=0? + lda search$user0! ora a! jz searchn + sta user0$pass + +if MPM + call swap +endif + + jmp searchok + +if MPM + +swap: ; Swap dcnt,sdblk with sdcnt0,sdblk0 + push h! push d! push b + lxi d,sdcnt! lxi h,sdcnt0 + mvi b,4 +swap1: + ldax d! mov c,a! mov a,m + stax d! mov m,c + inx h! inx d! dcr b! jnz swap1 + pop b! pop d! pop h! + ret +endif + +save$dcnt$pos2: + ; Save directory position of matching fcb + ; under user 0 with matching extent # & modnum = 0 + ; a = 0 on entry + ora b! pop b! lxi b,searchn! push b! rnz + inx h! inx h! mov a,m! ora a! rnz + ; Call if user0pass = 0ffh & + ; dir fcb(extnum) = fcb(extnum) + ; dir fcb(modnum) = 0 +save$dcnt$pos0: + call save$dcnt$pos ; Return to searchn +save$dcnt$pos1: + ; Save directory position of first empty fcb + ; or the end of the directory + + push h + lhld xdcnt + inr h! jnz save$dcnt$pos$ret ; Return if h ~= 0ffh + + +save$dcnt$pos: + lhld dcnt! shld xdcnt + +if MPM + lhld dblk! shld xdblk +endif + +save$dcnt$pos$ret: + pop h! ret + +if BANKED + +init$xfcb$search: + mvi a,0ffh +init$xfcb$search1: + sta find$xfcb! mvi a,0feh! sta xdcnt+1! ret + +does$xfcb$exist: + lda xdcnt+1! cpi 0feh! rz + call set$dcnt$dblk + xra a! call init$xfcb$search1 + lhld searcha! mov a,m! ori 10h! mov m,a + mvi c,extnum! call searchi1! jmp searchn + +xdcnt$eq$dcnt: + lhld dcnt! shld xdcnt! ret + +restore$dir$fcb: + call set$dcnt$dblk + mvi c,namlen! call searchi! jmp searchn +endif + +delete: + ; Delete the currently addressed file + call get$atts + +if BANKED + sta attributes + ; Make search return matching fcbs and xfcbs +deletex: + mvi a,0feh! call init$xfcb$search1 +else + ; Return with aret = 0 for XFCB only delete + ; in non-banked systems + ral! rc +endif + +; Delete pass 1 - check r/o attributes and xfcb passwords + + call search$extnum! rz + + delete00: + jz delete1 + +if BANKED + ; Is addressed dir fcb an xfcb? + call getdptra! mov a,m! ani 10h! jnz delete01 ; yes + +if MPM + call tst$olist ; Verify fcb not open by someone else +endif + + ; Check r/o attribute if this is not an + ; xfcb only delete operation. + lda attributes! ral! cnc check$rodir +else + call check$rodir +endif + +if BANKED + ; Are xfcb passwords enabled? + call get$dir$mode! ral! jc delete02 ; no +endif + + ; Is this a wild card delete operation? + lhld info! call chk$wild! jz delete02 ; yes + ; Not wild & passwords inactive + ; Skip to pass 2 + jmp delete11 + +if BANKED + + delete01: + ; Check xfcb password if passwords enabled + call get$dir$mode! ral! jnc delete02 + call chk$xfcb$password! jz delete02 + call chk$pw$error! jmp deletex +endif + + delete02: + call searchn! jmp delete00 + +; Delete pass 2 - delete all matching fcbs and/or xfcbs. + +delete1: + call search$extnum + + delete10: + jz copy$dir$loc + delete11: + call getdptra + +if BANKED + ; Is addressed dir fcb an xfcb? + mov a,m! ani 10h! jnz delete12 ; yes +if MPM + push h + call chk$olist ; Delete olist item if present + pop h +endif + ; Is this delete operation xfcb only? + lda attributes! ani 80h! jnz delete13 ; yes +endif + + delete12: + ; Delete dir fcb or xfcb + ; if fcb free all alocated blocks. + + mvi m,empty + +if BANKED + + delete13: + push a ; Z flag set => free FCB blocks + ; Zero password mode byte in sfcb if sfcb exists + ; Does sfcb exist? + call get$dtba$8! ora a! jnz $+4 ; no + ; Zero mode byte + mov m,a +endif + + call wrdir! mvi c,0 + +if BANKED + pop a! cz scandm$ab +else + call scandm$ab +endif + + call fix$hash + call searchn! jmp delete10 + +get$block: + ; Given allocation vector position bc, find the zero bit + ; closest to this position by searching left and right. + ; if found, set the bit to one and return the bit position + ; in hl. if not found (i.e., we pass 0 on the left, or + ; maxall on the right), return 0000 in hl + mov d,b! mov e,c ; copy of starting position to de + righttst: + lhld maxall ; value of maximum allocation# + mov a,e! sub l! mov a,d! sbb h ; right=maxall? + jnc retblock0 ; return block 0000 if so + inx d! push b! push d ; left, right pushed + mov b,d! mov c,e ; ready right for call + call getallocbit + rar! jnc retblock ; Return block number if zero + pop d! pop b ; Restore left and right pointers + lefttst: + mov a,c! ora b! jz righttst ; Skip if left=0000 + ; left not at position zero, bit zero? + dcx b! push d! push b ; left,right pushed + call getallocbit + rar! jnc retblock ; return block number if zero + ; bit is one, so try the right + pop b! pop d ; left, right restored + jmp righttst + retblock: + ral! inr a ; bit back into position and set to 1 + ; d contains the number of shifts required to reposition + call rotr ; move bit back to position and store + pop h! pop d ; hl returned value, de discarded + ret + retblock0: + ; cannot find an available bit, return 0000 + mov a,c + ora b! jnz lefttst ; also at beginning + lxi h,0000h! ret + +copy$dir: + ; Copy fcb information starting at c for e bytes + ; into the currently addressed directory entry + mvi d,80h +copy$dir0: + call copy$dir2 + inr c +copy$dir1: + dcr c! jz seek$copy + mov a,m! ana b! push b + mov b,a! ldax d! ani 7fh! ora b! mov m,a + pop b! inx h! inx d! jmp copy$dir1 +copy$dir2: + push d ; Save length for later + mvi b,0 ; double index to bc + lhld info ; hl = source for data + dad b + inx h! mov a,m! sui '$'! cz set$submit$flag + dcx h! xchg ; de=.fcb(c), source for copy + call getdptra ; hl=.buff(dptr), destination + pop b ; de=source, hl=dest, c=length + ret + +set$submit$flag: + lxi d,ccp$flgs! ldax d! ori 1! stax d! ret + +check$wild: + ; Check for ? in file name or type + lhld info +check$wild0: ; entry point used by rename + call chk$wild! rnz + mvi a,9! jmp set$aret + +chk$wild: + mvi c,11 +chk$wild1: + inx h! mvi a,3fh! sub m! ani 7fh! rz + dcr c! jnz chk$wild1! ora a! ret + +copy$user$no: + lhld info! mov a,m! lxi b,dskmap + dad b! mov m,a! ret + +rename: + ; Rename the file described by the first half of + ; the currently addressed file control block. The + ; new name is contained in the last half of the + ; currently addressed file control block. The file + ; name and type are changed, but the reel number + ; is ignored. The user number is identical. + + ; Verify that the new file name does not exist. + ; Also verify that no wild chars exist in + ; either filename. + +if MPM + call getatts! sta attributes +endif + + ; Verify that no wild chars exist in 1st filename. + call check$wild + +if BANKED + ; Check password of file to be renamed. + call chk$password! cnz chk$pw$error + ; Setup search to scan for xfcbs. + call init$xfcb$search +endif + + ; Copy user number to 2nd filename + call copy$user$no + shld searcha + + ; Verify no wild chars exist in 2nd filename + call check$wild0 + + ; Verify new filename does not already exist + mvi c,extnum! lhld searcha! call searchi1! call search1 + jnz file$exists ; New filename exists + +if BANKED + ; If an xfcb exists for the new filename, delete it. + call does$xfcb$exist! cnz delete11 +endif + + call copy$user$no + +if BANKED + call init$xfcb$search +endif + + ; Search up to the extent field + call search$extnum + rz + call check$rodir ; may be r/o file + +if MPM + call chk$olist +endif + + ; Copy position 0 + rename0: + ; not end of directory, rename next element + mvi c,dskmap! mvi e,extnum! call copy$dir + ; element renamed, move to next + + call fix$hash + call searchn + jnz rename0 + rename1: + +if BANKED + call does$xfcb$exist! jz copy$dir$loc + call copy$user$no! jmp rename0 +else + jmp copy$dir$loc +endif + +indicators: + ; Set file indicators for current fcb + call get$atts ; Clear f5' through f8' + sta attributes + +if BANKED + call chk$password! cnz chk$pw$error +endif + + call search$extnum ; through file type + rz + +if MPM + call chk$olist +endif + + indic0: + ; not end of directory, continue to change + mvi c,0! mvi e,extnum ; Copy name + call copy$dir2! call move + lda attributes! ani 40h! jz indic1 + + ; If interface att f6' set, dir fcb(s1) = fcb(cr) + + push h! call getfcba! mov a,m + pop h! inx h! mov m,a + indic1: + call seek$copy + call searchn + jz copy$dir$loc + jmp indic0 + +open: + ; Search for the directory entry, copy to fcb +;;; call search$namlen ;[JCE] DRI Patch 13 + call patch$1e3e +open1: + rz ; Return with lret=255 if end + ; not end of directory, copy fcb information +open$copy: + call setfwf! mov e,a! push h! dcx h! dcx h + mov d,m! push d ; Save extent# & module# with fcb write flag set + call getdptra! xchg ; hl = .buff(dptr) + lhld info ; hl=.fcb(0) + mvi c,nxtrec ; length of move operation + call move ; from .buff(dptr) to .fcb(0) + ; Note that entire fcb is copied, including indicators + call get$dir$ext! mov c,a + ; Restore module # and extent # + pop d! pop h! mov m,e! dcx h! dcx h! mov m,d + ; hl = .user extent#, c = dir extent# + ; above move set fcb(reccnt) to dir(reccnt) + ; if fcb ext < dir ext then fcb(reccnt) = fcb(reccnt) | 128 + ; if fcb ext = dir ext then fcb(reccnt) = fcb(reccnt) + ; if fcb ext > dir ext then fcb(reccnt) = 0 + +set$rc: ; hl=.fcb(ext), c=dirext + mvi b,0 + xchg! lxi h,(reccnt-extnum)! dad d + ; Is fcb ext = dirext? + ldax d! sub c! jz set$rc2 ; yes + ; Is fcb ext > dirext? + mov a,b! jnc set$rc1 ; yes - fcb(rc) = 0 + ; fcb ext < dirext + ; fcb(rc) = 128 | fcb(rc) + mvi a,128! ora m + set$rc1: + mov m,a! ret + set$rc2: + ; fcb ext = dirext + mov a,m! ora a! rnz ; ret if fcb(rc) ~= 0 + set$rc3: + mvi m,0 ; required by function 99 + lda dminx! ora a! rz ; ret if no blks in fcb + mvi m,128! ret ; fcb(rc) = 128 + +mergezero: + ; hl = .fcb1(i), de = .fcb2(i), + ; if fcb1(i) = 0 then fcb1(i) := fcb2(i) + mov a,m! inx h! ora m! dcx h! rnz ; return if = 0000 + ldax d! mov m,a! inx d! inx h ; low byte copied + ldax d! mov m,a! dcx d! dcx h ; back to input form + ret + +restore$rc: + ; hl = .fcb(extnum) + ; if fcb(rc) > 80h then fcb(rc) = fcb(rc) & 7fh + push h + lxi d,(reccnt-extnum)! dad d + mov a,m! cpi 81h! jc restore$rc1 + ani 7fh! mov m,a +restore$rc1: + pop h! ret + +close: + ; Locate the directory element and re-write it + xra a! sta lret + +if MPM + sta dont$close +endif + + call nowrite! rnz ; Skip close if r/o disk + ; Check file write flag - 0 indicates written + call getmodnum ; fcb(modnum) in a + ani fwfmsk! rnz ; Return if bit remains set +close1: + call chk$inv$fcb! jz mergerr + +if MPM + call set$fcb$cks$flag +endif + +;;; call get$dir$ext + call patch$1dfd ;[JCE] DRI patch 7 + + mov c,a + mov b,m + push b + ; b = original extent, c = directory extent + ; Set fcb(ex) to directory extent + mov m,c + ; Recompute fcb(rc) + call restore$rc + ; Call set$rc if fcb ext > dir ext + mov a,c! cmp b! cc set$rc + call close$fcb + ; Restore original extent & reset fcb(rc) + call get$exta! pop b + mov c,m! mov m,b! jmp set$rc ; Reset fcb(rc) + +close$fcb: + ; Locate file + call search$namlen + rz ; Return if not found + ; Merge the disk map at info with that at buff(dptr) + lxi b,dskmap! call get$fcb$adds + mvi c,(fcblen-dskmap) ; length of single byte dm + merge0: + lda single! ora a! jz merged ; Skip to double + ; This is a single byte map + ; if fcb(i) = 0 then fcb(i) = buff(i) + ; if buff(i) = 0 then buff(i) = fcb(i) + ; if fcb(i) <> buff(i) then error + mov a,m! ora a! ldax d! jnz fcbnzero + ; fcb(i) = 0 + mov m,a ; fcb(i) = buff(i) + fcbnzero: + ora a! jnz buffnzero + ; buff(i) = 0 + mov a,m! stax d ; buff(i)=fcb(i) + buffnzero: + cmp m! jnz mergerr ; fcb(i) = buff(i)? + jmp dmset ; if merge ok + merged: + ; This is a double byte merge operation + call mergezero ; buff = fcb if buff 0000 + xchg! call mergezero! xchg ; fcb = buff if fcb 0000 + ; They should be identical at this point + ldax d! cmp m! jnz mergerr ; low same? + inx d! inx h ; to high byte + ldax d! cmp m! jnz mergerr ; high same? + ; merge operation ok for this pair + dcr c ; extra count for double byte + dmset: + inx d! inx h ; to next byte position + dcr c! jnz merge0 ; for more + ; end of disk map merge, check record count + ; de = .buff(dptr)+32, hl = .fcb(32) + + xchg! lxi b,-(fcblen-extnum)! dad b! push h + call get$dir$ext! pop d + + ; hl = .fcb(extnum), de = .buff(dptr+extnum) + + call compare$extents + + ; b=1 -> fcb(ext) ~= dir ext = buff(ext) + ; b=2 -> fcb(ext) = dir ext ~= buff(ext) + ; b=3 -> fcb(ext) = dir ext = buff(ext) + + ; fcb(ext), buff(ext) = dir ext + mov m,a! stax d! push b + + lxi b,(reccnt-extnum)! dad b! xchg! dad b + pop b + + ; hl = .buff(rc) , de = .fcb(rc) + + dcr b! jz mrg$rc1 ; fcb(rc) = buff(rc) + + dcr b! jz mrg$rc2 ; buff(rc) = fcb(rc) + + ldax d! cmp m! jc mrg$rc1 ; Take larger rc + ora a! jnz mrg$rc2 + call set$rc3 + + mrg$rc1: xchg + + mrg$rc2: ldax d! mov m,a + +if MPM + lda dont$close! ora a! rnz +endif + + ; Set t3' off indicating file update + call getdptra! lxi d,11! dad d + mov a,m! ani 7fh! mov m,a + call setfwf + mvi c,1! call scandm$b ; Set 2nd ALV vector + jmp seek$copy ; OK to "wrdir" here - 1.4 compat + ; ret + mergerr: + ; elements did not merge correctly + call make$fcb$inv + jmp lret$eq$ff + +compare$extents: + mvi b,1! cmp m! rnz + inr b! xchg! cmp m! xchg! rnz + inr b! ret + +set$xdcnt: + lxi h,0ffffh! shld xdcnt! ret + +set$dcnt$dblk: + lhld xdcnt +set$dcnt$dblk1: + mvi a,1111$1100b! ana l + mov l,a! dcx h! shld dcnt + +if MPM + lhld xdblk! shld dblk +endif + + ret + +if MPM + +sdcnt$eq$xdcnt: + lxi h,sdcnt! lxi d,xdcnt! mvi c,4 + jmp move +endif + +make: + ; Create a new file by creating a directory entry + ; then opening the file + +;;; lxi h,xdcnt ;[JCE] DRI Patch 13 + call patch$1e31 + + call test$ffff! cnz set$dcnt$dblk + + lhld info! push h ; Save fcb address, Look for E5 + lxi h,efcb! shld info ; info = .empty + mvi c,1 + + call searchi! call searchn + + ; zero flag set if no space + pop h ; Recall info address + shld info ; in case we return here + rz ; Return with error condition 255 if not found + +if BANKED + ; Return early if making an xfcb + lda make$xfcb! ora a! rnz +endif + + ; Clear the remainder of the fcb + ; Clear s1 byte + lxi d,13! dad d! mov m,d! inx h + ; Clear and save file write flag of modnum + mov a,m! push a! push h! ani 3fh! mov m,a! inx h + mvi a,1 + mvi c,fcblen-namlen ; number of bytes to fill + make0: + mov m,d! inx h! dcr c! jnz make0 + dcr a! mov c,d! cz get$dtba + ora a! mvi c,10! jz make0 + call setcdr ; may have extended the directory + ; Now copy entry to the directory + mvi c,0! lxi d,fcblen! call copy$dir0 + ; and restore the file write flag + pop h! pop a! mov m,a + ; and set the fcb write flag to "1" + call fix$hash + jmp setfwf + +open$reel: + ; Close the current extent, and open the next one + ; if possible. rmf is true if in read mode + +if BANKED + call reset$copy$cr$only +endif + + call getexta + mov a,m! mov c,a + inr c! call compext + jz open$reel3 + push h! push b + call close + pop b! pop h + lda lret! inr a! rz + mvi a,maxext! ana c! mov m,a ; Incr extent field + ; Advance to module & save + inx h! inx h! mov a,m! sta save$mod + jnz open$reel0 ; Jump if in same module + + open$mod: + ; Extent number overflow, go to next module + inr m ; fcb(modnum)=++1 + ; Module number incremented, check for overflow + + mov a,m! ani 3fh ; Mask high order bits + + jz open$r$err ; cannot overflow to zero + + ; otherwise, ok to continue with new module + open$reel0: + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + +;;; call search$namlen ;[JCE] DRI Patch 13 + call patch$1e3e ;Next extent found? + + jnz open$reel1 + ; end of file encountered + lda rmf! inr a ; 0ffh becomes 00 if read + jz open$r$err ; sets lret = 1 + ; Try to extend the current file + call make + ; cannot be end of directory + jz open$r$err ; with lret = 1 + +if MPM + call fix$olist$item + call set$fcb$cks$flag +endif + + jmp open$reel2 + open$reel1: + ; not end of file, open + call open$copy + +if MPM + call set$fcb$cks$flag +endif + + open$reel2: + +if not MPM + call set$lsn +endif + + call getfcb ; Set parameters + xra a! sta vrecord! jmp sta$ret ; lret = 0 + ; ret ; with lret = 0 + open$r$err: + ; Restore module and extent + call getmodnum! lda save$mod! mov m,a + dcx h! dcx h! mov a,m! dcr a! ani 1fh + mov m,a! jmp setlret1 ; lret = 1 + + open$reel3: + inr m ; fcb(ex) = fcb(ex) + 1 + call get$dir$ext! mov c,a + ; Is new extent beyond dir$ext? + cmp m! jnc open$reel4 ; no + dcr m ; fcb(ex) = fcb(ex) - 1 + ; Is this a read fx? + lda rmf! inr a! jz set$lret1 ; yes - Don't advance ext + inr m ; fcb(ex) = fcb(ex) + 1 + open$reel4: + call restore$rc + call set$rc! jmp open$reel2 + +seqdiskread: +diskread: ; (may enter from seqdiskread) + call tst$inv$fcb ; Check for valid fcb + mvi a,true! sta rmf ; read mode flag = true (open$reel) + +if MPM + sta dont$close +endif + + ; Read the next record from the current fcb + call getfcb ; sets parameters for the read +diskread0: + lda vrecord! lxi h,rcount! cmp m ; vrecord-rcount + ; Skip if rcount > vrecord + jc recordok + +if MPM + call test$disk$fcb! jnz diskread0 + lda vrecord +endif + + ; not enough records in the extent + ; record count must be 128 to continue + cpi 128 ; vrecord = 128? + jnz setlret1 ; Skip if vrecord<>128 + call open$reel ; Go to next extent if so + ; Check for open ok + lda lret! ora a! jnz setlret1 ; Stop at eof + recordok: + ; Arrive with fcb addressing a record to read + +if BANKED + call set$copy$cr$only +endif + + call index ; Z flag set if arecord = 0 + +if MPM + jnz recordok1 + call test$disk$fcb! jnz diskread0 +endif + + jz setlret1 ; Reading unwritten data + recordok1: + ; Record has been allocated, read it + call atran ; arecord now a disk address + call check$nprs + jc setfcb + jnz read$deblock + + call setdata + call seek ; to proper track,sector + +if BANKED + mvi a,1! call setbnkf +endif + + call rdbuff ; to dma address + jmp setfcb ; Replace parameter + +read$deblock: + lxi h,0! shld last$block + mvi a,1! call deblock$dta + jmp setfcb + +check$nprs: + ; + ; on exit, c flg -> no i/o operation + ; z flg & ~c flg -> direct(physical) i/o operation + ; ~z flg & ~c flg -> indirect(deblock) i/o operation + ; + ; Dir$cnt contains the number of 128 byte records + ; to transfer directly. This routine sets dir$cnt + ; when initiating a sequence of direct physical + ; i/o operations. Dir$cnt is decremented each + ; time check$nprs is called during such a sequence. + ; + ; Is direct transfer operation in progress? + lda blk$off! mov b,a + lda phy$msk! mov c,a! ana b! push a + lda dir$cnt! cpi 2! jc check$npr1 ; no + ; yes - Decrement direct record count + dcr a! sta dir$cnt + ; Are we at a new physical record? + pop a! stc! rnz ; no - ret with c flg set + ; Perform physical i/o operation + xra a! ret ; Return with z flag set and c flag reset +check$npr1: + ; Are we in mid-physical record? + pop a! jz check$npr11 ; no +check$npr1a: + ; Is phymsk = 0? + mov a,c! ora a! rz ; yes - Don't deblock +check$npr1b: + ; Deblocking required + ori 1! ret ; ret with z flg reset and c flg reset +check$npr11: + mov a,c! cma! mov d,a ; d = ~phy$msk + lxi h,vrecord + ; Is mult$num < 2? + lda mult$num! cpi 2! jc check$npr1a ; yes + add m! cpi 80h! jc check$npr2 + mvi a,80h +check$npr2: ; a = min(vrecord + mult$num),80h) = x + push b ; Save low(arecord) & blkmsk, phymsk + mov b,m! mvi m,7fh ; vrecord = 7f + push b ; Save vrecord + push h ; Save .vrecord + push a ; Save x + lda blkmsk! mov e,a! inr e! cma! ana b! mov b,a + ; b = vrecord & ~blkmsk + ; e = blkmsk + 1 + pop h ; h = x + ; Is this a read function? + lda rmf! ora a! jz check$npr21 ; no + ; Is rcount & ~phymsk < x? + lda rcount! ana d! cmp h! jc check$npr23 ; yes +check$npr21: + mov a,h ; a = x +check$npr23: + sub b ; a = a - vrecord & ~blkmsk + mov c,a ; c = max # of records from beginning of curr blk + ; Is c < blkmsk+1? + cmp e! jc check$npr8 ; yes + +if BANKED + push b ; c = max # of records + ; Compute maximum disk map position + call dm$position + mov b,a ; b = index of last block in extent + ; Does the last block # = the current block #? + lda dminx! cmp b! mov e,a! jz check$npr5 ; yes + ; Compute # of blocks in sequence + mov c,a! push b! mvi b,0 + call get$dm ; hl = current block # +check$npr4: + ; Get next block # + push h! inx b! call get$dm + pop d! inx d + ; Does next block # = previous block # + 1? + mov a,d! sub h! mov d,a + mov a,e! sub l! ora d! jz check$npr4 ; yes + ; Is next block # = 0? + mov a,h! ora l! jnz check$npr45 ; no + ; Is this a read function? + lda rmf! ora a! jnz check$npr45 ; no + ; Is next block # > maxall? + lhld maxall! mov a,l! sub e + mov a,h! sbb d! jc check$npr45 ; yes + ; Is next block # allocated? + push b! push d! mov b,d! mov c,e + call getallocbit! pop h! pop b + rar! jnc check$npr4 ; no - it will be later +check$npr45: + dcr c! pop d + ; Is max dm position less than c? + mov a,d! cmp c! jc check$npr5 ; yes + mov a,c ; no +check$npr5: ; a = index of last block + sub e! mov b,a! inr b ; b = # of consecutive blks + lda blkmsk! inr a! mov c,a +check$npr6: + dcr b! jz check$npr7 + add c! jmp check$npr6 +check$npr7: + pop b + mov b,c ; b = max # of records + mov c,a ; c = (# of consecutive blks)*(blkmsk+1) + lda rmf! ora a! jz check$npr8 + mov a,b! cmp c! jc check$npr9 +else + mov c,e ; multis-sector max = 1 block in non-banked systems +endif + +check$npr8: + mov a,c +check$npr9: + ; Restore vrecord + pop h! pop b! mov m,b + pop b + ; a = max # of consecutive records including current blk + ; b = low(arecord) & blkmsk + ; c = phymsk + ; Is mult$num > a - b + lxi h,mult$num! mov d,m + sub b! cmp d! jnc check$npr10 + mov d,a ; yes - use smaller value to compute dir$cnt +check$npr10: + ; Does this operation involve at least 1 physical record? + mov a,c! cma! ana d! sta dir$cnt! jz check$npr1b ; Deblocking required + ; Flush any pending buffers before doing multiple reads + push a! lda rmf! ora a! jz check$npr10a + call flushx! call setdata +check$npr10a: + pop a! mov h,a ; Save # of 128 byte records + ; Does this operation involve more than 1 physical record? + ; Register h contains number of 128 byte records + call shr$physhf! mov a,h + cpi 1! mov c,a! cnz mult$iof ; yes - Make bios call + xra a! ret ; Return with z flg set + +if MPM + +test$unlocked: + lda high$ext! ani 80h! ret + +test$disk$fcb: + call test$unlocked! rz + lda dont$close! ora a! rz + call close1 +test$disk$fcb1: + pop d + lxi h,lret! inr m! mvi a,11! jz sta$ret + mvi m,0 + push d + call getrcnta! mov a,m! sta rcount ; Reset rcount + xra a! sta dont$close + inr a! ret +endif + +reset$fwf: + call getmodnum ; hl=.fcb(modnum), a=fcb(modnum) + ; Reset the file write flag to mark as written fcb + ani (not fwfmsk) and 0ffh ; bit reset + mov m,a ; fcb(modnum) = fcb(modnum) and 7fh + ret + +set$filewf: + call getmodnum! ani 0100$0000b! push a + mov a,m! ori 0100$0000b! mov m,a! pop a! ret + +seqdiskwrite: +diskwrite: ; (may enter here from seqdiskwrite above) + mvi a,false! sta rmf ; read mode flag + ; Write record to currently selected file + + call check$write ; in case write protected + +if BANKED + lda xfcb$read$only! ora a + mvi a,3! jnz set$aret +endif + + lda high$ext + +if MPM + ani 0100$0000b +else + ora a +endif + + ; Z flag reset if r/o mode + mvi a,3! jnz set$aret + + lhld info ; hl = .fcb(0) + call check$rofile ; may be a read-only file + + call tst$inv$fcb ; Test for invalid fcb + + call update$stamp + + call getfcb ; to set local parameters + lda vrecord! cpi lstrec+1 ; vrecord-128 + jc diskwrite0 + call open$reel ; vrecord = 128, try to open next extent + lda lret! ora a! rnz ; no available fcb +disk$write0: + +if MPM + mvi a,0ffh! sta dont$close +disk$write1: + +endif + + ; Can write the next record, so continue + call index ; Z flag set if arecord = 0 + jz diskwrite2 + ; Was the last write operation for the same block & drive? + lxi h,adrive! lxi d,last$drive! mvi c,3 + call compare! jz diskwrite15 ; yes + ; no - force preread in blocking/deblocking + mvi a,0ffh! sta last$off +diskwrite15: + +if MPM + ; If file is unlocked, verify record is not locked + ; Record has to be allocated to be locked + call test$unlocked! jz not$unlocked + call atran! mov c,a + lda mult$cnt! mov b,a! push b + call test$lock! pop b + xra a! mov c,a! push b + jmp diskwr10 +not$unlocked: + inr a +endif + + mvi c,0 ; Marked as normal write operation for wrbuff + jmp diskwr1 +diskwrite2: + +if MPM + call test$disk$fcb! jnz diskwrite1 +endif + +if BANKED + call reset$copy$cr$only +endif + + ; not allocated + ; The argument to getblock is the starting + ; position for the disk search, and should be + ; the last allocated block for this file, or + ; the value 0 if no space has been allocated + call dm$position + sta dminx ; Save for later + lxi b,0000h ; May use block zero + ora a! jz nopblock ; Skip if no previous block + ; Previous block exists at a + mov c,a! dcx b ; Previous block # in bc + call getdm ; Previous block # to hl + mov b,h! mov c,l ; bc=prev block# + nopblock: + ; bc = 0000, or previous block # + call get$block ; block # to hl + ; Arrive here with block# or zero + mov a,l! ora h! jnz blockok + ; Cannot find a block to allocate + mvi a,2! jmp sta$ret ; lret=2 + blockok: + +if MPM + call set$fcb$cks$flag +endif + + ; allocated block number is in hl + shld arecord! shld last$block! xra a! sta last$off + lda adrive! sta lastdrive + xchg ; block number to de + lhld info! lxi b,dskmap! dad b ; hl=.fcb(dskmap) + lda single! ora a ; Set flags for single byte dm + lda dminx ; Recall dm index + jz allocwd ; Skip if allocating word + ; Allocating a byte value + call addh! mov m,e ; single byte alloc + jmp diskwru ; to continue + allocwd: + ; Allocate a word value + mov c,a! mvi b,0 ; double(dminx) + dad b! dad b ; hl=.fcb(dminx*2) + mov m,e! inx h! mov m,d ; double wd + diskwru: + ; disk write to previously unallocated block + mvi c,2 ; marked as unallocated write + diskwr1: + ; Continue the write operation of no allocation error + ; c = 0 if normal write, 2 if to prev unalloc block + push b ; Save write flag + call atran ; arecord set +diskwr10: + lda fx! cpi 40! jnz diskwr11 ; fx ~= wrt rndm zero fill + mov a,c! dcr a! dcr a! jnz diskwr11 ; old allocation + + ; write random zero fill + new block + + pop b! push a ; zero write flag + lhld arecord! push h + lxi h,phymsk! mov e,m! inr e! mov d,a! push d + lhld dirbcba + +if BANKED + mov e,m! inx h! mov d,m! xchg +fill00: + push h! call get$next$bcba! pop d! jnz fill00 + xchg +endif + + ; Force prereads in blocking/deblocking + ; Discard BCB + dcr a! sta last$off! mov m,a + call setdir1 ; Set dma to BCB buffer + ; Zero out BCB buffer + pop d! push d! xra a + fill0: + mov m,a! inx h! inr d! jp fill0 + mov d,a! dcr e! jnz fill0 + ; Write 1st physical record of block + lhld arecord1! mvi c,2 + fill1: + shld arecord! push b! call discard$data$bcb + call seek + +if BANKED + xra a! call setbnkf +endif + + pop b! call wrbuff + lhld arecord! pop d! push d + ; Continue writing until blkmsk & arecord = 0 + dad d! lda blkmsk! ana l! mvi c,0! jnz fill1 + ; Restore arecord + pop h! pop h! shld arecord + + call setdata ; Restore dma + diskwr11: + + pop d! lda vrecord! mov d,a ; Load and save vrecord + push d! call check$nprs + + jc dont$write + jz write + + mvi a,2 ; deblock write code + call deblock$dta + jmp dont$write +write: + call setdata + call seek + +if BANKED + mvi a,1! call setbnkf +endif + + ; Discard matching BCB if write is direct + call discard$data$bcb + + ; Set write flag to zero if arecord & blkmsk ~= 0 + + pop b! push b! lda arecord + lxi h,blkmsk! ana m! jz write0 + mvi c,0 +write0: + call wrbuff + +dont$write: + pop b ; c = 2 if a new block was allocated, 0 if not + ; Increment record count if rcount<=vrecord + mov a,b! lxi h,rcount! cmp m ; vrecord-rcount + jc diskwr2 + ; rcount <= vrecord + mov m,a! inr m ; rcount = vrecord+1 + +if MPM + call test$unlocked! jz write1 + + ; for unlocked files + ; rcount = rcount & (~ blkmsk) + blkmsk + 1 + + lda blkmsk! mov b,a! inr b! cma! mov c,a + mov a,m! dcr a! ana c! add b! mov m,a + write1: +endif + + mvi c,2 ; Mark as record count incremented + diskwr2: + ; a has vrecord, c=2 if new block or new record# + dcr c! dcr c! jnz noupdate + call reset$fwf + +if MPM + call test$unlocked! jz noupdate + lda rcount! call getrcnta! mov m,a + call close + call test$disk$fcb1 +endif + +noupdate: + ; Set file write flag if reset + call set$filewf + +if BANKED + jnz disk$write3 + ; Reset fcb file write flag to ensure t3' gets + ; reset by the close function + call reset$fwf + call reset$copy$cr$only + jmp setfcb +disk$write3: + call set$copy$cr$only +else + cz reset$fwf +endif + jmp setfcb ; Replace parameters + ; ret + +rseek: + ; Random access seek operation, c=0ffh if read mode + ; fcb is assumed to address an active file control block + ; (1st block of FCB = 0ffffh if previous bad seek) + push b ; Save r/w flag + lhld info! xchg ; de will hold base of fcb + lxi h,ranrec! dad d ; hl=.fcb(ranrec) + mov a,m! ani 7fh! push psw ; record number + mov a,m! ral ; cy=lsb of extent# + inx h! mov a,m! ral! ani 11111b ; a=ext# + mov c,a ; c holds extent number, record stacked + + mov a,m! ani 1111$0000b! inx h! ora m + rrc! rrc! rrc! rrc! mov b,a + ; b holds module # + + ; Check high byte of ran rec <= 3 + mov a,m + ani 1111$1100b! pop h! mvi l,6! mov a,h + + ; Produce error 6, seek past physical eod + jnz seekerr + + ; otherwise, high byte = 0, a = sought record + lxi h,nxtrec! dad d ; hl = .fcb(nxtrec) + mov m,a ; sought rec# stored away + + ; Arrive here with b=mod#, c=ext#, de=.fcb, rec stored + ; the r/w flag is still stacked. compare fcb values + + lda fx! cpi 99! jz rseek3 + ; Check module # first + push d! call chk$inv$fcb! pop d! jz ranclose + lxi h,modnum! dad d! mov a,b ; b=seek mod# + sub m! ani 3fh! jnz ranclose ; same? + ; Module matches, check extent + lxi h,extnum! dad d + mov a,m! cmp c! jz seekok2 ; extents equal + call compext! jnz ranclose + ; Extent is in same directory fcb + push b! call get$dir$ext! pop b + cmp c! jnc rseek2 ; jmp if dir$ext > ext + pop d! push d! inr e! jnz rseek2 ; jmp if write fx + inr e! pop d! jmp set$lret1 ; error - reading unwritten data + rseek2: + mov m,c ; fcb(ext) = c + mov c,a ; c = dir$ext + ; hl=.fcb(ext),c=dir ext + call restore$rc + call set$rc + jmp seekok1 + ranclose: + push b! push d ; Save seek mod#,ext#, .fcb + call close ; Current extent closed + pop d! pop b ; Recall parameters and fill + mvi l,3 ; Cannot close error #3 + lda lret! inr a! jz seekerr + rseek3: + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + + lxi h,extnum! dad d! push h + mov d,m! mov m,c ; fcb(extnum)=ext# + inx h! inx h! mov a,m! mov e,a! push d + ani 040h! ora b! mov m,a + ; fcb(modnum)=mod# + call open ; Is the file present? + lda lret! inr a! jnz seekok ; Open successful? + ; Cannot open the file, read mode? + pop d! pop h! pop b ; r/w flag to c (=0ffh if read) + push b! push h! push d ; Restore stack + mvi l,4 ; Seek to unwritten extent #4 + inr c ; becomes 00 if read operation + jz badseek ; Skip to error if read operation + ; Write operation, make new extent + call make + mvi l,5 ; cannot create new extent #5 + jz badseek ; no dir space + +if MPM + call fix$olist$item +endif + + ; file make operation successful + seekok: + pop b! pop b ; Discard top 2 stacked items + +if MPM + call set$fcb$cks$flag +else + call set$lsn +endif + + seekok1: + +if BANKED + call reset$copy$cr$only +endif + + seekok2: + pop b ; Discard r/w flag or .fcb(ext) + xra a! jmp sta$ret ; with zero set + badseek: + ; Restore fcb(ext) & fcb(mod) + pop d! xthl ; Save error flag + mov m,d! inx h! inx h! mov m,e + pop h ; Restore error flag + seekerr: + +if BANKED + call reset$copy$cr$only ; Z flag set + inr a ; Reset Z flag +endif + + pop b ; Discard r/w flag + mov a,l! jmp sta$ret ; lret=#, nonzero + +randiskread: + ; Random disk read operation + mvi c,true ; marked as read operation + call rseek + cz diskread ; if seek successful + ret + +randiskwrite: + ; Random disk write operation + mvi c,false ; marked as write operation + call rseek + cz diskwrite ; if seek successful + ret + +compute$rr: + ; Compute random record position for getfilesize/setrandom + xchg! dad d + ; de=.buf(dptr) or .fcb(0), hl = .f(nxtrec/reccnt) + mov c,m! mvi b,0 ; bc = 0000 0000 ?rrr rrrr + lxi h,extnum! dad d! mov a,m! rrc! ani 80h ; a=e000 0000 + add c! mov c,a! mvi a,0! adc b! mov b,a + ; bc = 0000 000? errrr rrrr + mov a,m! rrc! ani 0fh! add b! mov b,a + ; bc = 000? eeee errrr rrrr + lxi h,modnum! dad d! mov a,m ; a=xxmm mmmm + add a! add a! add a! add a ; cy=m a=mmmm 0000 + + ora a! add b! mov b,a! push psw ; Save carry + mov a,m! rar! rar! rar! rar! ani 0000$0011b ; a=0000 00mm + mov l,a! pop psw! mvi a,0! adc l ; Add carry + ret + +compare$rr: + mov e,a ; Save cy + mov a,c! sub m! mov d,a! inx h ; lst byte + mov a,b! sbb m! inx h ; middle byte + push a! ora d! mov d,a! pop a + mov a,e! sbb m ; carry if .fcb(ranrec) > directory + ret + +set$rr: + mov m,e! dcx h! mov m,b! dcx h! mov m,c! ret + +getfilesize: + ; Compute logical file size for current fcb + ; Zero the receiving ranrec field + call get$rra! push h ; Save position + mov m,d! inx h! mov m,d! inx h! mov m,d ; =00 00 00 + call search$extnum + getsize: + jz setsize + ; current fcb addressed by dptr + call getdptra! lxi d,reccnt ; ready for compute size + call compute$rr + ; a=0000 00mm bc = mmmm eeee errr rrrr + ; Compare with memory, larger? + pop h! push h ; Recall, replace .fcb(ranrec) + call compare$rr! cnc set$rr + call searchn + mvi a,0! sta aret + jmp getsize + setsize: + + pop h ; Discard .fcb(ranrec) + ret + +setrandom: + ; Set random record from the current file control block + xchg! lxi d,nxtrec ; Ready params for computesize + call compute$rr ; de=info, a=0000 00mm, bc=mmmm eeee errr rrrr + lxi h,ranrec! dad d ; hl = .fcb(ranrec) + mov m,c! inx h! mov m,b! inx h! mov m,a ; to ranrec + ret + +disk$select: + ; Select disk info for subsequent input or output ops + sta adrive +disk$select1: ; called by deblock + mov m,a ; curdsk = seldsk or adrive + mov d,a ; Save seldsk in register D for selectdisk call + lhld dlog! call test$vector ; test$vector does not modify DE + mov e,a! push d ; Send to seldsk, save for test below + call selectdisk! pop h ; Recall dlog vector + jnc sel$error ; returns with C flag set if select ok + ; Is the disk logged in? + dcr l ; reg l = 1 if so + ret + +tmpselect: + lxi h,seldsk! mov m,e + +curselect: + lda seldsk! lxi h,curdsk! cmp m! jnz select + cpi 0ffh! rnz ; return if seldsk ~= ffh + +select: + call disk$select + +if MPM + jnz select1 ; no + ; yes - drive previously logged in + lhld rlog! call test$vector + sta rem$drv! ret ; Set rem$drv & return +select1: + +else + rz ; yes - drive previously logged in +endif + + call initialize ; Log in the directory + + ; Increment login sequence # if odd + lhld lsn$add! mov a,m! ani 1! push a! add m! mov m,a + pop a! cnz set$rlog + + call set$dlog + +if MPM + lxi h,chksiz+1! mov a,m! ral! mvi a,0! jc select2 + lxi d,rlog! call set$cdisk ; rlog=set$cdisk(rlog) + mvi a,1 +select2: + sta rem$drv +endif + + ret + +reselectx: + xra a! sta high$ext + +if BANKED + sta xfcb$read$only +endif + + jmp reselect1 + +reselect: + ; Check current fcb to see if reselection necessary + lxi b,807fh + lhld info! lxi d,7! xchg! dad d + +if BANKED + ; xfcb$read$only = 80h & fcb(7) + mov a,m! ana b! sta xfcb$read$only + ; fcb(7) = fcb(7) & 7fh + mov a,m! ana c! mov m,a +endif + +if MPM + ; if fcb(8) & 80h + ; then fcb(8) = fcb(8) & 7fh, high$ext = 60h + ; else high$ext = fcb(ext) & 0e0h + inx h! lxi d,4 + mov a,m! ana c! cmp m! mov m,a! mvi a,60h! jnz reselect0 + dad d! mvi a,0e0h! ana m +reselect0: + sta high$ext +else + ; high$ext = 80h & fcb(8) + inx h! mov a,m! ana b! sta high$ext + ; fcb(8) = fcb(8) & 7fh + mov a,m! ana c! mov m,a +endif + + ; fcb(ext) = fcb(ext) & 1fh + call clr$ext +reselect1: + + lxi h,0 + +if BANKED + shld make$xfcb ; make$xfcb,find$xfcb = 0 +endif + shld xdcnt ; required by directory hashing + + xra a! sta search$user0 + dcr a! sta resel ; Mark possible reselect + lhld info! mov a,m ; drive select code + sta fcbdsk ; save drive code + ani 1$1111b ; non zero is auto drive select + dcr a ; Drive code normalized to 0..30, or 255 + sta linfo ; Save drive code + cpi 0ffh! jz noselect + ; auto select function, seldsk saved above + sta seldsk + noselect: + call curselect + ; Set user code + lda usrcode ; 0...15 + lhld info! mov m,a + noselect0: + ; Discard directory BCB's if drive is removable + ; and fx = 15,17,19,22,23,30 etc. + call tst$log$fxs! cz discard$dir + ; Check for media change on currently slected disk + call check$media + ; Check for media change on any other disks + jmp check$all$media + +check$media: + ; Check media if DPH media flag set. + ; Is DPH media flag set? + call test$media$flag! rz ; no + ; Test for media change by reading directory + ; to current high water mark or until media change + ; is detected. + ; First reset DPH media flag & discard directory BCB's + mvi m,0 + call discard$dir + lhld dcnt! push h + call home! call set$end$dir +check$media1: + mvi c,false! call r$dir + lxi h,relog! mov a,m! ora a! jz check$media2 + mvi m,0! pop h! lda fx! cpi 48! rz + call drv$relog! jmp chk$exit$fxs +check$media2: + call comp$cdr! jc check$media1 + pop h! shld dcnt! ret + +check$all$media: + ; This routine checks all logged-in drives for + ; a set DPH media flag and pending buffers. It reads + ; the directory for these drives to verify that media + ; has not changed. If media has changed, the drives + ; get reset (but not relogged-in). + ; Is SCB media flag set? + lxi h,media$flag! mov a,m! ora a! rz ; no + ; Reset SCB media flag + mvi m,0 + ; Test logged-in drives only + lhld dlog! mvi a,16 +chk$am1: + dcr a! dad h! jnc chk$am2 + ; A = drive # + ; Select drive + push a! push h! lxi h,curdsk! call disk$select + ; Does drive have pending data buffers? + call test$pending! cnz check$media ; yes + pop h! pop a +chk$am2: + ora a! jnz chk$am1 + jmp curselect + +test$pending: + ; On return, Z flag reset if buffer pending + + ; Does dta$bcba = 0ffffh + lhld dta$bcba! mov a,l! ana h! inr a! rz ; yes + +if BANKED + +test$p1: + ; Does bcb addr = 0? + mov e,m! inx h! mov d,m + mov a,e! ora d! rz ; yes - no pending buffers + lxi h,4 +else + lxi d,4 +endif + + ; Is buffer pending? + dad d! mov a,m! ora a ; A ~= 0 if so + +if BANKED + rnz ; yes + ; no - advance to next bcb + lxi h,13! dad d! jmp test$p1 +else + ret +endif + +get$dir$mode: + lhld drvlbla! mov a,m + +if not BANKED + ani 7fh ; Mask off password bit +endif + + ret + +if BANKED + +chk$password: + call get$dir$mode! ani 80h! rz + +chk$pw: ; Check password + call get$xfcb! rz ; a = xfcb options + jmp cmp$pw + +chk$pw$error: + ; Disable special searches + xra a! sta xdcnt+1 + ; pw$fcb = dir$xfcb + call getdptra! xchg + mvi c,12! lxi h,pw$fcb! push h + call move! ldax d! inx h! mov m,a! pop d + lhld info! mov a,m! stax d + ; push original info and xfcb password mode + ; info = .pw$fcb + push h! xchg! shld info + ; Does fcb(ext = 0, mod = 0) exist? + call search$namlen! jz chk$pwe2 ; no + ; Does sfcb exist for fcb ? + call get$dtba$8! ora a! jnz chk$pwe1 ; no + xchg! lxi h,pw$mode + ; Is sfcb password mode nonzero? + mov b,m! ldax d! mov m,a! ora a! jz chk$pwe2 ; no + ; Do password modes match? + xra b! ani 0e0h! jz chk$pwe1 ; yes + ; no - update xfcb to match sfcb + call get$xfcb! jz chk$pwe1 ; no xfcb (error) + lda pw$mode! mov m,a! call nowrite! cz seek$copy +chk$pwe1: + pop h! shld info + lda fx! cpi 15! rz! cpi 22! rz + +pw$error: ; password error + mvi a,7! jmp set$aret + +chk$pwe2: + xra a! sta pw$mode + call nowrite! jnz chk$pwe3 + ; Delete xfcb + call get$xfcb! push a + lhld info! mov a,m! ori 10h! mov m,a + pop a! cnz delete$10 +chk$pwe3: + ; Restore info + pop h! shld info! ret + +cmp$pw: ; Compare passwords + inx h! mov b,m + mov a,b! ora a! jnz cmp$pw2 + mov d,h! mov e,l! inx h! inx h + mvi c,9 +cmp$pw1: + inx h! mov a,m! dcr c! rz + ora a! jz cmp$pw1 + cpi 20h! jz cmp$pw1 + xchg +cmp$pw2: + lxi d,(23-ubytes)! dad d! xchg + lhld xdmaad! mvi c,8 +cmp$pw3: + ldax d! xra b! cmp m! jnz cmp$pw4 + dcx d! inx h! dcr c! jnz cmp$pw3 + ret +cmp$pw4: + dcx d! dcr c! jnz cmp$pw4 + inx d + +if MPM + call get$df$pwa! inr a! jnz cmp$pw5 + inr a! ret +cmp$pw5: + +else + lxi h,df$password +endif + + mvi c,8! jmp compare + +if MPM + +get$df$pwa: ; a = ff => no df pwa + call rlr! lxi b,console! dad b + mov a,m! cpi 16! mvi a,0ffh! rnc + mov a,m! add a! add a! add a + mvi h,0! mov l,a! lxi b,dfpassword! dad b + ret +endif + +set$pw: ; Set password in xfcb + push h ; Save .xfcb(ex) + lxi b,8 ; b = 0, c = 8 + lxi d,(23-extnum)! dad d + xchg! lhld xdmaad +set$pw0: + xra a! push a +set$pw1: + mov a,m! stax d! ora a! jz set$pw2 + cpi 20h! jz set$pw2 + inx sp! inx sp! push a +set$pw2: + add b! mov b,a + dcx d! inx h! dcr c! jnz set$pw1 + pop a! ora b! pop h! jnz set$pw3 + ; is fx = 100 (directory label)? + lda fx! cpi 100! jz set$pw3 ; yes + mvi m,0 ; zero xfcb(ex) - no password +set$pw3: + inx d! mvi c,8 +set$pw4: + ldax d! xra b! stax d! inx d! dcr c! jnz set$pw4 + inx h! ret + +get$xfcb: + lhld info! mov a,m! push a + ori 010h! mov m,a + call search$extnum! mvi a,0! sta lret + lhld info! pop b! mov m,b! rz +get$xfcb1: + call getdptra! xchg + lxi h,extnum! dad d! mov a,m! ani 0e0h! ori 1 + ret + +adjust$dmaad: + push h! lhld xdmaad! dad d + shld xdmaad! pop h! ret + +init$xfcb: + call setcdr ; may have extended the directory + lxi b,1014h ; b=10h, c=20 +init$xfcb0: + ; b = fcb(0) logical or mask + ; c = zero count + push b + call getdptra! xchg! lhld info! xchg + ; Zero extnum and modnum + ldax d! ora b! mov m,a! inx d! inx h + mvi c,11! call move! pop b! inr c +init$xfcb1: + dcr c! rz + mvi m,0! inx h! jmp init$xfcb1 + +chk$xfcb$password: + call get$xfcb1 +chk$xfcb$password1: + push h! call cmp$pw! pop h! ret + +endif + +stamp1: + mvi c,0! jmp stamp3 +stamp2: + mvi c,4 +stamp3: + call get$dtba! ora a! rnz + lxi d,seek$copy! push d +stamp4: + +if MPM + push h + call get$stamp$add! xchg + pop h +else + lxi d,stamp +endif + + push h! push d + mvi c,0! call timef ; does not modify hl,de + mvi c,4! call compare + mvi c,4! pop d! pop h! jnz move + pop h! ret + +stamp5: + call getdptra! dad b! lxi d,func$ret! push d + jmp stamp4 + +if BANKED + +get$dtba$8: + mvi c,8 +endif + +get$dtba: + ; c = offset of sfcb subfield (0,4,8) + ; Return with a = 0 if sfcb exists + + ; Does fcb occupy 4th item of sector? + lda dcnt! ani 3! cpi 3! rz ; yes + mov b,a + lhld buffa! lxi d,96! dad d + ; Does sfcb reside in 4th directory item? + mov a,m! sui 21h! rnz ; no + ; hl = hl + 10*lret + 1 + c + mov a,b! add a! mov e,a! add a! add a! add e + inr a! add c! mov e,a! dad d! xra a + ret + +qstamp: + ; Is fcb 1st logical fcb for file? + call qdirfcb1! rnz ; no +qstamp1: + ; Does directory label specify requested stamp? + lhld drvlbla! mov a,c! ana m! jnz nowrite ; yes - verify drive r/w + inr a! ret ; no - return with Z flag reset + +qdirfcb1: + ; Routine to determine if fcb is 1st directory fcb + ; for file + ; Is fcb(ext) & ~extmsk & 00011111b = 0? + lda extmsk! ori 1110$0000b! cma! mov b,a + call getexta! mov a,m! ana b! rnz ; no + ; is fcb(mod) & 0011$1111B = 0? + inx h! inx h! mov a,m! ani 3fh! ret ; Z flag set if zero + +update$stamp: + ; Is update stamping requested on drive? + mvi c,0010$0000b! call qstamp1! rnz ; no + ; Has file been written to since it was opened? + call getmodnum! ani 40h! rnz ; yes - update stamp performed + ; Search for 1st dir fcb + call getexta! mov b,m! mvi m,0! push h + inx h! inx h! mov c,m! mvi m,0! push b + ; Search from beginning of directory + call search$namlen + ; Perform update stamp if dir fcb 1 found + cnz stamp2 + xra a! sta lret + ; Restore fcb extent and module fields + pop b! pop h! mov m,b! inx h! inx h! mov m,c! ret + +if MPM + +pack$sdcnt: + +;packed$dcnt = dblk(low 15 bits) || dcnt(low 9 bits) + +; if sdblk = 0 then dblk = shr(sdcnt,blkshf+2) +; else dblk = sdblk +; dcnt = sdcnt & (blkmsk || '11'b) +; +; packed$dcnt format (24 bits) +; +; 12345678 12345678 12345678 +; 23456789 .......1 ........ sdcnt (low 9 bits) +; ........ 9abcdef. 12345678 sdblk (low 15 bits) +; + lhld sdblk! mov a,h! ora l! jnz pack$sdcnt1 + lda blkshf! adi 2! mov c,a! lhld sdcnt + call hlrotr +pack$sdcnt1: + dad h! xchg! lxi h,sdcnt! mvi b,1 + lda blkmsk! ral! ora b! ral! ora b + ana m! sta packed$dcnt + lda blkshf! cpi 7! jnz pack$sdcnt2 + inx h! mov a,m! ana b! jz pack$sdcnt2 + mov a,e! ora b! mov e,a +pack$sdcnt2: + xchg! shld packed$dcnt+1 + ret + +; olist element = link(2) || atts(1) || dcnt(3) || +; pdaddr(2) || opncnt(2) +; +; link = 0 -> end of list +; +; atts - 80 - open in locked mode +; 40 - open in unlocked mode +; 20 - open in read/only mode +; 10 - deleted item +; 0n - drive code (0-f) +; +; dcnt = packed sdcnt+sdblk +; pdaddr = process descriptor addr +; opncnt = # of open calls - # of close calls +; olist item freed by close when opncnt = 0 +; +; llist element = link(2) || drive(1) || arecord(3) || +; pdaddr(2) || .olist$item(2) +; +; link = 0 -> end of list +; +; drive - 0n - drive code (0-f) +; +; arecord = record number of locked record +; pdaddr = process descriptor addr +; .olist$item = address of file's olist item + +search$olist: + lxi h,open$root! jmp srch$list0 +search$llist: + lxi h,lock$root! jmp srch$list0 +searchn$list: + lhld cur$pos +srch$list0: + shld prv$pos + +; search$olist, search$llist, searchn$list conventions +; +; b = 0 -> return next item +; b = 1 -> search for matching drive +; b = 3 -> search for matching dcnt +; b = 5 -> search for matching dcnt + pdaddr +; if found then z flag is set +; prv$pos -> previous list element +; cur$pos -> found list element +; hl -> found list element +; else prv$pos -> list element to insert after +; +; olist and llist are maintained in drive order + +srch$list1: + mov e,m! inx h! mov d,m! xchg + mov a,l! ora h! jz srch$list3 + xra a! cmp b! jz srch$list6 + inx h! inx h! + lxi d,curdsk! mov a,m! ani 0fh! mov c,a + ldax d! sub c! jnz srch$list4 + mov a,b! dcr a! jz srch$list5 + mov c,b! push h + inx d! inx h! call compare + pop h! jz srch$list5 +srch$list2: + dcx h! dcx h + shld prv$pos! jmp srch$list1 +srch$list3: + inr a! ret +srch$list4: + jnc srch$list2 +srch$list5: + dcx h! dcx h +srch$list6: + shld cur$pos! ret + +delete$item: ; hl -> item to be deleted + di + push d! push h + mov e,m! inx h! mov d,m + lhld prv$pos! shld cur$pos + ; prv$pos.link = delete$item.link + mov m,e! inx h! mov m,d + + lhld free$root! xchg + ; free$root = .delete$item + pop h! shld free$root + ; delete$item.link = previous free$root + mov m,e! inx h! mov m,d + pop d! ei! ret + +create$item: ; hl -> new item if successful + ; z flag set if no free items + lhld free$root! mov a,l! ora h! rz + push d! push h! shld cur$pos + mov e,m! inx h! mov d,m + ; free$root = free$root.link + xchg! shld free$root + + lhld prv$pos + mov e,m! inx h! mov d,m + pop h + ; create$item.link = prv$pos.link + mov m,e! inx h! mov m,d! dcx h + xchg! lhld prv$pos + ; prv$pos.link = .create$item + mov m,e! inx h! mov m,d! xchg + pop d! ret + +set$olist$item: + ; a = attributes + ; hl = olist entry address + inx h! inx h + mov b,a! lxi d,curdsk! ldax d! ora b + mov m,a! inx h! inx d + mvi c,5! call move + xra a! mov m,a! inx h! mov m,a! ret + +set$sdcnt: + mvi a,0ffh! sta sdcnt+1! ret + +tst$olist: + mvi a,0c9h! sta chk$olist05! jmp chk$olist0 +chk$olist: + xra a! sta chk$olist05 +chk$olist0: + lxi d,dcnt! lxi h,sdcnt! mvi c,4! call move + call pack$sdcnt! mvi b,3! call search$olist! rnz + pop d ; pop return address + inx h! inx h + mov a,m! ani 80h! jz openx06 + dcx h! dcx h + push d! push h + call compare$pds! pop h! pop d! jnz openx06 + push d ; Restore return address +chk$olist05: + nop ; tst$olist changes this instr to ret + call delete$item! lda pdcnt +chk$olist1: + adi 16! jz chk$olist1 + sta pdcnt + + push a! call rlr + lxi b,pdcnt$off! dad b! pop a + mov m,a! ret + +remove$files: ; bc = pdaddr + lhld cur$pos! push h + lhld prv$pos! push h + mov d,b! mov e,c! lxi h,open$root! shld cur$pos +remove$file1: + mvi b,0! push d! call searchn$list! pop d! jnz remove$file2 + lxi b,6! call tst$tbl$lmt! jnz remove$file1 + inx h! inx h! mov a,m! ori 10h! mov m,a + sta deleted$files + jmp remove$file1 +remove$file2: + pop h! shld prv$pos + pop h! shld cur$pos + ret + +delete$files: + lxi h,open$root! shld cur$pos +delete$file1: + mvi b,0! call search$nlist! rnz + inx h! inx h! mov a,m! ani 10h! jz delete$file1 + dcx h! dcx h! call remove$locks! call delete$item + jmp delete$file1 + +flush$files: + lxi h,flushed! mov a,m! ora a! rnz + inr m +flush$file0: + lxi h,open$root! shld cur$pos +flush$file1: + mvi b,1! call searchn$list! rnz + push h! call remove$locks! call delete$item! pop h + lxi d,6! dad d! mov e,m! inx h! mov d,m + lxi h,pdcnt$off! dad d! mov a,m! ani 1! jnz flush$file1 + mov a,m! ori 1! mov m,a + lhld pdaddr! mvi c,2! call compare! jnz flush$file1 + lda pdcnt! adi 10h! sta pdcnt! jmp flush$file1 + +free$files: + ; free$mode = 1 - remove curdsk files for process + ; 0 - remove all files for process + lhld pdaddr! xchg! lxi h,open$root! shld curpos +free$files1: + lda free$mode! mov b,a + push d! call searchn$list! pop d! rnz + lxi b,6! call tst$tbl$lmt! jnz free$files1 + push h! inx h! inx h! inx h + call test$ffff! jnz free$files2 + call test$ffff! jz free$files3 +free$files2: + mvi a,0ffh! sta incr$pdcnt +free$files3: + pop h! call remove$locks! call delete$item + jmp free$files1 + +remove$locks: + shld file$id + inx h! inx h! mov a,m! ani 40h! jz remove$lock3 + push d! lhld prv$pos! push h + lhld file$id! xchg! lxi h,lock$root! shld cur$pos +remove$lock1: + mvi b,0! push d! call searchn$list! pop d + jnz remove$lock2 + lxi b,8! call tst$tbl$lmt! jnz remove$lock1 + call delete$item + jmp remove$lock1 +remove$lock2: + pop h! shld prv$pos! pop d +remove$lock3: + lhld file$id! ret + +tst$tbl$lmt: + push h! dad b + mov a,m! inx h! mov h,m + sub e! jnz tst$tbl$lmt1 + mov a,h! sub d +tst$tbl$lmt1: + pop h! ret + +create$olist$item: + mvi b,1! call search$olist + di + call create$item! lda attributes! call set$olist$item + ei + ret + +count$opens: + xra a! sta open$cnt + lhld pdaddr! xchg! lxi h,open$root! shld curpos +count$open1: + mvi b,0! push d! call searchn$list! pop d! jnz count$open2 + lxi b,6! call tst$tbl$lmt! jnz count$open1 + lda open$cnt! inr a! sta open$cnt + jmp count$open1 +count$open2: + lxi h,open$max! lda open$cnt! ret + +count$locks: + xra a! sta lock$cnt + xchg! lxi h,lock$root! shld cur$pos +count$lock1: + mvi b,0! push d! call searchn$list! pop d! rnz + lxi b,8! call tst$tbl$lmt! jnz count$lock1 + lda lock$cnt! inr a! sta lock$cnt + jmp count$lock1 + +check$free: + lda mult$cnt! mov e,a + mvi d,0! lxi h,free$root! shld cur$pos +check$free1: + mvi b,0! push d! call searchn$list! pop d! jnz check$free2 + inr d! mov a,d! sub e! jc check$free1 + ret +check$free2: + pop h! mvi a,14! jmp sta$ret + +lock: ; record lock and unlock + call reselect! call check$fcb + call test$unlocked + rz ; file not opened in unlocked mode + lhld xdmaad! mov e,m! inx h! mov d,m + xchg! inx h! inx h + mov a,m! mov b,a! lda curdsk! sub b + ani 0fh! jnz lock8 ; invalid file id + mov a,b! ani 40h! jz lock8 ; invalid file id + dcx h! dcx h! shld file$id + lda lock$unlock! inr a! jnz lock1 ; jmp if unlock + call count$locks + lda lock$cnt! mov b,a + lda mult$cnt! add b! mov b,a + lda lock$max! cmp b + mvi a,12! jc sta$ret ; too many locks by this process + call check$free +lock1: + call save$rr! lxi h,lock9! push h! lda mult$cnt +lock2: + push a! call get$lock$add + lda lock$unlock! inr a! jnz lock3 + call test$lock +lock3: + pop a! dcr a! jz lock4 + call incr$rr! jmp lock2 +lock4: + call reset$rr! lda mult$cnt +lock5: + push a! call get$lock$add + lda lock$unlock! inr a! jnz lock6 + call set$lock! jmp lock7 +lock6: + call free$lock +lock7: + pop a! dcr a! rz + call incr$rr! jmp lock5 +lock8: + mvi a,13! jmp sta$ret ; invalid file id +lock9: + call reset$rr! ret + +get$lock$add: + lxi h,0! dad sp! shld lock$sp + mvi a,0ffh! sta lock$shell + call rseek + xra a! sta lock$shell + call getfcb + lhld aret! mov a,l! ora a! jnz lock$err + call index! lxi h,1! jz lock$err + call atran! ret + +lock$perr: + xra a! sta lock$shell + xchg! lhld lock$sp! sphl! xchg +lock$err: + pop d ; Discard return address + pop b ; b = mult$cnt-# recs processed + lda mult$cnt! sub b + add a! add a! add a! add a + ora h! mov h,a! mov b,a + shld aret! ret + +test$lock: + call move$arecord + mvi b,3! call search$llist! rnz + call compare$pds! rz + lxi h,8! jmp lock$err + +set$lock: + call move$arecord + mvi b,1! call search$llist + di + call create$item + xra a! call set$olist$item + xchg! lhld file$id! xchg + mov m,d! dcx h! mov m,e + ei! ret + +free$lock: + call move$arecord + mvi b,5! call search$llist! rnz +free$lock0: + call delete$item + mvi b,5! call searchn$list! rnz + jmp free$lock0 + +compare$pds: + lxi d,6! dad d! xchg + lxi h,pdaddr! mvi c,2! jmp compare + + +move$arecord: + lxi d,arecord! lxi h,packed$dcnt + + +fix$olist$item: + lxi d,xdcnt! lxi h,sdcnt + ; Is xdblk,xdcnt < sdblk,sdcnt + mvi c,4! ora a! +fix$ol1: + ldax d! sbb m! inx h! inx d! dcr c! jnz fix$ol1 + rnc + ; yes - update olist entry + call swap! call sdcnt$eq$xdcnt + lxi h,open$root! shld cur$pos + ; Find file's olist entry +fix$ol2: + call swap! call pack$sdcnt! call swap + mvi b,3! call searchn$list! rnz + ; Update olist entry with new dcnt value + push h! call pack$sdcnt! pop h + inx h! inx h! inx h! lxi d,packed$dcnt + mvi c,3! call move! jmp fix$ol2 + +hl$eq$hl$and$de: + mov a,l! ana e! mov l,a + mov a,h! ana d! mov h,a + ret + +remove$drive: + xchg! lda curdsk! mov c,a! lxi h,1 + call hlrotl + mov a,l! cma! ana e! mov e,a + mov a,h! cma! ana d! mov d,a + xchg! ret + +diskreset: + lxi h,0! shld ntlog + xra a! sta set$ro$flag + lhld info +intrnldiskreset: + xchg! lhld open$root! mov a,h! ora l! rz + xchg! lda curdsk! push a! mvi b,0 +dskrst1: + mov a,l! rar! jc dskrst3 +dskrst2: + mvi c,1! call hlrotr! inr b + mov a,h! ora l! jnz dskrst1 + pop a! sta curdsk + lhld ntlog! xchg! lhld tlog + mov a,l! ora e! mov l,a + mov a,h! ora d! mov h,a! shld tlog + inr a! ret +dskrst3: + push b! push h! mov a,b! sta curdsk + lhld rlog! call test$vector1! push a + lhld rodsk! lda curdsk! call test$vector1! mov b,a + pop h! lda set$ro$flag! ora b! ora h! sta check$disk + lxi h,open$root! shld cur$pos +dskrst4: + mvi b,1! call searchn$list! jnz dskrst6 + lda check$disk! ora a! jz dskrst5 + push h! call compare$pds! jz dskrst45 + pop h! xra a! xchg! jmp dskrst6 +dskrst45: + lxi d,ntlog! call set$cdisk + pop h! jmp dskrst4 +dskrst5: + lhld info! call remove$drive! shld info + ori 1 +dskrst6: + pop h! pop b! jnz dskrst2 + + ; error - olist item exists for another process + ; for removable drive to be reset + pop a! sta curdsk! mov a,b! adi 41h ; a = ascii drive + lxi h,6! dad d! mov c,m! inx h! mov b,m ; bc = pdaddr + push psw! call test$error$mode! pop d! jnz dskrst7 + mov a,d + + push b! push psw + call rlr! lxi d,console! dad d! mov d,m ; d = console # + lxi b,deniedmsg! call xprint + pop psw! mov c,a! call conoutx + mvi c,':'! call conoutx + lxi b,cnsmsg! call xprint + pop h! push h! lxi b,console! dad b + mov a,m! adi '0'! mov c,a! call conoutx + lxi b,progmsg! call xprint + pop h! call dsplynm + +dskrst7: + pop h ; Remove return addr from diskreset + lxi h,0ffffh! shld aret ; Flag the error + ret + +deniedmsg: + db cr,lf,'disk reset denied, drive ',0 +cnsmsg: + db ' console ',0 +progmsg: + db ' program ',0 +endif + +; +; individual function handlers +; + +func12: + ; Return version number + +if MPM + lxi h,0100h+dvers! jmp sthl$ret +else + lda version! jmp sta$ret ; lret = dvers (high = 00) +endif + +func13: + +if MPM + lhld dlog! shld info + call diskreset! jz reset$all + call reset$37 + jmp func13$cont +reset$all: + + ; Reset disk system - initialize to disk 0 + lxi h,0! shld rodsk! shld dlog + + shld rlog! shld tlog +func13$cont: + mvi a,0ffh! sta curdsk +else + lxi h,0ffffh! call reset$37x +endif + xra a! sta olddsk ; Note that usrcode remains unchanged + +if MPM + xra a! call getmemseg ; a = mem seg tbl index + ora a! rz + inr a! rz + call rlradr! lxi b,msegtbl-rlros! dad b + add a! add a! mov e,a! mvi d,0! dad d + mov h,m! mvi l,80h + jmp intrnlsetdma +else + lxi h,tbuff! shld dmaad ; dmaad = tbuff + jmp setdata ; to data dma address +endif + +func14: + +if MPM + call tmpselect ; seldsk = reg e + call rlr! lxi b,diskselect! dad b + mov a,m! ani 0fh! rrc! rrc! rrc! rrc + mov b,a! lda seldsk! ora b! rrc! rrc! rrc! rrc + mov m,a! ret +else + call tmpselect ; seldsk = reg e + lda seldsk! sta olddsk! ret +endif + +func15: + ; Open file + call clrmodnum ; Clear the module number + +if MPM + call reselect + xra a! sta make$flag + call set$sdcnt + lxi h,open$file! push h + mvi a,0c9h! sta check$fcb4 + call check$fcb1 + pop h! lda high$ext! cpi 060h! jnz open$file + call home! call set$end$dir + jmp open$user$zero +open$file: + call set$sdcnt + call reset$chksum$fcb ; Set invalid check sum +else + call reselectx +endif + + call check$wild ; Check for wild chars in fcb + +if MPM + + call get$atts! ani 1100$0000b ; a = attributes + cpi 1100$0000b! jnz att$ok + ani 0100$0000b ; Mask off unlock mode +att$ok: + sta high$ext + mov b,a! ora a! rar! jnz att$set + mvi a,80h +att$set: + sta attributes! mov a,b + ani 80h! jnz call$open +endif + + lda usrcode! ora a! jz call$open + mvi a,0feh! sta xdcnt+1! inr a! sta search$user0 + +if MPM + sta sdcnt0+1 +endif + +call$open: + call open! call openx ; returns if unsuccessful, a = 0 + lxi h,search$user0! cmp m! rz + mov m,a! lda xdcnt+1! cpi 0feh! rz +; +; file exists under user 0 +; + +if MPM + call swap +endif + + call set$dcnt$dblk + +if MPM + mvi a,0110$0000b +else + mvi a,80h +endif + + sta high$ext +open$user$zero: + ; Set fcb user # to zero + lhld info! mvi m,0 + mvi c,namlen! call searchi! call searchn + call open1 ; Attempt reopen under user zero + call openx ; openx returns only if unsuccessful + ret +openx: + call end$of$dir! rz + call getfcba! mov a,m! inr a! jnz openxa + dcx d! dcx d! ldax d! mov m,a +openxa: + ; open successful + pop h ; Discard return address + ; Was file opened under user 0 after unsuccessful + ; attempt to open under user n? + +if MPM + lda high$ext! cpi 060h! jz openx00 ; yes + ; Was file opened in locked mode? + ora a! jnz openx0 ; no + ; does user = zero? + lhld info! ora m! jnz openx0 ; no + ; Does file have read/only attribute set? + call rotest! jnc openx0 ; no + ; Does file have system attribute set? + inx h! mov a,m! ral! jnc openx0 ; no + + ; Force open mode to read/only mode and set user 0 flag + ; if file opened in locked mode, user = 0, and + ; file has read/only and system attributes set + +openx00: + +else + lda high$ext! ral! jnc openx0 +endif + + ; Is file under user 0 a system file ? + +if MPM + mvi a,20h! sta attributes +endif + + lhld info! lxi d,10! dad d + mov a,m! ani 80h! jnz openx0 ; yes - open successful + ; open fails + sta high$ext! jmp lret$eq$ff +openx0: + +if MPM + call reset$chksum$fcb +else + call set$lsn +endif + +if BANKED + + ; Are passwords enabled on drive? + call get$dir$mode! ani 80h! jz openx1a ; no + ; Is this 1st dir fcb? + call qdirfcb1! jnz openx0a ; no + ; Does sfcb exist? + call get$dtba$8! ora a! jnz openx0a ; no + ; Is sfcb password mode read or write? + mov a,m! ani 0c0h! jz openx1a ; no + ; Does xfcb exist? + call xdcnt$eq$dcnt + call get$xfcb! jnz openx0b ; yes + ; no - set sfcb password mode to zero + call restore$dir$fcb! rz ; (error) + ; Does sfcb still exist? + call get$dtba$8! ora a! jnz openx1a ; no (error) + ; sfcb password mode = 0 + mov m,a + ; update sfcb + call nowrite! cz seek$copy + jmp openx1a +openx0a: + call xdcnt$eq$dcnt + ; Does xfcb exist? + call get$xfcb! jz openx1 ; no +openx0b: + ; yes - check password + call cmp$pw! jz openx1 + call chk$pw$error + lda pw$mode! ani 0c0h! jz openx1 + ani 80h! jnz pw$error + mvi a,080h! sta xfcb$read$only +openx1: + call restore$dir$fcb! rz ; (error) +openx1a: + call set$lsn + +if MPM + call pack$sdcnt + ; Is this file currently open? + mvi b,3! call search$olist! jz openx04 +openx01: + ; no - is olist full? + lhld free$root! mov a,l! ora h! jnz openx03 + ; yes - error +openx02: + mvi a,11! jmp set$aret +openx03: + ; Has process exceeded open file maximum? + call count$opens! sub m! jc openx035 + ; yes - error +openx034: + mvi a,10! jmp set$aret +openx035: + ; Create new olist element + call create$olist$item + jmp openx08 +openx04: + ; Do file attributes match? + inx h! inx h + lda attributes! ora m! cmp m! jnz openx06 + ; yes - is open mode locked? + ani 80h! jnz openx07 + ; no - has this file been opened by this process? + lhld prv$pos! shld cur$pos + mvi b,5! call searchn$list! jnz openx01 +openx05: + ; yes - increment open file count + lxi d,8! dad d! inr m! jnz openx08 + ; count overflow + inx h! inr m! jmp openx08 +openx06: + ; error - file opened by another process in imcompatible mode + mvi a,5! jmp set$aret +openx07: + ; Does this olist item belong to this process? + dcx h! dcx h! push h + call compare$pds + pop h! jnz openx06 ; no - error + jmp openx05 ; yes +openx08:; Wopen ok + ; Was file opened in unlocked mode? + lda attributes! ani 40h! jz openx09 ; no + ; yes - return .olist$item in ranrec field of fcb + call get$rra + lxi d,cur$pos! mvi c,2! call move +openx09: + call set$fcb$cks$flag + lda make$flag! ora a! rnz +endif +endif + + mvi c,0100$0000b +openx2: + call qstamp! cz stamp1 + lxi d,olog! jmp set$cdisk + +func16: + ; Close file + call reselect + +if MPM + call get$atts! sta attributes + lxi h,close00! push h + mvi a,0c9h! sta check$fcb4 + call check$fcb1! pop h + call set$sdcnt + call getmodnum! ani 80h! jnz close01 + call close! jmp close02 +close00: + mvi a,6! jmp set$aret +close01: + mvi a,0ffh! sta dont$close! call close1 +close02: +else + call set$lsn + call chek$fcb! call close +endif + + lda lret! inr a! rz + + jmp flush ; Flush buffers + +if MPM + lda attributes! ral! rc + call pack$sdcnt + ; Find olist item for this process & file + mvi b,5! call search$olist! jnz close03 + ; Decrement open count + push h! lxi d,8! dad d + mov a,m! sui 1! mov m,a! inx h + mov a,m! sbi 0! mov m,a! dcx h + ; Is open count = 0ffffh + call test$ffff! pop h! jnz close03 + ; yes - remove file's olist entry + shld file$id! call delete$item + call reset$chksum$fcb + ; if unlocked file, remove file's locktbl entries + call test$unlocked! jz close03 + lhld file$id! call remove$locks +close03: + ret + +endif + +func17: + ; Search for first occurrence of a file + xchg! xra a +csearch: + push a + mov a,m! cpi '?'! jnz csearch1 ; no reselect if ? + call curselect! call noselect0! mvi c,0! jmp csearch3 +csearch1: + call getexta! mov a,m! cpi '?'! jz csearch2 + call clr$ext! call clrmodnum +csearch2: + call reselectx + mvi c,namlen +csearch3: + pop a! push a! jz csearch4 + ; dcnt = dcnt & 0fch + lhld dcnt! push h! mvi a,0fch + ana l! mov l,a! shld dcnt + call rd$dir + pop h! shld dcnt +csearch4: + pop a + lxi h,dir$to$user + push h + jz search + lda searchl! mov c,a! call searchi! jmp searchn + +func18: + ; Search for next occurrence of a file name + +if BANKED + xchg! shld searcha +else + lhld searcha! shld info +endif + + ori 1! jmp csearch + +func19: + ; Delete a file +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + jmp delete + +func20: + ; Read a file + call reselect + call check$fcb + jmp seqdiskread + +func21: + ; Write a file + call reselect + call check$fcb + jmp seqdiskwrite + +func22: + ; Make a file + +if BANKED + call get$atts! sta attributes +endif + + call clr$ext + call clrmodnum ; fcb mod = 0 + call reselectx + +if MPM + call reset$chksum$fcb +endif + + call check$wild + call set$xdcnt ; Reset xdcnt for make + +if MPM + call set$sdcnt +endif + + call open ; Verify file does not already exist + +if MPM + call reset$chksum$fcb +endif + + ; Does dir fcb for fcb exist? + ; ora a required to reset carry + call end$of$dir! ora a! jz makea0 ; no + ; Is dir$ext < fcb(ext)? + call get$dir$ext! cmp m! jnc file$exists ; no +makea0: + push a ; carry set if dir fcb already exists + +if MPM + lda attributes! ani 80h! rrc! jnz makex00 + mvi a,80h +makex00: + sta make$flag + lda sdcnt+1! inr a! jz makex01 + call pack$sdcnt + mvi b,3! call search$olist! jz make$x02 +makex01: + lhld free$root! mov a,l! ora h! jz openx02 + jmp makex03 +makex02: + inx h! inx h + lda makeflag! ana m! jz openx06 + dcx h! dcx h! call compare$pds! jz makex03 + lda makeflag! ral! jc openx06 +makex03: + +endif + +if BANKED + ; Is fcb 1st fcb for file? + call qdirfcb1! jz makex04 ; yes + ; no - does dir lbl require passwords? + call get$dir$mode! ani 80h! jz makex04 + ; no - does xfcb exist with mode 1 or 2 password? + call get$xfcb! jz makex04 + ; yes - check password + call chk$xfcb$password1! jz makex04 + ; Verify password error + call chk$pw$error + lda pw$mode! ani 0c0h! jnz pw$error +makex04: + +endif + + ; carry on stack indicates a make not required because + ; of extent folding + pop a! cnc make + +if MPM + call reset$chksum$fcb +endif + + ; end$of$dir call either applies to above make or open call + call end$of$dir! rz ; Return if make unsuccessful + +if not MPM + call set$lsn +endif + +if BANKED + + ; Are passwords activated by dir lbl? + call get$dir$mode! ani 80h! jz make3a + ; Did user set password attribute? + lda attributes! ani 40h! jz make3a + ; Is fcb file's 1st logical fcb? + call qdirfcb1! jnz make3a + ; yes - does xfcb already exist for file + call xdcnt$eq$dcnt + call get$xfcb! jnz make00 ; yes + ; Attempt to make xfcb + mvi a,0ffh! sta make$xfcb! call make! jnz make00 + ; xfcb make failed - delete fcb that was created above + call search$namlen + call delete10! jmp lret$eq$ff ; Return with a = 0ffh + +make00: + call init$xfcb ; Initialize xfcb + ; Get password mode from dma + 8 + xchg! lhld xdmaad! lxi b,8! dad b! xchg + ldax d! ani 0e0h! jnz make2 + mvi a,080h ; default password mode is read protect +make2: + sta pw$mode + ; Set xfcb password mode field + push a! call getxfcb1! pop a! mov m,a + ; Set xfcb password and password checksum + ; Fix hash table and write xfcb + call set$pw! mov m,b! call sdl3 + ; Return to fcb + call restore$dir$fcb! rz + ; Does sfcb exist? + mvi c,8! call getdtba! ora a! jnz make3a ; no + ; Place password mode in sfcb if sfcb exists + lda pw$mode! mov m,a! call seek$copy + call set$lsn +endif + +make3a: + mvi c,0101$0000b + +if MPM + call openx2 + lda make$flag! sta attributes + ani 40h! ral! sta high$ext + lda sdcnt+1! inr a! jnz makexx02 + call sdcnt$eq$xdcnt! call pack$sdcnt + jmp openx03 +makexx02: + call fix$olist$item! jmp openx1 + jmp set$fcb$cks$flag +else + call openx2 + mvi c,0010$0000b! call qstamp! rnz + call stamp2! jmp set$filewf +endif + +file$exists: + mvi a,8 +set$aret: + mov c,a! sta aret+1! call lret$eq$ff + +if MPM + call test$error$mode! jnz goback +else + jmp goerr1 +endif + +if MPM + mov a,c! sui 3 + mov l,a! mvi h,0! dad h + lxi d,xerr$list! dad d + mov e,m! inx h! mov d,m + xchg! jmp report$err +endif + +func23: + ; Rename a file +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + jmp rename + +func24: + ; Return the login vector + lhld dlog! jmp sthl$ret + +func25: + ; Return selected disk number + lda seldsk! jmp sta$ret + +func26: + +if MPM + ; Save dma address in process descriptor + lhld info +intrnlsetdma: + xchg + call rlr! lxi b,disksetdma! dad b + mov m,e! inx h! mov m,d +endif + + ; Set the subsequent dma address to info + xchg! shld dmaad ; dmaad = info + jmp setdata ; to data dma address + +func27: + ; Return the login vector address + call curselect + lhld alloca! jmp sthl$ret + +if MPM + +func28: + ; Write protect current disk + ; first check for open files on disk + mvi a,0ffh! sta set$ro$flag + lda seldsk! mov c,a! lxi h,0001h + call hlrotl! call intrnldiskreset + jmp set$ro +else + +func28: equ set$ro ; Write protect current disk + +endif + +func29: + ; Return r/o bit vector + lhld rodsk! jmp sthl$ret + +func30: + ; Set file indicators + call check$wild +;;; call reselectx ;[JCE] DRI Patch 13 + call patch$1e38 + call indicators + jmp copy$dirloc ; lret=dirloc + +func31: + ; Return address of disk parameter block + call curselect + lhld dpbaddr +sthl$ret: + shld aret! ret + +func32: + ; Set user code + lda linfo! cpi 0ffh! jnz setusrcode + ; Interrogate user code instead + lda usrcode! jmp sta$ret ; lret=usrcode + setusrcode: + ani 0fh! sta usrcode + +if MPM + push a + call rlr! lxi b,diskselect! dad b + pop b + mov a,m! ani 0f0h! ora b! mov m,a +endif + + ret + +func33: + ; Random disk read operation + call reselect + call check$fcb + jmp randiskread ; to perform the disk read + +func34: + ; Random disk write operation + call reselect + call check$fcb + jmp randiskwrite ; to perform the disk write + +func35: + ; Return file size (0-262,144) + call reselect + jmp getfilesize + +func36 equ setrandom ; Set random record + +func37: + ; Drive reset + +if MPM + call diskreset +reset$37: + lhld info +else + xchg +endif + +reset$37x: + mov a,l! cma! mov e,a! mov a,h! cma + lhld dlog! ana h! mov d,a! mov a,l! ana e + mov e,a! lhld rodsk! xchg! shld dlog + +if MPM + push h! call hl$eq$hl$and$de +else + mov a,l! ana e! mov l,a + mov a,h! ana d! mov h,a +endif + + shld rodsk + +if MPM + pop h! xchg! lhld rlog! call hl$eq$hl$and$de! shld rlog +endif + + ; Force select call in next curselect + mvi a,0ffh! sta curdsk! ret + +if MPM + +func38: + ; Access drive + + lxi h,packed$dcnt! mvi a,0ffh + mov m,a! inx h! mov m,a! inx h! mov m,a + xra a! xchg! lxi b,16 +acc$drv0: + dad h! adc b! dcr c! jnz acc$drv0 + ora a! rz + sta mult$cnt! dcr a! push a + call acc$drv02 + pop a! jmp openx02 ; insufficient free lock list items +acc$drv02: + call check$free! pop h ; Discard return addr, free space exists + call count$opens! pop b! add b! jc openx034 + sub m! jnc openx034 ; openmax exceeded + lhld info! lda curdsk! push a! mvi a,16 +acc$drv1: + dcr a! dad h! jc acc$drv2 +acc$drv15: + ora a! jnz acc$drv1 + pop a! sta curdsk! ret +acc$drv2: + push a! push h! sta curdsk + call create$olist$item + pop h! pop a! jmp acc$drv15 + +func39: + ; Free drive + lhld open$root! mov a,h! ora l! rz + xra a! sta incr$pdcnt! inr a! sta free$mode + lhld info! mov a,h! cmp l! jnz free$drv1 + inr a! jnz free$drv1 + sta free$mode! call free$files! jmp free$drv3 +free$drv1: + lda curdsk! push a! mvi a,16 +free$drv2: + dcr a! dad h! jc free$drv4 +free$drv25: + ora a! jnz free$drv2 + pop a! sta curdsk +free$drv3: + lda incr$pdcnt! ora a! rz + lda pdcnt! jmp chk$olist1 +free$drv4: + push a! push h! sta curdsk + call free$files + pop h! pop a! jmp free$drv25 +else + +func38 equ func$ret +func39 equ func$ret + +endif + +func40 equ func34 ; Write random with zero fill + +if MPM + +func41 equ func$ret ; Test & write +func42: ; Record lock + mvi a,0ffh! sta lock$unlock! jmp lock +func43: ; Record unlock + xra a! sta lock$unlock! jmp lock + +else + +func42 equ func$ret ; Record lock +func43 equ func$ret ; Record unlock + +endif + +func44: ; Set multi-sector count + mov a,e! ora a! jz lret$eq$ff + cpi 129! jnc lret$eq$ff + sta mult$cnt + +if MPM + mov d,a + call rlr! lxi b,mult$cnt$off! dad b + mov m,d +endif + + ret + +func45: ; Set bdos error mode + +if MPM + call rlr! lxi b,pname+4! dad b + call set$pflag + mov m,a! inx h + call set$pflag + mov m,a! ret + +set$pflag: + mov a,m! ani 7fh! inr e! rnz + ori 80h! ret +else + mov a,e! sta error$mode +endif + + ret + +func46: + ; Get free space + ; Perform temporary select of specified drive + call tmpselect + lhld alloca! xchg ; de = alloc vector addr + call get$nalbs ; Get # alloc blocks + ; hl = # of allocation vector bytes + ; Count # of true bits in allocation vector + lxi b,0 ; bc = true bit accumulator +gsp1: ldax d +gsp2: ora a! jz gsp4 +gsp3: rar! jnc gsp3 + inx b! jmp gsp2 +gsp4: inx d! dcx h + mov a,l! ora h! jnz gsp1 + ; hl = 0 when allocation vector processed + ; Compute maxall + 1 - bc + lhld maxall! inx h + mov a,l! sub c! mov l,a + mov a,h! sbb b! mov h,a + ; hl = # of available blocks on drive + lda blkshf! mov c,a! xra a + call shl3bv + ; ahl = # of available sectors on drive + ; Store ahl in beginning of current dma + xchg! lhld xdmaad! mov m,e! inx h + mov m,d! inx h! mov m,a! ret + +if MPM + +func47 equ func$ret + +else + +func47: ; Chain to program + lxi h,ccp$flgs! mov a,m! ori 80h! mov m,a + inr e! jnz rebootx1 + mov a,m! ori 40h! mov m,a + jmp rebootx1 +endif + +func48: ; Flush buffers + call check$all$media + call flushf + call diocomp +flush0: ; Function 98 entry point + lhld dlog! mvi a,16 +flush1: + dcr a! dad h! jnc flush5 + push a! push h! mov e,a! call tmpselect ; seldsk = e + lda fx! cpi 48! jz flush3 + ; Function 98 - reset allocation + ; Copy 2nd ALV over 1st ALV + call copy$alv +if BANKED + jmp patch$2d3a ;[JCE] DRI Patch 13 +else + jmp flush35 +endif + +flush3: + call flushx + ; if e = 0ffh then discard buffers after possible flush + lda linfo! inr a! jnz flush4 +flush35: + call discard$data +flush4: + pop h! pop a +flush5: + ora a! jnz flush1 + ret + +flush: + call flushf + call diocomp +flushx: + lda phymsk! ora a! rz + mvi a,4! jmp deblock$dta + +if MPM + +func49 equ func$ret + +else + +func49: ; Get/Set system control block + + xchg! mov a,m! cpi 99! rnc + xchg! lxi h,scb! add l! mov l,a + xchg! inx h! mov a,m! cpi 0feh! jnc func49$set + xchg! mov e,m! inx h! mov d,m! xchg + jmp sthl$ret +func49$set: + mov b,a! inx h! mov a,m! stax d! inr b! rz + inx h! inx d! mov a,m! stax d! ret +endif + +if MPM + +func50 equ func$ret + +else + +func50: ; Direct bios call + ; de -> function (1 byte) + ; a value (1 byte) + ; bc value (2 bytes) + ; de value (2 bytes) + ; hl value (2 bytes) + + lxi h,func50$ret! push h + xchg + +if BANKED + mov a,m! cpi 27! rz + cpi 12! jnz dir$bios1 + lxi d,dir$bios3! push d +dir$bios1: + cpi 9! jnz dir$bios2 + lxi d,dirbios4! push d +dir$bios2: + +endif + + push h! inx h! inx h + mov c,m! inx h! mov b,m! inx h + mov e,m! inx h! mov d,m! inx h + mov a,m! inx h! mov h,m! mov l,a + xthl! mov a,m! push h! mov l,a! add a! add l + + lxi h,bios + + add l! mov l,a! xthl + inx h! mov a,m! pop h! xthl! ret + +if BANKED + +dir$bios3: + mvi a,1! jmp setbnkf + +dir$bios4: + mov a,l! ora h! rz + xchg! lxi h,10! dad d! mvi m,0 ; Zero login sequence # + lhld common$base! call subdh! xchg! rnc + ; Copy DPH to common memory + xchg! lhld info! inx h! push h! lxi b,25 + call movef! pop h! ret +endif + +func50$ret: + +if BANKED + shld aret! mov b,a + lhld info! mov a,m + cpi 9! rz + cpi 16! rz + cpi 20! rz + cpi 22! rz + mov a,b! jmp sta$ret +else + xchg! lhld entsp! sphl! xchg! ret +endif +endif + +func98 equ flush0 ; Reset Allocation + +func99: ; Truncate file + call reselectx + call check$wild + +if BANKED + call chk$password! cnz chk$pw$error +endif + + mvi c,true! call rseek! jnz lret$eq$ff + ; compute dir$fcb size + call getdptra! lxi d,reccnt + call compute$rr ; cba = fcb size + ; Is random rec # >= dir$fcb size + call get$rra! call compare$rr + jc lret$eq$ff ; yes ( > ) + ora d! jz lret$eq$ff ; yes ( = ) + ; Perform truncate + call check$rodir ; may be r/o file + call wrdir ; verify BIOS can write to disk + call update$stamp ; Set update stamp + call search$extnum +trunc1: + jz copy$dirloc + ; is dirfcb < fcb? + call compare$mod$ext! jc trunc2 ; yes + ; remove dirfcb blocks from allocation vector + push a! mvi c,0! call scandm$ab! pop a + ; is dirfcb = fcb? + jz trunc3 ; yes + ; delete dirfcb + call getdptra! mvi m,empty! call fix$hash +trunc15: + call wrdir +trunc2: + call searchn + jmp trunc1 +trunc3: + call getfcb! call dm$position + call zero$dm + ; fcb(extnum) = dir$ext after blocks removed + call get$dir$ext! cmp m! mov m,a! push a + ; fcb(rc) = fcb(cr) + 1 + call getfcba! mov a,m! inr a! stax d + ; rc = 0 or 128 if dir$ext < fcb(extnum) + pop a! xchg! cnz set$rc3 + ; rc = 0 if no blocks remain in fcb + lda dminx! ora a! cz set$rc3 + lxi b,11! call get$fcb$adds! xchg + ; reset archive (t3') attribute bit + mov a,m! ani 7fh! mov m,a! inx h! inx d + ; dirfcb(extnum) = fcb(extnum) + ldax d! mov m,a + ; advance to .fcb(reccnt) & .dirfcb(reccnt) + inx h! mvi m,0! inx h! inx h + inx d! inx d! inx d + ; dirfcb_rc+dskmap = fcb_rc+dskmap + mvi c,17! call move + ; restore non-erased blkidxs in allocation vector + mvi c,1! call scandm$ab + jmp trunc15 + +get$fcb$adds: + call getdptra! dad b! xchg + lhld info! dad b! ret + +compare$mod$ext: + lxi b,modnum! call get$fcb$adds + mov a,m! ani 3fh! mov b,a + ; compare dirfcb(modnum) to fcb(modnum) + ldax d! cmp b! rnz ; dirfcb(modnum) ~= fcb(modnum) + dcx h! dcx h! dcx d! dcx d + ; compare dirfcb(extnum) to fcb(extnum) + ldax d! mov c,m! call compext! rz ; dirfcb(extnum) = fcb(extnum) + ldax d! cmp m! ret + +zero$dm: + inr a! lxi h,single! inr m! jz zero$dm1 + add a +zero$dm1: + dcr m + call getdma! mov c,a! mvi b,0! dad b + mvi a,16 +zero$dm2: + cmp c! rz + mov m,b! inx h! inr c! jmp zero$dm2 + +if BANKED + +func100: ; Set directory label + ; de -> .fcb + ; drive location + ; name & type fields user's discretion + ; extent field definition + ; bit 1 (80h): enable passwords on drive + ; bit 2 (40h): enable file access + ; bit 3 (20h): enable file update stamping + ; bit 4 (10h): enable file create stamping + ; bit 8 (01h): assign new password to dir lbl + call reselectx + lhld info! mvi m,21h! mvi c,1 + call search! jnz sdl0 + call getexta! mov a,m! ani 0111$0000b! jnz lret$eq$ff +sdl0: + ; Does dir lbl exist on drive? + lhld info! mvi m,20h! mvi c,1 + call set$xdcnt! call search! jnz sdl1 + ; no - make one + mvi a,0ffh! sta make$xfcb + call make! rz ; no dir space + call init$xfcb + lxi b,24! call stamp5! call stamp1 +sdl1: + ; Update date & time stamp + lxi b,28! call stamp5! call stamp2 + ; Verify password - new dir lbl falls through + call chk$xfcb$password! jnz pw$error + lxi b,0! call init$xfcb0 + ; Set dir lbl dta in extent field + ldax d! ori 1h! mov m,a + ; Low bit of dir lbl data set to indicate dir lbl exists + ; Update drive's dir lbl vector element + push h! lhld drvlbla! mov m,a! pop h +sdl2: + ; Assign new password to dir lbl or xfcb? + ldax d! ani 1! jz sdl3 + ; yes - new password field is in 2nd 8 bytes of dma + lxi d,8! call adjust$dmaad + call set$pw! mov m,b + lxi d,-8! call adjust$dmaad +sdl3: + call fix$hash + jmp seek$copy +else + +func100 equ lret$eq$ff +func103 equ lret$eq$ff + +endif + +func101: + ; Return directory label data + ; Perform temporary select of specified drive + call tmpselect + call get$dir$mode! jmp sta$ret + +func102: + ; Read file xfcb + call reselectx + call check$wild + call zero$ext$mod + call search$namlen! rz + call getdma! lxi b,8! call zero + push h! mvi c,0! call get$dtba! ora a! jnz rxfcb2 + pop d! xchg! mvi c,8 + +if BANKED + call move! ldax d! jmp rxfcb3 +else + jmp move +endif + +rxfcb2: + pop h! lxi b,8 + +if BANKED + call zero! call get$xfcb! rz + mov a,m +rxfcb3: + call getexta! mov m,a! ret +else + jmp zero +endif + +if BANKED + +func103: + ; Write or update file xfcb + call reselectx + ; Are passwords enabled in directory label? + call get$dir$mode! ral! jnc lret$eq$ff ; no + call check$wild + ; Save .fcb(ext) & ext + call getexta! mov b,m! push h! push b + ; Set extent & mod to zero + call zero$ext$mod + ; Does file's 1st fcb exist in directory? + call search$namlen + ; Restore extent + pop b! pop h! mov m,b! rz ; no + call set$xdcnt + ; Does sfcb exist? + call get$dtba$8! ora a! jz wxfcb5 ; yes + ; No - Does xfcb exist? + call get$xfcb! jnz wxfcb1 ; yes +wxfcb0: + ; no - does file exist in directory? + mvi a,0ffh! sta make$xfcb + call search$extnum! rz + ; yes - attempt to make xfcb for file + call make! rz ; no dir space + ; Initialize xfcb + call init$xfcb +wxfcb1: + ; Verify password - new xfcb falls through + call chk$xfcb$password! jnz pw$error + ; Set xfcb options data + push h! call getexta! pop d! xchg + mov a,m! ora a! jnz wxfcb2 + ldax d! ani 1! jnz wxfcb2 + call sdl3! jmp wxfcb4 +wxfcb2: + ldax d! ani 0e0h! jnz wxfcb3 + mvi a,80h +wxfcb3: + mov m,a! call sdl2 +wxfcb4: + call get$xfcb1! dcr a! sta pw$mode + call zero$ext$mod + call search$namlen! rz + call get$dtba$8! ora a! rnz + lda pw$mode! mov m,a! jmp seek$copy +wxfcb5: + ; Take sfcb's password mode over xfcb's mode + mov a,m! push a + call get$xfcb + ; does xfcb exist? + pop b! jz wxfcb0 ; no + ; Set xfcb's password mode to sfcb's mode + mov m,b! jmp wxfcb1 + +endif + +func104: ; Set current date and time + +if MPM + call get$stamp$add +else + lxi h,stamp +endif + call copy$stamp + mvi m,0! mvi c,0ffh! jmp timef + +func105: ; Get current date and time + + + +if MPM + call get$stamp$add +else + mvi c,0! call timef + lxi h,stamp +endif + + xchg + call copy$stamp + ldax d! jmp sta$ret + +copy$stamp: + mvi c,4! jmp move ; ret + +if MPM + +get$stamp$add: + call rlradr! lxi b,-5! dad b + ret +endif + +if BANKED + +func106: ; Set default password + +if MPM + call get$df$pwa! inr a! rz + lxi b,7! dad b +else + lxi h,df$password+7 +endif + xchg! lxi b,8! push h + jmp set$pw0 +else + +func106 equ func$ret + +endif + +func107: ; Return serial number + +if MPM + lhld sysdat! mvi l,181 +else + lxi h,serial +endif + + xchg! mvi c,6! jmp move + +func108: ; Get/Set program return code + + ; Is de = 0ffffh? + mov a,d! ana e! inr a + lhld clp$errcde! jz sthl$ret ; yes - return return code + xchg! shld clp$errcde! ret ; no - set return code + +goback0: + lxi h,0ffffh! shld aret +goback: + ; Arrive here at end of processing to return to user + lda resel! ora a! jz retmon + +if MPM + lda comp$fcb$cks! ora a! cnz set$chksum$fcb +endif + + lhld info! lda fcbdsk! mov m,a ; fcb(0)=fcbdsk +if BANKED + + ; fcb(7) = fcb(7) | xfcb$read$only + lxi d,7! dad d! lda xfcb$read$only! ora m! mov m,a + +endif +if MPM + ; if high$ext = 60h then fcb(8) = fcb(8) | 80h + ; else fcb(ext) = fcb(ext) | high$ext + + call getexta! lda high$ext! cpi 60h! jnz goback2 + lxi d,-4! dad d! mvi a,80h + goback2: + ora m! mov m,a +else + ; fcb(8) = fcb(8) | high$ext +if BANKED + inx h +else + lxi d,8! dad d +endif + lda high$ext! ora m! mov m,a +endif + +; return from the disk monitor + +retmon: + lhld entsp! sphl + lhld aret! mov a,l! mov b,h! ret +; +; data areas +; +efcb: db empty ; 0e5=available dir entry +rodsk: dw 0 ; read only disk vector +dlog: dw 0 ; logged-in disks + +if MPM + +rlog: dw 0 ; removeable logged-in disks +tlog: dw 0 ; removeable disk test login vector +ntlog: dw 0 ; new tlog vector +rem$drv: ds byte ; curdsk removable drive switch + ; 0 = permanent drive, 1 = removable drive +endif + +if not BANKED + +xdmaad equ $ +curdma ds word ; current dma address + +endif + +if not MPM + +buffa: ds word ; pointer to directory dma address + +endif + +; +; curtrka - alloca are set upon disk select +; (data must be adjacent, do not insert variables) +; (address of translate vector, not used) +cdrmaxa:ds word ; pointer to cur dir max value (2 bytes) +curtrka:ds word ; current track address (2) +curreca:ds word ; current record address (3) +drvlbla:ds word ; current drive label byte address (1) +lsn$add:ds word ; login sequence # address (1) + ; +1 -> bios media change flag (1) +dpbaddr:ds word ; current disk parameter block address +checka: ds word ; current checksum vector address +alloca: ds word ; current allocation vector address +dirbcba:ds word ; dir bcb list head +dtabcba:ds word ; data bcb list head +hash$tbla: + ds word ; directory hash table address + ds byte ; directory hash table bank + +addlist equ $-dpbaddr ; address list size + +; +; buffer control block format +; +; bcb format : drv(1) || rec(3) || pend(1) || sequence(1) || +; 0 1 4 5 +; +; track(2) || sector(2) || buffer$add(2) || +; 6 8 10 +; +; bank(1) || link(2) +; 12 13 +; + +; sectpt - offset obtained from disk parm block at dpbaddr +; (data must be adjacent, do not insert variables) +sectpt: ds word ; sectors per track +blkshf: ds byte ; block shift factor +blkmsk: ds byte ; block mask +extmsk: ds byte ; extent mask +maxall: ds word ; maximum allocation number +dirmax: ds word ; largest directory number +dirblk: ds word ; reserved allocation bits for directory +chksiz: ds word ; size of checksum vector +offset: ds word ; offset tracks at beginning +physhf: ds byte ; physical record shift +phymsk: ds byte ; physical record mask +dpblist equ $-sectpt ; size of area +; +; local variables +; +drec ds word ; directory record number +blk$off: ds byte ; record offset within block +last$off: ds byte ; last offset within new block +last$drive: ds byte ; drive of last new block +last$block: ds word ; last new block + +; The following two variables are initialized as a pair on entry + +dir$cnt: ds byte ; direct i/o count +mult$num: ds byte ; multi-sector number + +tranv: ds word ; address of translate vector +lock$unlock: +make$flag: +rmf: ds byte ; read mode flag for open$reel +incr$pdcnt: +dirloc: ds byte ; directory flag in rename, etc. +free$mode: +linfo: ds byte ; low(info) +dminx: ds byte ; local for diskwrite + +if MPM + +searchl:ds byte ; search length + +endif +if BANKED + +searcha:ds word ; search address + +endif + +if BANKED + +save$xfcb: + ds byte ; search xfcb save flag + +endif + +single: ds byte ; set true if single byte allocation map + +if MPM + +seldsk: ds byte ; currently selected disk + +endif + +seldsk: ds byte ; disk on entry to bdos +rcount: ds byte ; record count in current fcb +extval: ds byte ; extent number and extmsk +save$mod: + ds byte ; open$reel module save field + +vrecord:ds byte ; current virtual record + +if not MPM + +curdsk: db 0ffh ; current disk + +endif + +adrive: db 0ffh ; current blocking/deblocking disk +arecord:ds word ; current actual record + ds byte + +save$ranr: ds 3 ; random record save area +arecord1: ds word ; current actual block# * blkmsk +attributes: ds byte ; make attribute hold area +readf$sw: ds byte ; BIOS read/write switch + +;******** following variable order critical ***************** + +if MPM + +mult$cnt: ds byte ; multi-sector count +pdcnt: ds byte ; process descriptor count + +endif + +high$ext: ds byte ; fcb high ext bits + +if BANKED + +xfcb$read$only: ds byte ; xfcb read only flag + +endif +if MPM + +curdsk: db 0ffh ;current disk +packed$dcnt: ds 3 ; +pdaddr: ds word ; +;************************************************************ +cur$pos: ds word ; +prv$pos: ds word ; +sdcnt: ds word ; +sdblk: ds word ; +sdcnt0: ds word ; +sdblk0: ds word ; +dont$close: ds byte ; +open$cnt: ; mp/m temp variable for open +lock$cnt: ds word ; mp/m temp variable for lock +file$id: ds word ; mp/m temp variable for lock +deleted$files: ds byte +lock$shell: ds byte +lock$sp: ds word +set$ro$flag: ds byte +check$disk: ds byte +flushed: ds byte +fcb$cks$valid: ds byte +; mp/m variables * + +endif + +; local variables for directory access +dptr: ds byte ; directory pointer 0,1,2,3 + +save$hash: ds 4 ; hash code save area + +if BANKED + +copy$cr$init: ds byte ; copy$cr$only initialization value + +else + +hashmx: ds word ; cdrmax or dirmax +xdcnt: ds word ; empty directory dcnt + +endif + +if MPM + +xdcnt: ds word ; empty directory dcnt +xdblk: ds word ; empty directory block +dcnt: ds word ; directory counter 0,1,...,dirmax +dblk: ds word ; directory block index + +endif + +search$user0: ds byte ; search user 0 for file (open) + +user0$pass: ds byte ; search user 0 pass flag + +fcbdsk: ds byte ; disk named in fcb + +if MPM + +make$xfcb: ds 1 +find$xfcb: ds 1 + +endif + +log$fxs:db 15,16,17,19,22,23,30,35,99,100,102,103,0 +rw$fxs: db 20,21,33,34,40,41,0 +sc$fxs: db 16,18,0 + +if MPM + +comp$fcb$cks: ds byte ; compute fcb checksum flag + +endif +if BANKED + +pw$fcb: ds 12 ;1 | + db 0 ;2 | +pw$mode: db 0 ;3 |- Order critical + db 0 ;4 | + db 0 ;5 | + +df$password: ds 8 + +if MPM + ds 120 +endif +endif + +phy$off: ds byte +curbcba: ds word + +if BANKED + +lastbcba: ds word +rootbcba: ds word +emptybcba: ds word +seqbcba: ds word +buffer$bank: ds byte + +endif + +track: ds word +sector: ds word + +; ************************** +; Blocking/Deblocking Module +; ************************** + +deblock$dta: + lhld dtabcba + +if BANKED + cpi 4! jnz deblock +deblock$flush: + ; de = addr of 1st bcb + mov e,m! inx h! mov d,m + ; Search for dirty bcb with lowest track # + lxi h,0ffffh! shld track! xchg +deblock$flush1: + ; Does current drive own bcb? + lda adrive! cmp m! jnz deblock$flush2 ;no + ; Is bcb's buffer pending? + xchg! lxi h,4! dad d! mov a,m + xchg! inr a! jnz deblock$flush2 ; no + ; Is bcb(6) < track? + push h! inx d! inx d! xchg + mov e,m! inx h! mov d,m + ; Subdh computes hl = de - hl + lhld track! call subdh! pop h! jnc deblock$flush2 ; no + ; yes - track = bcb(6) , sector = addr(bcb) + xchg! shld track! xchg! shld sector +deblock$flush2: + ; Is this the last bcb? + call get$next$bcba! jnz deblock$flush1 ; no - hl = addr of next bcb + ; Does track = ffff? + lxi h,track! call test$ffff! rz ; yes - no bcb to flush + ; Flush bcb located by sector + lhld sector! xra a! mvi a,4! call deblock + lhld dtabcba! jmp deblock$flush ; Repeat until no bcb's to flush +endif + +deblock: + + ; BDOS Blocking/Deblocking routine + ; a = 1 -> read command + ; a = 2 -> write command + ; a = 3 -> locate command + ; a = 4 -> flush command + ; a = 5 -> directory update + + push a ; Save z flag and deblock fx + + ; phy$off = low(arecord) & phymsk + ; low(arecord) = low(arecord) & ~phymsk + call deblock8 + lda arecord! mov e,a! ana b! sta phy$off + mov a,e! ana c! sta arecord + +if BANKED + pop a! push a! cnz get$bcba +endif + + shld curbcba! call getbuffa! shld curdma + ; hl = curbcba, de = .adrive, c = 4 + call deblock9 + ; Is BCB discarded? + mov a,m! inr a! jz deblock2 ; yes + ; Is command flush? + pop a! push a! cpi 4! jnc deblock1 ; yes + ; Is referenced physical record already in buffer? + +;;; call compare ;[JCE] DRI patch 7 + call patch$1e0c + + jz deblock45 ; yes + xra a +deblock1: + ; Does buffer contain an updated record? + call deblock10 + cpi 5! jz deblock15 + mov a,m! ora a! jz deblock2 ; no +deblock15: + ; Reset record pending flag + mvi m,0 + ; Save arecord + lhld arecord! push h! lda arecord+2! push a + ; Flush physical record buffer + call deblock9 + xchg! call move + ; Select drive to be flushed + lxi h,curdsk! lda adrive! cmp m! cnz disk$select1 + ; Write record if drive logged-in + mvi a,1! cz deblock$io + ; Restore arecord + pop b! pop d! call set$arecord + ; Restore selected drive + call curselect +deblock2: + ; Is deblock command flush | dir write? + pop a! cpi 4! rnc ; yes - return + ; Is deblock command write? + push a! cpi 2! jnz deblock25 ; no + ; Is blk$off < last$off + lxi h,last$off + lda blk$off + cmp m + jnc deblock3 ; no +deblock25: + ; Discard BCB on read operations in case + ; I/O error occurs +;;; lhld curbcba ;[JCE] DRI Patch 7 + call patch$1e1c + mvi m,0ffh + ; Read physical record buffer + mvi a,2! jmp deblock35 +deblock3: + ; last$off = blk$off + 1 + inr a! mov m,a + ; Place track & sector in bcb + xra a +deblock35: + call deblock$io +deblock4: + call deblock9 ; phypfx = adrive || arecord + call move! mvi m,0 ; zero pending flag + +if BANKED + ; Zero logical record sequence + inx h! call set$bcb$seq +endif + +deblock45: + ; recadd = phybuffa + phy$off*80h + lda phy$off! inr a! lxi d,80h! lxi h,0ff80h +deblock5: + dad d! dcr a! jnz deblock5 + xchg! lhld curdma! dad d + ; If deblock command = locate then buffa = recadd; return + pop a! cpi 3! jnz deblock6 + shld buffa! ret +deblock6: + xchg! lhld dmaad! lxi b,80h + ; If deblock command = read + cpi 1 + +if BANKED + jnz deblock7 + ; then move to tpa + lda common$base+1! dcr a! cmp d! jc move$tpa + lda buffer$bank! mov c,a! mvi b,1! call deblock12 + lxi b,80h! jmp move$tpa +deblock7: + +else + jz move$tpa ; then move to dma +endif + + ; else move from dma + xchg + +if BANKED + lda common$base+1! dcr a! cmp h! jc deblock75 + lda buffer$bank! mov b,a! mvi c,1! call deblock12 + lxi b,80h +deblock75: + +endif + + call move$tpa + ; Set physical record pending flag for write command + call deblock10! mvi m,0ffh + ret + +deblock8: + lda phymsk! mov b,a! cma! mov c,a! ret + +deblock9: + lhld curbcba! lxi d,adrive! mvi c,4! ret + +deblock10: + lxi d,4 +deblock11: + lhld curbcba! dad d! ret + +if BANKED + +deblock12: + push h! push d! call xmovef + pop d! pop h! ret +endif + +deblock$io: + ; a = 0 -> seek only + ; a = 1 -> write + ; a = 2 -> read + push a! call seek + +if BANKED + lda buffer$bank! call setbnkf +endif + + mvi c,1 + pop a! dcr a + jz wrbuff + cp rdbuff + ; Move track & sector to bcb + call deblock10! inx h! inx h + lxi d,track! mvi c,4! jmp move + +if BANKED + +get$bcba: +;;; shld rootbcba ;[JCE] DRI Patch 13 + call patch$2d30 + lxi d,-13! dad d! shld lastbcba + call get$next$bcba! push h + ; Is there only 1 bcb in list? + call get$next$bcba! pop h! rz ; yes - return + xchg! lxi h,0! shld emptybcba! shld seqbcba + xchg +get$bcb1: + ; Does bcb contain requested record? + shld curbcba! call deblock9! call compare! jz get$bcb4 ; yes + ; Is bcb discarded? + lhld curbcba! mov a,m! inr a! jnz get$bcb11 ; no + xchg! lhld lastbcba! shld emptybcba! jmp get$bcb14 +get$bcb11: + ; Does bcb contain record from current disk? + lda adrive! cmp m! jnz get$bcb15 ; no + xchg! lxi h,5! dad d! lda phy$msk + ; Is phy$msk = 0? + ora a! jz get$bcb14 ; yes + ; Does bcb(5) [bcb sequence] = phymsk? + cmp m! jnz get$bcb14 ; no +;;; lhld seqbcba ;[JCE] DRI Patch 13 +;;; mov a,l +;;; ora h + lda patch$2d39 + ora a + nop + jnz get$bcb14 + lhld lastbcba! shld seqbcba +get$bcb14: + xchg +get$bcb15: + ; Advance to next bcb - list exhausted? + push h! call get$next$bcba! pop d! jz get$bcb2 ; yes + xchg! shld lastbcba! xchg! jmp get$bcb1 +get$bcb2: + ; Matching bcb not found + ; Was a sequentially accessed bcb encountered? +;;; lhld seqbcba ;[JCE] DRI Patch 13 + lhld emptybcba + + mov a,l! ora h! jnz get$bcb25 ; yes + ; Was a discarded bcb encountered? +;;; lhld emptybcba ;[JCE] DRI Patch 13 + lhld seqbcba + + mov a,l! ora h! jz get$bcb3 ; no +get$bcb25: + shld lastbcba +get$bcb3: + ; Insert selected bcb at head of list + lhld lastbcba! call get$next$bcba + shld curbcba! call get$next$bcba + xchg! call last$bcb$links$de + lhld rootbcba! mov e,m! inx h! mov d,m + lhld curbcba! lxi b,13! dad b + mov m,e! inx h! mov m,d + lhld curbcba! xchg! lhld rootbcba + mov m,e! inx h! mov m,d! xchg! ret +get$bcb4: + ; BCB matched arecord + lhld curbcba! lxi d,5! dad d + ; Does bcb(5) = phy$off? + lda phy$off! cmp m! jz get$bcb5 ; yes + ; Does bcb(5) + 1 = phy$off? + inr m! cmp m! jz get$bcb5 ; yes + call set$bcb$seq +get$bcb5: + ; Is bcb at head of list? + lhld curbcba! xchg! lhld rootbcba + mov a,m! inx h! mov l,m! mov h,a + call subdh! ora l! xchg! rz ; yes + jmp get$bcb3 ; no - insert bcb at head of list + +last$bcb$links$de: + lhld lastbcba! lxi b,13! dad b + mov m,e! inx h! mov m,d! ret + +get$next$bcba: + lxi b,13! dad b! mov e,m! inx h! mov d,m + xchg! mov a,h! ora l! ret + +set$bcb$seq: + lda phy$off! mov m,a! ora a! rz + lda phy$msk! inr a! mov m,a! ret + +endif + +if not MPM +if not BANKED + +patch$1dfd: ;[JCE] DRI Patch 7 + lda chksiz+1 + ral + jc get$dir$ext + mvi a,0ffh + sta patch$1e24 + jmp get$dir$ext + +patch$1e0c: + cpi 3 + jnz compare + lda patch$1e24 + inr a + jnz compare + pop h + jmp deblock25 + +patch$1e1c: + xra a + sta patch$1e24 + lhld curbcba + ret + +patch$1e24: + db 0 + +patch$1e25: + lxi h,0 + shld conbuffadd + shld ccp$conbuff + dcx h + dcx h + ret + +patch$1e31: ;Patch 13 + call check$write + lxi h,xdcnt + ret + +patch$1e38: + call reselectx + jmp check$write + +patch$1e3e: + call setfwf + jmp search$namlen + + ds 41 ;[JCE] Was 112 before patching +last: + org base + (((last-base)+255) and 0ff00h) - 112 + +olog: dw 0 +rlog: dw 0 + +patch$flgs: db 0,0,0,6 ;Patchlevel + dw base+6 + xra a! ret + +; System Control Block + +SCB: + +; Expansion Area - 6 bytes + +hashl: db 0 +hash: dw 0,0 +version: db 31h + +; Utilities Section - 8 bytes + +util$flgs: dw 0,0 +dspl$flgs: dw 0 + dw 0 + +; CLP Section - 4 bytes + +clp$flgs: dw 0 +clp$errcde: dw 0 + +; CCP Section - 8 bytes + +ccp$comlen: db 0 +ccp$curdrv: db 0 +ccp$curusr: db 0 +ccp$conbuff: dw 0 +ccp$flgs: dw 0 + db 0 + +; Device I/O Section - 32 bytes + +conwidth: db 0 +column: db 0 +conpage: db 0 +conline: db 0 +conbuffadd: dw 0 +conbufflen: dw 0 +conin$rflg: dw 0 +conout$rflg: dw 0 +auxin$rflg: dw 0 +auxout$rflg: dw 0 +lstout$rflg: dw 0 +page$mode: db 0 +pm$default: db 0 +ctlh$act: db 0 +rubout$act: db 0 +type$ahead: db 0 +contran: dw 0 +conmode: dw 0 + db 0 + db 0 +outdelim: db '$' +listcp db 0 +qflag: db 0 + +; BDOS Section - 42 bytes + +scbadd: dw scb +dmaad: dw 0080h +olddsk: db 0 +info: dw 0 +resel: db 0 +relog: db 0 +fx: db 0 +usrcode: db 0 +dcnt: dw 0 +searcha: dw 0 +searchl: db 0 +multcnt: db 1 +errormode: db 0 +searchchain: db 0,0ffh,0ffh,0ffh +temp$drive: db 0 +errdrv: db 0 + dw 0 +media$flag: db 0 + dw 0 +bdos$flags: db 0 +stamp: db 0ffh,0ffh,0ffh,0ffh,0ffh +commonbase: dw 0 +error: jmp error$sub +bdosadd: dw base+6 + +endif +endif + +; ************************ +; Directory Hashing Module +; ************************ + +; Hash format +; xxsuuuuu xxxxxxxx xxxxxxxx ssssssss +; x = hash code of fcb name field +; u = low 5 bits of fcb user field +; 1st bit is on for XFCB's +; s = shiftr(mod || ext,extshf) + +if not BANKED + +hashorg: + org base+(((hashorg-base)+255) and 0ff00h) +endif + +init$hash: + ; de = .hash table entry + ; hl = .dir fcb + push h! push d! call get$hash + ; Move computed hash to hash table entry + pop h! lxi d,hash! lxi b,4 + +if BANKED + lda hash$tbla+2! call move$out +else + call movef +endif + + ; Save next hash table entry address + shld arecord1 + ; Restore dir fcb address + pop h! ret + +set$hash: + ; Return if searchl = 0 + ora a! rz + ; Is searchl < 12 ? + cpi 12! jc set$hash2 ; yes - hashl = 0 + ; Is searchl = 12 ? + mvi a,2! jz set$hash1 ; yes - hashl = 2 + mvi a,3 ; hashl = 3 +set$hash1: + sta hashl + xchg + ; Is dir hashing invoked for drive? + call test$hash! rz ; no + xchg + lda fx + cpi 16! jz get$hash ; bdos fx = 16 + cpi 35! jz set$hash15 + cpi 20! jnc get$hash ; bdos fx = 20 or above +set$hash15: + mvi a,2! sta hashl ; bdos fx = 15,17,18,19, or 35 + ; if fcb wild then hashl = 0, hash = fcb(0) + ; else hashl = 2, hash = get$hash + push h! call chk$wild! pop h! jnz get$hash +set$hash2: + xra a! sta hashl + ; jmp get$hash + +get$hash: + ; hash(0) = fcb(0) + mov a,m! sta hash! inx h! xchg + ; Don't compute hash for dir lbl & sfcb's + lxi h,0! ani 20h! jnz get$hash6 + ; b = 11, c = 8, ahl = 0 + ; Compute fcb name hash (000000xx xxxxxxxxx xxxxxxxx) (ahl) + lxi b,0b08h +get$hash1: + ; Don't shift if fcb(8) + dcr c! push b! jz get$hash3 + ; Don't shift if fcb(6) + dcr c! dcr c! jz get$hash3 + ; ahl = ahl * 2 + dad h! adc a! push a! mov a,b + ; is b odd? + rar! jc get$hash4 ; yes + ; ahl = ahl * 2 for even fcb(i) + pop a! dad h! adc a +get$hash3: + push a +get$hash4: + ; a = fcb(i) & 7fh - 20h divided by 2 if even + ldax d! ani 7fh! sui 20h! rar! jnc get$hash5 + ral +get$hash5: + ; ahl = ahl + a + mov c,a! mvi b,0 + pop a! dad b! aci 0! pop b + ; advance to next fcb char + inx d! dcr b! jnz get$hash1 +get$hash6: + ; ahl = 000000xx xxxxxxxx xxxxxxxx + ; Store low 2 bytes of hash + shld hash+1! lxi h,hash + ; hash(0) = hash(0) (000uuuuu) | xx000000 + ani 3! rrc! rrc! ora m! mov m,a + ; Does fcb(0) = e5h, 20h, or 21h? + ani 20h! jnz get$hash9 ; yes + ; bc = 00000mmm mmmeeeee, m = module #, e = extent + ldax d! ani 1fh! mov c,a! inx d! inx d + ldax d! ani 3fh! rrc! rrc! rrc! mov d,a + ani 7! mov b,a! mov a,d! ani 0e0h! ora c! mov c,a + ; shift bc right by # of bits in extmsk + lda extmsk +get$hash7: + rar! jnc get$hash8 + push a + mov a,b! rar! mov b,a + mov a,c! rar! mov c,a + pop a! jmp get$hash7 +get$hash8: + ; hash(0) = hash(0) (xx0uuuuu) | 00s00000 + mov a,b! ani 1! rrc! rrc +get$hash9: + rrc! ora m! mov m,a + ; hash(3) = ssssssss + lxi d,3! dad d! mov m,c! ret + +test$hash: + lhld hash$tbla! mov a,l! ora h! inr a! ret + +search$hash: + ; Does hash table exist for drive? + call test$hash! rz ; no + ; Has dir hash search been disabled? + lda hashl! inr a! rz ; yes + ; Is searchl = 0? + lda searchl! ora a! rz ; yes + ; hashmx = cdrmaxa if searchl ~= 1 + ; dir$max if searchl = 1 + lhld cdrmaxa! mov e,m! inx h! mov d,m + xchg! dcr a! jnz search$h0 + lhld dir$max +search$h0: + shld hashmx + +if BANKED + ; call search$hash in resbdos, a = bank, hl = hash tbl addr + lda hash$tbla+2! lhld hash$tbla! call srch$hash + ; Was search successful? + jnz search$h1 ; no + ; Is directory read required? + lda rd$dir$flag! ora a! mvi c,0 + cnz r$dir2 ; yes if Z flag reset + ; Is function = 18? + lda fx! sui 18! rz ; Never reset dcnt for fx 18 + ; Was media change detected by above read? + lda hashl! inr a! cz setenddir ; yes + xra a! ret ; search$hash successful +search$h1: + ; Was search initiated from beginning of directory? + call end$of$dir! rnz ; no + ; Is bdos fx = 15,17,19,22,23,30? + call tst$log$fxs! rnz ; no + ; Disable hash & return successful + mvi a,0ffh! sta hashl + lhld cdrmaxa! mov e,m! inx h! mov d,m! xchg + dcx h! call set$dcnt$dblk1! xra a! ret +else + lhld hash$tbla! mov b,h! mov c,l + lhld hashmx! xchg + ; Return with Z flag set if dcnt = hashmx + lhld dcnt! push h! call subdh! pop d! ora l! rz + ; Push hashmx - dcnt (# of hashtbl entries to search) + ; Push dcnt + 1 + push h! inx d! xchg! push h + ; Compute .hash$tbl(dcnt) + dcx h! dad h! dad h! dad b +search$h1: + ; Advance hl to address of next hash$tbl entry + lxi d,4! dad d! lxi d,hash + ; Do hash u fields match? + ldax d! xra m! ani 1fh! jnz search$h3 ; no + ; Do hash's match? + call search$h6! jz search$h4 ; yes +search$h2: + xchg! pop h +search$h25: + ; de = .hash$tbl(dcnt), hl = dcnt + ; dcnt = dcnt + 1 + inx h! xthl + ; hl = # of hash$tbl entries to search + ; decrement & test for zero + ; Restore stack & hl to .hashtbl(dcnt) + dcx h! mov a,l! ora h! xthl! push h + ; Are we done? + xchg! jnz search$h1 ; no - keep searching + ; Search unsuccessful + pop h! pop h + ; Was search initiated from beginning of directory? + call end$of$dir! rnz ; no + ; Is fx = 15,17,19,22,23,30 & drive removeable? + call tst$log$fxs! rnz ; no + ; Disable hash & return successful + mvi a,0ffh! sta hashl + lhld cdrmaxa! mov e,m! inx h! mov d,m! xchg + dcx h! call set$dcnt$dblk1! xra a! ret + +search$h3: + ; Does xdcnt+1 = 0ffh? + lda xdcnt+1! inr a! jz search$h5 ; yes + ; Does xdcnt+1 = 0feh? + inr a! jnz search$h2 ; no - continue searching + ; Do hash's match? + call search$h6! jnz search$h2 ; no + ; xdcnt+1 = 0feh + ; Open user 0 search + ; Does hash u field = 0? + mov a,m! ani 1fh! jnz search$h2 ; no + ; Search successful +search$h4: + ; Successful search + ; Set dcnt to search$hash dcnt-1 + ; dcnt gets incremented by read$dir + ; Also discard search$hash loop count + lhld dcnt! xchg + pop h! dcx h! shld dcnt! pop b + ; Does dcnt&3 = 3? + mov a,l! ani 03h! cpi 03h! rz ; yes + ; Does old dcnt & new dcnt reside in same sector? + mov a,e! ani 0fch! mov e,a + mov a,l! ani 0fch! mov l,a + call subdh! ora l! rz ; yes + ; Read directory record + call read$dir2 + ; Has media change been detected? + lda hashl! inr a! cz setenddir ; dcnt = -1 if hashl = 0ffh + xra a! ret +search$h5: + ; xdcnt+1 = 0ffh + ; Make search to save dcnt of empty fcb + ; Is hash$tbl entry empty? + mov a,m! cpi 0f5h! jnz search$h2 ; no +search$h55: + ; xdcnt = dcnt + xchg! pop h! shld xdcnt! jmp search$h25 +search$h6: + ; hash compare routine + ; Is hashl = 0? + lda hashl! ora a! rz ; yes - hash compare successful + ; b = 0f0h if hashl = 3 + ; 0d0h if hashl = 2 + mov c,a! rrc! rrc! rrc! ori 1001$0000b! mov b,a + ; hash s field must be screened out of hash(0) + ; if hashl = 2 + ; Do hash(0) fields match? + ldax d! xra m! ana b! rnz ; no + ; Compare remainder of hash fields for hashl bytes + push h! inx h! inx d! call compare + pop h! ret +endif + +fix$hash: + call test$hash! rz + lxi h,save$hash! lxi d,hash! lxi b,4 + push h! push d! push b! call movef + lhld hash$tbla! push h + call get$dptra! call get$hash + lhld dcnt! dad h! dad h + pop d! dad d + pop b! pop d! push d! push b + +if BANKED + lda hash$tbla+2! call move$out +else + call movef +endif + + pop b! pop h! pop d! jmp movef + +if not MPM +if BANKED + +patch$1dfd: ;[JCE] DRI Patch 7 + lda chksiz+1 + ral + jc get$dir$ext + mvi a,0ffh + sta patch$1e24 + jmp get$dir$ext + +patch$1e0c: + cpi 3 + jnz compare + lda patch$1e24 + inr a + jnz compare + pop h + jmp deblock25 + +patch$1e1c: + xra a + sta patch$1e24 + lhld curbcba + ret + +patch$1e24: + db 0 + +patch$1e25: + lxi h,0 + shld conbuffadd + shld ccp$conbuff + dcx h + dcx h + ret + +patch$2d30: + shld rootbcba + sui 3 + sta patch$2d39 + ret + +patch$2d39: + db 0 + +patch$2d3a: + call patch$2d43 + jmp flush4 + +patch$2d40: + call copy$alv +patch$2d43: + lhld dtabcba + mov a,l + ana h + inr a + rz +patch$2d4a: + mov e,m + inx h + mov d,m + mov a,d + ora e + rz + lxi h,adrive + ldax d + cmp m + jnz patch$2d63 + lxi h,4 + dad d + mvi a,0ffh + cmp m + jnz patch$2d63 + stax d +patch$2d63: + lxi h,0dh + dad d + jmp patch$2d4a + +patch$2d6a: + call copy$alv + lhld lsn$add + mov a,m + ora a + rnz + mvi m,2 + ret + +patch$1e31: + call check$write + lxi h,xdcnt + ret + +patch$1e38: + call reselectx + jmp check$write + +patch$1e3e: + call setfwf + jmp search$namlen + +last: + + org (((last-base)+255) and 0ff00h) - 1 + db 0 + +endif ;BANKED + +else ;not MPM + + ds 192 +last: + org (((last-base)+255) and 0ff00h) - 192 + + ; bnkbdos patch area + + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0,0,0,0 + +free$root: dw $-$ +open$root: dw 0 +lock$root: dw 0 +lock$max: db 0 +open$max: db 0 + +; BIOS access table + +bios equ $ ; base of the bios jump table +bootf equ bios ; cold boot function +wbootf equ bootf+3 ; warm boot function +constf equ wbootf+3 ; console status function +coninf equ constf+3 ; console input function +conoutf equ coninf+3 ; console output function +listf equ conoutf+3 ; list output function +punchf equ listf+3 ; punch output function +readerf equ punchf+3 ; reader input function +homef equ readerf+3 ; disk home function +seldskf equ homef+3 ; select disk function +settrkf equ seldskf+3 ; set track function +setsecf equ settrkf+3 ; set sector function +setdmaf equ setsecf+3 ; set dma function +readf equ setdmaf+3 ; read disk function +writef equ readf+3 ; write disk function +liststf equ writef+3 ; list status function +sectran equ liststf+3 ; sector translate + +endif + + end diff --git a/software/CPM/cpm3/cpmldr.asm b/software/CPM/cpm3/cpmldr.asm new file mode 100644 index 0000000..7849afb --- /dev/null +++ b/software/CPM/cpm3/cpmldr.asm @@ -0,0 +1,1572 @@ + title 'CP/M V3.0 Loader' + + +; Copyright (C) 1982 +; Digital Research +; Box 579, Pacific Grove +; California, 93950 + +; Revised: +; 01 Nov 82 by Bruce Skidmore + +base equ $ +abase equ base-0100h + +cr equ 0dh +lf equ 0ah + +fcb equ abase+005ch ;default FCB address +buff equ abase+0080h ;default buffer address + +; +; System Equates +; +resetsys equ 13 ;reset disk system +printbuf equ 09 ;print string +open$func equ 15 ;open function +read$func equ 20 ;read sequential +setdma$func equ 26 ;set dma address +; +; Loader Equates +; +comtop equ abase+80h +comlen equ abase+81h +bnktop equ abase+82h +bnklen equ abase+83h +osentry equ abase+84h + + cseg + + lxi sp,stackbot + + call bootf ;first call is to Cold Boot + + mvi c,resetsys ;Initialize the System + call bdos + + mvi c,printbuf ;print the sign on message + lxi d,signon + call bdos + + mvi c,open$func ;open the CPM3.SYS file + lxi d,cpmfcb + call bdos + cpi 0ffh + lxi d,openerr + jz error + + lxi d,buff + call setdma$proc + + call read$proc ;read the load record + + lxi h,buff + lxi d,mem$top + mvi c,6 +cloop: + mov a,m + stax d + inx d + inx h + dcr c + jnz cloop + + call read$proc ;read display info + + mvi c,printbuf ;print the info + lxi d,buff + call bdos + +; +; Main System Load +; + +; +; Load Common Portion of System +; + lda res$len + mov h,a + lda mem$top + call load +; +; Load Banked Portion of System +; + lda bank$len + ora a + jz execute + mov h,a + lda bank$top + call load +; +; Execute System +; +execute: + lxi h,fcb+1 + mov a,m + cpi '$' + jnz execute$sys + inx h + mov a,m + cpi 'B' + cz break +execute$sys: + lxi sp,osentry$adr + ret + +; +; Load Routine +; +; Input: A = Page Address of load top +; H = Length in pages of module to read +; +load: + ora a ;clear carry + mov d,a + mvi e,0 + mov a,h + ral + mov h,a ;h = length in records of module +loop: + xchg + lxi b,-128 + dad b ;decrement dma address by 128 + xchg + push d + push h + call setdma$proc + call read$proc + pop h + pop d + dcr h + jnz loop + ret + +; +; Set DMA Routine +; +setdma$proc: + mvi c,setdma$func + call bdos + ret + +; +; Read Routine +; +read$proc: + mvi c,read$func ;Read the load record + lxi d,cpmfcb ;into address 80h + call bdos + ora a + lxi d,readerr + rz +; +; Error Routine +; +error: + mvi c,printbuf ;print error message + call bdos + di + hlt + +break: + db 0ffh + ret + +cpmfcb: + db 0,'CPM3 SYS',0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0,0 + +openerr: + db cr,lf + db 'CPMLDR error: failed to open CPM3.SYS' + db cr,lf,'$' + +readerr: + db cr,lf + db 'CPMLDR error: failed to read CPM3.SYS' + db cr,lf,'$' + +signon: + db cr + db lf,lf,lf,lf,lf,lf,lf,lf,lf,lf,lf,lf + db lf,lf,lf,lf,lf,lf,lf,lf,lf,lf,lf,lf + db 'CP/M V3.0 Loader',cr,lf + db 'Copyright (C) 1998, Caldera Inc. ' + db cr,lf,'$' + maclib makedate + @BDATE ;[JCE] Build date + db 0,0,0,0 +stackbot: + +mem$top: + ds 1 +res$len: + ds 1 +bank$top: + ds 1 +bank$len: + ds 1 +osentry$adr: + ds 2 + +; title 'CP/M 3.0 LDRBDOS Interface, Version 3.1 Nov, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** I n t e r f a c e M o d u l e ** +;** ** +;***************************************************************** +;***************************************************************** +; +; Copyright (c) 1978, 1979, 1980, 1981, 1982 +; Digital Research +; Box 579, Pacific Grove +; California +; +; Nov 1982 +; +; +; equates for non graphic characters +; + +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctlh equ 08h ; backspace + + +; +serial: db 0,0,0,0,0,0 +; +; Enter here from the user's program with function number in c, +; and information address in d,e +; + +bdos: +bdose: ; Arrive here from user programs + xchg! shld info! xchg ; info=de, de=info + + mov a,c! cpi 14! jc bdose2 + sta fx ; Save disk function # + xra a! sta dircnt + lda seldsk! sta olddsk ; Save seldsk + +bdose2: + mov a,e! sta linfo ; linfo = low(info) - don't equ + lxi h,0! shld aret ; Return value defaults to 0000 + shld resel ; resel = 0 + ; Save user's stack pointer, set to local stack + dad sp! shld entsp ; entsp = stackptr + + lxi sp,lstack ; local stack setup + + lxi h,goback ; Return here after all functions + push h ; jmp goback equivalent to ret + mov a,c! cpi nfuncs! jnc high$fxs ; Skip if invalid # + mov c,e ; possible output character to c + lxi h,functab! jmp bdos$jmp + + ; look for functions 100 -> +high$fxs: + sbi 100! jc lret$eq$ff ; Skip if function < 100 + +bdos$jmp: + + mov e,a! mvi d,0 ; de=func, hl=.ciotab + dad d! dad d! mov e,m! inx h! mov d,m ; de=functab(func) + lhld info ; info in de for later xchg + xchg! pchl ; dispatched + + +; dispatch table for functions + +functab: + dw func$ret, func1, func2, func3 + dw func$ret, func$ret, func6, func$ret + dw func$ret, func9, func10, func11 +diskf equ ($-functab)/2 ; disk funcs + dw func12,func13,func14,func15 + dw func16,func17,func18,func19 + dw func20,func21,func22,func23 + dw func24,func25,func26,func27 + dw func28,func29,func30,func31 + dw func32,func33,func34,func35 + dw func36,func37,func38,func39 + dw func40,func42,func43 + dw func44,func45,func46,func47 + dw func48,func49,func50 +nfuncs equ ($-functab)/2 + + +entsp: ds 2 ; entry stack pointer + + ; 40 level stack + + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h + dw 0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h,0c7c7h +lstack: + + +page + title 'CP/M 3.0 LDRBDOS Interface, Version 3.1 July, 1982' +;***************************************************************** +;***************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** C o n s o l e P o r t i o n ** +;** ** +;***************************************************************** +;***************************************************************** +; +; July, 1982 +; +; +; console handlers + +conout: + ;compute character position/write console char from C + ;compcol = true if computing column position + lda compcol! ora a! jnz compout + ;write the character, then compute the column + ;write console character from C + push b ;recall/save character + call conoutf ;externally, to console + pop b ;recall the character + compout: + mov a,c ;recall the character + ;and compute column position + lxi h,column ;A = char, HL = .column + cpi rubout! rz ;no column change if nulls + inr m ;column = column + 1 + cpi ' '! rnc ;return if graphic + ;not graphic, reset column position + dcr m ;column = column - 1 + mov a,m! ora a! rz ;return if at zero + ;not at zero, may be backspace or eol + mov a,c ;character back to A + cpi ctlh! jnz notbacksp + ;backspace character + dcr m ;column = column - 1 + ret + + notbacksp: + ;not a backspace character, eol? + cpi lf! rnz ;return if not + ;end of line, column = 0 + mvi m,0 ;column = 0 + ret +; +; +tabout: + ;expand tabs to console + mov a,c! cpi tab! jnz conout ;direct to conout if not + ;tab encountered, move to next tab pos + tab0: + mvi c,' '! call conout ;another blank + lda column! ani 111b ;column mod 8 = 0 ? + jnz tab0 ;back for another if not + ret +; +print: + ;print message until M(BC) = '$' + LXI H,OUTDELIM + ldax b! CMP M! rz ;stop on $ + ;more to print + inx b! push b! mov c,a ;char to C + call tabout ;another character printed + pop b! jmp print +; +; +func2: equ tabout + ;write console character with tab expansion +; +func9: + ;write line until $ encountered + xchg ;was lhld info + mov c,l! mov b,h ;BC=string address + jmp print ;out to console +; +sta$ret: + ;store the A register to aret + sta aret +func$ret: + ret ;jmp goback (pop stack for non cp/m functions) +; +setlret1: + ;set lret = 1 + mvi a,1! jmp sta$ret +; +func1: equ func$ret +; +func3: equ func$ret +; +func6: equ func$ret +; +func10: equ func$ret +func11: equ func$ret +; +; data areas +; + + +compcol:db 0 ;true if computing column position +; end of BDOS Console module + +;********************************************************************** +;***************************************************************** +; +; Error Messages + +md equ 24h + +err$msg: db cr,lf,'BDOS ERR: ',md +err$select: db 'Select',md +err$phys: db 'Perm.',md + +;***************************************************************** +;***************************************************************** +; +; common values shared between bdosi and bdos + + +aret: ds 2 ; address value to return +lret equ aret ; low(aret) + +;***************************************************************** +;***************************************************************** +;** ** +;** b a s i c d i s k o p e r a t i n g s y s t e m ** +;** ** +;***************************************************************** +;***************************************************************** + +; literal constants + +true equ 0ffh ; constant true +false equ 000h ; constant false +enddir equ 0ffffh ; end of directory +byte equ 1 ; number of bytes for "byte" type +word equ 2 ; number of bytes for "word" type + +; fixed addresses in low memory + +tbuff equ 0080h ; default buffer location + +; error message handlers + +sel$error: + ; report select error + lxi b,err$msg + call print + lxi b,err$select + jmp goerr1 + +goerr: + lxi b,err$msg + call print + lxi b,err$phys +goerr1: + call print + di ! hlt + +bde$e$bde$m$hl: + mov a,e! sub l! mov e,a + mov a,d! sbb h! mov d,a + rnc! dcr b! ret + +bde$e$bde$p$hl: + mov a,e! add l! mov e,a + mov a,d! adc h! mov d,a + rnc! inr b! ret + +shl3bv: + inr c +shl3bv1: + dcr c! rz + dad h! adc a! jmp shl3bv1 + +compare: + ldax d! cmp m! rnz + inx h! inx d! dcr c! rz + jmp compare + +; +; local subroutines for bios interface +; + +move: + ; Move data length of length c from source de to + ; destination given by hl + inr c ; in case it is zero + move0: + dcr c! rz ; more to move + ldax d! mov m,a ; one byte moved + inx d! inx h ; to next byte + jmp move0 + +selectdisk: + ; Select the disk drive given by register D, and fill + ; the base addresses curtrka - alloca, then fill + ; the values of the disk parameter block + mov c,d ; current disk# to c + ; lsb of e = 0 if not yet logged - in + call seldskf ; hl filled by call + ; hl = 0000 if error, otherwise disk headers + mov a,h! ora l! rz ; Return with C flag reset if select error + ; Disk header block address in hl + mov e,m! inx h! mov d,m! inx h ; de=.tran + inx h ! inx h + shld curtrka! inx h! inx h ; hl=.currec + shld curreca! inx h! inx h ; hl=.buffa + inx h! inx h + inx h! inx h + ; de still contains .tran + xchg! shld tranv ; .tran vector + lxi h,dpbaddr ; de= source for move, hl=dest + mvi c,addlist! call move ; addlist filled + ; Now fill the disk parameter block + lhld dpbaddr! xchg ; de is source + lxi h,sectpt ; hl is destination + mvi c,dpblist! call move ; data filled + ; Now set single/double map mode + lhld maxall ; largest allocation number + mov a,h ; 00 indicates < 255 + lxi h,single! mvi m,true ; Assume a=00 + ora a! jz retselect + ; high order of maxall not zero, use double dm + mvi m,false + retselect: + ; C flag set indicates successful select + stc + ret + +home: + ; Move to home position, then offset to start of dir + call homef + xra a ; constant zero to accumulator + lhld curtrka! mov m,a! inx h! mov m,a ; curtrk=0000 + lhld curreca! mov m,a! inx h! mov m,a ; currec=0000 + inx h! mov m,a ; currec high byte=00 + + ret + +pass$arecord: + lxi h,arecord + mov e,m! inx h! mov d,m! inx h! mov b,m + ret + +rdbuff: + ; Read buffer and check condition + call pass$arecord + call readf ; current drive, track, sector, dma + + +diocomp: ; Check for disk errors + ora a! rz + mov c,a + cpi 3! jc goerr + mvi c,1! jmp goerr + +seekdir: + ; Seek the record containing the current dir entry + + lhld dcnt ; directory counter to hl + mvi c,dskshf! call hlrotr ; value to hl + + mvi b,0! xchg + + lxi h,arecord + mov m,e! inx h! mov m,d! inx h! mov m,b + ret + +seek: + ; Seek the track given by arecord (actual record) + + lhld curtrka! mov c,m! inx h! mov b,m ; bc = curtrk + push b ; s0 = curtrk + lhld curreca! mov e,m! inx h! mov d,m + inx h! mov b,m ; bde = currec + lhld arecord! lda arecord+2! mov c,a ; chl = arecord +seek0: + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + push h ; Save low(arecord) + jnc seek1 ; if arecord >= currec then go to seek1 + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! xthl! dcx h! xthl ; curtrk = curtrk - 1 + jmp seek0 +seek1: + lhld sectpt! call bde$e$bde$p$hl ; currec = currec + sectpt + pop h ; Restore low(arecord) + mov a,l! sub e! mov a,h! sbb d! mov a,c! sbb b + jc seek2 ; if arecord < currec then go to seek2 + xthl! inx h! xthl ; curtrk = curtrk + 1 + push h ; save low (arecord) + jmp seek1 +seek2: + xthl! push h ; hl,s0 = curtrk, s1 = low(arecord) + lhld sectpt! call bde$e$bde$m$hl ; currec = currec - sectpt + pop h! push d! push b! push h ; hl,s0 = curtrk, + ; s1 = high(arecord,currec), s2 = low(currec), + ; s3 = low(arecord) + xchg! lhld offset! dad d + mov b,h! mov c,l! shld track + call settrkf ; call bios settrk routine + ; Store curtrk + pop d! lhld curtrka! mov m,e! inx h! mov m,d + ; Store currec + pop b! pop d! + lhld curreca! mov m,e! inx h! mov m,d + inx h! mov m,b ; currec = bde + pop b ; bc = low(arecord), de = low(currec) + mov a,c! sub e! mov l,a ; hl = bc - de + mov a,b! sbb d! mov h,a + call shr$physhf + mov b,h! mov c,l + + lhld tranv! xchg ; bc=sector#, de=.tran + call sectran ; hl = tran(sector) + mov c,l! mov b,h ; bc = tran(sector) + shld sector + call setsecf ; sector selected + lhld curdma! mov c,l! mov b,h! jmp setdmaf + +shr$physhf: + lda physhf! mov c,a! jmp hlrotr + + +; file control block (fcb) constants + +empty equ 0e5h ; empty directory entry +recsiz equ 128 ; record size +fcblen equ 32 ; file control block size +dirrec equ recsiz/fcblen ; directory fcbs / record +dskshf equ 2 ; log2(dirrec) +dskmsk equ dirrec-1 +fcbshf equ 5 ; log2(fcblen) + +extnum equ 12 ; extent number field +maxext equ 31 ; largest extent number +ubytes equ 13 ; unfilled bytes field + +namlen equ 15 ; name length +reccnt equ 15 ; record count field +dskmap equ 16 ; disk map field +nxtrec equ fcblen + +; utility functions for file access + +dm$position: + ; Compute disk map position for vrecord to hl + lxi h,blkshf! mov c,m ; shift count to c + lda vrecord ; current virtual record to a + dmpos0: + ora a! rar! dcr c! jnz dmpos0 + ; a = shr(vrecord,blkshf) = vrecord/2**(sect/block) + mov b,a ; Save it for later addition + mvi a,8! sub m ; 8-blkshf to accumulator + mov c,a ; extent shift count in register c + lda extval ; extent value ani extmsk + dmpos1: + ; blkshf = 3,4,5,6,7, c=5,4,3,2,1 + ; shift is 4,3,2,1,0 + dcr c! jz dmpos2 + ora a! ral! jmp dmpos1 + dmpos2: + ; Arrive here with a = shl(ext and extmsk,7-blkshf) + add b ; Add the previous shr(vrecord,blkshf) value + ; a is one of the following values, depending upon alloc + ; bks blkshf + ; 1k 3 v/8 + extval * 16 + ; 2k 4 v/16+ extval * 8 + ; 4k 5 v/32+ extval * 4 + ; 8k 6 v/64+ extval * 2 + ; 16k 7 v/128+extval * 1 + ret ; with dm$position in a + +getdma: + lhld info! lxi d,dskmap! dad d! ret + +getdm: + ; Return disk map value from position given by bc + call getdma + dad b ; Index by a single byte value + lda single ; single byte/map entry? + ora a! jz getdmd ; Get disk map single byte + mov l,m! mov h,b! ret ; with hl=00bb + getdmd: + dad b ; hl=.fcb(dm+i*2) + ; double precision value returned + mov a,m! inx h! mov h,m! mov l,a! ret + +index: + ; Compute disk block number from current fcb + call dm$position ; 0...15 in register a + sta dminx + mov c,a! mvi b,0! call getdm ; value to hl + shld arecord! mov a,l! ora h! ret + +atran: + ; Compute actual record address, assuming index called + +; arecord = shl(arecord,blkshf) + + lda blkshf! mov c,a + lhld arecord! xra a! call shl3bv + shld arecord! sta arecord+2 + + shld arecord1 ; Save low(arecord) + +; arecord = arecord or (vrecord and blkmsk) + + lda blkmsk! mov c,a! lda vrecord! ana c + mov b,a ; Save vrecord & blkmsk in reg b & blk$off + sta blk$off + lxi h,arecord! ora m! mov m,a! ret + + +getexta: + ; Get current extent field address to hl + lhld info! lxi d,extnum! dad d ; hl=.fcb(extnum) + ret + +getrcnta: + ; Get reccnt address to hl + lhld info! lxi d,reccnt! dad d! ret + +getfcba: + ; Compute reccnt and nxtrec addresses for get/setfcb + call getrcnta! xchg ; de=.fcb(reccnt) + lxi h,(nxtrec-reccnt)! dad d ; hl=.fcb(nxtrec) + ret + +getfcb: + ; Set variables from currently addressed fcb + call getfcba ; addresses in de, hl + mov a,m! sta vrecord ; vrecord=fcb(nxtrec) + xchg! mov a,m! sta rcount ; rcount=fcb(reccnt) + call getexta ; hl=.fcb(extnum) + lda extmsk ; extent mask to a + ana m ; fcb(extnum) and extmsk + sta extval + ret + +setfcb: + ; Place values back into current fcb + call getfcba ; addresses to de, hl + mvi c,1 + + lda vrecord! add c! mov m,a ; fcb(nxtrec)=vrecord+seqio + xchg! lda rcount! mov m,a ; fcb(reccnt)=rcount + ret + +hlrotr: + ; hl rotate right by amount c + inr c ; in case zero + hlrotr0: dcr c! rz ; return when zero + + mov a,h! ora a! rar! mov h,a ; high byte + mov a,l! rar! mov l,a ; low byte + jmp hlrotr0 + +hlrotl: + ; Rotate the mask in hl by amount in c + inr c ; may be zero + hlrotl0: dcr c! rz ; return if zero + + dad h! jmp hlrotl0 + +set$cdisk: + ; Set a "1" value in curdsk position of bc + lda seldsk + push b ; Save input parameter + mov c,a ; Ready parameter for shift + lxi h,1 ; number to shift + call hlrotl ; hl = mask to integrate + pop b ; original mask + mov a,c! ora l! mov l,a + mov a,b! ora h! mov h,a ; hl = mask or rol(1,curdsk) + ret + +test$vector: + lda seldsk + mov c,a! call hlrotr + mov a,l! ani 1b! ret ; non zero if curdsk bit on + +getdptra: + ; Compute the address of a directory element at + ; positon dptr in the buffer + + lhld buffa! lda dptr + ; hl = hl + a + add l! mov l,a! rnc + ; overflow to h + inr h! ret + +clr$ext: + ; fcb ext = fcb ext & 1fh + + call getexta! mov a,m! ani 0001$1111b! mov m,a! + ret + + +subdh: + ; Compute hl = de - hl + mov a,e! sub l! mov l,a! mov a,d! sbb h! mov h,a + ret + +get$buffa: + push d! lxi d,10! dad d + mov e,m! inx h! mov d,m + xchg! pop d! ret + + +rddir: + ; Read a directory entry into the directory buffer + call seek$dir + lda phymsk! ora a! jz rddir1 + mvi a,3 + call deblock$dir! jmp setdata + +rddir1: + call setdir ; directory dma + shld buffa! call seek + call rdbuff ; directory record loaded + +setdata: + ; Set data dma address + lhld dmaad! jmp setdma ; to complete the call + +setdir: + ; Set directory dma address + + lhld dirbcba + call get$buffa + +setdma: + ; hl=.dma address to set (i.e., buffa or dmaad) + shld curdma! ret + +end$of$dir: + ; Return zero flag if at end of directory, non zero + ; if not at end (end of dir if dcnt = 0ffffh) + lxi h,dcnt + mov a,m ; may be 0ffh + inx h! cmp m ; low(dcnt) = high(dcnt)? + rnz ; non zero returned if different + ; high and low the same, = 0ffh? + inr a ; 0ffh becomes 00 if so + ret + +set$end$dir: + ; Set dcnt to the end of the directory + lxi h,enddir! shld dcnt! ret + + +read$dir: + ; Read next directory entry, with c=true if initializing + + lhld dirmax! xchg ; in preparation for subtract + lhld dcnt! inx h! shld dcnt ; dcnt=dcnt+1 + + ; while(dirmax >= dcnt) + call subdh ; de-hl + jc set$end$dir + ; not at end of directory, seek next element + ; initialization flag is in c + + lda dcnt! ani dskmsk ; low(dcnt) and dskmsk + mvi b,fcbshf ; to multiply by fcb size + + read$dir1: + add a! dcr b! jnz read$dir1 + ; a = (low(dcnt) and dskmsk) shl fcbshf + sta dptr ; ready for next dir operation + ora a! rnz ; Return if not a new record + + push b ; Save initialization flag c + call rd$dir ; Read the directory record + pop b ; Recall initialization flag + ret +compext: + ; Compare extent# in a with that in c, return nonzero + ; if they do not match + push b ; Save c's original value + push psw! lda extmsk! cma! mov b,a + ; b has negated form of extent mask + mov a,c! ana b! mov c,a ; low bits removed from c + pop psw! ana b ; low bits removed from a + sub c! ani maxext ; Set flags + pop b ; Restore original values + ret + +get$dir$ext: + ; Compute directory extent from fcb + ; Scan fcb disk map backwards + call getfcba ; hl = .fcb(vrecord) + mvi c,16! mov b,c! inr c! push b + ; b=dskmap pos (rel to 0) +get$de0: + pop b + dcr c + xra a ; Compare to zero +get$de1: + dcx h! dcr b ; Decr dskmap position + cmp m! jnz get$de2 ; fcb(dskmap(b)) ~= 0 + dcr c! jnz get$de1 + ; c = 0 -> all blocks = 0 in fcb disk map +get$de2: + mov a,c! sta dminx + lda single! ora a! mov a,b + jnz get$de3 + rar ; not single, divide blk idx by 2 +get$de3: + push b! push h ; Save dskmap position & count + mov l,a! mvi h,0 ; hl = non-zero blk idx + ; Compute ext offset from last non-zero + ; block index by shifting blk idx right + ; 7 - blkshf + lda blkshf! mov d,a! mvi a,7! sub d + mov c,a! call hlrotr! mov b,l + ; b = ext offset + lda extmsk! cmp b! pop h! jc get$de0 + ; Verify computed extent offset <= extmsk + call getexta! mov c,m + cma! ani maxext! ana c! ora b + ; dir ext = (fcb ext & (~ extmsk) & maxext) | ext offset + pop b ; Restore stack + ret ; a = directory extent + + +search: + ; Search for directory element of length c at info + lhld info! shld searcha ; searcha = info + mov a,c! sta searchl ; searchl = c + + call set$end$dir ; dcnt = enddir + call home ; to start at the beginning + +searchn: + ; Search for the next directory element, assuming + ; a previous call on search which sets searcha and + ; searchl + + mvi c,false! call read$dir ; Read next dir element + call end$of$dir! jz lret$eq$ff + ; not end of directory, scan for match + lhld searcha! xchg ; de=beginning of user fcb + + call getdptra ; hl = buffa+dptr + lda searchl! mov c,a ; length of search to c + mvi b,0 ; b counts up, c counts down + + mov a,m! cpi empty! jz searchn + + searchloop: + mov a,c! ora a! jz endsearch + ; Scan next character if not ubytes + mov a,b! cpi ubytes! jz searchok + ; not the ubytes field, extent field? + cpi extnum ; may be extent field + jz searchext ; Skip to search extent + ldax d + sub m! ani 7fh ; Mask-out flags/extent modulus + jnz searchn ; Skip if not matched + jmp searchok ; matched character + searchext: + ldax d + ; Attempt an extent # match + push b ; Save counters + mov c,m ; directory character to c + call compext ; Compare user/dir char + pop b ; Recall counters + ora a ; Set flag + jnz searchn ; Skip if no match + searchok: + ; current character matches + inx d! inx h! inr b! dcr c + jmp searchloop + endsearch: + ; entire name matches, return dir position + xra a + sta lret ; lret = 0 + ; successful search - + ; return with zero flag reset + mov b,a! inr b + ret + lret$eq$ff: + ; unsuccessful search - + ; return with zero flag set + ; lret,low(aret) = 0ffh + mvi a,255 ! mov b,a ! inr b ! jmp sta$ret + +open: + ; Search for the directory entry, copy to fcb + mvi c,namlen! call search + rz ; Return with lret=255 if end + + ; not end of directory, copy fcb information +open$copy: + call getexta ! mov a,m ! push a ; save extent to check for extent + ; folding - move moves entire dir FCB + call getdptra! xchg ; hl = .buff(dptr) + lhld info ; hl=.fcb(0) + mvi c,nxtrec ; length of move operation + call move ; from .buff(dptr) to .fcb(0) + + ; Note that entire fcb is copied, including indicators + + call get$dir$ext! mov c,a + pop a ! mov m,a ; restore extent + + ; hl = .user extent#, c = dir extent# + ; above move set fcb(reccnt) to dir(reccnt) + ; if fcb ext < dir ext then fcb(reccnt) = fcb(reccnt) | 128 + ; if fcb ext = dir ext then fcb(reccnt) = fcb(reccnt) + ; if fcb ext > dir ext then fcb(reccnt) = 0 + +set$rc: ; hl=.fcb(ext), c=dirext + mvi b,0 + xchg! lxi h,(reccnt-extnum)! dad d + ldax d! sub c! jz set$rc2 + mov a,b! jnc set$rc1 + mvi a,128! mov b,m + + set$rc1: + mov m,a! mov a,b! sta actual$rc! ret + set$rc2: + sta actual$rc + mov a,m! ora a! rnz ; ret if rc ~= 0 + lda dminx! ora a! rz ; ret if no blks in fcb + lda fx! cpi 15! rz ; ret if fx = 15 + mvi m,128 ; rc = 128 + ret + +restore$rc: + ; hl = .fcb(extnum) + ; if actual$rc ~= 0 then rcount = actual$rc + push h + lda actual$rc! ora a! jz restore$rc1 + lxi d,(reccnt-extnum)! dad d + mov m,a! xra a! sta actual$rc + +restore$rc1: + pop h! ret + +open$reel: + ; Close the current extent, and open the next one + ; if possible. + + call getexta + mov a,m! mov c,a + inr c! call compext + jz open$reel3 + + mvi a,maxext! ana c! mov m,a ; Incr extent field + mvi c,namlen! call search ; Next extent found? + ; not end of file, open + call open$copy + + open$reel2: + call getfcb ; Set parameters + xra a! sta vrecord! jmp sta$ret ; lret = 0 + open$reel3: + inr m ; fcb(ex) = fcb(ex) + 1 + call get$dir$ext! mov c,a + ; Is new extent beyond dir$ext? + cmp m! jnc open$reel4 ; no + dcr m ; fcb(ex) = fcb(ex) - 1 + jmp set$lret1 + open$reel4: + call restore$rc + call set$rc! jmp open$reel2 + +seqdiskread: + ; Sequential disk read operation + ; Read the next record from the current fcb + + call getfcb ; sets parameters for the read + + lda vrecord! lxi h,rcount! cmp m ; vrecord-rcount + ; Skip if rcount > vrecord + jc recordok + + ; not enough records in the extent + ; record count must be 128 to continue + cpi 128 ; vrecord = 128? + jnz setlret1 ; Skip if vrecord<>128 + call open$reel ; Go to next extent if so + ; Check for open ok + lda lret! ora a! jnz setlret1 ; Stop at eof + + recordok: + ; Arrive with fcb addressing a record to read + + call index ; Z flag set if arecord = 0 + + jz setlret1 ; Reading unwritten data + + ; Record has been allocated + call atran ; arecord now a disk address + + lda phymsk! ora a ; if not 128 byte sectors + jnz read$deblock ; go to deblock + + call setdata ; Set curdma = dmaad + call seek ; Set up for read + call rdbuff ; Read into (curdma) + jmp setfcb ; Update FCB + +curselect: + lda seldsk! inr a! jz sel$error + dcr a! lxi h,curdsk! cmp m! rz + + ; Skip if seldsk = curdsk, fall into select +select: + ; Select disk info for subsequent input or output ops + mov m,a ; curdsk = seldsk + + mov d,a ; Save seldsk in register D for selectdisk call + lhld dlog! call test$vector ; test$vector does not modify DE + mov e,a! push d ; Send to seldsk, save for test below + call selectdisk! pop h ; Recall dlog vector + jnc sel$error ; returns with C flag set if select ok + ; Is the disk logged in? + dcr l ; reg l = 1 if so + rz ; yes - drive previously logged in + + lhld dlog! mov c,l! mov b,h ; call ready + call set$cdisk! shld dlog ; dlog=set$cdisk(dlog) + ret + +set$seldsk: + lda linfo! sta seldsk! ret + +reselectx: + xra a! sta high$ext! jmp reselect1 +reselect: + ; Check current fcb to see if reselection necessary + mvi a,80h! mov b,a! dcr a! mov c,a ; b = 80h, c = 7fh + lhld info! lxi d,7! xchg! dad d + mov a,m! ana b + ; fcb(7) = fcb(7) & 7fh + mov a,m! ana c! mov m,a + ; high$ext = 80h & fcb(8) + inx h! mov a,m! ana b! sta high$ext + ; fcb(8) = fcb(8) & 7fh + mov a,m! ana c! mov m,a + ; fcb(ext) = fcb(ext) & 1fh + call clr$ext + + ; if fcb(rc) & 80h + ; then fcb(rc) = 80h, actual$rc = fcb(rc) & 7fh + ; else actual$rc = 0 + + call getrcnta! mov a,m! ana b! jz reselect1 + mov a,m! ana c! mov m,b + +reselect1: + sta actual$rc + + lxi h,0 + shld fcbdsk ; fcbdsk = 0 + mvi a,true! sta resel ; Mark possible reselect + lhld info! mov a,m ; drive select code + ani 1$1111b ; non zero is auto drive select + dcr a ; Drive code normalized to 0..30, or 255 + sta linfo ; Save drive code + cpi 0ffh! jz noselect + ; auto select function, seldsk saved above + mov a,m! sta fcbdsk ; Save drive code + call set$seldsk + + noselect: + call curselect + mvi a,0 ! lhld info ! mov m,a + ret + +; +; individual function handlers +; + +func12 equ func$ret + +func13: + + ; Reset disk system - initialize to disk 0 + lxi h,0! shld dlog + + xra a! sta seldsk + dcr a! sta curdsk + + lxi h,tbuff! shld dmaad ; dmaad = tbuff + jmp setdata ; to data dma address + +func14: + ; Select disk info + call set$seldsk ; seldsk = linfo + jmp curselect + +func15: + ; Open file + call reselectx + call open! call openx ; returns if unsuccessful, a = 0 + ret + +openx: + call end$of$dir! rz + call getfcba! mov a,m! inr a! jnz openxa + dcx d! dcx d! ldax d! mov m,a +openxa: + ; open successful + pop h ; Discard return address + mvi c,0100$0000b + ret + +func16 equ func$ret + +func17 equ func$ret + +func18 equ func$ret + +func19 equ func$ret + +func20: + ; Read a file + call reselect + jmp seqdiskread + +func21 equ func$ret + +func22 equ func$ret + +func23 equ func$ret + +func24 equ func$ret + +func25: lda seldsk ! jmp sta$ret + +func26: xchg ! shld dmaad + jmp setdata + +func27 equ func$ret + +func28: equ func$ret + +func29 equ func$ret + +func30 equ func$ret + +func31 equ func$ret + +func32 equ func$ret + +func33 equ func$ret + +func34 equ func$ret + +func35 equ func$ret + +func36 equ func$ret + +func37 equ func$ret + +func38 equ func$ret + +func39 equ func$ret + +func40 equ func$ret + +func42 equ func$ret + +func43 equ func$ret + +func44 equ func$ret + +func45 equ func$ret + +func46 equ func$ret + +func47 equ func$ret + +func48 equ func$ret + +func49 equ func$ret + +func50 equ func$ret + +func100 equ func$ret + +func101 equ func$ret + +func102 equ func$ret + +func103 equ func$ret + +func104 equ func$ret + +func105 equ func$ret + +func106 equ func$ret + +func107 equ func$ret + +func108 equ func$ret + +func109 equ func$ret + + +goback: + ; Arrive here at end of processing to return to user + lda fx! cpi 15! jc retmon + lda olddsk! sta seldsk ; Restore seldsk + lda resel! ora a! jz retmon + + lhld info! mvi m,0 ; fcb(0)=0 + lda fcbdsk! ora a! jz goback1 + ; Restore fcb(0) + mov m,a ; fcb(0)=fcbdsk + goback1: + ; fcb(8) = fcb(8) | high$ext + inx h! lda high$ext! ora m! mov m,a + ; fcb(rc) = fcb(rc) | actual$rc + call getrcnta! lda actual$rc! ora m! mov m,a + ; return from the disk monitor +retmon: + lhld entsp! sphl + lhld aret! mov a,l! mov b,h + ret +; +; data areas +; +dlog: dw 0 ; logged-in disks +curdma ds word ; current dma address +buffa: ds word ; pointer to directory dma address + +; +; curtrka - alloca are set upon disk select +; (data must be adjacent, do not insert variables) +; (address of translate vector, not used) +cdrmaxa:ds word ; pointer to cur dir max value (2 bytes) +curtrka:ds word ; current track address (2) +curreca:ds word ; current record address (3) +drvlbla:ds word ; current drive label byte address (1) +lsn$add:ds word ; login sequence # address (1) + ; +1 -> bios media change flag (1) +dpbaddr:ds word ; current disk parameter block address +checka: ds word ; current checksum vector address +alloca: ds word ; current allocation vector address +dirbcba:ds word ; dir bcb list head +dtabcba:ds word ; data bcb list head +hash$tbla: + ds word + ds byte + +addlist equ $-dpbaddr ; address list size + +; +; buffer control block format +; +; bcb format : drv(1) || rec(3) || pend(1) || sequence(1) || +; 0 1 4 5 +; +; track(2) || sector(2) || buffer$add(2) || +; 6 8 10 +; +; link(2) +; 12 +; + +; sectpt - offset obtained from disk parm block at dpbaddr +; (data must be adjacent, do not insert variables) +sectpt: ds word ; sectors per track +blkshf: ds byte ; block shift factor +blkmsk: ds byte ; block mask +extmsk: ds byte ; extent mask +maxall: ds word ; maximum allocation number +dirmax: ds word ; largest directory number +dirblk: ds word ; reserved allocation bits for directory +chksiz: ds word ; size of checksum vector +offset: ds word ; offset tracks at beginning +physhf: ds byte ; physical record shift +phymsk: ds byte ; physical record mask +dpblist equ $-sectpt ; size of area +; +; local variables +; +blk$off: ds byte ; record offset within block +dir$cnt: ds byte ; direct i/o count + +tranv: ds word ; address of translate vector +linfo: ds byte ; low(info) +dminx: ds byte ; local for diskwrite + +actual$rc: + ds byte ; directory ext record count + +single: ds byte ; set true if single byte allocation map + + +olddsk: ds byte ; disk on entry to bdos +rcount: ds byte ; record count in current fcb +extval: ds byte ; extent number and extmsk + +vrecord:ds byte ; current virtual record + +curdsk: + +adrive: db 0ffh ; current disk +arecord:ds word ; current actual record + ds byte + +arecord1: ds word ; current actual block# * blkmsk + +;******** following variable order critical ***************** + +high$ext: ds byte ; fcb high ext bits +;xfcb$read$only: ds byte + +; local variables for directory access +dptr: ds byte ; directory pointer 0,1,2,3 + +; +; local variables initialized by bdos at entry +; +fcbdsk: ds byte ; disk named in fcb + +phy$off: ds byte +curbcba: ds word + +track: ds word +sector: ds word + +read$deblock: + mvi a,1! call deblock$dta + jmp setfcb + +column db 0 +outdelim: db '$' + +dmaad: dw 0080h +seldsk: db 0 +info: dw 0 +resel: db 0 +fx: db 0 +dcnt: dw 0 +searcha: dw 0 +searchl: db 0 + + +; ************************** +; Blocking/Deblocking Module +; ************************** + +deblock$dir: + + lhld dirbcba + + jmp deblock + +deblock$dta: + lhld dtabcba + +deblock: + + ; BDOS Blocking/Deblocking routine + ; a = 1 -> read command + ; a = 2 -> write command + ; a = 3 -> locate command + ; a = 4 -> flush command + ; a = 5 -> directory update + + push a ; Save z flag and deblock fx + + ; phy$off = low(arecord) & phymsk + ; low(arecord) = low(arecord) & ~phymsk + call deblock8 + lda arecord! mov e,a! ana b! sta phy$off + mov a,e! ana c! sta arecord + + shld curbcba! call getbuffa! shld curdma + + call deblock9 + ; Is command flush? + pop a! push a! cpi 4 + jnc deblock1 ; yes + ; Is referenced physical record + ;already in buffer? + call compare! jz deblock45 ; yes + xra a +deblock1: + call deblock10 + ; Read physical record buffer + mvi a,2! call deblock$io + + call deblock9 ; phypfx = adrive || arecord + call move! mvi m,0 ; zero pending flag + +deblock45: + ; recadd = phybuffa + phy$off*80h + lda phy$off! inr a! lxi d,80h! lxi h,0ff80h +deblock5: + dad d! dcr a! jnz deblock5 + xchg! lhld curdma! dad d + ; If deblock command = locate + ; then buffa = recadd; return + pop a! cpi 3! jnz deblock6 + shld buffa! ret +deblock6: + xchg! lhld dmaad! lxi b,80h + ; If deblock command = read + jmp move$tpa ; then move to dma + +deblock8: + lda phymsk! mov b,a! cma! mov c,a! ret + +deblock9: + lhld curbcba! lxi d,adrive! mvi c,4! ret + +deblock10: + lxi d,4 +deblock11: + lhld curbcba! dad d! ret + +deblock$io: + ; a = 0 -> seek only + ; a = 1 -> write + ; a = 2 -> read + push a! call seek + pop a! dcr a + cp rdbuff + ; Move track & sector to bcb + call deblock10! inx h! inx h + lxi d,track! mvi c,4! jmp move + + org base+((($-base)+255) and 0ff00h)-1 + db 0 + +; Bios equates + +bios$pg equ $ + +bootf equ bios$pg+00 ; 00. cold boot +conoutf equ bios$pg+12 ; 04. console output function +homef equ bios$pg+24 ; 08. disk home function +seldskf equ bios$pg+27 ; 09. select disk function +settrkf equ bios$pg+30 ; 10. set track function +setsecf equ bios$pg+33 ; 11. set sector function +setdmaf equ bios$pg+36 ; 12. set dma function +sectran equ bios$pg+48 ; 16. sector translate +movef equ bios$pg+75 ; 25. memory move function +readf equ bios$pg+39 ; 13. read disk function +move$out equ movef +move$tpa equ movef + + end + \ No newline at end of file diff --git a/software/CPM/cpm3/crdef.plm b/software/CPM/cpm3/crdef.plm new file mode 100644 index 0000000..6e70ed2 --- /dev/null +++ b/software/CPM/cpm3/crdef.plm @@ -0,0 +1,201 @@ +$title('GENCPM Token File Creator') +create$defaults: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 20 Sept 82 by Bruce Skidmore +*/ + + declare true literally '0FFH'; + declare false literally '0'; + declare forever literally 'while true'; + declare boolean literally 'byte'; + declare cr literally '0dh'; + declare lf literally '0ah'; + declare tab literally '09h'; + +/* + D a t a S t r u c t u r e s +*/ + + declare data$fcb (36) byte external; + + declare obuf (128) byte at (.memory); + + declare hexASCII (16) byte external; + + declare symtbl (20) structure( + token(8) byte, + len byte, + flags byte, + qptr byte, + ptr address) external; + +/* + B D O S P r o c e d u r e & F u n c t i o n C a l l s +*/ + + delete$file: + procedure (fcb$address) external; + declare fcb$address address; + end delete$file; + + create$file: + procedure (fcb$address) external; + declare fcb$address address; + end create$file; + + close$file: + procedure (fcb$address) external; + declare fcb$address address; + end close$file; + + write$record: + procedure (fcb$address) external; + declare fcb$address address; + end write$record; + + set$DMA$address: + procedure (DMA$address) external; + declare DMA$address address; + end set$DMA$address; + +/* + M a i n C R T D E F P r o c e d u r e +*/ + crtdef: + procedure public; + declare (flags,symbol$done,i,j,obuf$index,inc) byte; + declare val$adr address; + declare val based val$adr byte; + + inc$obuf$index: + procedure; + + if obuf$index = 7fh then + do; + call write$record(.data$fcb); + do obuf$index = 0 to 7fh; + obuf(obuf$index) = 1ah; + end; + obuf$index = 0; + end; + else + obuf$index = obuf$index + 1; + + end inc$obuf$index; + + emit$ascii$hex: + procedure(dig); + declare dig byte; + + call inc$obuf$index; + obuf(obuf$index) = hexASCII(shr(dig,4)); + call inc$obuf$index; + obuf(obuf$index) = hexASCII(dig and 0fh); + + end emit$ascii$hex; + + call set$dma$address(.obuf); + call delete$file(.data$fcb); + call create$file(.data$fcb); + + obuf$index = 0ffh; + + do i = 0 to 21; + + symbol$done = false; + flags = symtbl(i).flags; + inc = 0; + do while (inc < 16) and (not symbol$done); + + do j = 0 to 7; + call inc$obuf$index; + obuf(obuf$index) = symtbl(i).token(j); + end; + + if (flags and 8) = 0 then + symbol$done = true; + else + do; + if (flags and 10h) <> 0 then + obuf(obuf$index) = 'A' + inc; + else + do; + if inc < 10 then + do; + obuf(obuf$index) = '0' + inc; + end; + else + do; + obuf(obuf$index) = 'A' + inc - 10; + end; + end; + end; + + call inc$obuf$index; + obuf(obuf$index) = ' '; + call inc$obuf$index; + obuf(obuf$index) = '='; + call inc$obuf$index; + obuf(obuf$index) = ' '; + + val$adr = symtbl(i).ptr + (inc * symtbl(i).len); + + if (flags and 1) <> 0 then + do; + call inc$obuf$index; + obuf(obuf$index) = 'A' + val; + end; + else + do; + if (flags and 2) <> 0 then + do; + call inc$obuf$index; + if val then + obuf(obuf$index) = 'Y'; + else + obuf(obuf$index) = 'N'; + end; + else + do; + call emit$ascii$hex(val); + if (flags and 18h) = 8 then + do; + call inc$obuf$index; + obuf(obuf$index) = ','; + val$adr = val$adr + 1; + call emit$ascii$hex(val); + call inc$obuf$index; + obuf(obuf$index) = ','; + val$adr = val$adr + 1; + call emit$ascii$hex(val); + end; + end; + end; + + call inc$obuf$index; + obuf(obuf$index) = cr; + call inc$obuf$index; + obuf(obuf$index) = lf; + + inc = inc + 1; + + end; + + end; + + if obuf$index <= 7fh then + call write$record(.data$fcb); + call close$file(.data$fcb); + + end crtdef; +end create$defaults; diff --git a/software/CPM/cpm3/date.plm b/software/CPM/cpm3/date.plm new file mode 100644 index 0000000..bfaee1b --- /dev/null +++ b/software/CPM/cpm3/date.plm @@ -0,0 +1,672 @@ +$title ('CP/M V3.0 Date and Time') +tod: + do; + +/* + Revised: + 14 Sept 81 by Thomas Rolander + + Modifications: + Date: September 2,1982 + + Programmer: Thomas J. Mason + + Changes: + The 'P' option was changed to the 'C'ontinuous option. + Also added is the 'S'et option to let the user set either + the time or the date. + + Date: October 31,1982 + + Programmer: Bruce K. Skidmore + + Changes: + Added Function 50 call to signal Time Set and Time Get. + + Date: 17 May 1998 + + Programmer: John Elliott + + Changes: + Year 2000 fixes (flagged [JCE] below) + Patch 17 implemented + + Date: 18 Sep 1998 + + Programmer: John Elliott + + Changes: + Added "YMD" date format +*/ + + declare PLM label public; + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon2a: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon2a; + + declare xdos literally 'mon2a'; + declare date$flag$offset literally '0ch'; /* [JCE] Date format */ + + declare fcb (1) byte external; + declare fcb16 (1) byte external; + declare tbuff (1) byte external; + + RETURN$VERSION$FUNC: + procedure address; + return MON2A(12,0); + end RETURN$VERSION$FUNC; + + read$console: + procedure byte; + return mon2 (1,0); + end read$console; + + write$console: + procedure (char); + declare char byte; + call mon1 (2,char); + end write$console; + + print$buffer: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buffer; + + READ$CONSOLE$BUFFER: + procedure (BUFF$ADR); + declare BUFF$ADR address; + call MON1(10,BUFF$ADR); + end READ$CONSOLE$BUFFER; + + check$console$status: + procedure byte; + return mon2 (11,0); + end check$console$status; + + + terminate: + procedure; + call mon1 (0,0); + end terminate; + + crlf: + procedure; + call write$console (0dh); + call write$console (0ah); + end crlf; + + +get$date$flag: procedure byte; /* [JCE] Read the date format flag */ + declare scbpb structure + (offset byte, + set byte, + value address); + scbpb.offset = date$flag$offset; + scbpb.set = 0; + return (mon2(49,.scbpb) and 3); /* [JCE 18-9-1998] extra date formats */ +end get$date$flag; /* [JCE] ends */ + +/***************************************************** + + Time & Date ASCII Conversion Code + + *****************************************************/ +declare BUFFER$ADR structure ( + MAX$CHARS byte, + NUMB$OF$CHARS byte, + CONSOLE$BUFFER(23) byte) /* [JCE] size 21 -> 23 throughout */ + initial(23,0,0,0,0,0,0,0,0,0,0,0, /* because of printing */ + 0,0,0,0,0,0,0,0,0,0,0,0,0); /* four-figure year nos. */ + +declare tod$adr address; +declare tod based tod$adr structure ( + opcode byte, + date address, + hrs byte, + min byte, + sec byte, + ASCII (23) byte ); + +declare string$adr address; +declare string based string$adr (1) byte; +declare index byte; + +declare lit literally 'literally', + forever lit 'while 1', + word lit 'address'; + +/* - - - - - - - - - - - - - - - - - - - - - - */ + emitchar: + procedure(c); + declare c byte; + string(index := index + 1) = c; + end emitchar; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + emitn: + procedure(a); + declare a address; + declare c based a byte; + do while c <> '$'; + string(index := index + 1) = c; + a = a + 1; + end; + end emitn; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + emit$bcd: + procedure(b); + declare b byte; + call emitchar('0'+b); + end emit$bcd; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + emit$bcd$pair: + procedure(b); + declare b byte; + call emit$bcd(shr(b,4)); + call emit$bcd(b and 0fh); + end emit$bcd$pair; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + emit$colon: + procedure(b); + declare b byte; + call emit$bcd$pair(b); + call emitchar(':'); + end emit$colon; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + emit$bin$pair: + procedure(b); + declare b byte; + call emit$bcd(b/10); + call emit$bcd(b mod 10); + end emit$bin$pair; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + emit$slant: + procedure(b); + declare b byte; + call emit$bin$pair(b); + call emitchar('/'); + end emit$slant; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + emit$dash: /* [JCE 18-9-1998] for YMD format dates */ + procedure(b); + declare b byte; + call emit$bin$pair(b); + call emitchar('-'); + end emit$dash; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + declare chr byte; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + + gnc: + procedure; + /* get next command byte */ + if chr = 0 then return; + if index = 22 then /* [JCE] 20 -> 22 */ + do; + chr = 0; + return; + end; + chr = string(index := index + 1); + end gnc; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + deblank: + procedure; + do while chr = ' '; + call gnc; + end; + end deblank; + + numeric: + procedure byte; + /* test for numeric */ + return (chr - '0') < 10; + end numeric; + + scan$numeric: + procedure(lb,ub) byte; + declare (lb,ub) byte; + declare b byte; + b = 0; + call deblank; + if not numeric then go to error; + do while numeric; + if (b and 1110$0000b) <> 0 then go to error; + b = shl(b,3) + shl(b,1); /* b = b * 10 */ + if carry then go to error; + b = b + (chr - '0'); + if carry then go to error; + call gnc; + end; + if (b < lb) or (b > ub) then go to error; + return b; + end scan$numeric; + + scan$delimiter: + procedure(d,lb,ub) byte; + declare (d,lb,ub) byte; + call deblank; + if chr <> d then go to error; + call gnc; + return scan$numeric(lb,ub); + end scan$delimiter; + +declare base$year lit '78', /* base year for computations */ + base$day lit '0', /* starting day for base$year 0..6 */ + month$size (*) byte data + /* jan feb mar apr may jun jul aug sep oct nov dec */ + ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), + month$days (*) word data + /* jan feb mar apr may jun jul aug sep oct nov dec */ + ( 000,031,059,090,120,151,181,212,243,273,304,334); + + leap$days: + procedure(y,m) byte; + declare (y,m) byte; + /* compute days accumulated by leap years */ + declare yp byte; + yp = shr(y,2); /* yp = y/4 */ + if (y and 11b) = 0 and month$days(m) < 59 then + /* y not 00, y mod 4 = 0, before march, so not leap yr */ + return yp - 1; + /* otherwise, yp is the number of accumulated leap days */ + return yp; + end leap$days; + + declare word$value word; + + get$next$digit: + procedure byte; + /* get next lsd from word$value */ + declare lsd byte; + lsd = word$value mod 10; + word$value = word$value / 10; + return lsd; + end get$next$digit; + + bcd: + procedure (val) byte; + declare val byte; + return shl((val/10),4) + val mod 10; + end bcd; + + declare (month, day, year, hrs, min, sec) byte; + + set$date: + procedure; + declare (i, leap$flag) byte; /* temporaries */ + if get$date$flag = 2 then /* [JCE 18-9-1998] YMD format */ + do; + year = scan$numeric(0,99); + month = scan$delimiter('-',1,12) - 1; + if (leap$flag := month = 1) then i = 29; + else i = month$size(month); + day = scan$delimiter('-',1,i); + end; + else + if get$date$flag = 1 then /* [JCE] UK format */ + do; + day = scan$numeric(1,31); + month = scan$delimiter('/',1,12) - 1; + if (leap$flag := month = 1) then i = 29; + else i = month$size(month); + if day > i then go to error; + /* [JCE] year2000: Was year = scan$delimiter('/',base$year,99); */ + year = scan$delimiter('/',0,99); /* [JCE] */ + end; + else /* US format */ + do; + month = scan$numeric(1,12) - 1; + /* may be feb 29 */ + if (leap$flag := month = 1) then i = 29; + else i = month$size(month); + day = scan$delimiter('/',1,i); + /* [JCE] year2000: Was year = scan$delimiter('/',base$year,99); */ + year = scan$delimiter('/',0,99); /* [JCE] */ + end; + if year < base$year /* [JCE] */ + then year = year + 100; /* [JCE] Dates past 2000 */ + /* ensure that feb 29 is in a leap year */ + if leap$flag and day = 29 and (year and 11b) <> 0 then + /* feb 29 of non-leap year */ go to error; + /* compute total days */ + tod.date = month$days(month) + + 365 * (year - base$year) + + day + - leap$days(base$year,0) + + leap$days(year,month); + + end SET$DATE; + + SET$TIME: + procedure; + tod.hrs = bcd (scan$numeric(0,23)); + tod.min = bcd (scan$delimiter(':',0,59)); + if tod.opcode = 2 + then + /* date, hours and minutes only */ + do; + if chr = ':' + then i = scan$delimiter (':',0,59); + tod.sec = 0; + end; + /* include seconds */ + else tod.sec = bcd (scan$delimiter(':',0,59)); + end set$time; + + bcd$pair: + procedure(a,b) byte; + declare (a,b) byte; + return shl(a,4) or b; + end bcd$pair; + + + compute$year: + procedure; + /* compute year from number of days in word$value */ + declare year$length word; + year = base$year; + do forever; + year$length = 365; + if (year and 11b) = 0 then /* leap year */ + year$length = 366; + if word$value <= year$length then + return; + word$value = word$value - year$length; + year = year + 1; + end; + end compute$year; + +declare week$day byte, /* day of week 0 ... 6 */ + day$list (*) byte data ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'), + leap$bias byte; /* bias for feb 29 */ + + compute$month: + procedure; + month = 12; + do while month > 0; + if (month := month - 1) < 2 then /* jan or feb */ + leapbias = 0; + if month$days(month) + leap$bias < word$value then return; + end; + end compute$month; + +declare date$test byte, /* true if testing date */ + test$value word; /* sequential date value under test */ + + get$date$time: + procedure; + /* get date and time */ + hrs = tod.hrs; + min = tod.min; + sec = tod.sec; + word$value = tod.date; + /* word$value contains total number of days */ + week$day = (word$value + base$day - 1) mod 7; + call compute$year; + /* year has been set, word$value is remainder */ + leap$bias = 0; + if (year and 11b) = 0 and word$value > 59 then + /* after feb 29 on leap year */ leap$bias = 1; + call compute$month; + day = word$value - (month$days(month) + leap$bias); + month = month + 1; + end get$date$time; + + emit$date$time: + procedure; + declare century byte; /* [JCE] century */ + + century = 19; /* [JCE] start in the 1900s */ + call emitn(.day$list(shl(week$day,2))); + call emitchar(' '); + century = century + (year / 100); /* [JCE] Y2000 fix for output */ + year = year mod 100; /* [JCE] */ + if get$date$flag = 0 then /* [JCE] US or UK format for dates? */ + do; + call emit$slant(month); + call emit$slant(day); + call emit$bin$pair(century); + call emit$bin$pair(year); + end; + else + if get$date$flag = 1 then /* [JCE 18-9-1998] UK format */ + do; + call emit$slant(day); + call emit$slant(month); + call emit$bin$pair(century); + call emit$bin$pair(year); + end; + else /* [JCE 18-9-1998] YMD format */ + do; + call emit$bin$pair(century); + call emit$dash(year); + call emit$dash(month); + call emit$bin$pair(day); + end; + +/* [JCE] end of Y2000 fix for output */ + call emitchar(' '); + call emit$colon(hrs); + call emit$colon(min); + call emit$bcd$pair(sec); + end emit$date$time; + + tod$ASCII: + procedure (parameter); + declare parameter address; + declare ret address; + ret = 0; + tod$adr = parameter; + string$adr = .tod.ASCII; + if tod.opcode = 0 then + do; + call get$date$time; + index = -1; + call emit$date$time; + end; + else + do; + if (tod.opcode = 1) or + (tod.opcode = 2) then + do; + chr = string(index:=0); + call set$date; + call set$time; + ret = .string(index); + end; + else + do; + go to error; + end; + end; + end tod$ASCII; + +/******************************************************** + ********************************************************/ + + + declare lcltod structure ( + opcode byte, + date address, + hrs byte, + min byte, + sec byte, + ASCII (23) byte ); /* [JCE] 21 -> 23 */ + + declare datapgadr address; + declare datapg based datapgadr address; + + declare extrnl$todadr address; + declare extrnl$tod based extrnl$todadr structure ( + date address, + hrs byte, + min byte, + sec byte ); + + declare i byte; + declare ret address; + + display$tod: + procedure; + lcltod.opcode = 0; /* read tod */ + call mon1(50,.(26,0,0,0,0,0,0,0)); /* BIOS TIME GET SIGNAL */ + call move (5,.extrnl$tod.date,.lcltod.date); + call tod$ASCII (.lcltod); + call write$console (0dh); + do i = 0 to 22; /* [JCE] 20 -> 22 */ + call write$console (lcltod.ASCII(i)); + end; + end display$tod; + + comp: + procedure (cnt,parmadr1,parmadr2) byte; + declare (i,cnt) byte; + declare (parmadr1,parmadr2) address; + declare parm1 based parmadr1 (5) byte; + declare parm2 based parmadr2 (5) byte; + do i = 0 to cnt-1; + if parm1(i) <> parm2(i) + then return 0; + end; + return 0ffh; + end comp; + + + /************************************** + + + Main Program + + + **************************************/ + + declare last$dseg$byte byte initial (0); + declare CURRENT$VERSION address initial (0); + declare CPM30 byte initial (030h); + declare MPM byte initial (01h); + +PLM: +do; + CURRENT$VERSION = RETURN$VERSION$FUNC; + if (low(CURRENT$VERSION) >= CPM30) and (high(CURRENT$VERSION) <> MPM) then + do; + datapgadr = xdos (49,.(03ah,0)); + extrnl$todadr = xdos(49,.(03ah,0)) + 58H; + if (FCB(1) = 'C') then + do while FCB(1) = 'C'; + call mon1(105,.(0,0,0,0)); /* [JCE] this implements Patch 17 */ + if comp(5,.extrnl$tod.date,.lcltod.date) = 0 then + call display$tod; + if check$console$status then + do; + ret = read$console; + fcb(1) = 0; + end; + end; + else + if (FCB(1) = ' ') then + do; + call display$tod; + end; + else + if (FCB(1) = 'S') + then do; + call crlf; + call print$buffer(.('Enter today''s date (','$')); /* [JCE] UK-format */ + if get$date$flag =2 then /* [JCE] */ + call print$buffer(.('YY-MM-DD): ','$')); /* [JCE 18-9-1998] YMD format */ + else if get$date$flag = 1 then /* [JCE 18-9-1998] */ + call print$buffer(.('DD/MM/YY): ','$')); /* [JCE] UK format */ + else call print$buffer(.('MM/DD/YY): ','$')); /* [JCE] US format */ + call move(23,.(000000000000000000000),.buffer$adr.console$buffer); + call read$console$buffer(.buffer$adr); + if buffer$adr.numb$of$chars > 0 + then do; + call move(23,.buffer$adr.console$buffer,.lcltod.ASCII); + tod$adr = .lcltod; + string$adr = .tod.ASCII; + chr = string(index := 0); + call set$date; + call move(2,.lcltod.date,.extrnl$tod.date); + end; /* date initialization */ + call crlf; + call print$buffer(.('Enter the time (HH:MM:SS): ','$')); + call move(23,.(000000000000000000000),.buffer$adr.console$buffer); + call read$console$buffer(.buffer$adr); + if buffer$adr.numb$of$chars > 0 + then do; + call move(23,.buffer$adr.console$buffer,.lcltod.ASCII); + tod$adr = .lcltod; + string$adr = .tod.ASCII; + chr = string(index := 0); + call set$time; + call crlf; + call print$buffer(.('Press any key to set time ','$')); + ret = read$console; + call move(3,.lcltod.hrs,.extrnl$tod.hrs); + call mon1(50,.(26,0,0ffh,0,0,0,0,0)); /* BIOS TIME SET SIGNAL */ + end; + call crlf; + end; + else do; + call move (23,.tbuff(1),.lcltod.ASCII); + lcltod.opcode = 1; + call tod$ASCII (.lcltod); + call crlf; + call print$buffer (.('Strike key to set time','$')); + ret = read$console; + call move (5,.lcltod.date,.extrnl$tod.date); + call mon1(50,.(26,0,0ffh,0,0,0,0,0)); /* BIOS TIME SET SIGNAL */ + call crlf; + end; + call terminate; + end; + else + do; + call CRLF; + call PRINT$BUFFER(.('ERROR: Requires CP/M3.','$')); + call CRLF; + call TERMINATE; + end; + end; + + error: + do; + call crlf; + call print$buffer (.('ERROR: Illegal time/date specification.','$')); + call terminate; + end; + +end tod; diff --git a/software/CPM/cpm3/datmod.asm b/software/CPM/cpm3/datmod.asm new file mode 100644 index 0000000..c5e8516 --- /dev/null +++ b/software/CPM/cpm3/datmod.asm @@ -0,0 +1,169 @@ +$title ('GENCPM Data module') + name datmod + +; Copyright (C) 1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, CA 93950 +; +; Revised: +; 15 Nov 82 by Bruce Skidmore +; + + cseg + + public symtbl + +;declare symtbl(16) structure( +; token(8) byte, /* question variable name */ +; len byte, /* length of structure in array of structures */ +; flags byte, /* type of variable */ +; qptr byte, /* index into query array */ +; ptr address); /* pointer to the associated data structure */ + +; flags definition: +; bit(3) = 1 then array of structures +; bit(4) = 1 then index is A-P else index is 0-F +; bit(2) = 1 then numeric variable +; bit(1) = 1 boolean variable legal values are Y or N +; bit(0) = 1 drive variable legal values are A-P + +symtbl: + db 'PRTMSG ',1, 00000010B,0 + dw prtmsg + db 'PAGWID ',1, 00000100B,1 + dw conwid + db 'PAGLEN ',1, 00000100B,2 + dw conpag + db 'BACKSPC ',1, 00000010B,3 + dw bckspc + db 'RUBOUT ',1, 00000010B,4 + dw rubout + db 'BOOTDRV ',1, 00000001B,5 + dw bdrive + db 'MEMTOP ',1, 00000100B,6 + dw memtop + db 'BNKSWT ',1, 00000010B,7 + dw bnkswt + db 'COMBAS ',1, 00000100B,8 + dw bnktop + db 'LERROR ',1, 00000010B,9 + dw lerror + db 'NUMSEGS ',1, 00000100B,10 + dw numseg + db 'MEMSEG00',5, 00001100B,11 + dw memtbl+5 + db 'HASHDRVA',1, 00011010B,27 + dw hash + db 'ALTBNKSA',10,00011010B,43 + dw record+3 + db 'NDIRRECA',10,00011100B,59 + dw record+4 + db 'NDTARECA',10,00011100B,75 + dw record+5 + db 'ODIRDRVA',10,00011001B,91 + dw record+6 + db 'ODTADRVA',10,00011001B,107 + dw record+7 + db 'OVLYDIRA',10,00011010B,123 + dw record+8 + db 'OVLYDTAA',10,00011010B,139 + dw record+9 + db 'CRDATAF ',1,00000010B,155 + dw crdatf + db 'DBLALV ',1,00000010B,156 + dw dblalv + + public lerror,prtmsg,bnkswt,memtop,bnktop + public bdrive,conpag,conwid,bckspc + public rubout,numseg,hash,memtbl,record + public crdatf,dblalv + +lerror: + db 0ffh +prtmsg: + db 0ffh +bnkswt: + db 0ffh +memtop: + db 0ffh +bnktop: + db 0c0h +bdrive: + db 00h +conpag: + db 23 +conwid: + db 79 +bckspc: + db 0 +rubout: + db 0ffh +numseg: + db 3 +hash: + db 0ffh,0ffh,0ffh,0ffh + db 0ffh,0ffh,0ffh,0ffh + db 0ffh,0ffh,0ffh,0ffh + db 0ffh,0ffh,0ffh,0ffh +memtbl: + db 0,0,0,0,0 + db 0,080h,00h,0,0 + db 0,0c0h,02h,0,0 + db 0,0c0h,03h,0,0 + db 0,0c0h,04h,0,0 + db 0,0c0h,05h,0,0 + db 0,0c0h,06h,0,0 + db 0,0c0h,07h,0,0 + db 0,0c0h,08h,0,0 + db 0,0c0h,09h,0,0 + db 0,0c0h,0ah,0,0 + db 0,0c0h,0bh,0,0 + db 0,0c0h,0ch,0,0 + db 0,0c0h,0dh,0,0 + db 0,0c0h,0eh,0,0 + db 0,0c0h,0fh,0,0 + db 0,0c0h,10h,0,0 +record: + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh + dw 0 + db 0,0,1,1,0,0,0ffh,0ffh +crdatf: + db 0 +dblalv: + db 0ffh + + public quest +quest: + ds 157 + end + \ No newline at end of file diff --git a/software/CPM/cpm3/device.plm b/software/CPM/cpm3/device.plm new file mode 100644 index 0000000..e2d6c8f --- /dev/null +++ b/software/CPM/cpm3/device.plm @@ -0,0 +1,1333 @@ +$ TITLE('CP/M 3.0 --- DEVICE') +device: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* +Written: 09 July 82 by John Knight +Revised 02 Dec 82 by Bruce Skidmore +*/ + +/******************************************** +* * +* LITERALS AND GLOBAL VARIABLES * +* * +********************************************/ + +declare + true literally '1', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + lf literally '10', + ctrlc literally '3', + ctrlx literally '18h', + bksp literally '8', + conin$disp literally '22h', + conout$disp literally '24h', + auxin$disp literally '26h', + auxout$disp literally '28h', + listout$disp literally '2ah', + mb$input literally '1', + mb$output literally '2', + mb$in$out literally '3', + mb$soft$baud literally '4', + mb$serial literally '8', + mb$xon$xoff literally '16', + dev$table$adr$func literally '20', + dev$init$func literally '21', + cpmversion literally '30h', + console$page$offset literally '1ch', + console$width$offset literally '1ah'; + + declare begin$buffer address; + declare buf$length byte; + declare con$width byte; + declare con$page byte; + declare phys$dev$table$adr address; + declare no$chars byte; + declare string$adr address; + declare i byte; + declare device$bit$table (16) byte; + declare memory (255) byte; /* assignment input buffer */ + /* scanner variables and data */ + declare + options(*) byte data + ('NAMES~VALUES~HELP~CON:~CONIN:~CONOUT:~LST:~', + 'AUX:~AUXIN:~AUXOUT:~CONSOLE~KEYBOARD~', + 'PRINTER~AUXILIARY~AXI:~AXO:',0ffh), + + options$offset(*) byte data + (0,6,13,18,23,30,38,43,48,55,63,71,80,88,98,103,107), + + mods(*) byte data + ('XON~NOXON~NULL~50 ~75 ~110~134~150~300~', + '600~1200~1800~2400~3600~4800~7200~', + '9600~19200',0ffh), + + mods$offset(*) byte data + (0,4,10,15,21,27,31,35,39,43,47,52,57,62, + 67,72,77,82,87), + + page$options (*) byte data + ('COLUMNS~LINES~PAGESIZE',0ffh), + + page$offsets (*) byte data + (0,8,14,22), + + end$list byte data (0ffh), + + delimiters(*) byte data (0,'[]=, ',0,0ffh), + + SPACE byte data(5), + j byte initial(0), + buf$ptr address, + index byte, + endbuf byte, + delimiter byte; + + declare end$of$string byte initial ('~'); + + /* tables */ + declare phys$table (15) structure + (name(6) byte, + characteristic byte, + baud byte); + + declare biospb structure + (func byte, + areg byte, + bcreg address, + dereg address, + hlreg address); + + declare scbpd structure + (offset byte, + set byte, + value address); + + declare baud$rates (*) byte data + ('NONE 50 75 110 134 150 300 600 ', + '1200 1800 2400 3600 4800 7200 9600 19200'); + + declare baud$table (16) structure + (graphic (5) byte) at (.baud$rates(0)); + + declare log$offsets (*) byte data + (0,conin$disp,conout$disp,listout$disp,1,auxin$disp, + auxout$disp,3,conin$disp,listout$disp,2,auxin$disp,auxout$disp); + + declare characteristics$table (*) byte data + ('INPUT $OUTPUT $SOFT-BAUD$SERIAL $XON-XOFF $'); + + declare char$table (5) structure + (graphic (10) byte) at (.characteristics$table(0)); + + declare plm label public; + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + printchar: + procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + + print$buf: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buf; + + read$console$buf: + procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address address; + declare max byte; + new$max = max; + call mon1(10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of chars input */ + end read$console$buf; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + getscbbyte: procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); + end getscbbyte; + + getscbword: + procedure (offset) address; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon3(49,.scbpd); + end getscbword; + + setscbbyte: + procedure (offset,value); + declare offset byte; + declare value byte; + scbpd.offset = offset; + scbpd.set = 0FFH; + scbpd.value = double(value); + call mon1(49,.scbpd); + end setscbbyte; + + setscbword: + procedure (offset,value); + declare offset byte; + declare value address; + scbpd.offset = offset; + scbpd.set = 0FEh; + scbpd.value = value; + call mon1(49,.scbpd); + end setscbword; + + direct$bios: + procedure (func) address; + declare func byte; + biospb.func = func; + return mon3(50,.biospb); + end direct$bios; + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr,idx$ptr); + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + idx$ptr address, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index based idx$ptr byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + /* No skip for DEVICE */ + do while ((delimiter < 1) or (delimiter > 6)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while ((delimiter := separator(charac)) = SPACE); + buf$ptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return; + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return; + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then + buf$ptr = buf$ptr + 1; + else + delimiter = 5; + return; + +end opt$scanner; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +ucase: procedure (char) byte; + declare char byte; + if char >= 'a' then + if char < '{' then + return (char-20h); + return char; +end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* fill string @ s for c bytes with f */ +fill: proc(s,f,c); + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* The error processor. This routine prints the command line + with a carot '^' under the offending delimiter, or sub-string. + The code passed to the routine determmines the error message + to be printed beneath the command string. */ + +errors: procedure (code); + declare (code,i,j,nlines,rem) byte; + declare (string$ptr,tstring$ptr) address; + declare chr1 based string$ptr byte; + declare chr2 based tstring$ptr byte; + declare carot$flag byte; + +print$command: procedure (size); + declare size byte; + do j=1 to size; /* print command string */ + call printchar(chr1); + string$ptr = string$ptr + 1; + end; + call crlf; + do j=1 to size; /* print carot if applicable */ + if .chr2 = buf$ptr then do; + carot$flag = true; + call printchar('^'); + end; + else + call printchar(' '); + tstring$ptr = tstring$ptr + 1; + end; + call crlf; +end print$command; + + carot$flag = false; + string$ptr,tstring$ptr = begin$buffer; + if con$width < 40 then con$width = 40; /* minimum size screen assumed */ + nlines = buf$length / con$width; /* determine number lines to print */ + rem = buf$length mod con$width; /* number of extra characters */ + if (code = 2) or (code = 1) then /* adjust carot pointer */ + buf$ptr = buf$ptr - 1; /* for delimiter errors */ + else + buf$ptr = buf$ptr - endbuf - 1; /* for sub-string errors */ + call crlf; + do i=1 to nlines; + tstring$ptr = string$ptr; + call print$command(con$width); + end; + call print$command(rem); + if carot$flag then + call print$buf(.('Error at the ''^''; $')); + else + call print$buf(.('Error at end of line; $')); + if con$width < 63 then + call crlf; + do case code; /* error messages */ + call print$buf(.('Invalid number$')); + call print$buf(.('End of line expected$')); + call print$buf(.('Invalid delimiter$')); + call print$buf(.('Invalid option$')); + call print$buf(.('Baud rate can not be set for this device$')); + call print$buf(.('Invalid physical device$')); + call print$buf(.('Physical device does not have input capability$')); + call print$buf(.('Physical device does not have output capability$')); + call print$buf(.('Physical device does not have input/output capability$')); + call print$buf(.('A NULL device can not be assigned to CONIN$')); + call print$buf(.('Ambiguous assignments to a NULL device are not allowed$')); + end; + call crlf; + call mon1(0,0); +end errors; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/* Help display. A simple print of the syntax accepted by this + utility. The display assumes a minimum 40 column screen and + does not give an explanation to the commands. For quick ref. only + + help: procedure; COMMENTED OUT -- NEW HELP + PROGRAM WILL REPLACE THIS + DISPLAY + call print$buf(.( + 'COMMAND SYNTAX:',cr,lf,cr,lf, + 'DEVICE',cr,lf, + 'DEVICE NAMES',cr,lf, + 'DEVICE VALUES',cr,lf, + 'DEVICE pd',cr,lf, + 'DEVICE ld',cr,lf, + 'DEVICE ld=pd[opt,opt],pd[opt],...',cr,lf, + 'DEVICE pd[opt,opt]',cr,lf, + 'DEVICE ld=NULL',cr,lf, + 'DEVICE CONSOLE[COLUMNS=nnn,LINES=nnn]',cr,lf, + 'DEVICE CONSOLE[PAGESIZE]',cr,lf,cr,lf, + 'pd = a physical device',cr,lf, + 'ld = a logical device',cr,lf, + ' CON:,CONIN:,CONOUT:,LST:,AUX:,',cr,lf, + ' AUXIN:,AXI:,AUXOUT:,AXO:,CONSOLE,',cr,lf, + ' KEYBOARD,PRINTER, or AUXILIARY',cr,lf, + 'opt = a valid option',cr,lf, + ' XON,NOXON, or a baud rate: 50,',cr,lf, + ' 75,110,134,150,300,600,1200,1800,',cr,lf, + ' 2400,3600,4800,7200,9600,19200',cr,lf, + 'nnn = a number; 0-255',cr,lf,'$')); +end help; */ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +set$bit: + procedure (val,bit) address; + /* sets a bit in 0-15 in val, returns val */ + declare bit byte; + declare val address; + declare temp address; + temp = 1; + bit = 15 - bit; + if bit <> 0 then + temp = shl(temp,bit); + val = val or temp; + return val; +end set$bit; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine assigns to a word in the system control block a + bit pattern as specified in the device$bit$table. */ + +make$assignments: procedure (offset); + declare (i,offset) byte; + declare val address; + val = 0; /* clear address to be set */ + do i=0 to 15; + if device$bit$table(i) = 1 + then val= set$bit(val,i); + end; + call setscbword(offset,val); +end make$assignments; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine prints the physical device located in the + physical device table at the index passed to the routine */ + +print$phys$device: procedure (index); + declare (i,index) byte; + do i=0 to 5; + call printchar(phys$table(index).name(i)); + end; +end print$phys$device; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine prints the baud rate corresponding to the baud + code found in the physical device table. The index to the + physical device table is passed to this routine. */ + +print$baud$rate: procedure (index); + declare (k,index,baud) byte; + baud = phys$table(index).baud; + if baud > 15 then baud = 0; + do k=0 to 4; + call printchar(baud$table(baud).graphic(k)); + end; +end print$baud$rate; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine prints the physical characteristics codes for + a specific physical device found in the physical device table. + This procedure is called by names. */ + +print$phys$characteristics: procedure (index); + declare (char,index,ct) byte; + ct = 0; + char = phys$table(index).characteristic; + char = shr(char,1); + if carry = 0ffh then do; /* input bit */ + call printchar('I'); + ct = ct + 1; + end; + char = shr(char,1); + if carry = 0ffh then do; /* output bit */ + call printchar('O'); + ct = ct + 1; + end; + char = shr(char,2); /* skip soft-baud */ + if carry = 0ffh then do; /* serial bit in carry */ + call printchar('S'); + ct = ct + 1; + end; + char = shr(char,1); + if carry = 0ffh then do; /* xon-xoff bit */ + call printchar('X'); + ct = ct + 1; + end; + do while ct <> 4; + call printchar(' '); + ct = ct + 1; + end; +end print$phys$characteristics; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine prints the names of the physical devices as well + as the baud rate and characteristics codes. */ + +names: procedure; + declare (i,j,cols,char,baud,k) byte; + call crlf; + call print$buf(.('Physical Devices: ',cr,lf,'$')); + call print$buf(.('I=Input,O=Output,S=Serial,X=Xon-Xoff',cr,lf,'$')); + i = con$width; + if i < 40 then i = 40; + cols = i / 20; /* determine columns per line */ + j = 0; /* table index */ +crloop: i=1; /* columns counter */ +process: if phys$table(j).name(0) = 0 then do; + call crlf; + return; + end; + /* print device name, baud, and attributes */ + call print$phys$device(j); + call printchar(' '); + call print$baud$rate(j); + call printchar(' '); + call print$phys$characteristics(j); + call print$buf(.(' $')); + j = j + 1; + if i >= cols then do; + call crlf; + goto crloop; + end; + i = i + 1; + goto process; +end names; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine prints the physical devices that are assigned + to the logical device. The bit pattern of the vector passed + to this routine determines the current assignments to the device */ + +show$physical$devices: + procedure (vector); + declare vector address; + declare device$present byte; + declare bit$table (16) byte; + declare (i,k,cols,max) byte; + i = con$width; + if i < 40 then i = 40; + cols = (i - 10) / 7; /* determine phys$devices per line */ + do i = 0 to 15; + vector = shl(vector,1); + bit$table(i) = carry; /* ff = 1, 0 = 0 */ + end; + i = 0; + do while phys$table(i).name(0) <> 0; + if i = 15 then goto set$max; + i = i + 1; + end; + set$max: max = i; /* number of entries in table */ + device$present = false; + k = 1; /* cols printed count */ + do i = 0 to 14; + if bit$table(i) = 0ffh then do; + /* obtain match from physical device table */ + if i > max then do; + call print$buf(.(cr,lf,'Bad Logical Device Assignment; $')); + call print$buf(.('Physical Device Does Not Exist$')); + call crlf; + return; + end; + device$present = true; + call print$phys$device(i); + call printchar(' '); + k = k + 1; + if k > cols then do; + k = 1; + call crlf; + call print$buf(.(' $')); + end; + end; + end; + if bit$table(15) = 0ffh then do; /* File assignment */ + device$present = true; + call print$buf(.('File$')); + end; + if (device$present = false) then + call print$buf(.('Null Device$')); + call crlf; + end show$physical$devices; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This procedure produces the values display. It shows all the + assignments of physical devices to the logical devices */ + +values: procedure; + declare val address; + call crlf; + call print$buf(.('Current Assignments: ',cr,lf,'$')); + val = getscbword(conin$disp); + call print$buf(.('CONIN: = $')); + call show$physical$devices(val); + val = getscbword(conout$disp); + call print$buf(.('CONOUT: = $')); + call show$physical$devices(val); + val = getscbword(auxin$disp); + call print$buf(.('AUXIN: = $')); + call show$physical$devices(val); + val = getscbword(auxout$disp); + call print$buf(.('AUXOUT: = $')); + call show$physical$devices(val); + val = getscbword(listout$disp); + call print$buf(.('LST: = $')); + call show$physical$devices(val); + call crlf; + end values; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This procedure searches for the string pointed to by + search$string$adr in the local physical device table. + The length of the input string is determined by endbuf. */ + +search$physical$table: + procedure (search$string$adr) byte; + declare (i,j) byte; + declare search$string$adr address; + declare string (6) byte; + declare loc based search$string$adr (6) byte; + if endbuf > 6 then return 0ffh; + call fill(.string(0),' ',6); + do i=0 to (endbuf-1); + string(i)=loc(i); + end; + i = 0; + do while phys$table(i).name(0) <> 0; + do j=0 to 5; + if string(j) <> phys$table(i).name(j) + then goto search$next; + end; + return i; /* found; return index */ + search$next: i=i+1; + if i > 15 then return 0ffh; /* not found */ + end; + return 0ffh; /* not found, table empty */ + end search$physical$table; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine processes the physical device options: 'XON','NOXON' +and the baud rates. It calls the scanner and processes on the fly */ + +process$option: procedure (table$index); + declare table$index byte; + declare soft$baud byte; + declare (char,baud) byte; + declare val address; + char = phys$table(table$index).characteristic; + baud = phys$table(table$index).baud; + index = 0; + delimiter = 1; + do while((delimiter <> 2) and (delimiter <> 6)); + call opt$scanner(.mods(0),.mods$offset(0),.index); + if index = 0 then call errors(3); + if index = 3 then call errors(3); + if index = 1 then /* Xon */ + phys$table(table$index).characteristic = char or mb$xon$xoff; + if index = 2 then /* No Xon */ + phys$table(table$index).characteristic = char and (not mb$xon$xoff); + if index > 2 then do; /* baud rates to be set */ + index = index - 3; + /* set baud rate only if soft$baud set to 1 */ + soft$baud = shr(char,3); + soft$baud = carry; /* 0ffh = 1, 0 = 0 */ + if soft$baud = 0 then + call errors(4); + /* set baud in table and have bios initialize device */ + phys$table(table$index).baud = index; + /* move local phys$device table to actual table in bios */ + call move(120,.phys$table(0),phys$dev$table$adr); + biospb.bcreg = double(table$index); + val = direct$bios(dev$init$func); + end; + else + call move(120,.phys$table(0),phys$dev$table$adr); + end; +end process$option; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine converts an ascii number string into a byte number. + ie. 32h 35h 35h ==> FFh in one byte. Numbers allowed are 0-255 */ + +number: procedure (loc,length) byte; + declare (loc,val) address; + declare (length,i) byte; + declare chr based loc byte; + if length > 3 then + call errors(0); + val = 0; + do i=1 to length; + if (chr < 30h) or (chr > 39h) then + call errors(0); + val = val * 10 + (chr - 30h); + loc = loc + 1; + end; + if val > 255 then + call errors(0); + return low(val); +end number; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine converts a byte into an ascii string of numbers, + printing the number to the screen. ie. FFh ==> 255 */ + +print$byte: procedure (num); + declare (hundreds,tens,ones,num) byte; + hundreds = num / 100; + num = num - (100 * hundreds); + tens = num / 10; + ones = num - (10 * tens); + if hundreds > 0 then + call printchar(hundreds + 30h); + if (hundreds > 0) or (tens > 0) then + call printchar(tens + 30h); + call printchar(ones + 30h); +end print$byte; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This procedure processes the console page setting options. + It parses the command options and sets the scb page accordingly. + The result of the process is displayed showing the user the + number of lines and columns of the console. */ + +process$page$options: procedure; + declare num byte; + delimiter=1; + index=0; + do while ((delimiter <> 2) and (delimiter <> 6)); + call opt$scanner(.page$options(0),.page$offsets(0),.index); + if index = 0 then /* bad option */ + call errors(3); + if index = 1 then do; /* columns */ + if delimiter <> 3 then /* '=' */ + call errors(2); + else do; + call opt$scanner(.page$options(0),.page$offsets(0),.index); + num = number(buf$ptr-endbuf-1,endbuf)-1; + call setscbbyte(console$width$offset,num); + end; + end; + if index = 2 then do; /* lines */ + if delimiter <> 3 then + call errors(2); + else do; + call opt$scanner(.page$options(0),.page$offsets(0),.index); + num = number(buf$ptr-endbuf-1,endbuf)-1; + call setscbbyte(console$page$offset,num); + end; + end; + end; + con$width = getscbbyte(console$width$offset); + con$page = getscbbyte(console$page$offset); + call crlf; + call print$buf(.('Console width set to $')); + call print$byte(con$width+1); + call print$buf(.(' columns',cr,lf,'Console page set to $')); + call print$byte(con$page+1); + call print$buf(.(' lines',cr,lf,'$')); + call crlf; + call mon1(0,0); +end process$page$options; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine produces the display of the assignments to an + individual logical device. The command that invokes this + procedure is 'DEVICE '. */ + +show$assignments: procedure (index); + declare (index,offset) byte; + declare val address; + offset = log$offsets(index-4); + if (offset = 0) or (offset = 3) then do; /* CON: */ + call print$buf(.('CONIN: = $')); + val = getscbword(conin$disp); + call show$physical$devices(val); + call print$buf(.('CONOUT: = $')); + val = getscbword(conout$disp); + call show$physical$devices(val); + end; + if (offset = 1) or (offset = 2) then do; /* AUX: */ + call print$buf(.('AUXIN: = $')); + val = getscbword(auxin$disp); + call show$physical$devices(val); + call print$buf(.('AUXOUT: = $')); + val = getscbword(auxout$disp); + call show$physical$devices(val); + end; + if offset > 3 then do; /* all others */ + do case (offset - 22h); + call print$buf(.('CONIN: = $')); + ; + call print$buf(.('CONOUT: = $')); + ; + call print$buf(.('AUXIN: = $')); + ; + call print$buf(.('AUXOUT: = $')); + ; + call print$buf(.('LST: = $')); + end; + val = getscbword(offset); + call show$physical$devices(val); + end; + call crlf; + call mon1(0,0); +end show$assignments; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine is called if the first sub-string in the command + line was determined to be a logical device. If an end-of-line + is the delimiter, the routine will display the assignments to + the specified logical device. If a '[' is found as the delimiter + and the logical device is console, then the option processor to + set the console page parameters is called. If the delimiter was + an '=' then an assignment of physical devices to the logical + device is done. */ + +found$logical$device: procedure; + declare (save$index,offset,eoln,i,val) byte; + declare next$delim based buf$ptr byte; + save$index = index; /* save index to logical device */ + if (delimiter = 0) or (delimiter = 6) + then call show$assignments(index); /* DEVICE */ + else do; + if delimiter = 1 then do; /* '[' */ + if (index=4) or (index=5) or (index=6) or (index=11) then + call process$page$options; /* DEVICE CON:[col=45,lines=21] */ + else + call errors(2); + end; + else if delimiter <> 3 then + call errors(2); + end; + delimiter = 1; /* do assignment: DEVICE CON:=CRT,CRT1[XON,1200],... */ + index = 0; + call opt$scanner(.mods(0),.mods$offset(0),.index); + offset = log$offsets(save$index - 4); + if index = 3 then do; /* NULL */ + if (offset < 4) then do; /* CON: and AUX:*/ + call errors(10); + end; + else do; + if (offset=conin$disp) then do; + call errors(9); + end; + else do; + call setscbword(offset,0); + end; + end; + end; + else do; /* Process physical name */ + eoln = false; + do i = 0 to 15; /* clear bit table */ + device$bit$table(i) = 0; + end; + do while not eoln; + val = search$physical$table(buf$ptr-endbuf-1); + if val = 0ffh then /* not found */ + call errors(5); + device$bit$table(val) = 1; /* mark bit to be set in log device vector */ + if delimiter = 1 then + call process$option(val); + if (delimiter=0) or (delimiter=6) or ((delimiter=2) and (next$delim=0)) + then eoln = true; + if ((delimiter = 2) and (next$delim = ',')) then + buf$ptr = buf$ptr + 1; /* case where 2 delimiters: '],' */ + if not eoln then + call opt$scanner(.mods(0),.mods$offset(0),.index); + end; + if (offset = 0) or (offset = 3) then do; /* CON: */ + if ((phys$table(val).characteristic and mb$in$out)=mb$in$out) then do; + call make$assignments(conin$disp); + call make$assignments(conout$disp); + end; + else call errors(8); + end; + else do; + if ((offset=1) or (offset=2)) then do; /* AUX: */ + if ((phys$table(val).characteristic and mb$in$out)=mb$in$out) then do; + call make$assignments(auxin$disp); + call make$assignments(auxout$disp); + end; + else call errors(8); + end; + else do; + if ((offset=conin$disp) or (offset=auxin$disp)) then do; + if ((phys$table(val).characteristic and mb$input)<> mb$input) + then call errors(6); + else call make$assignments(offset); /* CONIN: OR AUXIN: */ + end; + else do; + if ((phys$table(val).characteristic and mb$output)<> mb$output) + then call errors(7); + else call make$assignments(offset); /* CONOUT: OR AUXOUT: OR LSTOUT: */ + end; + end; + end; + end; +end found$logical$device; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine produces the display invoked by the command + string: 'DEVICE '. It prints the characteristics + of the device as found in the physical device table */ + +show$characteristics: procedure (index); + declare (index,char,baud,j,i) byte; + char = phys$table(index).characteristic; + baud = phys$table(index).baud; + call crlf; + call print$buf(.('Physical Device: $')); + call print$phys$device(index); + call crlf; + call print$buf(.('Baud Rate: $')); + call print$baud$rate(index); + call crlf; + call print$buf(.('Characteristics: $')); + do i=0 to 4; + char = shr(char,1); + if carry = 0ffh then do; + call print$buf(.char$table(i)); + call crlf; + do j=0 to 17; + call printchar(' '); + end; + end; + else do; + if i = 3 then do; + call print$buf(.('PARALLEL$')); + call crlf; + do j=0 to 17; + call printchar(' '); + end; + end; + end; + end; + call mon1(0,0); +end show$characteristics; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine is called whenever a presummed physical device + is found as the first entry by the parser. It looks up the + string in the physical device table to validate it. If the + device has options, it calls process option to set the baud & protocol */ + +found$physical$device: procedure (string$adr); + declare (eoln,index) byte; + declare string$adr address; + if (delimiter=0) or (delimiter=6) then + eoln = true; + else + eoln = false; + index = search$physical$table(string$adr); + if index = 0ffh then + call errors(5); + if eoln then /* DEVICE */ + call show$characteristics(index); + if delimiter = 1 then + call process$option(index); + else + call errors(2); +end found$physical$device; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine determines which of the sub-routines should + continue with the parsing and eventual execution of the + command string. In the event that the commands were 'NAMES', + 'VALUES', no further parsing is needed and the routines + are called directly to produce the desired displays. */ + +parser: procedure; + declare (t,char,i) byte; + declare eoln byte; + declare phys$dev byte; + declare log$dev byte; + delimiter = 1; + index = 0; + if tbuff(0) = 0 then + begin$buffer,buf$ptr = .memory(2); + else do; + buf$ptr = .tbuff(2); + begin$buffer = .tbuff(1); + buf$length = tbuff(0); + end; + call opt$scanner(.options(0),.options$offset(0),.index); + if (delimiter=0) or (delimiter=2) or (delimiter=6) then + eoln = true; + else + eoln = false; + if (index = 0) or (index = 3) then do; /* HELP is now a valid phys device */ + call found$physical$device(buf$ptr-endbuf-1); + call names; /* show results */ + call values; + end; + else do; + if index = 1 then do; /* names */ + if eoln then + call names; + else + call errors(1); + end; + else do; + if index = 2 then do; /* values */ + if eoln then + call values; + else + call errors(1); + end; + else do; + call found$logical$device; + call names; /* show results */ + call values; + end; + end; + end; +end parser; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = 9); /* tabs & spaces */ + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + +/************************************** +* * +* M A I N P R O G R A M * +* * +**************************************/ + +plm: + do; + if (low(version) < cpmversion) or (high(version) = 1) then do; + call print$buf(.('Requires CP/M 3.0$')); + call mon1(0,0); + end; + phys$dev$table$adr = direct$bios(dev$table$adr$func); + if (tbuff(0) <> 0) and (phys$dev$table$adr = 0) then do; + buf$ptr = .tbuff(1); + call opt$scanner(.options(0),.options$offset(0),.index); + if ((index = 4) or (index = 11)) and (delimiter = 1) then do; + call parser; + call mon1(0,0); + end; + end; + if (phys$dev$table$adr = 0) then do; + call print$buf(.('Device Reassignment Not Supported$')); + call mon1(0,0); + end; + con$width = getscbbyte(console$width$offset); + con$page = getscbbyte(console$page$offset); + call move(120,phys$dev$table$adr,.phys$table(0)); + if not input$found(.tbuff(1)) then do; + /* display names & values and prompt for the assignment */ + call names; + call values; + call print$buf(.('Enter new assignment or hit RETURN $')); + /* can not use default dma; not always enough room for input */ + call crlf; + no$chars = read$console$buf(.memory(0),255); + call crlf; + memory(1) = ' '; /* blank out nc field */ + memory(no$chars+2) = 0; /* mark eoln */ + if not input$found(.memory(1)) then /* no input, quit */ + call mon1(0,0); + do i=1 to no$chars; /* convert input to caps */ + memory(i+1) = ucase(memory(i+1)); + end; + buf$length = no$chars; + end; + call parser; + call mon1(0,0); + end; +end device; diff --git a/software/CPM/cpm3/dirlbl.asm b/software/CPM/cpm3/dirlbl.asm new file mode 100644 index 0000000..9084ead --- /dev/null +++ b/software/CPM/cpm3/dirlbl.asm @@ -0,0 +1,546 @@ +;Function 100 RSX (set/create directory label +; Only for Non banked systems +; +; Procedure: +; 1. If this BDOS call ~= f100 then go to NEXT +; 2. select the current disk for BIOS calls +; 3. search for current label +; 4. if no label then do +; a. find first empty dir slot +; b. if no empties then return error +; c. create dir label from user FCB in DE +; d. call update SFCB +; e. return +; 5. if password protected then ok = password() +; 6. if ~ok then return error +; 7. update label from user info +; 8. call update SFCB +; 9. return +; +; P. Balma + +; +; RSX PREFIX +; +serial: db 0,0,0,0,0,0 +jmp1: jmp ftest +NEXTj: db 0c3h ; next RSX or BDOS +NEXTa: db 0,0 ; next address +prev: dw 0 ; where from +remove: db 0ffh ; remove RSX at warm start +nbank: db 0FFh ; non banked RSX +rsxname: db 'DIRLBL ' +space: dw 0 +patch: db 0 +; +; +ftest: + push a ;save user regs + mov a,c + cpi 64h ;compare BDOS func 100 + jz func100 + pop a ;some other BDOS call +goto$next: + lhld NEXTa ; go to next and don't return + pchl + + ; Set directory label + ; de -> .fcb + ; drive location + ; name & type fields user's discretion + ; extent field definition + ; bit 1 (80h): enable passwords on drive + ; bit 2 (40h): enable file access + ; bit 3 (20h): enable file update stamping + ; bit 4 (10h): enable file create stamping + ; bit 8 (01h): assign new password to dir lbl + +func100: + pop a + lxi h,0 ! dad sp ! shld ret$stack ; save user stack + lxi sp,loc$stack + + xchg ! shld info ! xchg + mvi c,19h ! call goto$next ! sta curdsk ; get current disk + + mvi c,1dh ! call goto$next ; is drive R/O ? + lda curdsk ! mov c,a ! call hlrotr + mov a,l ! ani 01h ! jnz read$only + + lhld info ! call getexta ! push a ; if user tries to set time + ani 0111$0000b ! sta set$time ; stamps and no SFCB's...error + mov a,m ! ani 7fh ! mov m,a ; mask off password bit + ani 1 ! sta newpass ; but label can have password + + mvi c,69h ! push d ! lxi d,stamp ; get time for possible + call goto$next ! pop d ; update later + + mvi c,31h ! lxi d,SCBPB ! call goto$next; get BDOS current dma + shld curdma + + lda curdsk ! call dsksel ; BIOS select and sets + ; disk parameters + ; Does dir lbl exist on drive? + call search ; return if found or + push h ! mvi b,0 ; successfully made + lxi d,20h ! lda nfcbs ! mov c,a ; Are there SFCB's in directory + main0: dad d ! mov a,m ! cpi 21h ! jz main1 + inr b ! lda i ! inr a ! sta i ! cmp c + jnz main0 + + lda set$time ! ora a ! jnz no$SFCB ; no, but user wants to set + ; time stamp + sta SFCB ; SFCB = false + + main1: shld SFCB$addr ! mov a,b ! sta j ! lhld info + xchg ! pop h ! push h ! inx h ; HL => dir FCB, DE => user FCB + inx d ! mvi c,0ch ; prepare to move DE to HL + call move ! lda newpass ; find out if new password ? + ora a + cnz scramble ; scramble user pass & put in + ; dFCB + + lda SFCB ! inr a ! jnz mainx1 ; any SFCB's + + + main2: ; update time & date stamp + lda j ! mov b,a ! mvi a,2 ; j = FCB position from SFCB + sub b ; in 4 FCB sector (0,1,2), thus + ; FCBx - 2 + ; FCBy - 1 + ; FCBz - 0 + ; SFCB + ; So, 2-j gives FCB offset in + ; SFCB + + mvi b,0 ! mov c,a ! lhld SFCB$addr + inx h ! lxi d,0ah ! inr c +mainx0: dcr c ! jz mainx1 + dad d ! jmp mainx0 + +mainx1: pop d ! push d ! push h ; HL => dFCB + xchg ! lxi d,18h ! dad d ; HL => dfcb(24) (TS field) + xchg ! pop h ! push d ; of DIR LABEL + ; HL => Time/stamp pos in SFCB + lda NEW ! inr a ! jnz st0 ; did we create a new DL? + call stamper ! jmp st1 ; yes + + st0: lxi d,4 ! dad d ; update time stamp + pop d ! push h ! xchg ! lxi d,4 ; DFCB position + dad d ! xchg ! pop h ! push d + st1: call stamper + pop h + +mainr: pop h ! call getexta ! ori 1 ! mov m,a ; set lsb extent + call write$dir + xra a ! lxi h,0 !jmp goback ; no SFCB, so finished + + +no$SFCB: + mvi a,0ffh ! lxi h,0ffh ! jmp goback + +read$only: + mvi a,0ffh ! lxi h,02ffh + +goback: push h ! lhld aDIRBCB ! mvi m,0ffh ; tell BDOS not to use buffer + ; contents + push a + + mvi c,0dh ! call goto$next ; BDOS reset + lda curdsk ! mov e,a ! mvi c,0eh + call goto$next + lda curdsk ! call seldsk ; restore BDOS environment + pop a ! pop d + lhld ret$stack ! sphl ; restore user stack + xchg ; move error return to h + ret + + +dsksel: ; select disk and get parameters + + call seldsk ; Bios select disk + call gethl ; DE = XLT addr + shld XLT ! xchg + lxi b,0ah ! dad b ; HL = addr DPB + call gethl + shld aDPB ! xchg + lxi b,4 ! dad b ; HL = addr DIR BCB + call gethl ! shld aDIRBCB + lxi b,0ah ! dad b ; Hl => DIR buffer +; +;[JCE] CP/M 3 Patch 10 + mov e,m + inx h + mov d,m + xchg +;[JCE] end of patch + shld bufptr ; use BDOS buffer for + ; BIOS reads & writes + ; must jam FF into it to + ; signal don't use when done + lhld aDPB + call gethl ; get [HL] + shld spt ! xchg + inx h! inx h! inx h ! inx h! inx h! ; HL => dirmax + call gethl ! shld dirmax ! xchg + inx h ! inx h ! + call gethl ! shld checkv ! xchg + call gethl ! shld offset ! xchg + ; HL => phys shift + call gethl ! xchg ; E = physhf, D = phymsk + inr d ! mov a,d ; phys mask+1 = # 128 byte rcd + ; phymsk * 4 = nfcbs/rcd + ora a ! ral ! ora a ! ral ; clear carry & shift phymsk + sta nfcbs + + lhld spt ; spt = spt/phymsk + mov c,e ! call hlrotr ; => spt = shl(spt,physhf) + shld spt + ret + +search: ; search dir for pattern in + ; info of length in c + xra a ! sta sect ! sta empty + lxi h,0 ! shld dcnt + + lhld bufptr ! mov b,h ! mov c,l ; set BIOS dma + call setdma + + src0: call read$dir + cpi 0 ! jnz oops ; if A ~= 0 then BIOS error + + mvi b,0 ! lda nfcbs ! mov c,a ; BC always = nfcbs + + lhld bufptr ! lxi d,20h ; start of buffer and FCB + xra a ; do i = 0 to nfcbs - 1 + src1: sta i ! mov a,m ; user # + cpi 20h ! jnz src2 ; dir label mark + + push h ! lxi d,10h ! dad d ! mov a,m ; found label, move to DM to + ora a ! pop h ! rz ; check if label is pass prot + push h ! cpi 20h ! pop h ! jnz checkpass + ret + + src2: lda empty ! inr a ! jz src3 ; record first sect with empty + mov a,m + cpi 0e5h ! jnz src3 ! lda sect ; save sector # + sta savsect ! mvi a,0ffh ! sta empty ; set empty found = true + src3: dad d ; position to next FCB + lda i ! inr a ; while i < nfcbs + cmp c ! jnz src1 + + lhld dirmax ! xchg ! lhld dcnt ; while (dcnt < dirmax) & + ; dir label not found + dad b ! shld dcnt ! call subdh ; is dcnt <= dirmax ? + jc not$found ; no + lda sect ! inr a ! sta sect ! jmp src0 + +oops: mvi a,0ffh ! lxi h,1ffh + pop b ! jmp goback ; return perm. error + +not$found: ; must make a label + + lda empty ! inr a ! jnz no$space ; if empty = false... + lda savsect ! sta sect + call read$dir ; get sector + lhld bufptr ! lxi d,20h ! mvi c,0 ; C = FCB offset in buffer + nf0: mov a,m ! cpi 0e5h ! jz nf1 + dad d ! inr c !jmp nf0 ; know that empty occurs here + ; so don't need bounds test + nf1: mvi m,20h ! mov a,c ! sta i + mvi a,0 ! push h ! mvi c,32 ; clear fcb to spaces + nf2: inx h ! dcr c ! jz nf3 + mov m,a ! jmp nf2 + nf3: pop h + mvi a,0ffh ! sta NEW + ret ; HL => dir FCB + +no$space: mvi a,0ffh ! lxi h,0ffh ! pop b ! jmp goback + +check$pass: ; Dir is password protected, check dma for + ; proper password + + push h ; save addr dir FCB + lxi d,0dh ! dad d ! mov c,m ; get XOR sum in S1, C = S1 + lxi d,0ah ! dad d ; position to last char in label pass + mvi b,8 ; # chars in pass + xchg ! lhld curdma ! xchg ; DE => user pass, HL => label pass + + cp0: mov a,m ! xra c ! push b ; HL = XOR(HL,C) + mov c,a ! ldax d ! cmp c ; compare user and label passwords + jnz wrong$pass + pop b ! inx d ! dcx h ! dcr b + jnz cp0 + + xchg ! shld curdma ; curdma => 2nd pass in field if there + pop h ; restore dir FCB addr + mvi a,0ffh ! sta oldpass + ret + +wrong$pass: + mvi a,0ffh ! lxi h,07ffh ! pop b ! pop b + jmp goback + +scramble: ; encrypt password at curdma + ; 1. sum each char of pass. + ; 2. XOR each char with sum + ; 3. reverse order of encrypted pass + + lxi b,8 ! lhld curdma ;checkpass sets to 2nd pos if + lda oldpass ! inr a ! jz scr0 ;old pass else must move dma + dad b ! shld curdma + ; B = sum, C = max size of pass + scr0: mov a,m ! add b ! mov b,a ! dcr c + inx h ! jnz scr0 + + + pop d ! pop h ! push d ; H => dFCB, D was return + lxi d,0dh ! dad d ! mov m,b ; S1 = sum + lxi d,0ah ! dad d ; position to last char in pass + mvi c,8 ! xchg ! lhld curdma + scr1: mov a,m ! xra b ! xchg ! mov m,a ; XOR(char) => dFCB + xchg ! inx h ! dcx d ! dcr c ! jnz scr1 + + ret + + +read$dir: ; read directory into bufptr + + call track + call sector + call rdsec + ret + +writedir: ; write directory from bufptr + lda sect + call track + call sector + call wrsec + ret + +track: ; set the track for the BIOS call + + lhld spt ! call intdiv ; E = integer(sect/spt) + lhld offset ! dad d ! xchg ! call settrk + ret + +sector: ; set the sector for the BIOS + lda sect + lhld spt ! call intdiv ; get mod(sect,spt) + mov a,c ! sub l ; D = x * spt such that D > sect + ; D - spt = least x*spt s.t. D < sect + mov c,a ! lda sect ! sub c ; a => remainder of sect/spt + mvi b,0 ! mov c,a ! lhld XLT ; BC = logical sector #, DE = translate + xchg ! call sectrn ; table address + xchg ! call setsec ; BC = physical sector # + ret + + +intdiv: ; compute the integer division of A/L + + mvi c,0 ! lxi d,0 + int0: push a ; compute the additive sum of L such + mov a,l ! add c ! mov c,a ; that C = E*L where C = 1,2,3,... + pop a + + cmp C ! inr e ! jnc int0 ; if A < E*L then return E - 1 + dcr e + ret + +getexta: + ; Get current extent field address to hl + lxi d,0ch ! dad d ; hl=.fcb(extnum) + mov a,m + ret + +move: ; Move data length of length c from source de to + ; destination given by hl + + inr c ; in case it is zero + move0: + dcr c! rz ; more to move + ldax d! mov m,a ; one byte moved + inx d! inx h ; to next byte + jmp move0 + +gethl: ; get the word pointed at by HL + mov e,m ! inx h ! mov d,m ! inx h + xchg ! ret + +subdh: ; HL = DE - HL + + ora a ; clear carry + mov a,e ! sub l ! mov l,a + mov a,d ! sbb h ! mov h,a + ret + +hlrotr: + ; rotate HL right by amount c + inr c ; in case zero + hlr: dcr c! rz ; return when zero + mov a,h! ora a! rar! mov h,a ; high byte + mov a,l! rar! mov l,a ; low byte + jmp hlr + +stamper: ; move time stamp into SFCB & FCB + lda SFCB ! inr a ; no SFCB, update DL only + cz stmp ! pop b ! pop d ! push h ! xchg + push b ! call stmp ! pop b ! xchg ! pop h ! push d + push b + ret +stmp: lxi d,stamp ! mvi c,4 ! call move + ret + +;********************************************************************** + +curdsk: db 0 +set$time: db 0 +oldpass: db 0 +newpass: db 0 +pass$prot db 0 +sect: db 0 +empty: db 0 +stamp: ds 4 +NEW: db 0 +nfcbs: db 0 +i: db 0 +j: db 0 +SFCB: db 0ffh +savsect: db 0 + +SFCB$addr: dw 0 +info: dw 0 +checkv dw 0 +offset: dw 0 +XLT: dw 0 +bufptr: dw 0 +spt: dw 0 +dcnt: dw 0 +curdma: dw 0 +aDIRBCB dw 0 +aDPB: dw 0 +dFCB: dw 0 +dirmax: dw 0 + +SCBPB: +Soff: db 3ch +Sset: db 0 +Svalue: dw 0 + +; +;*********************************************************** +;* * +;* bios calls from for track, sector io * +;* * +;*********************************************************** +;*********************************************************** +;* * +;* equates for interface to cp/m bios * +;* * +;*********************************************************** +; +; +base equ 0 +wboot equ base+1h ;warm boot entry point stored here +sdsk equ 18h ;bios select disk entry point +strk equ 1bh ;bios set track entry point +ssec equ 1eh ;bios set sector entry point +stdma equ 21h +read equ 24h ;bios read sector entry point +write equ 27h ;bios write sector entry point +stran equ 2dh ;bios sector translation entry point +; +;*********************************************************** +;* * +;*********************************************************** +seldsk: ;select drive number 0-15, in C + ;1-> drive no. + ;returns-> pointer to translate table in HL + mov c,a ;c = drive no. + lxi d,sdsk + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +settrk: ;set track number 0-76, 0-65535 in BC + ;1-> track no. + mov b,d + mov c,e ;bc = track no. + lxi d,strk + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +setsec: ;set sector number 1 - sectors per track + ;1-> sector no. + mov b,d + mov c,e ;bc = sector no. + lxi d,ssec + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +rdsec: ;read current sector into sector at dma addr + ;returns in A register: 0 if no errors + ; 1 non-recoverable error + lxi d,read + jmp gobios +;*********************************************************** +;* * +;*********************************************************** +wrsec: ;writes contents of sector at dma addr to current sector + ;returns in A register: 0 errors occured + ; 1 non-recoverable error + lxi d,write + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +sectrn: ;translate sector number + ;1-> logical sector number (fixed(15)) + ;2-> pointer to translate table + ;returns-> physical sector number + push d + lxi d,stran + lhld wboot + dad d ;hl = sectran entry point + pop d + pchl +; +; +setdma: ; set dma + ; 1 -> BC = dma address + + lxi d,stdma + jmp gobios +; +; +;*********************************************************** +;*********************************************************** +;*********************************************************** +;* * +;* compute offset from warm boot and jump to bios * +;* * +;*********************************************************** +; +; +gobios: ;jump to bios entry point + ;de -> offset from warm boot entry point + lhld wboot + dad d + lxi d,0 + pchl +; + +ret$stack: dw 0 + ds 32 + ds 32 ;[JCE] Add extra stack as per CP/M Patch 10 + +loc$stack: +end + + \ No newline at end of file diff --git a/software/CPM/cpm3/disp.plm b/software/CPM/cpm3/disp.plm new file mode 100644 index 0000000..1844c78 --- /dev/null +++ b/software/CPM/cpm3/disp.plm @@ -0,0 +1,677 @@ +$title ('SDIR - Display Files') +display: +do; + /* Display Module for SDIR */ + +$include(comlit.lit) + +$include(mon.plm) + +dcl debug boolean external; +dcl (cur$drv, cur$usr) byte external; + +dcl (os,bdos) byte external; +$include(vers.lit) + +dcl used$de address external; /* number of used directory entries */ +dcl date$opt boolean external; /* date option flag */ +dcl display$attributes boolean external; /* attributes display flag */ +dcl sorted boolean external; +dcl filesfound address external; +dcl no$page$mode byte external; +dcl sfcbs$present byte external; /* sfcb's there/not there indicator */ + +$include (search.lit) +dcl find find$structure external; + +dcl format byte external, /* format is one of the following */ + page$len address external, /* page size before printing new headers */ + message boolean external, /* print titles and msg when no file found */ + formfeeds boolean external; /* use form feeds to separate headers */ + +$include(format.lit) + +dcl file$displayed boolean public initial (false); + /* true if we ever display a file, from any drive or user */ + /* used by main.plm for file not found message */ + +dcl dir$label byte external; + +$include(fcb.lit) +$include(xfcb.lit) + +dcl + buf$fcb$adr address external, /* index into directory buffer */ + buf$fcb based buf$fcb$adr (32) byte, + /* fcb template for dir */ + + (f$i$adr,last$f$i$adr,first$f$i$adr) address external, + cur$file address; /* number of file currently */ + /* being displayed */ + +$include(finfo.lit) + /* structure of file info */ +dcl file$info based f$i$adr f$info$structure; + +dcl x$i$adr address external, + xfcb$info based x$i$adr x$info$structure; + +dcl f$i$indices$base address external, /* if sorted then f$i$indices */ + f$i$indices based f$i$indices$base (1) address; /* are here */ + + +/* -------- Routines in util.plm -------- */ + +printchar: procedure (char) external; + dcl char byte; +end printchar; + +print: procedure (string$adr) external; /* BDOS call # 9 */ + dcl string$adr address; +end print; + +printb: procedure external; +end printb; + +crlf: procedure external; +end crlf; + +printfn: procedure(fname$adr) external; + dcl fname$adr address; +end printfn; + +pdecimal: procedure(v,prec,zerosup) external; + /* print value val, field size = (log10 prec) + 1 */ + /* with leading zero suppression if zerosup = true */ + declare v address, /* value to print */ + prec address, /* precision */ + zerosup boolean; /* zero suppression flag */ +end pdecimal; + +p3byte: procedure(byte3adr,prec)external; + /* print 3 byte value with 0 suppression */ + dcl (byte3adr,prec) address; /* assume high order bit is < 10 */ +end p3byte; + +add3byte: procedure (byte3$adr,word$amt) external; + dcl (byte3$adr, word$amt) address; +end add3byte; /* add word to 3 byte structure */ + +add3byte3: procedure (byte3$adr,byte3) external; + dcl (byte3$adr, byte3) address; +end add3byte3; /* add 3 byte quantity to 3 byte total */ + +shr3byte: procedure (byte3$adr) external; + dcl byte3$adr address; +end shr3byte; + + +/* -------- Routines in search.plm -------- */ + +search$first: procedure(fcb$adr) byte external; + dcl fcb$adr address; +end search$first; + +search$next: procedure byte external; +end search$next; + +break: procedure external; +end break; + +match: procedure boolean external; + dcl fcb$adr address; +end match; + + +/* -------- Other external routines -------- */ + +display$time$stamp: procedure (ts$adr) external; /* in dts.plm */ + dcl ts$adr address; +end display$time$stamp; + +terminate: procedure external; /* in main.plm */ +end terminate; + +mult23: procedure(index) address external; /* in sort.plm */ + dcl index address; +end mult23; + + +/* -------- From dpb86.plm or dpb80.plm -------- */ + +$include(dpb.lit) + +dpb$byte: procedure (dpb$index) byte external; + dcl dpb$index byte; +end dpb$byte; + +dpb$word: procedure (dpb$index) address external; + dcl dpb$index byte; +end dpb$word; + + +/* -------- routines and data structures local to this module -------- */ + +direct$console$io: procedure byte; + return mon2(6,0ffh); /* ff to stay downward compatable */ +end direct$console$io; + +dcl first$time address initial (0); + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +wait$keypress: procedure; + declare char byte; +/* if debug then +call print(.(cr,lf,'In wait*keypress...',cr,lf,'$')); +*/ + char = direct$console$io; + do while char = 0; + char = direct$console$io; + end; + if char = ctrlc then + call terminate; +end wait$keypress; + +declare global$line$count byte initial(1); + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +crlf$and$check: procedure; +/* + if debug then +call print(.(cr,lf,'In crlf*and*check...',cr,lf,'$')); +*/ + if no$page$mode = 0 then do; + if global$line$count > page$len-1 then do; + call print(.(cr,lf,'Press RETURN to Continue $')); + cur$line = cur$line + 1; + call wait$keypress; + global$line$count = 0; + end; /* global$line$count > page$len */ + end; /* no$page$mode = 0 */ + call crlf; + global$line$count = global$line$count + 1; +end crlf$and$check; + +dcl total$kbytes structure ( /* grand total k bytes of files matched */ + lword address, + hbyte byte), + total$recs structure ( /* grand total records of files matched */ + lword address, + hbyte byte), + total$1k$blocks structure( /* how many 1k blocks are allocated */ + lword address, + hbyte byte); + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +add$totals: procedure; + +/* + if debug then +call print(.(cr,lf,'In add*totals...',cr,lf,'$')); +*/ + call add3byte(.total$kbytes,file$info.kbytes); + call add3byte3(.total$recs,.file$info.recs$lword); /* records in file */ + call add3byte(.total$1k$blocks,file$info.onekblocks); + +end add$totals; + +dcl files$per$line byte; +dcl cur$line address; + +dcl hdr (*) byte data (' Name Bytes Recs Attributes $'); +dcl hdr$bars (*) byte data ('------------ ------ ------ ------------$'); +dcl hdr$pu (*) byte data (' Prot Update $'); +dcl hdr$xfcb$bars (*) byte data (' ------ -------------- --------------$'); +dcl hdr$access (*) byte data (' Access $'); +dcl hdr$create (*) byte data (' Create $'); + /* example date 04/02/55 00:34 */ + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +display$file$info: procedure; + /* print filename.typ */ +/* +if debug then +call print(.(cr,lf,'In display*file*info...',cr,lf,'$')); +*/ + call printfn(.file$info.name(0)); + call printb; + call pdecimal(file$info.kbytes,10000,true); + call printchar('k'); /* up to 32 Meg - Bytes */ + /* or 32,000k */ + call printb; + call p3byte(.file$info.recs$lword,1); /* records */ + call printb; + if rol(file$info.name(f$dirsys-1),1) then /* Type */ + call print(.('Sys$')); + else call print(.('Dir$')); + call printb; + if rol(file$info.name(f$rw-1),1) then + call print(.('RO$')); + else call print(.('RW$')); + call printb; + if not display$attributes then do; + if rol(file$info.name(f$arc-1),1) then + call print(.('Arcv $')); + else + call print(.(' $')); + end; + else do; + if rol(file$info.name(f$arc-1),1) then /* arc bit was on in all */ + call print$char('A'); /* dir entries */ + else call printb; + if rol(file$info.name(0),1) then + call print$char('1'); + else call printb; + if rol(file$info.name(1),1) then + call print$char('2'); + else call printb; + if rol(file$info.name(2),1) then + call print$char('3'); + else call printb; + if rol(file$info.name(3),1) then + call print$char('4'); + else call printb; + end; +end display$file$info; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +display$xfcb$info: procedure; +/* +if debug then +call print(.(cr,lf,'In display*xfcb*info...',cr,lf,'$')); +*/ + if file$info.x$i$adr <> 0 then + do; + call printb; + x$i$adr = file$info.x$i$adr; + if (xfcb$info.passmode and pm$read) <> 0 then + call print(.('Read $')); + else if (xfcb$info.passmode and pm$write) <> 0 then + call print(.('Write $')); + else if (xfcb$info.passmode and pm$delete) <> 0 then + call print(.('Delete$')); + else + call print(.('None $')); + call printb; + if (xfcb$info.update(0) <> 0 or xfcb$info.update(1) <> 0) then + call display$timestamp(.xfcb$info.update); + else call print(.(' $')); + call printb; call printb; + if (xfcb$info.create(0) <> 0 or xfcb$info.create(1) <> 0) then + call display$timestamp(.xfcb$info.create(0)); + /* Create/Access */ + end; +end display$xfcb$info; + +dcl first$title boolean initial (true); + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +display$title: procedure; +/* +if debug then +call print(.(cr,lf,'In display*title...',cr,lf,'$')); +*/ + if formfeeds then + call print$char(ff); + else if not first$title then + call crlf$and$check; + call print(.('Directory For Drive $')); + call printchar('A'+ cur$drv); call printchar(':'); + if bdos >= bdos20 then + do; + call print(.(' User $')); + call pdecimal(cur$usr,10,true); + end; + call crlf$and$check; + cur$line = 2; + first$title = false; +end display$title; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +short$display: procedure (fname$adr); + dcl fname$adr address; +/* +if debug then +call print(.(cr,lf,'In short*display...',cr,lf,'$')); +*/ + if cur$file mod files$per$line = 0 then + do; + if cur$line mod page$len = 0 and first$time = 0 then + do; + call crlf$and$check; + call display$title; + call crlf$and$check; + end; + else + call crlf$and$check; + cur$line = cur$line + 1; + call printchar(cur$drv + 'A'); + end; + else call printb; + call print(.(': $')); + call printfn(fname$adr); + call break; + cur$file = cur$file + 1; + first$time = first$time + 1; +end short$display; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +test$att: procedure(char,off,on) boolean; + dcl (char,off,on) byte; +/* +if debug then +call print(.(cr,lf,'In test*att...',cr,lf,'$')); +*/ + if (80h and char) <> 80h and off then + return(true); + if (80h and char) = 80h and on then + return(true); + return(false); +end test$att; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +right$attributes: procedure(name$adr) boolean; + dcl name$adr address, + name based name$adr (1) byte; + return + test$att(name(f$rw-1),find.rw,find.ro) and + test$att(name(f$dirsys-1),find.dir,find.sys); +end right$attributes; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +short$dir: procedure; /* looks like "DIR" command */ + dcl dcnt byte; +/* +if debug then +call print(.(cr,lf,'In short*dir...',cr,lf,'$')); +*/ + fcb(f$drvusr) = '?'; + files$per$line = 4; + dcnt = search$first(.fcb); + do while dcnt <> 0ffh; + buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */ + if (buf$fcb(f$drvusr) and 0f0h) = 0 and + buf$fcb(f$ex) = 0 and + buf$fcb(f$ex)<= dpb$byte(extmsk$b) then /* no dir labels, xfcbs */ + if match then + if right$attributes(.buf$fcb(f$name)) then + call short$display(.buf$fcb(f$name)); + dcnt = search$next; + end; +end short$dir; + +dcl (last$plus$one,index) address; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +getnxt$file$info: procedure; /* set f$i$adr to base file$info on file */ +dcl right$usr boolean; /* to be displayed, f$i$adr = 0ffffh if end */ +/* +if debug then +call print(.(cr,lf,'In getnxt*file*info...',cr,lf,'$')); +*/ + right$usr = false; + if sorted then + do; index = index + 1; + f$i$adr = mult23(f$i$indices(index)); + do while file$info.usr <> cur$usr and index <> filesfound; + index = index + 1; + f$i$adr = mult23(f$i$indices(index)); + end; + if index = files$found then + f$i$adr = last$plus$one; /* no more files */ + end; + else /* not sorted display in order found in directory */ + do; /* use last$plus$one to avoid wrap around problems */ + f$i$adr = f$i$adr + size(file$info); + do while file$info.usr <> cur$usr and f$i$adr <> last$plus$one; + f$i$adr = f$i$adr + size(file$info); + end; + end; +end getnxt$file$info; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +size$display: procedure; +/* +if debug then +call print(.(cr,lf,'In size*display...',cr,lf,'$')); +*/ + if (format and form$size) <> 0 then + files$per$line = 3; + else files$per$line = 4; + do while f$i$adr <> last$plus$one; + if ((file$info.x$i$adr <> 0 and find.xfcb) or + file$info.x$i$adr = 0 and find.nonxfcb) and + right$attributes(.file$info.name(0)) then + do; + call add$totals; + call short$display(.file$info.name(0)); + call pdecimal(file$info.kbytes,10000,true); + call print(.('k$')); + end; + call getnxt$file$info; + end; +end size$display; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +display$no$dirlabel: procedure; +/* +if debug then +call print(.(cr,lf,'In display*no*dirlabel...',cr,lf,'$')); +*/ + files$per$line = 2; + first$time = 0; + do while (f$i$adr <> last$plus$one); + + if ((file$info.x$i$adr <> 0 and find.xfcb) or + (file$info.x$i$adr = 0 and find.nonxfcb)) and + right$attributes(.file$info.name(0)) then + do; + + if ((cur$file mod files$per$line) = 0) then /* need new line */ + do; + + if ((cur$line mod page$len) = 0) then + do; + + if ((no$page$mode = 0) or (first$time = 0)) then do; + call crlf$and$check; + call display$title; + call crlf$and$check; + call print(.hdr); + call printb; /* two sets of hdrs */ + call print(.hdr); + call crlf$and$check; + call print(.hdr$bars); + call printb; + call print(.hdr$bars); + call crlf$and$check; + cur$line = cur$line + 4; + first$time = first$time+1; + end; + else do; + call crlf$and$check; + cur$line = cur$line + 1; + end; /* no$page$mode check */ + + end; + else + do; call crlf$and$check; + cur$line = cur$line + 1; + end; + + end; + else + call printb; /* separate the files */ + + call display$file$info; + cur$file = cur$file + 1; + call add$totals; + call break; + end; + call getnxt$file$info; + end; + +end display$no$dirlabel; + +/*- - - - - - - - - - - - - - - - - - - - - - -*/ + +display$with$dirlabel: procedure; +/* +if debug then +call print(.(cr,lf,'In display*with*dirlabel...',cr,lf,'$')); +*/ + files$per$line = 1; + first$time = 0; + do while (f$i$adr <> last$plus$one); + + if ((file$info.x$i$adr <> 0 and find.xfcb) or + (file$info.x$i$adr = 0 and find.nonxfcb)) and + right$attributes(.file$info.name(0)) then + do; + + if cur$line mod page$len = 0 then + do; + + if ((no$page$mode = 0) or (first$time = 0)) then do; + + call crlf$and$check; + call display$title; + call crlf$and$check; + call print(.hdr); + call print(.hdr$pu); + if (dirlabel and dl$access) <> 0 then + call print(.hdr$access); + else + call print(.hdr$create); + call crlf$and$check; + call print(.hdr$bars); + call print(.hdr$xfcb$bars); + call crlf$and$check; + cur$line = cur$line + 4; + first$time = first$time + 1; + end; /* no$page$mode check */ + + end; + + call crlf$and$check; + cur$line = cur$line + 1; + call display$file$info; /* display non bdos 3.0 file info */ + call display$xfcb$info; + cur$file = cur$file + 1; + call break; + call add$totals; + end; + call getnxt$file$info; + end; +end display$with$dirlabel; + + +/*- - - - -MAIN ENTRY POINT - - - - - - - - - -*/ + + +display$files: procedure public; /* MODULE ENTRY POINT */ + /* display the collected data */ +/* +if debug then +call print(.(cr,lf,'In main display routine...',cr,lf,'$')); +*/ + cur$line, cur$file = 0; /* force titles and new line */ + totalkbytes.lword, totalkbytes.hbyte, totalrecs.lword, totalrecs.hbyte =0; + total$1k$blocks.lword, total$1k$blocks.hbyte = 0; + f$i$adr = first$f$i$adr - size(file$info); /* initial if no sort */ + last$plus$one = last$f$i$adr + size(file$info); + index = 0ffffh; /* initial if sorted */ + call getnxt$file$info; /* base file info record */ + + if format > 2 then + do; + call print(.('ERROR: Illegal Format Value.',cr,lf,'$')); + call terminate; /* default could be patched - watch it */ + end; + + do case format; /* format = */ + call short$dir; /* form$short */ + call size$display; /* form$size */ + /* form = full */ + if date$opt then do; + if ((( dir$label and dl$exists) <> 0 ) and + ((( dir$label and dl$access) <> 0 ) or + (( dir$label and dl$update) <> 0 ) or + (( dir$label and dl$makexfcb) <> 0 )) and (sfcbs$present)) then + call display$with$dirlabel; /* Timestamping is active! */ + else do; + call print(.('ERROR: Date and Time Stamping Inactive.',cr,lf,'$')); + call terminate; + end; + end; + else do; /* No date option; Regular Full display */ + if (((dir$label and dl$exists) <> 0) and (sfcbs$present)) then + do; + call display$with$dirlabel; + end; + else + do; + call display$no$dirlabel; + end; + end; + end; /* end of case */ + if format <> form$short and cur$file > 0 then /* print totals */ + do; + if cur$line + 4 > page$len and formfeeds then + do; + call printchar(cr); + call printchar(ff); /* need a new page ? */ + end; + else + do; + call crlf$and$check; + call crlf$and$check; + end; + call print(.( 'Total Bytes = $')); + call p3byte(.total$kbytes,1); /* 6 digit max */ + call printchar('k'); + call print(.(' Total Records = $')); + call p3byte(.total$recs,10); /* 7 digit max */ + call print(.(' Files Found = $')); + call pdecimal(cur$file,1000,true); /* 4 digit max */ + call print(.(cr,lf,'Total 1k Blocks = $')); + call p3byte(.total$1k$blocks,1); /* 6 digit max */ + call print(.(' Used/Max Dir Entries For Drive $')); + call print$char('A' + cur$drv); + call print$char(':'); call printb; + call pdecimal(used$de,1000,true); + call print$char('/'); + call pdecimal(dpb$word(dirmax$w) + 1,1000,true); + end; + + if cur$file = 0 then + do; + if message then + do; call crlf$and$check; + call display$title; + call print(.('No File',cr,lf,'$')); + end; + call break; + end; + else do; + file$displayed = true; + if not formfeeds then + call crlf$and$check; + end; + +end display$files; + +end display; diff --git a/software/CPM/cpm3/dpb.lit b/software/CPM/cpm3/dpb.lit new file mode 100644 index 0000000..7a36d79 --- /dev/null +++ b/software/CPM/cpm3/dpb.lit @@ -0,0 +1,13 @@ + +/* indices into disk parameter block, used as parameters to dpb procedure */ + +dcl spt$w lit '0', + blkshf$b lit '2', + blkmsk$b lit '3', + extmsk$b lit '4', + blkmax$w lit '5', + dirmax$w lit '7', + dirblk$w lit '9', + chksiz lit '11', + offset$w lit '13'; + diff --git a/software/CPM/cpm3/dpb80.plm b/software/CPM/cpm3/dpb80.plm new file mode 100644 index 0000000..2f909d3 --- /dev/null +++ b/software/CPM/cpm3/dpb80.plm @@ -0,0 +1,45 @@ +$title ('SDIR 8080 - Get Disk Parameters') +dpb80: +do; + /* the purpose of this module is to allow independence */ + /* of processor, i.e., 8080 or 8086 */ + +$include (comlit.lit) + +/* function call 32 in 2.0 or later BDOS, returns the address of the disk +parameter block for the currently selected disk, which consists of: + spt (2 bytes) number of sectors per track + blkshf (1 byte) block size = shl(double(128),blkshf) + blkmsk (1 byte) sector# and blkmsk = block number + extmsk (1 byte) logical/physical extents + blkmax (2 bytes) max alloc number + dirmax (2 bytes) size of directory-1 + dirblk (2 bytes) reservation bits for directory + chksiz (2 bytes) size of checksum vector + offset (2 bytes) offset for operating system +*/ + +$include(dpb.lit) +$include(mon.plm) +declare k$per$block address public; +declare dpb$base address; +declare dpb$array based dpb$base (15) byte; + +dcl get$dpb lit '31'; + +dpb$byte: procedure(param) byte public; + dcl param byte; + return(dpb$array(param)); +end dpb$byte; + +dpb$word: procedure(param) address public; + dcl param byte; + return(dpb$array(param) + shl(double(dpb$array(param+1)),8)); +end dpb$word; + +base$dpb: procedure public; + dpb$base = mon3(get$dpb,0); + k$per$block = shr(dpb$byte(blkmsk$b)+1,3); +end base$dpb; + +end dpb80; diff --git a/software/CPM/cpm3/drlink.com b/software/CPM/cpm3/drlink.com new file mode 100644 index 0000000..e188fb9 Binary files /dev/null and b/software/CPM/cpm3/drlink.com differ diff --git a/software/CPM/cpm3/drvtbl.asm b/software/CPM/cpm3/drvtbl.asm new file mode 100644 index 0000000..c0894d0 --- /dev/null +++ b/software/CPM/cpm3/drvtbl.asm @@ -0,0 +1,9 @@ + public @dtbl + extrn fdsd0,fdsd1 + + cseg + +@dtbl dw fdsd0,fdsd1 + dw 0,0,0,0,0,0,0,0,0,0,0,0,0,0 ; drives C-P non-existant + + end diff --git a/software/CPM/cpm3/dump.asm b/software/CPM/cpm3/dump.asm new file mode 100644 index 0000000..a0d0fd7 --- /dev/null +++ b/software/CPM/cpm3/dump.asm @@ -0,0 +1,488 @@ + title 'CP/M 3 DUMP Utility' + ;*************************** + ;*************************** + ;** ** + ;** D U M P ** + ;** ** + ;** FILE DUMP ROUTINE ** + ;** ** + ;** JULY 16 1982 ** + ;** ** + ;*************************** + ;*************************** + ; + ; + ; + org 100h ;base of TPA + ; + ;****************** + ;* BDOS Functions * + ;****************** +return equ 0 ;System reset +conin equ 01 ;Read console +conout equ 02 ;Type character +bdos equ 05 ;DOS entry point +input equ 06 ;Raw console I/O +pstring equ 09 ;Type string +rstring equ 10 ;Read connsole buffer +chkio equ 11 ;Console status +reset equ 13 ;Reset Disk System +openf equ 15 ;Open file +readf equ 20 ;Read buffer +dmaf equ 26 ;Set DMA address +fsize equ 35 ;Compute file size +errmode equ 45 ;Set ERROR mode +getscb equ 49 ;Get/Set SCB +conmode equ 109 ;Set console mode + ;************************** + ;* Non Graphic Characters * + ;************************** +ctrlc equ 03h ;control - C (^C) +ctrlx equ 018h ;control - X (^X) +cr equ 0dh ;carriage return +lf equ 0ah ;line feed + ; + ;******************* + ;* FCB definitions * + ;******************* +fcb equ 5ch ;File Control Block +buf equ 80h ;Password Buffer Location + ; + ;***************** + ;* Begin Program * + ;***************** + jmp begin + ; + ;********************************************* + ;* Patch Area, Date, Version & Serial Number * + ;********************************************* +dw 0,0,0,0,0,0 +db 0 +db 'DUMP VERSION 3.0' +db ' DUMP.COM ' +dw 0,0,0,0,0,0,0,0 +dw 0,0,0,0,0,0,0,0 + +maclib makedate ;[JCE] one file for all dates/copyrights +@LCOPY +@BDATE ;version date [day-month-year] +db 0,0,0,0 ;patch bit map +db '654321' ;Serial Number + ; +pgraph: ;print graphic char. in ACC. or period + cpi 7fh + jnc pperiod + cpi ' ' + jnc pchar + ; +pperiod: ;print period + mvi a,'.' + jmp pchar + ; +pchar: ;print char. in ACC. to console + push h + push d + push b + mov e,a ;value in ACC. is put in register E + mvi c,conout ;value in register E is sent to console + call bdos ;print character + pop b + pop d + pop h + ret + ; +pnib: ;print nibble in low Acc. + cpi 10 + jnc pnibh ;jump if 'A-F' + adi '0' + jmp pchar + ; +pnibh: + adi 'A'-10 + jmp pchar + ; +pbyte: ;print byte in hex + push psw ;save copy for low nibble + rar ;rotate high nibble to low + rar + rar + rar + ani 0fh ;mask high nibble + call pnib + pop psw + ani 0fh + jmp pnib + ; +openfile: + mvi c,openf + lxi d,fcb + call bdos ;open file + sta keepa + mov a,h + cpi 07 ;check password status + jz getpasswd ;Reg. H contains '7' if password exists + lda keepa + cpi 0ffh ;ACC.=FF if there is no file found + jz nofile + ret + ; +getpasswd: + lda tpasswd + cpi 255 ;check if already tried password + jz wrngpass + call space ;set password memory area too blanks + lxi d,quest + call print ;print question + mvi a,8 ;max # of characters able to input + sta buf ;for password is eight (8) + mvi c,rstring + lxi d,buf + call bdos ;get password + lda buf+1 + sta len ;store length of password + cpi 0 + jz stop ;if entered then stop program + call cap ;cap the password + lxi d,buf+2 + call setdma + mvi a,255 + sta tpasswd ;set Tried Password Flag + mvi a,0 + jmp openfile + ; +space: ;this routine fills the memory + mvi a,8 ;locations from 82-89H with + lxi h,buf+2 ;a space +space2: + mvi m,' ' ;put a (blank) into the memory + inx h ;location where HL are pointing + dcr a + jnz space2 + ret + ; +cap: ;this routine takes the inputed + mvi b,8 ;Password and converts it to + lxi h,buf+2 ;upper-case letters +cap2: + mov a,m ;move into the ACC. where the + cpi 'a' ;current HL position points to + jc skip ;and if it is a lower-case letter + cpi '{' ;make it upper case + jnc skip + sui 20h + mov m,a +skip: + inx h ;inc the pointer to the next letter + dcr b + jnz cap2 +delchar: ;this routine deletes the last + lda len ;character in the input because + adi 82h ;an extra character is added to + sta len2 ;the input when using BDOS function 10 + lhld len2 + mvi m,' ' + ret + ; +fillbuff: + lxi d,buff ;current position +fillbuff2: + sta keepa + push d + call setdma ;set DMA for file reading + call readbuff ;read file and fill BUFF + lda norec ;# records read in current loop + inr a + sta norec + cpi 8 ;check if '8' records read in loop + jz loop2 + pop d + lxi h,80h ;80h=128(decimal)= # bytes in 1 record read + dad d + xchg ;changes DMA = DMA+80h + jmp fillbuff2 + ; +setdma: + mvi c,dmaf + call bdos ;set DMA + ret + ; +readbuff: + mvi c,readf + lxi d,fcb + call bdos ;fill buffer + cpi 0 ;ACC. <> 0 if unsuccessful + rz ;return if not End Of File + lda norec + cpi 0 ;this check is needed to see if + jz stop ;the record is the first in the + mvi a,255 ;loop + sta eof ;set End Of File flag + jmp loop2 ;no more buff reading + ; +break: + push b + push d ;see if character ready + push h ;if so then quit program + mvi c,chkio ;if character is a ^C + call bdos ;check console status + ora a ;zero flag is set if no character + push psw ;save all registers + mvi c,conin ;console in function + cnz bdos ;eat character if not zero + pop psw ;restore all registers + pop h + pop d + pop b + ret + ; +paddr: + lhld aloc ;current display address + mov a,h + call pbyte ;high byte + mov a,l + lhld disloc + call pbyte ;low byte + mvi a,':' + jmp pchar + ; +page$check: + lda page$on + cpi 0 + cz page$count ;if page mode on call routine + ret + ; +crlf: + mvi a,cr + call pchar + mvi a,lf + jmp pchar + ; +blank: + mvi a,' ' + jmp pchar + ; +page$count: + lda page$size ;relative to zero + mov e,a + lda count ;current number of lines + cmp e + jz stop$display ;if xx lines then stop display + inr a + sta count ;count=count+1 + ret + ; +stop$display: + mvi a,0 + sta count ;count=0 + lxi d,con$mess + call print +stop$display2: + mvi c,input + mvi e,0fdh + call bdos + cpi ctrlc + jz stop + cpi cr ;compare character with + jnz stop$display2 ;wait until is encountered + mvi a,ctrlx + jmp pchar + ; +discom: ;check line format + xchg + lhld dismax + mov a,l + sub e + mov l,a + mov a,h + sbb d + xchg + ret + ; +display: + lhld size ;[(norec)x(128)]-1 + xchg + lxi h,buff ;buffer location + shld disloc + dad d + ; +display2: + shld dismax + ; +display3: + call page$check + call crlf + call break + jnz stop ;if key pressed then quit + lhld disloc + shld tdisp + call paddr ;print the line address + ; +display4: + call blank + mov a,m + call pbyte ;print byte + inx h ;increment the current buffer location + push h + lhld aloc ;aloc is current address for the display + mov a,l + ani 0fh + cpi 0fh ;check if 16 bytes printed + inx h ;increment current display address + shld aloc ;save it + pop h + jnz display4 ;if not then continue + ; +display5: + shld disloc ;save the current place + lhld tdisp ;load current place - 16 + xchg + call blank + call blank + ; +display6: + ldax d ;get byte + call pgraph ;print if graphic character + inx d + lhld disloc + mov a,l + sub e + jnz display6 + mov a,h + sub d + jnz display6 + lhld disloc + call discom ;end of display ? + rc + jmp display3 + ; +pintro: + lxi d,intromess + call print + ret + ; +setmode: ;this routine allows error codes + mvi c,errmode ;to be detected in the ACC. and + mvi e,255 ;Reg. H instead of BDOS ERROR + call bdos ;Messages + mvi c,conmode ;and also sets the console status + lxi d,1 ;so that only a ^C can affect + call bdos ;function 11 + ret + ; +check$page: + mvi c,getscb ;Get/Set SCB function + lxi d,page$mode + call bdos + cpi 0 + rnz ;return if mode is off (false) + sta page$on ;set 'on' byte + mvi c,getscb + lxi d,page$len + call bdos + dcr a + sta page$size ;store page length (relative to zero) + ret + ; +checkfile: + mvi c,fsize + lxi d,fcb + call bdos + lda fcb+33 + cpi 0 + rnz + lxi d,norecmess + call print + jmp stop + ; +chngsize: ;if odd number of records read + sta keepa ;this routine adds 128 or + mvi a,80h ;80h to the display size + mov l,a ;because the ACC. cannot deal + lda keepa ;with decimals + ret + ; +print: ;prints the string where + mvi c,pstring ;DE are pointing to + call bdos + ret + ; +nofile: + mvi c,pstring + lxi d,nofmess + call bdos ;print 'FILE NOT FOUND' + jmp stop + ; +wrngpass: + lxi d,badpass + call print ;print 'False Password' + ; +stop: ;stop program execution + mvi c,reset + call bdos + mvi c,return + call bdos + ; +begin: + lxi sp,stack + call pintro ;print the intro + call setmode ;set ERROR mode + call check$page ;check console page mode + call openfile ;open the file + call checkfile ;check if reany records exist + ; +loop: + jmp fillbuff ;fill the buffer(s) +loop2: + mvi l,0 ;set L = 0 + lda norec ;norec is set by fillbuff routine + rar ;(x128) or (/2) + cc chngsize ;if odd # records read then call this routine + mov h,a + dcx h + shld size ;number of bytes to display + pop d + call display ;call display routine + lda eof + cpi 255 + jz stop ;jump if End Of File + mvi a,0 + sta norec ;reset # records read to 0 + jmp loop + ; + ;**************************** + ;* Console Messages To User * + ;**************************** +intromess: db cr,lf,lf,'CP/M 3 DUMP - Version 3.0$' +nofmess: db cr,lf,'ERROR: File Not Found',cr,lf,'$' +quest: db cr,lf,'Enter Password: $' +badpass: db cr,lf,'Password Error$' +norecmess: db cr,lf,'ERROR: No Records Exist$' +con$mess: db cr,lf,'Press RETURN to continue $' + ; + ;***************************** + ;* Variable and Storage Area * + ;***************************** +dismax: ds 2 ;Max.# reference +tdisp: ds 2 ;Current buffer location (for ASCII) +disloc: ds 2 ;Current buffer loocation +aloc: dw 0 ;Line address +ploc: ds 2 ;Current buffer location storage +keepa: ds 2 ;Storage for ACC. +norec: db 0 ;# of records read in certain loop (1-8) +eof: db 0 ;End Of File flag +tpasswd: dw 0 ;Tried Password flag +size: dw 0 ;Display size +page$mode: db 02ch ;page mode offset relative to SCB + db 00h +page$len: db 01ch ;page length offset relative to SCB + db 00h +page$on: db 0ffh ;page ON/OFF flag (0=ON) +page$size: db 00h ;page length relative to zero +count: db 0 ;line counter +len: dw 0 ;Password Input length +len2: dw 0 ;Extra character pointer + ds 12h +stack: ds 2 +buff: ds 1024 ;The buffer (holds up to 400h = 1k) +end: + \ No newline at end of file diff --git a/software/CPM/cpm3/echovers.asm b/software/CPM/cpm3/echovers.asm new file mode 100644 index 0000000..d0f97c5 --- /dev/null +++ b/software/CPM/cpm3/echovers.asm @@ -0,0 +1,46 @@ + ; ECHOVERS RSX + +pstring equ 9 ; string print function +cr equ 0dh +lf equ 0ah +; +; RSX PREFIX STRUCTURE +; + db 0,0,0,0,0,0 ; room for serial number + jmp ftest ; begin of program +next db 0c3H ; jump + dw 0 ; next module in line +prev: dw 0 ; previous module +remov: db 0ffh ; remove flag set +nonbnk: db 0 + db 'ECHOVERS' +space: ds 3 + +ftest: ; is this function 12? + mov a,c + cpi 12 + jz begin ; yes - intercept + jmp next ; some other function + +begin: + lxi h,0 + dad sp ;save stack + shld ret$stack + lxi sp,loc$stack + + mvi c,pstring + lxi d,test$msg ; print message + call next ; call BDOS + + lhld ret$stack ; restore user stack + sphl + lxi h,0031h ; return version number = 0031h + ret + +test$msg: + db cr,lf,'**** ECHOVERS **** $' +ret$stack: + dw 0 + ds 32 ; 16 level stack +loc$stack: + end diff --git a/software/CPM/cpm3/ed.plm b/software/CPM/cpm3/ed.plm new file mode 100644 index 0000000..30bfd7c --- /dev/null +++ b/software/CPM/cpm3/ed.plm @@ -0,0 +1,2647 @@ +$ TITLE(' CP/M-80 3.0 --- ED') +ED: +DO; + /* MODIFIED FOR .PRL OPERATION MAY, 1979 */ + /* MODIFIED FOR OPERATION WITH CP/M 2.0 AUGUST 1979 */ + /* modified for MP/M 2.0 June 1981 */ + /* modified for CP/M 1.1 Oct 1981 */ + /* modified for CONCURRENT CP/M 1.0 Jul 1982 */ + /* modified for CP/M 3.0 July 1982 */ + /* modified for CP/M 3.0 SEPT 1982 */ + +/* MODIFICATION LOG: + * July 1982 whf: some code cleanup (grouped logicals, declared BOOL); + * fixed disk full error handling; fixed read from null files; + * fixed (some) of the dirty fcb handling (shouldn't use settype + * function on open fcbs!). + * July 1982 dh: installed patches to change macro abort command from + * ^C to ^Y and to not print error message when trying to delete + * a file that doesn't exist. Added PERROR: PROCEDURE to print + * error messages in a consistant format and modified error + * message handler at RESET: entry point. Also corrected Invalid + * filename error to not abort ED if parsing a R or X command. + * Modified start (at PLM:) and SETDEST: to prompt for missing + * filenames. Modified parse$fcb & parse$lib to set a global + * flag and break if it got an invalid filename for X or R commands. + * Start sets page size from the system control block (SCB) if + * ED is running under CP/M-80 (high(ver)=0). + * The H command now works with new files. (sets newfile=false) + * Sept 82 + * Corrected bug in which ED file b: didn't work. Changed PLM: + * and SETDEST: routines. + * Nov 82 + * Corrected bug in parse$fcb where filenames of 9 characters and + * types of 4 characters where accepted as valid and truncated. + */ + +$include (copyrt.lit) + +declare + mpmproduct literally '01h', /* requires mp/m */ + cpm3 literally '30h'; /* requires 3.0 cp/m */ + +declare plm label public; /* entry point for plm86 interface */ + +/* THE FOLLOWING COMMANDS CREATE ED.COM AND ED.CMD: + + wm $1.plm + attach b 5 + b:seteof $1.plm + vax $1.plm $$san\batch smpmcmd $1 date($2 Oct 81)\ + b:is14 + ERA $1.MOD + era $1 + era $1.obj + :f1:PLM80 $1.PLM debug PAGEWIDTH(132) $3 + :f1:link $101.obj,$1.obj,:f1:plm80.lib to $1.mod + :f1:locate $1.mod code(0100H) stacksize(100) map print($1.tra) + :f1:cpm + b:objcpm $1 + attach b 1 + + +the following VAX commands were used to create ED.CMD + + $ asm86 scd1.a86 debug xref + ! scd1 does a jump to the plm code + $ plm86 'p1'.plm 'p2' 'p3' 'p4' optimize(3) debug + $ link86 scd1.obj,'p1'.obj to 'p1'.lnk + $ loc86 'p1'.lnk od(sm(dats,code,data,stack,const)) ad(sm(code(0))) ss(stack(+16)) + $ h86 'p1' + + followed by the gencmd command + gencmd ed data[b1E3,m80,xFFF] + where 1E2 is the start of the constant area / 16 from ED.MP2 + +*/ + +/* DECLARE 8080 Interface + JMP EDCOMMAND - 3 (TO ADDRESS LXI SP) + EDJMP BYTE DATA(0C3H), + EDADR ADDRESS DATA(.EDCOMMAND-3); */ + + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare tbuff (1) byte external; /* default dma buffer */ + + +DECLARE + MAXB ADDRESS EXTERNAL, /* MAX BASE 0006H */ + BUFF (128)BYTE EXTERNAL, /* BUFFER 0080H */ + SECTSHF LITERALLY '7', /* SHL(1,SECTSHF) = SECTSIZE */ + SECTSIZE LITERALLY '80H'; /* SECTOR SIZE */ + +BOOT: PROCEDURE ; + call mon1(0,0); /* changed for MP/M-86 version */ + /* SYSTEM REBOOT */ + END BOOT; +$ eject + + /* E D : T H E C P / M C O N T E X T E D I T O R */ + + /* COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982 + DIGITAL RESEARCH + BOX 579 PACIFIC GROVE + CALIFORNIA 93950 + + Revised: + 07 April 81 by Thomas Rolander + 21 July 81 by Doug Huskey + 29 Oct 81 by Doug Huskey + 10 Nov 81 by Doug Huskey + 08 July 82 by Bill Fitler + 26 July 82 by Doug Huskey + */ +/* DECLARE COPYRIGHT(*) BYTE DATA + (' COPYRIGHT (C) 1982, DIGITAL RESEARCH '); + **** this message should be in the header *** +*/ +declare date(*) byte data ('8/82'); + + /* COMMAND FUNCTION + ------- -------- + A APPEND LINES OF TEXT TO BUFFER + B MOVE TO BEGINNING OR END OF TEXT + C SKIP CHARACTERS + D DELETE CHARACTERS + E END OF EDIT + F FIND STRING IN CURRENT BUFFER + H MOVE TO TOP OF FILE (HEAD) + I INSERT CHARACTERS FROM KEYBOARD + UP TO NEXT + J JUXTAPOSITION OPERATION - SEARCH FOR FIRST STRING, + INSERT SECOND STRING, DELETE UNTIL THIRD STRING + K DELETE LINES + L SKIP LINES + M MACRO DEFINITION (SEE COMMENT BELOW) + N FIND NEXT OCCURRENCE OF STRING + WITH AUTO SCAN THROUGH FILE + O RE-EDIT OLD FILE + P PAGE AND DISPLAY (MOVES UP OR DOWN 24 LINES AND + DISPLAYS 24 LINES) + Q QUIT EDIT WITHOUT UPDATING THE FILE + R READ FROM FILE UNTIL AND + INSERT INTO TEXT + S SEARCH FOR FIRST STRING, REPLACE BY SECOND STRING + T TYPE LINES + U TRANSLATE TO UPPER CASE (-U CHANGES TO NO TRANSLATE) + W WRITE LINES OF TEXT TO FILE + X TRANSFER (XFER) LINES TO FILE + Z SLEEP FOR 1/2 SECOND (USED IN MACROS TO STOP DISPLAY) + MOVE UP OR DOWN AND PRINT ONE LINE + + + IN GENERAL, THE EDITOR ACCEPTS SINGLE LETTER COMMANDS WITH OPTIONAL +INTEGER VALUES PRECEDING THE COMMAND. THE EDITOR ACCEPTS BOTH UPPER AND LOWER +CASE COMMANDS AND VALUES, AND PERFORMS TRANSLATION TO UPPER CASE UNDER THE FOL- +LOWING CONDITIONS. IF THE COMMAND IS TYPED IN UPPER CASE, THEN THE DATA WHICH +FOLLOWS IS TRANSLATED TO UPPER CASE. THUS, IF THE "I" COMMAND IS TYPED IN +UPPER CASE, THEN ALL INPUT IS AUTOMATICALLY TRANSLATED (ALTHOUGH ECHOED IN +LOWER CASE, AS TYPED). IF THE "A" COMMAND IS TYPED IN UPPER CASE, THEN ALL +INPUT IS TRANSLATED AS READ FROM THE DISK. GLOBAL TRANSLATION TO UPPER CASE +CAN BE CONTROLLED BY THE "U" COMMAND (-U TO NEGATE ITS EFFECT). IF YOU ARE +OPERATING WITH AN UPPER CASE ONLY TERMINAL, THEN OPERATION IS AUTOMATIC. +SIMILARLY, IF YOU ARE OPERATING WITH A LOWER CASE TERMINAL, AND TRANSLATION +TO UPPER CASE IS NOT SPECIFIED, THEN LOWER CASE CHARACTERS CAN BE ENTERED. + + A NUMBER OF COMMANDS CAN BE PRECEDED BY A POSITIVE OR + NEGATIVE INTEGER BETWEEN 0 AND 65535 (1 IS DEFAULT IF NO VALUE + IS SPECIFIED). THIS VALUE DETERMINES THE NUMBER OF TIMES THE + COMMAND IS APPLIED BEFORE RETURNING FOR ANOTHER COMMAND. + THE COMMANDS + C D K L T P U + CAN BE PRECEDED BY AN UNSIGNED, POSITIVE, OR NEGATIVE NUMBER, + THE COMMANDS + A F J N W Z + CAN BE PRECEDED BY AN UNSIGNED OR POSITIVE NUMBER, + THE COMMANDS + E H O Q + CANNOT BE PRECEDED BY A NUMBER. THE COMMANDS + F I J M R S + ARE ALL FOLLOWED BY ONE OR MORE STRINGS OF CHARACTERS WHICH CAN + BE OPTIONALLY SEPARATED OR TERMINATED BY EITHER OR . + THE IS GENERALLY USED TO SEPARATE THE SEARCH STRINGS + IN THE S AND J COMMANDS, AND IS USED AT THE END OF THE COMMANDS IF + ADDITIONAL COMMANDS FOLLOW. FOR EXAMPLE, THE FOLLOWING COMMAND + SEQUENCE SEARCHES FOR THE STRING 'GAMMA', SUBSTITUTES THE STRING + 'DELTA', AND THEN TYPES THE FIRST PART OF THE LINE WHERE THE + CHANGE OCCURRED, FOLLOWED BY THE REMAINDER OF THE LINE WHICH WAS + CHANGED: + SGAMMADELTA0TT + + THE CONTROL-L CHARACTER IN SEARCH AND SUBSTITUTE STRINGS IS + REPLACED ON INPUT BY CHARACTERS. THE CONTROL-I KEY + IS TAKEN AS A TAB CHARACTER. + + THE COMMANDS R & X MUST BE FOLLOWED BY A FILE NAME (WITH default + FILE TYPE OF 'LIB') WITH A TRAILING OR . THE COMMAND + I IS FOLLOWED BY A STRING OF SYMBOLS TO INSERT, TERMINATED BY + A OR . IF SEVERAL LINES OF TEXT ARE TO BE INSERTED, + THE I CAN BE DIRECTLY FOLLOWED BY AN OR IN WHICH + CASE THE EDITOR ACCEPTS LINES OF INPUT TO THE NEXT . + THE COMMAND 0T PRINTS THE FIRST PART OF THE CURRENT LINE, + AND THE COMMAND 0L MOVES THE REFERENCE TO THE BEGINNING OF THE + CURRENT LINE. THE COMMAND 0P PRINTS THE CURRENT PAGE ONLY, WHILE + THE COMMAND 0Z READS THE CONSOLE RATHER THAN WAITING (THIS IS USED + AGAIN WITHIN MACROS TO STOP THE DISPLAY - THE MACRO EXPANSION + STOPS UNTIL A CHARACTER IS READ. IF THE CHARACTER IS NOT A BREAK + THEN THE MACRO EXPANSION CONTINUES NORMALLY). + + NOTE THAT A POUND SIGN IS TAKEN AS THE NUMBER 65535, ALL + UNSIGNED NUMBERS ARE ASSUMED POSITIVE, AND A SINGLE - IS ASSUMED -1 + + A NUMBER OF COMMANDS CAN BE GROUPED TOGETHER AND EXECUTED + REPETITIVELY USING THE MACRO COMMAND WHICH TAKES THE FORM + + MC1C2...CN + + WHERE IS A NON-NEGATIVE INTEGER N, AND IS + OR . THE COMMANDS C1 ... CN FOLLOWING THE M ARE + EXECUTED N TIMES, STARTING AT THE CURRENT POSITION IN THE BUFFER. + IF N IS 0, 1, OR OMITTED, THE COMMANDS ARE EXECUTED UNTIL THE END + IF THE BUFFER IS ENCOUNTERED. + + THE FOLLOWING MACRO, FOR EXAMPLE, CHANGES ALL OCCURRENCES OF + THE NAME 'GAMMA' TO 'DELTA', AND PRINTS THE LINES WHICH + WERE CHANGED: + + MFGAMMA-5DIDELTA0LT + + (NOTE: AN IS THE CP/M END OF FILE MARK - CONTROL-Z) + + IF ANY KEY IS DEPRESSED DURING TYPING OR MACRO EXPANSION, THE + FUNCTION IS CONSIDERED TERMINATED, AND CONTROL RETURNS TO THE + OPERATOR. + + ERROR CONDITIONS ARE INDICATED BY PRINTING ONE OF THE CHARACTERS: + + SYMBOL ERROR CONDITION + ------ ---------------------------------------------------- + GREATER FREE MEMORY IS EXHAUSTED - ANY COMMAND CAN BE ISSUED + WHICH DOES NOT INCREASE MEMORY REQUIREMENTS. + QUESTION UNRECOGNIZED COMMAND OR ILLEGAL NUMERIC FIELD + POUND CANNOT APPLY THE COMMAND THE NUMBER OF TIMES SPECFIED + (OCCURS IF SEARCH STRING CANNOT BE FOUND) + LETTER O CANNOT OPEN .LIB IN R COMMAND + + THE ERROR CHARACTER IS ALSO ACCOMPANIED BY THE LAST CHARACTER + SCANNED WHEN THE ERROR OCCURRED. */ + +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * GLOBAL VARIABLES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +DECLARE LIT LITERALLY 'LITERALLY', + DCL LIT 'DECLARE', + PROC LIT 'PROCEDURE', + ADDR LIT 'ADDRESS', + BOOLEAN LIT 'BYTE', + CTLL LIT '0CH', + CTLR LIT '12H', /* REPEAT LINE IN INSERT MODE */ + CTLU LIT '15H', /* LINE DELETE IN INSERT MODE */ + CTLX LIT '18H', /* EQUIVALENT TO CTLU */ + CTLH LIT '08H', /* BACKSPACE */ + TAB LIT '09H', /* TAB CHARACTER */ + LCA LIT '110$0001B', /* LOWER CASE A */ + LCZ LIT '111$1010B', /* LOWER CASE Z */ + ESC LIT '1BH', /* ESCAPE CHARACTER */ + ENDFILE LIT '1AH'; /* CP/M END OF FILE */ + +DECLARE + TRUE LITERALLY '1', + FALSE LITERALLY '0', + FOREVER LITERALLY 'WHILE TRUE', + CTRL$Y LITERALLY '19h', + CR LITERALLY '13', + LF LITERALLY '10', + WHAT LITERALLY '63'; + +DECLARE + MAX ADDRESS, /* .MEMORY(MAX)=0 (END) */ + MAXM ADDRESS, /* MINUS 1 */ + HMAX ADDRESS; /* = MAX/2 */ + +declare + i byte; /* used by command parsing */ + +DECLARE + us literally '8', /* file from user 0 */ + RO LITERALLY '9', /* R/O FILE INDICATOR */ + SY LITERALLY '10', /* SYSTEM FILE ATTRIBUTE */ + EX LITERALLY '12', /* EXTENT NUMBER POSITION */ + UB LITERALLY '13', /* UNFILLED BYTES */ + ck LITERALLY '13', /* checksum */ + MD LITERALLY '14', /* MODULE NUMBER POSITION */ + NR LITERALLY '32', /* NEXT RECORD FIELD */ + FS LITERALLY '33', /* FCB SIZE */ + RFCB (FS) BYTE /* READER FILE CONTROL BLOCK */ + INITIAL(0, /* FILE NAME */ ' ', + /* FILE TYPE */ 'LIB',0,0,0), + RBP BYTE, /* READ BUFFER POINTER */ + XFCB (FS) BYTE /* XFER FILE CONTROL BLOCK */ + INITIAL(0, 'X$$$$$$$','LIB',0,0,0,0,0,0,0), + XFCBE BYTE AT(.XFCB(EX)), /* XFCB EXTENT */ + XFCBR BYTE AT(.XFCB(NR)), /* XFCB RECORD # */ + xfcbext byte initial(0), /* save xfcb extent for appends */ + xfcbrec byte initial(0), /* save xfcb record for appends */ + XBUFF (SECTSIZE) BYTE, /* XFER BUFFER */ + XBP BYTE, /* XFER POINTER */ + + NBUF BYTE, /* NUMBER OF BUFFERS */ + BUFFLENGTH ADDRESS, /* NBUF * SECTSIZE */ + SFCB (FS) BYTE AT(.FCB), /* SOURCE FCB = DEFAULT FCB */ + SDISK BYTE AT (.FCB), /* SOURCE DISK */ + SBUFFADR ADDRESS, /* SOURCE BUFFER ADDRESS */ + SBUFF BASED SBUFFADR (128) BYTE, /* SOURCE BUFFER */ + password (16) byte initial(0), /* source password */ + + DFCB (FS) BYTE, /* DEST FILE CONTROL BLOCK */ + DDISK BYTE AT (.DFCB), /* DESTINATION DISK */ + DBUFFADR ADDRESS, /* DESTINATION BUFFER ADDRESS */ + DBUFF BASED DBUFFADR (128) BYTE, /* DEST BUFFER */ + NSOURCE ADDRESS, /* NEXT SOURCE CHARACTER */ + NDEST ADDRESS, /* NEXT DESTINATION CHAR */ + + tmpfcb (FS) BYTE; /* temporary fcb for rename & deletes */ + +DECLARE /**** some of the logicals *****/ + newfile BOOLEAN initial (false), /* true if no source file */ + onefile BOOLEAN initial (true), /* true if output file=input file */ + XFERON BOOLEAN initial (false), /* TRUE IF XFER ACTIVE */ + reading BOOLEAN initial (false), /* TRUE IF reading RFCB */ + PRINTSUPPRESS BOOLEAN initial (false),/* TRUE IF PRINT SUPPRESSED */ + sys BOOLEAN initial (false), /* true if system file */ + protection BOOLEAN initial (false), /* password protection mode */ + INSERTING BOOLEAN, /* TRUE IF INSERTING CHARACTERS */ + READBUFF BOOLEAN, /* TRUE IF END OF READ BUFFER */ + TRANSLATE BOOLEAN initial (false), /* TRUE IF XLATION TO UPPER CASE */ + UPPER BOOLEAN initial (false), /* TRUE IF GLOBALLY XLATING TO UC */ + LINESET BOOLEAN initial (true), /* TRUE IF LINE #'S PRINTED */ + has$bdos3 BOOLEAN initial (false), /* true if BDOS version >= 3.0 */ + tail BOOLEAN initial (true), /* true if readiing from cmd tail */ + dot$found BOOLEAN initial (false); /* true if dot found in fname parse*/ + +DECLARE + dtype (3) byte, /* destination file type */ + libfcb (12) byte initial(0,'X$$$$$$$LIB'),/* default lib name */ + tempfl (3) byte initial('$$$'), /* temporary file type */ + backup (3) byte initial('BAK'); /* backup file type */ + +declare + error$code address; + +DECLARE + COLUMN BYTE initial(0), /* CONSOLE COLUMN POSITION */ + SCOLUMN BYTE INITIAL(8), /* STARTING COLUMN IN "I" MODE */ + TCOLUMN BYTE, /* TEMP DURING BACKSPACE */ + QCOLUMN BYTE; /* TEMP DURING BACKSPACE */ + +DECLARE DCNT BYTE; /* RETURN CODE FROM MON? CALLS */ + +/* COMMAND BUFFER */ +DECLARE (MAXLEN,COMLEN) BYTE, COMBUFF(128) BYTE, + CBP BYTE initial(0); + +DECLARE /* LINE COUNTERS */ + BASELINE ADDRESS, /* CURRENT LINE */ + RELLINE ADDRESS; /* RELATIVE LINE IN TYPEOUT */ + +DECLARE + FORWARD LIT '1', + BACKWARD LIT '0', + RUBOUT LIT '07FH', + POUND LIT '23H', + MACSIZE LIT '128', /* MAX MACRO SIZE */ + SCRSIZE LIT '100', /* SCRATCH BUFFER SIZE */ + COMSIZE LIT 'ADDRESS'; /* DETERMINES MAX COMMAND NUMBER*/ + +DCL MACRO(MACSIZE) BYTE, + SCRATCH(SCRSIZE) BYTE, /* SCRATCH BUFFER FOR F,N,S */ + (WBP, WBE, WBJ) BYTE, /* END OF F STRING, S STRING, J STRING */ + (FLAG, MP, MI, XP) BYTE, + MT COMSIZE; + +DCL (START, RESTART, OVERCOUNT, OVERFLOW, + disk$err, dir$err, RESET, BADCOM) LABEL; + +/* global variables used by file parsing routines */ +dcl ncmd byte initial(0); + + +DCL (DISTANCE, TDIST) COMSIZE, + (DIRECTION, CHAR) BYTE, + ( FRONT, BACK, FIRST, LASTC) ADDR; + +dcl LPP byte initial(23); /* LINES PER PAGE */ + +/* the following stucture is used near plm: to set + the lines per page from the BDOS 3 SCB */ +declare + pb (2) byte data (28,0); + +declare + ver address; /* VERSION NUMBER */ + +declare + err$msg address initial(0), + invalid (*) byte data ('Invalid Filename$'), + dirfull (*) byte data ('DIRECTORY FULL$'), + diskfull (*) byte data ('DISK FULL$'), + password$err(*) byte data ('Creating Password$'), + not$found (*) byte data ('File not found$'), + notavail (*) byte data ('File not available$'); +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * CP/M INTERFACE ROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + /* IO SECTION */ + +READCHAR: PROCEDURE BYTE; RETURN MON2(1,0); + END READCHAR; + + conin: + procedure byte; + return mon2(6,0fdh); + end conin; + +PRINTCHAR: PROCEDURE(CHAR); + DECLARE CHAR BYTE; + IF PRINTSUPPRESS THEN RETURN; + CALL MON1(2,CHAR); + END PRINTCHAR; + +TTYCHAR: PROCEDURE(CHAR); + DECLARE CHAR BYTE; + IF CHAR >= ' ' THEN COLUMN = COLUMN + 1; + IF CHAR = LF THEN COLUMN = 0; + CALL PRINTCHAR(CHAR); + END TTYCHAR; + +BACKSPACE: PROCEDURE; + /* MOVE BACK ONE POSITION */ + IF COLUMN = 0 THEN RETURN; + CALL TTYCHAR(CTLH); /* COLUMN = COLUMN - 1 */ + CALL TTYCHAR(' ' ); /* COLUMN = COLUMN + 1 */ + CALL TTYCHAR(CTLH); /* COLUMN = COLUMN - 1 */ + COLUMN = COLUMN - 2; + END BACKSPACE; + +PRINTABS: PROCEDURE(CHAR); + DECLARE (CHAR,I,J) BYTE; + I = CHAR = TAB AND 7 - (COLUMN AND 7); + IF CHAR = TAB THEN CHAR = ' '; + DO J = 0 TO I; + CALL TTYCHAR(CHAR); + END; + END PRINTABS; + +GRAPHIC: PROCEDURE(C) BOOLEAN; + DECLARE C BYTE; + /* RETURN TRUE IF GRAPHIC CHARACTER */ + IF C >= ' ' THEN RETURN TRUE; + RETURN C = CR OR C = LF OR C = TAB; + END GRAPHIC; + +PRINTC: PROCEDURE(C); + DECLARE C BYTE; + IF NOT GRAPHIC(C) THEN + DO; CALL PRINTABS('^'); + C = C + '@'; + END; + CALL PRINTABS(C); + END PRINTC; + +CRLF: PROCEDURE; + CALL PRINTC(CR); CALL PRINTC(LF); + END CRLF; + +PRINTM: PROCEDURE(A); + DECLARE A ADDRESS; + CALL MON1(9,A); + END PRINTM; + +PRINT: PROCEDURE(A); + DECLARE A ADDRESS; + CALL CRLF; + CALL PRINTM(A); + END PRINT; + +perror: procedure(a); + declare a address; + call print(.(tab,'ERROR - $')); + call printm(A); + call crlf; + end perror; + +READ: PROCEDURE(A); + DECLARE A ADDRESS; + CALL MON1(10,A); + END READ; + + /* used for library files */ +OPEN: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + if MON2(15,FCB) = 255 then do; + flag = 'O'; + err$msg = .not$found; + go to reset; + end; + END OPEN; + + /* used for main source file */ +OPEN$FILE: PROCEDURE(FCB) ADDRESS; + DECLARE FCB ADDRESS; + RETURN MON3(15,FCB); + END OPEN$FILE; + +CLOSE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + DCNT = MON2(16,FCB); + END CLOSE; + +DELETE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + DCNT = MON2(19,FCB); + END DELETE; + +DISKREAD: PROCEDURE(FCB) BYTE; + DECLARE FCB ADDRESS; + RETURN MON2(20,FCB); + END DISKREAD; + +DISKWRITE: PROCEDURE(FCB) BYTE; + DECLARE FCB ADDRESS; + RETURN MON2(21,FCB); + END DISKWRITE; + +RENAME: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + CALL MON1(23,FCB); + END RENAME; + +READCOM: PROCEDURE; + MAXLEN = 128; CALL READ(.MAXLEN); + END READCOM; + +BREAK$KEY: PROCEDURE BOOLEAN; + IF MON2(11,0) THEN + DO; /* CLEAR CHAR */ + IF MON2(1,0) = CTRL$Y THEN + RETURN TRUE; + END; + RETURN FALSE; + END BREAK$KEY; + +CSELECT: PROCEDURE BYTE; + /* RETURN CURRENT DRIVE NUMBER */ + RETURN MON2(25,0); + END CSELECT; + +SETDMA: PROCEDURE(A); + DECLARE A ADDRESS; + /* SET DMA ADDRESS */ + CALL MON1(26,A); + END SETDMA; + +set$attribute: procedure(FCB); + declare fcb address; + call MON1(30,FCB); + end set$attribute; + +/* The PL/M built-in procedure "MOVE" can be used to move storage, + its definition is: + +MOVE: PROCEDURE(COUNT,SOURCE,DEST); + DECLARE (COUNT,SOURCE,DEST) ADDRESS; + / MOVE DATA FROM SOURCE TO DEST ADDRESSES, FOR COUNT BYTES / + END MOVE; + */ + /* this routine is included solely for + enconomy of space over the use of the + equivalent (in-line) code generated by + the built-in function */ +move: proc(c,s,d); + dcl (s,d) addr, c byte; + dcl a based s byte, b based d byte; + + do while (c:=c-1)<>255; + b=a; s=s+1; d=d+1; + end; + end move; + +write$xfcb: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + call move(8,.password,.password(8)); + if MON2(103,FCB)= 0ffh then + call perror(.password$err); + END write$xfcb; + +read$xfcb: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + call MON1(102,FCB); + END read$xfcb; + + /* 0ff => return BDOS errors */ +return$errors: + procedure(mode); + declare mode byte; + call mon1 (45,mode); + end return$errors; + +REBOOT: PROCEDURE; + IF XFERON THEN + CALL DELETE(.libfcb); + CALL BOOT; + END REBOOT; + +version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * SUBROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + /* INPUT / OUTPUT BUFFERING ROUTINES */ + + + + /* abort ED and print error message */ +ABORT: PROCEDURE(A); + DECLARE A ADDRESS; + CALL perror(A); + CALL REBOOT; + END ABORT; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* fatal file error */ +FERR: PROCEDURE; + CALL CLOSE(.DFCB); /* ATTEMPT TO CLOSE FILE FOR LATER RECOVERY */ + CALL ABORT (.dirfull); + END FERR; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set password if cpm 3*/ +setpassword: procedure; + if has$bdos3 then + call setdma(.password); + end setpassword; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* delete file at afcb */ +delete$file: procedure(afcb); + declare afcb address; + call setpassword; + call delete(afcb); + end delete$file; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* rename file at afcb */ +rename$file: procedure(afcb); + declare afcb address; + call delete$file(afcb+16); /* delete new file */ + call setpassword; + call rename(afcb); + end rename$file; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* make file at afcb */ +make$file: procedure(afcb); + declare afcb address; + call delete$file(afcb); /* delete file */ + call setpassword; + DCNT = MON2(22,afcb); /* create file */ + end make$file; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* fill string @ s for c bytes with f */ +fill: proc(s,f,c); + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; + + + + +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * FILE HANDLING ROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + /* set destination file type to type at A */ +SETTYPE: PROCEDURE(afcb,A); + DECLARE (afcb, A) ADDRESS; + CALL MOVE(3,A,aFCB+9); + END SETTYPE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set dma to xfer buffer */ +SETXDMA: PROCEDURE; + CALL SETDMA(.XBUFF); + END SETXDMA; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* fill primary source buffer */ +FILLSOURCE: PROCEDURE; + DECLARE I BYTE; + ZN: PROCEDURE; + NSOURCE = 0; + END ZN; + + CALL ZN; + DO I = 0 TO NBUF; + CALL SETDMA(SBUFFADR+NSOURCE); + IF (DCNT := DISKREAD(.FCB)) <> 0 THEN + DO; IF DCNT > 1 THEN CALL FERR; + SBUFF(NSOURCE) = ENDFILE; + I = NBUF; + END; + ELSE + NSOURCE = NSOURCE + SECTSIZE; + END; + CALL ZN; + END FILLSOURCE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* get next character in source file */ +GETSOURCE: PROCEDURE BYTE; + DECLARE B BYTE; + if newfile then return endfile; /* in case they try to #a */ + IF NSOURCE >= BUFFLENGTH THEN CALL FILLSOURCE; + IF (B := SBUFF(NSOURCE)) <> ENDFILE THEN + NSOURCE = NSOURCE + 1; + RETURN B; + END GETSOURCE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* try to free space by erasing backup */ +erase$bak: PROCEDURE BOOLEAN; + + if onefile then + if newfile then do; + call move(fs,.dfcb,.tmpfcb); /* can't diddle with open fcb */ + CALL SETTYPE(.tmpfcb,.BACKUP); + CALL DELETE$file(.tmpfcb); + if dcnt <> 255 then + return true; + end; + return false; + end erase$bak; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* write output buffer up to (not including) + ndest (low 7 bits of ndest are 0 */ +WRITEDEST: PROCEDURE; + DECLARE (I,N,save$ndest) BYTE; + + n = shr(ndest,sectshf); /* calculate number sectors to write */ + if n=0 then return; /* no need to write if we haven't filled sector*/ + save$ndest = ndest; /* save for error recovery */ + ndest = 0; + DO I = 1 TO N; +retry: + CALL SETDMA(DBUFFADR+NDEST); + IF DISKWRITE(.DFCB) <> 0 THEN + if erase$bak then + go to retry; + else do; /* reset buffer, let them take action (delete files) */ + if ndest <> 0 then + call move(save$ndest-ndest, dbuffadr+ndest, dbuffadr); + ndest = save$ndest-ndest; + go to disk$err; + end; + NDEST = NDEST + SECTSIZE; + END; + ndest = 0; + END WRITEDEST; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* put a character in output buffer */ +PUTDEST: PROCEDURE(B); + DECLARE B BYTE; + IF NDEST >= BUFFLENGTH THEN CALL WRITEDEST; + DBUFF(NDEST) = B; + NDEST = NDEST + 1; + END PUTDEST; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* put a character in the xfer buffer */ +PUTXFER: PROCEDURE(C); + DECLARE C BYTE; + IF XBP >= SECTSIZE THEN /* BUFFER OVERFLOW */ + DO; +retry: + CALL SETXDMA; + xfcbext = xfcbe; /* save for appends */ + xfcbrec = xfcbr; + IF DISKWRITE(.XFCB) <> 0 THEN + if erase$bak then + go to retry; + else do; +/******** call close(.xfcb); *** commented out whf 8/82 !!!! ********/ + go to disk$err; + end; + XBP = 0; + END; + XBUFF(XBP) = C; XBP = XBP + 1; + END PUTXFER; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* empty xfer buffer and close file. + This routine is added to allow saving lib + files for future edits - DH 10/18/81 */ +close$xfer: procedure; + dcl i byte; + + do i = xbp to sectsize; + call putxfer(ENDFILE); + end; + call close(.xfcb); + end close$xfer; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* compare xfcb and rfcb to see if same */ +compare$xfer: procedure BOOLEAN; + dcl i byte; + + i = 12; + do while (i:=i-1) <> -1; + if xfcb(i) <> rfcb(i) then + return false; + end; + return true; + end compare$xfer; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* restore xfer file extent and current + record, read record and set xfer pointer + to first ENDFILE */ +append$xfer: procedure; + + xfcbe = xfcbext; + call open(.xfcb); + xfcbr = xfcbrec; + call setxdma; + if diskread(.xfcb) = 0 then do; + xfcbr = xfcbrec; /* write same record */ + do xbp = 0 to sectsize; + if xbuff(xbp) = ENDFILE then + return; + end; + end; + end append$xfer; +$ eject +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + * * * END EDIT ROUTINE * * * + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + /* finish edit, close files, rename */ +FINIS: PROCEDURE; + MOVEUP: PROCEDURE(afcb); + dcl afcb address; + /* set second filename (new name) for rename function */ + CALL MOVE(16,aFCB,aFCB+16); + END MOVEUP; + + /* * * * * * * * WRITE OUTPUT BUFFER * * * * * * * * */ + /* SET UNFILLED BYTES - USED FOR ISIS-II COMPATIBILITY */ + /* DFUB = 0 ; <<<< REMOVE FOR MP/M 2 , CP/M 3 */ + DO WHILE (LOW(NDEST) AND 7FH) <> 0; + /* COUNTS UNFILLED BYTES IN LAST RECORD */ + /* DFUB = DFUB + 1; */ + CALL PUTDEST(ENDFILE); + END; + CALL WRITEDEST; + + if not newfile then + call close(.sfcb); /* close this to clean up for mp/m environs */ + + /* * * * * * CLOSE TEMPORARY DESTINATION FILE * * * * * */ + CALL CLOSE(.DFCB); + IF DCNT = 255 THEN CALL FERR; + if sys then do; + dfcb(sy)=dfcb(sy) or 80h; + call setpassword; + call set$attribute(.dfcb); + end; + + /* * * * * * RENAME SOURCE TO BACKUP IF ONE FILE * * * * * */ + if onefile then do; + call moveup(.sfcb); + CALL SETTYPE(.sfcb+16,.BACKUP); /* set new type to BAK */ + CALL RENAME$FILE(.SFCB); + end; + + /* * * * * * RENAME TEMPORARY DESTINATION FILE * * * * * */ + CALL MOVEUP(.DFCB); + CALL SETTYPE(.DFCB+16,.DTYPE); + CALL RENAME$FILE(.DFCB); + + END FINIS; +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * COMMAND ROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + /* print a character if not macro expansion */ +PRINTNMAC: PROCEDURE(CHAR); + DECLARE CHAR BYTE; + IF MP <> 0 THEN RETURN; + CALL PRINTC(CHAR); + END PRINTNMAC; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* return true if lower case character */ +LOWERCASE: PROCEDURE(C) BOOLEAN; + DECLARE C BYTE; + RETURN C >= LCA AND C <= LCZ; + END LOWERCASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* translate character to upper case */ +UCASE: PROCEDURE(C) BYTE; + DECLARE C BYTE; + IF LOWERCASE(C) THEN RETURN C AND 5FH; + RETURN C; + END UCASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* get password and place at fcb + 16 */ +getpasswd: proc; + dcl (i,c) byte; + + call crlf; + call print(.('Password ? ','$')); +retry: + call fill(.password,' ',8); + do i = 0 to 7; +nxtchr: + if (c:=ucase(conin)) >= ' ' then + password(i)=c; + if c = cr then + go to exit; + if c = CTLX then + goto retry; + if c = CTLH then do; + if i<1 then + goto retry; + else do; + password(i:=i-1)=' '; + goto nxtchr; + end; + end; + if c = 3 then + call reboot; + end; +exit: + c = break$key; /* clear raw I/O mode */ + end getpasswd; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* translate to upercase if translate flag + is on (also translate ESC to ENDFILE) */ +UTRAN: PROCEDURE(C) BYTE; + DECLARE C BYTE; + IF C = ESC THEN C = ENDFILE; + IF TRANSLATE THEN RETURN UCASE(C); + RETURN C; + END UTRAN; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print the line number */ +PRINTVALUE: PROCEDURE(V); + /* PRINT THE LINE VALUE V */ + DECLARE D BYTE, + ZERO BOOLEAN, + (K,V) ADDRESS; + K = 10000; + ZERO = FALSE; + DO WHILE K <> 0; + D = LOW(V/K); V = V MOD K; + K = K / 10; + IF ZERO OR D <> 0 THEN + DO; ZERO = TRUE; + CALL PRINTC('0'+D); + END; + ELSE + CALL PRINTC(' '); + END; + END PRINTVALUE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print line with number V */ +PRINTLINE: PROCEDURE(V); + DECLARE V ADDRESS; + IF NOT LINESET THEN RETURN; + CALL PRINTVALUE(V); + CALL PRINTC(':'); + CALL PRINTC(' '); + IF INSERTING THEN + CALL PRINTC(' '); + ELSE + CALL PRINTC('*'); + END PRINTLINE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print current line (baseline) */ +PRINTBASE: PROCEDURE; + CALL PRINTLINE(BASELINE); + END PRINTBASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print current line if not in a macro */ +PRINTNMBASE: PROCEDURE; + IF MP <> 0 THEN RETURN; + CALL PRINTBASE; + END PRINTNMBASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* get next character from command tail */ +getcmd: proc byte; + if buff(ncmd+1) <> 0 then + return buff(ncmd := ncmd + 1); + return cr; + end getcmd; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* read next char from command buffer */ +READC: PROCEDURE BYTE; + /* MAY BE MACRO EXPANSION */ + IF MP > 0 THEN + DO; + IF BREAK$KEY THEN GO TO OVERCOUNT; + IF XP >= MP THEN + DO; /* START AGAIN */ + IF MT <> 0 THEN + DO; IF (MT:=MT-1) = 0 THEN + GO TO OVERCOUNT; + END; + XP = 0; + END; + RETURN UTRAN(MACRO((XP := XP + 1) - 1)); + END; + IF INSERTING THEN RETURN UTRAN(READCHAR); + + /* GET COMMAND LINE */ + IF READBUFF THEN + DO; READBUFF = FALSE; + IF LINESET AND COLUMN = 0 THEN + DO; + IF BACK >= MAXM THEN + CALL PRINTLINE(0); + ELSE + CALL PRINTBASE; + END; + ELSE + CALL PRINTC('*'); + CALL READCOM; CBP = 0; + CALL PRINTC(LF); + COLUMN = 0; + END; + IF (READBUFF := CBP = COMLEN ) THEN + COMBUFF(CBP) = CR; + RETURN UTRAN(COMBUFF((CBP := CBP +1) -1)); + END READC; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* get upper case character from command + buffer or command line */ +get$uc: proc; + if tail then + char = ucase(getcmd); + else + char = ucase(readc); + end get$uc; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* parse file name + this routine requires a routine to get + the next character and put it in a byte + variable */ +parse$fcb: proc(fcbadr) byte; + dcl fcbadr addr; + dcl afcb based fcbadr (33) byte; + dcl drive lit 'afcb(0)'; + dcl (i,delimiter) byte; + dcl pflag boolean; + + putc: proc; + afcb(i := i + 1) = char; + pflag = true; + end putc; + + delim: proc boolean; + dcl del(*) byte data (CR,ENDFILE,' ,.;=:<>_[]*?'); + /* 0 1 2345678901234 */ + do delimiter = 0 to last(del); + if char = del(delimiter) then do; + if delimiter > 12 then /* * or ? */ + call perror(.('Cannot Edit Wildcard Filename$')); + return (true); + end; + end; + return (false); + end delim; + + + pflag = false; + flag = true; /* global flag set to false if invalid filename */ + dot$found = false; /* allow null extensions in 'parse$lib' */ + call get$uc; + if char <> CR then + if char <> ENDFILE then do; + /* initialize fcb to srce fcb type & drive */ + call fill(fcbadr+12,0,21); + call fill(fcbadr+1,' ',11); + /* clear leading blanks */ + do while char = ' '; + call get$uc; + end; + /* parse loop */ + do while not delim; + i = 0; + /* get name */ + do while not delim; + if i > 7 then + go to err; /* too long */ + call putc; + call get$uc; + end; + if char = ':' then do; + /* get drive from afcb(1) */ + if i <> 1 then + go to err; /* invalid : */ + if (drive := afcb(1) - 'A' + 1) > 16 then + go to err; /* invalid drive */ + afcb(1) = ' '; + call get$uc; + end; + if char = '.' then do; + /* get file type */ + i = 8; + dot$found = true; /* .ext specified (may be null)*/ + call get$uc; + do while not delim; + if i > 10 then + go to err; /* too long */ + call putc; + call get$uc; + end; + end; + if char = ';' then do; + /* get password */ + call fill(fcbadr+16,' ',8); /* where fn #152 puts passwd */ + i = 15; /* passwd is last field */ + call get$uc; + do while not delim; + if i > 23 then + go to err; + call putc; + call get$uc; + end; + call move(8,fcbadr+16,.password); /* where ed wants it */ + end; + end; /* parse loop */ + /* delimiter must be a comma or space */ + if delimiter > 3 then /* not a CR,ENDFILE,SPACE,COMMA */ + go to err; + if not pflag then + go to err; + end; + + return (pflag); + +err: + call perror(.invalid); + return (flag:=false); + end parse$fcb; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set up destination FCB */ +setdest: PROCEDURE; + dcl i byte; + + /* onefile = true; (initialized) */ + if not tail then do; + call print(.('Enter Output file: $')); + call readcom; + cbp,readbuff = 0; + call crlf; + call crlf; + end; + if parse$fcb(.dfcb) then do; + onefile = false; + if dfcb(1) = ' ' then + call move(15,.sfcb+1,.dfcb+1); + end; + else + CALL MOVE(16,.SFCB,.DFCB); + call move(3,.dfcb(9),.dtype); /* save destination type */ + end setdest; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set read lib file DMA address */ +SETRDMA: PROCEDURE; + CALL SETDMA(.BUFF); + END SETRDMA; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* read lib file routine */ +READFILE: PROCEDURE BYTE; + IF RBP >= SECTSIZE THEN + DO; CALL SETRDMA; + IF DISKREAD(.RFCB) <> 0 THEN RETURN ENDFILE; + RBP = 0; + END; + RETURN UTRAN(BUFF((RBP := RBP + 1) - 1)); + END READFILE; +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * INITIALIZATION * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +SETUP: PROCEDURE; + + /* * * * * * * * * OPEN SOURCE FILE * * * * * * * * */ + + sfcb(ex), sfcb(md), sfcb(nr) = 0; + if has$bdos3 then do; + call return$errors(0FEh); /* set error mode */ + call setpassword; + end; + error$code = open$file (.SFCB); + if has$bdos3 then do; /* extended bdos errors */ + call return$errors(0); /* reset error mode */ + if low(error$code) = 0FFh and high(error$code) = 7 then do; + call getpasswd; /* let them enter password */ + call crlf; + call crlf; + call setpassword; /* set dma to password */ + error$code = open$file(.fcb); /* reset error$code */ + end; + if low(error$code)=0FFh and high(error$code)<>0 then + call abort(.notavail); /* abort anything but not found */ + end; + dcnt=low(error$code); + if onefile then do; + IF ROL(FCB(RO),1) THEN + CALL abort(.('FILE IS READ/ONLY$')); + else IF ROL(FCB(SY),1) THEN /* system attribute */ + do; + if rol(FCB(us),1) then + dcnt = 255; /* user 0 file so create */ + else + sys = true; + end; + end; + + /* * * * * * NEW FILE IF NO SOURCE FILE * * * * * */ + + IF DCNT = 255 THEN do; + if not onefile then + call abort(.not$found); + newfile = true; + CALL PRINT(.('NEW FILE$')); + CALL CRLF; + END; + + /* * * * * * MAKE TEMPORARY DESTINATION FILE * * * * * */ + + CALL SETTYPE(.dfcb,.tempfl); + DFCB(EX)=0; + CALL MAKE$file(.DFCB); + if dcnt = 255 then + call ferr; + /* THE TEMP FILE IS NOW CREATED */ + + /* now create the password if any */ + if protection <> 0 then do; + dfcb(ex) = protection or 1; /* set password */ + call setpassword; + call write$xfcb(.dfcb); + end; + dfcb(ex),DFCB(32) = 0; /* NEXT RECORD IS ZERO */ + + /* * * * * * * * * RESET BUFFER * * * * * * * * */ + + NSOURCE = BUFFLENGTH; + NDEST = 0; + BASELINE = 1; /* START WITH LINE 1 */ + END SETUP; + + + + +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * BUFFER MANAGEMENT * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + /* DISTANCE is the number of lines prefix + to a command */ + /* set maximum distance (0FFFFH) */ +SETFF: PROCEDURE; + DISTANCE = 0FFFFH; + END SETFF; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* return true if distance is zero */ +DISTZERO: PROCEDURE BOOLEAN; + RETURN DISTANCE = 0; + END DISTZERO; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set distance to zero */ +ZERODIST: PROCEDURE; + DISTANCE = 0; + END ZERODIST; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* check for zero distance and decrement */ +DISTNZERO: PROCEDURE BOOLEAN; + IF NOT DISTZERO THEN + DO; DISTANCE = DISTANCE - 1; + RETURN TRUE; + END; + RETURN FALSE; + END DISTNZERO; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set memory limits of command from + distance and direction */ +SETLIMITS: PROC; + DCL (I,K,L,M) ADDR, (MIDDLE,LOOPING) BYTE; + RELLINE = 1; /* RELATIVE LINE COUNT */ + IF DIRECTION = BACKWARD THEN + DO; DISTANCE = DISTANCE+1; I = FRONT; L = 0; K = 0FFFFH; + END; + ELSE + DO; I = BACK; L = MAXM; K = 1; + END; + + LOOPING = TRUE; + DO WHILE LOOPING; + DO WHILE (MIDDLE := I <> L) AND + MEMORY(M:=I+K) <> LF; + I = M; + END; + LOOPING = (DISTANCE := DISTANCE - 1) <> 0; + IF NOT MIDDLE THEN + DO; LOOPING = FALSE; + I = I - K; + END; + ELSE do; + RELLINE = RELLINE - 1; + IF LOOPING THEN + I = M; + end; + END; + + IF DIRECTION = BACKWARD THEN + DO; FIRST = I; LASTC = FRONT - 1; + END; + ELSE + DO; FIRST = BACK + 1; LASTC = I + 1; + END; + END SETLIMITS; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* increment current position */ +INCBASE: PROCEDURE; + BASELINE = BASELINE + 1; + END INCBASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* decrement current position */ +DECBASE: PROCEDURE; + BASELINE = BASELINE - 1; + END DECBASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* increment limits */ +INCFRONT: PROC; FRONT = FRONT + 1; + END INCFRONT; +INCBACK: PROCEDURE; BACK = BACK + 1; + END INCBACK; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* decrement limits */ +DECFRONT: PROC; FRONT = FRONT - 1; + IF MEMORY(FRONT) = LF THEN + CALL DECBASE; + END DECFRONT; +DECBACK: PROC; BACK = BACK - 1; + END DECBACK; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* move current page in memory if move flag + true otherwise delete it */ +MEM$MOVE: PROC(MOVEFLAG); + DECLARE (MOVEFLAG,C) BYTE; + /* MOVE IF MOVEFLAG IS TRUE */ + IF DIRECTION = FORWARD THEN + DO WHILE BACK < LASTC; CALL INCBACK; + IF MOVEFLAG THEN + DO; + IF (C := MEMORY(BACK)) = LF THEN CALL INCBASE; + MEMORY(FRONT) = C; CALL INCFRONT; + END; + END; + ELSE + DO WHILE FRONT > FIRST; CALL DECFRONT; + IF MOVEFLAG THEN + DO; MEMORY(BACK) = memory(front); CALL DECBACK; + END; + END; + END MEM$MOVE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* force a memory move */ +MOVER: PROC; + CALL MEM$MOVE(TRUE); + END MOVER; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* reset memory limit pointers, deleting + characters (used by D command) */ +SETPTRS: PROC; + CALL MEM$MOVE(FALSE); + END SETPTRS; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set limits and force a move */ +MOVELINES: PROC; + CALL SETLIMITS; + CALL MOVER; + END MOVELINES; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set front to lower value deleteing + characters (used by S and J commands) */ +setfront: proc(newfront); + dcl newfront addr; + + do while front <> newfront; + call decfront; + end; + end setfront; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set limits for memory move */ +SETCLIMITS: PROC; + IF DIRECTION = BACKWARD THEN + DO; LASTC = BACK; + IF DISTANCE > FRONT THEN + FIRST = 1; + ELSE + FIRST = FRONT - DISTANCE; + END; + ELSE + DO; FIRST = FRONT; + IF DISTANCE >= MAX - BACK THEN + LASTC = MAXM; + ELSE + LASTC = BACK + DISTANCE; + END; + END SETCLIMITS; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* read another line of input */ +READLINE: PROCEDURE; + DECLARE B BYTE; + /* READ ANOTHER LINE OF INPUT */ + CTRAN: PROCEDURE(B) BYTE; + DECLARE B BYTE; + /* CONDITIONALLY TRANSLATE TO UPPER CASE ON INPUT */ + IF UPPER THEN RETURN UTRAN(B); + RETURN B; + END CTRAN; + DO FOREVER; + IF FRONT >= BACK THEN GO TO OVERFLOW; + IF (B := CTRAN(GETSOURCE)) = ENDFILE THEN + DO; CALL ZERODIST; RETURN; + END; + MEMORY(FRONT) = B; + CALL INCFRONT; + IF B = LF THEN + DO; CALL INCBASE; + RETURN; + END; + END; + END READLINE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* write one line out */ +WRITELINE: PROCEDURE; + DECLARE B BYTE; + DO FOREVER; + IF BACK >= MAXM THEN /* EMPTY */ + DO; CALL ZERODIST; RETURN; + END; + CALL INCBACK; + CALL PUTDEST(B:=MEMORY(BACK)); + IF B = LF THEN + DO; CALL INCBASE; + RETURN; + END; + END; + END WRITELINE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* write lines until at least half the + the buffer is empty */ +WRHALF: PROCEDURE; + CALL SETFF; + DO WHILE DISTNZERO; + IF HMAX >= (MAXM - BACK) THEN + CALL ZERODIST; + ELSE + CALL WRITELINE; + END; + END WRHALF; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* write lines determined by distance + called from W and E commands */ +WRITEOUT: PROCEDURE; + DIRECTION = BACKWARD; FIRST = 1; LASTC = BACK; + CALL MOVER; + IF DISTZERO THEN CALL WRHALF; + /* DISTANCE = 0 IF CALL WRHALF */ + DO WHILE DISTNZERO; + CALL WRITELINE; + END; + IF BACK < LASTC THEN + DO; DIRECTION = FORWARD; CALL MOVER; + END; + END WRITEOUT; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* clear memory buffer */ +CLEARMEM: PROCEDURE; + CALL SETFF; + CALL WRITEOUT; + END CLEARMEM; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* clear buffers, terminate edit */ +TERMINATE: PROCEDURE; + CALL CLEARMEM; + if not newfile then + DO WHILE (CHAR := GETSOURCE) <> ENDFILE; + CALL PUTDEST(CHAR); + END; + CALL FINIS; + END TERMINATE; + + + + +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * COMMAND PRIMITIVES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + + /* insert char into memory buffer */ +INSERT: PROCEDURE; + IF FRONT = BACK THEN GO TO OVERFLOW; + MEMORY(FRONT) = CHAR; CALL INCFRONT; + IF CHAR = LF THEN CALL INCBASE; + END INSERT; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* read a character and check for endfile + or CR */ +SCANNING: PROCEDURE BYTE; + RETURN NOT ((CHAR := READC) = ENDFILE OR + (CHAR = CR AND NOT INSERTING)); + END SCANNING; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* read command buffer and insert characters + into scratch 'til next endfile or CR for + find, next, juxt, or substitute commands + fill at WBE and increment WBE so it + addresses the next empty position of scratch */ +COLLECT: PROCEDURE; + + SETSCR: PROCEDURE; + SCRATCH(WBE) = CHAR; + IF (WBE := WBE + 1) >= SCRSIZE THEN GO TO OVERFLOW; + END SETSCR; + + DO WHILE SCANNING; + IF CHAR = CTLL THEN + DO; CHAR = CR; CALL SETSCR; + CHAR = LF; + END; + IF CHAR = 0 THEN GO TO BADCOM; + CALL SETSCR; + END; + END COLLECT; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* find the string in scratch starting at + PA and ending at PB */ +FIND: PROCEDURE(PA,PB) BYTE; + DECLARE (PA,PB) BYTE; + DECLARE J ADDRESS, + (K, MATCH) BYTE; + J = BACK ; + MATCH = FALSE; + DO WHILE NOT MATCH AND (MAXM > J); + LASTC,J = J + 1; /* START SCAN AT J */ + K = PA ; /* ATTEMPT STRING MATCH AT K */ + DO WHILE SCRATCH(K) = MEMORY(LASTC) AND + NOT (MATCH := K = PB); + /* MATCHED ONE MORE CHARACTER */ + K = K + 1; LASTC = LASTC + 1; + END; + END; + IF MATCH THEN /* MOVE STORAGE */ + DO; LASTC = LASTC - 1; CALL MOVER; + END; + RETURN MATCH; + END FIND; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set up the search string for F, N, and + S commands */ +SETFIND: PROCEDURE; + WBE = 0; CALL COLLECT; WBP = WBE; + END SETFIND; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* check for found string in F and S commands */ +CHKFOUND: PROCEDURE; + IF NOT FIND(0,WBP) THEN /* NO MATCH */ GO TO OVERCOUNT; + END CHKFOUND; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* parse read / xfer lib FCB */ +parse$lib: procedure(fcbadr) byte; + dcl fcbadr address; + dcl afcb based fcbadr (33) byte; + dcl b byte; + + b = parse$fcb(fcbadr); + /* flag = false if invalid */ + if not flag then do; + flag = 'O'; + goto reset; + end; + if afcb(9) = ' ' and not dot$found then + call move(3,.libfcb(9),fcbadr+9); + if afcb(1) = ' ' then + call move(8,.libfcb(1),fcbadr+1); + return b; + end parse$lib; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print relative position */ +PRINTREL: PROCEDURE; + CALL PRINTLINE(BASELINE+RELLINE); + END PRINTREL; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* type lines command */ +TYPELINES: PROCEDURE; + DCL I ADDR; + DCL C BYTE; + CALL SETLIMITS; + /* DISABLE THE * PROMPT */ + INSERTING = TRUE; + IF DIRECTION = FORWARD THEN + DO; RELLINE = 0; I = FRONT; + END; + ELSE + I = FIRST; + IF (C := MEMORY(I-1)) = LF then do; + if COLUMN <> 0 THEN + CALL CRLF; + end; + else + relline = relline + 1; + + DO I = FIRST TO LASTC; + IF C = LF THEN + DO; + CALL PRINTREL; + RELLINE = RELLINE + 1; + IF BREAK$KEY THEN GO TO OVERCOUNT; + END; + CALL PRINTC(C:=MEMORY(I)); + END; + END TYPELINES; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set distance to lines per page (LPP) */ +SETLPP: PROCEDURE; + DISTANCE = LPP; + END SETLPP; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* save distance in TDIST */ +SAVEDIST: PROCEDURE; + TDIST = DISTANCE; + END SAVEDIST; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* Restore distance from TDIST */ +RESTDIST: PROCEDURE; + DISTANCE = TDIST; + END RESTDIST; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* page command (move n pages and print) */ +PAGE: PROCEDURE; + DECLARE I BYTE; + CALL SAVEDIST; + CALL SETLPP; + CALL MOVELINES; + I = DIRECTION; + DIRECTION = FORWARD; + CALL SETLPP; + CALL TYPELINES; + DIRECTION = I; + IF LASTC = MAXM OR FIRST = 1 THEN + CALL ZERODIST; + ELSE + CALL RESTDIST; + END PAGE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* wait command (1/2 second time-out) */ +WAIT: PROCEDURE; + DECLARE I BYTE; + DO I = 0 TO 19; + IF BREAK$KEY THEN GO TO RESET; + CALL TIME(250); + END; + END WAIT; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set direction to forward */ +SETFORWARD: PROCEDURE; + DIRECTION = FORWARD; + DISTANCE = 1; + END SETFORWARD; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* append 'til buffer is at least half full */ +APPHALF: PROCEDURE; + CALL SETFF; /* DISTANCE = 0FFFFH */ + DO WHILE DISTNZERO; + IF FRONT >= HMAX THEN + CALL ZERODIST; + ELSE + CALL READLINE; + END; + END APPHALF; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* insert CR LF characters */ +INSCRLF: PROCEDURE; + /* INSERT CR LF CHARACTERS */ + CHAR = CR; CALL INSERT; + CHAR = LF; CALL INSERT; + END INSCRLF; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* test if invalid delete or + backspace at beginning of inserting */ +ins$error$chk: procedure; + if (tcolumn = 255) or (front = 1) then + go to reset; + end ins$error$chk; +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * COMMAND PARSING * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + + /* test for upper or lower case command + set translate flag (used to determine + if following characters should be translated + to upper case */ +TESTCASE: PROCEDURE; + DECLARE T BYTE; + TRANSLATE = TRUE; + T = LOWERCASE(CHAR); + CHAR = UTRAN(CHAR); + TRANSLATE = UPPER OR NOT T; + END TESTCASE; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set translate to false and read next + character */ +READCTRAN: PROCEDURE; + TRANSLATE = FALSE; + CHAR = READC; + CALL TESTCASE; + END READCTRAN; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* return true if command is only character + not in macro or combination on a line */ +SINGLECOM: PROCEDURE(C) BOOLEAN; + DECLARE C BYTE; + RETURN CHAR = C AND COMLEN = 1 AND MP = 0; + END SINGLECOM; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* return true if command is only character + not in macro or combination on a line, and + the operator has responded with a 'Y' to a + Y/N request */ +SINGLERCOM: PROCEDURE(C) BOOLEAN; + DECLARE (C,i) BYTE; + IF SINGLECOM(C) THEN + DO forever; + CALL CRLF; CALL PRINTCHAR(C); + CALL MON1(9,.('-(Y/N)',WHAT,'$')); + i = UCASE(READCHAR); CALL CRLF; + IF i = 'N' THEN GO TO START; + if i = 'Y' then + RETURN TRUE; + END; + RETURN FALSE; + END SINGLERCOM; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* return true if char is a digit */ +DIGIT: PROCEDURE BOOLEAN; + RETURN (I := CHAR - '0') <= 9; + END DIGIT; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* return with distance = number char = + next command */ +NUMBER: PROCEDURE; + DISTANCE = 0; + DO WHILE DIGIT; + DISTANCE = SHL(DISTANCE,3) + + SHL(DISTANCE,1) + I; + CALL READCTRAN; + END; + END NUMBER; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* set distance to distance relative to + the current line */ +RELDISTANCE: PROCEDURE; + IF DISTANCE > BASELINE THEN + DO; DIRECTION = FORWARD; + DISTANCE = DISTANCE - BASELINE; + END; + ELSE + DO; DIRECTION = BACKWARD; + DISTANCE = BASELINE - DISTANCE; + END; + END RELDISTANCE; + + + +$ eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * MAIN PROGRAM * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +plm: /* entry of MP/M-86 Interface */ + + /* INITIALIZE THE SYSTEM */ + + ver = version; + if low(ver) >= cpm3 then + has$bdos3 = true; /* handles passwords & xfcbs */ + + /* * * * * * * SET UP MEMORY BUFFER * * * * * * * * * */ + + /* I/O BUFFER REGION IS 1/8 AVAILABLE MEMORY */ + NBUF = SHR(MAX := MAXB - .MEMORY,SECTSHF+3) - 1; + /* NBUF IS NUMBER OF BUFFERS - 1 */ + BUFFLENGTH = SHL(DOUBLE(NBUF+1),SECTSHF+1); + /* NOW SET MAX AS REMAINDER OF FREE MEMORY */ + IF BUFFLENGTH + 1024 > MAX THEN + DO; CALL perror(.('Insufficient memory$')); + CALL BOOT; + END; + /* REMOVE BUFFER SPACE AND 00 AT END OF MEMORY VECTOR */ + MAX = MAX - BUFFLENGTH - 1; + /* RESET BUFFER LENGTH FOR I AND O */ + BUFFLENGTH = SHR(BUFFLENGTH,1); + SBUFFADR = MAXB - BUFFLENGTH; + DBUFFADR = SBUFFADR - BUFFLENGTH; + MEMORY(MAX) = 0; /* STOPS MATCH AT END OF BUFFER */ + MAXM = MAX - 1; + HMAX = SHR(MAXM,1); + + /* * * * * * SET UP SOURCE & DESTINATION FILES * * * * * */ + + if fcb(1)=' ' then do; + call print(.('Enter Input file: $')); + call readcom; + call crlf; + tail = false; + end; + if not parse$fcb(.SFCB) then /* parse source fcb */ + call reboot; + + if has$bdos3 then do; + call read$xfcb(.sfcb); /* get prot from source */ + protection = sfcb(ex); /* password protection mode */ + sfcb(ex) = 0; + if high(ver) = 0 then /* CP/M-80 */ + if (lpp:=mon2(49,.pb)) = 0 then + lpp = 23; /* get lines per page from SCB */ + end; + call setdest; /* parse destination file */ + tail = false; /* parse$fcb from ED command */ + + /* SOURCE AND DESTINATION DISKS SET */ + + /* IF SOURCE AND DESTINATION DISKS DIFFER, CHECK FOR + AN EXISTING SOURCE FILE ON THE DESTINATION DISK - THERE + COULD BE A FATAL ERROR CONDITION WHICH COULD DESTROY A + FILE IF THE USER HAPPENED TO BE ADDRESSING THE WRONG + DISK */ + IF (SDISK <> DDISK) or not onefile THEN + IF mon2(15,.dfcb) <> 255 THEN /* try to open */ + /* SOURCE FILE PRESENT ON DEST DISK */ + CALL ABORT(.('Output File Exists, Erase It$')); + + + +RESTART: + CALL SETUP; + MEMORY(0) = LF; + FRONT = 1; BACK = MAXM; + COLUMN = 0; + GO TO START; + +OVERCOUNT: FLAG = POUND; GO TO RESET; + +BADCOM: FLAG = WHAT; GO TO RESET; + +OVERFLOW: /* ARRIVE HERE ON OVERFLOW CONDITION (I,F,S COMMAND) */ + FLAG = '>'; go to reset; + +disk$err: + flag = 'F'; + err$msg = .diskfull; + go to reset; + +dir$err: + flag = 'F'; + err$msg = .dirfull; + +RESET: /* ARRIVE HERE ON ERROR CONDITION */ + PRINTSUPPRESS = FALSE; + CALL PRINT(.(tab,'BREAK "$')); + CALL PRINTC(FLAG); + CALL PRINTM(.('" AT $')); + if char = CR or char = LF then + call printm(.('END OF LINE$')); + else + CALL PRINTC(CHAR); + if err$msg <> 0 then do; + call perror(err$msg); + err$msg = 0; + end; + CALL CRLF; + + +START: + READBUFF = TRUE; + MP = 0; + + + +$ eject + + DO FOREVER; /* OR UNTIL THE POWER IS TURNED OFF */ + + /* ************************************************************** + SIMPLE COMMANDS (CANNOT BE PRECEDED BY DIRECTION/DISTANCE): + E END THE EDIT NORMALLY + H MOVE TO HEAD OF EDITED FILE + I INSERT CHARACTERS + O RETURN TO THE ORIGINAL FILE + R READ FROM LIBRARY FILE + Q QUIT EDIT WITHOUT CHANGES TO ORIGINAL FILE + ************************************************************** */ + + + + INSERTING = FALSE; + CALL READCTRAN; + FLAG = 'E'; + MI = CBP; /* SAVE STARTING ADDRESS FOR COMMAND */ + IF SINGLECOM('E') THEN + DO; CALL TERMINATE; + CALL REBOOT; + END; + + ELSE IF SINGLECOM('H') THEN /* GO TO TOP */ + DO; CALL TERMINATE; + newfile = false; + if onefile then do; + /* PING - PONG DISKS */ + CHAR = DDISK; + DDISK = SDISK; + SDISK = CHAR; + end; + else do; + call settype(.dfcb,.dtype); + call move (16,.dfcb,.sfcb); /* source = destination */ + onefile = true; + end; + GO TO RESTART; + END; + + ELSE IF CHAR = 'I' THEN /* INSERT CHARACTERS */ + DO; + IF (INSERTING := (CBP = COMLEN) AND (MP = 0)) THEN do; + tcolumn = 255; /* tested in ins$error$chk routine */ + distance = 0; + direction = backward; + if memory(front-1) = LF then + call printbase; + else + call typelines; + end; + DO WHILE SCANNING; + DO WHILE CHAR <> 0; + IF CHAR=CTLU OR CHAR=CTLX OR CHAR=CTLR THEN + /* LINE DELETE OR RETYPE */ + DO; + /* ELIMINATE OR REPEAT THE LINE */ + IF CHAR = CTLR THEN + DO; CALL CRLF; + CALL TYPELINES; + END; + ELSE + /* LINE DELETE */ + DO; CALL SETLIMITS; CALL SETPTRS; + IF CHAR = CTLU THEN + DO; CALL CRLF; CALL PRINTNMBASE; + END; + ELSE + /* MUST BE CTLX */ + DO WHILE COLUMN > SCOLUMN; + CALL BACKSPACE; + END; + END; + END; + ELSE IF CHAR = CTLH THEN + DO; + call ins$error$chk; + IF (TCOLUMN := COLUMN) > 0 THEN + CALL PRINTNMAC(' '); /* RESTORE AFT BACKSP */ + call decfront; + if tcolumn > scolumn then + DO; /* CHARACTER CAN BE ELIMINATED */ + PRINTSUPPRESS = TRUE; + /* BACKSPACE CHARACTER ACCEPTED */ + COLUMN = 0; + CALL TYPELINES; + PRINTSUPPRESS = FALSE; + /* COLUMN POSITION NOW RESET */ + IF (QCOLUMN := COLUMN) < SCOLUMN THEN + QCOLUMN = SCOLUMN; + COLUMN = TCOLUMN; /* ORIGINAL VALUE */ + DO WHILE COLUMN > QCOLUMN; + CALL BACKSPACE; + END; + END; + else + do; + if memory(front-1) = CR then + call decfront; + call crlf; + call typelines; + end; + CHAR = 0; + END; + ELSE IF CHAR = RUBOUT THEN + DO; call ins$error$chk; + CALL DECFRONT; CALL PRINTC(CHAR:=MEMORY(FRONT)); + CHAR = 0; + END; + else if char = LF and memory(front-1) <> CR then + do; + call printc(CR); + call inscrlf; + end; + ELSE + /* NOT A SPECIAL CASE */ + DO; + IF NOT GRAPHIC(CHAR) THEN + DO; + CALL PRINTNMAC('^'); + CALL PRINTNMAC(CHAR + '@'); + end; + /* COLUMN COUNT GOES UP IF GRAPHIC */ + /* COMPUTE OUTPUT COLUMN POSITION */ + if char = CTLL and not inserting then + call inscrlf; + else do; + IF MP = 0 THEN + DO; + IF CHAR >= ' ' THEN + COLUMN = COLUMN + 1; + ELSE IF CHAR = TAB THEN + COLUMN = COLUMN + (8 - (COLUMN AND 111B)); + END; + CALL INSERT; + END; + end; + IF CHAR = LF THEN CALL PRINTNMBASE; + IF CHAR = CR THEN + CALL PRINTNMAC(CHAR:=LF); + ELSE + CHAR = 0; + tcolumn = 0; + END; /* of while char <> 0 */ + END; /* of while scanning */ + IF CHAR <> ENDFILE THEN do; /* MUST HAVE STOPPED ON CR */ + CALL INSCRLF; + column = 0; + end; + IF INSERTING AND LINESET THEN CALL CRLF; + END; + + + ELSE IF SINGLERCOM('O') THEN /* FORGET THIS EDIT */ + do; + call close(.sfcb); + GO TO RESTART; + end; + + + ELSE IF CHAR = 'R' THEN + DO; DECLARE I BYTE; + /* READ FROM LIB FILE */ + CALL SETRDMA; + IF (FLAG := parse$lib(.rfcb)) THEN + reading = false; + if not reading then do; + if not flag then + /* READ FROM XFER FILE */ + CALL MOVE(12,.XFCB,.RFCB); + RFCB(12), RFCB(32) = 0; /* zero extent, next record */ + rbp = sectsize; + CALL open(.RFCB); + reading = true; + end; + + DO WHILE (CHAR := READFILE) <> ENDFILE; + CALL INSERT; + END; + reading = false; + call close (.rfcb); + END; + + + ELSE IF SINGLERCOM('Q') THEN + DO; + CALL DELETE$file(.DFCB); + if newfile or not onefile then do; + call settype(.dfcb,.dtype); + call delete$file(.dfcb); + end; + CALL REBOOT; + END; + + + ELSE + /* MAY BE A COMMAND WHICH HAS AN OPTIONAL DIRECTION AND DISTANCE */ + DO; /* SCAN A SIGNED INTEGER VALUE (IF ANY) */ + DCL I BYTE; + + CALL SETFORWARD; + + IF CHAR = '-' THEN + DO; CALL READCTRAN; DIRECTION = BACKWARD; + END; + + IF CHAR = POUND THEN + DO; CALL SETFF; CALL READCTRAN; + END; + + ELSE IF DIGIT THEN + DO; CALL NUMBER; + /* MAY BE ABSOLUTE LINE REFERENCE */ + IF CHAR = ':' THEN + DO; CHAR = 'L'; + CALL RELDISTANCE; + END; + END; + + ELSE IF CHAR = ':' THEN /* LEADING COLON */ + DO; CALL READCTRAN; /* CLEAR THE COLON */ + CALL NUMBER; + CALL RELDISTANCE; + IF DIRECTION = FORWARD THEN + DISTANCE = DISTANCE + 1; + END; + + +$ eject + + IF DISTZERO THEN + DIRECTION = BACKWARD; + /* DIRECTION AND DISTANCE ARE NOW SET */ + + + /* ************************************************************** + MAY BE A COMMAND WHICH HAS DIRECTION AND DISTANCE SPECIFIED: + B BEGINNING/BOTTOM OF BUFFER + C MOVE CHARACTER POSITIONS + D DELETE CHARACTERS + K KILL LINES + L MOVE LINE POSITION + P PAGE UP OR DOWN (LPP LINES AND PRINT) + T TYPE LINES + U UPPER CASE TRANSLATE + V VERIFY LINE NUMBERS + MOVE UP OR DOWN LINES AND PRINT LINE + ************************************************************** */ + + + IF CHAR = 'B' THEN + DO; DIRECTION = 1 - DIRECTION; + FIRST = 1; LASTC = MAXM; CALL MOVER; + END; + + + ELSE IF CHAR = 'C' THEN + DO; CALL SETCLIMITS; CALL MOVER; + END; + + + ELSE IF CHAR = 'D' THEN + DO; CALL SETCLIMITS; + CALL SETPTRS; /* SETS BACK/FRONT */ + END; + + + ELSE IF CHAR = 'K' THEN + DO; CALL SETLIMITS; + CALL SETPTRS; + END; + + + ELSE IF CHAR = 'L' THEN + CALL MOVELINES; + + + ELSE IF CHAR = 'P' THEN /* PAGE MODE PRINT */ + DO; + IF DISTZERO THEN + DO; DIRECTION = FORWARD; + CALL SETLPP; CALL TYPELINES; + END; + ELSE + DO WHILE DISTNZERO; CALL PAGE; + CALL WAIT; + END; + END; + + + ELSE IF CHAR = 'T' THEN + CALL TYPELINES; + + + ELSE IF CHAR = 'U' THEN + UPPER = DIRECTION = FORWARD; + + + ELSE IF CHAR = 'V' THEN + DO; /* 0V DISPLAYS BUFFER STATE */ + IF DISTZERO THEN + DO; CALL PRINTVALUE(BACK-FRONT); + CALL PRINTC('/'); + CALL PRINTVALUE(MAXM); + CALL CRLF; + END; + ELSE if (LINESET := DIRECTION = FORWARD) then + scolumn = 8; + else + scolumn = 0; + END; + + + + ELSE IF CHAR = CR THEN /* MAY BE MOVE/TYPE COMMAND */ + DO; + IF MI = 1 AND MP = 0 THEN /* FIRST COMMAND */ + DO; CALL MOVELINES; CALL SETFORWARD; CALL TYPELINES; + END; + END; + + +$ eject + + ELSE IF DIRECTION = FORWARD OR DISTZERO THEN + DO; + + /* ************************************************************** + COMMANDS WHICH ALLOW ONLY A PRECEDING NUMBER: + A APPEND LINES + F FIND NTH OCCURRENCE + M APPLY MACRO + N SAME AS F WITH AUTOSCAN THROUGH FILE + S PERFORM N SUBSTITUTIONS + W WRITE LINES TO OUTPUT FILE + X TRANSFER (XFER) LINES TO TEMP FILE + Z SLEEP + ************************************************************** */ + + + + IF CHAR = 'A' THEN + DO; DIRECTION = FORWARD; + FIRST = FRONT; LASTC = MAXM; CALL MOVER; + /* ALL STORAGE FORWARD */ + IF DISTZERO THEN CALL APPHALF; + /* DISTANCE = 0 IF APPHALF CALLED */ + DO WHILE DISTNZERO; + CALL READLINE; + END; + DIRECTION = BACKWARD; CALL MOVER; + /* POINTERS REPOSITIONED */ + END; + + + ELSE IF CHAR = 'F' THEN + DO; CALL SETFIND; /* SEARCH STRING SCANNED + AND SETUP BETWEEN 0 AND WBP-1 IN SCRATCH */ + DO WHILE DISTNZERO; CALL CHKFOUND; + END; + END; + + + ELSE IF CHAR = 'J' THEN /* JUXTAPOSITION OPERATION */ + DO; DECLARE T ADDRESS; + CALL SETFIND; CALL COLLECT; + WBJ = WBE; CALL COLLECT; + /* SEARCH FOR STRING 0 - WBP-1, INSERT STRING WBP TO WBJ-1, + AND THEN DELETE UP TO STRING WBJ TO WBE-1 */ + DO WHILE DISTNZERO; CALL CHKFOUND; + /* INSERT STRING */ MI = WBP - 1; + DO WHILE (MI := MI + 1) < WBJ; + CHAR = SCRATCH(MI); CALL INSERT; + END; + T = FRONT; /* SAVE POSITION FOR DELETE */ + IF NOT FIND(WBJ,WBE) THEN GO TO OVERCOUNT; + /* STRING FOUND, SO MOVE IT BACK */ + FIRST = FRONT - (WBE - WBJ); + DIRECTION = BACKWARD; CALL MOVER; + /* NOW REMOVE THE INTERMEDIATE STRING */ + call setfront(t); + END; + END; + + + ELSE IF CHAR = 'M' AND MP = 0 THEN /* MACRO DEFINITION */ + DO; XP = 255; + IF DISTANCE = 1 THEN CALL ZERODIST; + DO WHILE (MACRO(XP := XP + 1) := READC) <> CR; + END; + MP = XP; XP = 0; MT = DISTANCE; + END; + + + ELSE IF CHAR = 'N' THEN + DO; /* SEARCH FOR STRING WITH AUTOSCAN */ + CALL SETFIND; /* SEARCH STRING SCANNED */ + DO WHILE DISTNZERO; + /* FIND ANOTHER OCCURRENCE OF STRING */ + DO WHILE NOT FIND(0,WBP); /* NOT IN BUFFER */ + IF BREAK$KEY THEN GO TO RESET; + CALL SAVEDIST; CALL CLEARMEM; + /* MEMORY BUFFER WRITTEN */ + CALL APPHALF; + DIRECTION = BACKWARD; FIRST = 1; CALL MOVER; + CALL RESTDIST; DIRECTION = FORWARD; + /* MAY BE END OF FILE */ + IF BACK >= MAXM THEN GO TO OVERCOUNT; + END; + END; + END; + + + ELSE IF CHAR = 'S' THEN /* SUBSTITUTE COMMAND */ + DO; CALL SETFIND; + CALL COLLECT; + /* FIND STRING FROM 0 TO WBP-1, SUBSTITUTE STRING + BETWEEN WBP AND WBE-1 IN SCRATCH */ + DO WHILE DISTNZERO; + CALL CHKFOUND; + /* FRONT AND BACK NOW POSITIONED AT FOUND + STRING - REPLACE IT */ + call setfront(FRONT - (MI := WBP)); /* BACKED UP */ + DO WHILE MI < WBE; + CHAR = SCRATCH(MI); + MI = MI + 1; CALL INSERT; + END; + END; + END; + + + ELSE IF CHAR = 'W' THEN + CALL WRITEOUT; + + + ELSE IF CHAR = 'X' THEN /* TRANSFER LINES */ + DO; + flag = parse$lib(.rfcb); + xbp = 0; + IF DISTZERO THEN + DO; /* delete the file */ + xferon = false; + CALL DELETE(.rfcb); + if dcnt = 255 then + call perror(.not$found); + END; + ELSE + do; /* transfer lines */ + declare i address; + + if xferon and compare$xfer then + call append$xfer; + else + DO; + XFERON = TRUE; + call move(12,.rfcb,.xfcb); + xfcbext, xfcbrec, xfcbe, xfcbr = 0; + CALL MAKE$file(.XFCB); + IF DCNT = 255 THEN + goto dir$err; + END; + CALL SETLIMITS; + DO I = FIRST TO LASTC; + CALL PUTXFER(MEMORY(I)); + END; + call close$xfer; + END; + END; + + + ELSE IF CHAR = 'Z' THEN /* SLEEP */ + DO; + IF DISTZERO THEN + DO; IF READCHAR = ENDFILE THEN GO TO RESET; + END; + DO WHILE DISTNZERO; CALL WAIT; + END; + END; + ELSE IF CHAR <> 0 THEN /* NOT BREAK LEFT OVER FROM STOP */ + /* DIRECTION FORWARD, BUT NOT ONE OF THE ABOVE */ + GO TO BADCOM; + + + END; + ELSE /* DIRECTION NOT FORWARD */ + GO TO BADCOM; + END; + END; +END; diff --git a/software/CPM/cpm3/erase.plm b/software/CPM/cpm3/erase.plm new file mode 100644 index 0000000..3a8e249 --- /dev/null +++ b/software/CPM/cpm3/erase.plm @@ -0,0 +1,824 @@ +$ TITLE('CP/M 3.0 --- ERA ') +/* contains the confirm option */ + +era: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 19 Jan 80 by Thomas Rolander + 14 Sept 81 by Doug Huskey + 23 June 82 by John Knight + 03 Dec 82 by Bruce Skidmore +*/ + +declare + true literally '1', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + lf literally '10', + ctrlc literally '3', + ctrlx literally '18h', + tab literally '9', + bksp literally '8', + cpmversion literally '30h', + dcnt$offset literally '45h', + searcha$offset literally '47h', + searchl$offset literally '49h', + hash1$offset literally '00h', + hash2$offset literally '02h', + hash3$offset literally '04h'; + + declare plm label public; + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + parse: + procedure (pfcb) address external; + declare pfcb address; + end parse; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + read$console: + procedure byte; + return mon2 (1,0); + end read$console; + + + printchar: + procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + + conin: + procedure byte; + return mon2(6,0fdh); + end conin; + + print$buf: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buf; + + + read$console$buf: + procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address address; + declare max byte; + new$max = max; + call mon1(10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of chars input */ + end read$console$buf; + + check$con$stat: + procedure byte; + return mon2 (11,0); + end check$con$stat; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + setdma: procedure(dma); + declare dma address; + call mon1(26,dma); + end setdma; + + search$first: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (17,fcb$address); + end search$first; + + search$next: + procedure byte; + return mon2 (18,0); + end search$next; + + delete$file: + procedure (fcb$address) address; + declare fcb$address address; + return mon3 (19,fcb$address); + end delete$file; + + get$user$code: + procedure byte; + return mon2 (32,0ffh); + end get$user$code; + + /* 0ff => return BDOS errors */ + return$errors: + procedure; + call mon1 (45,0ffh); + end return$errors; + + declare scbpd structure + (offset byte, + set byte, + value address); + + getscbword: + procedure (offset) address; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon3(49,.scbpd); + end getscbword; + + setscbword: + procedure (offset,value); + declare offset byte; + declare value address; + scbpd.offset = offset; + scbpd.set = 0FEh; + scbpd.value = value; + call mon1(49,.scbpd); + end setscbword; + + set$console$mode: procedure; + /* set console mode to ctrl-c only */ + call mon1(109,1); + end set$console$mode; + + declare + parse$fn structure ( + buff$adr address, + fcb$adr address); + + + /************************************** + * * + * GLOBAL VARIABLES * + * * + **************************************/ + + declare successful lit '0FFh'; + + declare dir$entry$adr address; + declare dir$entry based dir$entry$adr (1) byte; + declare confirm$opt byte initial (false); + declare passwd$opt byte initial (false); + declare save$passwd (8) byte; + declare (savdcnt,savsearcha,savsearchl) address; + declare (hash1,hash2,hash3) address; + + /* options scanner variables and data */ + declare + options(*) byte + data('PASSWORD0CONFIRM',0ffh), + + off$opt(*) byte data(0,9,16), + + end$list byte data (0ffh), + + delimiters(*) byte data (0,'[]=, ',0,0ffh), + + SPACE byte data(5), + + j byte initial(0), + buf$ptr address, + index byte, + endbuf byte, + delimiter byte; + + declare end$of$string byte initial('0'); + + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* * * * Option scanner * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr,idx$ptr); + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + idx$ptr address, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index based idx$ptr byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + /* No skip for ERA */ + do while ((delimiter < 1) or (delimiter > 6)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while ((delimiter := separator(charac)) = SPACE); + buf$ptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return; + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return; + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then + buf$ptr = buf$ptr + 1; + else + delimiter = 5; + return; + +end opt$scanner; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +break: procedure; + if check$con$stat then do; + call print$buf(.(cr,lf,'*** Aborted by ^C ***$')); + call mon1(0,0); + end; +end break; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* upper case character from console */ +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* fill string @ s for c bytes with f */ +fill: proc(s,f,c); + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* error message routine */ +error: proc(code); + declare + code byte; + + call printchar(' '); + if code=1 then + call print$buf(.(cr,lf,'Disk I/O $')); + if code=2 then + call print$buf(.(cr,lf,'Drive $')); + if code = 3 or code = 2 then + call print$buf(.('Read Only$')); + if code = 5 then + call print$buf(.('Currently Opened$')); + if code = 7 then + call print$buf(.('Password Error$')); + if code < 3 then + call mon1(0,0); + end error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* try to delete fcb at fcb$address + return error code if unsuccessful */ + delete: + procedure(fcb$address) byte; + declare + fcb$address address, + fcbv based fcb$address (32) byte, + error$code address, + code byte; + + if passwd$opt then + fcbv(5) = fcbv(5) or 80h; + call setdma(.save$passwd(0)); /* password */ + fcbv(0) = fcb(0); /* drive */ + error$code = delete$file(fcb$address); + fcbv(5) = fcbv(5) and 7fh; /* reset xfcb bit */ + if low(error$code) = 0FFh then do; + code = high(error$code); + if (code=1) or (code=2) then + call error(code); + return code; + end; + return successful; + end delete; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* upper case character from console */ +ucase: proc byte; + dcl c byte; + + if (c:=conin) >= 'a' then + if c < '{' then + return(c-20h); + return c; + end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* get password and place at fcb + 16 */ +getpasswd: proc; + dcl (i,c) byte; + + call print$buf(.('Password: ','$')); +retry: + call fill(.save$passwd(0),' ',8); + do i = 0 to 7; +nxtchr: + if (c:=ucase) >= ' ' then + save$passwd(i)=c; + if c = cr then + go to exit; + if c = ctrlx then + goto retry; + if c = bksp then do; + if i<1 then + goto retry; + else do; + save$passwd(i:=i-1)=' '; + goto nxtchr; + end; + end; + if c = 3 then + call mon1(0,0); + end; +exit: + c = check$con$stat; /* clear raw I/O mode */ + end getpasswd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* error on deleting a file */ + file$err: procedure(code); + declare code byte; + + if not confirm$opt then do; /* print file */ + call printchar('A'+fcb(0)-1); + call printchar(':'); + call printchar(' '); + do k=1 to 11; + if k=9 then + call printchar('.'); + call printchar(dir$entry(k)); + end; + call print$buf(.(' $')); + end; + call print$buf(.('Not erased, $')); + call error(code); + call crlf; + end file$err; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +erase: procedure; + if (code:=delete(.fcb)) <> successful then do; + if code < 3 then + call error(code); + else if code = 7 then do; + call file$err(code); + call getpasswd; + call crlf; + code = delete(.fcb); + end; + if code <> successful then + call file$err(code); + end; +end erase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + parse$options: procedure; + declare + t address, + char based t byte, + i byte; + + delimiter = 1; + index = 0; + do while ((delimiter <> 0) and (delimiter <> 2) and (delimiter <> 6)); + call opt$scanner(.options(0),.off$opt(0),.index); + if index = 0 then do; + /* unrecognized option */ + call print$buf(.(cr,lf,'ERROR: Missing Delimiter or$')); + call print$buf(.(cr,lf,' Unrecognized Option $')); + call print$buf(.('Near: $')); + t = buf$ptr - endbuf - 1; + do i = 1 to endbuf; + call printchar(char); + t = t + 1; + end; + call mon1(0,0); + end; + if index = 1 then + passwd$opt = true; + if index = 2 then + confirm$opt = true; + end; + end parse$options; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = tab); + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + + /************************************** + * * + * M A I N P R O G R A M * + * * + **************************************/ + +declare (i,k,code,response,user,dcnt) byte; +declare status address; +declare char$count byte; +declare last$dseg$byte byte + initial (0); +declare no$chars byte; +declare m based status byte; + +plm: + do; + if (low(version) < cpmversion) or (high(version) = 1) then do; + call print$buf(.('Requires CP/M 3.0 $')); + call mon1(0,0); + end; + call set$console$mode; + if not input$found(.tbuff(1)) then do; + /* prompt for file */ + confirm$opt = true; /* confirm, unless otherwise specified */ + call print$buf(.('Enter filename: $')); + no$chars = read$console$buf(.tbuff(0),40); + char$count = no$chars + 2; + call print$buf(.(cr,lf,'$')); + tbuff(1) = ' '; /* blank out nc field */ + tbuff(char$count) = 00h; /* eoln marker set */ + /* convert input string to upper case */ + do i = 1 to char$count; + if tbuff(i+1) >= 'a' then + if tbuff(i+1) < '}' then + tbuff(i+1) = tbuff(i+1) - 20h; + end; + end; + parse$fn.buff$adr = .tbuff(1); + parse$fn.fcb$adr = .fcb; + status = parse(.parse$fn); + if status = 0FFFFh then do; + call print$buf(.('ERROR: Invalid file name $')); + call mon1(0,0); + end; + if status <> 0 then do; /* options must follow */ + do while m = ' '; + status = status + 1; /* skip over blank delimiters */ + end; + buf$ptr = status + 1; /* skip first delimiter */ + call parse$options; + end; + if fcb(0) = 0 then + fcb(0) = low (mon2 (25,0)) + 1; + user = get$user$code; + call return$errors; + call move(8,.fcb16,.save$passwd(0)); + if not confirm$opt then do; + i = 0; + do while fcb(i:=i+1) = '?'; + end; + if i > 11 then + if not passwd$opt then do; + call print$buf(.('Confirm delete all user files (Y/N)?$')); + response = read$console; + if not ((response = 'y') or (response = 'Y')) then + call mon1(0,0); + call crlf; + end; + end; + call move(16,.fcb,.fcb16); + call setdma(.tbuff); + dcnt = search$first (.fcb16); + if dcnt = 0FFh then do; + call print$buf(.('No File $')); + call mon1(0,0); + end; + do while dcnt <> 0ffh; + dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b); + savdcnt = getscbword(dcnt$offset); + savsearcha = getscbword(searcha$offset); + savsearchl = getscbword(searchl$offset); + /* save searched fcb's hash code (5 bytes) */ + hash1 = getscbword(hash1$offset); + hash2 = getscbword(hash2$offset); + hash3 = getscbword(hash3$offset); + if confirm$opt then do; + if dir$entry(0) = user then do; + call printchar ('A'+fcb(0)-1); + call printchar (':'); + call printchar (' '); + do k = 1 to 11; + if k = 9 + then call printchar ('.'); + call printchar (dir$entry(k)); + end; + call print$buf(.(' (Y/N)? $')); + response = read$console; + call printchar (cr); + call printchar (lf); + if response = ctrlc then do; + call print$buf(.(cr,lf,'*** Aborted by ^C ***$')); + call mon1(0,0); + end; + if (response = 'y') or + (response = 'Y') then do; + call move (12,.dir$entry(1),.fcb(1)); + call erase; + end; + end; + end; + else do; /* not confirm option */ + call move(12,.dir$entry(1),.fcb(1)); + call break; + call erase; + end; + call setdma(.tbuff); + call setscbword(dcnt$offset,savdcnt); + call setscbword(searcha$offset,savsearcha); + call setscbword(searchl$offset,savsearchl); + /* restore hash code */ + call setscbword(hash1$offset,hash1); + call setscbword(hash2$offset,hash2); + call setscbword(hash3$offset,hash3); + if .fcb16 <> savsearcha then /* restore search fcb if destroyed */ + call move(16,.fcb16,savsearcha); + dcnt = search$next; + end; + call mon1(0,0); + end; +end era; diff --git a/software/CPM/cpm3/fcb.lit b/software/CPM/cpm3/fcb.lit new file mode 100644 index 0000000..1dc8e81 --- /dev/null +++ b/software/CPM/cpm3/fcb.lit @@ -0,0 +1,21 @@ + +declare + f$drvusr lit '0', /* drive/user byte */ + f$name lit '1', /* file name */ + f$namelen lit '8', /* file name length */ + f$type lit '9', /* file type field */ + f$typelen lit '3', /* type length */ + f$rw lit '9', /* high bit is R/W attribute */ + f$dirsys lit '10', /* high bit is dir/sys attribute */ + f$arc lit '11', /* high bit is archive attribute */ + f$ex lit '12', /* extent */ + f$s1 lit '13', /* module byte */ + f$rc lit '15', /* record count */ + f$diskmap lit '16', /* file disk map */ + diskmaplen lit '16', /* disk map length */ + f$drvusr2 lit '16', /* fcb2 */ + f$name2 lit '17', + f$type2 lit '25', + f$rrec lit '33', /* random record */ + f$rreco lit '35'; /* " " overflow */ + diff --git a/software/CPM/cpm3/fd1797sd.asm b/software/CPM/cpm3/fd1797sd.asm new file mode 100644 index 0000000..fddc9fd --- /dev/null +++ b/software/CPM/cpm3/fd1797sd.asm @@ -0,0 +1,384 @@ + title 'wd1797 w/ Z80 DMA Single density diskette handler' + +; CP/M-80 Version 3 -- Modular BIOS + +; Disk I/O Module for wd1797 based diskette systems + + ; Initial version 0.01, + ; Single density floppy only. - jrp, 4 Aug 82 + + dseg + + ; Disk drive dispatching tables for linked BIOS + + public fdsd0,fdsd1 + + ; Variables containing parameters passed by BDOS + + extrn @adrv,@rdrv + extrn @dma,@trk,@sect + extrn @dbnk + + ; System Control Block variables + + extrn @ermde ; BDOS error mode + + ; Utility routines in standard BIOS + + extrn ?wboot ; warm boot vector + extrn ?pmsg ; print message @ up to 00, saves & + extrn ?pdec ; print binary number in from 0 to 99. + extrn ?pderr ; print BIOS disk error header + extrn ?conin,?cono ; con in and out + extrn ?const ; get console status + + + ; Port Address Equates + + maclib ports + + ; CP/M 3 Disk definition macros + + maclib cpm3 + + ; Z80 macro library instruction definitions + + maclib z80 + + ; common control characters + +cr equ 13 +lf equ 10 +bell equ 7 + + + ; Extended Disk Parameter Headers (XPDHs) + + dw fd$write + dw fd$read + dw fd$login + dw fd$init0 + db 0,0 ; relative drive zero +fdsd0 dph trans,dpbsd,16,31 + + dw fd$write + dw fd$read + dw fd$login + dw fd$init1 + db 1,0 ; relative drive one +fdsd1 dph trans,dpbsd,16,31 + + cseg ; DPB must be resident + +dpbsd dpb 128,26,77,1024,64,2 + + dseg ; rest is banked + +trans skew 26,6,1 + + + + ; Disk I/O routines for standardized BIOS interface + +; Initialization entry point. + +; called for first time initialization. + + +fd$init0: + lxi h,init$table +fd$init$next: + mov a,m ! ora a ! rz + mov b,a ! inx h ! mov c,m ! inx h + outir + jmp fd$init$next + +fd$init1: ; all initialization done by drive 0 + ret + +init$table db 4,p$zpio$1A + db 11001111b, 11000010b, 00010111b,11111111b + db 4,p$zpio$1B + db 11001111b, 11011101b, 00010111b,11111111b + db 0 + + +fd$login: + ; This entry is called when a logical drive is about to + ; be logged into for the purpose of density determination. + + ; It may adjust the parameters contained in the disk + ; parameter header pointed at by + + ret ; we have nothing to do in + ; simple single density only environment. + + +; disk READ and WRITE entry points. + + ; these entries are called with the following arguments: + + ; relative drive number in @rdrv (8 bits) + ; absolute drive number in @adrv (8 bits) + ; disk transfer address in @dma (16 bits) + ; disk transfer bank in @dbnk (8 bits) + ; disk track address in @trk (16 bits) + ; disk sector address in @sect (16 bits) + ; pointer to XDPH in + + ; they transfer the appropriate data, perform retries + ; if necessary, then return an error code in + +fd$read: + lxi h,read$msg ; point at " Read " + mvi a,88h ! mvi b,01h ; 1797 read + Z80DMA direction + jmp rw$common + +fd$write: + lxi h,write$msg ; point at " Write " + mvi a,0A8h ! mvi b,05h ; 1797 write + Z80DMA direction + ; jmp wr$common + +rw$common: ; seek to correct track (if necessary), + ; initialize DMA controller, + ; and issue 1797 command. + + shld operation$name ; save message for errors + sta disk$command ; save 1797 command + mov a,b ! sta zdma$direction ; save Z80DMA direction code + lhld @dma ! shld zdma$dma ; get and save DMA address + lda @rdrv ! mov l,a ! mvi h,0 ; get controller-relative disk drive + lxi d,select$table ! dad d ; point to select mask for drive + mov a,m ! sta select$mask ; get select mask and save it + out p$select ; select drive +more$retries: + mvi c,10 ; allow 10 retries +retry$operation: + push b ; save retry counter + + lda select$mask ! lxi h,old$select ! cmp m + mov m,a + jnz new$track ; if not same drive as last, seek + + lda @trk ! lxi h,old$track ! cmp m + mov m,a + jnz new$track ; if not same track, then seek + + in p$fdmisc ! ani 2 ! jnz same$track ; head still loaded, we are OK + +new$track: ; or drive or unloaded head means we should . . . + call check$seek ; . . read address and seek if wrong track + + lxi b,16667 ; 100 ms / (24 t states*250 ns) +spin$loop: ; wait for head/seek settling + dcx b + mov a,b ! ora c + jnz spin$loop + +same$track: + lda @trk ! out p$fdtrack ; give 1797 track + lda @sect ! out p$fdsector ; and sector + + lxi h,dma$block ; point to dma command block + lxi b,dmab$length*256 + p$zdma ; command block length and port address + outir ; send commands to Z80 DMA + + in p$bankselect ; get old value of bank select port + ani 3Fh ! mov b,a ; mask off DMA bank and save + lda @dbnk ! rrc ! rrc ; get DMA bank to 2 hi-order bits + ani 0C0h ! ora b ; merge with other bank stuff + out p$bankselect ; and select the correct DMA bank + + lda disk$command ; get 1797 command + call exec$command ; start it then wait for IREQ and read status + sta disk$status ; save status for error messages + + pop b ; recover retry counter + ora a ! rz ; check status and return to BDOS if no error + + ani 0001$0000b ; see if record not found error + cnz check$seek ; if a record not found, we might need to seek + + dcr c ! jnz retry$operation + + ; suppress error message if BDOS is returning errors to application... + + lda @ermde ! cpi 0FFh ! jz hard$error + + ; Had permanent error, print message like: + + ; BIOS Err on d: T-nn, S-mm, , Retry ? + + call ?pderr ; print message header + + lhld operation$name ! call ?pmsg ; last function + + ; then, messages for all indicated error bits + + lda disk$status ; get status byte from last error + lxi h,error$table ; point at table of message addresses +errm1: + mov e,m ! inx h ! mov d,m ! inx h ; get next message address + add a ! push psw ; shift left and push residual bits with status + xchg ! cc ?pmsg ! xchg ; print message, saving table pointer + pop psw ! jnz errm1 ; if any more bits left, continue + + lxi h,error$msg ! call ?pmsg ; print ", Retry (Y/N) ? " + call u$conin$echo ; get operator response + cpi 'Y' ! jz more$retries ; Yes, then retry 10 more times +hard$error: ; otherwise, + mvi a,1 ! ret ; return hard error to BDOS + +cancel: ; here to abort job + jmp ?wboot ; leap directly to warmstart vector + + + ; subroutine to seek if on wrong track + ; called both to set up new track or drive + +check$seek: + push b ; save error counter + call read$id ; try to read ID, put track in + jz id$ok ; if OK, we're OK + call step$out ; else step towards Trk 0 + call read$id ; and try again + jz id$ok ; if OK, we're OK + call restore ; else, restore the drive + mvi b,0 ; and make like we are at track 0 +id$ok: + mov a,b ! out p$fdtrack ; send current track to track port + lda @trk ! cmp b ! pop b ! rz ; if its desired track, we are done + out p$fddata ; else, desired track to data port + mvi a,00011010b ; seek w/ 10 ms. steps + jmp exec$command + + + +step$out: + mvi a,01101010b ; step out once at 10 ms. + jmp exec$command + +restore: + mvi a,00001011b ; restore at 15 ms + ; jmp exec$command + + +exec$command: ; issue 1797 command, and wait for IREQ + ; return status + out p$fdcmnd ; send 1797 command +wait$IREQ: ; spin til IREQ + in p$fdint ! ani 40h ! jz wait$IREQ + in p$fdstat ; get 1797 status and clear IREQ + ret + +read$id: + lxi h,read$id$block ; set up DMA controller + lxi b,length$id$dmab*256 + p$zdma ; for READ ADDRESS operation + outir + mvi a,11000100b ; issue 1797 read address command + call exec$command ; wait for IREQ and read status + ani 10011101b ; mask status + lxi h,id$buffer ! mov b,m ; get actual track number in + ret ; and return with Z flag true for OK + + +u$conin$echo: ; get console input, echo it, and shift to upper case + call ?const ! ora a ! jz u$c1 ; see if any char already struck + call ?conin ! jmp u$conin$echo ; yes, eat it and try again +u$c1: + call ?conin ! push psw + mov c,a ! call ?cono + pop psw ! cpi 'a' ! rc + sui 'a'-'A' ; make upper case + ret + + +disk$command ds 1 ; current wd1797 command +select$mask ds 1 ; current drive select code +old$select ds 1 ; last drive selected +old$track ds 1 ; last track seeked to + +disk$status ds 1 ; last error status code for messages + +select$table db 0001$0000b,0010$0000b ; for now use drives C and D + + + ; error message components + +read$msg db ', Read',0 +write$msg db ', Write',0 + +operation$name dw read$msg + + ; table of pointers to error message strings + ; first entry is for bit 7 of 1797 status byte + +error$table dw b7$msg + dw b6$msg + dw b5$msg + dw b4$msg + dw b3$msg + dw b2$msg + dw b1$msg + dw b0$msg + +b7$msg db ' Not ready,',0 +b6$msg db ' Protect,',0 +b5$msg db ' Fault,',0 +b4$msg db ' Record not found,',0 +b3$msg db ' CRC,',0 +b2$msg db ' Lost data,',0 +b1$msg db ' DREQ,',0 +b0$msg db ' Busy,',0 + +error$msg db ' Retry (Y/N) ? ',0 + + + + ; command string for Z80DMA device for normal operation + +dma$block db 0C3h ; reset DMA channel + db 14h ; channel A is incrementing memory + db 28h ; channel B is fixed port address + db 8Ah ; RDY is high, CE/ only, stop on EOB + db 79h ; program all of ch. A, xfer B->A (temp) +zdma$dma ds 2 ; starting DMA address + dw 128-1 ; 128 byte sectors in SD + db 85h ; xfer byte at a time, ch B is 8 bit address + db p$fddata ; ch B port address (1797 data port) + db 0CFh ; load B as source register + db 05h ; xfer A->B + db 0CFh ; load A as source register +zdma$direction ds 1 ; either A->B or B->A + db 0CFh ; load final source register + db 87h ; enable DMA channel +dmab$length equ $-dma$block + + + +read$id$block db 0C3h ; reset DMA channel + db 14h ; channel A is incrementing memory + db 28h ; channel B is fixed port address + db 8Ah ; RDY is high, CE/ only, stop on EOB + db 7Dh ; program all of ch. A, xfer A->B (temp) + dw id$buffer ; starting DMA address + dw 6-1 ; Read ID always xfers 6 bytes + db 85h ; byte xfer, ch B is 8 bit address + db p$fddata ; ch B port address (1797 data port) + db 0CFh ; load dest (currently source) register + db 01h ; xfer B->A + db 0CFh ; load source register + db 87h ; enable DMA channel +length$id$dmab equ $-read$id$block + + cseg ; easier to put ID buffer in common + +id$buffer ds 6 ; buffer to hold ID field + ; track + ; side + ; sector + ; length + ; CRC 1 + ; CRC 2 + + end diff --git a/software/CPM/cpm3/finfo.lit b/software/CPM/cpm3/finfo.lit new file mode 100644 index 0000000..be3e302 --- /dev/null +++ b/software/CPM/cpm3/finfo.lit @@ -0,0 +1,15 @@ + +/* file info record for SDIR - note if this structure changes in size */ +/* the multXX: routine in the sort.plm module must also change */ + +declare + f$info$structure lit 'structure( + usr byte, name (8) byte, type (3) byte, onekblocks address, + kbytes address, recs$lword address, recs$hbyte byte, + hash$link address, x$i$adr address)'; +declare + x$info$structure lit 'structure ( + create (4) byte, + update (4) byte, + passmode byte)'; + diff --git a/software/CPM/cpm3/format.lit b/software/CPM/cpm3/format.lit new file mode 100644 index 0000000..e2fa6dd --- /dev/null +++ b/software/CPM/cpm3/format.lit @@ -0,0 +1,5 @@ + +dcl form$short lit '0', /* format values for SDIR */ + form$size lit '1', + form$full lit '2'; + diff --git a/software/CPM/cpm3/gencom.plm b/software/CPM/cpm3/gencom.plm new file mode 100644 index 0000000..9e6fb59 --- /dev/null +++ b/software/CPM/cpm3/gencom.plm @@ -0,0 +1,1999 @@ +$ TITLE('CPM 3.0 --- GENCOM 1.0') +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * GENCOM * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +gencomer: +do; + + +declare + mpmproduct literally '01h', /* requires mp/m */ + cpmversion literally '30h'; /* requires 3.0 cp/m */ + + +declare plm label public; + +declare copyright (*) byte data ( + ' Copyright (c) 1982, Digital Research '); + +declare version (*) byte data('11/02/82'); + +/* + Digital Research + Box 579 + Pacific Grove, Ca + 93950 +*/ +$ eject +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * CP/M INTERFACE * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +declare + maxb address external, /* addr field of jmp BDOS */ + fcb (33) byte external, /* default file control block */ + fcb16(33) byte external, /* default fcb 2 */ + buff(128) byte external, /* default buffer */ + buffa literally '.buff', /* default buffer */ + fcba literally '.fcb', /* default file control block */ + + cr literally '13', + lf literally '10'; + + /* reset drive mask */ + declare reset$mask (16) address data ( + 0000000000000001b, + 0000000000000010b, + 0000000000000100b, + 0000000000001000b, + 0000000000010000b, + 0000000000100000b, + 0000000001000000b, + 0000000010000000b, + 0000000100000000b, + 0000001000000000b, + 0000010000000000b, + 0000100000000000b, + 0001000000000000b, + 0010000000000000b, + 0100000000000000b, + 1000000000000000b ); + +mon1: procedure(f,a) external; + declare f byte, a address; + end mon1; + +mon2: procedure(f,a) byte external; + declare f byte, a address; + end mon2; + +declare mon3 literally 'mon2a'; + +mon3: procedure(f,a) address external; + declare f byte, a address; + end mon3; + + /********** SYSTEM FUNCTION CALLS *********************/ + +printchar: procedure(char); + declare char byte; + call mon1(2,char); +end printchar; + +printb: procedure; + /* print blank character */ + call printchar(' '); +end printb; + +printx: procedure(a); + declare a address; + declare s based a byte; + do while s <> 0; + call printchar(s); + a = a + 1; + end; +end printx; + +check$con$stat: procedure byte; + return mon2(11,0); /* console ready */ +end check$con$stat; + +crlf: procedure; + call printchar(cr); + call printchar(lf); + if check$con$stat then do; + call mon1 (1,0); /* read character */ + call mon1 (0,0); /* system reset */ + end; +end crlf; + +print: procedure(a); + declare a address; + /* print the string starting at address a until the + next 0 is encountered */ + call crlf; + call printx(a); +end print; + +get$version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); +end get$version; + + +conin: procedure byte; + return mon2(6,0fdh); +end conin; + + +open: procedure(fcb) byte; + declare fcb address; + return mon2(15,fcb); +end open; + +close: procedure(fcb) byte; + declare fcb address; + return mon2(16,fcb); +end close; + +make: procedure(fcb) byte; + declare fcb address; + return mon2(22,fcb); +end make; + + declare ioflag address, + nrecs byte; + +mread: procedure(fcb); /* multi sector read - returns # recs*/ + declare fcb address; + + ioflag = mon3(20,fcb); + readflag = low(ioflag); /* if = 255 then error */ + nrecs = high(ioflag); /* if 0 -> multi sector count */ + +end mread; + + +setmulti: procedure(nsects); /* set multi sector count */ + declare nsects byte; + + flag = mon2(44,nsects); + +end setmulti; + + +readsq: procedure(fcb) byte; + declare fcb address; + return mon2(20,fcb); +end readsq; + +writesq: procedure(fcb) byte; + declare fcb address; + return mon2(21,fcb); +end writesq; + +rename: procedure(fcb) byte; + declare fcb address; + return mon2(23,fcb); +end rename; + +delete: procedure(fcb) byte; + declare fcb address; + return mon2(19,fcb); +end delete; + +setdma: procedure(dma); + declare dma address; + call mon1(26,dma); +end setdma; + +return$errors: /* 0ff => return BDOS errors */ + procedure(mode); + declare mode byte; + call mon1 (45,mode); +end return$errors; + +/******************************************************/ + +terminate: procedure; + call crlf; + call mon1 (0,0); +end terminate; + +parse: procedure(pfcb) address external; + declare pfcb address; + +end parse; + +$eject + + declare + + options(*) byte data + ('NULL0LOADER0SCB',0FFH), + off$opt(*) byte data(0,5,12,15), + end$list byte data (0ffh), + end$of$string byte data (0), + + delimiters(*) byte data (0,'[]=, :;<>%\|"()/#!@&+-*?',0,0ffh), + SPACE byte data(5), /* delim space */ + COMMA byte data(4), /* " comma */ + LPAREN byte data(14), /* " left paren */ + + opt$map(23) byte, + + j byte initial(0), + buf$ptr address, + opt$index byte, + endbuf byte, + delimiter byte; +$ eject + + + declare + true literally '1', + false literally '0', + punchSCB byte initial (false), + COMonly byte initial (false), + revert byte initial (false), + build byte initial (false), + replace byte initial (false), + empty byte initial (false), + hex byte initial (false), + + oldSCB byte initial (false), + + incount byte initial (0), + ret$inst byte data (0c9h), + BLANK byte data (020h), + (readflag,writeflag) byte, + flag byte, + (rsx,old,fill) byte, + maxrcd byte data(32), + + deletes byte, + which(15) byte, + + comoff address, + comsize address, + totbyte address, + rsxrec address, + oldrsx address, + offsets(15) address, + length$rsx(15) address, + testvers address, + + comtype(3) byte data ('COM'), + hextype(3) byte data ('HEX'), + rsxtype(3) byte data ('RSX'), + + tempfcb(33) byte initial(0,'TEMP $$$',0,0,0,0,0), + errfcb(14) byte, + + files(16) structure ( pass(8) byte), + len$pass(16) byte, + + parse$struc structure( + name$addr address, + fcb$addr address), + + optmark based buf$ptr byte, + NULL byte initial(0), + LOAD byte initial(0), + SCB byte initial(0), + + fcbs(16) structure( + file(33) byte), + + test$ptr address, + allfcbs(16) address, + fcbp address, + comptr address, + comfcb based comptr (1) byte, + testfcb based test$ptr (1) byte, + gen$fcb based fcbp (1) byte; + +/* RSX COM FILE HEADER FORMAT */ + + declare + head$ptr address, + head based head$ptr structure( + retinst byte, /* return instruction 0C9h */ + progsize address,/* program size:orig com prog */ + SCBjmp byte, + SCBaddr address, + RESERVED2(7) byte, + LOADER byte, + nscb byte, + nrsx byte); /* number of RSX modules in file */ + + declare + subptr address, + rsx$sub$head based subptr structure( + off address, + len address, + NONBANK byte, + RESERVED3 byte, + name(8) byte, + RESERVED4 address), + + scbvect based subptr structure( + pad1 byte, + smark byte, + pad2 address, + svect(12) byte), + + head$byte based head$ptr byte, + + head$buffer(384) byte, + iobuff(4096) byte, + + nextptr address, + next based nextptr structure( + off address, + len address, + NONBANK byte, + RESERVED3 byte, + name(8) byte, + RESERVED4 address), + + nbank(16) byte initial(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0), + newoff(16) address, + newlen(16) address, + actlen(15) address, + new(15) structure( + name(8) byte), + + soff(20) byte, + sval(20) byte, + nscbs byte initial(0); + + declare + SCBbuff(256) byte, + SCBcode(23) byte data(011h,018h,00,0d5h,0eh,031h,0cdh,5,0, + 0e1h,23h,23h,23h,7eh,0feh, + 0ffh,0e5h,0ebh,0c2h,4,0,0e1h,0c9h), + SCBpos address; +$eject + + declare + ERRORM(*) byte data ('ERROR: ',0), + FILEM(*) byte data ('FILE: ',0), + err$notfnd(*) byte data ('File not found.',0), + err$msg$make(*) byte data ('No directory space.',0), + err$msg$parse(*) byte data ('Invalid file name.',0), + err$msg$first(*) byte data ('First submitted file must be + + a COM file.',0), + err$msg$dup1(*) byte data ('Duplicate input RSX...',0), + err$msg$dup2(*) byte data ('Duplicate RSX in header.', + ' Replacing old by new.',0), + + err$msg$rsxval(*) byte data ('Invalid RSX type.',0), + err$msg$no$rsx(*) byte data ('No more RSX files to be used + +.',0), + err$msg$copy(*) byte data ('Error on copy.',0), + err$msg$rsx$slot(*) byte data ('There are not enough availab + +le RSX slots.',0), + err$msg$read(*) byte data ('Disk read.',0), + err$msg$write(*) byte data ('Disk write.',0), + err$msg$toobig(*) byte data ('Total file size exceeds 64K. + +',0), + err$NULL(*) byte data ('COM file found and NULL option.',0), + + errSTRIP(*) byte data ('No header or RSXs to strip.',0), + + errIFCB(*) byte data ('Invalid FCB.',0), + errMEDIA(*) byte data ('Media change occurred.',0), + errDIO(*) byte data ('Disk I/O error.',0), + errDRIVE(*) byte data ('Invalid drive error.',0), + + errscboff(*) byte data ('Invalid SCB offset',0), + errscbclose(*) byte data('Missing right parenthesis.',0), + errscbnoval(*) byte data ('Missing SCB value.',0), + errscbpar(*) byte data ('Missing left parenthesis.',0), + err$unrecopt(*) byte data ('Unrecognized option.',0), + err$notscb(*) byte data ('No modifier for this option.',0); + + + +closeall: procedure; + declare i byte; + + do i = 0 to incount; + readflag = close(allfcbs(i)); /* close input files */ + end; + readflag = close(.tempfcb); + readflag = delete(.tempfcb); + +end closeall; + +get$errfcb: procedure; + declare (i,j) byte; + + do i = 1 to 14; + errfcb(i) = 0; + end; + errfcb(0) = 9; /* tab */ + + i = 1; + j = 1; + do while i < 9 and gen$fcb(j) <> 32; /* 32 = space */ + errfcb(i) = gen$fcb(j); + i = i + 1; + j = j + 1; + end; + +ge1: errfcb(i) = 46; /* dot */ + j = 9; + do while i < 12 and gen$fcb(j) <> 32; + i = i + 1; + errfcb(i) = gen$fcb(j); + j = j + 1; + end; +end get$errfcb; + + +e$print1: procedure(message); + declare message address; + + call get$errfcb; + call print(.ERRORM); + call printx(message); + +end e$print1; + +e$print2: procedure; + + call print(.FILEM); + call printx(.errfcb); + call crlf; + +end e$print2; + + +err$print: procedure(message); + declare message address; + + call e$print1(message); + call e$print2; + + call closeall; + call terminate; + +end err$print; + + + +bdoserr: procedure; + declare (lflag,hflag) byte; + + lflag = low(ioflag); + hflag = high(ioflag); + + if lflag = 9 then call err$print(.errIFCB); + if lflag = 10 then call err$print(.errMEDIA); + if lflag = 255 then do; + if hflag = 1 then call err$print(.errDIO); + if hflag = 4 then call err$print(.errDRIVE); + end; + +end bdoserr; +$ eject + + +$eject +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr,idx$ptr); + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + idx$ptr address, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index based idx$ptr byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5) + and (delimiter <> 25)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while(delimiter := separator(charac)) = SPACE; + bufptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return; + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return; + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then buf$ptr = buf$ptr + 1; + else delimiter = SPACE; + +end opt$scanner; + +error$prt: procedure; + declare i byte, + t address, + char based t byte; + + t = buf$ptr - endbuf - 1; + do i = 1 to endbuf; + call printchar(char); + t = t + 1; + end; + +end error$prt; + +$eject + +e$print3: procedure(message); + + declare message address; + + call print(.ERRORM); + call printx(message); + call terminate; + +end e$print3; + + +aschex: procedure(ahbyte,albyte) byte; + + declare (ahbyte,albyte) address, + hbyte based ahbyte byte, + lbyte based albyte byte; + + conv: procedure(abyte); + declare abyte address, + b based abyte byte; + + if b > 39h then b = b - 37h; + else b = b - 30h; + + end conv; + + call conv(ahbyte); + call conv(albyte); + hbyte = shl(hbyte,4); + + return(hbyte or lbyte); + +end aschex; + +/**************************************************************************/ + +valoff: procedure(high,low,achar); + declare (high,low) byte, + achar address, + char based achar byte; + + if (char > high) or (char < low) then + call e$print3(.errscboff); + +end valoff; + +/**************************************************************************/ + +/**************************************************************************/ + +getoption: procedure; + + declare char based buf$ptr byte, + bufptr1 address, + nextchar based bufptr1 byte, + index byte, + zero byte; + + /************************************************/ + +getscbval: procedure; + + bufptr1 = buf$ptr + 1; + + if (delimiter := separator(nextchar)) = 0 then do; + sval(nscbs) = aschex(buf$ptr,buf$ptr1); /* 2 chars */ + buf$ptr = buf$ptr + 2; + end; + else do; + sval(nscbs) = aschex(.zero,buf$ptr); /* 1 char */ + buf$ptr = bufptr1; + end; + + nscbs = nscbs + 1; + + if (delimiter := separator(char)) <> 15 then /* ) */ + call e$print3(.errscbclose); + + buf$ptr = buf$ptr + 1; + + delimiter = separator(char); /* set delimiter */ + if delimiter <> 0 then buf$ptr = buf$ptr + 1; + +end getscbval; + + /******************************************************/ + +checkval: procedure; + + delimiter = separator(char); + if delimiter = SPACE then go to cv0; + if delimiter <> COMMA then + call e$print3(.err$scbnoval); + +cv0: buf$ptr = buf$ptr + 1; + +end checkval; + + /******************************************************/ + + +getscboff: procedure; + + if (delimiter := separator(char)) = LPAREN then do; + + buf$ptr = buf$ptr + 1; + call valoff(39h,30h,buf$ptr); /* valid char ? */ + + bufptr1 = buf$ptr + 1; + + delimiter = separator(nextchar); + + if delimiter = SPACE then go to gs1; + if delimiter = COMMA then go to gs1; + /* 2 char input */ + call valoff(36h,30h,buf$ptr); + call valoff(46h,30h,bufptr1); /* valid ? */ + soff(nscbs) = aschex(buf$ptr,bufptr1); + buf$ptr = buf$ptr + 2; + call checkval; + return; + + /* single char in */ +gs1: soff(nscbs) = aschex(.zero,buf$ptr); + buf$ptr = bufptr1 + 1; + end; + else call e$print3(.errscbpar); + +end getscboff; + + /******************************************************/ + + zero = 30h; + delimiter = 1; + index = 0; + buf$ptr = buf$ptr + 1; /* move off [ delimiter */ + + /* while not eos */ + +gto0: call opt$scanner(.options,.off$opt,.index); + if index = 0 then do; + call print(.ERRORM); + call printx(.err$unrecopt); + call print(.('OPTION: ',0)); + call error$prt; + end; + + if index = 1 then NULL = true; + else if index = 2 then LOAD = true; + + if delimiter = 2 then return; + if delimiter = 25 then return; + + if delimiter = 3 then do; /* = */ + if index <> 3 then do; + call print(.ERRORM); + call printx(.err$notscb); + call opt$scanner(.options,.offopt, + .index); + go to gto1; + end; + + call getscboff; /* buf$ptr -> value */ + call getscbval; + SCB = true; + end; + +gto1: if delimiter = 0 then return; + if delimiter = 2 then return; + if delimiter = 25 then return; + + go to gto0; + +end getoption; + +$ eject + + +opener: procedure(fcb); + declare fcb address; + + if open(fcb) > 3 then do; + fcbp = fcb; + call err$print(.err$notfnd); + end; + +end opener; + + +closer: procedure(fcb); + declare fcb address; + + if close(fcb) > 3 then do; + fcbp = fcb; + call err$print(.err$notfnd); + end; +end closer; + +maker: procedure(fcb); + declare fcb address; + + flag = make(fcb); + if flag > 3 then do; + fcbp = fcb; + call err$print(.err$msg$make); + end; + +end maker; + +deleter: procedure; + + if (comfcb(8) and 80h) = 80h then return; /* user 0 file ? */ + + if delete(comptr) > 0 then do; + fcbp = comptr; + end; + +end deleter; + + +parser: procedure(fcb$ptr); + + declare fcb$ptr address; + + parse$struc.name$addr = buf$ptr; + parse$struc.fcb$addr = fcb$ptr; + test$ptr = buf$ptr; + +pa1: buf$ptr = parse(.parse$struc); /* parse command tail */ + +pa2: if buf$ptr = 0ffffh then do; + fcbp = test$ptr; + call err$print(.err$msg$parse); + end; + +end parser; + + +copypass$dma: procedure(index); + declare index byte, + i byte; + + do i = 0 to 7; + buff(i) = files(index).pass(i); + end; + +end copypass$dma; + +renamer: procedure; + + declare + (i,j) byte, + renbuf(32) byte; + + do i = 12 to 15; + j = i + 16; + renbuf(i) = 0; + renbuf(j) = 0; + end; + + do i = 0 to 11; /* set up buffer */ + j = i + 16; + renbuf(i) = tempfcb(i); + renbuf(j) = comfcb(i); + end; + +re1: flag = rename(.renbuf); + + if flag > 0 then do; + fcbp = allfcbs(0); /*GLITCH?????????*/ + end; +end renamer; + +clearfcb: procedure(fcb); + + declare fcb address, + f based fcb (1) byte, + i byte; + + do i = 12 to 33; + f(i) = 0; + end; + +end clearfcb; + + +/****************************************************************************/ + + +copy: procedure(recsize); + declare recsize address; + declare recs based recsize address; + declare + i byte, + flag address; + + call setmulti(maxrcd); + call mread(fcbp); + +co2: if readflag <> 0 then do; + if readflag = 1 then do; + if nrecs = 0 then return; /* EOF */ + end; + else call bdoserr; + end; + + i = maxrcd; + if nrecs <> 0 then do; /* read less than maxrcd */ + call setmulti(nrecs); + i = nrecs; + end; + + writeflag = writesq(.tempfcb); + + do while i <> 0; + recs = recs + 128; /* this is in bytes */ + i = i - 1; + end; + /* record count <= 64K */ + if recs > 0ffffh then call err$print(.err$msg$toobig); + + if nrecs <> 0 then return; + + call mread(fcbp); + + go to co2; + +end copy; + + +/*************************************************************************/ + + +copy2: procedure(nrcds,skip); + /* read/write in min(maxrcd,nrcds) + units. */ + + declare nrcds address, + skip byte, + set byte, + savin address; + + savin = nrcds; + +cp20: if savin > maxrcd then set = maxrcd; + else set = savin; + + call setmulti(set); + flag = readsq(comptr); /* get nrcds units */ + +cp21: if skip = 0 then flag = writesq(.tempfcb); /* while savin > 0 */ + savin = savin - set; + + if savin = 0 then return; + + if savin > maxrcd then set = maxrcd; + else set = savin; + + call setmulti(set); + flag = readsq(comptr); + + go to cp21; + +end copy2; + + +/****************************************************************************/ + + +reopen$temp: procedure; + declare i byte; + + call closer(.tempfcb); + call clearfcb(.tempfcb); + call opener(.tempfcb); + + call setmulti(2); + + readflag = readsq(.tempfcb); + +end reopen$temp; + + +/***************************************************************************/ + + +get$off: procedure(xrecs,index); + declare index byte, + xrecs address, + i based xrecs address; + declare (temp,sum) address; + +gt0: temp = offsets(index - 1); + sum = temp + i; +gt1: if sum < temp then call err$print(.err$msg$toobig); + + offsets(index) = sum; + +end get$off; + +zapRSX: procedure; + + declare dRSX based subptr (16) byte, + i byte; + + do i = 0 to 15; + dRSX(i) = 0; + end; + + subptr = subptr + 16; + +end zapRSX; + + +/************************************************************************/ + + +addrsx: procedure; + declare i byte, + prlptr address, + rsxlen based prlptr address; + + i = 1; +next$rsx: fcbp = allfcbs(i); /* while i <= incount */ + + call setmulti(2); /* get header */ + readflag = readsq(fcbp); + prlptr = .iobuff(1); /* get program length */ +ad1: length$rsx(i) = rsxlen; + + call setmulti(1); + readflag = readsq(fcbp); + + if iobuff(15) <> 0 then iobuff(14) = 0ffh; + nbank(i) = iobuff(15); /* only non-banked ? */ + iobuff(10) = 6; + iobuff(12) = 7; + iobuff(24) = 0; + + writeflag = writesq(.tempfcb); + + rsxrec = 128; + call copy(.rsxrec); + +ad2: totbyte = totbyte + rsxrec; + + i = i + 1; + + if i > incount then go to fini; + + call get$off(.rsxrec,i); + go to next$rsx; + +fini: end addrsx; + + +/*****************************************************************************/ + + +putSCBcode: procedure(ptrfcb); + declare (i,j) byte, + ptrfcb address, + fixup address, + fa based fixup address; + + if not SCB and not oldSCB then return; + + totbyte = totbyte + 256; /* rel to 100h */ + + call setdma(.SCBbuff); + call setmulti(2); + + if oldscb then i = SCBbuff(23); /* next open slot */ + else if SCB then do; /* must initialze buffer with code */ + + do i = 0 to 255; + SCBbuff(i) = 0ffh; + end; + +ps0: fixup = .SCBcode(1); + fa = fa + totbyte; + fixup = .SCBcode(19); + fa = fa + totbyte; + +ps1: call move(23,.SCBcode,.SCBbuff(0)); + i = 24; + end; + +ps2: if nscbs > 0 then do; + do j = 0 to nscbs-1; + SCBbuff(i) = soff(j); + SCBbuff(i+2) = sval(j); + i = i + 3; + end; + end; + + SCBbuff(23) = i; /* next available scb init */ + +ps3: if oldSCB then + if ptrfcb = comptr then comfcb(32) = comfcb(32) - 2; + + writeflag = writesq(ptrfcb); + call setdma(.iobuff); + +end putSCBcode; + +/***************************************************************************/ + + +update$head: procedure; + declare (i,j,k) byte, + (olds,temp) byte; + + + possub: procedure; + + subptr = .iobuff(16); /* start of RSX info in header */ + + i = 1; /* skip old rsx heads */ + do while i <= old; + subptr = subptr + 16; + i = i + 1; + end; +end possub; + + /************************************************************/ + + + call possub; /* set subptr to end of RSX */ + head$ptr = .iobuff; + + if not COMonly then do; + if build then head.progsize = comsize; +up1: k = old; + + do i = 1 to incount; + k = k + 1; + rsx$sub$head.off = offsets(i); + rsx$sub$head.len = length$rsx(i); + rsx$sub$head.NONBANK = nbank(i); + fcbp = allfcbs(i); + do j = 0 to 7; + rsx$sub$head.name(j) = gen$fcb(j + 1); + end; + + subptr = subptr + 16; + end; + end; /* COMonly... */ + else head.progsize = comsize; + +up2: if LOAD then head.LOADER = 1; + if SCB or oldSCB then call move(2,.totbyte,.iobuff(4)); + + tempfcb(32) = 0; /* backup CR to re-write rcd */ + + writeflag = writesq(.tempfcb); + call closer(.tempfcb); + + if not NULL then call deleter; /* erase old file */ + call renamer; + +end update$head; + + +/***********************************************************************/ + + +tear$down: procedure; + + /* remove header from file */ + head$ptr = .iobuff(0); + comsize = head.progsize/128; + +tr1: call copy2(comsize,0); /* copies com to temp */ + + call closer(comptr); + call closer(.tempfcb); + /* set up pass if any */ + if len$pass(0) > 0 then call copypass$dma(0); + call deleter; /* delete com file*/ + call renamer; + +end tear$down; + + +/***************************************************************************/ + +create2: procedure; + + + if not COMonly then do; + + offsets(0) = 256; /* starting pos in bytes */ +cr4: call get$off(.comsize,1); + call addrsx; /* copy RSX to temp */ + end; + + call putSCBcode(.tempfcb); + + call reopen$temp; + +cr5: old = 0; + call update$head; + +end create2; + + +/***************************************************************************/ + + +create: procedure; + declare i byte; + + do i = 0 to 384; /* clear the header buffer */ + head$buffer(i) = 0; + end; + do i = 0 to incount; /* clear offsets */ + offsets(i) = 0; + end; + + head$ptr = .head$buffer; + head.retinst = ret$inst; + if not SCB then head.SCBjmp = ret$inst; + else head.SCBjmp = 0c3h; + + head.nrsx = incount; + + totbyte = 256; + if NULL then do; + head$buffer(256) = ret$inst; + call setmulti(3); + end; + +cr1: call setdma(head$ptr); /* move dma to header */ + writeflag = writesq(.tempfcb); + if writeflag > 0 then do; + fcbp = .tempfcb; + call err$print(.err$msg$write); + end; + + call setdma(.iobuff); + + if not NULL then do; + + if readflag <> 1 then do; /* if size of COM = 1 + then read in setup + found EOF, no need + to copy; if flag > 1 + then setup catches */ + + writeflag = writesq(.tempfcb); /* first 2 COM rcds */ + + fcbp = comptr; + comsize = 256; +cr2: call copy(.comsize); /* COM->temp */ + end; + else do; + call setmulti(1); + writeflag = writesq(.tempfcb); + comsize = 128; + end; + end; + else comsize = 128; + + totbyte = totbyte + comsize; + + call create2; + +end create; + +/*****************************************************************************/ + + +SCBget: procedure(skip); + declare skip byte; + /* where in record units is beginning + of SCB initialization code? + Record numbering is rel to 0 */ + + comsize = shr(SCBpos,7) - 4; + call copy2(comsize,skip); /* do not copy SCB code */ + totbyte = shl(comsize,7); + + readflag = readsq(comptr); + call move(256,.iobuff,.SCBbuff); + +end SCBget; + +/*****************************************************************************/ + + +remover: procedure; + /* remove old RSX in gencommed file */ + +getname: procedure(j); + + declare (j,k) byte; + + do k = 0 to 7; + new(j).name(k) = rsx$sub$head.name(k); + end; +end getname; + + + declare (i,j,k,l) byte, + zeroes based subptr (1) byte, + tot address; + + + fcbp = comptr; +rp1: subptr = .iobuff(16); /* prepare to collapse header.. + compute actual lengths, + & save start bit map */ + nextptr = .iobuff(32); + do j = 1 to old; + newlen(j) = rsx$sub$head.len; /* save len & name */ + call getname(j); + actlen(j) = next.off - rsx$sub$head.off; + nbank(j) = rsx$sub$head.NONBANK; + + subptr = nextptr; + nextptr = nextptr + 16; + end; + actlen(old) = 0; + +rp2: subptr = .iobuff(16); /* start copying current COM + file, skipping dup entries*/ + writeflag = writesq(.tempfcb); /* header */ + tot = shr(head.progsize,7); /* # 80h units to copy */ + call copy2(tot,0); /* copies COM to temp */ + tot = tot + 2; + +rp3: j = 1; /* now copy each valid RSX */ + do i = 1 to old; + comsize = shr(actlen(i),7); /* convert to 80h units */ + if which(i) = i then do; /* duplicate */ + if i <> old then /* don't skip last */ + call copy2(comsize,1); + end; + else do; /* copy RSX & setup new offsets + lengths */ +rpx: newoff(j) = shl(tot,7); + nbank(j) = nbank(i); + /* if last RSX then we have no + way of knowing the actual + length...so write until EOF, + else write comsize # rcds */ + if i = old then call copy(.tot); + else do; + tot = tot + comsize; + call copy2(comsize,0); + end; + + newlen(j) = newlen(i); /* i > j always */ + do k = 0 to 7; + new(j).name(k) = new(i).name(k); + end; + j = j + 1; + end; + end; + + /* now rebuild header */ + call reopen$temp; + + j = j - 1; + subptr = .iobuff(16); + do i = 1 to j; /* j = # good RSX */ + rsx$sub$head.off = newoff(i); + rsx$sub$head.len = newlen(i); + rsx$sub$head.NONBANK = nbank(i); + nbank(i) = 0; + do k = 0 to 7; + rsx$sub$head.name(k) = new(i).name(k); + end; + subptr = subptr + 16; + end; + + do i = j + 1 to old; /* clear out header */ + call zapRSX; + end; + +rp4: head.nrsx = j; + old = j; + + tempfcb(32) = 0; /* CR = 0 */ + flag = writesq(.tempfcb); + + call closer(.tempfcb); /* close and rename */ + call deleter; /* delete com file */ + call renamer; + + call clearfcb(comptr); + call clearfcb(.tempfcb); + call maker(.tempfcb); +rp9: call opener(comptr); /* prepare return to concat */ +rp7: readflag = readsq(comptr); + +end remover; + + +/***************************************************************************/ + + +dup$RSX: procedure byte; + /* check for duplications in header and + input. Remove old entry if found, + or if all are duplicated then strip + everything off. */ + + declare (i,j,k,l) byte, + temp address; + + subptr = .iobuff(16); + deletes = 0; + + do i = 1 to old; + which(i) = 0; + + do j = 1 to incount; /* compare names */ + fcbp = allfcbs(j); + do k = 0 to 7; + if rsx$sub$head.name(k) <> gen$fcb(k+1) + then go to dp1; + end; + /* duplicate RSX's */ + which(i) = i; + deletes = deletes + 1; + + call e$print1(.err$msg$dup2); + call e$print2; + + go to dp2; /* no need to scan rest of + input names- checked input + for dups already */ +dp1: end; +dp2: subptr = subptr + 16; + end; + + if deletes = 0 then return(false); +dp4: if deletes >= old then do; /* replace all ? */ + subptr = .iobuff(16); + do i = 1 to old; + call zapRSX; + end; + + temp = head.progsize; /* get size of COM in rcds */ + + if oldSCB then do; + call SCBget(1); + comfcb(32) = 0; + call setmulti(2); + readflag = readsq(comptr); + end; + + comsize = shr(temp,7); + writeflag = writesq(.tempfcb); /* copy header to temp */ + call copy2(comsize,0); /* copy COM file */ + + comsize = temp; /* back to byte count */ + call create2; + + return(true); + end; + + call remover; /* selective replace */ + + return(false); /* return and add new RSX */ + +end dup$RSX; + + +/***************************************************************************/ + + +concat: procedure; + /* add new, replace old */ + + declare i byte; + + head$ptr = .iobuff; + if (old := head.nrsx) <> 0 then do; +yy: if dup$RSX then return; /* true : did a create + false : add new RSX, + might have collapsed + old header...*/ + + end; + + head.nrsx = head.nrsx + incount; + fcbp = comptr; + +cc1: if head.nrsx > 15 then + call err$print(.err$msg$rsx$slot); + + flag = writesq(.tempfcb); /* write header */ + + if oldSCB then call SCBget(0); + else do; /* no SCB...copy to EOF */ + comsize = 256; + call copy(.comsize); + end; + + /* comsize = size of file in bytes + +1 = offset of first new RSX */ + offsets(0) = 0; + call getoff(.comsize,1); + + totbyte = comsize; + + call closer(fcbp); /*close old file */ + + call addrsx; + + call putSCBcode(.tempfcb); + + call reopen$temp; + call update$head; + +end concat; + + +/***********************************************************************/ + +setSCB: procedure; + + /* read in gencommed file and set scb values + from command line */ + + head$ptr = .iobuff; + + fcbp = comptr; + totbyte = 2; + + if LOAD then do; /* write out loader flag */ + if oldSCB or not SCB then do; + iobuff(13) = 1; + comfcb(32) = 0; + writeflag = writesq(.comfcb); + if writeflag <> 0 then call err$print(.err$msg$write); + totbyte = 0; + end; + end; + + if SCB then do; + if oldSCB then call SCBget(1); + else do; + if readflag <> 1 then do; /* 1 rcd com file ? */ + call setmulti(32); + call mread(comptr); + do while readflag <> 1; + totbyte = totbyte + nrecs; + call mread(comptr); + end; + end; + + totbyte = totbyte + nrecs; + totbyte= shl(totbyte,7); /* change to bytes */ + end; + + call putSCBcode(comptr); + + if not oldSCB then do; /* must update header + for new SCB's */ + call closer(comptr); + call setmulti(1); + call clearfcb(comptr); + call opener(comptr); + readflag = readsq(comptr); + call move(2,.totbyte,.iobuff(4)); + if LOAD then iobuff(13) = 1; + iobuff(3) = ret$inst; + comfcb(32) = 0; + writeflag = writesq(.comfcb); + if writeflag <> 0 then call err$print(.err$msg$write); + end; + end; + + call closer(comptr); + +end setSCB; + + +/***********************************************************************/ + + +setuper: procedure; + + /* 1. get each file (process passwords) + 2. check for proper type + 3. check for duplicate RSX on input + 4. open files and make temp + */ + + declare (i,j,k,l) byte; + +init: procedure; + + fcbp,allfcbs(i) = .fcbs(i).file(0); + do j = 0 to 32; + fcbs(i).file(j) = 0; + end; +end init; + +RSX$errprint: procedure; + + + call e$print1(.('This file was not used.',0)); + call e$print2; + call crlf; + + which(deletes) = i; + deletes = deletes + 1; + +end RSX$errprint; + +fill$type: procedure(typea); + declare typea address, + type based typea (1) byte; + + k = 0; + do l = 9 to 11; + gen$fcb(l) = type(k); + k = k + 1; + end; + +end fill$type; + + +checktype: procedure(typea) byte; + declare typea address, + type based typea (1) byte; + + if gen$fcb(9) = BLANK then /* any type ? */ + call fill$type(typea); + + else do; /* check input type */ + k = 0; + do l = 9 to 11; + if gen$fcb(l) <> type(k) then return(false); + k = k + 1; + end; + end; + + return(true); + +end checktype; + + + + buf$ptr = .buff(1); /* get files */ + i = 0; + do while buf$ptr <> 0; + call init; + call parser(fcbp); + + if optmark = '[' then go to sb1;/* no more names, options */ + + /* any PASSWORDS !!!! */ + k = gen$fcb(26); /* length of password */ + if k > 0 then do; + l = 16; /* start of password */ + do j = 0 to k - 1; + files(i).pass(j) = gen$fcb(l); + l = l + 1; + end; + len$pass(i) = k; + end; + i = i + 1; + end; + +sb1: incount = i - 1; + + if optmark = '[' then do; + incount = i; + call getoption; + end; + + comptr = allfcbs(0); + /* check COM */ +sb2: fcbp = comptr; + if not checktype(.comtype) then do; /* bad input */ + if not NULL then do; + call print(.err$msg$first); + call terminate; + end; + end; + + if len$pass(0) > 0 then call copypass$dma(0); + if open(fcbp) > 3 then do; /* something awry */ + if not NULL then do; + call err$print(.err$notfnd); + call e$print1(.err$msg$first); + call terminate; + end; + end; + else + if NULL then + if (comfcb(8) and 80h) <> 80h then + call err$print(.err$NULL); /* NULL and COM file*/ + + if NULL then do; +sb3: i = (incount := incount + 1); /* move fcbs up */ + allfcbs(i) = .fcbs(i); + do j = 0 to incount - 1; + do k = 0 to 32; + fcbs(i).file(k) = fcbs(i-1).file(k); + end; + i = i - 1; + end; + /* dummy COM name = 1st RSX */ + call fill$type(.comtype); + fcbp = allfcbs(1); /* restore type to RSX */ + call fill$type(.rsxtype); + end; + +sb4: if incount > 0 then do; + deletes = 0; /* now check RSX's */ + do i = 1 to incount; + fcbp = allfcbs(i); /* point to RSX fcb */ + + if not checktype(.rsxtype) then do; + call e$print1(.err$msg$rsxval); + call RSX$errprint; + end; + + else do; /* try to open file */ + if len$pass(i) > 0 then + call copypass$dma(i); + + flag = open(fcbp); + if flag > 3 then do; + call e$print1(.err$notfnd); + call RSX$errprint; + end; + else /* Duplicate input RSX ? */ + do j = i+1 to incount; + test$ptr = allfcbs(j); + do l = 1 to 8; + if genfcb(l) <> testfcb(l) + then go to sb5; + end; + call e$print1(.err$msg$dup1); + call RSX$errprint; +sb5: end; + end; + end; /* ends i = incount...*/ + + /* have any RSX's left? */ + if deletes >= incount then do; + call print(.err$msg$no$rsx); + call terminate; + end; + + i = 0; +sb6: do while i < deletes; /* collapse allfcbs */ + j = which(i); + incount = incount - 1; + + do l = j to incount; + allfcbs(l) = allfcbs(l + 1); + end; + + i = i + 1; + end; + + rsx = true; + end; /* if incount> 0...*/ + +sb7: + call setdma(.iobuff); + call setmulti(2); /* read header if any */ + + if not NULL then do; + fcbp = comptr; + call mread(comptr); + if readflag > 1 then call err$print(.err$msg$read); + + /* is this already gencommed*/ +sb8: if iobuff(0) = ret$inst then do; + /* first byte = return */ + if rsx then replace = true; + else do; + if SCB or LOAD then punchSCB = true; + else revert = true; + end; + + /* do we need to move old SCB + initialization code ? */ + if iobuff(3) <> 0c9h then do; + oldSCB = true; + call move(2,.iobuff(4),.SCBpos); + end; + end; + else do; + if rsx then build = true; + else if SCB or LOAD then COMonly = true; + else call err$print(.errSTRIP); + end; + end; + else build = true; + +sb9: if not punchSCB then do; + call clearfcb(.tempfcb); + flag = delete(.tempfcb); + tempfcb(0) = comfcb(0); /* init temp drive */ +sb0: call maker(.tempfcb); + end; + +end setuper; + + + +/* MAIN PROGRAM */ + + +plm: + + testvers = get$version; + if high(testvers) = 1 then go to err$vers; + if low(testvers) < 30h then go to err$vers; + + call return$errors(254); + + call setuper; + + if revert then call tear$down; + else + if build then call create; + else + if punchSCB then call setscb; + else if COMonly then call create; + else call concat; + + call closeall; + + call print(.('GENCOM completed.',0)); + call terminate; + +err$vers: + call print(.ERRORM); + call printx(.('Requires CP/M 3 or higher.',0)); + call terminate; + + +end gencomer; diff --git a/software/CPM/cpm3/gencpm.plm b/software/CPM/cpm3/gencpm.plm new file mode 100644 index 0000000..3e7855b --- /dev/null +++ b/software/CPM/cpm3/gencpm.plm @@ -0,0 +1,1478 @@ +$title('CP/M 3 System Generation') +gencpm: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 02 Dec 82 by Bruce Skidmore +*/ + + declare true literally '0FFH'; + declare false literally '0'; + declare forever literally 'while true'; + declare boolean literally 'byte'; + declare cr literally '0dh'; + declare lf literally '0ah'; + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + relfix: + procedure byte external; + end relfix; + + setbuf: + procedure external; + end setbuf; + + getdef: + procedure external; + end getdef; + + crtdef: + procedure external; + end crtdef; + + declare reset label external; + + declare fcb (1) byte external; + declare fcb16 (1) byte external; + declare tbuff (1) byte external; + declare maxb address external; + declare bitmap (128) byte external; + + declare FCBin address public; + + declare bios$fcb (36) byte initial ( + 0,'BNKBIOS3','SPR',0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + + declare res$fcb (36) byte initial ( + 0,'RESBDOS3','SPR',0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + + declare bnk$fcb (36) byte initial ( + 0,'BNKBDOS3','SPR',0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + + declare FCBout (36) byte initial ( + 0,'CPM3 ','SYS',0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + + declare data$fcb (36) byte public initial ( + 0,'GENCPM ','DAT',0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + + declare offset byte public; + declare prgsiz address public; + declare bufsiz address public; + declare codsiz address public; + declare bios$pg byte public; + declare scb$pg byte public; + declare res$pg byte public; + declare bnk$pg byte public; + declare bnk$off byte public; + declare res$len byte public; + declare non$bnk byte public; + declare dma address public; + + declare hexASCII (16) byte public data ( + '0123456789ABCDEF'); + + declare lnbfr (14) byte public initial (12); + + declare sctbfr (1) structure ( + record (128) byte) public at (.memory); + + declare fcb$msg (13) byte initial (' . $'); + + declare query boolean public; + +/* + B D O S P r o c e d u r e & F u n c t i o n C a l l s +*/ + + system$reset: + procedure public; + call mon1 (0,0); + end system$reset; + + write$console: + procedure (char) public; + declare char byte; + if display then + call mon1 (2,char); + end write$console; + + print$console$buffer: + procedure (buffer$address) public; + declare buffer$address address; + if display then + call mon1 (9,buffer$address); + end print$console$buffer; + + read$console$buffer: + procedure (buffer$address) public; + declare buffer$address address; + declare buf based buffer$address (1) byte; + buf(1) = 0; + if automatic then + do; + if not query then + return; + end; + call mon1 (10,buffer$address); + buf(buf(1)+2) = 0; + end read$console$buffer; + + crlf: + procedure public; + call write$console (cr); + call write$console (lf); + end crlf; + + error: + procedure(term$code,err$type,err$msg$adr) public; + declare (term$code,err$type) byte; + declare err$msg$adr address; + display = true; + call print$console$buffer (.(cr,lf, + 'ERROR: $')); + call print$console$buffer (err$msg$adr); + if err$type = 1 then + call print$console$buffer(.fcb$msg); + call crlf; + if term$code then + call system$reset; + if automatic and not query then + do; + fcb(1), + fcb16(1) = ' '; + goto reset; + end; + end error; + + open$file: + procedure (fcb$address) byte public; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + fcb(12), /* ex = 0 */ + fcb(32) = 0; /* cr = 0 */ + return mon2 (15,fcb$address); + end open$file; + + close$file: + procedure (fcb$address) public; + declare fcb$address address; + call mon1 (16,fcb$address); + end close$file; + + delete$file: + procedure (fcb$address) public; + declare fcb$address address; + call mon1 (19,fcb$address); + end delete$file; + + read$record: + procedure (fcb$address) public; + declare fcb$address address; + if mon2 (20,fcb$address) <> 0 then + do; + call error(true,1,.( + 'Reading file: $')); + end; + end read$record; + + write$record: + procedure (fcb$address) public; + declare fcb$address address; + if mon2 (21,fcb$address) <> 0 then + do; + call error(true,1,.( + 'Writing file: ','$')); + end; + end write$record; + + create$file: + procedure (fcb$address) public; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + if mon2 (22,fcb$address) = 255 then + do; + call error(true,0,.( + 'Directory full','$')); + end; + fcb(32) = 0; /* set cr = 0 */ + end create$file; + + set$DMA$address: + procedure (DMA$address) public; + declare DMA$address address; + call mon1 (26,DMA$address); + end set$DMA$address; + + read$random$record: + procedure (fcb$address) public; + declare fcb$address address; + if mon2 (33,fcb$address) <> 0 then + do; + call error(true,1,.( + 'Reading file: ','$')); + end; + end read$random$record; + + write$random$record: + procedure (fcb$address) public; + declare fcb$address address; + if mon2 (34,fcb$address) <> 0 then + do; + call error(true,1,.( + 'Writing file: ','$')); + end; + end write$random$record; + + set$random$record: + procedure (fcb$address) public; + declare fcb$address address; + call mon1 (36,fcb$address); + end set$random$record; + + +/* + D a t a S t r u c t u r e s +*/ + + + declare automatic boolean; + declare display boolean public; + + declare nmb$sect address; + + declare link address at (.memory); + + declare bios$atts(3) address public; + declare res$atts(3) address public; + declare bnk$atts(3) address public; + + declare res$bios$len byte public; + declare res$base byte public; + declare pg$dif byte public; + declare xmove$implemented boolean public; + declare os$top address; + + declare system$data (256) byte; + + declare common$len byte public at (.system$data(1)); + declare banked$len byte public at (.system$data(3)); + declare sys$entry address public at (.system$data(4)); + + declare prt$msg$ptr byte; + + declare dont$hash boolean; + + declare wordadr address; + declare word based wordadr address; + + declare len byte; + declare off address; + declare res$flg byte; + declare save$mem$top byte; + + declare drvtbl$adr address public; + declare drvtbl based drvtbl$adr (16) address; + + declare dph$adr address public; + declare dph based dph$adr structure ( + xlt address, + scratch1(4) address, + scratch2 byte, + mf byte, + dpb address, + csv address, + alv address, + dirbcb address, + dtabcb address, + hash address, + hbank byte); + + declare dpb$adr address public; + declare dpb based dpb$adr structure ( + spt address, + bsh byte, + blm byte, + exm byte, + dsm address, + drm address, + al0 byte, + al1 byte, + cks address, + off address, + psh byte, + phm byte); + + declare bnk$swt boolean external; + declare dbl$alv boolean external; + declare mem$top byte external; + declare bnk$top byte external; + declare lerror boolean external; + declare bdrive byte external; + declare con$wid byte external; + declare con$pag byte external; + declare bck$spc boolean external; + declare rubout boolean external; + declare prt$msg boolean external; + declare hash(16) boolean external; + declare num$seg byte external; + declare crdatf boolean external; + + declare mem$tbl (17) structure( + base byte, + len byte, + bank byte, + attr address) external; + + declare record(16) structure( + size address, + attr byte, + altbnks byte, + no$dirrecs byte, + no$dtarecs byte, + ovlydir$dr byte, + ovlydta$dr byte, + dir$resp byte, + dta$resp byte) external; + + declare quest(157) boolean external; + + declare hash$data(16) address public; + declare hash$space address public; + declare alloc(16) address public; + declare alloc$space address public; + declare chk(16) address public; + declare chk$space address public; + +/* + L o c a l P r o c e d u r e s +*/ + + movef: + procedure (count,source$adr,dest$adr) public; + declare count byte; + declare (source$adr,dest$adr) address; + + if count = 0 + then return; + else call move (count,source$adr,dest$adr); + + end movef; + + shift$left: + procedure (pattern, count) address public; + declare count byte; + declare pattern address; + + if count = 0 + then return pattern; + else return shl(pattern,count); + + end shift$left; + + upper: + procedure(b) byte public; + declare b byte; + + if b < ' ' then return cr; /* all non-graphics */ + /* translate alpha to upper case */ + if b >= 'a' and b <= 'z' then + b = b and 101$1111b; /* upper case */ + return b; + end upper; + + valid$drive: + procedure(drv) boolean public; + declare drv byte; + if (drv >= 0) and (drv <= 15) then + return true; + call error(false,0,.('Invalid drive.$')); + return false; + end valid$drive; + + get$response: + procedure (val$adr) public; + declare val$adr address; + declare val based val$adr byte; + call write$console ('('); + if val = 0ffh + then call write$console ('Y'); + else call write$console ('N'); + call print$console$buffer (.(') ? ','$')); + call read$console$buffer (.lnbfr); + if lnbfr(1) = 0 + then return; /* accept default */ + val = (upper(lnbfr(2)) = 'Y'); + end get$response; + + dsply$hex: + procedure (val) public; + declare val byte; + call write$console (hexASCII(shr (val,4))); + call write$console (hexASCII(val and 0fh)); + end dsply$hex; + + dsply$hex$adr: + procedure (val) public; + declare val address; + call write$console (' '); + call dsply$hex (high (val)); + call dsply$hex (low (val)); + call write$console ('H'); + end dsply$hex$adr; + + dsply$hex$high$adr: + procedure (val) public; + declare val byte; + call dsply$hex$adr (double (val)*256); + end dsply$hex$high$adr; + + dsply$dec$adr: + procedure (val) public; + declare val address; + declare big address; + declare (digit,i) byte; + declare pdigit boolean; + + pdigit = false; + digit = '0'; + big = 10000; + if val = 0 then + call write$console(digit); + else + do; + do i = 0 to 4; + do while val >= big; + pdigit = true; + digit = digit + 1; + val = val - big; + end; + if pdigit then + do; + call write$console(digit); + digit = '0'; + end; + big = big / 10; + end; + end; + end dsply$dec$adr; + + dsply$param: + procedure (val,base) public; + declare (val,base) byte; + call write$console ('('); + if base = 10 then + do; + call write$console ('#'); + call dsply$dec$adr(double(val)); + end; + else + do; + call dsply$hex (val); + end; + call print$console$buffer (.(') ? ','$')); + end dsply$param; + + get$param: + procedure (string$adr,val$adr,pbase) public; + declare (string$adr,val$adr) address; + declare pbase byte; + declare base byte; + declare val based val$adr byte; + declare string based string$adr (1) byte; + declare char byte; + declare lbindx byte; + + prompt$read: + procedure; + call print$console$buffer (string$adr); + if string(0) = ' ' then + do; + call write$console ('('); + call dsply$hex (val); + do lbindx = 1 to 2; + val$adr = val$adr + 1; + if (lbindx=2) and (not bnk$swt) then + do; + val = 0; + end; + else + do; + call write$console (','); + call dsply$hex (val); + end; + end; + val$adr = val$adr - 2; + call print$console$buffer (.(') ? ','$')); + end; + else + do; + call dsply$param (val,pbase); + end; + base = 16; + lbindx = 1; + call read$console$buffer (.lnbfr); + end prompt$read; + + call prompt$read; + if lnbfr(1) = 0 then + do; + /* accept default value */ + call crlf; + return; + end; + val = 0; + do while (char := upper(lnbfr(lbindx:=lbindx+1))) <> cr; + if char = ',' then + do; + val$adr = val$adr + 1; + val = 0; + base = 16; + end; + else + do; + if char = '#' then + do; + base = 10; + end; + else + do; + char = char - '0'; + if (base = 16) and (char > 9) then + do; + if char > 16 + then char = char - 7; + else char = 255; + end; + if char < base then + do; + val = val*base + char; + end; + else + do; + char, + val = 0; + call error (false,0,.( + 'Bad character, re-enter $')); + call prompt$read; + val = 0; + end; + end; + end; + end; + call crlf; + end get$param; + + get$seg: + procedure(type,record$size) byte public; + + declare (type,k,seg$no) byte; + declare (record$size,max$attr) address; + + if not bnk$swt then + return 0; + + seg$no = 0ffh; + max$attr = 0ffffh; + do k = 1 to num$seg; + if mem$tbl(k).attr >= record$size then + if type = 1 then + do; + if (mem$tbl(k).bank = 0) and + (mem$tbl(k).attr < max$attr) then + do; + seg$no = k; + max$attr = mem$tbl(k).attr; + end; + end; + else + do; + if (mem$tbl(k).bank <> 0) and + (mem$tbl(k).attr < max$attr) then + do; + seg$no = k; + max$attr = mem$tbl(k).attr; + end; + end; + end; + if (seg$no = 0ffh) and (type = 2) then + do k = 1 to num$seg; + if (mem$tbl(k).attr >= record$size) and + (mem$tbl(k).bank = 0) and + (mem$tbl(k).attr < max$attr) then + do; + seg$no = k; + max$attr = mem$tbl(k).attr; + end; + end; + return seg$no; + + end get$seg; + +plm: + procedure public; + + st$ascii$hex: + procedure(string$adr,val); + declare string$adr address; + declare string based string$adr (6) byte; + declare val address; + declare i byte; + string(0) = ' '; + string(1) = ' '; + string(2) = hexASCII(shr(high(val),4)); + string(3) = hexASCII(high(val) and 0fh); + string(4) = hexASCII(shr(low(val),4)); + string(5) = hexASCII(low(val) and 0fh); + end st$ascii$hex; + + setup$scb: + procedure; + declare scb$adr address; + declare scb$dat based scb$adr (100) byte; + + scb$adr = .memory + shl(double(scb$pg-res$pg),8) + 09ch; + + scb$dat(13h) = bdrive; + scb$dat(1ah) = con$wid; + scb$dat(1ch) = con$pag; + scb$dat(2eh) = bck$spc; + scb$dat(2fh) = rubout; + call movef(5,.(012h,07h,0,0,0),.scb$dat(58h)); /* December 15, 1982 */ + if not lerror then + scb$dat(57h) = scb$dat(57h) and 7fh; + if not dbl$alv and not bnk$swt then + scb$dat(57h) = scb$dat(57h) or 0100$0000B; + else + scb$dat(57h) = scb$dat(57h) and 1011$1111B; + scb$dat(5eh) = bnk$top; + + end setup$scb; + + get$drvtbl$adr: + procedure address; + declare temp$adr address; + declare temp2 based temp$adr address; + declare temp3 address; + + temp$adr = .memory(43h); + temp3 = temp2 + 1 + .memory; + temp$adr = temp3; + if temp2 = 0fffeh + then res$flg = 2; + else res$flg = 0; + if temp2 < 0fffeh + then return temp2 + .memory; + else return 0ffffh; + end get$drvtbl$adr; + + page$chop: + procedure; + declare i byte; + + drvtbl$adr = get$drvtbl$adr; + + dont$hash = true; + if (drvtbl$adr <> 0ffffh) then + do; + do i = 0 to 15; + if drvtbl(i) <> 0 then + do; + dph$adr = drvtbl(i) + .memory; + if dph.hash <> 0ffffh then + dont$hash = false; + end; + end; + if dont$hash and not bnk$swt then + res$flg = 2; + else + res$flg = 0; + end; + + end page$chop; + + get$xmove: + procedure boolean; + declare xmove$adr address; + declare xmove$val based xmove$adr byte; + + call movef(2,.memory(58h),.xmove$adr); + xmove$adr = xmove$adr + .memory; + if xmove$val = 0c9h /* ret instr. */ then + return false; + else + return true; + end get$xmove; + + display$layout: + procedure(string$adr,base,length); + declare string$adr address; + declare base address; + declare length byte; + + call print$console$buffer (.(cr,lf,' ','$')); + call print$console$buffer (string$adr); + call write$console(' '); + call dsply$hex$adr (base); + call write$console(' '); + call dsply$hex$high$adr (length); + if prt$msg then + do; + call movef(12,string$adr,.system$data(prt$msg$ptr)); + prt$msg$ptr = prt$msg$ptr + 12; + call st$ascii$hex(.system$data(prt$msg$ptr),base); + prt$msg$ptr = prt$msg$ptr + 6; + call st$ascii$hex(.system$data(prt$msg$ptr), + double(length)*256); + prt$msg$ptr = prt$msg$ptr + 6; + call movef(3,.(cr,lf,' '),.system$data(prt$msg$ptr)); + prt$msg$ptr = prt$msg$ptr + 3; + end; + end display$layout; + + reloc$module: + procedure (fcb$adr); + declare fcb$adr address; + FCBin = fcb$adr; + if relfix <> 0 then + do; + call error(true,1,.('Disk read error: $')); + end; + call close$file(fcb$adr); + end reloc$module; + + load: + procedure (fcb$adr,atts$adr); + declare fcb$adr address; + declare atts$adr address; + declare atts based atts$adr (3) address; + declare (i,rdcnt) byte; + + prgsiz = atts(0); + bufsiz = atts(1); + codsiz = atts(2); + call movef(8,fcb$adr+1,.fcb$msg); + call movef(3,fcb$adr+9,.fcb$msg+9); + if shr(prgsiz+255,7) > nmb$sect then + do; + call error(true,1,.('File cannot fit into GENCPM buffer: ','$')); + end; + rdcnt = low(shr(prgsiz-1,7)) + 1; + i = 0; + do while (i < rdcnt); + call set$dma$address(dma:=.sctbfr(i)); + call read$record(fcb$adr); + i = i + 1; + end; + call movef(128,dma,.bitmap); /* copy the last sector read, into */ + /* the bitmap buffer, relocation */ + /* info might be that last sector */ + dma = prgsiz + .memory; + end load; + + wrtbuf: + procedure (wrtlen,wrtoff$adr); + declare (i,wrtlen,wrtcnt) byte; + declare wrtoff$adr address; + declare wrtoff based wrtoff$adr address; + if wrtlen <> 0 then + do; + call movef(8,.FCBout+1,.fcb$msg); + call movef(3,.FCBout+9,.fcb$msg+9); + FCBout(33) = low(wrtoff); + FCBout(34) = high(wrtoff); + call write$random$record(.FCBout); + dma = dma + low(256 - low(dma - .memory)); + wrtcnt = wrtlen * 2 - 1; + do i = 0 to wrtcnt; + call set$dma$address(dma:=dma-80h); + call write$record(.FCBout); + end; + call set$random$record(.FCBout); + call movef(2,.FCBout(33),wrtoff$adr); + end; + end wrtbuf; + + get$file$info: + procedure; + declare fcb$adr address; + declare atts$adr address; + declare file$atts based atts$adr(3) address; + declare header$record structure ( + fill1 byte, + psize address, + fill2 byte, + dsize address, + fill3 (4) byte, + csize address, + fill4 (116) byte) at (.memory); + + + get$atts: + procedure; + call movef(8,fcb$adr+1,.fcb$msg); + call movef(3,fcb$adr+9,.fcb$msg+9); + if open$file(fcb$adr) = 0ffh + then call error(true,1,.('Unable to open: $')); + call set$dma$address(.header$record); + call read$record(fcb$adr); + file$atts(0) = header$record.psize; + file$atts(1) = header$record.dsize; + file$atts(2) = header$record.csize; + call read$record(fcb$adr); + end get$atts; + + if not bnk$swt then + do; + call movef(8,.('BDOS3 '),.res$fcb+1); + call movef(8,.('BIOS3 '),.bios$fcb+1); + end; + else + do; + fcb$adr = .bnk$fcb; + atts$adr = .bnk$atts; + call get$atts; + end; + fcb$adr = .bios$fcb; + atts$adr = .bios$atts; + call get$atts; + fcb$adr = .res$fcb; + atts$adr = .res$atts; + call get$atts; + end get$file$info; + + need$tbl: + procedure byte; + declare (all$some,i) byte; + + all$some = false; + + if drvtbl$adr = 0ffffh + then return false; + else + do i = 0 to 15; + if drvtbl(i) <> 0 then + do; + dph$adr = drvtbl(i) + .memory; + /* zero the reserved bytes in the DPH */ + call movef(9,.(0,0,0,0,0,0,0,0,0),dph$adr+2); + if (dph.dirbcb = 0fffeh) or (dph.dtabcb = 0fffeh) or + (dph.hash = 0fffeh) or (dph.alv = 0fffeh) or + (dph.csv = 0fffeh) + then all$some = true; + end; + end; + return all$some; + + end need$tbl; + + setup$hash: + procedure; + declare (i,j,printed,seg$no,seg0$no,h$bank,hohash) byte; + declare (size,h$attr,max$attr,max0$attr) address; + declare nohash boolean; + + printed = false; + nohash = true; + + do i = 0 to 15; + dph$adr = drvtbl(i) + .memory; + if drvtbl(i) <> 0 then + do; + if dph.hash < 0fffeh then + nohash = false; + if dph.hash = 0fffeh then + do; + if not printed then + do; + printed = true; + call print$console$buffer(. + (lf,cr,'Setting up directory hash tables:', + lf,cr,'$')); + end; + query = quest(27 + i); + dpb$adr = dph.dpb + .memory; + size = shl(dpb.drm+1,2); + call print$console$buffer(. + (' Enable hashing for drive $')); + call write$console('A'+i); + call print$console$buffer(.(': $')); + call get$response(.hash(i)); + call crlf; + if not hash(i) then + do; + dph.hash = 0ffffh; + end; + else + if not bnk$swt then + do; + nohash = false; + hash$data(i) = size; + hash$space = hash$space + size; + end; + else + do; + if (seg$no := get$seg(2,size)) = 0ffh then + call error(false,0,.( + 'Unable to allocate space for hash table.$')); + else + do; + dph.hbank = mem$tbl(seg$no).bank; + dph.hash = shl(double(mem$tbl(seg$no).base),8) + + (shl(double(mem$tbl(seg$no).len),8) - + mem$tbl(seg$no).attr); + mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - size; + end; + end; + end; + end; + end; + if (not bnk$swt) and (nohash) then + do; + res$flg = 2; + scb$pg = scb$pg + 2; + res$pg = res$pg + 2; + end; + end setup$hash; + + get$alloc$chk: + procedure; + declare (i,dbl$alloc) byte; + declare printed boolean; + + do i = 0 to 15; + alloc(i) = 0; + chk(i) = 0; + end; + + if not dbl$alv and not bnk$swt then + dbl$alloc = 1; + else + dbl$alloc = 2; + + alloc$space = 0; + chk$space = 0; + printed = false; + do i = 0 to 15; + if drvtbl(i) <> 0 then + do; + dph$adr = drvtbl(i) + .memory; + dpb$adr = dph.dpb + .memory; + if dph.alv = 0fffeh then + do; + call print$console$buffer(.(cr,lf, + 'Setting up Allocation vector for drive $')); + call write$console('A'+i); + call write$console(':'); + printed = true; + alloc(i) = (dpb.dsm/8 + 1) * dbl$alloc; + alloc$space = alloc$space + alloc(i); + end; + if dph.csv = 0fffeh then + do; + call print$console$buffer(.(cr,lf, + 'Setting up Checksum vector for drive $')); + call write$console('A'+i); + call write$console(':'); + printed = true; + chk(i) = (dpb.drm + 4)/4; + chk$space = chk$space + chk(i); + dpb.cks = (dpb.cks and 8000h) or chk(i); + end; + end; + end; + if printed then + call crlf; + end get$alloc$chk; + + setup$mem$seg$tbl: + procedure; + declare (i,j,ok,accept,mlow,mhigh,tlow,thigh) byte; + declare mem$temp address; + + /* Create first memory segment table entry */ + mem$tbl(0).base = bnk$pg; + mem$tbl(0).len = bnk$top - bnk$pg; + mem$tbl(0).attr = 0; + mem$tbl(0).bank = 0; + + accept = false; + + call print$console$buffer( + .(lf,cr, + '*** Bank 1 and Common are not included ***', + lf,cr, + '*** in the memory segment table. ***', + lf,cr,lf,cr,'$')); + query = quest(10); + call get$param (.('Number of memory segments $'), + .num$seg,10); + call print$console$buffer(.(cr,lf, + 'CP/M 3 Base,size,bank ($')); + call dsply$hex(mem$tbl(0).base); + call write$console(','); + call dsply$hex(mem$tbl(0).len); + call write$console(','); + call dsply$hex(mem$tbl(0).bank); + call print$console$buffer(.(')',lf,cr,'$')); + + do while not accept; + /* Bank switched memory segment table input */ + call print$console$buffer (.(cr,lf, + 'Enter memory segment table:',lf,cr,'$')); + do j = 1 to num$seg; + ok = false; + do while not ok; + query = quest(11 + j - 1); + call get$param (.(' Base,size,bank ','$'), + .mem$tbl(j),16); + mem$tbl(j).attr = shl(double(mem$tbl(j).len),8); + if mem$tbl(j).len = 0 then + do; + call error(false,0,.( + 'Zero length segment not allowed.$')); + end; + else + if mem$tbl(j).bank = 1 then + do; + call error(false,0,.( + 'Bank one not allowed.$')); + end; + else + do; + tlow = mem$tbl(j).base; + mem$temp = double(tlow) + double(mem$tbl(j).len); + if (high(mem$temp) <> 0) or (low(mem$temp) > bnk$top) then + do; + call print$console$buffer(.(cr,lf,'ERROR: ', + 'Memory conflict - segment trimmed.', + cr,lf,'$')); + mem$tbl(j).len = bnk$top - tlow; + mem$tbl(j).attr = shl(double(bnk$top - tlow),8); + end; + else + do; + thigh = low(mem$temp); + i = 0; + ok = true; + do while ((i < j) and ok); + mlow = mem$tbl(i).base; + mhigh = mlow + mem$tbl(i).len; + if mem$tbl(i).bank = mem$tbl(j).bank then + do; + if (mhigh >= thigh) and (tlow >= mlow) then + do; + call error(false,0,.( + 'Memory conflict - cannot trim segment.$')); + ok = false; + end; + else + if ((thigh > mhigh) and (mhigh > tlow)) then + do; + call print$console$buffer(.(cr,lf,'ERROR: ', + 'Memory conflict - segment trimmed.', + cr,lf,'$')); + mem$tbl(j).base = mhigh; + ok = false; + end; + else + if ((thigh > mlow) and (mlow > tlow)) then + do; + call print$console$buffer(.(cr,lf,'ERROR: ', + 'Memory conflict - segment trimmed.', + cr,lf,'$')); + mem$tbl(j).len = mlow - tlow; + mem$tbl(j).attr = shl(double(mlow-tlow),8); + ok = false; + end; + end; + i = i + 1; + end; + end; + end; + end; + end; + call crlf; + do j = 0 to num$seg; + if j = 0 then + call print$console$buffer (.(' CP/M 3 Sys ','$')); + else + do; + call print$console$buffer (.(' Memseg No. ','$')); + call dsply$hex(j-1); + end; + call dsply$hex$high$adr (mem$tbl(j).base); + call dsply$hex$high$adr (mem$tbl(j).len); + if bnk$swt then + do; + call print$console$buffer (.(' Bank ','$')); + call dsply$hex (mem$tbl(j).bank); + end; + call crlf; + end; + query = false; + accept = true; + call print$console$buffer (.(cr,lf, + 'Accept new memory segment table entries ','$')); + call get$response (.accept); + end; /* do while not accept */ + call crlf; + end setup$mem$seg$tbl; + + get$default$file: + procedure; + declare ret byte; + + call print$console$buffer(.( + 'Default entries are shown in (parens).',cr,lf, + 'Default base is Hex, precede entry with # for decimal', + cr,lf,'$')); + if (ret:=open$file(.data$fcb)) <> 255 then + do; + call movef(8,.data$fcb+1,.fcb$msg); + call movef(3,.data$fcb+9,.fcb$msg+9); + call print$console$buffer(.( + cr,lf,'Use GENCPM.DAT for defaults $')); + ret = 0ffh; + call get$response(.ret); + call crlf; + if ret then + call getdef; + call close$file(.data$fcb); + end; + else + do; + display = true; + automatic = false; + end; + + end get$default$file; + + setup$system$dat: + procedure; + declare (i,j,ok,temp) byte; + ok = false; + call get$default$file; + do while not ok; + query = quest(155); + call crlf; + call print$console$buffer(.('Create a new GENCPM.DAT file $')); + call get$response(.crdatf); + query = quest(0); + call crlf; + call crlf; + call print$console$buffer(.('Display Load Map at Cold Boot $')); + call get$response(.prt$msg); + call crlf; + call crlf; + query = quest(1); + con$wid = con$wid + 1; + call get$param (.('Number of console columns $'), + .con$wid,10); + con$wid = con$wid - 1; + query = quest(2); + con$pag = con$pag + 1; + call get$param (.('Number of lines in console page $'), + .con$pag,10); + con$pag = con$pag - 1; + query = quest(3); + call print$console$buffer(. + ('Backspace echoes erased character $')); + call get$response (.bck$spc); + call crlf; + query = quest(4); + call print$console$buffer(. + ('Rubout echoes erased character $')); + call get$response (.rubout); + call crlf; + call crlf; + query = quest(5); + err1: + call print$console$buffer(.('Initial default drive ($')); + call write$console('A'+bdrive); + call print$console$buffer(.(':) ? $')); + call read$console$buffer(.lnbfr); + if lnbfr(1) <> 0 then + do; + temp = upper(lnbfr(2))-'A'; + if not valid$drive(temp) then + goto err1; + bdrive = temp; + end; + call crlf; + call crlf; + query = quest(6); + call get$param (.('Top page of memory $'), + .mem$top,16); + os$top = shl(double(mem$top),8) + 100h; + query = quest(7); + call print$console$buffer(.('Bank switched memory $')); + call get$response (.bnk$swt); + call crlf; + non$bnk = not bnk$swt; + if bnk$swt then + do; + query = quest(8); + call get$param (.('Common memory base page $'), + .bnk$top,16); + call crlf; + query = quest(9); + call print$console$buffer(.('Long error messages $')); + call get$response(.lerror); + call crlf; + end; + else + do; + query = quest(156); + call crlf; + call print$console$buffer(.('Double allocation vectors $')); + call get$response(.dbl$alv); + call crlf; + bnk$top = 0; + end; + query = false; + ok = true; + call crlf; + call print$console$buffer(.('Accept new system definition $')); + call get$response(.ok); + call crlf; + end; + save$mem$top = mem$top; + mem$top = mem$top + 1; + rubout = not rubout; + end setup$system$dat; + + setup$CPM80$sys: + procedure; + declare i byte; + call print$console$buffer (.( cr,lf,lf, + 'CP/M 3.0 System Generation',cr,lf, + 'Copyright (C) 1982, Digital Research', + cr,lf,cr,lf,'$')); + call delete$file (.fcbout); + call create$file (.fcbout); + FCBout(32) = 0; + do i = 0 to 127; + system$data(i) = 0; + end; + do i = 128 to 255; + system$data(i) = '$'; + end; + prt$msg$ptr = 128; + call movef(3,.(cr,lf,' '),.system$data(prt$msg$ptr)); + prt$msg$ptr = 131; + call movef(8,.FCBout+1,.fcb$msg); + call movef(3,.FCBout+9,.fcb$msg+9); + call set$DMA$address (.sctbfr); + call write$record (.FCBout); + call write$record (.FCBout); + end setup$CPM80$sys; + + initialization: + procedure; + declare i byte; + + nmb$sect = shr ((maxb-.sctbfr+1),7); + + do i = 0 to 15; + hash$data(i) = 0; + end; + hash$space = 0; + + if fcb(1) = 'A' then + do; + automatic = true; + display = false; + do i = 0 to 154; + quest(i) = false; + end; + end; + else + do; + automatic = false; + display = true; + end; + if fcb16(1) = 'D' then + do; + display = true; + end; + query = false; + + end initialization; + + +/* + G E N C P M M a i n P r o g r a m +*/ + + res$flg = 0; + display = true; + call setup$CPM80$sys; + call initialization; + call setup$system$dat; + + call get$file$info; + + if bios$atts(2) <> 0 + then res$bios$len = high(bios$atts(2) + 255); + else res$bios$len = high(bios$atts(0) + 255); + bios$pg = mem$top - res$bios$len; + bnk$off = bnk$top - (high(bios$atts(0) + 255) - res$bios$len); + bnk$pg = bnk$off - high(bnk$atts(0) + 255); + + call load(.bios$fcb,.bios$atts); + + call page$chop; + + + if not bnk$swt then + do; + scb$pg = bios$pg - (3 - res$flg); + res$pg = bios$pg - high(res$atts(0) + 255) + res$flg; + end; + else + do; + scb$pg = bios$pg - 1; + res$pg = bios$pg - high(res$atts(0) + 255); + end; + + if need$tbl then + do; + call get$alloc$chk; + if bnk$swt then + do; + bnk$off = bnk$top - (high(bios$atts(0) + alloc$space + + chk$space + 255) - res$bios$len); + bnk$pg = bnk$off - high(bnk$atts(0) + 255); + xmove$implemented = get$xmove; + call setup$mem$seg$tbl; + if (not xmove$implemented) then + do len = 0 to 15; + record(len).altbnks = false; + end; + end; + else + xmove$implemented = false; + if not dont$hash then + call setup$hash; + call setbuf; + end; + + res$len = res$bios$len; + + offset = bios$pg; + call reloc$module(.bios$fcb); + + if bnk$swt + then call display$layout(.('BNKBIOS3 SPR$'), + double(bios$pg)*256,res$bios$len); + else call display$layout(.('BIOS3 SPR$'), + double(bios$pg)*256,res$bios$len); + if not bnk$swt then + do; + len = res$bios$len; + off = 2; + call wrtbuf(len,.off); + common$len = len; + banked$len = 0; + end; + else + do; + len = high(bios$atts(0) + 255) - res$bios$len; + off = (high(res$atts(0) + 255) + res$bios$len) * 2 + 2; + call display$layout(.('BNKBIOS3 SPR$'),double(bnk$off)*256,len); + call wrtbuf(len,.off); + banked$len = len; + len = res$bios$len; + off = 2; + dma = dma - 80h; + call wrtbuf(len,.off); + common$len = len; + end; + + res$len = high(res$atts(0) + 255) - res$flg; + offset = res$pg; + call load(.res$fcb,.res$atts); + call reloc$module(.res$fcb); + call setup$scb; + dma = dma - (res$flg * 256); + len = high(res$atts(0) + 255) - res$flg; + if not bnk$swt + then call display$layout(.('BDOS3 SPR$'),double(res$pg)*256,len); + else call display$layout(.('RESBDOS3 SPR$'),double(res$pg)*256,len); + call wrtbuf(len,.off); + common$len = common$len + len; + + if bnk$swt then + do; + res$len = 0ffh; + offset = bnk$pg; + call load(.bnk$fcb,.bnk$atts); + call reloc$module(.bnk$fcb); + len = high(bnk$atts(0) + 255); + off = off + (high(bios$atts(0) + 255) - res$bios$len) * 2; + call display$layout(.('BNKBDOS3 SPR$'),double(bnk$pg)*256,len); + call wrtbuf(len,.off); + banked$len = banked$len + len; + end; + if not prt$msg then prt$msg$ptr = prt$msg$ptr - 3; + call movef(12,.(lf,cr,' 64K TPA',lf,cr),.system$data(prt$msg$ptr)); + res$pg = shr(res$pg,2); + system$data(prt$msg$ptr+3) = res$pg/10 + '0'; + system$data(prt$msg$ptr+4) = res$pg mod 10 + '0'; + prt$msg$ptr = prt$msg$ptr + 12; + sys$entry = bios$pg * 256; + call movef(36,.('Copyright (C) 1982, Digital Research'),.system$data(10h)); + call movef(6,.memory,.system$data(35h)); /* Copy Serial No. into header */ + FCBout(33) = 0; FCBout(34) = 0; FCBout(35) = 0; + system$data(0) = mem$top; + system$data(2) = bnk$top; + call movef(8,.FCBout+1,.fcb$msg); + call movef(3,.FCBout+9,.fcb$msg+9); + call set$DMA$address(.system$data); + call write$random$record(.FCBout); + FCBout(33) = 1; + call set$DMA$address(.system$data(128)); + call write$random$record(.FCBout); + call close$file(.fcbout); + + if crdatf then + do; /* create a new data file for GENCPM */ + crdatf = false; + mem$top = save$mem$top; + rubout = not rubout; + call movef(8,.data$fcb+1,.fcb$msg); + call movef(3,.data$fcb+9,.fcb$msg+9); + call crtdef; + end; + + display = true; + call print$console$buffer (.(cr,lf,lf, + '*** CP/M 3.0 SYSTEM GENERATION DONE ***','$')); + return; + + end plm; +end gencpm; diff --git a/software/CPM/cpm3/get.plm b/software/CPM/cpm3/get.plm new file mode 100644 index 0000000..929d96b --- /dev/null +++ b/software/CPM/cpm3/get.plm @@ -0,0 +1,939 @@ +$ TITLE('CP/M 3.0 --- GET user interface') +get: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* +Written: 30 July 82 by John Knight + 12 Sept 82 by Doug Huskey +*/ + +/******************************************** +* * +* LITERALS AND GLOBAL VARIABLES * +* * +********************************************/ + +declare + true literally '1', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + lf literally '10', + ctrlc literally '3', + ctrlx literally '18h', + bksp literally '8', + con$type literally '0', + aux$type literally '1', + con$width$offset literally '1ah', + ccp$flag$offset literally '18h', + get$rsx$init literally '128', + get$rsx$kill literally '129', + get$rsx$fcb literally '130', + cpmversion literally '30h'; + + declare ccp$flag byte; + declare con$width byte; + declare i byte; + declare begin$buffer address; + declare buf$length byte; + declare no$chars byte; + declare get$init$pb byte initial(get$rsx$init); + declare get$kill$pb byte initial(get$rsx$kill); + declare get$fcb$pb byte initial(get$rsx$fcb); + declare input$type byte; + + declare + sub$fcb (*) byte data (0,'SYSIN $$$'), + get$msg (*) byte data ('Getting console input from $'); + + /* scanner variables and data */ + declare + options(*) byte data + ('INPUT~FROM~FILE~STATUS~CONDITIONAL~', + 'FALSE~TRUE~CONSOLE~CONIN:~AUXILIARY~', + 'AUXIN:~END~CON:~AUX:~NOT~ECHO~FILTERED~SYSTEM~PROGRAM',0FFH), + + options$offset(*) byte data + (0,6,11,16,23,35,41,46,54,61,71,78,82,87,92,96,101,110,117,124), + + end$list byte data (0ffh), + + delimiters(*) byte data (0,'[]=, ./;',0,0ffh), + + SPACE byte data(5), + + buf$ptr address, + index byte, + endbuf byte, + j byte initial(0), + delimiter byte; + + declare end$of$string byte initial ('~'); + + declare getpb structure + (input$type byte, + echo$flag byte, + filtered$flag byte, + program$flag byte) + initial(con$type,true,true,true); + + declare scbpd structure + (offset byte, + set byte, + value address); + + declare parse$fn structure + (buff$adr address, + fcb$adr address); + + declare plm label public; + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + printchar: + procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + + conin: + procedure byte; + return mon2(6,0fdh); + end conin; + + print$buf: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buf; + + read$console$buf: + procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address address; + declare max byte; + new$max = max; + call mon1(10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of characters input */ + end read$console$buf; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + check$con$stat: procedure byte; + return mon2(11,0); + end check$con$stat; + + open$file: + procedure (fcb$address) address; + declare fcb$address address; + return mon3(15,fcb$address); + end open$file; + + set$dma: procedure(dma); + declare dma address; + call mon1(26,dma); + end set$dma; + + /* 0ffh ==> return BDOS errors */ + return$errors: procedure (mode); + declare mode byte; + call mon1(45,mode); + end return$errors; + + getscbbyte: procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); + end getscbbyte; + + setscbbyte: + procedure (offset,value); + declare offset byte; + declare value byte; + scbpd.offset = offset; + scbpd.set = 0ffh; + scbpd.value = double(value); + call mon1(49,.scbpd); + end setscbbyte; + +get$console$mode: procedure address; +/* returns console mode */ + return mon3(6dh,0ffffh); +end get$console$mode; + +set$console$mode: procedure (new$value); + declare new$value address; + call mon1(6dh,new$value); +end set$console$mode; + +rsx$call: procedure (rsxpb) address; +/* call Resident System Extension */ + declare rsxpb address; + return mon3(60,rsxpb); +end rsx$call; + +parse: procedure (pfcb) address external; + declare pfcb address; +end parse; + +getf: procedure (input$type) external; + declare input$type address; +end getf; + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr,idx$ptr); + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + idx$ptr address, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index based idx$ptr byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + /* No skip for GET */ + do while ((delimiter < 1) or (delimiter > 9)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while ((delimiter := separator(charac)) = SPACE); + buf$ptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + if delimiter = 9 then + return; + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return; + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return; + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then + buf$ptr = buf$ptr + 1; + else + delimiter = 5; + return; + +end opt$scanner; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* fill string @ s for c bytes with f */ +fill: procedure(s,f,c); + declare s address; + declare (f,c) byte; + declare a based s byte; + do while (c:=c-1) <> 255; + a=f; + s=s+1; + end; +end fill; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* The error processor. This routine prints the command line + with a carot '^' under the offending delimiter, or sub-string. + The code passed to the routine determines the error message + to be printed beneath the command string. */ + +error: procedure (code); + declare (code,i,j,nlines,rem) byte; + declare (string$ptr,tstring$ptr) address; + declare chr1 based string$ptr byte; + declare chr2 based tstring$ptr byte; + declare carot$flag byte; + +print$command: procedure (size); + declare size byte; + do j=1 to size; /* print command string */ + call printchar(chr1); + string$ptr = string$ptr + 1; + end; + call crlf; + do j=1 to size; /* print carot if applicable */ + if .chr2 = buf$ptr then do; + carot$flag = true; + call printchar('^'); + end; + else + call printchar(' '); + tstring$ptr = tstring$ptr + 1; + end; + call crlf; +end print$command; + + carot$flag = false; + string$ptr,tstring$ptr = begin$buffer; + con$width = getscbbyte(con$width$offset); + if con$width < 40 then con$width = 40; + nlines = buf$length / con$width; /* num lines to print */ + rem = buf$length mod con$width; /* num extra chars to print */ + if code <> 2 then do; + if ((code = 1) or (code = 4)) then /* adjust carot pointer */ + buf$ptr = buf$ptr - 1; /* for delimiter errors */ + else if code <> 5 then + buf$ptr = buf$ptr - endbuf - 1; /* all other errors */ + end; + call crlf; + do i=1 to nlines; + tstring$ptr = string$ptr; + call print$command(con$width); + end; + call print$command(rem); + if carot$flag then + call print$buf(.('Error at the ''^'': $')); + else + call print$buf(.('Error at end of line: $')); + if con$width < 65 then + call crlf; + do case code; + call print$buf(.('Invalid option or modifier$')); + call print$buf(.('End of line expected$')); + call print$buf(.('Invalid file specification$')); + call print$buf(.('Invalid command$')); + call print$buf(.('Invalid delimiter$')); + call print$buf(.('File not found$')); + end; + call crlf; + call mon1(0,0); +end error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +ucase: procedure (char) byte; + declare char byte; + if char >= 'a' then + if char < '{' then + return (char-20h); + return char; +end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +getucase: procedure byte; + declare c byte; + c = ucase(conin); + return c; +end getucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +getpasswd: procedure; + declare (i,c) byte; + call crlf; + call crlf; + call print$buf(.('Enter Password: $')); +retry: + call fill(.fcb16,' ',8); + do i=0 to 7; +nxtchr: + if (c:=getucase) >= ' ' then + fcb16(i)=c; + if c = cr then + go to exit; + if c = ctrlx then + go to retry; + if c = bksp then do; + if i < 1 then + goto retry; + else do; + fcb16(i := i - 1) = ' '; + goto nxtchr; + end; + end; + if c = 3 then + call mon1(0,0); + end; +exit: + c = check$con$stat; /* clear raw i/o mode */ +end getpasswd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +print$fn: procedure (fcb$ad); + declare k byte; + declare fcb$ad address; + declare driv based fcb$ad byte; + declare fn based fcb$ad (12) byte; + + call print$buf(.('file: $')); + if driv <> 0 then do; + call printchar('@'+driv); + call printchar(':'); + end; + do k=1 to 11; + if k=9 then + call printchar('.'); + if fn(k) <> ' ' then + call printchar(fn(k) and 07fh); + end; +end print$fn; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +try$open: procedure; + declare (error$code,a) address; + declare prog$flag based a byte; + declare code byte; + + + error$code = rsx$call(.get$fcb$pb); + if error$code <> 0ffh then do; /* 0ffh means no active get */ + a = error$code - 2; + if prog$flag then /* program input only? */ + error$code = rsx$call(.get$kill$pb); /* kill if so */ + end; + call setdma(.fcb16); /* set dma to password */ + call return$errors(0ffh); + error$code = open$file(.fcb); + call return$errors(0); + if low(error$code) = 0ffh then + if (code := high(error$code)) <> 0 then do; + if code = 7 then do; + call getpasswd; + call crlf; + call setdma(.fcb16); + end; + error$code=open$file(.fcb); + end; + else do; + buf$ptr = parse$fn.buff$adr; /* adjust pointer to file */ + call error(5); /* file not found */ + end; + call print$buf(.get$msg); + if getscbbyte(26) < 48 then + call crlf; /* console width */ + call print$fn(.fcb); + call getf(.getpb); +end try$open; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +submit: procedure(adr) byte; + declare adr address; + declare fn based adr (12) byte; + declare (i,match) byte; + + compare: procedure(j); + dcl j byte; + if (fn(j) and 07fh) = sub$fcb(j) then + return; + match = false; + end compare; + + match = true; + do i = 1 to 3; /* sub = SYS $$$ */ + call compare(i); + call compare(i+8); + end; + return match; +end submit; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +kill$rsx: procedure; + declare (fcb$adr,a) address; + + if delimiter <> 9 then /* check for eoln */ + call error(1); + /* remove SUBMIT & GET rsx modules */ + do while (fcb$adr:=rsx$call(.get$fcb$pb)) <> 0ffh; + a = rsx$call(.get$kill$pb); + if submit(fcb$adr) then + call print$buf(.('SUBMIT of $')); + else + call print$buf(.('GET from $')); + call print$fn(fcb$adr); + call print$buf(.(' stopped$')); + call crlf; + end; + call print$buf(.get$msg); + call print$buf(.('console$')); + call mon1(0,0); +end kill$rsx; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +end$rsx: procedure; + declare (a,fcb$adr) address; + + if delimiter <> 9 then /* check for eoln */ + call error(1); + if (fcb$adr := rsx$call(.get$fcb$pb)) <> 0ffh then + if not submit(fcb$adr) then do; + a = rsx$call(.get$kill$pb); + call print$buf(.('GET from $')); + call print$fn(fcb$adr); + call print$buf(.(' stopped$')); + call crlf; + end; + + /* determine where console input comes from now */ + call print$buf(.get$msg); + fcb$adr = rsx$call(.get$fcb$pb); + if fcb$adr = 0ffh then + call print$buf(.('console$')); + else do; + if getscbbyte(26) < 48 then + call crlf; /* console width */ + call print$fn(fcb$adr); + end; + call mon1(0,0); +end end$rsx; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +set$rsx$mode: procedure (bit$value); + declare bit$value byte; + declare temp address; + temp = get$console$mode; + temp = temp and 111111$00$11111111b; /* mask off bits to be set */ + if bit$value <> 0 then + temp = temp or (255 + bit$value); + call set$console$mode(temp); +end set$rsx$mode; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +process$file: procedure(buf$adr); + declare negate byte; + declare status address; + declare buf$adr address; + declare char based status byte; + parse$fn.buff$adr = buf$adr; + parse$fn.fcb$adr = .fcb; + status = parse(.parse$fn); + if status = 0ffffh then + call error(2); /* bad file */ + if status = 0 then /* eoln */ + call try$open; /* try$open does not return */ + else + buf$ptr = status + 1; /* position buf$ptr past '[' */ + if char <> '[' then /* PROCESS OPTIONS */ + call error(4); + do while ((delimiter<>2) and (delimiter<>9)); + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 4 then do; /* STATUS */ + if delimiter <> 3 then /* '=' */ + call error(4); + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 5 then /* CONDITIONAL */ + call set$rsx$mode(0); + else if index = 6 then /* FALSE */ + call set$rsx$mode(1); + else if index = 7 then /* TRUE */ + call set$rsx$mode(2); + else + call error(0); /* Not a valid option */ + end; + else do; /* ECHO, FILTER, & SYSTEM options */ + negate=false; + if index = 15 then do; + negate = true; + call opt$scanner(.options(0),.options$offset(0),.index); + end; + if index = 16 then do; /* ECHO */ + if negate then + getpb.echo$flag = false; + else + getpb.echo$flag = true; + end; + else if index = 17 then do; /* FILTER */ + if negate then + getpb.filtered$flag = false; + else + getpb.filtered$flag = true; + end; + else if index = 18 then do; /* SYSTEM */ + if negate then + getpb.program$flag = true; + else + getpb.program$flag = false; + end; + else if index = 19 then do; /* PROGRAM */ + if negate then + getpb.program$flag = false; + else + getpb.program$flag = true; + end; + else + call error(0); + end; + end; + call try$open; /* all set up, so do open */ +end process$file; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = 9); /* tabs & spaces */ + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/********************************* +* * +* M A I N P R O G R A M * +* * +*********************************/ + +plm: + do; + if (low(version) < cpmversion) or (high(version)=1) then do; + call print$buf(.('Requires CP/M 3.0$')); + call mon1(0,0); + end; + if not input$found(.tbuff(1)) then do; /* just GET */ + call print$buf(.('CP/M 3 GET Version 3.0',cr,lf,'$')); + call print$buf(.('Get console input from a file',cr,lf,'$')); + call print$buf(.('Enter file: $')); + no$chars = read$console$buf(.tbuff(0),128); + call crlf; + tbuff(1) = ' '; /* blank out nc field */ + tbuff(no$chars+2) = 0; /* mark eoln */ + if not input$found(.tbuff(1)) then /* quit, no file name */ + call mon1(0,0); + do i=1 to no$chars; /* make input capitals */ + tbuff(i+1) = ucase(tbuff(i+1)); + end; + begin$buffer = .tbuff(2); + buf$length = no$chars; + buf$ptr = .tbuff(2); + call process$file(.tbuff(2)); + end; + else do; /* Get with input */ + i = 1; /* skip over leading spaces */ + do while (tbuff(i) = ' '); + i = i + 1; + end; + begin$buffer = .tbuff(1); /* note beginning of input */ + buf$length = tbuff(0); /* note length of input */ + buf$ptr = .tbuff(i); /* set up for scanner */ + index = 0; + delimiter = 1; + call opt$scanner(.options(0),.options$offset(0),.index); + if (index=10) or (index=11) or (index=14) then do; /* AUX */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 1 then /* INPUT */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 2 then /* FROM */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 3 then do; /* FILE */ + getpb.input$type=aux$type; + call process$file(buf$ptr); + end; + else do; + if (index=10) or (index=11) or (index=14) then /* AUX */ + call kill$rsx; + else + call error(3); + end; + end; + else do; /* not AUX */ + if index = 12 then /* END */ + call end$rsx; + if (index=8) or (index=9) or (index=13) then do; /* CONSOLE */ + if delimiter = 9 then + call kill$rsx; + else + call opt$scanner(.options(0),.options$offset(0),.index); + end; + if index = 1 then /* INPUT */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 2 then /* FROM */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 3 then /* FILE */ + call process$file(buf$ptr); + if (index=8) or (index=9) or (index=13) then /* CONIN:, CONSOLE */ + call kill$rsx; + else + call error(3); + end; + end; + end; +end get; diff --git a/software/CPM/cpm3/getdef.plm b/software/CPM/cpm3/getdef.plm new file mode 100644 index 0000000..19199c6 --- /dev/null +++ b/software/CPM/cpm3/getdef.plm @@ -0,0 +1,338 @@ +$title('GENCPM Token File parser') +get$sys$defaults: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 20 Sept 82 by Bruce Skidmore +*/ + + declare true literally '0FFH'; + declare false literally '0'; + declare forever literally 'while true'; + declare boolean literally 'byte'; + declare cr literally '0dh'; + declare lf literally '0ah'; + declare tab literally '09h'; + +/* + D a t a S t r u c t u r e s +*/ + + declare data$fcb (36) byte external; + + declare quest (156) boolean external; + + declare display boolean external; + + declare symbol (8) byte; + + declare lnbfr (14) byte external; + + declare buffer (128) byte at (.memory); + + declare symtbl (20) structure( + token(8) byte, + len byte, + flags byte, + qptr byte, + ptr address) external; + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + +/* + B D O S P r o c e d u r e & F u n c t i o n C a l l s +*/ + + system$reset: + procedure external; + end system$reset; + + write$console: + procedure (char) external; + declare char byte; + end write$console; + + print$console$buffer: + procedure (buffer$address) external; + declare buffer$address address; + end print$console$buffer; + + open$file: + procedure (fcb$address) byte external; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + end open$file; + + close$file: + procedure (fcb$address) external; + declare fcb$address address; + end close$file; + + set$DMA$address: + procedure (DMA$address) external; + declare DMA$address address; + end set$DMA$address; + + crlf: + procedure external; + end crlf; + + dsply$dec$adr: + procedure (val) external; + declare val address; + end dsply$dec$adr; + +/* + M a i n G E T D E F P r o c e d u r e +*/ + getdef: + procedure public; + + declare buffer$index byte; + declare index byte; + declare end$of$file byte; + declare line$count address; + + err: + procedure(term$code,msg$adr); + declare (term$code,save$display) byte; + declare msg$adr address; + + save$display = display; + display = true; + call print$console$buffer(.('ERROR: $')); + call print$console$buffer(msg$adr); + call print$console$buffer(.(' at line $')); + call dsply$dec$adr(line$count); + if term$code then + call system$reset; + call crlf; + display = save$display; + end err; + + inc$ptr: + procedure; + + if buffer$index = 127 then + do; + buffer$index = 0; + if mon2(20,.data$fcb) <> 0 then + end$of$file = true; + end; + else + buffer$index = buffer$index + 1; + end inc$ptr; + + get$char: + procedure byte; + declare char byte; + + call inc$ptr; + char = buffer(buffer$index); + do while (char = ' ') or (char = tab) or (char = lf); + if char = lf then + line$count = line$count + 1; + call inc$ptr; + char = buffer(buffer$index); + end; + if (char >= 'a') and (char <= 'z') then + char = char and 0101$1111b; /* force upper case */ + if char = 1ah then + end$of$file = true; + return char; + end get$char; + + get$sym: + procedure; + declare (i,sym$char) byte; + declare got$sym boolean; + + got$sym = false; + do while (not got$sym) and (not end$of$file); + do i = 0 to 7; + symbol(i) = ' '; + end; + sym$char = get$char; + i = 0; + do while (i < 8) and (sym$char <> '=') and + (sym$char <> cr) and (not end$of$file); + symbol(i) = sym$char; + sym$char = get$char; + i = i + 1; + end; + do while (sym$char <> '=') and (sym$char <> cr) and (not end$of$file); + sym$char = get$char; + end; + if not end$of$file then + do; + if (sym$char = '=') and (i > 0) then + got$sym = true; + else + do; + if (sym$char = '=') then + call err(false,.('Missing parameter variable$')); + else + if i <> 0 then + call err(false,.('Equals (=) delimiter missing$')); + do while (sym$char <> cr) and (not end$of$file); + sym$char = get$char; + end; + end; + end; + end; + end get$sym; + + get$val: + procedure; + declare (flags,i,val$char) byte; + declare val$adr address; + declare val based val$adr byte; + declare (base,inc,lnbfr$index) byte; + + val$char = get$char; + i = 0; + do while (i < lnbfr(0)) and (val$char <> cr) and (not end$of$file); + lnbfr(i+2) = val$char; + i = i + 1; + lnbfr(1) = i; + val$char = get$char; + end; + do while (val$char <> cr) and (not end$of$file); + val$char = get$char; + end; + inc = 0; + lnbfr$index = 2; + if i > 0 then + do; + val$adr = symtbl(index).ptr; + flags = symtbl(index).flags; + if (flags and 8) <> 0 then + do; + if (flags and 10h) <> 0 then + inc = symbol(7) - 'A'; + else + if (symbol(7) >= '0') and (symbol(7) <= '9') then + inc = symbol(7) - '0'; + else + inc = 10 + (symbol(7) - 'A'); + val$adr = val$adr + (inc * symtbl(index).len); + end; + if lnbfr(lnbfr$index) = '?' then + do; + quest(inc+symtbl(index).qptr) = true; + display = true; + lnbfr$index = lnbfr$index + 1; + lnbfr(1) = lnbfr(1) - 1; + end; + if lnbfr(1) > 0 then + do; + if (flags and 1) <> 0 then + do; + if (lnbfr(lnbfr$index) >= 'A') and + (lnbfr(lnbfr$index) <= 'P') then + val = lnbfr(lnbfr$index) - 'A'; + else + call err(false,.('Invalid drive ignored$')); + end; + else + if (flags and 2) <> 0 then + do; + val = (lnbfr(lnbfr$index) = 'Y'); + end; + else + do; + base = 16; + val = 0; + do i = 0 to lnbfr(1) - 1; + val$char = lnbfr(i+lnbfr$index); + if val$char = ',' then + do; + val$adr = val$adr + 1; + val = 0; + base = 16; + end; + else + do; + if val$char = '#' then + base = 10; + else + do; + val$char = val$char - '0'; + if (base = 16) and (val$char > 9) then + do; + if val$char > 16 then + val$char = val$char - 7; + else + val$char = 0ffh; + end; + if val$char < base then + val = val * base + val$char; + else + call err(false,.('Invalid character$')); + end; + end; + end; + end; + end; + end; + end get$val; + + compare$sym: + procedure byte; + declare (i,j) byte; + declare found boolean; + + found = false; + i = 0; + do while ((i < 22) and (not found)); + j = 0; + do while ((j < 7) and (symtbl(i).token(j) = symbol(j))); + j = j + 1; + end; + if j = 7 then + found = true; + else + i = i + 1; + end; + if not found then + return 0ffh; + else + return i; + end compare$sym; + + line$count = 1; + call set$dma$address(.buffer); + buffer$index = 127; + end$of$file = false; + do while (not end$of$file); + call get$sym; + if not end$of$file then + do; + index = compare$sym; + if index <> 0ffh then + call get$val; + else + call err(false,.('Invalid parameter variable$')); + end; + end; + + end getdef; +end get$sys$defaults; diff --git a/software/CPM/cpm3/getf.asm b/software/CPM/cpm3/getf.asm new file mode 100644 index 0000000..7092f69 --- /dev/null +++ b/software/CPM/cpm3/getf.asm @@ -0,0 +1,487 @@ +$title('GETF - CP/M 3.0 Input Redirection - August 1982') + name getf +;****************************************************************** +; +; get 'Input Redirection Initializer' version 3.0 +; +; 11/30/82 - Doug Huskey +;****************************************************************** +; +; +; Copyright (c) 1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, Ca. +; 93950 +; +; +; generation procedure +; +; seteof get.plm +; seteof getscan.dcl +; seteof getf.asm +; seteof getscan.plm +; seteof parse.asm +; is14 +; asm80 getf.asm debug +; asm80 mcd80a.asm debug +; asm80 parse.asm debug +; plm80 get.plm pagewidth(100) debug optimize +; link mcd80a.obj,get.obj,parse.obj,getf.obj,plm80.lib to get.mod +; locate get.mod code(0100H) stacksize(100) +; era get.mod +; cpm +; objcpm get +; rmac getrsx +; link getrsx[op] +; era get.rsx +; ren get.rsx=getrsx.prl +; gencom get.com +; gencom get.com get.rsx +; +; +; +; This module is called as an external routine by the +; PL/M routines GET and SUBMIT. It is passed a structure +; with the following format: +; +; +; declare getpb structure +; (input$type byte, +; echo$flag byte, +; filtered$flag byte, +; program$flag byte); +; +; input$type = 0 > console input (default) +; = 1 > auxiliary output +; +; echo = true > echo input to real device +; (default) +; = false > don't echo input (output is +; still echoed) +; filtered = true > convert control characters +; to a printable form +; preceeded by an ^ in echo +; (default) +; = false > no character conversions +; program = false > continue until EOF or +; GET INPUT FROM CONSOLE +; command +; = true > active only until program +; termination +; + public getf + extrn mon1,fcb,memsiz +; +; +true equ 0ffffh +false equ 00000h +; +biosfunctions equ true ;intercept BIOS conin & constat +; +; +; low memory locations +; +wboot equ 0000h +wboota equ wboot+1 +; +; equates for non graphic characters +; +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +; +; BDOS function equates +; +cinf equ 1 ;read character +coutf equ 2 ;output character +crawf equ 6 ;raw console I/O +creadf equ 10 ;read buffer +cstatf equ 11 ;status +pchrf equ 5 ;print character +pbuff equ 9 ;print buffer +openf equ 15 ;open file +closef equ 16 ;close file +delf equ 19 ;delete file +dreadf equ 20 ;disk read +dmaf equ 26 ;set dma function +curdrv equ 25 +userf equ 32 ;set/get user number +scbf equ 49 ;set/get system control block word +rsxf equ 60 ;RSX function call +initf equ 128 ;GET initialization sub-function no. +killf equ 129 ;GET delete sub-function no. +jkillf equ 141 ;JOURNAL delete sub-function no. +; +; System Control Block definitions +; +scba equ 03ah ;offset of scbadr from SCB base +ccpflg2 equ 0b4h ;offset of 2nd ccp flag byte from pg bound +errflg equ 0aah ;offset of error flag from page boundary +conmode equ 0cfh ;offset of console mode from page boundary +listcp equ 0d4h ;offset of ^P flag from page boundary +common equ 0f9h ;offset of common memory base from pg. bound +wbootfx equ 068h ;offset of warm boot jmp from page. bound +constfx equ 06eh ;offset of constat jmp from page. bound +coninfx equ 074h ;offset of conin jmp from page. bound +conoufx equ 07ah ;offset of conout jmp from page. bound +listfx equ 080h ;offset of list jmp from page. bound +realdos equ 098h ;offset of real BDOS entry from pg. bound +; +; Restore mode equates (used with inr a, rz, rm, rpe, ret) +; +norestore equ 0ffh ;no BIOS interception +biosonly equ 07fh ;restore BIOS jump table only +stfix equ 080h ;restore BIOS jump table and + ;restore JMP in RESBDOS for constat +everything equ 0 ;restore BIOS jump table and jmps in + ;RESBDOS (default mode) +; +; Instructions +; +lxih equ 21h ;LXI H, instruction +jmpi equ 0c3h ;JMP instruction +shldi equ 22h ;SHLD instruction +; +;****************************************************************** +; START OF INITIALIZATION CODE +;****************************************************************** + + cseg + +getf: + ;get parameters + mov h,b + mov l,c ;HL = .(parameter block) + mov a,m ;input type 0=con:,1=aux: + cpi 1 ;is it aux? + jz notimp ;error if so + inx h + mov a,m ;echo/noecho mode + sta echo + inx h + mov a,m ;cooked/raw mode + sta cooked + inx h + mov a,m + sta program + ; + ;check if enough memory + ; + lhld memsiz + mov a,h + cpi 20h + jc nomem + ; + ;close to get those blocks in the directory + ; + lxi d,fcb + mvi c,closef + call mon1 + ; + ;check if drive specified + lxi h,fcb + mov a,m ;drive code + ora a ;default? + jnz movfcb + ; + ;set to current drive, if not + ; + push h ;save .fcb + mvi c,curdrv + call mon1 + pop h ;a=current drive, hl=.fcb + inr a + mov m,a ;set fcb to force drive select + ; +movfcb: ;copy default fcb up into data area for move to RSX + ; + lxi d,subfcb + lxi b,32 ;length of fcb + call ldir ;move it to subfcb + ; + ;initialize other variables to be moved to RSX + ; + call getusr ;get current user number + sta subusr ;save for redirection file I/O + call getscbadr + shld scbadr ;System Control Block address + ; + ;get real BDOS address (bypass chain to check for user break) + ; + mvi l,realdos + mov e,m + inx h + mov d,m + xchg + shld realbdos+1 + ; + ;check for user abort + ; + xchg + mvi l,conmode + mov a,m + ori 1 ;set ^C status mode + mov m,a + mvi c,cstatf + call realbdos ;check for user abort + ora a + jnz error1 ;abort if so + ; + ;get address of initialization table in RSX + ; + mvi c,rsxf + lxi d,journkill + call mon1 ;terminate any PUT INPUT commands + mvi c,rsxf + lxi d,rsxinit + call mon1 ;call GET.RSX initialization routine + push h ;save for move at end of setup + mov e,m + inx h + mov d,m ;DE = .RSXKILL flag + push d ;set flag to zero if successfull + inx h ;HL = .(real bios status routine) + push h + ; +if biosfunctions + ; + ;check if BIOS jump table looks valid (jmp in right places) + lhld wboota + lxi d,3 + dad d ;HL = .(jmp constat address) + mov a,m + cpi jmpi ;should be a jump + jnz bioserr ;skip bios redirection if not + dad d ;HL = .(jmp conin address) + mov a,m + cpi jmpi + jnz bioserr ;skip bios redirection if not + ; + ;fix up RESBDOS to do BIOS calls to intercepted functions + ; + lhld scbadr + mvi l,common+1 + mov a,m ;get high byte of common base + ora a + jnz fix0 ;high byte = zero if non-banked + mvi a,biosonly + sta biosmode + jmp trap ;skip code that fixes resbdos + ;fix BIOS constat +fix0: mvi l,constfx ;hl = .constfx in SCB + mov a,m + cpi jmpi ;is it a jump instruction? + jz fix1 ;jump if so + mvi a,biosonly ;whoops already changed + sta biosmode ;restore jump table only +fix1: mvi m,lxih + ;fix BIOS conin + mvi l,coninfx ;hl = .coninfx in SCB + mov a,m + cpi jmpi ;is it a jump instruction? + lda biosmode + jz fix2 ;jump if so + cpi biosonly + jnz bioserr ;error if conin is LXI but not constat + xra a ;zero accumulator to jnz below +fix2: cpi biosonly ;was const already an LXI h? + jnz fix3 ;jmp if not + mvi a,stfix ;restore constat jmp but not conin + sta biosmode +fix3: mvi m,lxih + ;get addresses of RSX const and conin traps +trap: pop h + mov c,m ;HL = .(.bios constat trap) + inx h + mov b,m ;BC = .bios constat trap in RSX + inx h + push h ;save for CONIN setup + ; + ;patch RSX constat entry into BIOS jump table + ;save real constat address in RSX exit table + ; + lhld wboota + lxi d,4 + dad d ;HL = .(jmp constat address) + shld constjmp ;save for RSX restore at end + mov e,m + mov m,c + inx h + mov d,m ;DE = constat address + mov m,b ;BIOS constat jumps to RSX + xchg + shld biosta ;save real constat address + ; + ;get address of RSX bios conin entry point + ; + pop h ;HL = .(RSX BIOS conin trap) + mov c,m + inx h + mov b,m + ; + ;patch RSX conin entry into BIOS jump table + ;save real conin address in RSX exit table + ; + xchg + inx h ;past jmp instruction + inx h ;HL = .(conin address) + shld coninjmp + mov e,m + mov m,c + inx h + mov d,m ;DE = conin address + mov m,b ;BIOS conin jumps to RSX + xchg + shld biosin ;save real conin address +endif + ; + ;move data area to RSX + ; +rsxmov: + pop h ;HL = .Kill flag in RSX + inr m ;switch from FF to 0 + lxi h,movstart + pop d ;RSX data area address + lxi b,movend-movstart + call ldir + mvi c,crawf + mvi e,0fdh ;raw console input + call mon1 ;prime RSX by reading a char + jmp wboot + +if biosfunctions +; +; can't do BIOS redirection +; +bioserr: + lxi d,nobios + mvi c,pbuff + call mon1 + lxi h,biosmode + mvi m,norestore ;no bios redirection + pop h ;throw away bios constat trap adr + jmp rsxmov +endif +; +; auxiliary redirection +; +notimp: + lxi d,notdone +error: + mvi c,pbuff + call mon1 +error1: mvi c,closef + lxi d,fcb + call mon1 + mvi c,delf + lxi d,fcb + call mon1 + jmp wboot +; +; insufficient memory +; +nomem: lxi d,memerr + jmp error + +; +; get/set user number +; +getusr: mvi a,0ffh ;get current user number +setusr: mov e,a ;set current user number (in A) + mvi c,userf + jmp mon1 +; +; get system control block address +; (BDOS function #49) +; +; exit: hl = system control block address +; +getscbadr: + mvi c,scbf + lxi d,data49 + jmp mon1 +; +data49: db scba,0 ;data structure for getscbadd +; +; copy memory bytes (emulates z80 ldir instruction) +; +ldir: mov a,m ;get byte + stax d ;store it at destination + inx h ;advance pointers + inx d + dcx b ;decrement byte count + mov a,c ;loop if non-zero + ora b + jnz ldir + ret +; +;****************************************************************** +; DATA AREA +;****************************************************************** + + ; +journkill: db jkillf +rsxinit: db initf +nobios: db 'WARNING: Cannot redirect from BIOS',cr,lf,'$' +notdone: + db 'ERROR: Auxiliary device redirection not implemented',cr,lf,'$' +memerr: + db 'ERROR: Insufficient Memory',cr,lf,'$' + ; +;****************************************************************** +; Following variables are initialized by GET.COM +; and moved to the GET RSX - Their order must not be changed +;****************************************************************** + ; + ; + ; +movstart: +inittable: ;addresses used by GET.COM for +scbadr: dw 0 ;address of System Control Block + ; + if biosfunctions ;GET.RSX initialization + ; +biosta: dw 0 ;set to real BIOS routine +biosin: dw 0 ;set to real BIOS routine + ; + ;restore only if changed when removed. +biosmode: + db 0 ;if non-zero change LXI @jmpadr to JMP + ;when removed. +restorebios: + ;hl = real constat routine + ;de = real conin routine + db shldi +constjmp: + dw 0 ;address of const jmp initialized by COM + xchg + db shldi +coninjmp: + dw 0 ;address of conin jmp initialized by COM + ret + endif + ; +realbdos: + jmp 0 ;address filled in by COM + ; +echo: db 1 +cooked: db 0 + ; +program: + db 0 ;true if only program input +subusr: db 0 ;user number for redirection file +subfcb: db 1 ;a: + db 'SYSIN ' + db 'SUB' + db 0,0 +submod: db 0 +subrc: db 0 + ds 16 ;map +subcr: db 0 + ; +movend: +;******************************************************************* + end +EOF + + \ No newline at end of file diff --git a/software/CPM/cpm3/getrsx.asm b/software/CPM/cpm3/getrsx.asm new file mode 100644 index 0000000..8759abd --- /dev/null +++ b/software/CPM/cpm3/getrsx.asm @@ -0,0 +1,873 @@ +title 'GET.RSX 3.0 - CP/M 3.0 Input Redirection - August 1982' +;****************************************************************** +; +; get 'Input Redirection Facility' version 3.0 +; +; 11/30/82 - Doug Huskey +; This RSX redirects console input and status from a file. +;****************************************************************** +; +; +true equ 0ffffh +false equ 00000h +; + maclib getrsx ;[JCE] The Get/Submit equate + maclib makedate ;[JCE] Build date +remove$rsx equ false ;true if RSX removes itself +; ;false if LOADER does removes +; +; +; generation procedure +; +; rmac getrsx +; xref getrsx +; link getrsx[op] +; ERA get.RSX +; REN get.RSX=getRSX.PRL +; GENCOM $1.COM get.RSX ($1 is either SUBMIT or GET) +; +; +; initialization procedure +; +; GETF makes a RSX function 60 call with a sub-function of +; 128. GETRSX returns the address of a data table containing: +; +; init$table: +; dw kill ;RSX remove flag addr in GET +; dw bios$constat ;bios entry point in GET +; dw bios$conin ;bios entry point in GET +; +; GETF initializes the data are between movstart: and movend: +; and moves it into GET.RSX. This means that data should not +; be reordered without also changing GETF.ASM. +; +bios$functions equ true ;intercept BIOS console functions +; +; low memory locations +; +wboot equ 0000h +bdos equ 0005h +bdosl equ bdos+1 +buf equ 0080h +; +; equates for non graphic characters +; +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlh equ 08h ; backspace +ctlp equ 10h ; prnt toggle +ctlr equ 12h ; repeat line +ctls equ 13h ; stop/start screen +ctlu equ 15h ; line delete +ctlx equ 18h ; =ctl-u + if submit +ctlz equ 0ffh + else +ctlz equ 1ah ; end of file + endif +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow +; +; BDOS function equates +; +cinf equ 1 ;read character +coutf equ 2 ;output character +crawf equ 6 ;raw console I/O +creadf equ 10 ;read buffer +cstatf equ 11 ;status +pchrf equ 5 ;print character +pbuff equ 9 ;print buffer +openf equ 15 ;open file +closef equ 16 ;close file +delf equ 19 ;delete file +dreadf equ 20 ;disk read +dmaf equ 26 ;set dma function +userf equ 32 ;set/get user number +scbf equ 49 ;set/get system control block word +loadf equ 59 ;loader function call +rsxf equ 60 ;RSX function call +ginitf equ 128 ;GET initialization sub-function no. +gkillf equ 129 ;GET delete sub-function no. +gfcbf equ 130 ;GET file display sub-function no. +pinitf equ 132 ;PUT initialization sub-funct no. +pckillf equ 133 ;PUT CON: delete sub-function no. +pcfcbf equ 134 ;return PUT CON: fcb address +plkillf equ 137 ;PUT LST: delete sub-function no. +plfcbf equ 138 ;return PUT LST:fcb address +gsigf equ 140 ;signal GET without [SYSTEM] option +jinitf equ 141 ;JOURNAL initialization sub-funct no. +jkillf equ 142 ;JOURNAL delete sub-function no. +jfcbf equ 143 ;return JOURNAL fcb address +; +; System Control Block definitions +; +scba equ 03ah ;offset of scbadr from SCB base +ccpflg equ 0b3h ;offset of ccpflags word from page boundary +ccpres equ 020h ;ccp resident flag = bit 5 +bdosoff equ 0feh ;offset of BDOS address from page boundary +errflg equ 0ach ;offset of error flag from page boundary +pg$mode equ 0c8h ;offset of page mode byte from pag. bound. +pg$def equ 0c9h ;offset of page mode default from pag. bound. +conmode equ 0cfh ;offset of console mode word from pag. bound. +listcp equ 0d4h ;offset of ^P flag from page boundary +dmaad equ 0d8h ;offset of DMA address from pg bnd. +usrcode equ 0e0h ;offset of user number from pg bnd. +dcnt equ 0e1h ;offset of dcnt, searcha & searchl from pg bnd. +constfx equ 06eh ;offset of constat JMP from page boundary +coninfx equ 074h ;offset of conin JMP from page boundary + + +;****************************************************************** +; RSX HEADER +;****************************************************************** + +serial: db 0,0,0,0,0,0 + +trapjmp: + jmp trap ;trap read buff and DMA functions +next: jmp 0 ;go to BDOS +prev: dw bdos +kill: db 0FFh ;0FFh => remove RSX at wstart +nbank: db 0 +rname: db 'GET ' ;RSX name +space: dw 0 +patch: db 0 + +;****************************************************************** +; START OF CODE +;****************************************************************** + +; +; ABORT ROUTINE +; +getout: + ; +if bios$functions + ; + ;restore bios jumps + lda restore$mode ;may be FF, 7f, 80 or 0 + inr a + rz ; FF = no bios interception + lhld biosin + xchg + lhld biosta + call restore$bios ;restore BIOS constat & conin jmps + rm ; 7f = RESBDOS jmps not changed + lhld scbadr + mvi l,constfx + mvi m,jmp + rpe ; 80 = conin jmp not changed + mvi l,coninfx + mvi m,jmp +endif + ret ; 0 = everything done +; +; ARRIVE HERE ON EACH BIOS CONIN OR CONSTAT CALL +; +; +bios$constat: + ; +if bios$functions + ; + ;enter here from BIOS constat + lxi b,4*256+cstatf ;b=offset in exit table + jmp bios$trap +endif +; +bios$conin: + ; +if bios$functions + ; + ;enter here from BIOS conin + lxi b,6*256+crawf ;b=offset in exit table + mvi e,0fdh + jmp biostrap +endif +; +; ARRIVE HERE AT EACH BDOS CALL +; +trap: + ; + ; + lxi h,excess + mvi b,0 + mov m,b +biostrap: + ;enter here on BIOS calls + + pop h ;return address + push h ;back to stack + lda trapjmp+2 ;GET.RSX page address + cmp h ;high byte of return address + jc exit ;skip calls on bdos above here + mov a,c ;function number + ; + ; + cpi cstatf ;status + jz intercept + cpi crawf + jz intercept ;raw I/O + lxi h,statflg ;zero conditional status flag + mvi m,0 + cpi cinf + jz intercept ;read character + cpi creadf + jz intercept ;read buffer + cpi rsxf + jz rsxfunc ;rsx function + cpi dmaf + jnz exit ;skip if not setting DMA + xchg + shld udma ;save user's DMA address + xchg +; +exit: + ;go to real BDOS + +if not bios$functions + ; + jmp next ;go to next RSX or BDOS + +else + mov a,b ;get type of call: + lxi h,exit$table ;0=BDOS call, 4=BIOS CONIN, 6=BIOS CONSTAT + call addhla + mov b,m ;low byte to b + inx h + mov h,m ;high byte to h + mov l,b ;HL = .exit routine + pchl ;gone to BDOS or BIOS +endif +; +; +rsxfunc: ;check for initialize or delete RSX functions + ldax d ;get RSX sub-function number + lxi h,init$table ;address of area initialized by COM file + cpi ginitf + rz + lda kill + ora a + jnz exit + ldax d + cpi gfcbf + lxi h,subfcb + rz +cksig: + cpi gsigf + jnz ckkill + lxi h,get$active + mvi a,gkillf + sub m ;toggle get$active flag + mov m,a ;gkillf->0 0->gkillf + +ckkill: + cpi gkillf ;remove this instance of GET? + jnz exit ;jump if not + + +restor: + lda get$active + ora a + rz + call getout ;bios jump fixup + +if submit + mvi c,closef + call subdos + mvi c,delf + call subdos ;delete SYSIN??.$$$ if not +endif + lxi h,kill + dcr m ;set to 0ffh, so we are removed + xchg ; D = base of this RSX + lhld scbadr + mvi l,ccpflg+1 ;hl = .ccp flag 2 in SCB + mov a,m + ani 0bfh + mov m,a ;turn off redirection flag + ;we must remove this RSX if it is the lowest one + lda bdosl+1 ;location 6 high byte + cmp d ;Does location 6 point to us + RNZ ;return if not +if remove$rsx + xchg ;D = scb page + lhld next+1 + shld bdosl + xchg ;H = scb page + mvi l,bdosoff ;HL = "BDOS" address in SCB + mov m,e ;put next address into SCB + inx h + mov m,d + xchg + mvi l,0ch ;HL = .previous RSX field in next RSX + mvi m,7 + inx h + mvi m,0 ;put previous into previous + ret +else + ; CP/M 3 loader does RSX removal if DE=0 + mvi c,loadf + lxi d,0 + jmp next ;ask loader to remove me +endif + +; +; +; INTERCEPT EACH BDOS CONSOLE INPUT FUNCTION CALL HERE +; +; enter with funct in A, info in DE +; +intercept: +; + lda kill + ora a + jnz exit ;skip if remove flag turned on + ; + ;switch stacks + lxi h,0 + dad sp + shld old$stack + lxi sp,stack + push b ;save function # + push d ;save info + ;check redirection mode + call getmode ;returns with H=SCB page + cpi 2 + jz skip ;skip if no redirection flag on + +if submit +; +; SUBMIT PROCESSOR +; + ;check if CCP is calling +ckccp: mvi l,pg$mode + mov m,H ;set to non-zero for no paging + mvi l,ccpflg+1 ;CCP FLAG 2 in SCB + mov a,m ;ccp flag byte 2 to A + ori 040h + mov m,a ;set redirection flag on + ani ccpres ;zero flag set if not CCP calling + lda ccp$line + jz not$ccp + ;yes, CCP is calling + ora a + jnz redirect ;we have a CCP line + ;CCP & not a CCP line + push h + call coninf ;throw away until next CCP line + lxi h,excess + mov a,m + ora a ;is this the first time? + mvi m,true + lxi d,garbage + mvi c,pbuff + cz next ;print the warning if so + pop h + lda kill + ora a + jz ckccp ;get next character (unless eof) + mov a,m + ani 7fh ;turn off disk reset (CCP) flag + mov m,a + jmp wboot ;skip if remove flag turned on +; +not$ccp: + ;no, its not the CCP + ora a + jnz skip ;skip if no program line + +else + lda program + ora a ;program input only? + mvi l,ccpflg+1 ;CCP FLAG 2 in SCB + mov a,m ;ccp flag byte 2 to A + jz set$no$page ;jump if [system] option + ;check if CCP is calling + ani ccpres ;zero flag set if not CCP calling + jz redirect ;jump if not the CCP + lxi h,ccpcnt ;decrement once for each + dcr m ;time CCP active + cm restor ;if 2nd CCP appearance + lxi d,cksig+1 + mvi c,rsxf ;terminate any GETs waiting for + call next ;us to finish + jmp skip + ; +set$no$page: + ori 40h ;A=ccpflag2, HL=.ccpflag2 + mov m,a ;set redirection flag on + mvi l,pg$mode + mov m,h ;set to non-zero for no paging +endif + ; + ; REDIRECTION PROCESSOR + ; +redirect: + ;break if control-C typed on console + call break + pop d + pop b ;recover function no. & info + push b ;save function + push d ;save info + mov a,c ;function no. to A + lxi h,retmon ;program return routine + push h ;push on stack + ; + ; + cpi creadf + jz func10 ;read buffer (returns to retmon) + cpi cinf + jz func1 ;read character (returns to retmon) + cpi cstatf + jz func11 ;status (returns to retmon) +; +func6: + ;direct console i/o - read if 0ffh + ;returns to retmon + mov a,e + inr a + jz dirinp ;0ffh in E for status/input + inr a + jz CONBRK ;0feh in E for status + lxi h,statflg + mvi m,0 + inr a + jz coninf ;0fdh in E for input + ; + ;direct output function + ; + jmp skip1 + ; +break: ; + ;quit if ^C typed + mvi c,cstatf + call real$bdos + ora a ;was ^C typed? + rz + pop h ;throw away return address + call restor ;remove this RSX, if so + mvi c,crawf + mvi e,0ffh + call next ;eat ^C if not nested + ; +skip: ; + ;reset ^C status mode + call getmode ;returns .conmode+1 + dcx h ;hl = .conmode in SCB + mov a,m + ani 0feh ;turn off control C status + mov m,a + ;restore the BDOS call + pop d ;restore BDOS function no. + pop b ;restore BDOS parameter + ;restore the user's stack +skip1: lhld old$stack + sphl + jmp exit ;goto BDOS + +; +retmon: + ;normal entry point, char in A + cpi ctlz + jz skip + lhld old$stack + sphl + mov l,a + ret ;to calling program + + +;****************************************************************** +; BIOS FUNCTIONS (REDIRECTION ROUTINES) +;****************************************************************** +; +; ;direct console input +dirinp: + call conbrk + ora a + rz +; +; +; get next character from file +; + ; +coninf: +getc: ;return ^Z if end of file + xra a + lxi h,cbufp ;cbuf index + inr m ;next chr position + cm readf ;read a new record + ora a + mvi b,ctlz ;EOF indicator + jnz getc1 ;jump if end of file + lda cbufp + lxi h,cbuf + call addhla ;HL = .char + ;one character look ahead + ;new char in B, current char in nextchr + mov b,m ;new character in B +getc1: mov a,b + cpi ctlz + push b + cz restor + pop b + lxi h,nextchr + mov a,m ;current character + cpi cr + mov m,b ;save next character + rnz + mov a,b ;A=character after CR + cpi lf ;is it a line feed + cz getc ;eat line feeds after a CR + ;this must return from above + ;rnz because nextchr = lf + ; +if submit + ; + mov a,b ;get nextchr + sui '<' ;program line? + sta ccp$line ;zero if so + cz getc ;eat '<' char + ;this must return from above + ;rnz because nextchr = < +endif + mvi a,cr ;get back the cr + ret ;with character in a +; +; set DMA address in DE +; +setdma: mvi c,dmaf + jmp next +; +; read next record +; +readf: mvi c,dreadf ;read next record of input to cbuf +subdos: push b + lxi d,cbuf + call setdma ;set DMA to our buffer + lhld scbadr + lxi d,sav$area ;10 byte save area + pop b ;C = function no. + push h ;save for restore + push d ;save for restore + call mov7 ;save hash info in save area + mvi l,usrcode ;HL = .dcnt in SCB + call mov7 ;save dcnt, searcha & l, user# & + dcx h ;multi-sector I/O count + mvi m,1 ;set multi-sector count = 1 + lxi d,subusr ;DE = .submit user # + mvi l,usrcode ;HL = .BDOS user number + ldax d + mov m,a + inx d + call next ;read next record + pop h ;HL = .sav$area + pop d ;DE = .scb + push psw ;save A (non-zero if error) + call mov7 ;restore hash info + mvi e,usrcode ;DE = .dcnt in scb + call mov7 ;restore dcnt search addr & len + lhld udma + xchg + call setdma ;restore DMA to program's buffer + xra a + sta cbufp ;reset buffer position to 0 + pop psw + ora a + ret ;zero flag set, if successful +; +; reboot from ^C +; +rebootx: + ;store 0fffeh in clp$errcode in SCB + lhld scbadr + mvi l,errflg + mvi m,0feh + inx h + mvi m,0ffh + jmp wboot +; +; +; get input redirection mode to A +; turn on ^C status mode for break +; return .conmode+1 in HL +; preserve registers BC and DE +; +getmode: + lhld scbadr + mvi l,conmode + mov a,m + ori 1 ;turn on ^C status + mov m,a + inx h + mov a,m + ani 3 ;mask off redirection bits + dcr a ;255=false, 0=conditional, 1=true, + ret ; 2=don't redirect input +; +; move routine +; +mov7: mvi b,7 + ; HL = source + ; DE = destination + ; B = count +move: mov a,m + stax d + inx h + inx d + dcr b + jnz move + ret +; +; add a to hl +; +addhla: add l + mov l,a + rnc + inr h + ret +; +;****************************************************************** +; BDOS CONSOLE INPUT ROUTINES +;****************************************************************** + +; +; February 3, 1981 +; +; +; console handlers + +conin: equ coninf +; +conech: + ;read character with echo + call conin! call echoc! rc ;echo character? + ;character must be echoed before return + push psw! call conout! pop psw + ret ;with character in A +; +echoc: + ;are we in cooked or raw mode? + lxi h,cooked! dcr m! inr m! rz ;return if raw + ;echo character if graphic + ;cr, lf, tab, or backspace + cpi cr! rz ;carriage return? + cpi lf! rz ;line feed? + cpi tab! rz ;tab? + cpi ctlh! rz ;backspace? + cpi ' '! ret ;carry set if not graphic +; +conbrk: ;STATUS - check for character ready + lxi h,statflg + mov b,m! mvi m,0ffh ;set conditional status flag true + call getmode ;check input redirection status mode + cpi 1! rz ;actual status mode => return true + ora a! rz ;false status mode => return false + ;conditional status mode => false unless prev func was status + mov a,b! ret ; return false if statflg false + ; return true if statflg true +; +; +ctlout: + ;send character in A with possible preceding up-arrow + call echoc ;cy if not graphic (or special case) + jnc conout ;skip if graphic, tab, cr, lf, or ctlh + ;send preceding up arrow + push psw! mvi a,ctl! call conout ;up arrow + pop psw! ori 40h ;becomes graphic letter + ;(drop through to conout) +; +; +; send character in A to console +; +conout: + mov e,a + lda echo + ora a + rz + mvi c,coutf + jmp next +; +; +read: ;read to buffer address (max length, current length, buffer) + xchg ;buffer address to HL + mov c,m! inx h! push h! mvi b,0 ;save .(current length) + ;B = current buffer length, + ;C = maximum buffer length, + ;HL= next to fill - 1 + readnx: + ;read next character, BC, HL active + push b! push h ;blen, cmax, HL saved + readn0: + call conin ;next char in A + pop h! pop b ;reactivate counters + cpi ctlz! jnz noteof ;end of file? + dcr b! inr b! jz readen ;skip if buffer empty + mvi a,cr ;otherwise return + noteof: + cpi cr! jz readen ;end of line? + cpi lf! jz readen ;also end of line + cpi ctlp! jnz notp ;skip if not ctlp + ;list toggle - change parity + push h! push b ;save counters + lhld scbadr! mvi l,listcp ;hl =.listcp + mvi a,1! sub m ;True-listcp + mov m,a ;listcp = not listcp + pop b! pop h! jmp readnx ;for another char + notp: + ;not a ctlp + ;place into buffer + rdecho: + inx h! mov m,a ;character filled to mem + inr b ;blen = blen + 1 + rdech1: + ;look for a random control character + push b! push h ;active values saved + call ctlout ;may be up-arrow C + pop h! pop b! mov a,m ;recall char + cpi ctlc ;set flags for reboot test + mov a,b ;move length to A + jnz notc ;skip if not a control c + cpi 1 ;control C, must be length 1 + jz rebootx ;reboot if blen = 1 + ;length not one, so skip reboot + notc: + ;not reboot, are we at end of buffer? + cmp c! jc readnx ;go for another if not + readen: + ;end of read operation, store blen + pop h! mov m,b ;M(current len) = B + push psw ;may be a ctl-z + mvi a,cr! call conout ;return carriage + pop psw ;restore character + ret +; +func1: equ conech + ;return console character with echo +; +;func6: see intercept routine at front of module +; +func10: equ read + ;read a buffered console line +; +func11: equ conbrk + ;check console status +; +; + +;****************************************************************** +; DATA AREA +;****************************************************************** + +statflg: db 0 ;non-zero if prev funct was status + ; + ; + +;****************************************************************** +; Following variables and entry points are used by GET.COM +; Their order and contents must not be changed without also +; changing GET.COM. +;****************************************************************** + ; + if bios$functions + ; +exit$table: ;addresses to go to on exit + dw next ;BDOS + endif + ; +movstart: +init$table: ;addresses used by GET.COM for +scbadr: dw kill ;address of System Control Block + ; + if bios$functions ;GET.RSX initialization + ; +biosta dw bios$constat ;set to real BIOS routine +biosin dw bios$conin ;set to real BIOS routine + ; + ;restore only if changed when removed. +restore$mode + db 0 ;if non-zero change LXI @jmpadr to JMP + ;when removed. +restore$bios: + ;hl = real constat routine + ;de = real conin routine + shld 0 ;address of const jmp initialized by COM + xchg + shld 0 ;address of conin jmp initialized by COM + ret + endif + ; +real$bdos: + jmp bdos ;address filled in by COM + ; + ; +echo: db 1 +cooked: db 0 + ; +program: + db 0 ;true if program input only +subusr: db 0 ;user number for redirection file +subfcb: db 1 ;a: + db 'SYSIN ' + db 'SUB' + db 0,0 +submod: db 0 +subrc: ds 1 + ds 16 ;map +subcr: ds 1 + ; +movend: +;******************************************************************* + +cbufp db 128 ;current character position in cbuf +nextchr db cr ;next character (1 char lookahead) + + if submit +ccp$line: + db false ;nonzero if line is for CCP + endif + +cbuf: ;128 byte record buffer + + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + +udma: dw buf ;user dma address +get$active: + db gkillf + ; +sav$area: ;14 byte save area (searchn) + db 68h,68h,68h,68h,68h, 68h,68h,68h,68h,68h + db 68h,68h,68h,68h +excess: db 0 +old$stack: + dw 0 + if submit +garbage: +; db cr,lf + db 'WARNING: PROGRAM INPUT IGNORED',cr,lf,'$' + else +ccpcnt: db 1 + endif +patch$area: + ds 30h + db ' ' + @BDATE + db ' ' + @SCOPY + db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h + db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h + db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h + ; +stack: ;15 level stack + end + \ No newline at end of file diff --git a/software/CPM/cpm3/getrsx.lib b/software/CPM/cpm3/getrsx.lib new file mode 100644 index 0000000..8624396 --- /dev/null +++ b/software/CPM/cpm3/getrsx.lib @@ -0,0 +1 @@ +submit equ true ;true if submit RSX diff --git a/software/CPM/cpm3/help.dat b/software/CPM/cpm3/help.dat new file mode 100644 index 0000000..fa456f7 --- /dev/null +++ b/software/CPM/cpm3/help.dat @@ -0,0 +1,2043 @@ + + ///1commands + + CP/M 3 Command Format: + + A>COMMAND {command tail} + + A CP/M 3 command line is composed of a command, an optional + command tail, and a carriage return. The command is the name or + filename of a program to be executed. The optional command tail + can consist of a drive specification, one or more file + specifications, and some options or parameters. + + ///2conventions + COMMAND CONVENTIONS + + The following special symbols define command syntax. + + {} surrounds an optional item. + | separates alternative items in a command line. + indicates a carriage return. + ^ indicates the Control Key. + n substitute a number for n. + s substitute a string (group) of characters for s. + o substitute an option or option list for o. + [] type square brackets to enclose an option list. + () type parens to enclose a range of options within an option list. + RW Read-Write attribute - opposite of RO + RO Read-Only attribute - opposite of RW + SYS System attribute - opposite of DIR + DIR Directory attribute - opposite of SYS + ... preceding element can be repeated as many times as desired. + * wildcard: replaces all or part of a filename and/or filetype. + ? wildcard: replaces any single character + in the same position of a filename and/or filetype. + + + ///1cntrlchars + + Control Character Function + + CTRL-A moves cursor one character to the left. Banked system + only. + + CTRL-B moves cursor from beginning to end of command line and + back without affecting command. Banked system only. + + CTRL-C stops executing program when entered at the system + prompt or after CTRL-S. + + CTRL-E forces a physical carriage return without sending + command to CP/M 3. + + CTRL-F moves cursor one character to the right. Banked system + only. + + CTRL-G deletes character at current cursor position if in the + middle of a line. Banked system only. + + CTRL-I same as the TAB key. + + CTRL-H delete character to the left of cursor. + + CTRL-J moves cursor to the left of the command line and sends + command to CP/M 3. Line feed, has same effect as + carriage return. + + CTRL-K deletes character at cursor and all characters to the + right. + + CTRL-M same as carriage return. + + CTRL-P echoes console output to the list device. + + CTRL-Q restarts screen scrolling after a CTRL-S. + + CTRL-R retypes the characters to the left of the cursor on a + new line; updates the command line buffer. + + CTRL-S stops screen scrolling. + + CTRL-U updates the command line buffer to contain the + characters to the left of the cursor; deletes current + line. + + CTRL-W recalls previous command line if current line is empty; + otherwise moves cursor to end of line. CTRL-J,-M,-R,-U + and RETURN update the command line buffer for recall + with CTRL-W. Banked system only. + + CTRL-X deletes all characters to the left of the cursor. + + ///1COPYSYS + + Syntax: + + COPYSYS + + Explanation: + + COPYSYS copies the CP/M 3 system from a CP/M 3 system diskette to + another diskette. The new diskette must have the same format as + the original system diskette. + + Example: + + A>COPYSYS + + ///1DATE + + Syntax: + + DATE {CONTINUOUS} + DATE {time-specification} + DATE SET + + Explanation: + + The DATE command lets you display and set the date and time of + day. The date and time may be in US, UK or Year-Month-Day format, + depending on the current setting - see SETDEF. + + ///2Examples + + A>DATE + + Displays the current date and time. + + A>DATE C + + Displays the date and time continuously. + + A>DATE 08/14/82 10:30:0 + + Sets the date and time. + + A>DATE SET + + Prompts for date and time entries. + + ///1DEVICE + + Syntax: + + DEVICE { NAMES | VALUES | physical-dev | logical-dev} + DEVICE logical-dev=physical-dev {option} + {,physical-dev {option},...} + DEVICE logical-dev = NULL + DEVICE physical-dev {option} + DEVICE CONSOLE [ PAGE | COLUMNS = columns | LINES = lines] + + Explanation: + + DEVICE displays current logical device assignments and physical + device names. DEVICE assigns logical devices to peripheral + devices attached to the computer. DEVICE also sets the + communications protocol and speed of a peripheral device, and + displays or sets the current console screen size. + + ///2Options + + [ XON | NOXON | baud-rate ] + + XON refers to the XON/XOFF communications protocol. + + NOXON indicates no protocol and the computer sends data to + the device whether or not the device is ready to + receive it. + + baud-rate is the speed of the device. The system + accepts the following baud rates: + + 50 75 110 134 + 150 300 600 1200 + 1800 2400 3600 4800 + 7200 9600 19200 + + ///2Examples + + A>DEVICE + + Displays the physical devices and current assignments of + the logical devices in the system. + + A>DEVICE NAMES + + Lists the physical devices with a summary of the device + characteristics. + + A>DEVICE VALUES + + Displays the current logical device assignments. + + A>DEVICE CRT + + Displays the attributes of the physical device CRT. + + A>DEVICE CON + + Displays the assignment of the logical device CON: + + A>DEVICE CONOUT:=LPT,CRT + + Assigns the system console output (CONOUT:) to the + printer (LPT) and the screen (CRT). + + A>DEVICE AUXIN:=CRT2 [XON,9600] + + Assigns the auxiliary logical input device (AUXIN:) to + the physical device CRT using protocol XON/XOFF and + sets the transmission rate for the device at 9600. + + A>DEVICE LST:=NULL + + Disconnects the list output logical device (LST:). + + A>DEVICE LPT [XON,9600] + + Sets the XON/XOFF protocol for the physical device LPT + and sets the transmission speed at 9600. + + A>DEVICE CONSOLE [PAGE] + + Displays the current console page width in columns and + length in lines. + + A>DEVICE CONSOLE [COLUMNS=40 LINES=16] + + Sets the screen size to 40 columns and 16 lines. + + ///1DIR + + The DIR command displays the names of files and the + characteristics associated with the files. + + The DIR command has three distinct references: + + DIR + DIRS + DIR with Options + + DIR and DIRS are built-in utilities. DIR with Options is a + transient utility and must be loaded into memory from the disk. + + ///2Built-in + + Syntax: + + DIR {d:} + DIR {filespec} + + DIRS {d:} + DIRS {filespec} + + Explanation: + + The DIR and DIRS Built-in commands display the names of files + cataloged in the directory of an on-line disk. DIR lists the + names of files in the current user number that have the Directory + (DIR) attribute. DIR accepts the * and ? wildcards in the file + specification. + + ///3Examples + + A>DIR + + Displays all files in user 0 on drive A that have the + Directory attribute. + + A>DIR B: + + Displays all DIR files in user 0 on drive B. + + + 2A>DIR C:ZIPPY.DAT + + Displays the name ZIPPY.DAT if the file is in user 2 on + drive C. + + 4A>DIR *.BAS + + Displays all DIR files with filetype BAS in user 4 on drive + A. + + B3>DIR X*.C?D + + Displays all DIR files in user 3 on drive B whose filename + begins with the letter X, and whose three character filetype + contains the first character C and last character D. + + A>DIRS + + Displays all files for user 0 on drive A that have the + system (SYS) attribute. + + A>DIRS *.COM + + Displays all SYS files with filetype COM on drive A in user + 0. A command (.COM) file in user 0 with the system + attribute can be accessed from any user number on that + drive, and from any drive in the search chain (see SETDEF). + + ///2withOptions + + Syntax: + + DIR {d:} [options] + DIR {filespec} {filespec} ... [options] + + Explanation: + + The DIR command with options is an enhanced version of the DIR + built-in command and displays your files in a variety of ways. + DIR can search for files on any or all drives, for any or all + user numbers. One or two letters is sufficient to identify an + option. You need not type the right hand square bracket. + + ///3Options + + Option Function + + ATT displays the file attributes. + + DATE displays date and time stamps of files. + + DIR displays only files that have the DIR attribute. + + DRIVE=ALL displays files on all on-line drives. + + DRIVE=(A,B,C,...,P) + displays files on the drives specified. + + DRIVE=d displays files on the drive specified by d. + + EXCLUDE displays files that DO NOT MATCH the files + specified in the command line. + + FF sends an initial form feed to the printer device if + the printer has been activated by CTRL-P. + + FULL shows the name, size, number of 128-byte records, and + attributes of the files. If there is a directory + label on the drive, DIR shows the password + protection mode and the time stamps. If there is no + directory label, DIR displays two file entries on a + line, omitting the password and time stamp columns. + The display is alphabetically sorted. (See SET for a + description of file attributes, directory labels, + passwords and protection modes.) + + LENGTH=n displays n lines of printer output before inserting + a table heading. n is a number between 5 and 65536. + + MESSAGE displays the names of drives and user numbers DIR is + searching. + + NOSORT displays files in the order it finds them on the disk. + + RO displays only the files that have the Read-Only + attribute. + + RW displays only the files that are set to Read-Write. + + SIZE displays the filename and size in kilobytes (1024 + bytes). + + SYS displays only the files that have the SYS attribute. + + USER=ALL displays all files in all user numbers for the default + or specified drive. + + USER=n displays the files in the user number specified by n. + + USER=(0,1,...,15) + displays files under the user numbers specified. + + ///3Examples + + A>DIR C: [FULL] + + Displays full set of characteristics for all files in user 0 + on drive C. + + A>DIR C: [DATE] + + Lists the files on drive C and their dates. + + A>DIR D: [RW,SYS] + + Displays all files in user 0 on drive D with Read-Write + and System attributes. + + 3A>DIR [USER=ALL, DRIVE=ALL] + + Displays all the files in all user numbers (0-15) in all on- + line drives. + + B6>DIR [exclude] *.DAT + + Lists all the files on drive B in user 6 that do not have a + filetype of .DAT. + + 3B>DIR [SIZE] *.PLI *.COM *.ASM + + Displays all the files of type PLI, COM, and ASM in user + 3 on drive B in size display format. + + A>DIR [drive=all user=all] TESTFILE.BOB + + DIR displays the filename TESTFILE.BOB if it is found on + any drive in any user number. + + A>DIR [size,rw] D: + + DIR lists each Read-Write file that resides on Drive D, + with its size in kilobytes. Note that D: is equivalent to + D:*.*. + + ///1DUMP + + Syntax: + + DUMP filespec + + Explanation: + + DUMP displays the contents of a file in hexadecimal and ASCII + format. + + Example: + + A>DUMP ABC.TEX + + ///1ed + + Format: + + ED input-filespec {d:|output-filespec} + + Explanation: + + Character file editor. To redirect or rename the new version of + the file specify the destination drive or destination filespec. + + ///2commands + + ED Command Summary + + + Command Action + + nA + append n lines from original file to memory buffer + + 0A + append file until buffer is one half full + + #A + append file until buffer is full (or end of file) + + B, -B + move CP to the beginning (B) or bottom (-B) of buffer + + nC, -nC + move CP n characters forward (C) or back (-C) through buffer + + nD, -nD + delete n characters before (-D) or from (D) the CP + + E + save new file and return to CP/M-86 + + Fstring{^Z} + find character string + + H + save new file, reedit, use new file as original file + + I + enter insert mode + + Istring{^Z} + insert string at CP + + Jsearch_str^Zins_str^Zdel_to_str + juxtapose strings + + nK, -nK + delete (kill) n lines from the CP + + nL, -nL, 0L + move CP n lines + + nMcommands + execute commands n times + + n, -n + move CP n lines and display that line + + n: + move to line n + + :ncommand + execute command through line n + + Nstring{^Z} + extended find string + + O + return to original file + + nP, -nP + move CP 23 lines forward and display 23 lines at console + + Q + abandon new file, return to CP/M-86 + + R{^Z} + read X$$$$$$$.LIB file into buffer + + Rfilespec{^Z} + read filespec into buffer + + Sdelete string^Zinsert string + substitute string + + nT, -nT, 0T + type n lines + + U, -U + upper-case translation + V, -V + line numbering on/off + 0V + display free buffer space + nW + write n lines to new file + 0W + write until buffer is half empty + nX + write or append n lines to X$$$$$$$.LIB + + nXfilespec{^Z} + write n lines to filespec; + append if previous xcommand applied to same file + + 0x{^Z} + delete file X$$$$$$$.LIB + + 0xfilespec{^Z} + delete filespec + nZ + wait n seconds + + Note: CP points to the current character being referenced in + the edit buffer. Use {^Z} to separate multiple commands + on the same line. + + ///2Examples + + A>ED TEST.DAT + A>ED TEST.DAT B: + A>ED TEST.DAT TEST2.DAT + A>ED TEST.DAT B:TEST2.DAT + + ///1erase + + Syntax: + + ERASE {filespec} {[CONFIRM]} + + Explanation: + + The ERASE command removes one or more files from the + directory of a disk. Wildcard characters are accepted in the + filespec. Directory and data space are automatically reclaimed + for later use by another file. The ERASE command can be + abbreviated to ERA. + + ///2Option + + [CONFIRM] option informs the system to prompt for + verification before erasing each file that + matches the filespec. CONFIRM can be + abbreviated to C. + + ///2Examples + + A>ERASE X.PAS + + Removes the file X.PAS from the disk in drive A. + + A>ERA *.PRN + Confirm (Y/N)?Y + + All files with the filetype PRN are removed from the disk + in drive A. + + B>ERA A:MY*.* [CONFIRM] + + Each file on drive A with a filename that begins with MY is + displayed with a question mark for confirmation. Type Y to + erase the file displayed, N to keep the file. + + A>ERA B:*.* + Confirm (Y/N)?Y + + All files on drive B are removed from the disk. + + ///1filespec + + FILESPEC FORMAT + + CP/M 3 identifies every file by its unique file specification, + which can consist of four parts: the drive specification, the + filename, the filetype and the password. The term "filespec" + indicates any valid combination of the four parts of a file + specification, all separated by their appropriate delimiters. + A colon must follow a drive letter. A period must precede a + filetype. A semicolon must precede a password. + + The symbols and rules for the parts of a file + specification follow: + + d: drivespec optional single alpha character (A-P) + filename filename 1-8 letters and/or numbers + typ filetype optional 0-3 letters and/or numbers + password password optional 0-8 letters and/or numbers + + Valid combinations of the elements of a CP/M 3 file specification + are: + + filename + d:filename + filename.typ + d:filename.typ + filename;password + d:filename;password + filename.typ;password + d:filename.typ;password + + If you do not include a drive specifier, CP/M 3 automatically + uses the default drive. + + Some CP/M 3 commands accept wildcard (* and ?) characters in the + filename and/or filetype parts of the command tail. A wildcard + in the command line can in one command reference many matching + files on the default or specified user number and drive. (See + Commands). + + ///1GENCOM + + Syntax: + + GENCOM {COM-filespec} {RSX-filespec} ... + {[LOADER | NULL | SCB=(offset,value)]} + + Explanation: + + The GENCOM command creates a special COM file with attached RSX + files. The GENCOM command can also restore a previously + GENCOMed file to the original COM file without the header and + RSX's. GENCOM can also attach header records to COM files. + + ///2Options + + LOADER sets a flag to keep the program loader active. + + NULL indicates that only RSX files are specified. GENCOM + creates a dummy COM file for the RSX files. The + output COM filename is taken from the filename of the + first RSX-filespec. + + SCB=(offset,value) + sets the System Control Block from the program by + using the hex values specified by (offset,value). + + ///2Examples + + A>GENCOM MYPROG PROG1 PROG2 + + Generates a new COM file MYPROG.COM with attached RSX's + PROG1 and PROG2. + + A>GENCOM PROG1 PROG2 [NULL] + + Creates a COM file PROG1.COM with RSX's PROG1 and PROG2. + + A>GENCOM MYPROG + + GENCOM takes MYPROG.COM, strips off the header and + deletes all attached RSX's to restore it to its original COM + format. + + A>GENCOM MYPROG PROG1 PROG2 + + GENCOM looks at the already-GENCOMed file MYPROG.COM to see + if PROG1.RSX and PROG2.RSX are already attached RSX files in + the module. If either one is already attached, GENCOM + replaces it with the new RSX module. Otherwise, GENCOM + appends the specified RSX files to the COM file. + + ///1GET + + Syntax: + + GET {CONSOLE INPUT FROM} FILE filespec{[{ECHO|NO ECHO} | SYSTEM]} + GET {CONSOLE INPUT FROM} CONSOLE + + Explanation: + + GET directs the system to take console input from a file for the + next system command or user program entered at the console. + + Console input is taken from a file until the program + terminates. If the file is exhausted before program input is + terminated, the program looks for subsequent input from the + console. If the program terminates before exhausting all its + input, the system reverts back to the console for console input. + + With the SYSTEM option, the system immediately goes to the + specified file for console input. The system reverts to the + console for input when it reaches the end of file. Re-direct + the system to the console for console input with the GET + CONSOLE INPUT FROM CONSOLE command as a command line in the input + file. + + ///2Options + + ECHO specifies that input is echoed to the console. This + is the default option. + + NO ECHO specifies that file input is not echoed to the + console. The program output and the system prompts are + not affected by this option and are still echoed to + the console. + + SYSTEM specifies that all system input is immediately taken + from the disk file specified in the command line. GET + takes system and program input from the file until the + file is exhausted or until GET reads a GET console + command from the file. + + ///2Examples + + A>GET FILE XINPUT + A>MYPROG + + Tells the system to activate the GET utility. Since SYSTEM + is not specified, the system reads the next input line from + the console and executes MYPROG. If MYPROG program + requires console input, it is taken from the file XINPUT. + When MYPROG terminates, the system reverts back to the + console for console input. + + A>GET FILE XIN2 [SYSTEM] + + Immediately directs the system to get subsequent + console input from file XIN2 because it includes the SYSTEM + option. The system reverts back to the console for + console input when it reaches the end of file in XIN2. Or + XIN2 may redirect the system back to the console if it + contains a GET CONSOLE command. + + A>GET CONSOLE + + Tells the system to get console input from the console. + This command may be used in a file (previously specified in + a GET FILE command), which is already being read by the + system for console input. It is used to re-direct the + console input back to the console before the end-of-file + is reached. + + ///1HELP + + Syntax: + + HELP {topic} {subtopic1 ... subtopic8} {[NOPAGE|LIST]} + + Explanation: + + HELP displays a list of topics and provides summarized + information for CP/M 3 commands. + + HELP topic displays information about that topic. + HELP topic subtopic displays information about that subtopic. + + One or two letters is enough to identify the topics. After HELP + displays information for your topic, it displays the + special prompt HELP> on your screen, followed by a list of + subtopics. + + - Enter ? to display list of main topics. + - Enter a period and subtopic name to access subtopics. + - Enter a period to redisplay what you just read. + - Press the RETURN key to return to the CP/M 3 system prompt. + - [NOPAGE] option disables the 24 lines per page console display. + - Press any key to exit a display and return to the HELP> prompt. + + Examples: + + A>HELP + A>HELP DATE + A>HELP DIR OPTIONS + A>HELP>.OPTIONS + HELP>SET + HELP>SET PASSWORD + HELP>.PASSWORD + HELP>. + HELP> + + ///1HEXCOM + + Syntax: + + HEXCOM filename + + Explanation: + + The HEXCOM Command generates a command file (filetype .COM) from + a .HEX input file. It names the output file with the same + filename as the input file but with filetype .COM. HEXCOM always + looks for a file with filetype .HEX. + + Example: + + A>HEXCOM B:PROGRAM + + Generates a command file PROGRAM.COM from the input hex file + PROGRAM.HEX. + + ///1INITDIR + + Syntax: + + INITDIR {d:} + + Explanation: + + The INITDIR Command initializes a disk directory to allow date + and time stamping of files on that disk. INITDIR can also recover + time/date directory space. + + Example: + + A>INITDIR C: + + INITDIR WILL ACTIVATE TIME-STAMPS FOR SPECIFIED DRIVE. + Do you want to re-format the directory on C: (Y/N)?Y + + ///1LIB + + Syntax: + + LIB filespec{[I|M|P|D]} + LIB filespec{[I|M|P]}=filespec{modifier} + {,filespec{modifier} ... } + + Explanation: + + A library is a file that contains a collection of object modules. + Use the LIB utility to create libraries, and to append, replace, + select or delete modules from an existing library. Use LIB to + obtain information about the contents of library files. + + LIB creates and maintains library files that contain object + modules in Microsoft REL file format. These modules are produced + by Digital Research's relocatable macro-assembler program, RMAC, + or any other language translator that pruduces modules in + Microsoft REL file format. + + You can use LINK-80 to link the object modules contained in a + library to other object files. LINK-80 automatically selects + from the library only those modules needed by the program being + linked, and then forms an executable file with a filetype of COM. + + ///2Options + + I The INDEX option creates an indexed library file + of type .IRL. LINK-80 searches faster on indexed + libraries than on non-indexed libraries. + + M The MODULE option displays module names. + + P The PUBLICS option displays module names and the + public variables for the new library file. + + D The DUMP option displays the contents of object + modules in ASCII form. + + ///2Modifiers + + Use modifiers in the command line to instruct LIB to + delete, replace, or select modules in a library file. Angle + brackets enclose the modules to be deleted or replaced. + Parentheses enclose the modules to be selected. + + LIB Modifiers + + Delete + + Replace + + If module name and filename are the + same this shorthand can be used: + + + + Select (modFIRST-modLAST,mod1,mod2,...,modN) + + ///2Examples + + A>LIB TEST4[P] + + Displays all modules and publics in TEST4.REL. + + A>LIB TEST5[P]=FILE1,FILE2 + + Creates TEST5.REL from FILE1.REL and FILE2.REL and displays + all modules and publics in TEST5.REL. + + A>LIB TEST=TEST1(MOD1,MOD4),TEST2(C1-C4,C6) + + Creates a library file TEST.REL from modules in two source + files. TEST1.REL contributes MOD1 and MOD4. LIB extracts + modules C1, C4, and all the modules located between them, + as well as module C6 from TEST2.REL. + + A>LIB FILE2=FILE3 + + Creates FILE2.REL from FILE3.REL, omitting MODA which is + a module in FILE3.REL. + + A>LIB FILE6=FILE5 + + Creates FILE6.REL from FILE5.REL, FILEB.REL replaces MODA. + + A>LIB FILE6=FILE5 + + Module THISNAME is in FILE5.REL. When LIB creates + FILE6.REL from FILE5.REL the file THISNAME.REL replaces the + similarly named module THISNAME. + + A>LIB FILE1[I]=B:FILE2(PLOTS,FIND,SEARCH-DISPLAY) + + Creates FILE1.IRL on drive A from the selected modules + PLOTS, FIND, and modules SEARCH through the module + DISPLAY, in FILE2.REL on drive B. + + ///1LINK + + Syntax: + + LINK d:{filespec,{[options]}=}filespec{[options]}{,...} + + Explanation: + + LINK combines relocatable object modules such as those + produced by RMAC and PL/I-80 into a .COM file ready for + execution. Relocatable files can contain external references and + publics. Relocatable files can reference modules in library + files. LINK searches the library files and includes the + referenced modules in the output file. See the CP/M 3 + Programmer's Utilities Guide for a complete description of LINK- + 80. + + ///2Options + + Use LINK option switches to control execution parameters. Link + options follow the file specifications and are enclosed + within square brackets. Multiple switches are separated by + commas. + + LINK-80 Options + + A Additional memory; reduces buffer space + and writes temporary data to disk + + B BIOS link in banked CP/M 3 system. + 1. Aligns data segment on page boundary. + 2. Puts length of code segment in header. + 3. Defaults to .SPR filetype. + + Dhhhh Data origin; sets memory origin for + common and data area + + Gn Go; set start address to label n + + Lhhhh Load; change default load address + of module to hhhh. Default 0100H + + Mhhhh Memory size; Define free memory + requirements for MP/M modules. + + NL No listing of symbol table at console + + NR No symbol table file + + OC Output .COM command file. Default + + OP Output .PRL page relocatable file for + execution under MP/M in relocatable + segment + + OR Output .RSP resident system process file + for execution under MP/M + + OS Output .SPR system page relocatable file + for execution under MP/M + + Phhhh Program origin; changes default + program origin address to hhhh. + Default is 0100H. + + Q Lists symbols with leading question mark + + S Search preceding file as a library + + $Cd Destination of console messages + d can be X (console), Y (printer), + or Z (zero output). Default is X. + + $Id Source of intermediate files; + d is disk drive A-P. Default + is current drive. + + $Ld Source of library files; + d is disk drive A-P. Default + is current drive. + + $Od Destination of of object file; + d can be Z or disk drive A-P. + Default is to same drive as + first file in the LINK-80 command. + + $Sd Destination of symbol file; + d can be Y or Z or disk drive A-P. + Default is to same drive as + first file in LINK-80 command. + + ///2Examples + + A>LINK b:MYFILE[NR] + + LINK-80 on drive A uses as input MYFILE.REL on drive B and + produces the executable machine code file MYFILE.COM on + drive B. The [NR] option specifies no symbol table file. + + A>LINK m1,m2,m3 + + LINK-80 combines the separately compiled files m1, m2, and + m3, resolves their external references, and produces the + executable machine code file m1.COM. + + A>LINK m=m1,m2,m3 + + LINK-80 combines the separately compiled files m1, m2, and + m3 and produces the executable machine code file m.COM. + + A>LINK MYFILE,FILE5[s] + + The [s] option tells LINK-80 to search FILE5 as a library. + LINK-80 combines MYFILE.REL with the referenced + subroutines contained in FILE5.REL on the default drive + A and produces MYFILE.COM on drive A. + + ///1mac + + Syntax: + + MAC filename {$options} + + Explanation: + + MAC, the CP/M 3 macro assembler, reads assembly language + statements from a file of type .ASM, assembles the statements, + and produces three output files with the input filename and + filetypes of .HEX, .PRN, and .SYM. Filename.HEX contains INTEL + hexadecimal format object code. Filename.PRN contains an + annotated source listing that you can print or examine at the + console. Filename.SYM contains a sorted list of symbols defined + in the program. + + ///2Examples + + A>MAC SAMPLE + + A>MAC SAMPLE $PB AA HB SX + + ///2options + + Use options to direct the input and output of MAC. Use a letter + with the option to indicate the source and destination drives, + and console, printer, or zero output. Valid drive names are A + thru O. X, P and Z specify console, printer, and zero output, + respectively. + + Assembly Options That Direct Input/Output + + A source drive for .ASM file (A-O) + + H destination drive for .HEX file (A-O, Z) + + L source drive for macrolibrary .LIB files called by the + MACLIB statement. + + P destination drive for .PRN file (A-O, X, P, Z) + + S destination drive for .SYM file + + + + Assembly Options That Modify Contents Of Output File + + +L lists input lines read from macrollibrary .LIB files + -L suppresses listing (default) + + +M lists all macro lines as they are processed during assembly + -M suppresses all macro lines as they are read during assembly + *M lists only hex generated by macro expansions + + +Q lists all LOCAL symbols in the symbol list + -Q suppresses all LOCAL symbols in the symbol list (default) + + +S appends symbol file to print file + -S suppresses creation of symbol file + + +1 produces a pass 1 listing for macro debugging in .PRN file + -1 suppress listing on pass 1 (default) + + ///1PATCH + + Syntax: + + PATCH filename{.typ} {n} + + Explanation: + + The PATCH command displays or installs patch number n to the + CP/M 3 system or command files. The patch number n must be + between 1 and 32 inclusive. + + Example: + + A>PATCH SHOW 2 + + Patches the SHOW.COM system file with patch number 2. + + ///1PIP (copy) + + Syntax: + + DESTINATION SOURCE + + PIP d:{Gn} | filespec{[Gn]} = filespec{[o]},... | d:{[o]} + + Explanation: + + The file copy program PIP copies files, combines files, and + transfers files between disks, printers, consoles, or other + devices attached to your computer. The first filespec is the + destination. The second filespec is the source. Use two or more + source filespecs separated by commas to combine two or more files + into one file. [o] is any combination of the available options. + The [Gn] option in the destination filespec tells PIP to copy + your file to that user number. + + PIP with no command tail displays an * prompt and awaits your + series of commands, entered and processed one line at a time. + The source or destination can be any CP/M 3 logical device. + ///2Examples + + COPY A FILE FROM ONE DISK TO ANOTHER + + A>PIP b:=a:draft.txt + A>PIP b:draft.txt = a: + + B3>PIP myfile.dat=A:[G9] + A9>PIP B:[G3]=myfile.dat + + COPY A FILE AND RENAME IT + + A5>PIP newdraft.txt=oldraft.txt + C8>PIP b:newdraft.txt=a:oldraft.txt + + COPY MULTIPLE FILES + + A>PIP b:=draft.* + A>PIP b:=*.* + B>PIP b:=c:.*.* + C>PIP b:=*.txt[g5] + C>PIP a:=*.com[wr] + B>PIP a:[g3]=c:*.* + + COMBINE MULTIPLE FILES + + A>PIP b:new.dat=file1.dat,file2.dat + + COPY, RENAME AND PLACE IN USER 1 + + A>pip newdraft.txt[g1]=oldraft.txt + + COPY, RENAME AND GET FROM USER 1 + + A>PIP newdraft.txt=oldraft.txt[g1] + + COPY TO/FROM LOGICAL DEVICES + + A>PIP b:funfile.sue=con: + A>PIP lst:=con: + A>PIP lst:=b:draft.txt[t8] + A>PIP prn:=b:draft.txt + + ///2options + + PIP OPTIONS + + A Archive. Copy only files that have been changed since the + last copy. + C Confirm. PIP prompts for confirmation before each file copy. + Dn Delete any characters past column n. + E Echo transfer to console. + F Filter form-feeds from source data. + Gn Get from or go to user n. + H Test for valid Hex format. + I Ignore :00 Hex data records and test for valid Hex format. + K Kill display of filespecs on console. + L Translate upper case to lower case. + N Number output lines + O Object file transfer, ^Z ignored. + Pn Set page length to n. (default n=60) + Qs^Z Quit copying from source at string s. + R Read files that have been set to SYStem. + Ss^Z Start copying from the source at the string s. + Tn Expand tabs to n spaces. + U Translate lower case to upper case. + V Verify that data has been written correctly. + W Write over Read Only files without console query. + Z Zero the parity bit. + + All options except C,G,K,O,R,V and W force an ASCII file + transfer, character by character, terminated by a ^Z. + + ///1PUT + + Syntax: + + PUT CONSOLE {OUTPUT TO} FILE filespec {option} | CONSOLE + PUT PRINTER {OUTPUT TO} FILE filespec {option} | PRINTER + PUT CONSOLE {OUTPUT TO} CONSOLE + PUT PRINTER {OUTPUT TO} PRINTER + + Explanation: + + PUT puts console or printer output to a file for the next + command entered at the console, until the program terminates. + Then console output reverts to the console. Printer output + is directed to a file until the program terminates. + Then printer output is put back to the printer. + + PUT with the SYSTEM option directs all subsequent + console/printer output to the specified file. This option + terminates when you enter the PUT CONSOLE or PUT PRINTER + command. + + ///2Options + + [ {ECHO | NO ECHO} {FILTER | NO FILTER} | {SYSTEM} ] + + ECHO specifies that output is echoed to the console. This + is the default option when you direct console output + to a file. + + NO ECHO specifies that file output is not echoed to the + console. NO ECHO is the default for the PUT PRINTER + command. + + FILTER specifies filtering of control characters, which + means that control characters are translated to + printable characters. For example, an ESCape + character is translated to ^[. + + NO FILTER means that PUT does not translate control + characters. This is the default option. + + SYSTEM specifies that system output as well as program + output is written to the file specified by + filespec. Output is written to the file until a + subsequent PUT CONSOLE command redirects console + output back to the console. + + ///2Examples + + A>PUT CONSOLE OUTPUT TO FILE XOUT [ECHO] + + Directs console output to file XOUT with the output echoed + to the console. + + A>PUT PRINTER OUTPUT TO FILE XOUT + A>MYPROG + + Directs the printer output of program MYPROG to file + XOUT. The output is not echoed to the printer. + + A>PUT PRINTER OUTPUT TO FILE XOUT2 [ECHO,SYSTEM] + + Directs all printer output to file XOUT2 as well as to the + printer (with ECHO option), and the PUT is in effect until + you enter a PUT PRINTER OUTPUT TO PRINTER command. + + A>PUT CONSOLE OUTPUT TO CONSOLE + + Directs console output back to the console. + + A>PUT PRINTER OUTPUT TO PRINTER + + Directs printer output back to the printer. + + ///1RENAME + + Syntax: + + RENAME {new-filespec=old-filespec} + + Explanation: + + RENAME lets you change the name of a file in the directory of a + disk. To change several filenames in one command use the * or ? + wildcards in the file specifications. The RENAME command can be + abbreviated REN. REN prompts you for input. + + ///2Examples + + A>RENAME NEWFILE.BAS=OLDFILE.BAS + + The file OLDFILE.BAS changes to NEWFILE.BAS on drive A. + + A>RENAME + + The system prompts for the filespecs: + + Enter New Name:X.PRN + Enter Old Name:Y.PRN + Y .PRN=X .PRN + A> + + File X.PRN is renamed to Y.PRN on drive A. + + B>REN A:PRINTS.NEW = PRINCE.NEW + + The file PRINCE.NEW on drive A changes to PRINTS.NEW on + drive A. + + A>RENAME S*.TEX=A*.TEX + + The above command renames all the files matching + A*.TEX to files with filenames S*.TEX. + + A>REN B:NEWLIST=B:OLDLIST + + The file OLDLIST changes to NEWLIST on drive B. Since the + second drive specifier, B: is implied by the first one, it + is unnecessary in this example. The command line above has + the same effect as the following: + + A>REN B:NEWLIST=OLDLIST + or + A>REN NEWLIST=B:OLDLIST + + ///1RMAC + + Syntax: + + RMAC filespec {$Rd | $Sd | $Pd} + + Explanation: + + RMAC, a relocatable macro assembler, assembles .ASM files of + into .REL files that you can link to create .COM files. + + ///2options + + RMAC options specify the destination of the output files. + Replace d with the destination drive letter for the output files. + + Option d=output option + + R- drive for REL file (A-O, Z) + S- drive for SYM file (A-O, X, P, Z) + P- drive for PRN file (A-O, X, P, Z) + + A-O specifies drive A-O. + X means output to the console. + P means output to the printer. + Z means zero output. + + ///2Example + + A>RMAC TEST $PX SB RB + + Assembles the file TEST.ASM from drive A, sends the listing + file (TEST.PRN) to the console, puts the symbol file + (TEST.SYM) on drive B and puts the relocatable object + file (TEST.REL) on drive B. + + ///1SAVE + + Syntax: + + SAVE + + Explanation: + + SAVE copies the contents of memory to a file. To use SAVE, + first issue the SAVE command, then run your program which reads a + file into memory. Your program exits to the SAVE utility which + prompts you for a filespec to which it copies the contents of + memory, and the beginning and ending address of the memory to be + SAVEd. + + ///2Example + + A>SAVE + + Activates the SAVE utility. Now enter the name of the program + which loads a file into memory. + + A>SID dump.com + + Next, execute the program. + + #g0 + + When the program exits, SAVE intercepts the return to the system + and prompts the user for the filespec and the bounds of memory to + be SAVEd. + + SAVE Ver 3.0 + Enter file (type RETURN to exit):dump2.com + + If file DUMP2.COM exists already, the system asks: + + Delete dump2.com? Y + + Then the system asks for the bounds of memory to be saved: + + Beginning hex address: 100 + Ending hex address: 400 + + The contents of memory from 100H (Hexadecimal) to 400H is copied + to file DUMP2.COM. + + ///1SET + + Syntax: + + SET [options] + SET d: [options] + SET filespec [options] + + Explanation: + + SET initiates password protection and time stamping of + files. It also sets the file and drive attributes Read-Write, + Read-Only, DIR and SYS. It lets you label a disk and password + protect the label. To enable time stamping of files, you + must first run INITDIR to format the disk directory. + + ///2Label + + Syntax: + + SET {d:} [NAME=labelname.typ] + SET [PASSWORD=password] + SET [PASSWORD= + + ///3Examples + + A>SET [NAME=DISK100] + + Labels the disk on the default drive as DISK100. + + A>SET [PASSWORD=SECRET] + + Assigns SECRET to the disk label. + + A>SET [PASSWORD= + + Nullifies the existing password. + + ///2Passwords + + SET [PROTECT=ON] + SET [PROTECT=OFF] + SET filespec [PASSWORD=password] + SET filespec [PROTECT=READ] + SET filespec [PROTECT=WRITE] + SET filespec [PROTECT=DELETE] + SET filespec [PROTECT=NONE] + SET filespec [attribute-options] + + ///3Modes + + Password Protection Modes + + Mode Protection + + READ The password is required for reading, copying + writing, deleting or renaming the file. + + WRITE The password is required for writing, deleting or + renaming the file. You do not need a password to + read the file. + + DELETE The password is only required for deleting or + renaming the file. You do not need a password to + read or modify the file. + + NONE No password exists for the file. If a password + password exists, this modifier can be used to + delete the password. + + ///2Attributes + + RO sets the file attribute to Read-Only. + + RW sets the file attribute to Read-Write. + + SYS sets the file attribute to SYS. + + DIR sets the file attribute to DIR. + + ARCHIVE=OFF means that the file has not been backed up + (archived). + + ARCHIVE=ON means that the file has been backed up (archived). + The Archive attribute can be turned on by SET or + by PIP when copying a group of files with the PIP + [A] option. SHOW and DIR display the Archive + option. + + F1=ON|OFF turns on or off the user-definable file attribute + F1. + + F2=ON|OFF turns on or off the user-definable file attribute + F2. + + F3=ON|OFF turns on or off the user-definable file attribute + F3. + + F4=ON|OFF turns on or off the user-definable file attribute + F4. + + ///3Examples + + SET [PROTECT=ON] + + Turns on password protection for all the files on the disk. + You must turn on password protection before you can assign + passwords to files. + + SET [PROTECT=OFF] + + Disables password protection for the files on your disk. + + A>SET MYFILE.TEX [PASSWORD=MYFIL] + + MYFIL is the password assigned to file MYFILE.TEX. + + B>SET *.TEX [PASSWORD=SECRET, PROTECT=WRITE] + + Assigns the password SECRET to all the TEX files on drive B. + Each TEX file is given a WRITE protect mode to prevent + unauthorized editing. + + A>SET MYFILE.TEX [RO SYS] + + Sets MYFILE.TEX to Read-Only and SYStem. + + ///2Default + + A>SET [DEFAULT=dd] + + Instructs the system to use dd as a password if you do not + enter a password for a password-protected file. + + ///2Time-Stamps + + Syntax: + + SET [CREATE=ON] + SET [ACCESS=ON] + SET [UPDATE=ON] + + Explanation: + + The above SET commands allow you to keep a record of the time + and date of file creation and update, or of the last access and + update of your files. + + ///3Options + + [CREATE=ON] turns on CREATE time stamps on the disk in the + default or specified drive. To record the + creation time of a file, the CREATE option must be + turned on before the file is created. + + [ACCESS=ON] turns on ACCESS time stamps on the disk in the + default or specified drive. ACCESS and CREATE + options are mutually exclusive; only one can be in + effect at a time. If you turn on the ACCESS time + stamp on a disk that previously had CREATE + time stamp, the CREATE time stamp is + automatically turned off. + + [UPDATE=ON] turns on UPDATE time stamps on the disk in the + default or specified drive. UPDATE time stamps + record the time the file was last modified. + + ///3Examples + + A>SET [ACCESS=ON] + A>SET [CREATE=ON,UPDATE=ON] + + ///2Drives + + Syntax: + + SET {d:} [RO] + SET {d:} [RW] + + + Example: + + A>SET B: [RO] + + Sets drive B to Read-Only. + + ///1SETDEF + + Syntax: + + SETDEF { d: {,d: {,d: {,d:}}}} {[ TEMPORARY = d: ] | + [ ORDER = (typ {,typ}) ]} + SETDEF [DISPLAY | NO DISPLAY] + + SETDEF [PAGE | NOPAGE] + + SETDEF [US | UK | YMD] + + Explanation: + + SETDEF allows the user to display or define up to four drives + for the program search order, the drive for temporary files, and + the file type search order. The SETDEF definitions affect + only the loading of programs and/or execution of SUBMIT + (SUB) files. SETDEF turns on/off the system Display and Console + Page modes. When on, the system displays the location and name + of programs loaded or SUBmit files executed, and stops after + displaying one full console screen of information. SETDEF is also + used to select whether dates are displayed in US, UK or + Year-Month-Day format. + + ///2Examples + + A>SETDEF + + Displays current SETDEF parameters. + + A>SETDEF [TEMPORARY=C:] + + Sets disk drive C as the drive to be used for temporary + files. + + A>SETDEF C:,* + + Tells the system to search for a program on drive C, then, + if not found, search for it on the default drive. + + A>SETDEF [ORDER=(SUB,COM)] + + Instructs the system to search for a SUB file to execute. + If no SUB file is found, search for a COM file. + + A>SETDEF [DISPLAY] + + Turns on the system display mode. Henceforth, the system + displays the name and location of programs loaded or submit + files executed. + + A>SETDEF [NO DISPLAY] Turns off the system Display mode. + + A>SETDEF [UK] Dates will be entered and displayed in UK form. + + ///1SHOW + + Syntax: + + SHOW {d:}{[SPACE |LABEL |USERS |DIR |DRIVE]} + + Explanation: + + The SHOW command displays the following disk drive information: + + Access mode and the amount of free disk space + Disk label + Current user number and + Number of files for each user number on the disk + Number of free directory entries for the disk + Drive characteristics + + ///2Examples + + A>SHOW + + A>SHOW [SPACE] + + Instructs the system to display access mode and amount of + space left on logged-in drives. + + A>SHOW B: + + Show access mode for drive B and amount of space left on + drive B. + + A>SHOW B:[LABEL] + + Displays label information for drive B. + + A>SHOW [USERS] + + Displays the current user number and all the users on drive + A and the corresponding number of files assigned to them. + + A>SHOW C:[DIR] + + Displays the number of free directory entries on drive C. + + A>SHOW [DRIVE] + + Displays the drive characteristics of drive A. + + ///1SID + + Syntax: + + SID {pgm-filespec} {,sym-filespec} + + Explanation: + + The SID symbolic debugger allows you to monitor and test + programs developed for the 8080 microprocessor. SID supports + real-time breakpoints, fully monitored execution, symbolic + disassembly, assembly, and memory display and fill functions. + SID can dynamically load SID utility programs to provide + traceback and histogram facilities. + + ///2Commands + + Command Meaning + + As (Assemble) Enter assembly language + statements + s is the start address + + Cs{b{,d}} (Call) Call to memory location from SID + s is the called address + b is the value of the BC register + pair d is the value of the DE + register pair + + D{W}{s}{,f} (Display) Display memory in hex and ASCII + W is a 16-bit word format + s is the start address + f is the finish address + + Epgm-filespec (Load) Load program and symbol table + {,sym-filespec} for execution + + E*sym-filespec (Load) Load a symbol table file + + Fs,f,d (Fill) Fill memory with constant value + s is the start address + f is the finish address + d is an eight-bit data item + + G{p}{,a{,b}} (Go) Begin Execution + p is a start address + a is a temporary breakpoint + + H (Hex) Displays all symbols with + addresses in Hex + H.a Displays hex, decimal, and ASCII + values of a where + a is a symbolic expression + + Ha,b Computes hex sum and difference + of a and b where + a and b are symbolic expressions + + Icommand tail (Input) Input CCP command line + + L{s}{,f} (List) List 8080 mnemonic instructions + s is the start address + f is the finish address + + Ms,h,d (Move) Move Memory Block + s is the start address + h is the high address of the block + d is the destination start address + + P{p{,c}} (Pass) Pass point set, reset, and display + p is a permanent breakpoint address + c is initial value of pass counter + + Q (Quit) Exit SID (for compatibility with + 80x86 versions of SID) + + Rfilespec{,d} (Read) Read Code/Symbols + d is an offset to each address + + S{W}s (Set) Set Memory Values + s is address where value is sent + W is 16 bit word + + T{n{,c}} (Trace) Trace Program Execution + n is the number of program steps + c is the utility entry address. + + T{W}{n{,c}} (Trace) Trace Without Call + W instructs SID not to trace + subroutines + n is the number of program steps + c is the utility entry address + + U{W}{n{,c}} (Untrace) Monitor Execution without Trace + n is the number of program steps + c is the utility entry address + W instructs SID not to trace + subroutines + + V (Value) Display the value of the next + available location in memory + (NEXT), the next location after + the largest file read in (MSZE), + the current value of the Program + counter (PC), and the address of + the end of available memory (END) + + Wfilespec,s,f (Write) Write the contents of a contiguous + block of memory to filespec. + f is finish address + + X{f}{r} (Examine) Examine/alter CPU state. + f is flag bit C,Z,M,E or I. + r is register A,B,D,H,S or P. + + ///2Examples + + A>SID + + CP/M 3 loads SID from drive A into memory. SID displays the + # prompt when it is ready to accept commands. + + A>B:SID SAMPLE.HEX + + CP/M 3 loads SID and the program file SAMPLE.HEX into memory + from drive B. + + ///2Utilities + + SID utilities, HIST.UTL and TRACE.UTL are special programs that + operate with SID to provide additional debugging facilities. The + mechanisms for system initialization, data collection, and + data display are described in the CP/M SID User's Guide. + + The HIST utility creates a histogram (bar graph) showing the + relative frequency of execution of code within selected + program segments of the test program. The HIST utility allows + you to monitor those sections of code that execute most + frequently. + + The TRACE utility obtains a backtrace of the instructions that + led to a particular breakpoint address in a program under test. + You can collect the addresses of up to 256 instructions + between pass points in U or T modes. + + ///1SUBMIT + + Syntax: + + SUBMIT {filespec} {argument} ... {argument} + + Explanation: + + The SUBMIT command lets you execute a group (batch) of + commands from a SUBmit file (a file with filetype of SUB). + + ///2Subfile + + The SUB file can contain the following types of lines: + + Any valid CP/M 3 command + Any valid CP/M 3 command with SUBMIT parameters ($0-$9) + Any data input line + Any program input line with parameters ($0 to $9) + + The command line cannot exceed 135 characters. + + The following lines illustrate the variety of lines which may + be entered in a SUB file: + + DIR + DIR *.BAK + MAC $1 $$$4 + PIP LST:=$1.PRN[T$2 $3 $5] + DIR *.ASM + PIP + SUBMIT + A>SUBMIT SUBA + A>SUBMIT AA ZZ SZ + A>SUBMIT B:START DIR E: + + ///2PROFILE.SUB + + Everytime you power up or reset your computer, CP/M 3 looks for a + special SUBmit file named PROFILE.SUB to execute. If it does not + exist, CP/M 3 resumes normal operation. If the PROFILE.SUB file + exists, the system executes the commands in the file. This file + is convenient to use if you regularly execute a set of commands + before you do your regular session on the computer. + + ///1TYPE + + Syntax: + + TYPE {filespec {[ PAGE | NOPAGE ]}} + + Explanation: + + The TYPE command displays the contents of an ASCII + character file on your screen. + + [PAGE] Causes the console listing to be displayed in paged + mode; i.e., stop automatically after listing n lines + of text, where n normally defaults to 24 lines per + page. + + [NOPAGE] Turns off Console Page Mode and continuously displays a + typed file on the screen. + + ///2Examples + + A>TYPE MYPROG.PLI + + Displays the contents of the file MYPROG.PLI on your screen. + + A>TYPE B:THISFILE [PAGE] + + Displays the contents of the file THISFILE from drive B on + your screen twenty four lines at a time. + + ///1USER + + Syntax: + + USER {number} + + Explanation: + + The USER command sets the current user number. The disk + directory can be divided into distinct groups according to a + "User Number." User numbers range from 0 through 15. + + ///2Examples + + A>USER + Enter User#:5 + 5A> + + The current user number is now 5 on drive A. + + A>USER 3 + 3A> + + This command changes the current User Number to 3. + + ///1XREF + + Syntax: + + XREF {d:} filename {$P} + + Explanation: + + XREF provides a cross-reference summary of variable usage + in a program. XREF requires the .PRN and .SYM files produced + by MAC or RMAC for input to the program. The SYM and PRN files + must have the same filename as the filename in the XREF command + tail. XREF outputs a file of type .XRF. + + Examples: + + A>XREF b:MYPROG + + A>XREF b:MYPROG $P + + ///1WHATS-NEW + + All the CP/M 3 patches described in the document CPM3FIX.PAT + have been applied to the source code, except those relating to + INITDIR. Patches applied were nos. 1-18, except nos. 5 and 9. + + CP/M 3 is now fully Year 2000 compliant. This affects the + programs DATE.COM, DIR.COM and SHOW.COM. + + Dates can be displayed in US, UK or Year-Month-Day format. This + is set by SETDEF. + + The CCP has a further bug fix: A command sequence such as: + + C1 + :C2 + :C3 + + will now not execute the command C3 if the command C1 failed. + + diff --git a/software/CPM/cpm3/help.plm b/software/CPM/cpm3/help.plm new file mode 100644 index 0000000..1aacced --- /dev/null +++ b/software/CPM/cpm3/help.plm @@ -0,0 +1,1091 @@ +$title ('Help Utility Version 1.1') +help: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. 579 + Pacific Grove, CA 93950 + + Revised: + 06 Dec 82 by Bruce Skidmore +*/ + + declare plm label public; + +/********************************************** + Interface Procedures +**********************************************/ + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + +/********************************************** + Global Variables +**********************************************/ + + declare (list$mode,nopage$mode,create$mode,extract$mode,page$mode) byte; + declare (offset,eod) byte; + + declare cmdrv (1) byte external; /* [JCE] Help patch 2 */ + declare fcb (13) byte external; + declare fcb2 (36) byte; + + declare maxb address external; + declare fcb16 (1) byte external; + declare tbuff (128) byte external; + + declare control$z literally '1AH'; + declare cr literally '0DH'; + declare lf literally '0AH'; + declare tab literally '09H'; + declare slash literally '''/'''; + declare true literally '0FFH'; + declare false literally '00H'; + + declare (cnt,index) byte; + declare sub(12) byte; + declare com(11) structure( + name(15) byte); + + declare sysbuff(8) structure( + subject(12) byte, + record address, + rec$offset byte, + level byte) at (.memory); + + declare name(12) byte; + declare level byte; + declare gindex address; + declare tcnt byte; + declare version address; + declare page$len byte; + declare display$cols byte; + declare clear$screen (26) byte initial (cr,lf,lf,lf,lf,lf,lf, + lf,lf,lf,lf,lf,lf, + lf,lf,lf,lf,lf,lf, + lf,lf,lf,lf,lf,lf,'$'); + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + read$console: + procedure byte; + return mon2 (1,0); + end read$console; + + write$console: + procedure (char); + declare char byte; + call mon1 (2,char); + end write$console; + + print$console$buf: + procedure (buff$adr); + declare buff$adr address; + call mon1 (9,buff$adr); + end print$console$buf; + + read$console$buff: + procedure (buff$adr); + declare buff$adr address; + call mon1(10,buff$adr); + end read$console$buff; + + direct$con$io: + procedure(func) byte; + declare func byte; + return mon2(6,func); + end direct$con$io; + + get$version: + procedure address; + return mon3(12,0); + end get$version; + + delete$file: + procedure (fcb$address); + declare fcb$address address; + call mon1(19,fcb$address); + end delete$file; + + open$file: + procedure (fcb$address) byte; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + fcb(12) = 0; /* EX = 0 */ + fcb(32) = 0; /* CR = 0 */ + return mon2 (15,fcb$address); + end open$file; + + close$file: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (16,fcb$address); + end close$file; + + read$record: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (20,fcb$address); + end read$record; + + write$record: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2(21,fcb$address); + end write$record; + + make$file: + procedure (fcb$address) byte; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + fcb(12) = 0; /* EX = 0 */ + fcb(32) = 0; /* CR = 0 */ + return mon2(22,fcb$address); + end make$file; + + read$rand: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2(33,fcb$address); + end read$rand; + + set$dma: + procedure (dma$address); + declare dma$address address; + call mon1(26,dma$address); + end set$dma; + + set$rand$rec: + procedure (fcb$address); + declare fcb$address address; + call mon1(36,fcb$address); + end set$rand$rec; + + terminate: + procedure; + call mon1 (0,0); + end terminate; + +/********************************************* + Error Procedure + + Displays error messages and + terminates if required. +*********************************************/ +error: + procedure(term$code,err$msg$adr); + declare term$code byte; + declare err$msg$adr address; + + call print$console$buf(.(cr,lf,'ERROR: $')); + call print$console$buf(err$msg$adr); + call print$console$buf(.(cr,lf,'$')); + if term$code then + call terminate; + end error; + +/********************************************* + Move Procedure + + Moves specified number of bytes + from the Source address to the + Destination address. +*********************************************/ +movef: + procedure (mvcnt,source$addr,dest$addr); + declare (source$addr,dest$addr) address; + declare mvcnt byte; + call move(mvcnt,source$addr,dest$addr); + return; + end movef; + +/********************************************* + Compare Function + + Compares 12 byte strings + + Results: 0 - string1 = string2 + 1 - string1 < string2 + 2 - string1 > string2 +*********************************************/ +compare: + procedure(str1$addr,str2$addr) byte; + declare (str1$addr,str2$addr) address; + declare string1 based str1$addr (12) byte; + declare string2 based str2$addr (12) byte; + declare (result,i) byte; + result, + i = 0; + do while ((i < 12) and (string1(i) <> ' ')); + if string1(i) <> string2(i) then + do; + if string1(i) < string2(i) then + do; + result = 1; + end; + else + do; + result = 2; + end; + i = 11; + end; + i = i + 1; + end; + return result; + end compare; + +/********************************************* + Increment Procedure + + Increments through a record. +*********************************************/ +inc: + procedure (inci) byte; + declare inci byte; + inci = inci + 1; + if inci > 127 then + do; + if read$record(.fcb) = 0 then + do; + inci = 0; + end; + else + do; + eod = true; + inci = 0; + end; + end; + return inci; + end inc; + +/************************************** + Page$check Procedure + + Halts display after page$len lines +**************************************/ +page$check: + procedure(line$cnt$addr) byte; + declare line$cnt$addr address; + declare line$cnt based line$cnt$addr byte; + declare quit byte; + quit = 0; + if (not nopage$mode) and (page$mode) then + do; + if (line$cnt:=line$cnt+1) > page$len then + do; + call print$console$buf(.(cr,lf,'Press RETURN to continue $')); + line$cnt = 0; + do while (line$cnt = 0); + line$cnt = direct$con$io(0FDH); + end; + call print$console$buf(.(cr,' ', + cr,'$')); + if line$cnt = 3 /* control c */ then + do; + line$cnt = close$file(.fcb); + call terminate; + end; + else + do; + if line$cnt <> cr then + do; + quit = true; + end; + line$cnt = 0; + end; + end; + else + do; + call write$console(lf); + end; + end; + else + do; + line$cnt = 0; + call write$console(lf); + end; + return quit; + end page$check; + +/******************************************* + Init Procedure + + Reads the index into memory +*******************************************/ +init: + procedure; + declare (buf$size,max$buf,init$i) address; + declare end$index byte; + buf$size = maxb - .memory; + max$buf = buf$size; + end$index = 0; + init$i = 7; + do while (not end$index) and (max$buf > 127); + call set$dma(.sysbuff(init$i-7).subject); + if read$record(.fcb) <> 0 then + do; + init$i = close$file(.fcb); + call error(true,.('Reading HELP.HLP index.$')); + end; + if sysbuff(init$i).subject(0) = '$' then end$index = true; + if not end$index then + do; + max$buf = max$buf - 128; + init$i = init$i + 8; + end; + end; + call set$dma(.tbuff); + if (max$buf < 128) and (not end$index) then + do; + init$i = close$file(.fcb); + call error(true,.('Too many entries in Index Table.', + ' Not enough memory.$')); + end; + end init; + + +/******************************************* + Parse Procedure + + Parses the command tail +*******************************************/ +parse: + procedure byte; + declare (index,begin,cnt,i,stop,bracket) byte; + index = 0; + if tbuff(0) <> 0 then + do; + do index = 1 to tbuff(0); + if tbuff(index) = tab then tbuff(index) = ' '; + else if tbuff(index) = ',' then tbuff(index) = ' '; + end; + index = 1; + do while(index < tbuff(0)) and (tbuff(index) = ' '); + index = index + 1; + end; + if tbuff(index) = '.' then + do; + begin = level; + tbuff(index) = ' '; + end; + else + begin = 0; + do index = begin to 10; + call movef(15,.(' ',cr,'$'),.com(index).name); + end; + index = begin; + cnt = 1; + stop, + bracket = 0; + do while (tbuff(cnt) <> 0) and (not stop); + if (tbuff(cnt) <> 20H) then + do; + i = 0; + do while (((tbuff(cnt) <> 20H) and (tbuff(cnt) <> '[')) and + (tbuff(cnt) <> 0)) and ((i < 12) and (index < 11)); + if (tbuff(cnt) > 60H) and (tbuff(cnt) < 7BH) then + do; + com(index).name(i) = tbuff(cnt) - 20H; + end; + else + do; + com(index).name(i) = tbuff(cnt); + end; + cnt = cnt + 1; + i = i + 1; + end; + index = index + 1; + if (bracket or (index > 10)) then + do; + stop = true; + end; + else + if tbuff(cnt) = '[' then + do; + if com(index-1).name(0) = ' ' then index = index - 1; + com(index).name(0) = '['; + cnt = cnt + 1; + index = index + 1; + bracket = true; + end; + end; + else + do; + cnt = cnt + 1; + end; + end; + end; + list$mode, + nopage$mode, + create$mode, + extract$mode = false; + if index > 0 then + do; + i = 0; + do while (i < 10); + if com(i).name(0) = '[' then + do; + if (com(i+1).name(0) = 'C') then + do; + create$mode = true; + index = index - 2; + end; + else if (com(i+1).name(0) = 'E') then + do; + extract$mode = true; + index = index - 2; + end; + else if (com(i+1).name(0) = 'N') then + do; + nopage$mode =true; + index = index - 2; + end; + else if (com(i+1).name(0) = 'L') then + do; + list$mode = true; + nopage$mode = true; + index = index - 2; + end; + else if (com(i+1).name(0) <> ' ') then + do; + index = index - 2; + end; + else + do; + index = index - 1; + end; + i = 10; + end; + i = i + 1; + end; + end; + return index; + end parse; + +/****************************************** + Create$index Procedure + + Creates HELP.HLP from HELP.DAT +******************************************/ +create$index: + procedure; + declare (cnt, i, rec$cnt) byte; + declare (index,count,count2,max$buf,save$size) address; + declare fcb3(36) byte; + call print$console$buf(.(cr,lf,'Creating HELP.HLP....$')); + do i = 0 to 7; + call movef(12,.('$ '),.sysbuff(i).subject); + end; + rec$cnt, + index = 0; + save$size = maxb - .memory; + max$buf = save$size; + call movef(13,.(0,'HELP DAT',0),.fcb); + if open$file(.fcb) = 0FFH then + do; + call error(true,.('HELP.DAT not on current drive.$')); + end; + eod = 0; + do while (not eod) and (read$record(.fcb) = 0); + i = 0; + do while(i < 128) and (not eod); + if tbuff(i) = control$z then + do; + eod = true; + end; + else + do; + if tbuff(i) = slash then + do; + cnt = 0; + do while(not eod) and (tbuff(i) = slash); + i = inc(i); + cnt = cnt + 1; + end; + if (cnt = 3) and (not eod) then + do; + sysbuff(index).level = tbuff(i) - '0'; + i = inc(i); + cnt = 0; + do while ((cnt < 12) and (not eod)) and (tbuff(i) <> cr); + if (tbuff(i) > 60H) and (tbuff(i) < 7BH) then + do; + sysbuff(index).subject(cnt) = tbuff(i) - 20H; + end; + else + do; + sysbuff(index).subject(cnt) = tbuff(i); + end; + i = inc(i); + cnt = cnt + 1; + end; + if (not eod) then + do; + call set$rand$rec(.fcb); + call movef(1,.fcb(33),.sysbuff(index).record); + call movef(1,.fcb(34),.sysbuff(index).record+1); + sysbuff(index).record = sysbuff(index).record - 0001H; + sysbuff(index).rec$offset = i; + index = index + 1; + if ((index mod 8) = 0) then + do; + rec$cnt = rec$cnt + 1; + max$buf = max$buf - 128; + if (max$buf < 128) and (not eod) then + do; + cnt = close$file(.fcb); + call error(true, + .('Too many entries in Index Table.', + ' Not enough memory.$')); + end; + else + do count = index to index + 7; + call movef(12,.('$ '), + .sysbuff(count).subject); + end; + end; + end; + end; + end; + else + do; + i = inc(i); + end; + end; + end; + end; + call set$dma(.sysbuff); + rec$cnt = rec$cnt + 1; + /******************************** + create HELP.HLP + ********************************/ + call movef(13,.(0,'HELP HLP',0),.fcb3); + call delete$file(.fcb3); + if make$file(.fcb3) = 0FFH then + do; + cnt = close$file(.fcb2); + call delete$file(.fcb2); + cnt = close$file(.fcb); + call error(true,.('Unable to Make HELP.HLP.$')); + end; + call movef(4,.(0,0,0,0),.fcb2+32); + cnt = read$rand(.fcb2); + do count = 0 to index - 1; + sysbuff(count).record = sysbuff(count).record + rec$cnt; + end; + do count = 0 to rec$cnt - 1; + call set$dma(.memory(shl(count,7))); + if write$record(.fcb3) = 0FFH then + do; + cnt = close$file(.fcb3); + call delete$file(.fcb3); + cnt = close$file(.fcb2); + call delete$file(.fcb2); + cnt = close$file(.fcb); + call error(true,.('Writing file HELP.HLP.$')); + end; + end; + call movef(4,.(0,0,0,0),.fcb+32); + cnt = read$rand(.fcb); + eod = 0; + do while (not eod); + count = 0; + max$buf = save$size; + do while (not eod) and (max$buf > 127); + call set$dma(.memory(shl(count,7))); + if read$record(.fcb) <> 0 then + do; + eod = true; + end; + else + do; + max$buf = max$buf - 128; + count = count + 1; + end; + end; + do count2 = 0 to count-1; + call set$dma(.memory(shl(count2,7))); + if write$record(.fcb3) = 0FFH then + do; + i = close$file(.fcb3); + call delete$file(.fcb3); + i = close$file(.fcb); + call error(true,.('Writing file HELP.HLP.$')); + end; + end; + end; + if close$file(.fcb) = 0FFH then + do; + cnt = close$file(.fcb3); + call error(true,.('Closing file HELP.DAT.$')); + end; + if close$file(.fcb3) = 0FFH then + do; + call error(true,.(false,'Closing file HELP.HLP.$')); + end; + call print$console$buf(.('HELP.HLP created',cr,lf,'$')); + end create$index; + +/******************************************** + Extract$file Procedure + + Creates HELP.DAT from HELP.HLP +********************************************/ +extract$file: + procedure; + declare (end$index,i) byte; + declare (count,count2,max$buf,save$size) address; + + call print$console$buf(.(cr,lf,'Extracting data....$')); + call movef(13,.(0,'HELP HLP',0),.fcb); + if open$file(.fcb) = 0FFH then + do; + call error(true,.('Unable to find file HELP.HLP.$')); + end; + call movef(13,.(0,'HELP DAT',0),.fcb2); + call delete$file(.fcb2); + if make$file(.fcb2) = 0FFH then + do; + i = close$file(.fcb); + call error(true,.('Unable to Make HELP.DAT.$')); + end; + call set$dma(.sysbuff); + end$index = 0; + do while ((i := read$record(.fcb)) = 0) and (not end$index); + if sysbuff(7).subject(0) = '$' then end$index = true; + end; + eod = 0; + if i <> 0 then eod = true; + i = write$record(.fcb2); + save$size = maxb - .memory; + do while (not eod); + count = 0; + max$buf = save$size; + do while (not eod) and (max$buf > 127); + call set$dma(.memory(shl(count,7))); + if read$record(.fcb) <> 0 then + do; + eod = true; + end; + else + do; + max$buf = max$buf - 128; + count = count + 1; + end; + end; + do count2 = 0 to count-1; + call set$dma(.memory(shl(count2,7))); + if write$record(.fcb2) = 0FFH then + do; + i = close$file(.fcb2); + call delete$file(.fcb2); + i = close$file(.fcb); + call error(true,.('Writing file HELP.DAT.$')); + end; + end; + end; + if close$file(.fcb) = 0FFH then + do; + call error(false,.('Unable to Close HELP.HLP.$')); + end; + if close$file(.fcb2) = 0FFH then + do; + call delete$file(.fcb2); + call error(true,.('Unable to Close HELP.DAT.$')); + end; + call print$console$buf(.('Extraction complete',cr,lf,lf, + 'HELP.DAT created',cr,lf,'$')); + + end extract$file; + +/*********************************************** + Display$ind Procedure + + Displays the avialable topics +***********************************************/ +display$ind: + procedure; + declare (disp$level,i,eod,written) byte; + declare (offset,index,count) address; + declare name (14) byte; + offset, + written, + eod = 0; + disp$level = level + 1; + if disp$level < 10 then + do; + if level = 0 then + do; + offset = 0; + end; + else + do; + offset = gindex; + end; + count = 0; + end; + else + do; + eod = true; + end; + index = offset; + offset = 0; + do while (not eod); + if sysbuff(index).subject(0) = '$' then + do; + eod = true; + end; + else + do; + if sysbuff(index).level = disp$level then + do; + if not written then + do; + written = true; + i = page$check(.tcnt); + if disp$level = 1 then + do; + call print$console$buf(.(cr,'Topics available:$')); + end; + else + do; + call print$console$buf(.(cr,'ENTER .subtopic FOR ', + 'INFORMATION ON THE FOLLOWING SUBTOPICS:$')); + end; + i = page$check(.tcnt); + call print$console$buf(.(cr,'$')); + end; + if (count mod display$cols) = 0 then + do; + i = page$check(.tcnt); + call write$console(cr); + end; + do i = 0 to 13; + name(i) = ' '; + end; + name(13) = '$'; + call movef(12,.sysbuff(index).subject,.name); + call print$console$buf(.name); + count = count + 1; + end; + else + do; + if sysbuff(index).level < disp$level then eod = true; + end; + index = index + 1; + end; + end; + if written then + do; + i = page$check(.tcnt); + call print$console$buf(.(cr,lf,'$')); + end; + call set$dma(.tbuff); + end display$ind; + +/********************************************* + Search$file Procedure + + Searches the index table for the key +*********************************************/ +search$file: + procedure byte; + declare (eod, error, cnt, found, saved, save$level) byte; + declare index address; + eod, + error, + found, + saved, + index = 0; + do while(not eod) and (not error); + if sysbuff(index).subject(0) <> '$' then + do; + if sysbuff(index).level = level + 1 then + do; + cnt = compare(.com(level).name,.sysbuff(index).subject); + if cnt = 0 then + do; + call movef(12,.sysbuff(index).subject,.com(level).name); + level = level + 1; + if (not saved) then + do; + save$level = level; + saved = true; + end; + if ((level > 8) or (com(level).name(0) = ' ')) + or (com(level).name(0) = '[') then + do; + found = true; + eod = true; + end; + else + do; + index = index + 1; + found = 0; + end; + end; + else + do; + index = index + 1; + end; + end; + else + do; + if saved then + do; + if save$level < sysbuff(index).level then + do; + index = index + 1; + end; + else + do; + error = true; + end; + end; + else + do; + index = index + 1; + end; + end; + end; + else + do; + error = true; + end; + end; + if found then + do; + gindex = index + 1; + call movef(1,.sysbuff(index).record,.fcb(33)); + call movef(1,.sysbuff(index).record+1,.fcb(34)); + fcb(35) = 0; + offset = sysbuff(index).rec$offset; + level = sysbuff(index).level; + end; + return error; + end search$file; + +/************************************** + Token Display Procedure + + Displays the Parsed Tokens +**************************************/ +display$tokens: + procedure (no$tokens); + declare (token$cnt1, token$cnt2, no$tokens) byte; + token$cnt1 = 0; + do while (token$cnt1 < no$tokens) and (not eod); + eod = page$check(.tcnt); + if (not eod) then + do; + do token$cnt2 = 0 to token$cnt1; + call print$console$buf(.(' $')); + end; + call print$console$buf(.com(token$cnt1).name); + token$cnt1 = token$cnt1 + 1; + end; + end; + end display$tokens; + +/************************************** + Print Procedure + + Displays the Help text +**************************************/ +print: + procedure; + declare (i,ii,char,eod2) byte; + declare temp(3) byte; + call write$console(cr); + call display$tokens(level); + if (not eod) then eod = page$check(.tcnt); + if (not eod) then + do; + if read$rand(.fcb) <> 0 then + do; + offset =close$file(.fcb); + call error(true,.('Reading file HELP.HLP.$')); + end; + else + do; + eod2 = 0; + do while ((not eod2) and (not eod)) and (read$record (.fcb) = 0); + i = offset - 1; + do while (((i:=i+1) <= 127) and (not eod2)); + if (char := tbuff(i)) = control$z then eod = true; + ii = 0; + do while((not eod2) and (not eod)) and + ((ii < 3) and (tbuff(i) = slash)); + ii = ii + 1; + i = inc(i); + temp(ii-1) = tbuff(i); + end; + if ii = 3 then eod2 = true; else temp(ii) = '$'; + if ((not eod) and (not eod2)) then + do; + if (char = lf) and (not nopage$mode) then + do; + eod = page$check(.tcnt); + end; + else + do; + call write$console (char); + end; + if ii > 0 then call print$console$buf(.temp); + ii = 0; + end; + end; + offset = 0; + end; + end; + end; + eod = 0; + end print; + +/************************************** + Prompt Procedure + + Prompts for input from the user +***************************************/ +prompt: + procedure byte; + declare temp byte; + call movef(1,.(128),.tbuff-1); + temp = page$check(.tcnt); + call print$console$buf(.(cr,'HELP> $')); + call read$console$buff(.tbuff-1); + tbuff(tbuff(0)+1) = 0; + tcnt = -1; + temp = parse; + if (temp <> 0) and (not list$mode) + then call print$console$buf(.clear$screen); + return temp; + end prompt; + + +/************************************** + Main Program +**************************************/ + +declare last$dseg$byte byte + initial (0); + + +plm: + do; + eod, + tcnt = 0; + version = get$version; + if (high(version) = 1) or (low(version) < 30h) then + do; + call error(true,.('Requires CP/M Version 3$')); + end; + page$len = mon2(49,.(1ch,0)) - 1; + display$cols = low((mon2(49,.(1ah,0))+1) / 13); + if mon2(49,.(2ch,0)) = 0 then + page$mode = true; + else + page$mode = false; + cnt = parse; + if create$mode then + do; + call create$index; + end; + else + if extract$mode then + do; + call extract$file; + end; + else + do; + call movef(13,.(0,'HELP ',0A0H,' HLP',0),.fcb); /* open read/only */ + fcb(0) = cmdrv(0); /* [JCE] Help patch 2 */ + if open$file (.fcb) <> 0FFH then + do; + call init; + if (not list$mode) then + call print$console$buf(.clear$screen); + if cnt = 0 then + do; + level = 0; + call print$console$buf(.(cr,lf,'HELP UTILITY v1.1 pl3',cr,lf,lf, + 'At "HELP>" enter ', + 'topic {,subtopic}...',cr,lf,lf, + /* [JCE] CP/M 3 Patch 11 */ 'EXAMPLE: HELP> DIR BUILT-IN', + cr,lf,'$')); + tcnt = 2; + call display$ind; + cnt = prompt; /* Prompt for user input */ + end; + do while cnt <> 0; /* If user didn't hit a return do */ + level = 0; + if compare(.com(0).name,.('? ')) = 0 then + do; + ; /* NULL COMMAND */ + end; + else + if search$file <> 0FFH then + do; + call print; + if compare(.com(0).name,.('HELP ')) = 0 then + do; + level = 0; + end; + end; + else + do; + eod = page$check(.tcnt); + call write$console(cr); + if (not eod) then + do; + eod = page$check(.tcnt); + if (not eod) then + do; + call print$console$buf(.('Topic:$')); + eod = page$check(.tcnt); + call write$console(cr); + call display$tokens(cnt); + eod = page$check(.tcnt); + call write$console(cr); + eod = page$check(.tcnt); + call write$console(cr); + call print$console$buf(.('Not found$')); + eod = page$check(.tcnt); + call write$console(cr); + end; + end; + level = 0; + end; + if (not eod) then call display$ind; + cnt = prompt; /* Prompt for user input */ + end; + offset = close$file(.fcb); + end; + else + do; + call error(false,.('No HELP.HLP file on the default drive.$')); + end; + end; + end; + call terminate; +end help; diff --git a/software/CPM/cpm3/hexcom.asm b/software/CPM/cpm3/hexcom.asm new file mode 100644 index 0000000..9a9ab9a --- /dev/null +++ b/software/CPM/cpm3/hexcom.asm @@ -0,0 +1,663 @@ +title 'CP/M 3 - HEXCOM - Oct 1982' +; + +; Copyright (C) 1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, CA 93950 + +; Revised: +; 22 Oct 82 by Paul Lancaster +; 25 Oct 82 by Doug Huskey +; +; +; ********** HEXCOM ********** +; + +;PROGRAM TO CREATE A CP/M "COM" FILE FROM A "HEX" FILE. + +;THIS PROGRAM IS VERY SIMILAR IN FUNCTION TO THE CP/M +;UTILITY CALLED "LOAD". IT IS OPTIMIZED WITH RESPECT TO +;EXECUTION SPEED AND MEMORY SPACE. IT RUNS ABOUT TWICE +;AS FAST AS THE CP/M COUNTERPART ON A LONG "HEX" FILE. +;IT IS ALSO ABOUT 700 BYTES SHORTER. + +;ONE MINOR DIFFERENCE BETWEEN "HEXCOM" AND "LOAD" THAT MAY +;BE VISIBLE TO THE USER IS THAT VERY LARGE LOAD ADDRESS +;INVERSIONS ARE TOLERATED BY "HEXCOM", WHEREAS THE MAXIMUM +;ALLOWED INVERSION IN "LOAD" IS 80H. THE MAXIMUM IN "HEXCOM" +;IS A FUNCTION OF THE TPA SIZE. +;CAUTION SHOULD BE EXERCIZED WHEN USING AN INVERSION GREATER +;THAN 80H IN "HEXCOM" SINCE PART OF THE COMFILE MAY NOT +;GET CREATED IF THE FINAL LOAD ADDRESS IS INVERTED WITH +;RESPECT TO THE "LAST ADDRESS" IN THE "HEX" FILE. + +;******************************************************* + +;VERSION 1.00 6 MARCH 1979 +;ORIGINAL VERSION. +;******************************************************* + +;22 October 1982 - Changed assumed CCP length for CP/M-PLUS +;25 October 1982 - Changed version to 3.0 +; +; EQUATES + +VERS EQU 300 ;VERSION TIMES 100 +CR EQU 0DH +LF EQU 0AH +BDOS EQU 5 +DEFAULT$FCB EQU 5CH + + + ORG 100H + + ; include file for use with ASM programs + ; + ;********************************************* + ;* STANDARD DIGITAL RESEARCH COM FILE HEADER * + ;********************************************* + ; + JMP BEGIN ;LABEL CAN BE CHANGED + ; + ;********************************************* + ;* Patch Area, Date, Version & Serial Number * + ;********************************************* + ; + dw 0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + db 0 + + db 'CP/M Version 3.0' + maclib makedate ;[JCE] Build date + @LCOPY + @BDATE ; version date day-month-year + db 0,0,0,0 ; patch bit map + db '654321' ; Serial no. + +; +BEGIN: +; code starts here + LXI H,0 + DAD SP ;GET CURRENT CCP STACK + SHLD STACK$SAVE ;SAVE IT + LXI SP,STACK ;INIT LOCAL STACK + LXI D,SIGNON$MSG ;POINT SIGN-ON MESSAGE + CALL PRINT$BUFFER ;SEND IT TO CONSOLE + LXI D,DEFAULT$FCB ;FILE NAME TO HEX FCB + LXI H,HEX$FCB + PUSH D ;SAVE COM FCB ADDR + PUSH H ;-AND HEX FCB ADDR + MVI C,33 ;MOVE ENTIRE FCB +MOVEFCB LDAX D ;GET BYTE FROM DFLT FCB + MOV M,A ;MOVE TO HEX FCB + INX D ;BUMP POINTERS + INX H + DCR C ;HIT COUNTER + JNZ MOVEFCB ;LOOP TILL DONE + LXI H,HEX$FCB+9 ;"HEX" TYPE NAME TO FCB + MVI M,'H' + INX H + MVI M,'E' + INX H + MVI M,'X' + LXI H,DEFAULT$FCB+9 ;"COM" TYPE NAME TO FCB + MVI M,'C' + INX H + MVI M,'O' + INX H + MVI M,'M' + POP D ;HEX$FCB TO + MVI C,15 ;OPEN FILE + CALL BDOS + INR A ;SEE IF -1 FOR ERROR + LXI D,COSMSG + JZ ERROR$ABORT ;CANNOT OPEN SOURCE + POP D ;COM FCB ADDR + PUSH D ;KEEP COPY ON STACK + MVI C,19 ;DELETE FILE + CALL BDOS ;DELETE OLD "COM" FILE + POP D ;GET COM FCB ADDR AGAIN + PUSH D ;SAVE IT STILL + MVI C,22 ;MAKE FILE + CALL BDOS ;CREATE "COM" FILE + INR A ;SEE IF -1 FOR ERROR + LXI D,NMDSMSG + JZ ERROR$ABORT ;NO MORE DIR SPACE + +;DEFINE AND CLEAR THE COMFILE BUFFER + + LDA 7 ;GET BDOS PAGE ADDRESS + SUI 16 ;ALLOW FOR UP TO 4K CCP + MOV H,A ;HI BYTE OF COM BUFFER TOP + MVI L,0 ;END ON PAGE BOUNDARY + SHLD CURR$COM$BUF$END + SUI (HIGH COMFILE$BUFFER)+1 + MVI L,80H ;START IN MIDDLE OF PAGE + MOV H,A ;BUFFER LENGTH IN PAGES + SHLD CURR$COM$BUF$LEN + CALL CLEAR$COMBUFFER ;ZERO-OUT COM BUFFER + +; HEX RECORD LOOP + +SCAN$FOR$COLON: + CALL GET$HEXFILE$CHAR + CPI ':' ;DO WE HAVE COLON YET? + JNZ SCAN$FOR$COLON + CALL GET$BINARY$BYTE ;GOT COLON. GET LOAD COUNT + STA LOAD$COUNT ;STORE COUNT FOR THIS RECORD + JZ FINISH$UP ;ZERO MEANS ALL DONE + +;INCREMENT BYTES-READ COUNTER BY NUMBER OF BYTES TO BE +;LOADED IN THIS RECORD. + + LXI H,BYTES$READ$COUNT + ADD M ;ADD LO BYTE OF SUM + MOV M,A ;SAVE NEW LO BYTE + JNC FORM$LOAD$ADDRESS + INX H ;POINT HI BYTE OF SUM + INR M ;BUMP HI BYTE + +;NOW SET NEW LOAD ADDRESS FROM THE +;HEX FILE RECORD. + +FORM$LOAD$ADDRESS: + CALL GET$BINARY$BYTE + PUSH PSW + CALL GET$BINARY$BYTE + POP H ;HI BYTE TO + MOV L,A ;AND LO BYTE TO + SHLD LOAD$ADDRESS ;SAVE NEW LOAD ADDRESS + XCHG ;PUT IN + LHLD CURRENT$COM$BASE + +;NEW LOAD ADDRESS MINUS THE CURRENT COMFILE BASE GIVES +;THE NEW COM BUFFER OFFSET. + + MOV A,E + SUB L + MOV L,A + MOV A,D + SBB H + MOV H,A + SHLD COM$BUF$OFFSET ;STORE NEW OFFSET + LXI D,ILAMSG ;POINT ERR MSG + JC ERROR$ABORT ;FATAL INVERSION IF CY SET + +;FIRST ADDRESS HAS ALREADY BEEN ESTABLISHED IF "FIRST$ADDRESS" +;IS NON-ZERO. + + LDA FIRST$ADDRESS+1 ;--ONLY PAGE NO. NEED BE + ORA A ;--CHECKED SINCE 1ST ADDR + JNZ GET$ZERO$BYTE ;--CAN'T BE IN PAGE ZERO + LXI D,FAMSG ;POINT "1ST ADDR" MSG + CALL MSG$ON$NEW$LINE ;ANNOUNCE FIRST ADDRESS + LHLD LOAD$ADDRESS ;THIS IS FIRST ADDR + SHLD FIRST$ADDRESS ;SET FIRST ADDRESS + CALL WORD$OUT ;SEND IT TO CONSOLE + +;SKIP OVER THE ZERO BYTE OF THE HEX RECORD. IT HAS NO +;SIGNIFICANCE TO THIS PROGRAM. + +GET$ZERO$BYTE: + CALL GET$BINARY$BYTE + +;THIS LOOP LOADS THE COM FILE WITH THE BYTE VALUES IN THE +;CURRENT HEX RECORD. + +BYTE$LOAD$LOOP: + CALL GET$BINARY$BYTE ;GET BYTE TO LOAD + CALL PUT$TO$COMFILE ;LOAD IT TO COM FILE + LXI H,LOAD$COUNT + DCR M ;HIT LOAD COUNT + JNZ BYTE$LOAD$LOOP ;MORE LOADING IF NOT-ZERO + +;UPDATE THE LAST ADDRESS IF CURRENT ABSOLUTE LOAD ADDRESS +;IS HIGHER THAN THE CURRENT VALUE OF "LAST$ADDRESS" + + LHLD LAST$ADDRESS ;GET THE CURR VALUE + XCHG ;TO + CALL ABSOLUTE ;ABSOLUTE ADDR TO + MOV A,E ;--SUBTRACT ABSOLUTE + SUB L ;--ADDRESS FROM CURRENT + MOV A,D ;--LAST ADDRESS + SBB H + JNC CHECK$CHECKSUM ;LAST ADDR LARGER IF NC + DCX H ;DOWN 1 FOR LAST ACTUAL LOAD + SHLD LAST$ADDRESS ;UPDATE IT + +;VERIFY THE CHECKSUM FOR THIS RECORD. + +CHECK$CHECKSUM: + CALL GET$BINARY$BYTE ;GET CHECKSUM BYTE + JZ SCAN$FOR$COLON ;ZERO ON FOR CHECKSUM OK + LXI D,CSEMSG ;CHECKSUM ERROR + JMP HEXFILE$ERROR + +;SEND PROCESSING SUMMARY TO THE CONSOLE AND FLUSH THE +;COM BUFFER OF ANY UNWRITTEN DATA. + +FINISH$UP: + LXI D,LSTADDRMSG ;POINT "LAST ADDR" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + LHLD LAST$ADDRESS ;GET THE LAST ADDRESS + CALL WORD$OUT ;SEND IT TO CONSOLE + LXI D,BRMESSAGE ;POINT "BYTES READ" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + LHLD BYTES$READ$COUNT ;GET THE COUNT + CALL WORD$OUT ;SEND IT OUT + +;THE FOLLOWING CODE PREPARES FOR AND MAKES THE FINAL CALL +;TO THE "PUT" ROUTINE IN ORDER TO FLUSH THE "COM" BUFFER. +;IT HAS BEEN "KLUGED" IN ORDER TO WORK AROUND THE BOUNDARY +;CONDITION OF HAVING AN OFFSET OF <100H AT FLUSH TIME. +;WE FORCE THE OFFSET AND LENGTH TO BE NON-ZERO SO THE +;INITIAL COMPARE IN THE "PUT" ROUTINE WON'T GET SCREWED +;UP. THE BUFFER END ADDRESS IS NOT PLAYED WITH, HOWEVER. +;THIS IS TO INSURE THAT THE CORRECT NUMBER OF RECORDS GET +;WRITTEN. + + LHLD COM$BUF$OFFSET ;GET THE CURRENT OFFSET + PUSH H ;SAVE OFFSET FOR LATER + LXI D,COMFILE$BUFFER ;GET BUFFER ADDRESS + DAD D ;ADD TO OFFSET TO GET LEN + SHLD CURR$COM$BUF$END ;STORE NEW END ADDR + LXI H,CLEAR$FLAG ;POINT TO CLEAR FLAG + INR M ;DISABLE CLEAR WITH NON-ZERO + POP H ;GET OFFSET BACK + MVI H,1 ;FORCE HI BYTE NON-ZERO + SHLD COM$BUF$OFFSET ;FAKE OFFSET + SHLD CURR$COM$BUF$LEN ;AND FAKE LENGTH + CALL PUT$TO$COMFILE ;FLUSH THE BUFFER + LXI D,RWMSG ;POINT "REC WRIT" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + LDA RECORDS$WRITTEN ;GET THE COUNT + CALL BYTE$OUT ;SEND IT OUT + CALL CRLF ;SEND OUT CRLF + POP D ;COM FILE FCB ADDR + MVI C,16 ;CLOSE FILE + CALL BDOS ;COM FILE CLOSE + INR A ;SEE IF -1 FOR ERROR + LXI D,CCFMSG ;CANNOT CLOSE FILE + JZ ERROR$ABORT +CRLF$AND$EXIT: + CALL CRLF +EXIT: + LXI D,80H + MVI C,26 ;RE-SET DMA TO 80H + CALL BDOS + LHLD STACK$SAVE ;RECOVER CCP STACK POINTER + SPHL ;TO + RET ;RET TO CCP + + + + +; SUBROUTINES + + + +;THIS ROUTINE GETS TWO CHARACTERS FROM THE HEX FILE +;AND CONVERTS TO AN 8-BIT BINARY VALUE, RETURNED IN . + +GET$BINARY$BYTE: + CALL GET$HEX$DIGIT ;GET HI NYBBLE FIRST + ADD A ;SHIFT UP 4 SLOTS + ADD A + ADD A + ADD A + PUSH PSW ;SAVE HI NYBBLE + CALL GET$HEX$DIGIT ;NOW GET LO NYBBLE + POP B ;HI NYBBLE TO + ORA B ;COMBINE NYBBLES TO FORM BYTE + MOV B,A ;SAVE THE BYTE + LXI H,CHECKSUM + ADD M ;UPDATE THE CHECKSUM + MOV M,A ;AND STORE IT + MOV A,B ;GET BYTE BACK + RET ;ZERO SET MEANS CHECKSUM=0 + + +;ROUTINE TO GET A HEX-ASCII CHARACTER FROM THE HEX FILE +;AND RETURN IT IN THE REGISTER CONVERTED TO BINARY. +;A CHECK FOR LEGAL HEX VALUE IS MADE. PROGRAM ABORTS +;WITH APPROPRIATE MESSAGE IF ILLEGAL DIGIT ENCOUNTERED. + +GET$HEX$DIGIT: + CALL GET$HEXFILE$CHAR + SUI '0' ;REMOVE ASCII BIAS + CPI 10 ;DECIMAL DIGIT? + RC + SUI 7 ;STRIP ADDITIONAL BIAS + CPI 10 ;MUST BE AT LEAST 10 + JC ILLHEX + CPI 16 ;MUST BE 15 OR LESS + RC +ILLHEX LXI D,IHDMSG ;ILLEGAL HEX DIGIT + +;ROUTINE TO INDICATE THAT AN ERROR HAS BEEN FOUND IN THE +;HEX FILE (EITHER CHECKSUM OR ILLEGAL HEX DIGIT). +;APPROPRIATE MESSAGES ARE PRINTED AND THE PROGRAM ABORTS. + +HEXFILE$ERROR: + CALL MSG$ON$NEW$LINE ;PRINT ERROR TYPE + LXI D,LAMESSAGE ;POINT "LOAD ADDR" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + LHLD LOAD$ADDRESS ;GET LOAD ADDR + CALL WORD$OUT ;SEND IT OUT + LXI D,EAMSG ;POINT "ERR ADDR" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + CALL ABSOLUTE ;GET ABSOLUTE ADDR + CALL WORD$OUT ;THIS IS ERR ADDR + LXI D,BRMESSAGE ;POINT "BYTES READ" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + CALL PRINT$LOAD$ADDR ;SEND OUT CURR LOAD ADDR + +;PRINT OUT ALL BYTES THAT WERE LOADED FROM THE CURRENT +;HEX RECORD UP TO THE POINT WHERE THE ERROR WAS DETECTED. + +ERR$OUT$LOOP: + LHLD LOAD$ADDRESS ;POINT TO BYTE TO BE OUTPUT + XCHG ;TO + CALL ABSOLUTE ;GET ABSOLUTE ADDR + MOV A,E ;--SEE IF "LOAD ADDR" + SUB L ;--HAS REACHED ABSO ADDR + MOV A,D + SBB H + JNC CRLF$AND$EXIT ;DONE IF THEY'RE EQUAL + MOV A,E ;SEE IF MULTIPLE OF 16 + ANI 0FH + CZ PRINT$LOAD$ADDR ;IF MULTIPLE OF 16 + LHLD LOAD$ADDRESS ;GET LOAD ADDR AGAIN + XCHG ;TO + LHLD CURRENT$COM$BASE + MOV A,E ;--CALC OFFSET OF CURR + SUB L ;--BYTE TO GO OUT + MOV L,A ;LO BYTE OF OFFSET + MOV A,D ;HI BYTE OF LOAD ADDR + SBB H + MOV H,A ;HI BYTE OF OFFSET + LXI B,COMFILE$BUFFER + DAD B ; NOW POINTS TO BYTE TO GO + MOV A,M ;GET THE BYTE FROM BUFFER + CALL BYTE$OUT ;SEND IT OUT + LHLD LOAD$ADDRESS ;BUMP LOAD ADDRESS + INX H + SHLD LOAD$ADDRESS + MVI A,' ' ;SEND A SPACE BETWEEN BYTES + CALL CHAR$TO$CONSOLE + JMP ERR$OUT$LOOP ;BACK FOR MORE + + + +;ROUTINE TO GET A CHARACTER FROM THE HEX FILE BUFFER. +;CHAR IS RETURNED IN . + + +GET$HEXFILE$CHAR: + LDA HEX$BUFFER$OFFSET + INR A ;BUMP HEX OFFSET + JP GETCHAR ;PLUS IF NOT 80H YET + LXI D,HEX$BUFFER + MVI C,26 ;SET-DMA CODE + CALL BDOS ;SET DMA ADDR TO HEX BUFFER + LXI D,HEX$FCB ;POINT HEX FCB + MVI C,20 ;READ-NEXT-RECORD CODE + CALL BDOS ;GET NEXT HEXFILE RECORD + ORA A ;TEST FOR ERROR + LXI D,DRMSG ;ASSUME ERROR FOR NOW + JNZ ERROR$ABORT ;FATAL ERR IF NOT ZERO +GETCHAR: + STA HEX$BUFFER$OFFSET + MVI H,HIGH HEX$BUFFER + MOV L,A ;POINT TO NEXT CHAR + MOV A,M ;GET THE CHARACTER + RET + + +; +;THIS ROUTINE PUTS A DATA BYTE TO THE "COM" FILE. +;THE BYTE IS PASSED IN . +;THE FIRST COMPARE IS DONE ON JUST THE HI BYTES FOR THE +;SAKE OF SPEED, SINCE WE ARE PROCESSING THE "HEX" FILE +;"ON THE FLY". + +PUT$TO$COMFILE: + PUSH PSW ;SAVE BYTE TO LOAD + LHLD COM$BUF$OFFSET ;GET CURRENT OFFSET + XCHG ;TO +PTC LDA CURR$COM$BUF$LEN+1 ;PAGE NO. OF BUFF TOP + DCR A ;ONE LESS FOR COMPARE + CMP D ;TOP < OFFSET? + JNC STORE$BYTE ;STORE BYTE IF NOT + LHLD CURR$COM$BUF$LEN + MOV A,E ;SUBTRACT LEN FROM OFFSET-- + SUB L ;--TO GET NEW OFFSET + MOV C,A ; HAS LO BYTE OF DIFF + MOV A,D ;HI BYTE OF OFFSET + SBB H ;MINUS HI BYTE OF BUFF LENGTH + MOV B,A ; HAS NEW OFFSET + PUSH B ;SAVE NEW OFFSET + XCHG ;BUFFER LENGTH TO + LHLD CURRENT$COM$BASE ;COM BASE TO + DAD D ;INCREASE IT BY BUFFER LENGTH + SHLD CURRENT$COM$BASE ;STORE NEW BASE + LHLD CURR$COM$BUF$END + LXI D,COMFILE$BUFFER ;BUFFER ADDR TO +COMLOOP: + MOV A,E ;SUBTRACT BUFF END FROM POINTER + SUB L + MOV A,D + SBB H ;WRITTEN TO END OF BUFFER YET? + JNC STORE ;CY OFF MEANS WE'RE DONE + PUSH H ;SAVE BUFFER END ADDRESS + PUSH D ;SAVE WRITE POINTER + MVI C,26 ;SET DMA FUNCTION CODE + CALL BDOS ;SET NEW DMA ADDRESS + MVI C,21 ;WRITE-NEXT-RECORD CODE + LXI D,DEFAULT$FCB ;POINT COM FILE FCB + CALL BDOS ;WRITE NEXT COM RECORD + ORA A ;TEST FOR ERROR ON WRITE + LXI D,DWMSG ;POINT WRITE ERROR MSG + JNZ ERROR$ABORT ;BOMB IF WRITE ERROR + POP D ;RESTORE WRITE POINTER + LXI H,128 ;SECTOR SIZE + DAD D ;BUMP POINTER BY 128 + XCHG ;NEW POINTER TO + LXI H,RECORDS$WRITTEN + INR M + POP H ;RESTORE BUFFER END ADDR + JMP COMLOOP ;SEE IF END OF BUFFER YET +STORE: + LDA CLEAR$FLAG ;GET CLEAR-BUFFER FLAG + ORA A ;SHALL WE CLEAR? + CZ CLEAR$COMBUFFER ;ZERO THE BUFFER + POP D ;GET BACK NEW OFFSET + JMP PTC ;SEE IF WE MUST FLUSH AGAIN +STORE$BYTE: + LXI H,COMFILE$BUFFER ;BUFFER ADDR TO + DAD D ;ADD TO CURRENT OFFSET + POP PSW ;RETRIEVE BYTE TO WRITE + MOV M,A ;STUFF IT + INX D ;BUMP OFFSET + XCHG ;TO FOR STORE + SHLD COM$BUF$OFFSET ;UPDATE OFFSET + RET ;ALL DONE + + +; +;ROUTINE TO CONVERT THE 2-BYTE VALUE IN TO +;TWO ASCII CHARACTERS AND SEND THEM TO THE CONSOLE. +; +WORD$OUT: + PUSH H ;SAVE WORD + MOV A,H ;HI WORD GOES OUT 1ST + CALL BYTE$OUT + POP H ;RESTORE WORD + MOV A,L ;LO BYTE GOES NEXT +BYTE$OUT: + PUSH PSW ;SAVE BYTE + RRC! RRC! RRC! RRC ;HI NYBBLE COMES DOWN + CALL NYBBLE$OUT + POP PSW ;RESTORE VALUE +NYBBLE$OUT: + ANI 0FH + ADI 90H + DAA + ACI 40H + DAA +CHAR$TO$CONSOLE: + MOV E,A + MVI C,2 ;WRITE CONSOLE CHAR FUNC CODE + JMP BDOS +; +;ROUTINE TO OUTPUT A "CRLF". +; +CRLF: + MVI A,CR + CALL CHAR$TO$CONSOLE + MVI A,LF + JMP CHAR$TO$CONSOLE +; +;ROUTINE TO PRINT A BUFFER TO THE CONSOLE. +; POINTS TO THE MESSAGE ON ENTRY. +;EARLIEST ENTRY POINT STARTS MESSAGE ON A NEW LINE +; +MSG$ON$NEW$LINE: + PUSH D ;SAVE MESSAGE POINTER + CALL CRLF ;START NEW LINE + POP D ;RESTORE MESSAGE POINTER +PRINT$BUFFER: + MVI C,9 ;OUTPUT BUFFER TO CONSOLE + JMP BDOS +; +; +;ERROR ABORT ROUTINE +; + +ERROR$ABORT: + PUSH D ;SAVE MESSAGE POINTER + LXI D,ERRMSG ;POINT "ERROR" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + POP D ;RESTORE MESSAGE POINTER + CALL PRINT$BUFFER ;SEND OUT ERR TYPE + LXI D,LAMESSAGE ;POINT "LOAD ADDR" MSG + CALL MSG$ON$NEW$LINE ;SEND IT OUT + CALL ABSOLUTE ;GET ABSOLUTE ADDR + CALL WORD$OUT ;SEND IT OUT + JMP EXIT ;BAIL OUT + +;THIS ROUTINE PRINTS THE LOAD ADDRESS OF THE CURRENT +;HEX RECORD ON A NEW LINE FOLLOWED BY A ':' AND SPACE. + +PRINT$LOAD$ADDR: + CALL CRLF + LHLD LOAD$ADDRESS + CALL WORD$OUT + MVI A,':' + CALL CHAR$TO$CONSOLE + MVI A,' ' + JMP CHAR$TO$CONSOLE + + +;ROUTINE TO CLEAR THE COMFILE BUFFER. + + +CLEAR$COMBUFFER: + LXI H,COMFILE$BUFFER + LDA CURR$COM$BUF$END+1 ;PAGE NO. OF BUF END + MVI C,0 ;GET ZERO +CLOOP MOV M,C ;ZERO TO BUFFER + INX H ;BUMP POINTER + CMP H ;END OF BUFFER YET? + JNZ CLOOP ;LOOP TILL DONE + RET + + +;ROUTINE TO COMPUTE CURRENT ABSOLUTE LOAD ADDRESS +;AND RETURN IT IN + + +ABSOLUTE: + LHLD CURRENT$COM$BASE ;GET BASE OF COM BUFFER + MOV B,H ;MOVE IT TO + MOV C,L + LHLD COM$BUF$OFFSET ;GET THE CURRENT OFFSET + DAD B ;SUM IS THE ABSO ADDR + RET + + +; MESSAGES + + +ERRMSG: + DB 'ERROR: $' +DRMSG: + DB 'DISK READ$' +ILAMSG: + DB 'LOAD ADDRESS LESS THAN 100$' +DWMSG: + DB 'DISK WRITE$' +LAMESSAGE: + DB 'LOAD ADDRESS $' +EAMSG: + DB 'ERROR ADDRESS $' +IHDMSG: + DB 'INVALID HEX DIGIT$' +CSEMSG: + DB 'CHECKSUM ERROR $' +FAMSG: + DB 'FIRST ADDRESS $' +LSTADDRMSG: + DB 'LAST ADDRESS $' +BRMESSAGE: + DB 'BYTES READ $' +RWMSG: + DB 'RECORDS WRITTEN $' +COSMSG: + DB 'CANNOT OPEN SOURCE FILE$' +NMDSMSG: + DB 'DIRECTORY FULL$' +CCFMSG: + DB 'CANNOT CLOSE FILE$' +SIGNON$MSG: + DB 'HEXCOM VERS: ',VERS/100+'0' + DB '.',VERS/10 MOD 10 +'0' + DB VERS MOD 10 + '0',CR,LF,'$' + + +; DATA AREA + + + +HEX$BUFFER$OFFSET DB 127 +FIRST$ADDRESS DW 0 +LAST$ADDRESS DW 0 +BYTES$READ$COUNT DW 0 +RECORDS$WRITTEN DB 0 +LOAD$ADDRESS DW 100H +CURRENT$COM$BASE DW 100H +CHECKSUM DB 0 +COM$BUF$OFFSET DW 0 +CLEAR$FLAG DB 0 ;CLEAR-COM-BUF FLAG + + + +; STORAGE AREA + + + +STACK$SAVE DS 2 +HEX$FCB DS 33 +LOAD$COUNT DS 1 +CURR$COM$BUF$END DS 2 ;COM BUFFER TOP +CURR$COM$BUF$LEN DS 2 ;COM BUFFER LENGTH + DS 32 ;STACK AREA +STACK EQU $ + ORG ((HIGH $)+1)*256 +HEX$BUFFER DS 128 +COMFILE$BUFFER EQU $ + END + \ No newline at end of file diff --git a/software/CPM/cpm3/hexcom.c b/software/CPM/cpm3/hexcom.c new file mode 100644 index 0000000..cc65438 --- /dev/null +++ b/software/CPM/cpm3/hexcom.c @@ -0,0 +1,118 @@ +/* + * load - convert a hex file to a com file + * + * Expanded to HEXCOM by John Elliott, 25-5-1998 + * + * Compiles with gcc or Pacific C + * + */ + +#include +#include + +unsigned char checksum; +int L; + +FILE *fpout; + +unsigned char getbyte () { + register int c; + unsigned char x; + + c = getchar (); + if ('0' <= c && c <= '9') + x = c - '0'; + else + if ('A' <= c && c <= 'F') + x = c - 'A' + 10; + else + goto funny; + + x <<= 4; + c = getchar (); + if ('0' <= c && c <= '9') + x |= c - '0'; + else + if ('A' <= c && c <= 'F') + x |= c - 'A' + 10; + else { + funny: + fprintf (stderr, "Funny hex letter %c\n", c); + exit (2); + } + checksum += x; + return x; +} + +main (int argc, char **argv) { + register unsigned i, n; + char c, buf[64]; + unsigned type; + unsigned int al, ah, addr = 0, naddr; + + L = 0; + if (argc < 2) fpout = stdout; + else fpout = fopen(argv[1],"wb"); + + do { + do { + c = getchar (); + if (c == EOF) { + fprintf (stderr, "Premature EOF colon missing\n"); + exit (1); + } + } while (c != ':'); + + ++L; + checksum = 0; + n = getbyte (); /* bytes / line */ + ah = getbyte (); + al = getbyte (); + + + switch (type = getbyte ()) + { + case 0: + if (!n) /* MAC uses a line with no bytes as EOF */ + { + type = 1; + break; + } + naddr = (ah << 8) | al; + if (!addr) addr = naddr; + else while (addr < naddr) + { + fwrite("", 1, 1, fpout); + ++addr; + } + if (addr > naddr) + { + fprintf(stderr,"Line %d: Records out of sequence at %x > %x\n", L, naddr, addr); + exit(1); + } + + for (i = 0; i < n; i++) + buf[i] = getbyte (); + fwrite (buf, 1, n, fpout); + break; + + case 1: + break; + + default: + fprintf (stderr, "Line %d: Funny record type %d\n", L, type); + exit (1); + } + + (void) getbyte (); + if (checksum != 0) + { + fprintf (stderr, "Line %d: Checksum error", L); + exit (2); + } + + addr += n; + + } while (type != 1); + exit(0); +} diff --git a/software/CPM/cpm3/hexpat.c b/software/CPM/cpm3/hexpat.c new file mode 100644 index 0000000..3717afb --- /dev/null +++ b/software/CPM/cpm3/hexpat.c @@ -0,0 +1,134 @@ +/* + * load - convert a hex file to a com file + * + * Converted to HEXPAT by John Elliott, 25-5-1998 + * + * Compiles with gcc or Pacific C + * + */ + +#include +#include + +unsigned char checksum; +int L; + +FILE *fpout, *fpcom; + +unsigned char getbyte () { + register int c; + unsigned char x; + + c = getchar (); + if ('0' <= c && c <= '9') + x = c - '0'; + else + if ('A' <= c && c <= 'F') + x = c - 'A' + 10; + else + goto funny; + + x <<= 4; + c = getchar (); + if ('0' <= c && c <= '9') + x |= c - '0'; + else + if ('A' <= c && c <= 'F') + x |= c - 'A' + 10; + else { + funny: + fprintf (stderr, "Funny hex letter %c\n", c); + exit (2); + } + checksum += x; + return x; +} + +main (int argc, char **argv) { + register unsigned i, n; + char c, buf[64]; + int j; + unsigned type; + unsigned int al, ah, addr = 0x100, naddr; + + L = 0; + if (argc < 3) fpout = stdout; + else fpout = fopen(argv[2],"wb"); + + fpcom = fopen(argv[1], "rb"); + + do { + do { + c = getchar (); + if (c == EOF) { + fprintf (stderr, "Premature EOF colon missing\n"); + exit (1); + } + } while (c != ':'); + + ++L; + checksum = 0; + n = getbyte (); /* bytes / line */ + ah = getbyte (); + al = getbyte (); + + + switch (type = getbyte ()) + { + case 0: + if (!n) /* MAC uses a line with no bytes as EOF */ + { + type = 1; + break; + } + naddr = (ah << 8) | al; + while (addr < naddr) + { + j = fgetc(fpcom); + if (j == EOF) fputc(0, fpout); + else fputc(j, fpout); + ++addr; + } + if (addr > naddr) + { + fprintf(stderr,"Line %d: Records out of sequence at %x > %x\n", L, naddr, addr); + exit(1); + } + + for (i = 0; i < n; i++) + { + /* Step through the COM file */ + (void)fgetc(fpcom); + buf[i] = getbyte (); + } + fwrite (buf, 1, n, fpout); + break; + + case 1: + break; + + default: + fprintf (stderr, "Line %d: Funny record type %d\n", L, type); + exit (1); + } + + (void) getbyte (); + if (checksum != 0) + { + fprintf (stderr, "Line %d: Checksum error", L); + exit (2); + } + + addr += n; + + } while (type != 1); + + j = fgetc(fpcom); + while (j != EOF) + { + fputc(j, fpout); + j = fgetc(fpcom); + } + + exit(0); +} diff --git a/software/CPM/cpm3/inpout.asm b/software/CPM/cpm3/inpout.asm new file mode 100644 index 0000000..e576c5a --- /dev/null +++ b/software/CPM/cpm3/inpout.asm @@ -0,0 +1,32 @@ +$title ('INP:/OUT: Interface') + name inpout + cseg +; +; CP/M 3 PIP Utility INP: / OUT: Interface module +; Code org'd at 080h +; July 5, 1982 + +public inploc,outloc,inpd,outd + + org 00h +inpd: + call inploc + ret + +outd: + call outloc + ret + +inploc: + mvi a,01Ah + ret + +outloc: + ret + nop + nop + + org 07fh + db 0 +end +EOF diff --git a/software/CPM/cpm3/ldrlwr.asm b/software/CPM/cpm3/ldrlwr.asm new file mode 100644 index 0000000..13c03bb --- /dev/null +++ b/software/CPM/cpm3/ldrlwr.asm @@ -0,0 +1,195 @@ +$title ('CP/M V3.0 Relocate and Fix Up File') + name relfix +; +;/* +; Copyright (C) 1979,1980,1981,1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, CA 93950 +; +; Revised: +; 05 Aug 82 by Bruce Skidmore +;*/ + + cseg + + extrn mon1 ;BDOS entry point + extrn FCBin ;FCB for input + extrn sctbfr ;sector buffer + extrn offset ;relocation offset + extrn prgsiz ;program size + extrn bufsiz ;buffer size + extrn bnkpg ;bnkbdos page + extrn respg ;resbdos page + extrn scbpg ;System Control Block page + extrn biospg ;Bios page + extrn reslen ;Resident System length + extrn bnkoff ;Banked System offset + extrn nonbnk ;Non Banked CP/M flag + + public bitmap ;bitmap buffer + +RelFix: + public RelFix + lxi d,bitmap + mvi c,26 + call mon1 ;set DMA address to bit map +; + ;file loaded, ready for relocation + lhld prgsiz + mov b,h + mov c,l ;BC = program size + mov a,l + ani 127 + mov l,a + jnz nofill ;if program size is an even number + push h ;of sectors prefill the bitmap buffer + push b + lhld fcbin + xchg + mvi c,20 + call mon1 + pop b + pop h + ora a + jnz errtn +nofill: + mov e,l ;L = offset into bitmap buffer + mvi d,0 + lxi h,bitmap + dad d ;HL = bit map base + mvi a,low(bitmap+128) + sta btmptp ;save number of relocation bytes + ;in left in bitmap buffer + lxi d,sctbfr ;DE = base of program + push h ;save bit map base in stack + lda offset + mov h,a ;H = relocation offset +pgrel0: + mov a,b ;bc=0? + ora c + jz ExitRelFix +; +; not end of the relocation, +; may be into next byte of bit map + dcx b ;count length down + mov a,e + sui low(sctbfr) + ani 111b ;0 causes fetch of next byte + jnz pgrel3 +; fetch bit map from stacked address + xthl + lda btmptp + cmp l + jnz pgrel2 + push b + push d + lhld FCBin + xchg + mvi c,20 + call mon1 + pop d + pop b + lxi h,bitmap + ora a + jnz errtn ;return with error condition +pgrel2: + mov a,m ;next 8 bits of map + inx h + xthl ;base address goes back to stack + mov l,a ;l holds map as 8 bytes done +pgrel3: + mov a,l + ral ;cy set to 1 if reloc necessary + mov l,a ;back to l for next time around + jnc pgrel4 ;skip relocation if cy=0 +; +; current address requires relocation +; + push h + ldax d ;if page = 0ffh + inr a + jnz test2 + lda biospg ;then page = bios$page + jmp endt +test2: ;else + inr a ;if page = 0feh + jnz test3 + lda scbpg ;then page = SCB$page + push psw + dcx d ;add 9ch to the offset(low byte) + ldax d + adi 09ch + stax d + inx d + pop psw + jmp endt +test3: ;else + inr a ;if page = 0fdh + jnz test4 + lda respg ;then page = resbdos$page + jmp endt +test4: ;else + inr a ;if page = 0fch + jnz test5 + lda bnkpg ;then page = bnkbdos$page + jmp endt +test5: ;else + inr a ;if page = 0fbh + jnz test6 + lda scbpg ;then page = scb$page + jmp endt +test6: ;else + lda reslen + mov h,a ;if non$banked and page >= reslen + lda nonbnk + ora a + jz test7 + ldax d + sub h + jc default ;then do; + dcx d ;page$adr = page$adr - 1; + mvi a,09ah + stax d ;page = 9ah; + inx d ;page$adr = page$adr + 1; + lda scbpg ;page = scb$pg; + jmp endt ;end; +test7: ;else + lda bnkoff + mov l,a ;if page >= reslen + ldax d + sub h + jc default + add l ;then page = page - reslen + jmp endt +default: ;else + lda offset ;page = page + offset + mov h,a + ldax d + add h +endt: + stax d + pop h +pgrel4: + inx d ;to next address + jmp pgrel0 ;for another byte to relocate + +ExitRelFix: + pop h + lxi h,0 + mov a,h + ret + +errtn: + pop h ;discard return address + lxi h,0ffffh + mov a,h + ret ;return with error condition +; +; Local Data Segment +; +bitmap: ds 128 ;bit map buffer +btmptp: ds 1 ;bit low (bitmap+128) + + end + \ No newline at end of file diff --git a/software/CPM/cpm3/loader3.asm b/software/CPM/cpm3/loader3.asm new file mode 100644 index 0000000..d80bb8f --- /dev/null +++ b/software/CPM/cpm3/loader3.asm @@ -0,0 +1,739 @@ +title 'CP/M 3 - PROGRAM LOADER RSX - November 1982' +; version 3.0b Nov 04 1982 - Kathy Strutynski +; version 3.0c Nov 23 1982 - Doug Huskey +; Dec 22 1982 - Bruce Skidmore +; +; +; copyright (c) 1982 +; digital research +; box 579 +; pacific grove, ca. +; 93950 +; + **************************************************** + ***** The following values must be placed in *** + ***** equates at the front of CCP3.ASM. *** + ***** *** + ***** Note: Due to placement at the front these *** + ***** equates cause PHASE errors which can be *** + ***** ignored. *** +equ1 equ rsxstart +0100h ;set this equate in the CCP +equ2 equ fixchain +0100h ;set this equate in the CCP +equ3 equ fixchain1+0100h ;set this equate in the CCP +equ4 equ fixchain2+0100h ;set this equate in the CCP +equ5 equ rsx$chain+0100h ;set this equate in the CCP +equ6 equ reloc +0100h ;set this equate in the CCP +equ7 equ calcdest +0100h ;set this equate in the CCP +equ8 equ scbaddr +0100h ;set this equate in the CCP +equ9 equ banked +0100h ;set this equate in the CCP +equ10 equ rsxend +0100h ;set this equate in the CCP +ccporg equ CCP ;set origin to this in CCP +patch equ patcharea+0100h ;LOADER patch area + +CCP equ 401h ;[JCE] was 41A before patches + ;ORIGIN OF CCP3.ASM + + + **************************************************** + +; conditional assembly toggles: + +true equ 0ffffh +false equ 0h +spacesaver equ true + +stacksize equ 32 ;16 levels of stack +version equ 30h +tpa equ 100h +ccptop equ 0Fh ;top page of CCP +osbase equ 06h ;base page in BDOS jump +off$nxt equ 10 ;address in next jmp field +currec equ 32 ;current record field in fcb +ranrec equ 33 ;random record field in fcb + + + +; +; +; dsect for SCB +; +bdosbase equ 98h ; offset from page boundary +ccpflag1 equ 0b3h ; offset from page boundary +multicnt equ 0e6h ; offset from page boundary +rsx$only$clr equ 0FDh ;clear load RSX flag +rsx$only$set equ 002h +rscbadd equ 3ah ;offset of scbadd in SCB +dmaad equ 03ch ;offset of DMA address in SCB +bdosadd equ 62h ;offset of bdosadd in SCB +; +loadflag equ 02H ;flag for LOADER in memory +; +; dsect for RSX +entry equ 06h ;RSX contain jump to start +; +nextadd equ 0bh ;address of next RXS in chain +prevadd equ 0ch ;address of previous RSX in chain +warmflg equ 0eh ;remove on wboot flag +endchain equ 18h ;end of RSX chain flag +; +; +readf equ 20 ;sequential read +dmaf equ 26 ;set DMA address +scbf equ 49 ;get/set SCB info +loadf equ 59 ;load function +; +; +maxread equ 64 ;maximum of 64 pages in MULTIO +; +; +wboot equ 0000h ;BIOS warm start +bdos equ 0005h ;bdos entry point +print equ 9 ;bdos print function +vers equ 12 ;get version number +module equ 200h ;module address +; +; DSECT for COM file header +; +comsize equ tpa+1h +scbcode equ tpa+3h +rsxoff equ tpa+10h +rsxlen equ tpa+12h +; +; +cr equ 0dh +lf equ 0ah +; +; + cseg +; +; +; ********* LOADER RSX HEADER *********** +; +rsxstart: + jmp ccp ;the ccp will move this loader to + db 0,0,0 ;high memory, these first 6 bytes + ;will receive the serial number from + ;the 6 bytes prior to the BDOS entry + ;point +tojump: + jmp begin +next db 0c3h ;jump to next module +nextjmp dw 06 +prevjmp dw 07 + db 0 ;warm start flag + db 0 ;bank flag + db 'LOADER ' ;RSX name + db 0ffh ;end of RSX chain flag + db 0 ;reserved + db 0 ;patch version number + +; ********* LOADER RSX ENTRY POINT *********** + +begin: + mov a,c + cpi loadf + jnz next +beginlod: + pop b + push b ;BC = return address + lxi h,0 ;switch stacks + dad sp + lxi sp,stack ;our stack + shld ustack ;save user stack address + push b ;save return address + xchg ;save address of user's FCB + shld usrfcb + mov a,h ;is .fcb = 0000h + ora l + push psw + cz rsx$chain ;if so , remove RSXs with remove flag on + pop psw + cnz loadfile + pop d ;return address + lxi h,tpa + mov a,m + cpi ret + jz rsxfile + mov a,d ;check return address + dcr a ; if CCP is calling + ora e ; it will be 100H + jnz retuser1 ;jump if not CCP +retuser: + lda prevjmp+1 ;get high byte + ora a ;is it the zero page (i.e. no RSXs present) + jnz retuser1 ;jump if not + lhld nextjmp ;restore five....don't stay arround + shld osbase + shld newjmp + call setmaxb +retuser1: + lhld ustack ;restore the stack + sphl + xra a + mov l,a + mov h,a ;A,HL=0 (successful return) + ret ;CCP pushed 100H on stack +; +; +; BDOS FUNC 59 error return +; +reterror: + lxi d,0feh +reterror1: + ;DE = BDOS error return + lhld ustack + sphl + pop h ;get return address + push h + dcr h ;is it 100H? + mov a,h + ora l + xchg ;now HL = BDOS error return + mov a,l + mov b,h + rnz ;return if not the CCP +; +; +loaderr: + mvi c,print + lxi d,nogo ;cannot load program + call bdos ;to print the message + jmp wboot ;warm boot + +; +; +;; +;************************************************************************ +; +; MOVE RSXS TO HIGH MEMORY +; +;************************************************************************ +; +; +; RSX files are present +; + +rsxf1: inx h + mov c,m + inx h + mov b,m ;BC contains RSX length + lda banked + ora a ;is this the non-banked system? + jz rsxf2 ;jump if so + inx h ;HL = banked/non-banked flag + inr m ;is this RSX only for non-banked? + jz rsxf3 ;skip if so +rsxf2: push d ;save offset + call calcdest ;calculate destination address and bias + pop h ;rsx offset in file + call reloc ;move and relocate file + call fixchain ;fix up rsx address chain +rsxf3: pop h ;RSX length field in header + + +rsxfile: + ;HL = .RSX (n-1) descriptor + lxi d,10h ;length of RSX descriptor in header + dad d ;HL = .RSX (n) descriptor + push h ;RSX offset field in COM header + mov e,m + inx h + mov d,m ;DE = RSX offset + mov a,e + ora d + jnz rsxf1 ;jump if RSX offset is non-zero +; +; +; +comfile: + ;RSXs are in place, now call SCB setting code + call scbcode ;set SCB flags for this com file + ;is there a real COM file? + lda module ;is this an RSX only + cpi ret + jnz comfile2 ;jump if real COM file + lhld scbaddr + mvi l,ccpflag1 + mov a,m + ori rsx$only$set ;set if RSX only + mov m,a +comfile2: + lhld comsize ;move COM module to 100H + mov b,h + mov c,l ;BC contains length of COM module + lxi h,tpa+100h ;address of source for COM move to 100H + lxi d,tpa ;destination address + call move + jmp retuser1 ;restore stack and return +;; +;************************************************************************ +; +; ADD AN RSX TO THE CHAIN +; +;************************************************************************ +; +; +fixchain: + lhld osbase ;next RSX link + mvi l,0 + lxi b,6 + call move ;move serial number down + mvi e,endchain + stax d ;set loader flag=0 + mvi e,prevadd+1 + stax d ;set previous field to 0007H + dcx d + mvi a,7 + stax d ;low byte = 7H + mov l,e ;HL address previous field in next RSX + mvi e,nextadd ;change previous field in link + mov m,e + inx h + mov m,d ;current <-- next +; +fixchain1: + ;entry: H=next RSX page, + ; DE=.(high byte of next RSX field) in current RSX + xchg ;HL-->current DE-->next + mov m,d ;put page of next RSX in high(next field) + dcx h + mvi m,6 +; +fixchain2: + ;entry: H=page of lowest active RSX in the TPA + ;this routine resets the BDOS address @ 6H and in the SCB + mvi l,6 + shld osbase ;change base page BDOS vector + shld newjmp ;change SCB value for BDOS vector +; +; +setmaxb: + lxi d,scbadd2 +scbfun: + mvi c,scbf + jmp bdos +; +; +;; +;************************************************************************ +; +; REMOVE TEMPORARY RSXS +; +;************************************************************************ +; +; +; +rsx$chain: + ; + ; Chase up RSX chain, removing RSXs with the + ; remove flag on (0FFH) + ; + lhld osbase ;base of RSX chain + mov b,h + +rsx$chain1: + ;B = current RSX + mov h,b + mvi l,endchain + inr m + dcr m ;is this the loader? + rnz ;return if so (m=0ffh) + mvi l,nextadd ;address of next node + mov b,m ;DE -> next link +; +; +check$remove: +; + mvi l,warmflg ;check remove flag + mov a,m ;warmflag in A + ora a ;FF if remove on warm start + jz rsx$chain1 ;check next RSX if not +; +remove: + ;remove this RSX from chain +; + ;first change next field of prior link to point to next RSX + ;HL = current B = next +; + mvi l,prevadd + mov e,m ;address of previous RSX link + inx h + mov d,m + mov a,b ;A = next (high byte) + stax d ;store in previous link + dcx d ;previous RSX chains to next RSX + mvi a,6 ;initialize low byte to 6 + stax d ; + inx d ;DE = .next (high byte) +; + ;now change previous field of next link to address previous RSX + mov h,b ;next in HL...previous in DE + mvi l,prevadd + mov m,e + inx h + mov m,d ;next chained back to previous RSX + mov a,d ;check to see if this is the bottom + ora a ;RSX... + push b + cz fixchain2 ;reset BDOS BASE to page in H + pop b + jmp rsx$chain1 ;check next RSX in the chain +; +; +;; +;************************************************************************ +; +; PROGRAM LOADER +; +;************************************************************************ +; +; +; +loadfile: +; entry: HL = .FCB + push h + lxi d,scbdma + call scbfun + xchg + pop h ;.fcb + push h ;save .fcb + lxi b,currec + dad b + mvi m,0 ;set current record to 0 + inx h + mov c,m ;load address + inx h + mov h,m + mov l,c + dcr h + inr h + jz reterror ;Load address < 100h + push h ;now save load address + push d ;save the user's DMA + push h + call multio1 ;returns A=multio + pop h + push psw ;save A = user's multisector I/O + mvi e,128 ;read 16k + + ;stack: |return address| + ; |.FCB | + ; |Load address | + ; |users DMA | + ; |users Multio | + ; + +loadf0: + ;HL= next load address (DMA) + ; E= number of records to read + lda osbase+1 ;calculate maximum number of pages + dcr a + sub h + jc endload ;we have used all we can + inr a + cpi maxread ;can we read 16k? + jnc loadf2 + rlc ;change to sectors + mov e,a ;save for multi i/o call + mov a,l ;A = low(load address) + ora a + jz loadf2 ;load on a page boundary + mvi b,2 ;(to subtract from # of sectors) + dcr a ;is it greater than 81h? + jm subtract ;080h < l(adr) <= 0FFh (subtract 2) + dcr b ;000h < l(adr) <= 080h (subtract 1) +subtract: + mov a,e ;reduce the number of sectors to + sub b ;compensate for non-page aligned + ;load address + jz endload ;can't read zero sectors + mov e,a +; +loadf2: + ;read the file + push d ;save number of records to read + push h ;save load address + call multio ;set multi-sector i/o + pop h + push h + call readb ;read sector + pop h + pop d ;restore number of records + push psw ;zero flag set if no error + mov a,e ;number of records in A + inr a + rar ;convert to pages + add h + mov h,a ;add to load address + shld loadtop ;save next free page address + pop psw + jz loadf0 ;loop if more to go + +loadf4: + ;FINISHED load A=1 if successful (eof) + ; A>1 if a I/O error occured + ; + pop b ;B=multisector I/O count + dcr a ;not eof error? + mov e,b ;user's multisector count + call multio + mvi c,dmaf ;restore the user's DMA address + pop d + push psw ;zero flag => successful load + call bdos ; user's DMA now restored + pop psw + lhld bdosret ;BDOS error return + xchg + jnz reterror1 + pop d ;load address + pop h ;.fcb + lxi b,9 ;is it a PRL? + dad b ;.fcb(type) + mov a,m + ani 7fh ;get rid of attribute bit + cpi 'P' ;is it a P? + rnz ;return if not + inx h + mov a,m + ani 7fh + cpi 'R' ;is it a R + rnz ;return if not + inx h + mov a,m + ani 7fh + sui 'L' ;is it a L? + rnz ;return if not + ;load PRL file + mov a,e + ora a ;is load address on a page boundary + jnz reterror ;error, if not + mov h,d + mov l,e ;HL,DE = load address + inx h + mov c,m + inx h + mov b,m + mov l,e ;HL,DE = load address BC = length +; jmp reloc ;relocate PRL file at load address +; +;; +;************************************************************************ +; +; PAGE RELOCATOR +; +;************************************************************************ +; +; +reloc: +; HL,DE = load address (of PRL header) +; BC = length of program (offset of bit map) + inr h ;offset by 100h to skip header + push d ;save destination address + push b ;save length in bc + call move ;move rsx to correct memory location + pop b + pop d + push d ;save DE for fixchain...base of RSX + mov e,d ;E will contain the BIAS from 100h + dcr e ;base address is now 100h + ;after move HL addresses bit map + ; + ;storage moved, ready for relocation + ; HL addresses beginning of the bit map for relocation + ; E contains relocation bias + ; D contain relocation address + ; BC contains length of code +rel0: push h ;save bit map base in stack + mov h,e ;relocation bias is in e + mvi e,0 +; +rel1: mov a,b ;bc=0? + ora c + jz endrel +; +; not end of the relocation, may be into next byte of bit map + dcx b ;count length down + mov a,e + ani 111b ;0 causes fetch of next byte + jnz rel2 +; fetch bit map from stacked address + xthl + mov a,m ;next 8 bits of map + inx h + xthl ;base address goes back to stack + mov l,a ;l holds the map as we process 8 locations +rel2: mov a,l + ral ;cy set to 1 if relocation necessary + mov l,a ;back to l for next time around + jnc rel3 ;skip relocation if cy=0 +; +; current address requires relocation + ldax d + add h ;apply bias in h + stax d +rel3: inx d ;to next address + jmp rel1 ;for another byte to relocate +; +endrel: ;end of relocation + pop d ;clear stacked address + pop d ;restore DE to base of PRL + ret + + +; +;; +;************************************************************************ +; +; PROGRAM LOAD TERMINATION +; +;************************************************************************ +; +;; +;; +endload: + call multio1 ;try to read after memory is filled + lxi h,80h ;set load address = default buffer + call readb + jnz loadf4 ;eof => successful + lxi h,0feh ;set BDOSRET to indicate an error + shld bdosret + jmp loadf4 ;unsuccessful (file to big) +; +;; +; +;; +;************************************************************************ +; +; SUBROUTINES +; +;************************************************************************ +; +; +; +; Calculate RSX base in the top of the TPA +; +calcdest: +; +; calcdest returns destination in DE +; BC contains length of RSX +; + lda osbase+1 ;a has high order address of memory top + dcr a ;page directly below bdos + dcx b ;subtract 1 to reflect last byte of code + sub b ;a has high order address of reloc area + inx b ;add 1 back get bit map offset + cpi ccptop ;are we below the CCP + jc loaderr + lhld loadtop + cmp h ;are we below top of this module + jc loaderr + mov d,a + mvi e,0 ;d,e addresses base of reloc area + ret +; +;; +;;----------------------------------------------------------------------- +;; +;; move memory routine + +move: +; move source to destination +; where source is in HL and destination is in DE +; and length is in BC +; + mov a,b ;bc=0? + ora c + rz + dcx b ;count module size down to zero + mov a,m ;get next absolute location + stax d ;place it into the reloc area + inx d + inx h + jmp move +;; +;;----------------------------------------------------------------------- +;; +;; Multi-sector I/O +;; (BDOS function #44) +; +multio1: + mvi e,1 ;set to read 1 sector +; +multio: + ;entry: E = new multisector count + ;exit: A = old multisector count + lhld scbaddr + mvi l,multicnt + mov a,m + mov m,e + ret +;; +;;----------------------------------------------------------------------- +;; +;; read file +;; (BDOS function #20) +;; +;; entry: hl = buffer address (readb only) +;; exit z = set if read ok +;; +readb: xchg +setbuf: mvi c,dmaf + push h ;save number of records + call bdos + mvi c,readf + lhld usrfcb + xchg + call bdos + shld bdosret ;save bdos return + pop d ;restore number of records + ora a + rz ;no error on read + mov e,h ;change E to number records read + ret +; +; +;************************************************************************ +; +; DATA AREA +; +;************************************************************************ +; + +nogo db cr,lf,'Cannot load Program$' + +patcharea: + ds 36 ;36 byte patch area + +scbaddr dw 0 +banked db 0 + +scbdma db dmaad + db 00h ;getting the value +scbadd2 db bdosadd ;current top of TPA + db 0feh ;set the value +; + + if not spacesaver + +newjmp ds 2 ;new BDOS vector +loadtop ds 2 ;page above loaded program +usrfcb ds 2 ;contains user FCB add +ustack: ds 2 ; user stack on entry +bdosret ds 2 ;bdos error return +; +rsxend : +stack equ rsxend+stacksize + + else + +rsxend: +newjmp equ rsxend +loadtop equ rsxend+2 +usrfcb equ rsxend+4 +ustack equ rsxend+6 +bdosret equ rsxend+8 +stack equ rsxend+10+stacksize + + endif + end + \ No newline at end of file diff --git a/software/CPM/cpm3/loader3.prl b/software/CPM/cpm3/loader3.prl new file mode 100644 index 0000000..31b64dc Binary files /dev/null and b/software/CPM/cpm3/loader3.prl differ diff --git a/software/CPM/cpm3/mac.com b/software/CPM/cpm3/mac.com new file mode 100644 index 0000000..f49e835 Binary files /dev/null and b/software/CPM/cpm3/mac.com differ diff --git a/software/CPM/cpm3/main.plm b/software/CPM/cpm3/main.plm new file mode 100644 index 0000000..05f1eef --- /dev/null +++ b/software/CPM/cpm3/main.plm @@ -0,0 +1,632 @@ + + /* C P / M - M P / M D I R E C T O R Y C O M M O N (SDIR) */ + + /* B E G I N N I N G O F C O M M O N M A I N M O D U L E */ + + + /* This module is included in main80.plm or main86.plm. */ + /* The differences between 8080 and 8086 versions are */ + /* contained in the modules main80.plm, main86.plm and */ + /* dpb80.plm, dpb86.plm and the submit files showing */ + /* the different link and location addresses. */ + + +$include (comlit.lit) +$include (mon.plm) + + +dcl patch (128) address; + +/* Scanner Entry Points in scan.plm */ + +scan: procedure(pcb$adr) external; + declare pcb$adr address; +end scan; + +scan$init: procedure(pcb$adr) external; + declare pcb$adr address; +end scan$init; + +/* -------- Routines in other modules -------- */ + +search$init: procedure external; /* initialization of search.plm */ +end search$init; + +get$files: procedure external; /* entry to search.plm */ +end get$files; + +sort: procedure external; /* entry to sort.plm */ +end sort; + +mult23: procedure (num) address external; /* in sort.plm */ +dcl num address; +end mult23; + +display$files: procedure external; /* entry to disp.plm */ +end display$files; + +/* -------- Routines in util.plm -------- */ + +printb: procedure external; +end printb; + +print$char: procedure(c) external; +dcl c byte; +end print$char; + +print: procedure(string$adr) external; +dcl string$adr address; +end print; + +crlf: procedure external; +end crlf; + +p$decimal: procedure(value,fieldsize,zsup) external; + dcl value address, + fieldsize address, + zsup boolean; +end p$decimal; + + +/* ------------------------------------- */ + +dcl debug boolean public initial (false); + +/* -------- version information -------- */ + +dcl (os,bdos) byte public; +$include (vers.lit) + +$include (fcb.lit) + +$include(search.lit) + +dcl find find$structure public initial + (false,false,false,false, false,false,false,false); + +dcl + num$search$files byte public initial(0), + no$page$mode byte public initial(0), + search (max$search$files) search$structure public; + +dcl first$f$i$adr address external; +dcl get$all$dir$entries boolean public; +dcl first$pass boolean public; + +dcl usr$vector address public initial(0), /* bits for user #s to scan */ + active$usr$vector address public, /* active users on curdrv */ + drv$vector address initial (0); /* bits for drives to scan */ + +$include (format.lit) + +dcl format byte public initial (form$full), + page$len address public initial (0ffffh), + /* lines on a page before printing new headers, 0 forces initial hdrs */ + message boolean public initial(false),/* show titles when no files found*/ + formfeeds boolean public initial(false),/* use form feeds */ + date$opt boolean public initial(false), /* dates display */ + display$attributes boolean public initial(false); /* attributes display */ + +dcl file$displayed boolean external; + /* true if 1 or more files displayed by dsh.plm */ + +dcl sort$op boolean initial (true); /* default is to do sorting */ +dcl sorted boolean external; /* if successful sort */ + + +dcl cur$usr byte public, /* current user being searched */ + cur$drv byte public; /* current drive " " */ + +/* -------- BDOS calls --------- */ + +get$version: procedure address; /* returns current version information */ + return mon2(12,0); +end get$version; + +select$drive: procedure(d); + declare d byte; + call mon1(14,d); +end select$drive; + +search$first: procedure(d) byte external; +dcl d address; +end search$first; + +search$next: procedure byte external; +end search$next; + +get$cur$drv: procedure byte; /* return current drive number */ + return mon2(25,0); +end get$cur$drv; + +getlogin: procedure address; /* get the login vector */ + return mon3(24,0); +end getlogin; + +getusr: procedure byte; /* return current user number */ + return mon2(32,0ffh); +end getusr; + +getscbbyte: procedure (offset) byte public; /* [JCE] public so the timest */ + declare offset byte; /* code can use it */ + declare scbpb structure + (offset byte, + set byte, + value address); + scbpb.offset = offset; + scbpb.set = 0; + return mon2(49,.scbpb); +end getscbbyte; + +set$console$mode: procedure; + /* set console mode to control-c only */ + call mon1(109,1); +end set$console$mode; + +terminate: procedure public; + call mon1 (0,0); +end terminate; + + +/* -------- Utility routines -------- */ + +number: procedure (char) boolean; + dcl char byte; + return(char >= '0' and char <= '9'); +end number; + +make$numeric: procedure(char$adr,len,val$adr) boolean; + dcl (char$adr, val$adr, place) address, + chars based char$adr (1) byte, + value based val$adr address, + (i,len) byte; + + value = 0; + place = 1; + do i = 1 to len; + if not number(chars(len - i)) then + return(false); + value = value + (chars(len - i) - '0') * place; + place = place * 10; + end; + return(true); +end make$numeric; + +set$vec: procedure(v$adr,num) public; + dcl v$adr address, /* set bit number given by num */ + vector based v$adr address, /* 0 <= num <= 15 */ + num byte; + if num = 0 then + vector = vector or 1; + else + vector = vector or shl(double(1),num); +end set$vec; + +bit$loc: procedure(vector) byte; + /* return location of right most on bit vector */ + dcl vector address, /* 0 - 15 */ + i byte; + i = 0; + do while i < 16 and (vector and double(1)) = 0; + vector = shr(vector,1); + i = i + 1; + end; + return(i); +end bit$loc; + +get$nxt: procedure(vector$adr) byte; + dcl i byte, + (vector$adr,mask) address, + vector based vector$adr address; +/* + if debug then + do; call print(.(cr,lf,'getnxt: vector = $')); + call pdecimal(vector,10000,false); + end; +*/ + if (i := bit$loc(vector)) > 15 then + return(0ffh); + mask = 1; + if i > 0 then + mask = shl(mask,i); + vector = vector xor mask; /* turn off bit */ +/* + if debug then + do; call print(.(cr,lf,'getnxt: vector, i, mask $')); + call pdecimal(vector,10000,false); + call printb; + call pdecimal(i,10000,false); + call printb; + call pdecimal(mask,10000,false); + end; +*/ + return(i); +end get$nxt; /* too bad plm rotates only work on byte values */ + +/* help: procedure; COMMENTED OUT - HELP PROGRAM REPLACE DISPLAY + +call print(.(cr,lf, +tab,tab,tab,'DIR EXAMPLES',cr,lf,lf, +'dir file.one',tab,tab,tab, +'(find a file on current user and default drive)',cr,lf, +'dir *.com d:*.pli',tab,tab,'(find matching files on default and d: drive)', +cr,lf, +'dir [rw]',tab,tab,tab,'(find files that are read/write)',cr,lf, +'dir [ro dir sys]',tab,tab,'(same for read/only, directory, system)',cr,lf, +'dir [xfcb]',tab,tab,tab,'(find files with XFCB''s)',cr,lf, +'dir [nonxfcb]',tab,tab,tab,'(find files without XFCB''s)',cr,lf, +'dir [exclude] *.com',tab,tab,'(find files that don''t end in ''com'')',cr,lf, +'dir [nosort]',tab,tab,tab,'(don''t sort the files)',cr,lf, +'dir [full]',tab,tab,tab,'(show all file information)',cr,lf, +'dir [size]',tab,tab,tab,'(show name and size in kilobytes)',cr,lf, +'dir [short]',tab,tab,tab,'(show just the file names)',cr,lf, +'dir [drive = all]',tab,tab,'(search all logged in drives)',cr,lf, +'dir [drive = (a,b,p)]',tab,tab, +'(search specified drives, ''disk'' is synonym)',cr,lf, +'dir [user = all]',tab,tab,'(find files with any user number)',cr,lf, +'dir [user = (0,1,15), G12]',tab,'(find files with specified user number)', +cr,lf, +'dir [length = n]',tab,tab,'(print headers every n lines)',cr,lf, +'dir [ff]',tab,tab,tab,'(print form feeds between headers)',cr,lf, +'dir [message user=all]',tab,tab,'(show user/drive areas with no files)', +cr,lf, +'dir [help]',tab,tab,tab,'(show this message)',cr,lf, +'dir [dir sys rw ro sort xfcb nonxfcb full] d:*.*',tab,'(defaults)$')); + +call terminate; +end help; */ + + +/* -------- Scanner Info -------- */ + +$include (scan.lit) + +dcl pcb pcb$structure + initial (0,.buff(0),.fcb,0,0,0,0) ; + +dcl token based pcb.token$adr (12) byte; +dcl got$options boolean; + +get$options: procedure; + dcl temp byte; + + do while pcb.scan$adr <> 0ffffh and ((pcb.tok$typ and t$op) <> 0); + + if pcb.nxt$token <> t$mod then do; + /* options with no modifiers */ + if token(1) = 'A' then + display$attributes = true; + + else if token(1) = 'D' and token(2) = 'I' then + find.dir = true; + + else if token(1) = 'D' and token(2) = 'A' then do; + format = form$full; + date$opt = true; + end; +/* + else if token(1) = 'D' and token(2) = 'E' then + debug = true; +*/ + else if token(1) = 'E' then + find.exclude = true; + + else if token(1) = 'F'then do; + if token(2) = 'F' then + formfeeds = true; + else if token(2) = 'U' then + format = form$full; + else goto op$err; + end; + + else if token(1) = 'G' then + do; + if pcb.token$len < 3 then + temp = token(2) - '0'; + else + temp = (token(2) - '0') * 10 + (token(3) - '0'); + if temp >= 0 and temp <= 15 then + call set$vec(.usr$vector,temp); + else goto op$err; + end; + + /* else if token(1) = 'H' then + call help; */ + + else if token(1) = 'M' then + message = true; + + else if token(1) = 'N' then + do; + if token(4) = 'X' then + find.nonxfcb = true; + else if token(3) = 'P' then + no$page$mode = 0FFh; + else if token(3) = 'S' then + sort$op = false; + else goto op$err; + end; + + /* else if token(1) = 'P' then + find.pass = true; */ + + else if token(1) = 'R' and token(2) = 'O' then + find.ro = true; + + else if token(1) = 'R' and token(2) = 'W' then + find.rw = true; + + else if token(1) = 'S' then do; + if token(2) = 'Y' then + find.sys = true; + else if token(2) = 'I' then + format = form$size; + else if token(2) = 'O' then + sort$op = true; + else goto op$err; + end; + + else if token(1) = 'X' then + find.xfcb = true; + + else goto op$err; + + call scan(.pcb); + end; + + else + do; /* options with modifiers */ + if token(1) = 'L' then + do; + call scan(.pcb); + if (pcb.tok$typ and t$numeric) <> 0 then + if make$numeric(.token(1),pcb.token$len,.page$len) then + if page$len < 5 then + goto op$err; + else call scan(.pcb); + else goto op$err; + else goto op$err; + end; + + else if token(1) = 'U' then + do; +/* + if debug then + call print(.(cr,lf,'In User option$')); +*/ + call scan(.pcb); + if (((pcb.tok$typ and t$mod) = 0) or (bdos < bdos20)) then + goto op$err; + do while (pcb.tok$typ and t$mod) <> 0 and + pcb.scan$adr <> 0ffffh; + if token(1) = 'A' and token(2) = 'L' then + usr$vector = 0ffffh; + else if (pcb.tok$typ and t$numeric) <> 0 and pcb.token$len < 3 then + do; + if pcb.token$len = 1 then + temp = token(1) - '0'; + else + temp = (token(1) - '0') * 10 + (token(2) - '0'); + if temp >= 0 and temp <= 15 then + call set$vec(.usr$vector,temp); + else goto op$err; + end; + else goto op$err; + call scan(.pcb); + end; + end; /* User option */ + + else if token(1) = 'D' and (token(2) = 'R' or token(2) = 'I') then + do; /* allow DRIVE or DISK */ + call scan(.pcb); + if (pcb.tok$typ and t$mod) = 0 then + goto op$err; + do while (pcb.tok$typ and t$mod ) <> 0 and + pcb.scan$adr <> 0ffffh; + if token(1) = 'A' and token(2) = 'L' then + do; + drv$vector = 0ffffh; + drv$vector = drv$vector and get$login; + end; + else if token(1) >= 'A' and token(1) <= 'P' then + call set$vec(.drv$vector,token(1) - 'A'); + else goto op$err; + call scan(.pcb); + end; + end; /* drive option */ + + else goto op$err; + + end; /* options with modifiers */ + + end; /* do while */ + + got$options = true; + return; + + op$err: + call print(.('ERROR: Illegal Option or Modifier.', + cr,lf,'$')); + call terminate; +end get$options; + +get$file$spec: procedure; + dcl i byte; + if num$search$files < max$search$files then + do; + call move(f$namelen + f$typelen,.token(1), + .search(num$search$files).name(0)); + + if search(num$search$files).name(f$name - 1) = ' ' and + search(num$search$files).name(f$type - 1) = ' ' then + search(num$search$files).anyfile = true; /* match on any file */ + else search(num$search$files).anyfile = false;/* speedier compare */ + + if token(0) = 0 then + search(num$search$files).drv = 0ffh; /* no drive letter with */ + else /* file spec */ + search(num$search$files).drv = token(0) - 1; + /* 0ffh in drv field indicates to look on all drives that will be */ + /* scanned as set by the "drive =" option, see "match:" proc in */ + /* search.plm module */ + + num$search$files = num$search$files + 1; + end; + else + do; call print(.('File Spec Limit is $')); + call p$decimal(max$search$files,100,true); + call crlf; + end; + call scan(.pcb); +end get$file$spec; + +set$defaults: procedure; + /* set defaults if not explicitly set by user */ + if not (find.dir or find.sys) then + find.dir, find.sys = true; + if not(find.ro or find.rw) then + find.rw, find.ro = true; + + if find.xfcb or find.nonxfcb then + do; if format = form$short then + format = form$full; + end; + else /* both xfcb and nonxfcb are off */ + find.nonxfcb, find.xfcb = true; + + if num$search$files = 0 then + do; + search(num$search$files).anyfile = true; + search(num$search$files).drv = 0ffh; + num$search$files = 1; + end; + + if drv$vector = 0 then + do i = 0 to num$search$files - 1; + if search(i).drv = 0ffh then search(i).drv = cur$drv; + call set$vec(.drv$vector,search(i).drv); + end; + else /* a "[drive =" option was found */ + do i = 0 to num$search$files - 1; + if search(i).drv <> 0ffh and search(i).drv <> cur$drv then + do; call print(.('ERROR: Illegal Global/Local ', + 'Drive Spec Mixing.',cr,lf,'$')); + call terminate; + end; + end; + if usr$vector = 0 then + call set$vec(.usr$vector,get$usr); + + /* set up default page size for display */ + if bdos > bdos30 then do; + if not formfeeds then do; + if page$len = 0ffffh then do; + page$len = getscbbyte(page$len$offset); + if page$len < 5 then + page$len = 24; + end; + end; + end; +end set$defaults; + +dcl (save$uvec,temp) address; +dcl i byte; +declare last$dseg$byte byte + initial (0); + +plm: + do; + os = high(get$version); + bdos = low(get$version); + + if bdos < bdos30 or os = mpm then do; + call print(.('Requires CP/M 3',cr,lf,'$')); + call terminate; /* check to make sure function call is valid */ + end; + else + call set$console$mode; + + /* note - initialized declarations set defaults */ + cur$drv = get$cur$drv; + call scan$init(.pcb); + call scan(.pcb); + no$page$mode = getscbbyte(nopage$mode$offset); + got$options = false; + do while pcb.scan$adr <> 0ffffh; + if (pcb.tok$typ and t$op) <> 0 then + if got$options = false then + call get$options; + else + do; + call print(.('ERROR: Options not grouped together.', + cr,lf,'$')); + call terminate; + end; + else if (pcb.tok$typ and t$filespec) <> 0 then + call get$file$spec; + else + do; + call print(.('ERROR: Illegal command tail.',cr,lf,'$')); + call terminate; + end; + end; + + call set$defaults; + + /* main control loop */ + + call search$init; /* set up memory pointers for subsequent storage */ + + do while (cur$drv := get$nxt(.drv$vector)) <> 0ffh; + call select$drive(cur$drv); + save$uvec = usr$vector; /* user numbers to search on each drive */ + active$usr$vector = 0; /* users active on cur$drv */ + cur$usr = get$nxt(.usr$vector); /* get first user num and mask */ + get$all$dir$entries = false; /* off it off */ + if usr$vector <> 0 and format <> form$short then + /* find high water mark if */ + do; /* more than one user requested */ + fcb(f$drvusr) = '?'; + i = search$first(.fcb); /* get first directory entry */ + temp = 0; + do while i <> 255; + temp = temp + 1; + i = search$next; + end; /* is there enough space in the */ + /* worst case ? */ + if maxb > mult23(temp) + shl(temp,1) then + get$all$dir$entries = true; /* location of last possible */ + end; /* file info record and add */ + first$pass = true; /* room for sort indices */ + active$usr$vector = 0ffffh; + do while cur$usr <> 0ffh; +/* + if debug then + call print(.(cr,lf,'in user loop $')); +*/ + call set$vec(.temp,cur$usr); + if (temp and active$usr$vector) <> 0 then + do; + if format <> form$short and + (first$pass or not get$all$dir$entries) then + do; + call get$files; /* collect files in memory and */ + first$pass = false; /* build the active usr vector */ + sorted = false; /* sort module will set sorted */ + if sort$op then /* to true, if successful sort */ + call sort; + end; + call display$files; + end; + cur$usr = get$nxt(.usr$vector); + end; + usr$vector = save$uvec; /* restore user vector for nxt */ + end; /* do while drv$usr drive scan */ + + + if not file$displayed and not message then + call print(.('No File',cr,lf,'$')); + call terminate; + + end; +end sdir; diff --git a/software/CPM/cpm3/main80.plm b/software/CPM/cpm3/main80.plm new file mode 100644 index 0000000..09abb7b --- /dev/null +++ b/software/CPM/cpm3/main80.plm @@ -0,0 +1,10 @@ +$title ('SDIR 8080 - Main Module') +sdir: /* SDIR FOR 8080 */ +do; + +$include(copyrt.lit) + +declare plm label public; + +$include(main.plm) + diff --git a/software/CPM/cpm3/makedate.lib b/software/CPM/cpm3/makedate.lib new file mode 100644 index 0000000..3fe3f25 --- /dev/null +++ b/software/CPM/cpm3/makedate.lib @@ -0,0 +1,16 @@ +; +; [JCE] Have the date and copyright messages in only one source file +; +@BDATE MACRO + db '101198' + ENDM + +@LCOPY MACRO + db 'Copyright 1998, ' + db 'Caldera, Inc. ' + ENDM + +@SCOPY MACRO + db '(c) 98 Caldera' + ENDM + diff --git a/software/CPM/cpm3/making.txt b/software/CPM/cpm3/making.txt new file mode 100644 index 0000000..60be9dd --- /dev/null +++ b/software/CPM/cpm3/making.txt @@ -0,0 +1,39 @@ +Compiling Caldera CP/M 3 +======================== + + The supplied source is (I hope) all that is necessary to build the CP/M 3 +binary distribution under Unix. + + The Makefile has been written for GNU Make. You will need: + +* The PL/M development system from the Unofficial CP/M Website + +* The zxcc emulator (version 0.3 or later) installed + +* The thames emulator (version 0.1.0 or later) installed + + + The PL/M system contains the PLM80 compiler, the ASM80 assembler, and the +ISIS emulator. Unpack these to separate directories. + + Edit the shell script run_thames to set the four directories: + +ISIS_F0 source code directory +ISIS_F1 PLM80 compiler +ISIS_F2 ASM80 assembler +ISIS_F3 ISIS emulator and libraries + + 'make all' will then set the build in motion. Since the build tools do not +return error codes, you will have to watch for error messages yourself, +and stop the build if you see one. + + When GENCOM is being run, you may see a "corrupt FCB" message. This is +caused by GENCOM closing a file it didn't open, and you may safely ignore it. + + The build date is stored in three files: + +MCD80A.ASM +MCD80F.ASM +MAKEDATE.LIB + +and you should change all of these if you are making a new release. diff --git a/software/CPM/cpm3/mcd80a.asm b/software/CPM/cpm3/mcd80a.asm new file mode 100644 index 0000000..b1bdded --- /dev/null +++ b/software/CPM/cpm3/mcd80a.asm @@ -0,0 +1,94 @@ +$title ('COM Externals') + name mcd80a + CSEG +; September 14, 1982 + +offset equ 0000h +boot equ 0000h ;[JCE] to make SHOW compile + + EXTRN PLM + +; EXTERNAL ENTRY POINTS + +mon1 equ 0005h+offset +mon2 equ 0005h+offset +mon2a equ 0005h+offset +mon3 equ 0005h+offset + public mon1,mon2,mon2a,mon3 + +; EXTERNAL BASE PAGE DATA LOCATIONS + +iobyte equ 0003h+offset +bdisk equ 0004h+offset +maxb equ 0006h+offset +memsiz equ maxb +cmdrv equ 0050h+offset +pass0 equ 0051h+offset +len0 equ 0053h+offset +pass1 equ 0054h+offset +len1 equ 0056h+offset +fcb equ 005ch+offset +fcba equ fcb +sfcb equ fcb +ifcb equ fcb +ifcba equ fcb +fcb16 equ 006ch+offset +dolla equ 006dh+offset +parma equ 006eh+offset +cr equ 007ch+offset +rr equ 007dh+offset +rreca equ rr +ro equ 007fh+offset +rreco equ ro +tbuff equ 0080h+offset +buff equ tbuff +buffa equ tbuff +cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000 + + public iobyte,bdisk,maxb,memsiz + public cmdrv,pass0,len0,pass1,len1 + public fcb,fcba,sfcb,ifcb,ifcba,fcb16 + public cr,rr,rreca,ro,rreco,dolla,parma + public buff,tbuff,buffa, cpu, boot + + + ;******************************************************* + ; The interface should proceed the program + ; so that TRINT becomes the entry point for the + ; COM file. The stack is set and memsiz is set + ; to the top of memory. Program termination is done + ; with a return to preserve R/O diskettes. + ;******************************************************* + +; EXECUTION BEGINS HERE + +; +;[JCE 17-5-1998] Guard code prevents this program being run under DOS +; + db 0EBh,7 ;Sends 8086s to I8086: + lxi sp, stack + JMP PLM + db 0 ;Packing. +; +I8086: db 0CDh,020h ;INT 20h - terminate immediately + +; PATCH AREA, DATE, VERSION & SERIAL NOS. + + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0 + db 0 + db 'CP/M Version 3.0' +; +;[JCE] Since I can't work out how to get ASM80 to use macro libraries, +; the date and copyright are here as well as in MAKEDATE.LIB +; + db 'Copyright 1998, ' + db 'Caldera, Inc. ' + db '101198' ; version date day-month-year + db 0,0,0,0 ; patch bit map + db '654321' ; Serial no. + + END + EOF diff --git a/software/CPM/cpm3/mcd80a.prn b/software/CPM/cpm3/mcd80a.prn new file mode 100644 index 0000000..b474cfd --- /dev/null +++ b/software/CPM/cpm3/mcd80a.prn @@ -0,0 +1,96 @@ + + +S $title ('COM Externals') +L name mcd80a + CSEG + ; September 14, 1982 + + 0000 = offset equ 0000h + 0000 = boot equ 0000h ;[JCE] to make SHOW compile + +L EXTRN PLM + + ; EXTERNAL ENTRY POINTS + +P010C = mon1 equ 0005h+offset + 0005 = mon2 equ 0005h+offset + 0005 = mon2a equ 0005h+offset + 0005 = mon3 equ 0005h+offset +L public mon1,mon2,mon2a,mon3 + + ; EXTERNAL BASE PAGE DATA LOCATIONS + +P010C = iobyte equ 0003h+offset + 0004 = bdisk equ 0004h+offset + 0006 = maxb equ 0006h+offset + 0006 = memsiz equ maxb +P010C = cmdrv equ 0050h+offset + 0051 = pass0 equ 0051h+offset + 0053 = len0 equ 0053h+offset + 0054 = pass1 equ 0054h+offset + 0056 = len1 equ 0056h+offset +P010C = fcb equ 005ch+offset +P010C = fcba equ fcb +P010C = sfcb equ fcb +P010C = ifcb equ fcb +P010C = ifcba equ fcb + 006C = fcb16 equ 006ch+offset + 006D = dolla equ 006dh+offset + 006E = parma equ 006eh+offset +P010C = cr equ 007ch+offset + 007D = rr equ 007dh+offset + 007D = rreca equ rr + 007F = ro equ 007fh+offset + 007F = rreco equ ro + 0080 = tbuff equ 0080h+offset +P010C = buff equ tbuff + 0080 = buffa equ tbuff + 0000 = cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000 + +L public iobyte,bdisk,maxb,memsiz +L public cmdrv,pass0,len0,pass1,len1 +L public fcb,fcba,sfcb,ifcb,ifcba,fcb16 +L public cr,rr,rreca,ro,rreco,dolla,parma +L public buff,tbuff,buffa, cpu, boot + + + ;******************************************************* + ; The interface should proceed the program + ; so that TRINT becomes the entry point for the + ; COM file. The stack is set and memsiz is set + ; to the top of memory. Program termination is done + ; with a return to preserve R/O diskettes. + ;******************************************************* + + ; EXECUTION BEGINS HERE + + ; + ;[JCE 17-5-1998] Guard code prevents this program being run under DOS + ; + 0000 EB07 db 0EBh,7 ;Sends 8086s to I8086: +U0002 310000 lxi sp, stack + 0005 C30000 JMP PLM + 0008 00 db 0 ;Packing. + ; + 0009 CD20 I8086: db 0CDh,020h ;INT 20h - terminate immediately + + ; PATCH AREA, DATE, VERSION & SERIAL NOS. + + 000B 0000000000 dw 0,0,0,0,0,0,0,0 + 001B 0000000000 dw 0,0,0,0,0,0,0,0 + 002B 0000000000 dw 0,0,0,0,0,0,0,0 + 003B 00000000 dw 0,0 + 003F 00 db 0 + 0040 43502F4D20 db 'CP/M Version 3.0' + ; + ;[JCE] Since I can't work out how to get ASM80 to use macro libraries, + ; the date and copyright are here as well as in MAKEDATE.LIB + ; + 0050 436F707972 db 'Copyright 1998, ' + 0060 43616C6465 db 'Caldera, Inc. ' + 0070 3130313139 db '101198' ; version date day-month-year + 0076 00000000 db 0,0,0,0 ; patch bit map + 007A 3635343332 db '654321' ; Serial no. + + 0080 END + \ No newline at end of file diff --git a/software/CPM/cpm3/mcd80f.asm b/software/CPM/cpm3/mcd80f.asm new file mode 100644 index 0000000..5007270 --- /dev/null +++ b/software/CPM/cpm3/mcd80f.asm @@ -0,0 +1,97 @@ +$title ('COM Externals') + name mcd80b + CSEG +; August 2, 1982 + +offset equ 0000h + + + EXTRN PLM + +; EXTERNAL ENTRY POINTS + +mon1 equ 0005h+offset +mon2 equ 0005h+offset +mon2a equ 0005h+offset +mon3 equ 0005h+offset + public mon1,mon2,mon2a,mon3 + +; EXTERNAL BASE PAGE DATA LOCATIONS + +iobyte equ 0003h+offset +bdisk equ 0004h+offset +maxb equ 0006h+offset +memsiz equ maxb +cmdrv equ 0050h+offset +pass0 equ 0051h+offset +len0 equ 0053h+offset +pass1 equ 0054h+offset +len1 equ 0056h+offset +fcb equ 005ch+offset +fcba equ fcb +sfcb equ fcb +ifcb equ fcb +ifcba equ fcb +fcb16 equ 006ch+offset +dolla equ 006dh+offset +parma equ 006eh+offset +cr equ 007ch+offset +rr equ 007dh+offset +rreca equ rr +ro equ 007fh+offset +rreco equ ro +tbuff equ 0080h+offset +buff equ tbuff +buffa equ tbuff +cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000 + + public iobyte,bdisk,maxb,memsiz + public cmdrv,pass0,len0,pass1,len1 + public fcb,fcba,sfcb,ifcb,ifcba,fcb16 + public cr,rr,rreca,ro,rreco,dolla,parma + public buff,tbuff,buffa,cpu,reset + + + ;******************************************************* + ; The interface should proceed the program + ; so that TRINT becomes the entry point for the + ; COM file. The stack is set and memsiz is set + ; to the top of memory. + ;******************************************************* + +bdos equ mon1 +getalv equ 27 +getdpb equ 31 + +; EXECUTION BEGINS HERE + +reset: +trint: + +;[JCE 17-5-1998] Protect against being run under DOS + + db 0EBh,0Bh ;Sends 8086s to I8086: below + + lxi sp, stack + call plm ; call program + mvi c,0 + call bdos + +I8086: db 0CDh,020h ;8086 processors come here - INT 20h + + ; PATCH AREA, DATE, VERSION & SERIAL NOS. + + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + db 0 + + db 'CP/M Version 3.0' + db 'Copyright 1998, ' + db 'Caldera, Inc. ' + db '101198' ; version date day-month-year + db 0,0,0,0 ; patch bit map + db '654321' ; Serial no. + + END + EOF diff --git a/software/CPM/cpm3/minhlp.com b/software/CPM/cpm3/minhlp.com new file mode 100644 index 0000000..642e730 Binary files /dev/null and b/software/CPM/cpm3/minhlp.com differ diff --git a/software/CPM/cpm3/minhlp.plm b/software/CPM/cpm3/minhlp.plm new file mode 100644 index 0000000..5cc0ff5 --- /dev/null +++ b/software/CPM/cpm3/minhlp.plm @@ -0,0 +1,779 @@ +$title ('Help Utility Version 1.1') +help: +do; + +/* [JCE] Cut-down version of help that only does [C]reate */ + +/* + Copyright (C) 1982 + Digital Research + P.O. 579 + Pacific Grove, CA 93950 + + Revised: + 06 Dec 82 by Bruce Skidmore +*/ + + declare plm label public; + +/********************************************** + Interface Procedures +**********************************************/ + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + +/********************************************** + Global Variables +**********************************************/ + + declare (list$mode,nopage$mode,create$mode,extract$mode,page$mode) byte; + declare (offset,eod) byte; + + declare cmdrv (1) byte external; /* [JCE] Help patch 2 */ + declare fcb (13) byte external; + declare fcb2 (36) byte; + + declare maxb address external; + declare fcb16 (1) byte external; + declare tbuff (128) byte external; + + declare control$z literally '1AH'; + declare cr literally '0DH'; + declare lf literally '0AH'; + declare tab literally '09H'; + declare slash literally '''/'''; + declare true literally '0FFH'; + declare false literally '00H'; + + declare (cnt,index) byte; + declare sub(12) byte; + declare com(11) structure( + name(15) byte); + + declare sysbuff(8) structure( + subject(12) byte, + record address, + rec$offset byte, + level byte) at (.memory); + + declare name(12) byte; + declare level byte; + declare gindex address; + declare tcnt byte; + declare version address; + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + read$console: + procedure byte; + return mon2 (1,0); + end read$console; + + write$console: + procedure (char); + declare char byte; + call mon1 (2,char); + end write$console; + + print$console$buf: + procedure (buff$adr); + declare buff$adr address; + call mon1 (9,buff$adr); + end print$console$buf; + + read$console$buff: + procedure (buff$adr); + declare buff$adr address; + call mon1(10,buff$adr); + end read$console$buff; + + direct$con$io: + procedure(func) byte; + declare func byte; + return mon2(6,func); + end direct$con$io; + + get$version: + procedure address; + return mon3(12,0); + end get$version; + + delete$file: + procedure (fcb$address); + declare fcb$address address; + call mon1(19,fcb$address); + end delete$file; + + open$file: + procedure (fcb$address) byte; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + fcb(12) = 0; /* EX = 0 */ + fcb(32) = 0; /* CR = 0 */ + return mon2 (15,fcb$address); + end open$file; + + close$file: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (16,fcb$address); + end close$file; + + read$record: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (20,fcb$address); + end read$record; + + write$record: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2(21,fcb$address); + end write$record; + + make$file: + procedure (fcb$address) byte; + declare fcb$address address; + declare fcb based fcb$address (1) byte; + fcb(12) = 0; /* EX = 0 */ + fcb(32) = 0; /* CR = 0 */ + return mon2(22,fcb$address); + end make$file; + + read$rand: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2(33,fcb$address); + end read$rand; + + set$dma: + procedure (dma$address); + declare dma$address address; + call mon1(26,dma$address); + end set$dma; + + set$rand$rec: + procedure (fcb$address); + declare fcb$address address; + call mon1(36,fcb$address); + end set$rand$rec; + + terminate: + procedure; + call mon1 (0,0); + end terminate; + +/********************************************* + Error Procedure + + Displays error messages and + terminates if required. +*********************************************/ +error: + procedure(term$code,err$msg$adr); + declare term$code byte; + declare err$msg$adr address; + + call print$console$buf(.(cr,lf,'ERROR: $')); + call print$console$buf(err$msg$adr); + call print$console$buf(.(cr,lf,'$')); + if term$code then + call terminate; + end error; + +/********************************************* + Move Procedure + + Moves specified number of bytes + from the Source address to the + Destination address. +*********************************************/ +movef: + procedure (mvcnt,source$addr,dest$addr); + declare (source$addr,dest$addr) address; + declare mvcnt byte; + call move(mvcnt,source$addr,dest$addr); + return; + end movef; + +/********************************************* + Compare Function + + Compares 12 byte strings + + Results: 0 - string1 = string2 + 1 - string1 < string2 + 2 - string1 > string2 +*********************************************/ +compare: + procedure(str1$addr,str2$addr) byte; + declare (str1$addr,str2$addr) address; + declare string1 based str1$addr (12) byte; + declare string2 based str2$addr (12) byte; + declare (result,i) byte; + result, + i = 0; + do while ((i < 12) and (string1(i) <> ' ')); + if string1(i) <> string2(i) then + do; + if string1(i) < string2(i) then + do; + result = 1; + end; + else + do; + result = 2; + end; + i = 11; + end; + i = i + 1; + end; + return result; + end compare; + +/********************************************* + Increment Procedure + + Increments through a record. +*********************************************/ +inc: + procedure (inci) byte; + declare inci byte; + inci = inci + 1; + if inci > 127 then + do; + if read$record(.fcb) = 0 then + do; + inci = 0; + end; + else + do; + eod = true; + inci = 0; + end; + end; + return inci; + end inc; + +/******************************************* + Init Procedure + + Reads the index into memory +*******************************************/ +init: + procedure; + declare (buf$size,max$buf,init$i) address; + declare end$index byte; + buf$size = maxb - .memory; + max$buf = buf$size; + end$index = 0; + init$i = 7; + do while (not end$index) and (max$buf > 127); + call set$dma(.sysbuff(init$i-7).subject); + if read$record(.fcb) <> 0 then + do; + init$i = close$file(.fcb); + call error(true,.('Reading HELP.HLP index.$')); + end; + if sysbuff(init$i).subject(0) = '$' then end$index = true; + if not end$index then + do; + max$buf = max$buf - 128; + init$i = init$i + 8; + end; + end; + call set$dma(.tbuff); + if (max$buf < 128) and (not end$index) then + do; + init$i = close$file(.fcb); + call error(true,.('Too many entries in Index Table.', + ' Not enough memory.$')); + end; + end init; + + +/******************************************* + Parse Procedure + + Parses the command tail +*******************************************/ +parse: + procedure byte; + declare (index,begin,cnt,i,stop,bracket) byte; + index = 0; + if tbuff(0) <> 0 then + do; + do index = 1 to tbuff(0); + if tbuff(index) = tab then tbuff(index) = ' '; + else if tbuff(index) = ',' then tbuff(index) = ' '; + end; + index = 1; + do while(index < tbuff(0)) and (tbuff(index) = ' '); + index = index + 1; + end; + if tbuff(index) = '.' then + do; + begin = level; + tbuff(index) = ' '; + end; + else + begin = 0; + do index = begin to 10; + call movef(15,.(' ',cr,'$'),.com(index).name); + end; + index = begin; + cnt = 1; + stop, + bracket = 0; + do while (tbuff(cnt) <> 0) and (not stop); + if (tbuff(cnt) <> 20H) then + do; + i = 0; + do while (((tbuff(cnt) <> 20H) and (tbuff(cnt) <> '[')) and + (tbuff(cnt) <> 0)) and ((i < 12) and (index < 11)); + if (tbuff(cnt) > 60H) and (tbuff(cnt) < 7BH) then + do; + com(index).name(i) = tbuff(cnt) - 20H; + end; + else + do; + com(index).name(i) = tbuff(cnt); + end; + cnt = cnt + 1; + i = i + 1; + end; + index = index + 1; + if (bracket or (index > 10)) then + do; + stop = true; + end; + else + if tbuff(cnt) = '[' then + do; + if com(index-1).name(0) = ' ' then index = index - 1; + com(index).name(0) = '['; + cnt = cnt + 1; + index = index + 1; + bracket = true; + end; + end; + else + do; + cnt = cnt + 1; + end; + end; + end; + list$mode, + nopage$mode, + create$mode, + extract$mode = false; + if index > 0 then + do; + i = 0; + do while (i < 10); + if com(i).name(0) = '[' then + do; + if (com(i+1).name(0) = 'C') then + do; + create$mode = true; + index = index - 2; + end; + else if (com(i+1).name(0) = 'E') then + do; + extract$mode = true; + index = index - 2; + end; + else if (com(i+1).name(0) = 'N') then + do; + nopage$mode =true; + index = index - 2; + end; + else if (com(i+1).name(0) = 'L') then + do; + list$mode = true; + nopage$mode = true; + index = index - 2; + end; + else if (com(i+1).name(0) <> ' ') then + do; + index = index - 2; + end; + else + do; + index = index - 1; + end; + i = 10; + end; + i = i + 1; + end; + end; + return index; + end parse; + +/****************************************** + Create$index Procedure + + Creates HELP.HLP from HELP.DAT +******************************************/ +create$index: + procedure; + declare (cnt, i, rec$cnt) byte; + declare (index,count,count2,max$buf,save$size) address; + declare fcb3(36) byte; + call print$console$buf(.(cr,lf,'Creating HELP.HLP....$')); + do i = 0 to 7; + call movef(12,.('$ '),.sysbuff(i).subject); + end; + rec$cnt, + index = 0; + save$size = maxb - .memory; + max$buf = save$size; + call movef(13,.(0,'HELP DAT',0),.fcb); + if open$file(.fcb) = 0FFH then + do; + call error(true,.('HELP.DAT not on current drive.$')); + end; + eod = 0; + do while (not eod) and (read$record(.fcb) = 0); + i = 0; + do while(i < 128) and (not eod); + if tbuff(i) = control$z then + do; + eod = true; + end; + else + do; + if tbuff(i) = slash then + do; + cnt = 0; + do while(not eod) and (tbuff(i) = slash); + i = inc(i); + cnt = cnt + 1; + end; + if (cnt = 3) and (not eod) then + do; + sysbuff(index).level = tbuff(i) - '0'; + i = inc(i); + cnt = 0; + do while ((cnt < 12) and (not eod)) and (tbuff(i) <> cr); + if (tbuff(i) > 60H) and (tbuff(i) < 7BH) then + do; + sysbuff(index).subject(cnt) = tbuff(i) - 20H; + end; + else + do; + sysbuff(index).subject(cnt) = tbuff(i); + end; + i = inc(i); + cnt = cnt + 1; + end; + if (not eod) then + do; + call set$rand$rec(.fcb); + call movef(1,.fcb(33),.sysbuff(index).record); + call movef(1,.fcb(34),.sysbuff(index).record+1); + sysbuff(index).record = sysbuff(index).record - 0001H; + sysbuff(index).rec$offset = i; + index = index + 1; + if ((index mod 8) = 0) then + do; + rec$cnt = rec$cnt + 1; + max$buf = max$buf - 128; + if (max$buf < 128) and (not eod) then + do; + cnt = close$file(.fcb); + call error(true, + .('Too many entries in Index Table.', + ' Not enough memory.$')); + end; + else + do count = index to index + 7; + call movef(12,.('$ '), + .sysbuff(count).subject); + end; + end; + end; + end; + end; + else + do; + i = inc(i); + end; + end; + end; + end; + call set$dma(.sysbuff); + rec$cnt = rec$cnt + 1; + /******************************** + create HELP.HLP + ********************************/ + call movef(13,.(0,'HELP HLP',0),.fcb3); + call delete$file(.fcb3); + if make$file(.fcb3) = 0FFH then + do; + cnt = close$file(.fcb2); + call delete$file(.fcb2); + cnt = close$file(.fcb); + call error(true,.('Unable to Make HELP.HLP.$')); + end; + call movef(4,.(0,0,0,0),.fcb2+32); + cnt = read$rand(.fcb2); + do count = 0 to index - 1; + sysbuff(count).record = sysbuff(count).record + rec$cnt; + end; + do count = 0 to rec$cnt - 1; + call set$dma(.memory(shl(count,7))); + if write$record(.fcb3) = 0FFH then + do; + cnt = close$file(.fcb3); + call delete$file(.fcb3); + cnt = close$file(.fcb2); + call delete$file(.fcb2); + cnt = close$file(.fcb); + call error(true,.('Writing file HELP.HLP.$')); + end; + end; + call movef(4,.(0,0,0,0),.fcb+32); + cnt = read$rand(.fcb); + eod = 0; + do while (not eod); + count = 0; + max$buf = save$size; + do while (not eod) and (max$buf > 127); + call set$dma(.memory(shl(count,7))); + if read$record(.fcb) <> 0 then + do; + eod = true; + end; + else + do; + max$buf = max$buf - 128; + count = count + 1; + end; + end; + do count2 = 0 to count-1; + call set$dma(.memory(shl(count2,7))); + if write$record(.fcb3) = 0FFH then + do; + i = close$file(.fcb3); + call delete$file(.fcb3); + i = close$file(.fcb); + call error(true,.('Writing file HELP.HLP.$')); + end; + end; + end; + if close$file(.fcb) = 0FFH then + do; + cnt = close$file(.fcb3); + call error(true,.('Closing file HELP.DAT.$')); + end; + if close$file(.fcb3) = 0FFH then + do; + call error(true,.(false,'Closing file HELP.HLP.$')); + end; + call print$console$buf(.('HELP.HLP created',cr,lf,'$')); + end create$index; + +/******************************************** + Extract$file Procedure + + Creates HELP.DAT from HELP.HLP +********************************************/ +extract$file: + procedure; + declare (end$index,i) byte; + declare (count,count2,max$buf,save$size) address; + + call print$console$buf(.(cr,lf,'Extracting data....$')); + call movef(13,.(0,'HELP HLP',0),.fcb); + if open$file(.fcb) = 0FFH then + do; + call error(true,.('Unable to find file HELP.HLP.$')); + end; + call movef(13,.(0,'HELP DAT',0),.fcb2); + call delete$file(.fcb2); + if make$file(.fcb2) = 0FFH then + do; + i = close$file(.fcb); + call error(true,.('Unable to Make HELP.DAT.$')); + end; + call set$dma(.sysbuff); + end$index = 0; + do while ((i := read$record(.fcb)) = 0) and (not end$index); + if sysbuff(7).subject(0) = '$' then end$index = true; + end; + eod = 0; + if i <> 0 then eod = true; + i = write$record(.fcb2); + save$size = maxb - .memory; + do while (not eod); + count = 0; + max$buf = save$size; + do while (not eod) and (max$buf > 127); + call set$dma(.memory(shl(count,7))); + if read$record(.fcb) <> 0 then + do; + eod = true; + end; + else + do; + max$buf = max$buf - 128; + count = count + 1; + end; + end; + do count2 = 0 to count-1; + call set$dma(.memory(shl(count2,7))); + if write$record(.fcb2) = 0FFH then + do; + i = close$file(.fcb2); + call delete$file(.fcb2); + i = close$file(.fcb); + call error(true,.('Writing file HELP.DAT.$')); + end; + end; + end; + if close$file(.fcb) = 0FFH then + do; + call error(false,.('Unable to Close HELP.HLP.$')); + end; + if close$file(.fcb2) = 0FFH then + do; + call delete$file(.fcb2); + call error(true,.('Unable to Close HELP.DAT.$')); + end; + call print$console$buf(.('Extraction complete',cr,lf,lf, + 'HELP.DAT created',cr,lf,'$')); + + end extract$file; + +/********************************************* + Search$file Procedure + + Searches the index table for the key +*********************************************/ +search$file: + procedure byte; + declare (eod, error, cnt, found, saved, save$level) byte; + declare index address; + eod, + error, + found, + saved, + index = 0; + do while(not eod) and (not error); + if sysbuff(index).subject(0) <> '$' then + do; + if sysbuff(index).level = level + 1 then + do; + cnt = compare(.com(level).name,.sysbuff(index).subject); + if cnt = 0 then + do; + call movef(12,.sysbuff(index).subject,.com(level).name); + level = level + 1; + if (not saved) then + do; + save$level = level; + saved = true; + end; + if ((level > 8) or (com(level).name(0) = ' ')) + or (com(level).name(0) = '[') then + do; + found = true; + eod = true; + end; + else + do; + index = index + 1; + found = 0; + end; + end; + else + do; + index = index + 1; + end; + end; + else + do; + if saved then + do; + if save$level < sysbuff(index).level then + do; + index = index + 1; + end; + else + do; + error = true; + end; + end; + else + do; + index = index + 1; + end; + end; + end; + else + do; + error = true; + end; + end; + if found then + do; + gindex = index + 1; + call movef(1,.sysbuff(index).record,.fcb(33)); + call movef(1,.sysbuff(index).record+1,.fcb(34)); + fcb(35) = 0; + offset = sysbuff(index).rec$offset; + level = sysbuff(index).level; + end; + return error; + end search$file; + +/************************************** + Main Program +**************************************/ + +declare last$dseg$byte byte + initial (0); + + +plm: + do; + eod, + tcnt = 0; + version = get$version; + if (high(version) = 1) or (low(version) < 30h) then + do; + call error(true,.('Requires CP/M Version 3$')); + end; + cnt = parse; + if create$mode then + do; + call create$index; + end; + else + if extract$mode then + do; + call extract$file; + end; + end; + call terminate; +end help; diff --git a/software/CPM/cpm3/mon.plm b/software/CPM/cpm3/mon.plm new file mode 100644 index 0000000..4c988ef --- /dev/null +++ b/software/CPM/cpm3/mon.plm @@ -0,0 +1,19 @@ + + /* definitions for assembly interface module */ +declare + fcb (33) byte external, /* default file control block */ + maxb address external, /* top of memory */ + buff(128)byte external; /* default buffer */ + +mon1: procedure(f,a) external; + declare f byte, a address; + end mon1; + +mon2: procedure(f,a) byte external; + declare f byte, a address; + end mon2; + +mon3: procedure(f,a) address external; + declare f byte, a address; + end mon3; + diff --git a/software/CPM/cpm3/move.asm b/software/CPM/cpm3/move.asm new file mode 100644 index 0000000..72727dc --- /dev/null +++ b/software/CPM/cpm3/move.asm @@ -0,0 +1,33 @@ + title 'bank & move module for CP/M3 linked BIOS' + + cseg + + public ?move,?xmove,?bank + extrn @cbnk + + maclib z80 + maclib ports + +?xmove: ; ALTOS can't perform interbank moves + ret + +?move: + xchg ; we are passed source in DE and dest in HL + ldir ; use Z80 block move instruction + xchg ; need next addresses in same regs + ret + + ; by exiting through bank select +?bank: + push b ; save register b for temp + ral ! ral ! ral ! ani 18h ; isolate bank in proper bit position + mov b,a ; save in reg B + in p$bankselect ; get old memory control byte + ani 0E7h ! ora b ; mask out old and merge in new + out p$bankselect ; put new memory control byte + pop b ; restore register b + ret + + ; 128 bytes at a time + + end diff --git a/software/CPM/cpm3/newpip.plm b/software/CPM/cpm3/newpip.plm new file mode 100644 index 0000000..d0b91cc --- /dev/null +++ b/software/CPM/cpm3/newpip.plm @@ -0,0 +1,1928 @@ +$title('PERIPHERAL INTERCHANGE PROGRAM') +PIPMOD: + DO; +/* P E R I P H E R A L I N T E R C H A N G E P R O G R A M + + COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982 + DIGITAL RESEARCH + BOX 579 + PACIFIC GROVE, CA + 93950 + + Revised: + 17 Jan 80 by Thomas Rolander (MP/M 1.1) + 05 Oct 81 by Ray Pedrizetti (MP/M-86 2.0) + 18 Dec 81 by Ray Pedrizetti (CP/M-86 1.1) + 29 Jun 82 by Ray Pedrizetti (CCP/M-86 3.0) + 17 May 1998 by John Elliott (better error messages) */ + +/* Command lines used for CMD file generation */ + +/* (on VAX) + asm86 scd1.a86 + asm86 inpout.a86 + plm86 pip.plm debug xref optimize(3) + link86 scd1.obj,inpout.obj,pip.obj, to pip.lnk + loc86 pip.lnk od(sm(code,dats,data,const,stack)) - + ad(sm(code(0), dats(10000h))) ss(stack(+32)) to pip. + h86 pip + + (on a micro) + vax pip.h86 $fans + gencmd pip data[b1000 m280 xfff] + + * note the beginning of the data segment will change when + * the program is changed. see the 'MP2' file generated + * by LOC86. the constants are last to force hex generation + */ + + /* Compiler Directives */ +/** $set (mpm) **/ +/** $reset (cpm3) **/ +/** $cond **/ + +declare /* resets stack for error handling */ + reset label external; + +DECLARE + MAXB ADDRESS EXTERNAL, /* ADDR FIELD OF JMP BDOS */ + FCB (33) BYTE EXTERNAL, /* DEFAULT FILE CONTROL BLOCK */ + BUFF(128)BYTE EXTERNAL; /* DEFAULT BUFFER */ + +declare + retry byte initial(0); /* true if error has occured */ + +OUTD: PROCEDURE(B) external; + DECLARE B BYTE; + /* SEND B TO OUT: DEVICE */ + END OUTD; + +INPD: PROCEDURE BYTE external; + END INPD; + +MON1: PROCEDURE(F,A) EXTERNAL; + DECLARE F BYTE, + A ADDRESS; + END MON1; + +MON2: PROCEDURE(F,A) BYTE EXTERNAL; + DECLARE F BYTE, + A ADDRESS; + END MON2; + +MON3: PROCEDURE(F,A) ADDRESS EXTERNAL; + DECLARE F BYTE, + A ADDRESS; + END MON3; + + +plm: procedure public; + +DECLARE +/** $if mpm **/ + VERSION LITERALLY '0031H', /* REQUIRED FOR BDOS 3.1 OPERATION */ +/** $else **/ +/** $endif **/ + + ENDFILE LITERALLY '1AH'; /* END OF FILE MARK */ + +DECLARE COPYRIGHT(*) BYTE DATA ( +/** $if cpm3 **/ + ' (12/06/82) CP/M 3 PIP VERS 3.0 '); +/** $else **/ +/** $endif **/ + + + /* LITERAL DECLARATIONS */ +DECLARE + LIT LITERALLY 'LITERALLY', + LPP LIT '60', /* LINES PER PAGE */ + TAB LIT '09H', /* HORIZONTAL TAB */ + FF LIT '0CH', /* FORM FEED */ + LA LIT '05FH', /* LEFT ARROW */ + LB LIT '05BH', /* LEFT BRACKET */ + RB LIT '05DH', /* RIGHT BRACKET */ + + FSIZE LIT '33', + FRSIZE LIT '36', /* SIZE OF RANDOM FCB */ + NSIZE LIT '8', + FNSIZE LIT '11', + FEXT LIT '9', + FEXTL LIT '3', + + /* scanner return type code */ + outt LIT '0', /* output device */ + PRNT LIT '1', /* PRINTER */ + LSTT LIT '2', /* list device */ + axot lit '3', /* auxilary output device */ + FILE LIT '4', /* file type */ + auxt lit '5', /* auxilary input/output device */ + CONS LIT '6', /* CONSOLE */ + axit LIT '7', /* auxilary input device */ + inpt lit '8', /* input device */ + NULT LIT '9', /* nul characters */ + EOFT LIT '10', /* EOF character */ + ERR LIT '11', /* error type */ + SPECL LIT '12', /* special character */ + DISKNAME LIT '13'; /* diskname letter */ + +DECLARE + SEARFCB LIT 'FCB'; /* SEARCH FCB IN MULTI COPY */ + +DECLARE + TRUE LIT '1', + FALSE LIT '0', + FOREVER LIT 'WHILE TRUE', + cntrlc lit '3', + CR LIT '13', + LF LIT '10', + WHAT LIT '63'; + +/** $if mpm **/ +declare + maxmcnt lit '128', /* maximum multi sector count */ + maxmbuf lit '16384'; /* maximum multi sector buffer size */ +/** $endif **/ + +DECLARE + COLUMN BYTE, /* COLUMN COUNT FOR PRINTER TABS */ + LINENO BYTE, /* LINE WITHIN PAGE */ + FEEDBASE BYTE, /* USED TO FEED SEARCH CHARACTERS */ + FEEDLEN BYTE, /* LENGTH OF FEED STRING */ + MATCHLEN BYTE, /* USED IN MATCHING STRINGS */ + QUITLEN BYTE, /* USED TO TERMINATE QUIT COMMAND */ + CDISK BYTE, /* CURRENT DISK */ + SBLEN ADDRESS, /* SOURCE BUFFER LENGTH */ + DBLEN ADDRESS, /* DEST BUFFER LENGTH */ + tblen address, /* temp buffer length */ + SBASE ADDRESS, /* SOURCE BUFFER BASE */ + + /* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION + 1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */ + DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */ + SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */ + + /* source fcb, password and password mode */ + source structure ( + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ), + + /* temporary destination fcb, password and password mode */ + dest structure ( + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ), + + /* original destination fcb, password and password mode */ + odest structure ( + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ), + + filsize(3) byte, /* file size random record number */ + + DESTR ADDRESS AT(.DEST.FCB(33)), /* RANDOM RECORD POSITION */ + SOURCER ADDRESS AT(.SOURCE.FCB(33)), /* RANDOM RECORD POSITION */ + DESTR2 BYTE AT(.DEST.FCB(35)), /* RANDOM RECORD POSITION R2 */ + SOURCER2 BYTE AT(.SOURCE.FCB(35)), /* RANDOM RECORD POSITION R2 */ + + extsave byte, /* temp extent byte for bdos bug */ + + nsbuf address, /* next source buffer */ +/** $if mpm **/ + bufsize address, /* multsect buffer size */ + mseccnt byte, /* last multi sector count value */ +/** $endif **/ + NSOURCE ADDRESS, /* NEXT SOURCE CHARACTER */ + NDEST ADDRESS; /* NEXT DESTINATION CHARACTER */ + +DECLARE + fastcopy byte, /* true if copy directly to dbuf */ + dblbuf byte, /* true if both source and dest buffer used */ + concat byte, /* true if concatination command */ + ambig byte, /* true if file is ambig type */ + dfile byte, /* true if dest is file type */ + sfile byte, /* true if source is file type */ + made byte, /* true if destination file already made */ + opened byte, /* true if source file open */ + endofsrc byte, /* true if end of source file */ + nendcmd byte, /* true if not end of command tail */ + insparc byte, /* true if in middle of sparce file */ + sparfil byte, /* true if sparce file being copied */ + MULTCOM BYTE, /* true if processing multiple commands */ + PUTNUM BYTE, /* SET WHEN READY FOR NEXT LINE NUM */ + CONCNT BYTE, /* COUNTER FOR CONSOLE READY CHECK */ + CHAR BYTE, /* LAST CHARACTER SCANNED */ + FLEN BYTE; /* FILE NAME LENGTH */ + +declare + f1 byte, /* f1 user attribute flag */ + f2 byte, /* f2 user attribute flag */ + f3 byte, /* f3 user attribute flag */ + f4 byte, /* f4 user attribute flag */ + ro byte, /* read only attribute flag */ + sys byte, /* system attribute flag */ +/** $if mpm **/ + exten byte, /* extention error code */ + odcnt byte, /* saves dcnt for open dest file */ + eretry byte, /* error return flag */ +/** $endif **/ + dcnt byte; /* error code or directory code */ + + +DECLARE CBUFF(130) BYTE, /* COMMAND BUFFER */ + MAXLEN BYTE AT (.CBUFF(0)), /* MAX BUFFER LENGTH */ + COMLEN BYTE AT (.CBUFF(1)), /* CURRENT LENGTH */ + COMBUFF(128) BYTE AT (.CBUFF(2)), /* COMMAND BUFFER CONTENTS */ + CBP BYTE; /* COMMAND BUFFER POINTER */ + +DECLARE + CUSER BYTE, /* CURRENT USER NUMBER */ + last$user byte; + +DECLARE /* CONTROL TOGGLE VECTOR */ + CONT(26) BYTE, /* ONE FOR EACH ALPHABETIC */ + /* 00 01 02 03 04 05 06 07 08 09 10 11 12 13 + A B C D E F G H I J K L M N + 14 15 16 17 18 19 20 21 22 23 24 25 + O P Q R S T U V W X Y Z */ + archiv byte at(.cont(0)), /* file archive */ + confrm byte at(.cont(2)), /* confirm copy */ + DELET BYTE AT(.CONT(3)), /* DELETE CHARACTERS */ + ECHO BYTE AT(.CONT(4)), /* ECHO CONSOLE CHARACTERS */ + FORMF BYTE AT(.CONT(5)), /* FORM FILTER */ + GETU BYTE AT(.CONT(6)), /* GET FILE, USER # */ + HEXT BYTE AT(.CONT(7)), /* HEX FILE TRANSFER */ + IGNOR BYTE AT(.CONT(8)), /* IGNORE :00 RECORD ON FILE */ + kilds byte at(.cont(10)), /* kill filename display */ + LOWER BYTE AT(.CONT(11)), /* TRANSLATE TO LOWER CASE */ + NUMB BYTE AT(.CONT(13)), /* NUMBER OUTPUT LINES */ + OBJ BYTE AT(.CONT(14)), /* OBJECT FILE TRANSFER */ + PAGCNT BYTE AT(.CONT(15)), /* PAGE LENGTH */ + QUITS BYTE AT(.CONT(16)), /* QUIT COPY */ + RSYS BYTE AT(.CONT(17)), /* READ SYSTEM FILES */ + STARTS BYTE AT(.CONT(18)), /* START COPY */ + TABS BYTE AT(.CONT(19)), /* TAB SET */ + UPPER BYTE AT(.CONT(20)), /* UPPER CASE TRANSLATE */ + VERIF BYTE AT(.CONT(21)), /* VERIFY EQUAL FILES ONLY */ + WRROF BYTE AT(.CONT(22)), /* WRITE TO R/O FILE */ + ZEROP BYTE AT(.CONT(25)); /* ZERO PARITY ON INPUT */ + +DECLARE ZEROSUP BYTE, /* ZERO SUPPRESSION */ + (C3,C2,C1) BYTE; /* LINE COUNT ON PRINTER */ + + +/** $if mpm **/ +retcodes: procedure(a); + declare a address; + dcnt = low(a); + exten = high(a); + end retcodes; +/** $endif **/ + +BOOT: PROCEDURE; + /* SYSTEM REBOOT */ + CALL MON1(0,0); + END BOOT; + + +RDCHAR: PROCEDURE BYTE; + /* READ CONSOLE CHARACTER */ + RETURN MON2(1,0); + END RDCHAR; + +PRINTCHAR: PROCEDURE(CHAR); + DECLARE CHAR BYTE; + CALL MON1(2,CHAR AND 7FH); + END PRINTCHAR; + +CRLF: PROCEDURE; + CALL PRINTCHAR(CR); + CALL PRINTCHAR(LF); + END CRLF; + +printx: procedure(a); + declare a address; + call mon1(9,a); + end printx; + +PRINT: PROCEDURE(A); + DECLARE A ADDRESS; + /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE + NEXT DOLLAR SIGN IS ENCOUNTERED */ + CALL CRLF; + CALL printx(A); + END PRINT; + +RDCOM: PROCEDURE; + /* READ INTO COMMAND BUFFER */ + MAXLEN = 128; + CALL MON1(10,.MAXLEN); + END RDCOM; + +CVERSION: PROCEDURE ADDRESS; + RETURN MON3(12,0); /* VERSION NUMBER */ + END CVERSION; + +SETDMA: PROCEDURE(A); + DECLARE A ADDRESS; + CALL MON1(26,A); + END SETDMA; + +/** $if mpm **/ +setpw: procedure(fcba); + declare fcba address; + declare fcbs based fcba structure ( + fcb(frsize) byte, + pwnam(nsize) byte ); + call setdma(.fcbs.pwnam(0)); + end setpw; +/** $endif **/ + +OPEN: PROCEDURE(fcba); + DECLARE fcba ADDRESS; + declare fcb based fcba (frsize) byte; +/** $if mpm **/ + CALL SETPW(fcba); + call retcodes(mon3(15,fcba)); +/** $else **/ +/** $endif **/ + if dcnt <> 255 and rol(fcb(8),1) then + do; call mon1(16,fcba); + dcnt = 255; +/** $if mpm **/ + exten = 0; +/** $endif **/ + end; + END OPEN; + +CLOSE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(16,FCB)); +/** $else **/ +/** $endif **/ + END CLOSE; + +SEARCH: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(17,FCB)); +/** $else **/ +/** $endif **/ + END SEARCH; + +SEARCHN: PROCEDURE; +/** $if mpm **/ + call retcodes(MON3(18,0)); +/** $else **/ +/** $endif **/ + END SEARCHN; + +DELETE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + CALL SETPW(FCB); + call retcodes(MON3(19,FCB)); +/** $else **/ +/** $endif **/ + END DELETE; + +DISKRD: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(20,FCB)); +/** $else **/ +/** $endif **/ + END DISKRD; + +DISKWRITE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(21,FCB)); +/** $else **/ +/** $endif **/ + END DISKWRITE; + +MAKE: procedure(fcba); + declare fcba address; +/** $if mpm **/ + declare fcbs based fcba structure ( + fcb(frsize) byte, + pwnam(nsize) byte ); + if fcbs.pwnam(0) = 0 then /* zero if no password */ + fcbs.fcb(6) = fcbs.fcb(6) and 7fh; /* reset password attribute */ + else do; + fcbs.fcb(6) = fcbs.fcb(6) or 80h; /* set password attribute */ + call setdma(.fcbs.pwnam(0)); /* set password dma */ + end; + call retcodes(mon3(22,fcba)); +/** $else **/ +/** $endif **/ + END MAKE; + +RENAME: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + CALL SETPW(FCB); + call retcodes(MON3(23,FCB)) ; +/** $else **/ +/** $endif **/ + END RENAME; + +getdisk: procedure byte; + return mon2(25,0); + end getdisk; + +SETIND: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(30,FCB)); +/** $else **/ +/** $endif **/ + END SETIND; + +GETUSER: PROCEDURE BYTE; + RETURN MON2(32,0FFH); + END GETUSER; + +SETUSER: PROCEDURE(USER); + DECLARE USER BYTE; + if last$user <> user then + CALL MON1(32,(last$user:=USER)); + END SETUSER; + +SETCUSER: PROCEDURE; + CALL SETUSER(CUSER); + END SETCUSER; + +setduser: procedure; + call setuser(odest.user); + end setduser; + +SETSUSER: PROCEDURE; + CALL SETUSER(source.user); + END SETSUSER; + +RD$RANDOM: PROCEDURE(FCB) BYTE; + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(mon3(33,fcb)); +/** $else **/ +/** $endif **/ + return dcnt; + END RD$RANDOM; + +write$random: procedure(fcb) byte; + declare fcb address; +/** $if mpm **/ + call retcodes(mon3(34,fcb)); +/** $else **/ +/** $endif **/ + return dcnt; + end write$random; + +retfsize: procedure(fcb) byte; + declare fcb address; + return mon2(35,fcb); + end retfsize; + +SET$RANDOM: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + /* SET RANDOM RECORD POSITION */ + CALL MON1(36,FCB); + END SET$RANDOM; + +/** $if mpm **/ +multsect: procedure(cnt); + declare cnt byte; + if mseccnt <> cnt then + call mon1(44,(mseccnt := cnt)); + end multsect; + +flushbuf: procedure; + call mon1(48, 0ffh); /* 0FFH = flush and discard buffers */ + end flushbuf; + +conatlst: procedure byte; + return mon2(161,0); + end conatlst; +/** $endif **/ + + +MOVE: PROCEDURE(S,D,N); + DECLARE (S,D) ADDRESS, N BYTE; + DECLARE A BASED S BYTE, B BASED D BYTE; + DO WHILE (N:=N-1) <> 255; + B = A; S = S+1; D = D+1; + END; + END MOVE; + + /* [JCE] PIP's error messages could do with improvement */ + + /* errtype error messages */ + declare er00(*) byte data ('While reading: $'); + declare er01(*) byte data ('While writing: $'); + declare er02(*) byte data ('While verifying: $'); + declare er03(*) byte data ('Invalid destination$'); + declare er04(*) byte data ('Invalid source$'); + declare er05(*) byte data ('User aborted$'); + declare er06(*) byte data ('Bad parameters'); + declare er07(*) byte data ('Invalid user number$'); + declare er08(*) byte data ('Invalid format$'); + declare er09(*) byte data ('Hex record checksum error$'); + declare er10(*) byte data ('File not found$'); + declare er11(*) byte data ('[S] pattern not found$'); + declare er12(*) byte data ('[Q] pattern not found$'); + declare er13(*) byte data ('Invalid hex digit$'); + declare er14(*) byte data ('While closing file: $'); + declare er15(*) byte data ('Unexpected end of hex file$'); + declare er16(*) byte data ('Invalid separator$'); + declare er17(*) byte data ('No directory space$'); + declare er18(*) byte data ('Invalid format with sparse file$'); +/** $if mpm **/ + declare er19(*) byte data ('While creating file: $'); + declare er20(*) byte data ('While opening file: $'); + declare er21(*) byte data ('Printer is busy$'); + declare er22(*) byte data ('Can''t delete temporary file$'); +/** $endif **/ + + declare errmsg(*) address data( + .er00,.er01,.er02,.er03,.er04, + .er05,.er06,.er07,.er08,.er09, + .er10,.er11,.er12,.er13,.er14, + .er15,.er16,.er17,.er18 +/** $if mpm **/ + ,.er19,.er20,.er21,.er22 +/** $endif **/ + ); + + declare sper00(*) byte data ('No directory space$'); + declare sper01(*) byte data ('No space on disc$'); + declare sper02(*) byte data ('Can''t close current extent$'); + declare sper03(*) byte data ('Seek to unwritten extent$'); + declare sper05(*) byte data ('Record number out of range$'); + declare sper06(*) byte data ('Records don''t match$'); + declare sper07(*) byte data ('Record locked$'); + declare sper08(*) byte data ('Invalid filename$'); + declare sper09(*) byte data ('FCB checksum$'); + + declare numspmsgs lit '10'; /* number of extended messages */ + declare special$msg(numspmsgs) address data( + .sper00,.sper01,.sper02,.sper03,.sper00, + .sper05,.sper06,.sper07,.sper08,.sper09); + +/** $if mpm **/ + /* extended error messages */ + declare ex00(*) byte data ('$'); /* NO MESSAGE */ + declare ex01(*) byte data ('Fatal error$'); + declare ex02(*) byte data ('Disc is read-only$'); + declare ex03(*) byte data ('File is read-only$'); + declare ex04(*) byte data ('Not a valid disc drive$'); + declare ex05(*) byte data ('Incompatible mode$'); + declare ex07(*) byte data ('Invalid password$'); + declare ex08(*) byte data ('File already exists$'); + declare ex10(*) byte data ('Limit exceeded$'); + + declare nummsgs lit '11'; /* number of extended messages */ + declare extmsg(nummsgs) address data( + .ex00,.ex01,.ex02,.ex03,.ex04, + .ex05,.sper09,.ex07,.ex08,.sper08, + .ex10); +/** $endif **/ + +error$cleanup: procedure; +/** $if mpm **/ + call multsect(1); +/** $endif **/ + eretry = 0; /* initialize to no error retry */ + if opened then /* if source file opened */ + do; call setsuser; + call close(.source); + opened = false; + end; + if made then + do; call setduser; + call close(.dest); + call delete(.dest); /* delete destination scratch file */ + end; + /* Zero the command length in case this is a single command */ + comlen = 0; + retry = true; + call print(.('ERROR: $')); + end error$cleanup; + +error: procedure (errtype); + declare errtype byte; + + call error$cleanup; + call printx(errmsg(errtype)); + call crlf; + go to reset; + end error; + +xerror: procedure (funcno,fileadr); + declare temp byte, + i byte, + sdcnt byte, + sexten byte, + funcno byte, + fileadr address, + fcb based fileadr (fsize) byte; + + declare message$index$tbl(17) byte data + (2,18,13,15,9,3,10,20,14,10,22,17,19,0,1,0,1); + + sdcnt = dcnt; + sexten = exten; + call error$cleanup; + + if (funcno < 6) or (sdcnt <> 0ffh) then + sexten = 0; + else sexten = sexten and 0fh; + + call printx(errmsg(message$index$tbl(funcno))); + + if (funcno > 12) and (funcno < 17) and + (sdcnt <> 0ffh) and (sdcnt <= numspmsgs) then + do; call printchar(' '); + call printx(special$msg(sdcnt-1)); + sexten = 0; + end; + +/** $if mpm **/ + if sexten < nummsgs then + do; call printchar(' '); + call printx(extmsg(sexten)); + end; +/** $endif **/ + + call printx(.(' - $')); + if fileadr <> 0 then + do; call printchar('A' + fcb(0) - 1); + call printchar(':'); + do i = 1 to fnsize; + if (temp := fcb(i) and 07fh) <> ' ' then + do; if i = fext then call printchar('.'); + call printchar(temp); + end; + end; + end; + call crlf; + + if (sdcnt = 3) or (sdcnt = 4) or (sdcnt = 6) or (sdcnt = 8) then + eretry = ambig; + else + if (sexten = 3) or ((sexten > 4) and (sexten < 9)) or (sexten > 9) then + eretry = ambig; + + go to reset; + end xerror; + +FORMERR: PROCEDURE; + call error(8); /* invalid format */ + END FORMERR; + +CONBRK: PROCEDURE; + /* CHECK CONSOLE CHARACTER READY */ + if mon2(11,0) <> 0 then + if mon2(6,0fdh) = cntrlc then + call error(5); + END CONBRK; + +MAXSIZE: procedure byte; + /* three byte compare of random record field + returns true if source.fcb.ranrec >= filesize */ + + if (source.fcb(35) < filsize(2)) then + return false; + if (source.fcb(35) = filsize(2)) then + do; + if (source.fcb(34) < filsize(1)) then + return false; + if (source.fcb(34) = filsize(1)) then + do; + if (source.fcb(33) < filsize(0)) then + return false; + end; + end; + return true; + end maxsize; + +SETUPDEST: PROCEDURE; + call setduser; /* destination user */ +/** $if mpm **/ + call move(.odest,.dest,(frsize + nsize + 1)); /* save original dest */ +/** $else **/ +/** $endif **/ + /* MOVE THREE CHARACTER EXTENT INTO DEST FCB */ + CALL MOVE(.('$$$'),.DEST.FCB(FEXT),FEXTL); +/** $if mpm **/ + odest.fcb(6) = odest.fcb(6) or 80h; + call open(.odest); /* try to open destination file */ + odcnt = dcnt; /* and save error code */ + if odcnt <> 255 then + call close(.odest); + else if (exten and 0fh) <> 0 then /* file exists */ + call xerror(7,.odest); /* but can't open - error */ + + CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */ + if dcnt = 255 and exten <> 0 then + /* cant delete temp file */ + call xerror(10,.dest); + CALL MAKE(.DEST); /* CREATE A NEW ONE */ + IF DCNT = 255 THEN + if (exten and 0fh) = 0 then + call xerror(11,.dest); /* no directory space */ + else call xerror(12,.dest); /* make file error */ +/** $else **/ +/** $endif **/ + DEST.FCB(32) = 0; + made = true; + END SETUPDEST; + +SETUPSOURCE: PROCEDURE; + declare (i,j) byte; + CALL SETSUSER; /* SOURCE USER */ +/** $if mpm **/ + source.fcb(6) = source.fcb(6) or 80h; +/** $endif **/ + CALL OPEN(.SOURCE); /* open source */ + if dcnt <> 255 then + opened = true; + IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN + /* skip system file */ + DCNT = 255; + IF DCNT = 255 THEN +/** $if mpm **/ + if (exten and 0fh) = 0 then + call xerror(6,.source); /* file not found */ + else + call xerror(7,.source); /* open file error */ +/** $else **/ +/** $endif **/ + f1 = source.fcb(1) and 80h; /* save file atributes */ + f2 = source.fcb(2) and 80h; + f3 = source.fcb(3) and 80h; + f4 = source.fcb(4) and 80h; + ro = source.fcb(9) and 80h; + sys = source.fcb(10) and 80h; + dcnt = retfsize(.source); + call move(.source.fcb(33),.filsize,3); + SOURCE.FCB(32) = 0; + source.fcb(33),source.fcb(34),source.fcb(35) = 0; + /* cause immediate read with no preceding write */ + NSOURCE = 0ffffh; + END SETUPSOURCE; + +WRITEDEST: PROCEDURE; + /* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION + NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */ + DECLARE (J,DATAOK) BYTE, + (tdest,n) address; + if not made then call setupdest; + if (n := ndest and 0ff80h) = 0 then return; + tdest = 0; + call setduser; /* destination user */ + if (sparfil := (sparfil or insparc)) then + /* set up fcb from random record no. */ + do; +/** $if mpm **/ + call multsect(1); +/** $endif **/ + CALL SETDMA(.dbuff(tdest)); + if write$random(.dest) <> 0 then + call xerror(16,.dest); /* DISK WRITE ERROR */ + end; + else + CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */ +/** $if mpm **/ + if fastcopy then + do; bufsize = maxmbuf; + call multsect(maxmcnt); + end; + else + do; bufsize = 128; + call multsect(1); + end; +/** $endif **/ + + do while n - tdest > 127; +/** $if mpm **/ + if fastcopy and (n - tdest < maxmbuf) then + do; bufsize = n - tdest; + call multsect(low(shr(bufsize,7))); + end; +/** $endif **/ + /* SET DMA ADDRESS TO NEXT BUFFER */ + CALL SETDMA(.dbuff(tdest)); + call diskwrite(.dest); + IF dcnt <> 0 THEN + call xerror(14,.dest); /* DISK WRITE ERROR */ +/** $if mpm **/ + tdest = tdest + bufsize; +/** $else **/ +/** $endif **/ + END; + + IF VERIF THEN /* VERIFY DATA WRITTEN OK */ + DO; + call flushbuf; + tdest = 0; +/** $if mpm **/ + call multsect(1); +/** $endif **/ + CALL SETDMA(.BUFF); /* FOR COMPARE */ + do while tdest < n; + DATAOK = (RDRANDOM(.DEST) = 0); + if (DESTR := DESTR + 1) = 0 then /* 3 byte inc for */ + destr2 = destr2 + 1; /* next random record */ + J = 0; + /* PERFORM COMPARISON */ + DO WHILE DATAOK AND J < 80H; + DATAOK = (BUFF(J) = DBUFF(tdest+J)); + J = J + 1; + END; + tdest = tdest + 128; + IF NOT DATAOK THEN + call xerror(0,.dest); /* VERIFY ERROR */ + END; + call diskrd(.dest); + /* NOW READY TO CONTINUE THE WRITE OPERATION */ + END; + CALL SETRANDOM(.DEST); /* set base record for sparce copy */ + call move(.dbuff(tdest),.dbuff(0),low(ndest := ndest - tdest)); + END WRITEDEST; + +FILLSOURCE: PROCEDURE; + /* FILL THE SOURCE BUFFER */ + call conbrk; +/** $if mpm **/ + if fastcopy then + do; bufsize = maxmbuf; + call multsect(maxmcnt); + end; + else do; + bufsize = 128; + call multsect(1); + end; +/** $endif **/ + CALL SETSUSER; /* SOURCE USER NUMBER SET */ + nsource = nsbuf; + do while sblen - nsbuf > 127; + if fastcopy and (sblen - nsbuf < maxmbuf) then + do; bufsize = (sblen - nsbuf) and 0ff80h; + call multsect(low(shr(bufsize,7))); + end; + /* SET DMA ADDRESS TO NEXT BUFFER POSIITION */ + CALL SETDMA(.SBUFF(nsbuf)); + extsave = source.fcb(12); /* save extent field */ + call diskrd(.source); + IF dcnt <> 0 THEN + DO; IF dcnt <> 1 THEN + call xerror(13,.source); /* DISK READ ERROR */ + /* END - OF - FILE */ +/** $if mpm **/ + if fastcopy then /* add no. sectors copied */ + nsbuf = nsbuf + shl(double(exten),7); + /* nsbuf = nsbuf + shl(double(exten and 0f0h),3); */ +/** $endif **/ + /* check boundry condition for bug in bdos and correct */ + if (source.fcb(12) <> extsave) and (source.fcb(32) = 80h) then + source.fcb(32) = 0; /* zero current record */ + call set$random(.source); + if (insparc := not maxsize) then + do; + if concat or (not fastcopy) then + /* invalid format with sparce file */ + call xerror(1,.source); + end; + else + do; + call close(.source); + opened = false; + end; + endofsrc = true; /* set end of source file */ + SBUFF(nsbuf) = ENDFILE; return; + END; + ELSE +/** $if mpm **/ + nsbuf = nsbuf + bufsize; +/** $else **/ +/** $endif **/ + END; + END FILLSOURCE; + +PUTDCHAR: PROCEDURE(B); + DECLARE B BYTE; + /* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY ODEST.TYPE */ + IF B >= ' ' THEN + DO; COLUMN = COLUMN + 1; + IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */ + DO; IF COLUMN > DELET THEN RETURN; + END; + END; + if echo then call mon1(2,b); /* echo to console */ + do case odest.type; + /* CASE 0 IS OUT */ + CALL OUTD(B); + /* CASE 1 IS PRN, TABS EXPANDED, LINES LISTED */ + call mon1(5,b); + /* CASE 2 IS LST */ + CALL MON1(5,B); + /* CASE 3 IS axo */ +axocase: +/** $if not mpm **/ + CALL MON1(4,B); +/** $else **/ +/** $endif **/ + /* CASE 4 IS DESTINATION FILE */ + DO; + IF NDEST >= DBLEN THEN CALL WRITEDEST; + DBUFF(NDEST) = B; + NDEST = NDEST+1; + END; + /* CASE 5 IS AUX */ + goto axocase; + /* CASE 6 IS CON */ + CALL MON1(2,B); + END; /* of case */ + END PUTDCHAR; + +PUTDESTC: PROCEDURE(B); + DECLARE (B,I) BYTE; + /* WRITE DESTINATION CHARACTER, TAB EXPANSION */ + IF B <> TAB THEN CALL PUTDCHAR(B); + ELSE IF TABS = 0 THEN CALL PUTDCHAR(B); + ELSE /* B IS TAB CHAR, TABS > 0 */ + DO; I = COLUMN; + DO WHILE I >= TABS; + I = I - TABS; + END; + I = TABS - I; + DO WHILE I > 0; + I = I - 1; + CALL PUTDCHAR(' '); + END; + END; + IF B = CR THEN COLUMN = 0; + END PUTDESTC; + +PRINT1: PROCEDURE(B); + DECLARE B BYTE; + IF (ZEROSUP := ZEROSUP AND B = 0) THEN + CALL PUTDESTC(' '); + ELSE + CALL PUTDESTC('0'+B); + END PRINT1; + +PRINTDIG: PROCEDURE(D); + DECLARE D BYTE; + CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B); + END PRINTDIG; + +NEWLINE: PROCEDURE; + DECLARE ONE BYTE; + ONE = 1; + ZEROSUP = (NUMB = 1); + C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0); + CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1); + IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */ + DO; CALL PUTDESTC(':'); CALL PUTDESTC(' '); + END; + ELSE + CALL PUTDESTC(TAB); + END NEWLINE; + +PUTDEST: PROCEDURE(B); + DECLARE (I,B) BYTE; + /* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */ + IF FORMF THEN /* SKIP FORM FEEDS */ + DO; IF B = FF THEN RETURN; + END; + IF PUTNUM THEN /* END OF LINE OR START OF FILE */ + DO; + IF (B <> FF) and (b <> endfile) THEN + DO; /* NOT FORM FEED or end of file */ + IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */ + DO; IF I=1 THEN I=LPP; + IF (LINENO := LINENO + 1) >= I THEN + DO; LINENO = 0; /* NEW PAGE */ + CALL PUTDESTC(FF); + END; + END; + IF NUMB > 0 THEN + CALL NEWLINE; + PUTNUM = FALSE; + END; + END; + IF B = FF THEN LINENO = 0; + CALL PUTDESTC(B); + IF B = LF THEN PUTNUM = TRUE; + END PUTDEST; + + +UTRAN: PROCEDURE(B) BYTE; + DECLARE B BYTE; + /* TRANSLATE ALPHA TO UPPER CASE */ + IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */ + B = B AND 101$1111B; /* TO UPPER CASE */ + RETURN B; + END UTRAN; + +LTRAN: PROCEDURE(B) BYTE; + DECLARE B BYTE; + /* TRANSLATE TO LOWER CASE ALPHA */ + IF B >= 'A' AND B <= 'Z' THEN + B = B OR 10$0000B; /* TO LOWER */ + RETURN B; + END LTRAN; + +GETSOURCEC: PROCEDURE BYTE; + /* READ NEXT SOURCE CHARACTER */ + DECLARE (B,CONCHK) BYTE; + + CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */ + DO CASE source.type; + /* CASE 0 IS out */ + go to notsource; + /* CASE 1 IS prn */ + go to notsource; + /* CASE 2 IS lst */ + notsource: + call error(4); /* INVALID SOURCE */ + /* CASE 3 IS axo */ + go to notsource; + /* CASE 4 IS SOURCE FILE */ + DO; + IF NSOURCE >= SBLEN THEN + do; if dblbuf or (not dfile) then + nsbuf = 0; + else if (nsource <> 0ffffh) then + do; call writedest; + nsbuf = ndest; + end; + CALL FILLSOURCE; + end; + B = SBUFF(NSOURCE); + NSOURCE = NSOURCE + 1; + END; + /* CASE 5 IS AUX */ + goto axicase; + /* CASE 6 IS CON */ + DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */ + B = MON2(1,0); + END; + /* CASE 7 IS axi */ +axicase: +/** $if not mpm **/ + B = MON2(3,0) AND 7FH; +/** $else **/ +/** $endif **/ + /* CASE 7 IS INP */ + B = INPD; + END; /* OF CASES */ + + IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */ + DO; + IF obj THEN /* SOURCE IS AN OBJECT FILE */ + CONCHK = ((CONCNT := CONCNT + 1) = 0); + ELSE /* ASCII */ + CONCHK = (B = LF); + IF CONCHK THEN + DO; + call CONBRK; + END; + END; + IF ZEROP THEN B = B AND 7FH; + IF UPPER THEN RETURN UTRAN(B); + IF LOWER THEN RETURN LTRAN(B); + RETURN B; + END GETSOURCEC; + +GETSOURCE: PROCEDURE BYTE; + /* GET NEXT SOURCE CHARACTER */ + DECLARE CHAR BYTE; + MATCH: PROCEDURE(B) BYTE; + /* MATCH START AND QUIT STRINGS */ + DECLARE (B,C) BYTE; + IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */ + DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */ + RETURN TRUE; + END; + IF C = CHAR THEN MATCHLEN = MATCHLEN + 1; + ELSE + MATCHLEN = 0; /* NO MATCH */ + RETURN FALSE; + END MATCH; + + IF QUITLEN > 0 THEN + DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF; + RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */ + END; + DO FOREVER; /* LOOKING FOR START */ + IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */ + DO; FEEDLEN = FEEDLEN - 1; + CHAR = COMBUFF(FEEDBASE); + FEEDBASE = FEEDBASE + 1; + RETURN CHAR; + END; + IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE; + IF STARTS > 0 THEN /* LOOKING FOR START STRING */ + DO; IF MATCH(STARTS) THEN + DO; FEEDBASE = STARTS; STARTS = 0; + FEEDLEN = MATCHLEN + 1; + matchlen = 0; + END; /* OTHERWISE NO MATCH, SKIP CHARACTER */ + END; + ELSE IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */ + DO; IF MATCH(QUITS) THEN + DO; QUITS = 0; QUITLEN = 2; + /* SUBSEQUENTLY RETURN CR, LF, ENDFILE */ + RETURN CR; + END; + RETURN CHAR; + END; + ELSE + RETURN CHAR; + END; /* OF DO FOREVER */ + END GETSOURCE; + +RD$EOF: PROCEDURE BYTE; + /* RETURN TRUE IF END OF FILE */ + CHAR = GETSOURCE; + IF obj THEN RETURN (endofsrc and (nsource > nsbuf)); + RETURN (CHAR = ENDFILE); + END RD$EOF; + + +HEXRECORD: PROCEDURE; + DECLARE (h, hbuf, RL, CS, RT) BYTE, + zerorec byte, /* true if last record had length of zero */ + LDA ADDRESS; /* LOAD ADDRESS WHICH FOLLOWS : */ + + ckhex: procedure byte; + IF H - '0' <= 9 THEN + RETURN H-'0'; + IF H - 'A' > 5 THEN + CALL xerror(2,.source); /* invalid hex digit */ + RETURN H - 'A' + 10; + end ckhex; + + rdhex: procedure byte; + call putdest(h := getsource); + return ckhex; + end rdhex; + + RDCS: PROCEDURE BYTE; + /* READ BYTE WITH CHECKSUM */ + RETURN CS := CS + (SHL(RDHEX,4) OR RDHEX); + END RDCS; + + RDADDR: PROCEDURE ADDRESS; + /* READ DOUBLE BYTE WITH CHECKSUM */ + RETURN SHL(DOUBLE(RDCS),8) OR RDCS; + END RDADDR; + + /* READ HEX FILE AND CHECK EACH RECORD + FOR VALID DIGITS, AND PROPER CHECKSUM */ + zerorec = false; + /* READ NEXT RECORD */ + h = getsource; + do forever; + /* SCAN FOR THE ':' */ + DO WHILE h <> ':'; + IF (h = ENDFILE) THEN + do; if zerorec then return; + CALL xerror(3,.source); /* unexpected end of hex file */ + end; + call putdest(h); + h = getsource; + END; + + /* ':' FOUND */ + /* check for end of hex record */ + h = getsource; + rl = shl(ckhex,4); + hbuf = h; h = getsource; + rl = rl or ckhex; + if (rl = 0) then zerorec = true; + else zerorec = false; + if (zerorec and ignor) then + do while (h <> ':') and (h <> endfile); + h = getsource; + end; + else do; call putdest(':'); + call putdest(hbuf); + call putdest(h); + cs = rl; + LDA = RDADDR; /* LOAD ADDRESS */ + + /* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */ + RT = RDCS; /* RECORD TYPE */ + DO WHILE RL <> 0; RL = RL - 1; + hbuf = RDCS; + /* INCREMENT LA HERE FOR EXACT ADDRESS */ + END; + + /* CHECK SUM */ + IF rdcs <> 0 THEN + CALL xerror(4,.source); /* hex record checksum */ + h = getsource; + end; + end; /* do forever */ + END HEXRECORD; + +CK$STRINGS: PROCEDURE; + IF STARTS > 0 THEN + call error(11); /* START NOT FOUND */ + IF QUITS > 0 THEN + call error(12); /* QUIT NOT FOUND */ + END CK$STRINGS; + +CLOSEDEST: PROCEDURE; + DO WHILE (LOW(NDEST) AND 7FH) <> 0; + CALL PUTDEST(ENDFILE); + END; + CALL CK$STRINGS; + CALL WRITEDEST; + call setduser; /* destination user */ + CALL CLOSE(.DEST); + IF DCNT = 255 THEN +/** $if mpm **/ + call xerror(8,.dest); /* CLOSE FILE */ + IF odcnt <> 255 THEN /* FILE EXISTS */ + do; +/** $else **/ +/** $endif **/ + IF ROL(odest.fcb(9),1) THEN /* READ ONLY */ + DO; + IF NOT WRROF THEN + DO; + do while ((dcnt <> 'Y') and (dcnt <> 'N')); + CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)? $')); + dcnt = utran(rdchar); + end; + IF dcnt <> 'Y' THEN + DO; CALL PRINT(.('**NOT DELETED**$')); + CALL CRLF; + CALL DELETE(.DEST); + RETURN; + END; + CALL CRLF; + END; + END; + /* reset r/o and sys attributes */ + odest.fcb(9) = odest.fcb(9) and 7fh; + odest.fcb(10) = odest.fcb(10) AND 7FH; + CALL SETIND(.odest); + CALL DELETE(.odest); + END; + CALL MOVE(.odest.fcb,.dest.fcb(16),16); /* READY FOR RENAME */ + CALL RENAME(.DEST); + /* set destination attributes same as source */ + odest.fcb(1) = (odest.fcb(1) and 07fh) or f1; + odest.fcb(2) = (odest.fcb(2) and 07fh) or f2; + odest.fcb(3) = (odest.fcb(3) and 07fh) or f3; + odest.fcb(4) = (odest.fcb(4) and 07fh) or f4; + odest.fcb(8) = (odest.fcb(8) and 07fh); + odest.fcb(9) = (odest.fcb(9) and 07fh) or ro; + odest.fcb(10) = (odest.fcb(10) and 07fh) or sys; + odest.fcb(11) = (odest.fcb(11) and 07fh); + call setind(.odest); + if archiv then /* set archive bit */ + do; call setsuser; + source.fcb(11) = source.fcb(11) or 080h; + source.fcb(12) = 0; + call setind(.source); + end; + END CLOSEDEST; + +SIZE$MEMORY: PROCEDURE; + /* SET UP SOURCE AND DESTINATION BUFFERS */ + if not dblbuf then + do; /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */ + sbase = .memory; + sblen,dblen = ((maxb - .memory) and 0ff80h) - 128; + end; + else do; /* may need to write destination buffer */ + sblen,dblen = (shr((maxb - .memory),1) and 0ff80h) - 128; + sbase = .memory + dblen + 128; + if ndest >= dblen then call writedest; + nsbuf = 0; + end; + END SIZE$MEMORY; + +setupeob: procedure; + /* sets nsbuf to end of source buffer */ + declare i byte; + if (not obj) and (nsbuf <> 0) then + do; tblen = nsbuf - 128; + do i = 0 to 128; + if (sbuff(tblen + i)) = endfile then + do; nsbuf = tblen + i; + return; + end; + end; + end; + end setupeob; + +SIMPLECOPY: PROCEDURE; + DECLARE I BYTE; + declare + fast lit '0', /* fast file to file copy */ + chrt lit '1', /* character transfer option */ + dubl lit '2'; /* double buffer required for file copy */ + declare optype(26) byte data ( + /* option type for each option character */ + fast, /* for A option */ + fast, /* for B option */ + fast, /* for C option */ + dubl, /* for D option */ + chrt, /* for E option */ + dubl, /* for F option */ + fast, /* for G option */ + chrt, /* for H option */ + dubl, /* for I option */ + fast, /* for J option */ + fast, /* for K option */ + chrt, /* for L option */ + fast, /* for M option */ + dubl, /* for N option */ + fast, /* for O option */ + dubl, /* for P option */ + dubl, /* for Q option */ + fast, /* for R option */ + dubl, /* for S option */ + dubl, /* for T option */ + chrt, /* for U option */ + fast, /* for V option */ + fast, /* for W option */ + fast, /* for X option */ + fast, /* for Y option */ + chrt); /* for Z option */ + + chkrandom: procedure; + call setsuser; + call set$random(.source); +/** $if mpm **/ + call multsect(1); +/** $endif **/ + call setdma(.buff); + do forever; + if (((dcnt := rd$random(.source)) = 0) or maxsize) then + do; destr = sourcer; + destr2 = sourcer2; + endofsrc = false; + return; + end; + if dcnt = 1 then + do; if (sourcer := sourcer + 1) = 0 then + sourcer2 = sourcer2 + 1; + end; + else if dcnt = 4 then + do; + if (sourcer := (sourcer + 128) and 0ff80h) = 0 then + sourcer2 = sourcer2 + 1; + end; + else + call xerror(15,.source); + end; + end chkrandom; + + fastcopy = (sfile and dfile); + endofsrc = false; + dblbuf = false; + sparfil = false; + insparc = false; + /* LOOK FOR PARAMETERS */ + DO I = 0 TO 25; + IF CONT(I) <> 0 THEN + DO; + IF optype(i) = chrt THEN + FASTCOPY = FALSE; + else + if optype(i) = dubl then + do; dblbuf = (sfile and dfile); + fastcopy = false; + end; + END; + END; + + CALL SIZE$MEMORY; + if sfile then + CALL SETUPSOURCE; + /* FILES READY FOR COPY */ + + if fastcopy then + do while not endofsrc; + CALL FILLSOURCE; + if endofsrc and concat then + do; call setupeob; + ndest = nsbuf; + if nendcmd then return; + end; + ndest = nsbuf; + CALL WRITEDEST; + nsbuf = ndest; + if (endofsrc and insparc) then + call chkrandom; + end; + + else do; + /* PERFORM THE ACTUAL COPY FUNCTION */ + IF HEXT OR IGNOR THEN /* HEX FILE */ + call hexrecord; + ELSE + DO WHILE NOT RD$EOF; + CALL PUTDEST(CHAR); + END; + if concat and nendcmd then + do; nsbuf = ndest; + return; + end; + end; + + if dfile then + CALL CLOSEDEST; + END SIMPLECOPY; + +MULTCOPY: PROCEDURE; + DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS; + + PRNAME: PROCEDURE; + /* PRINT CURRENT FILE NAME */ + DECLARE (I,C) BYTE; + CALL CRLF; + DO I = 1 TO FNSIZE; + IF (C := odest.fcb(I)) <> ' ' THEN + DO; IF I = FEXT THEN CALL PRINTCHAR('.'); + CALL PRINTCHAR(C); + END; + END; + END PRNAME; + + archck: procedure byte; + /* check if archive bit is set in any extent of source file */ + if not archiv then + return 1; + call setsuser; + source.fcb(12) = what; + call search(.source); + do while dcnt <> 255; + call move(.buff+shl(dcnt and 11b,5)+1,.source.fcb(1),15); + if not rol(source.fcb(11),1) then + return 1; + call searchn; + end; + return 0; + end archck; + +/** $if mpm **/ + /* initialize counters if not error retry */ + if eretry = 0 then NEXTDIR, NCOPIED = 0; +/** $else **/ +/** $endif **/ + + DO FOREVER; + /* FIND A MATCHING ENTRY */ + CALL SETSUSER; /* SOURCE USER */ + CALL SETDMA(.BUFF); + searfcb(12) = 0; + CALL SEARCH(.SEARFCB); + NDCNT = 0; + DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR; + NDCNT = NDCNT + 1; + CALL SEARCHN; + END; + /* FILE CONTROL BLOCK IN BUFFER */ + IF DCNT = 255 THEN + DO; IF NCOPIED = 0 THEN + call xerror(9,.searfcb); /* file not found */ + if not kilds then + CALL CRLF; + RETURN; + END; + NEXTDIR = NDCNT + 1; + /* GET THE FILE CONTROL BLOCK NAME TO DEST */ + CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.odest.fcb(1),15); + CALL MOVE(.odest.fcb(1),.SOURCE.FCB(1),15); /* FILL BOTH FCB'S */ + if archck then + do; odest.fcb(12) = 0; + source.fcb(12) = 0; + IF RSYS OR NOT ROL(odest.fcb(10),1) THEN /* OK TO READ */ + DO; if not kilds then /* kill display option */ + do; IF NCOPIED = 0 THEN + CALL PRINT(.('COPYING -$')); + dcnt = false; + do while ((dcnt <> 'Y') and (dcnt <> 'N')); + call prname; + if confrm then + do; call printx(.(' (Y/N)? $')); + dcnt = utran(rdchar); + end; + else + dcnt = 'Y'; + end; + end; + ncopied = ncopied + 1; + made = false; /* destination file not made */ + if (dcnt = 'Y') or (kilds) then + CALL SIMPLECOPY; + END; + end; + END; + END MULTCOPY; + +CK$DISK: PROCEDURE; + /* error if same user and same disk */ + IF (odest.user = source.user) and (odest.fcb(0) = source.fcb(0)) THEN + CALL FORMERR; + END CK$DISK; + +GNC: PROCEDURE BYTE; + IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR; + RETURN UTRAN(COMBUFF(CBP)); + END GNC; + +DEBLANK: PROCEDURE; + DO WHILE (CHAR := GNC) = ' '; + END; + END DEBLANK; + +CK$EOL: PROCEDURE; + CALL DEBLANK; + IF CHAR <> CR THEN CALL FORMERR; + END CK$EOL; + +SCAN: PROCEDURE(FCBA); + DECLARE FCBA ADDRESS, /* ADDRESS OF FCB TO FILL */ + fcbs based fcba structure ( /* FCB STRUCTURE */ + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ); + DECLARE (I,K) BYTE; /* TEMP COUNTERS */ + + /* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME. + THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */ + + DELIMITER: PROCEDURE(C) BYTE; + DECLARE (I,C) BYTE; + DECLARE DEL(*) BYTE DATA + (' =.:;,<>',CR,LA,LB,RB); + DO I = 0 TO LAST(DEL); + IF C = DEL(I) THEN RETURN TRUE; + END; + RETURN FALSE; + END DELIMITER; + + PUTCHAR: PROCEDURE; + FCBS.FCB(FLEN:=FLEN+1) = CHAR; + IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */ + END PUTCHAR; + + FILLQ: PROCEDURE(LEN); + /* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */ + DECLARE LEN BYTE; + CHAR = WHAT; /* QUESTION MARK */ + DO WHILE FLEN < LEN; + CALL PUTCHAR; + END; + END FILLQ; + + SCANPAR: PROCEDURE; + DECLARE (I,J) BYTE; + /* SCAN OPTIONAL PARAMETERS */ + CHAR = GNC; /* SCAN PAST BRACKET */ + DO WHILE NOT(CHAR = CR OR CHAR = RB); + IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */ + DO; IF CHAR = ' ' THEN + CHAR = GNC; + ELSE + call error(6); /* BAD PARAMETER */ + END; + ELSE + DO; /* SCAN PARAMETER VALUE */ + IF CHAR = 'S' OR CHAR = 'Q' THEN + DO; /* START OR QUIT COMMAND */ + J = CBP + 1; /* START OF STRING */ + DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR); + END; + CHAR=GNC; + END; + ELSE IF (J := (CHAR := GNC) - '0') > 9 THEN + J = 1; + ELSE + DO WHILE (K := (CHAR := GNC) - '0') <= 9; + J = J * 10 + K; + END; + CONT(I) = J; + IF I = 6 THEN /* SET SOURCE USER */ + DO; + IF J > 15 THEN + call error(7); /* INVALID USER NUMBER */ + fcbs.user = J; + END; + END; + END; + CHAR = GNC; + END SCANPAR; + + + /* scan procedure entry point */ + + /* INITIALIZE FILE CONTROL BLOCK TO EMPTY */ + fcbs.type = ERR; CHAR = ' '; FLEN = 0; +/** $if mpm **/ + DO WHILE FLEN < (FRSIZE + NSIZE); + IF FLEN = FNSIZE THEN CHAR = 0; + ELSE IF FLEN = FRSIZE THEN CHAR = ' '; + call putchar; + END; + fcbs.pwnam(0) = 0; + fcbs.pwmode = 1; +/** $else **/ +/** $endif **/ + fcbs.fcb(0) = cdisk +1; /* initialize to current disk */ + fcbs.user = cuser; /* and current user */ + /* CLEAR PARAMETERS */ + DO I = 0 TO 25; CONT(I) = 0; + END; + FEEDLEN,MATCHLEN,QUITLEN = 0; + + /* DEBLANK COMMAND BUFFER */ + CALL DEBLANK; + + /* CHECK PERIPHERALS AND DISK FILES */ + /* SCAN NEXT NAME */ + DO FOREVER; + FLEN = 0; + DO WHILE NOT DELIMITER(CHAR); + IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */ + RETURN; + IF CHAR = '*' THEN CALL FILLQ(NSIZE); + ELSE CALL PUTCHAR; + CHAR = GNC; + END; + + /* CHECK FOR DISK NAME OR DEVICE NAME */ + IF CHAR = ':' THEN + DO; IF FLEN = 1 THEN + /* MAY BE DISK NAME A ... P */ + DO; + IF (fcbs.fcb(0) := fcbs.fcb(1) - 'A' + 1) > 16 THEN + RETURN; /* ERROR, INVALID DISK NAME */ + CALL DEBLANK; /* MAY BE DISK NAME ONLY */ + IF DELIMITER(CHAR) THEN + DO; IF CHAR = LB THEN + CALL SCANPAR; + CBP = CBP - 1; + fcbs.type = DISKNAME; + RETURN; + END; + END; + ELSE + /* MAY BE A THREE CHARACTER DEVICE NAME */ + IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */ + RETURN; + ELSE + /* LOOK FOR DEVICE NAME */ + DO; DECLARE (I,J,K) BYTE, M LITERALLY '9', + IO(*) BYTE DATA + ('OUTPRNLSTAXO', + 0,0,0, /* fake area for file type */ + 'AUX', + 'CONAXIINPNULEOF',0); + + J = 255; + DO K = 0 TO M; + I = 0; + DO WHILE ((I:=I+1) <= 3) AND + IO(J+I) = fcbs.fcb(I); + END; + IF I = 4 THEN /* COMPLETE MATCH */ + DO; fcbs.type = k; + /* SCAN PARAMETERS */ + IF GNC = LB THEN CALL SCANPAR; + CBP = CBP - 1; + RETURN; + END; + J = J + 3; /* OTHERWISE TRY NEXT DEVICE */ + END; + RETURN; /* ERROR, NO DEVICE NAME MATCH */ + END; + IF CHAR = LB THEN /* PARAMETERS FOLLOW */ + CALL SCANPAR; + END; + ELSE + /* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */ + DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */ + RETURN; + FLEN = NSIZE; + IF CHAR = '.' THEN /* SCAN FILE TYPE */ + DO WHILE NOT DELIMITER(CHAR := GNC); + IF FLEN >= FNSIZE THEN + RETURN; /* ERROR, TYPE FIELD TOO LONG */ + IF CHAR = '*' THEN CALL FILLQ(FNSIZE); + ELSE CALL PUTCHAR; + END; +/** $if mpm **/ + FLEN = 0; + IF CHAR = ';' THEN /* SCAN PASSWORD */ + DO WHILE NOT DELIMITER(CHAR := GNC); + IF FLEN >= NSIZE THEN + /* ERROR, PW TOO LONG */ RETURN; + ELSE /* SAVE PASSWORD */ + FCBS.PWNAM(FLEN) = CHAR; + FLEN = FLEN + 1; + END; +/** $endif **/ + IF CHAR = LB THEN + CALL SCANPAR; + /* RESCAN DELIMITER NEXT TIME AROUND */ + CBP = CBP - 1; + fcbs.type = FILE; + FCBS.FCB(32) = 0; + RETURN; + END; + END; + END SCAN; + + +/* PLM (PIP) ENTRY POINT */ + /* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED + FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */ + + if not retry then + do; CALL MOVE(.BUFF,.COMLEN,80H); + MULTCOM = (COMLEN = 0); + + /* GET CURRENT CP/M VERSION */ + IF low(CVERSION) < VERSION THEN + DO; +/** $if cpm3 **/ + CALL PRINT(.('REQUIRES CP/M 3$')); +/** $else **/ +/** $endif **/ + CALL BOOT; + END; + + call mon1(45,255); /* set return error mode */ + +/** $if cpm3 **/ + call mon1(109,1); /* set CP/M 3 control-C status mode */ +/** $endif **/ + + if multcom then + do; +/** $if cpm3 **/ + call printx(.('CP/M 3 PIP VERSION 3.0$')); +/** $else **/ +/** $endif **/ + call crlf; + end; + + cuser,last$user = getuser; /* GET CURRENT USER */ + cdisk = getdisk; /* GET CURRENT DISK */ +/** $if mpm **/ + mseccnt = 1; +/** $endif **/ + eretry = false; /* need to initialize here for first time */ + end; + + + /* START HERE ON RESET EXIT FROM THE PROCEDURE 'ERROR' */ +/** $if mpm **/ + if eretry <> 0 then + do; call multcopy; + comlen = multcom; + end; +/** $endif **/ + /* MAIN PROCESSING LOOP. PROCESS UNTIL CR ONLY */ + DO FOREVER; + C1, C2, C3 = 0; /* LINE COUNT = 000000 */ + CONCNT,COLUMN = 0; /* PRINTER TABS */ + ndest,nsbuf = 0; + ambig = false; + made = false; /* destination file not made */ + opened = false; /* source file not opened */ + concat = false; + eretry = false; + PUTNUM = TRUE; /* ACTS LIKE LF OCCURRED ON ASCII FILE */ + dfile,sfile = true; + nendcmd = true; + LINENO = 254; /* INCREMENTED TO 255 > PAGCNT */ + /* READ FROM CONSOLE IF NOT A ONELINER */ + IF MULTCOM THEN + DO; CALL PRINTCHAR('*'); CALL RDCOM; + CALL CRLF; + END; + CBP = 255; + IF COMLEN = 0 THEN /* character = */ + do; call setcuser; /* restore current user */ + CALL BOOT; /* normal exit from pip here */ + end; + + /* LOOK FOR SPECIAL CASES FIRST */ + + CALL SCAN(.odest); + if ambig then + call xerror(5,.odest); /* invalid destination */ + call deblank; /* check for equal sign or left arrow */ + if (char <> '=') and (char <> la) then call formerr; + call scan(.source); + + IF odest.type = DISKNAME THEN + DO; + IF source.type <> file then call formerr; + CALL CK$EOL; + CALL CK$DISK; + odest.type = file; /* set for character transfer */ + /* MAY BE MULTI COPY */ + IF AMBIG THEN /* FORM IS A:=B:AFN */ + DO; + CALL MOVE(.source.fcb(0),.searfcb(0),frsize); + CALL MULTCOPY; + END; + ELSE DO; /* FORM IS A:=B:UFN */ + CALL MOVE(.source.fcb(1),.odest.fcb(1),frsize - 1); + CALL SIMPLECOPY; + END; + END; + + else IF (odest.type = FILE) and (source.type = DISKNAME) THEN + DO; + CALL CK$EOL; + CALL CK$DISK; + source.type = file; /* set for character transfer */ +/** $if mpm **/ + call move(.odest.fcb(1),.source.fcb(1),(frsize+nsize)); +/** $else **/ +/** $endif **/ + CALL SIMPLECOPY; + END; + + else if (odest.type > cons) then + call error(3); /* invalid destination */ + else do; + IF odest.type <> FILE THEN dfile = false; +/** $if not mpm **/ + /* no conditional attach list device */ +/** $else **/ +/** $endif **/ + /* SCAN AND COPY UNTIL CR */ + DO WHILE nendcmd; + sfile = true; + call deblank; + IF (CHAR <> ',' AND CHAR <> CR) THEN + call error(16); /* invalid separator */ + concat = concat or (nendcmd := (char = ',')); + IF odest.type = PRNT THEN + DO; NUMB = 1; + IF TABS = 0 THEN TABS = 8; + IF PAGCNT = 0 THEN PAGCNT = 1; + END; + IF (source.type < file) or (source.type > eoft) or ambig THEN + call error(4); /* invalid source */ + IF source.type <> FILE THEN /* NOT A SOURCE FILE */ + sfile = false; + IF source.type = NULT THEN + /* SEND 40 NULLS TO OUTPUT DEVICE */ + DO sfile = 0 TO 39; CALL PUTDEST(0); + END; + ELSE IF source.type = EOFT THEN + CALL PUTDEST(ENDFILE); + else call simplecopy; + + CALL CK$STRINGS; + /* READ ENDFILE, GO TO NEXT SOURCE */ + + if nendcmd then call scan(.source); + END; + end; + + /* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */ + COMLEN = MULTCOM; + + END; /* DO FOREVER */ + end plm; + END; + +EOF diff --git a/software/CPM/cpm3/parse.asm b/software/CPM/cpm3/parse.asm new file mode 100644 index 0000000..5e6fa83 --- /dev/null +++ b/software/CPM/cpm3/parse.asm @@ -0,0 +1,234 @@ +$title ('Filename Parser') + name Parse + public parse + CSEG + ; BC->.(.filename,.fcb) + ; + ; filename = [d:]file[.type][;password] + ; + ; fcb assignments + ; + ; 0 => drive, 0 = default, 1 = A, 2 = B, ... + ; 1-8 => file, converted to upper case, + ; padded with blanks + ; 9-11 => type, converted to upper case, + ; padded with blanks + ; 12-15 => set to zero + ; 16-23 => password, converted to upper case, + ; padded with blanks + ; 24-25 => address of password field in 'filename', + ; set to zero if password length = 0 + ; 26 => length of password (0 - 8) + ; + ; Upon return, HL is set to FFFFH if BC locates + ; an invalid file name; + ; otherwise, HL is set to 0000H if the delimiter + ; following the file name is a 00H (NULL) + ; or a 0DH (CR); + ; otherwise, HL is set to the address of the delimiter + ; following the file name. + ; +parse: lxi h,0 + push h + push h + mov h,b + mov l,c + mov e,m + inx h + mov d,m + inx h + mov a,m + inx h + mov h,m + mov l,a + call deblnk + call delim + jnz parse1 + mov a,c + ora a + jnz parse9 + mov m,a + jmp parse3 +parse1: mov b,a + inx d + ldax d + cpi ':' + jnz parse2 + mov a,b + sui 'A' + jc parse9 + cpi 16 + jnc parse9 + inr a + mov m,a + inx d + call delim + jnz parse3 + cpi '.' + jz parse9 + cpi ':' + jz parse9 + cpi ';' + jz parse9 + jmp parse3 +parse2: dcx d + mvi m,0 +parse3: mvi b,8 + call setfld + mvi b,3 + cpi '.' + jz parse4 + call padfld + jmp parse5 +parse4: inx d + call setfld +parse5: mvi b,4 +parse6: inx h + mvi m,0 + dcr b + jnz parse6 + mvi b,8 + cpi ';' + jz parse7 + call padfld + jmp parse8 +parse7: inx d + call pwfld +parse8: push d + call deblnk + call delim + jnz pars81 + inx sp + inx sp + jmp pars82 +pars81: pop d +pars82: mov a,c + ora a + pop b + mov a,c + pop b + inx h + mov m,c + inx h + mov m,b + inx h + mov m,a + xchg + rnz + lxi h,0 + ret +parse9: pop h + pop h + lxi h,0ffffh + ret + +setfld: call delim + jz padfld + inx h + cpi '*' + jnz setfd1 + mvi m,'?' + dcr b + jnz setfld + jmp setfd2 +setfd1: mov m,a + dcr b +setfd2: inx d + jnz setfld +setfd3: call delim + rz + pop h + jmp parse9 + +pwfld: call delim + jz padfld + inx sp + inx sp + inx sp + inx sp + inx sp + inx sp + push d + push h + mvi l,0 + xthl + dcx sp + dcx sp +pwfld1: inx sp + inx sp + xthl + inr l + xthl + dcx sp + dcx sp + inx h + mov m,a + inx d + dcr b + jz setfd3 + call delim + jnz pwfld1 + ;jmp padfld + +padfld: inx h + mvi m,' ' + dcr b + jnz padfld + ret + +delim: ldax d + mov c,a + ora a + rz + mvi c,0 + cpi 0dh + rz + mov c,a + cpi 09h + rz + cpi ' ' + jc delim2 + rz + cpi '.' + rz + cpi ':' + rz + cpi ';' + rz + cpi '=' + rz + cpi ',' + rz + cpi '/' + rz + cpi '[' + rz + cpi ']' + rz + cpi '<' + rz + cpi '>' + rz + cpi 'a' + rc + cpi 'z'+1 + jnc delim1 + ani 05fh +delim1: ani 07fh + ret +delim2: pop h + jmp parse9 + +deblnk: ldax d + cpi ' ' + jz dblnk1 + cpi 09h + jz dblnk1 + ret +dblnk1: inx d + jmp deblnk + END + EOF + + + \ No newline at end of file diff --git a/software/CPM/cpm3/patch.asm b/software/CPM/cpm3/patch.asm new file mode 100644 index 0000000..ac8b881 --- /dev/null +++ b/software/CPM/cpm3/patch.asm @@ -0,0 +1,1068 @@ + title 'CP/M 3 Patch - Version 3.0' + ;*************************** + ;*************************** + ;** ** + ;** P A T C H ** + ;** ** + ;** AUGUST 15 1982 ** + ;** ** + ;*************************** + ;*************************** + ; + ; + org 100h ;beginning of TPA + ; + ;******************************** + ;* BDOS Functions + ;******************************** +return equ 0 ;Return to CCP +conout equ 2 ;Console Output +conin equ 6 ;Console Input +pstring equ 9 ;Print String +rstring equ 10 ;Read String +version equ 12 ;CP/M Version +openf equ 15 ;Open File +closef equ 16 ;Close File +readf equ 20 ;Read File +dmaf equ 26 ;Set DMA +writerf equ 34 ;Write Random +errmode equ 45 ;Set ERROR Mode + ; + ;******************************** + ;* Non Graphic Characters + ;******************************** +cr equ 0dh ;Carriage Return +lf equ 0ah ;Line Feed ^J +ctrlx equ 018h ;^X +ctrlc equ 03h ;^C +bak equ 08h ;<- +rub equ 07fh ;<- (DEL) + ; + ;******************************** + ;* FCB, BUFFER and BDOS Locations + ;******************************** +bdos equ 05h ;BDOS entry point +fcb equ 05ch ;File Control Block +spec equ 065h ;File Spec Beginning Location +buf equ 080h ;Password Buffer + ; + ;******************************** + ;* Beginning of Program + ;******************************** + jmp begin + ; + ;******************************** + ;* Patch Header / Patch Area + ;******************************** + dw 0,0,0,0,0,0 ;Undefined Area + db 0 + db 'PATCH VERSION3.0' ;Program name and version + db ' PATCH.COM ' ;Program as Found on Disk + dw 0,0,0,0,0,0,0,0 ;Undefined Area + dw 0,0,0,0,0,0,0,0 + maclib makedate + @LCOPY ;Copyright and Year + @BDATE ;Version Date [day-month-year] + db 0,0,0,0 ;Patch Bit Map + db '654321' ;Serial Number Identifier + ; + ;******************************** + ;* Beginning of Program + ;******************************** + jmp begin ;Begin Program + ; + ;******************************** + ;* Initializing Routine + ;******************************** +init: + lda 06fh + sta num + lhld 06dh ;Patch number inputed + shld number + mvi c,errmode ;Set ERROR Mode so no + mvi e,255 ;BDOS error messages will + call bdos ;appear + lxi d,intro$mess + call print ;print 'PATCH ' + ; +check$ver: + mvi c,version + call bdos ;get version + mov a,h ;'H'=0 -> CP/M + cpi 0h ;'H'=1 -> MP/M + jnz wrngver ;jump if wrong o.s. + mov a,l + cpi 030h + jc wrngver ;jump if wrong version + ret + ; + ;******************************** + ;* Check File Types + ;* Check Default Routines + ;******************************** +check$file: + lda fcb+1 + cpi ' ' + rnz + lxi d,file$prmt$mess + call print + mvi a,18 + sta file$buff + lxi d,file$buff + mvi c,rstring + call bdos ;ask for file name + lda file$buff+1 + cpi 0 + jz stop +parse: + lda file$buff+3 + cpi ':' + jz parse$drive + lxi h,file$buff+2 +parse2: + mvi b,8 + lxi d,fcb+1 +parse$name: + mov a,m + cpi '.' + jz parse3 + cpi ' ' + jz parse$num + cpi 'a' + jc parse$name2 + cpi '{' + jnc parse$name2 + sui 020h +parse$name2: + stax d + inx h + inx d + dcr b + jnz parse$name +parse3: + inx h + lxi d,fcb+9 + mvi b,3 +parse$type: + mov a,m + cpi ' ' + jz parse$num2 + cpi 'a' + jc parse$type2 + cpi '{' + jnc parse$type2 + sui 020h +parse$type2: + stax d + inx h + inx d + dcr b + jz parse$num + jmp parse$type + ; +parse$num: + inx h +parse$num2: + mov a,m + cpi ' ' + rz + sta 6dh + inx h + mov a,m + sta 6eh + lhld 6dh + shld number + ret + ; +parse$drive: + lda file$buff+2 + cpi 'a' + jc parse$drive2 + cpi '{' + jnc parse$drive2 + sui 020h +parse$drive2: + sui 040h + sta fcb + lxi h,file$buff+4 + lda fcb + cpi 17 + jnc bad$drive + jmp parse2 + ; +check$spec: + lxi h,spec + mvi b,3 +check$spec2: + mov a,m + cpi ' ' + rnz + inx h + dcr b + jnz check$spec2 + lxi h,04f43h ;='CO' + shld spec + mvi a,'M' + sta spec+2 + mvi a,1 + sta type + ret + ; +check$type: + call check$com ;check file type + jmp check$prl ;if .COM or .PRL + ; ;1=>COM 2=>PRL +check$com: + lda type + cpi 1 + lhld spec + mov a,l + cpi 'C' + rnz + mov a,h + cpi 'O' + rnz + lda spec+2 + cpi 'M' + rnz + mvi a,1 + sta type + ret + ; +check$prl: ;check if .PLR + lhld spec + mov a,l + cpi 'P' + jnz no$com + mov a,h + cpi 'R' + jnz no$com + lda spec+2 + cpi 'L' + jnz no$com + mvi a,2 + sta type + ret + ; + ;******************************** + ;* Open File / Password Routine + ;******************************** +open$fileº + mvi c,openf ;also check if PASSWORD + lxi d,fcb + call bdos ;open the file + sta keepa + mov a,h + cpi 7 ;if PASSWORD status exists + jz get$passwd ;then H=7 + lda keepa + cpi 255 ;if nofile then ACC.=FFh + jz no$file + ret + ; +get$passwd: + lda tpasswd + cpi 255 ;check if user has already + jz wrng$pass ;tried PASSWORD + call space + lxi d,quest + call print ;print 'Password ?' + call input ;get the PASSWORD + sta len ;len = length of PASSWORD + call cap ;CAP the PASSWORD + lxi d,buf+2 + call set$dma2 ;tell where PASSWORD can + mvi a,255 ;be found + sta tpasswd ;set Tried PASSWORD Flag + jmp open$file + ; +input: + lxi h,buf+2 ;Buf+2 = buffer area for + mvi a,0 ;PASSWORD +input2: ;ACC. is the counter + push h + sta keepa ;Save the registers + mvi c,conin + mvi e,0fdh + call bdos ;get raw character + cpi ctrlx + jz input3 ;restart input routine if ^X + cpi ctrlc + jz stop ;stop if ^C + cpi cr + jz input4 ;return if + cpi bak + jz back$space ;jump if DEL or BAK + cpi rub ;jump if RUB + jz back$space + pop h + mov m,a ;move into memory the char. + lda keepa ;restore the counter + inx h ;inc. Memory location + inr a ;inc. Counter + cpi 8 ;check if 8 chars. read + jnz input2 + ret + ; +back$space: ;BACK SPACE (^H) + pop h ;restore buffer pointer + lda keepa ;restore counter + dcx h ;set memory back 1 + dcr a ;set counter back 1 + mvi m,' ' ;blank out the unwanted + jmp input2 ;character + ; +input3: ;CTRL - X (^X) + pop h ;restore buffer pointer + call space ;blank out the buffer + jmp input ;for PASSWORD and start again + ; +input4: ;Restore STACK and return + pop h ;to GETPASSWD routine + ret + ; +space: ;This routine blanks + mvi a,8 ;out the buffer that + lxi h,buf+2 ;contains the PASSWORD +space2: ; + mvi m,' ' ;move into the pointer ' ' + inx h ;do it 8 times + dcr a + jnz space2 + ret + ; +cap: ;This routine changes + mvi d,8 ;the'PASSWORD' to upper-case + lxi h,buf+2 +cap2: + mov a,m + cpi 'a' ;check if character is + jc skip ;between 'a' and 'z' + cpi '{' ;if so then change it + jnc skip ;to uppercase by subtracting + sui 20h ;20 hex + mov m,a +skip: + inx h + dcr d + jnz cap2 + ; +del$char: ;This routine deletes + lda len ;the character after + adi 082h ;the PASSWORD because + sta len ;BDOS function 10 adds + lhld len ;an extra character to the + mvi m,' ' ;input + ret + ; + ;******************************** + ;* Serail Number Check Routines + ;******************************** +check$ser: ;This routine checks to see + lda type ;if the program to be PATCHED + cpi 1 ;is a CP/M 3 program + jz com$serial + cpi 2 + jz prl$serial + jmp no$com + ; +change$type: + mvi a,2 ;This routine tells PATCH +change$type2: ;to treat the current COM + sta keepa ;file in the FCB as a PRL + call set$dma ;file so it will search the + call read$buff ;third record instead of + lda keepa ;the first + dcr a + jnz change$type2 + call serial + mvi a,2 + sta type + ret + ; +com$serial: ;check for .COM serial # + call set$dma + call read$buff + lda buff + cpi 0c9h ;check if a 'ret' statement + jz change$type ;if so treat it as a PRL file + call serial + ret + ; +prl$serial: ;check for .PRl serial # + mvi a,3 ;counter +prl$serial2: + sta keepa ;must read in the 3rd + call set$dma ;record of the .PRL file + call read$buff ;inorder to check for the + lda keepa ;serial number and retreive + dcr a ;the patch bit map + jnz prl$serial2 + call serial + ret + ; +serial: ;this routine checks a certain + lxi h,buff+112 ;[JCE] DRI Patch 4 - check date + lxi d,ser$table ;memory block and searches 6 + + mvi b,5 ;certain bytes to see if it is +serial2: + ldax d + cmp m + jnz wrng$ser ;it checks the last 6 bytes + inx h + inx d + dcr b + jnz serial2 + ret + ; + ;******************************** + ;* Branching Routines + ;******************************** +check$rw: ;this routine checks to + lda num ;see if the user wants + cpi ' ' ;to 'WRITE' or 'READ' + jnz not$num ;a patch + lhld number + mov a,l + cpi ' ' + jz set$read + cpi '1' + jc not$num + cpi ':' + jnc not$num + mvi a,2 + sta rw ;set the'WRITE' flag + ret + ; +set$read: ;set the 'READ' flag + mvi a,1 + sta rw + ret + ; +branch: ;branch if 'READ or WRITE' + call get$patchbits ;get bit map patch + lda rw ;into actual numbers + cpi 1 + jz read ;if '1' then 'READ' + cpi 2 + jz write ;if '2' then 'WRITE' + jmp stop + ; + ;******************************** + ;* Multiply Routine + ;******************************** +get$num: ;get inputed number + lhld number ;by user and transfer it + mov a,h ;into a non ASCII number + cpi ' ' + jz set$val + sui 030h ;change into actual number + sta numtwo ;store it + mov a,l + sui 030h ;change into actual number + ; +multiply: + mvi b,9 ;times to add number + mov e,a +multiply2: + add e ;A=A+E + dcr b + jnz multiply2 + mov e,a ;E=A*10 + lda numtwo + add e + sta val + cpi 33 + jnc not$num + ret + ; +set$val: ;if inputed patch number is + mov a,l ;only one character then + sui 030h ;change it into a 'NO ASCII' + sta val ;number + ret + ; +get$patchbits: ;get the 4 bytes in the bit map + lhld buff+118 ;and save them for later + shld patch1 + lhld buff+120 + shld patch2 + ret + ; + ;******************************** + ;* READ Routine + ;******************************** +read: ;This routine checks the PATCH + lxi d,crpatc$mess ;Bit Map and displays any + call print ;current patches + call disp$file ;display the file + lxi d,col$cr$lf$sp + call print + call check$bits ;check if any patches exist + mvi e,0 ;hex total counter + lhld patch2 + mov a,h + call rot ;see if any 1-8 + lhld patch2 + mov a,l + call rot ;see if any 9-16 + lhld patch1 + mov a,h + call rot ;see if any 17-24 + lhld patch1 + mov a,l + call rot ;see if any 25-32 + jmp stop + ; +rot: + mvi d,8 ;loop counter (1-8) + sta keepa + mvi a,0 +rot2: + lda ct ;decimal counter + adi 1 + daa ;add 1 (decimal) + sta ct + inr e + mov a,e + sta keepe ;E is the hex counter + mov a,d + sta keepd + lda keepa + rrc ;rotate the byte + sta keepa + cc disp$ct ;Call routine if bit is on + lda keepd + mov d,a + dcr d ;check if loop is done + rz + jmp rot2 + ; +check$bits: + lhld patch2 ;This routine checks the + mov a,h ;Patch Bit Map area to see + cpi 0 ;if any of the bytes have + rnz ;a bit that is on + mov a,l + cpi 0 + rnz + lhld patch1 + mov a,h + cpi 0 + rnz + mov a,l + cpi 0 + jz no$patches ;jump if no bits are on + ret + ; + ;******************************** + ;* WRITE Routine + ;******************************** +write: + call check$same ;check to see if the inputed + lda hpatch ;number by the user + mov e,a ;already exists for the file + lda val + cmp e + cc lesser + jmp greater + ; +check$same: + lda val ;This routine takes the inputed + mov b,a ;number and compares it + mvi e,0 ;to an incrementing number + lhld patch2 ;every time a bit is on + mov a,h + call rotate + mov a,l + call rotate + lhld patch1 + mov a,h + call rotate + mov a,l + call rotate + ret + ; +rotate: + mvi d,8 ;counter to rotate eight times +rotate2: + inr e + rrc + sta keepa + cc compare ;if bit is on then check if + lda keepa ;the counter equals the inputed + dcr d ;number by the user + jnz rotate2 + ret + ; +compare: + mov a,e + sta hpatch ;store the current higest patch + cmp b ;found for later use + jz already + ret + ; +greater: ;This routine displays the + lxi d,instl$mess ;user's inputed patch number + call disp$num ;display inputed number + lxi d,has$mess + call print + lxi d,betw$mess + call print + call disp$file ;display the file in the 'FCB' + mvi e,' ' + call pbyte2 + mvi e,'?' ;make it a question + call pbyte2 + mvi e,' ' + call pbyte2 + mvi c,rstring + mvi a,4 ;length of input + sta answer ;buffer + lxi d,answer ;pont 'DE' to buffer + call bdos ;wait for input + lda answer+2 + cpi 'Y' + jz greater2 ;with the patch + cpi 'y' + jz greater2 + jmp quit$ptch +greater2: + call plc$patch ;place the patch in the buffer + call writ$ptch ;write the patch into the file + mvi c,closef + lxi d,fcb + call bdos ;close the file + lxi d,ok$mess ;tell user that the patch + jmp pr$stop ;is finished + ; +lesser: + lxi d,less$mess ;This routine cautions the user + call disp$num ;that patches greater than + lxi d,less2$mess + call print + call disp$file ;display the file + lxi d,cr$lf + call print + ret + ; +plc$patch: ;This routine checks to see + lda val ;what byte to alter + cpi 9 + jc byte3 ;inputed # is 1-8 + cpi 25 ;[JCE] Was 24, CP/M 3 patch 14 + jnc byte0 ;inputed # is 25-32 + cpi 17 + jc byte2 ;inputed # is 9-16 + jmp byte1 ;inputed # is 17-24 + ; +byte0: ;This routine is done + lda val ;if the input was between + sui 25 ;25-32 + sta bit$pos + mvi a,0 + jmp table$load + ; +byte1: ;This routine is done + lda val ;if the input was between + sui 17 ;17-24 + sta bit$pos + mvi a,1 + jmp table$load + ; +byte2: ;This routine is done + lda val ;if the input was between + sui 9 ;9-16 + sta bit$pos + mvi a,2 + jmp table$load + ; +byte3: ;This routine is done + lda val ;if the input was between + dcr a ;1-8 + sta bit$pos + mvi a,3 + jmp table$load + ; +table$load: + sta byte$pos + lxi h,buff+118 ;patch bit map + mvi b,0 + lda byte$pos ;patch area + mov c,a + dad b ;'HL' = location to get byte + shld patch$pos ;place to get/put patch + lxi h,table + mvi b,0 + lda bit$pos ;bit position (0-7) + mov c,a + dad b + mov b,m ;'HL' contains the byte to alter + lhld patch$pos + mov a,m + ora b ;turn the bit on + mov m,a ;save it + ret + ; +already: ;this routine tells the user + lxi d,alread$mess2 ;that the inputed patch number + call disp$num ;has already been installed + lxi d,alread$mess + call print + call disp$file + jmp stop + ; +writ$ptch: ;This routine branches depending + lda type ;what type of file type the file + cpi 1 ;has so it can write + jz com$patch ;correctly + jmp prl$patch + ; +com$patch: ;Tell that the record postion + mvi a,0 ;is the first record + jmp write$ran + ; +prl$patch: + mvi a,2 ;Tell that the record postion + jmp write$ran ;is the third record + ; +write$ran: ;This routine writes a record + sta fcb+33 + lxi h,00 + shld fcb+34 + mvi c,writerf ;to the file in the FCB + lxi d,fcb ;at the record position found + call bdos ;at FCB+33 + cpi 0 ;And the data to be written + rz ;is found from the BUFF+128(80h) + cpi 255 + jz phys$err ;jump if physical error + jmp quit$ptch + ; + ;******************************** + ;* SUBROUTINES + ;******************************** +set$dma: + lxi d,buff ;This routine set the DMA +set$dma2: + mvi c,dmaf + call bdos + ret + ; +read$buff: ;this routine reads a block + mvi c,readf ;from a file and places it into + lxi d,fcb ;memory + call bdos + ret + ; +perror: ;print 'ERROR :' + lxi d,err$mess + ; +print: ;this routine prints a string + mvi c,pstring ;pointed by registers 'DE' + call bdos ;until a '$' is found + ret + ; +pbyte: ;this routine prints the + mov e,a ;'ASCII' character found +pbyte2: ;in register 'E' + mvi c,conout + call bdos + ret + ; +displayit: ;this routine displays + shld keeph ;the invalid patch number + sta keepa ;that was inputed + mov a,m + cpi ' ' + rz + call pbyte + lhld keeph + lda keepa + inx h + dcr a + jnz displayit + rz + ; +displayit2: ;this routine displays + shld keeph ;the invalid filespec + sta keepa ;when an ERROR occurs + mov e,m + call pbyte2 + lhld keeph + lda keepa + inx h + dcr a + jnz displayit2 + ret + ; +disp$num: + call print ;print string pointed earlier + lhld number + mov a,l + call pbyte + lhld number + mov a,h + cpi ' ' + rz + call pbyte + ret + ; +disp$file: ;this routine displays the file + lxi h,fcb+1 ;name and spec. found in the FCB + mvi a,8 ;(5dhex) + call displayit + mvi e,'.' + call pbyte2 + lxi h,fcb+9 + mvi a,3 + call displayit + ret + ; +disp$drv: + call print + lda fcb ;get the current logged on drive + cpi 0 ;see if it is drive 'A' + cz chngdrv ;if so change the number + adi 040h ;make the number ASCII + call pbyte ;display it + mvi e,':' + call pbyte2 + ret + ; +chngdrv: + inr a ;This routine adds 1 to the drive + ret ;number so it can be displayed + ; +disp$ct: ;This routine is called + lda keepe ;every time a bit is found + cpi 10 ;on in the 'READ' routine + jnc disp$ct2 ;and displays the current + adi 030h ;patch according to what + call pbyte ;bit is on + mvi e,' ' + call pbyte2 + ret +disp$ct2: + lda ct ;current decimal count + ani 0fh ;get rid of the high nibble + sta lowdig ;store the lower + lda ct + ani 0f0h ;get rid of the low nibble + rrc + rrc + rrc + rrc ;rotate four times + adi 030h ;make it an ASCII character + cpi '0' ;if character =0 then skip + jz disp$ct3 ;the display routine + call pbyte ;print the byte +disp$ct3: + lda lowdig ;get the second digit + adi 030h ;make it an ASCII character + call pbyte + mvi e,' ' ;print a space + call pbyte2 + ret + ; +no$com: ;this routine tells the user + lda type ;that the file was not the + cpi 3 ;proper file type and displays + rc ;the file type the user + call perror + lxi d,ncom$mess ;inputed + call print + lxi h,spec + mvi a,3 + call displayit2 + lxi d,pos$type + jmp pr$stop + ; +no$patches: ;this routine tells the user + lxi d,none$mess ;that no patches have been + jmp pr$stop ;made for the file + ; +wrng$ser: ;this routine tells the user + call perror + lxi d,ser$mess ;that the serial # does not + jmp pr$stop ;match + ; +wrngver: ;this routine informs the user + call perror ;that the wrong version of CP/M + lxi d,ver$mess ;is being used + jmp pr$stop + ; +wrng$pass: ;this routine tells the user + call perror + lxi d,pass$mess ;that the inputed password + call print ;was false + lxi h,buf+2 + mvi a,8 + call displayit2 + jmp stop + ; +no$file: ;this routine tells the user + call perror + lxi d,nf$mess ;that the file was not found + call print ;and it gives the name of the + lda fcb+1 ;file + cpi ' ' + jz stop + call disp$file + lxi d,drv$mess + call disp$drv + jmp stop + ; +not$num: ;this routine tells the user + call perror + lxi d,nonum$mess ;that the inputed number to patch + call print ;is illegal + lxi h,06dh + mvi a,5 + call displayit + lxi d,pos$num + jmp pr$stop + ; +quit$ptch: ;This routine tells the user + lxi d,not$ptchd ;that the patch was not installed + jmp pr$stop + ; +disk$ro: ;This routine tells the user + lxi d,cr$lf ;that the disk is Read/Only + call print + call perror + lxi d,drive$mess + call disp$drv + lxi d,ro$mess + call print + jmp stop + ; +file$ro: ;This routine tells the user that + lxi d,cr$lf ;the file he/she is trying to + call print ;Patch is Read/Only + call perror + call disp$file + lxi d,ro$mess + jmp pr$stop + ; +bad$drive: + call perror + lxi d,baddrv$mess + call print + lda fcb + adi 040h + call pbyte + mvi e,':' + call pbyte2 + jmp stop + ; +phys$err: ;This routine tells the user + mov a,h ;that when performing the + cpi 2 ;write routine a permanent error + jz disk$ro ;was detected + cpi 3 + jz file$ro + jmp quit$ptch + ; +pr$stop: + call print + jmp stop + ; +stop: ;this routine ends the program + lxi d,cr$lf$lf + call print + mvi c,return + call bdos ;return to CCP + ; + ;******************************** + ;* Program Calling Routine + ;******************************** +begin: + lxi sp,stack ;set stack to 'STACK' + call init ;initialize + call check$file ;check if file in the FCB + call check$spec ;check if .COM inplied + call check$type ;check file type +begin2: + call check$rw ;check if 'READ' or 'WRITE' + call get$num ;get/change inputed number + call open$file ;open the file + call check$ser ;check serial number + call branch ;branch too READ or WRITE + call stop ;stop program + ; + ;******************************** + ;* CONSOLE MESSAGES TO USER + ;******************************** + ;* INTRO MESSAGE * +intro$mess: db cr,lf,'CP/M 3 PATCH - Version 3.0$' + ;* ERROR MESSAGES * +err$mess: db cr,lf,'ERROR: $' +ver$mess: db 'PATCH requires CP/M 3$' +ncom$mess: db 'Invalid file type: .$' +ser$mess: db 'Serial number mismatch$' +nf$mess: db 'No file: $' +pass$mess: db 'False password: $' +nonum$mess: db 'Invalid patch number: $' +drive$mess: db 'Drive $' +ro$mess: db ' is R/O$' +drv$mess: db ' on $' +baddrv$mess: db 'Illegal drive: $' + ;* QUESTIONS * +file$prmt$mess: db cr,lf,'Enter File: $' +quest: db cr,lf,'Enter Password: $' +instl$mess: db cr,lf,'Do you want to indicate that patch $' + ;* STATUS MESSAGES * +pos$type: db cr,lf,'Valid file types: COM or PRL$' +pos$num: db cr,lf,'Valid patch numbers: 1-32$' +crpatc$mess: db cr,lf,'Current patches for $' +less$mess: db cr,lf,'WARNING: Patches greater than $' +less2$mess: db cr,lf,' exist for $' +has$mess: db cr,lf,' has been installed$' +alread$mess: db ' already exists for $' +alread$mess2: db cr,lf,'Patch $' +none$mess: db 'None$' +betw$mess: db ' for $' +ok$mess: db cr,lf,lf,'Patch installed$' +not$ptchd: db cr,lf,lf,'Patch not installed$' +cr$lf: db cr,lf,'$' +cr$lf$lf: db cr,lf,lf,'$' +col$cr$lf$sp: db ':',cr,lf,' $' + ; + ;******************************** + ;* VARIABLE AND DATA STORAGE AREA + ;******************************** +keepa: db 0 ;Storage for 'ACC' +keepe: db 0 ;Storage for 'E' +keepd: db 0 ;Storage for 'D' +keeph: dw 0 ;Storage for 'HL' +file$buff: db 32,32,32,32,32,32 ;File Buffer for default + db 32,32,32,32,32,32 + db 32,32,32,32,32,32,32,32 +tpasswd: db 0 ;'Tried Password' Flag +len: db 0 ;Length of password input +type: db 255 ;File type (.COM,. PRL or .SPR) +rw: db 0 ;'READ/WRITE' flag +hpatch: db 0 ;highest patch +number: dw 00 ;Inputed (ASCII) number +patch1: dw 00 ;'PATCH' bit map storage area +patch2: dw 00 ;'PATCH' bit map storage area +num: db 0 ;Third number of input by user +ct: db 0 ;Actual 'PATCHES' after rotate (dec) +numtwo: db 0 ;Input # -30h +val: db 0 ;Actual input value after multiply +answer: ds 3 ;Storage for input to question +lowdig: ds 1 ;Storage for lower digit to display +bit$pos: db 0 ;Position of bit (0-7) +byte$pos: db 0 ;Postion of byte (0-3) +patch$pos: dw 0 ;Holds address of patch byte +com$table: db 'COM' ;These tables are used to +prl$table: db 'PRL' ; compare file types in +ser$table: @BDATE ;[JCE] DRI patch 4, compare the date +table: db 1,2,4,8,16,32,64,128 ;This table is for bit manipulation + ds 16 ;Stack area +stack: + ds 2 +buff: ds 128 ;Buffer (holds one record;128 bytes) + \ No newline at end of file diff --git a/software/CPM/cpm3/pip.plm b/software/CPM/cpm3/pip.plm new file mode 100644 index 0000000..44f1033 --- /dev/null +++ b/software/CPM/cpm3/pip.plm @@ -0,0 +1,1927 @@ +$title('PERIPHERAL INTERCHANGE PROGRAM') +PIPMOD: + DO; +/* P E R I P H E R A L I N T E R C H A N G E P R O G R A M + + COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982 + DIGITAL RESEARCH + BOX 579 + PACIFIC GROVE, CA + 93950 + + Revised: + 17 Jan 80 by Thomas Rolander (MP/M 1.1) + 05 Oct 81 by Ray Pedrizetti (MP/M-86 2.0) + 18 Dec 81 by Ray Pedrizetti (CP/M-86 1.1) + 29 Jun 82 by Ray Pedrizetti (CCP/M-86 3.0) + 26 May 1998 John Elliott DRI patch 6 */ + +/* Command lines used for CMD file generation */ + +/* (on VAX) + asm86 scd1.a86 + asm86 inpout.a86 + plm86 pip.plm debug xref optimize(3) + link86 scd1.obj,inpout.obj,pip.obj, to pip.lnk + loc86 pip.lnk od(sm(code,dats,data,const,stack)) - + ad(sm(code(0), dats(10000h))) ss(stack(+32)) to pip. + h86 pip + + (on a micro) + vax pip.h86 $fans + gencmd pip data[b1000 m280 xfff] + + * note the beginning of the data segment will change when + * the program is changed. see the 'MP2' file generated + * by LOC86. the constants are last to force hex generation + */ + + /* Compiler Directives */ +/** $set (mpm) **/ +/** $reset (cpm3) **/ +/** $cond **/ + +declare /* resets stack for error handling */ + reset label external; + +DECLARE + MAXB ADDRESS EXTERNAL, /* ADDR FIELD OF JMP BDOS */ + FCB (33) BYTE EXTERNAL, /* DEFAULT FILE CONTROL BLOCK */ + BUFF(128)BYTE EXTERNAL; /* DEFAULT BUFFER */ + +declare + retry byte initial(0); /* true if error has occured */ + +OUTD: PROCEDURE(B) external; + DECLARE B BYTE; + /* SEND B TO OUT: DEVICE */ + END OUTD; + +INPD: PROCEDURE BYTE external; + END INPD; + +MON1: PROCEDURE(F,A) EXTERNAL; + DECLARE F BYTE, + A ADDRESS; + END MON1; + +MON2: PROCEDURE(F,A) BYTE EXTERNAL; + DECLARE F BYTE, + A ADDRESS; + END MON2; + +MON3: PROCEDURE(F,A) ADDRESS EXTERNAL; + DECLARE F BYTE, + A ADDRESS; + END MON3; + + +plm: procedure public; + +DECLARE +/** $if mpm **/ + VERSION LITERALLY '0031H', /* REQUIRED FOR BDOS 3.1 OPERATION */ +/** $else **/ +/** $endif **/ + + ENDFILE LITERALLY '1AH'; /* END OF FILE MARK */ + +DECLARE COPYRIGHT(*) BYTE DATA ( +/** $if cpm3 **/ + ' (12/06/82) CP/M 3 PIP VERS 3.0 '); +/** $else **/ +/** $endif **/ + + + /* LITERAL DECLARATIONS */ +DECLARE + LIT LITERALLY 'LITERALLY', + LPP LIT '60', /* LINES PER PAGE */ + TAB LIT '09H', /* HORIZONTAL TAB */ + FF LIT '0CH', /* FORM FEED */ + LA LIT '05FH', /* LEFT ARROW */ + LB LIT '05BH', /* LEFT BRACKET */ + RB LIT '05DH', /* RIGHT BRACKET */ + + FSIZE LIT '33', + FRSIZE LIT '36', /* SIZE OF RANDOM FCB */ + NSIZE LIT '8', + FNSIZE LIT '11', + FEXT LIT '9', + FEXTL LIT '3', + + /* scanner return type code */ + outt LIT '0', /* output device */ + PRNT LIT '1', /* PRINTER */ + LSTT LIT '2', /* list device */ + axot lit '3', /* auxilary output device */ + FILE LIT '4', /* file type */ + auxt lit '5', /* auxilary input/output device */ + CONS LIT '6', /* CONSOLE */ + axit LIT '7', /* auxilary input device */ + inpt lit '8', /* input device */ + NULT LIT '9', /* nul characters */ + EOFT LIT '10', /* EOF character */ + ERR LIT '11', /* error type */ + SPECL LIT '12', /* special character */ + DISKNAME LIT '13'; /* diskname letter */ + +DECLARE + SEARFCB LIT 'FCB'; /* SEARCH FCB IN MULTI COPY */ + +DECLARE + TRUE LIT '1', + FALSE LIT '0', + FOREVER LIT 'WHILE TRUE', + cntrlc lit '3', + CR LIT '13', + LF LIT '10', + WHAT LIT '63'; + +/** $if mpm **/ +declare + maxmcnt lit '128', /* maximum multi sector count */ + maxmbuf lit '16384'; /* maximum multi sector buffer size */ +/** $endif **/ + +DECLARE + COLUMN BYTE, /* COLUMN COUNT FOR PRINTER TABS */ + LINENO BYTE, /* LINE WITHIN PAGE */ + FEEDBASE BYTE, /* USED TO FEED SEARCH CHARACTERS */ + FEEDLEN BYTE, /* LENGTH OF FEED STRING */ + MATCHLEN BYTE, /* USED IN MATCHING STRINGS */ + QUITLEN BYTE, /* USED TO TERMINATE QUIT COMMAND */ + CDISK BYTE, /* CURRENT DISK */ + SBLEN ADDRESS, /* SOURCE BUFFER LENGTH */ + DBLEN ADDRESS, /* DEST BUFFER LENGTH */ + tblen address, /* temp buffer length */ + SBASE ADDRESS, /* SOURCE BUFFER BASE */ + + /* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION + 1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */ + DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */ + SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */ + + /* source fcb, password and password mode */ + source structure ( + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ), + + /* temporary destination fcb, password and password mode */ + dest structure ( + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ), + + /* original destination fcb, password and password mode */ + odest structure ( + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ), + + filsize(3) byte, /* file size random record number */ + + DESTR ADDRESS AT(.DEST.FCB(33)), /* RANDOM RECORD POSITION */ + SOURCER ADDRESS AT(.SOURCE.FCB(33)), /* RANDOM RECORD POSITION */ + DESTR2 BYTE AT(.DEST.FCB(35)), /* RANDOM RECORD POSITION R2 */ + SOURCER2 BYTE AT(.SOURCE.FCB(35)), /* RANDOM RECORD POSITION R2 */ + + extsave byte, /* temp extent byte for bdos bug */ + + nsbuf address, /* next source buffer */ +/** $if mpm **/ + bufsize address, /* multsect buffer size */ + mseccnt byte, /* last multi sector count value */ +/** $endif **/ + NSOURCE ADDRESS, /* NEXT SOURCE CHARACTER */ + NDEST ADDRESS; /* NEXT DESTINATION CHARACTER */ + +DECLARE + fastcopy byte, /* true if copy directly to dbuf */ + dblbuf byte, /* true if both source and dest buffer used */ + concat byte, /* true if concatination command */ + ambig byte, /* true if file is ambig type */ + dfile byte, /* true if dest is file type */ + sfile byte, /* true if source is file type */ + made byte, /* true if destination file already made */ + opened byte, /* true if source file open */ + endofsrc byte, /* true if end of source file */ + nendcmd byte, /* true if not end of command tail */ + insparc byte, /* true if in middle of sparce file */ + sparfil byte, /* true if sparce file being copied */ + MULTCOM BYTE, /* true if processing multiple commands */ + PUTNUM BYTE, /* SET WHEN READY FOR NEXT LINE NUM */ + CONCNT BYTE, /* COUNTER FOR CONSOLE READY CHECK */ + CHAR BYTE, /* LAST CHARACTER SCANNED */ + FLEN BYTE; /* FILE NAME LENGTH */ + +declare + f1 byte, /* f1 user attribute flag */ + f2 byte, /* f2 user attribute flag */ + f3 byte, /* f3 user attribute flag */ + f4 byte, /* f4 user attribute flag */ + ro byte, /* read only attribute flag */ + sys byte, /* system attribute flag */ +/** $if mpm **/ + exten byte, /* extention error code */ + odcnt byte, /* saves dcnt for open dest file */ + eretry byte, /* error return flag */ +/** $endif **/ + dcnt byte; /* error code or directory code */ + + +DECLARE CBUFF(130) BYTE, /* COMMAND BUFFER */ + MAXLEN BYTE AT (.CBUFF(0)), /* MAX BUFFER LENGTH */ + COMLEN BYTE AT (.CBUFF(1)), /* CURRENT LENGTH */ + COMBUFF(128) BYTE AT (.CBUFF(2)), /* COMMAND BUFFER CONTENTS */ + CBP BYTE; /* COMMAND BUFFER POINTER */ + +DECLARE + CUSER BYTE, /* CURRENT USER NUMBER */ + last$user byte; + +DECLARE /* CONTROL TOGGLE VECTOR */ + CONT(26) BYTE, /* ONE FOR EACH ALPHABETIC */ + /* 00 01 02 03 04 05 06 07 08 09 10 11 12 13 + A B C D E F G H I J K L M N + 14 15 16 17 18 19 20 21 22 23 24 25 + O P Q R S T U V W X Y Z */ + archiv byte at(.cont(0)), /* file archive */ + confrm byte at(.cont(2)), /* confirm copy */ + DELET BYTE AT(.CONT(3)), /* DELETE CHARACTERS */ + ECHO BYTE AT(.CONT(4)), /* ECHO CONSOLE CHARACTERS */ + FORMF BYTE AT(.CONT(5)), /* FORM FILTER */ + GETU BYTE AT(.CONT(6)), /* GET FILE, USER # */ + HEXT BYTE AT(.CONT(7)), /* HEX FILE TRANSFER */ + IGNOR BYTE AT(.CONT(8)), /* IGNORE :00 RECORD ON FILE */ + kilds byte at(.cont(10)), /* kill filename display */ + LOWER BYTE AT(.CONT(11)), /* TRANSLATE TO LOWER CASE */ + NUMB BYTE AT(.CONT(13)), /* NUMBER OUTPUT LINES */ + OBJ BYTE AT(.CONT(14)), /* OBJECT FILE TRANSFER */ + PAGCNT BYTE AT(.CONT(15)), /* PAGE LENGTH */ + QUITS BYTE AT(.CONT(16)), /* QUIT COPY */ + RSYS BYTE AT(.CONT(17)), /* READ SYSTEM FILES */ + STARTS BYTE AT(.CONT(18)), /* START COPY */ + TABS BYTE AT(.CONT(19)), /* TAB SET */ + UPPER BYTE AT(.CONT(20)), /* UPPER CASE TRANSLATE */ + VERIF BYTE AT(.CONT(21)), /* VERIFY EQUAL FILES ONLY */ + WRROF BYTE AT(.CONT(22)), /* WRITE TO R/O FILE */ + ZEROP BYTE AT(.CONT(25)); /* ZERO PARITY ON INPUT */ + +DECLARE ZEROSUP BYTE, /* ZERO SUPPRESSION */ + (C3,C2,C1) BYTE; /* LINE COUNT ON PRINTER */ + + +/** $if mpm **/ +retcodes: procedure(a); + declare a address; + dcnt = low(a); + exten = high(a); + end retcodes; +/** $endif **/ + +BOOT: PROCEDURE; + /* SYSTEM REBOOT */ + CALL MON1(0,0); + END BOOT; + + +RDCHAR: PROCEDURE BYTE; + /* READ CONSOLE CHARACTER */ + RETURN MON2(1,0); + END RDCHAR; + +PRINTCHAR: PROCEDURE(CHAR); + DECLARE CHAR BYTE; + CALL MON1(2,CHAR AND 7FH); + END PRINTCHAR; + +CRLF: PROCEDURE; + CALL PRINTCHAR(CR); + CALL PRINTCHAR(LF); + END CRLF; + +printx: procedure(a); + declare a address; + call mon1(9,a); + end printx; + +PRINT: PROCEDURE(A); + DECLARE A ADDRESS; + /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE + NEXT DOLLAR SIGN IS ENCOUNTERED */ + CALL CRLF; + CALL printx(A); + END PRINT; + +RDCOM: PROCEDURE; + /* READ INTO COMMAND BUFFER */ + MAXLEN = 128; + CALL MON1(10,.MAXLEN); + END RDCOM; + +CVERSION: PROCEDURE ADDRESS; + RETURN MON3(12,0); /* VERSION NUMBER */ + END CVERSION; + +SETDMA: PROCEDURE(A); + DECLARE A ADDRESS; + CALL MON1(26,A); + END SETDMA; + +/** $if mpm **/ +setpw: procedure(fcba); + declare fcba address; + declare fcbs based fcba structure ( + fcb(frsize) byte, + pwnam(nsize) byte ); + call setdma(.fcbs.pwnam(0)); + end setpw; +/** $endif **/ + +OPEN: PROCEDURE(fcba); + DECLARE fcba ADDRESS; + declare fcb based fcba (frsize) byte; +/** $if mpm **/ + CALL SETPW(fcba); + call retcodes(mon3(15,fcba)); +/** $else **/ +/** $endif **/ + if dcnt <> 255 and rol(fcb(8),1) then + do; call mon1(16,fcba); + dcnt = 255; +/** $if mpm **/ + exten = 0; +/** $endif **/ + end; + END OPEN; + +CLOSE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(16,FCB)); +/** $else **/ +/** $endif **/ + END CLOSE; + +SEARCH: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(17,FCB)); +/** $else **/ +/** $endif **/ + END SEARCH; + +SEARCHN: PROCEDURE; +/** $if mpm **/ + call retcodes(MON3(18,0)); +/** $else **/ +/** $endif **/ + END SEARCHN; + +DELETE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + CALL SETPW(FCB); + call retcodes(MON3(19,FCB)); +/** $else **/ +/** $endif **/ + END DELETE; + +DISKRD: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(20,FCB)); +/** $else **/ +/** $endif **/ + END DISKRD; + +DISKWRITE: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(21,FCB)); +/** $else **/ +/** $endif **/ + END DISKWRITE; + +MAKE: procedure(fcba); + declare fcba address; +/** $if mpm **/ + declare fcbs based fcba structure ( + fcb(frsize) byte, + pwnam(nsize) byte ); + if fcbs.pwnam(0) = 0 then /* zero if no password */ + fcbs.fcb(6) = fcbs.fcb(6) and 7fh; /* reset password attribute */ + else do; + fcbs.fcb(6) = fcbs.fcb(6) or 80h; /* set password attribute */ + call setdma(.fcbs.pwnam(0)); /* set password dma */ + end; + call retcodes(mon3(22,fcba)); +/** $else **/ +/** $endif **/ + END MAKE; + +RENAME: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + CALL SETPW(FCB); + call retcodes(MON3(23,FCB)) ; +/** $else **/ +/** $endif **/ + END RENAME; + +getdisk: procedure byte; + return mon2(25,0); + end getdisk; + +SETIND: PROCEDURE(FCB); + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(MON3(30,FCB)); +/** $else **/ +/** $endif **/ + END SETIND; + +GETUSER: PROCEDURE BYTE; + RETURN MON2(32,0FFH); + END GETUSER; + +SETUSER: PROCEDURE(USER); + DECLARE USER BYTE; + if last$user <> user then + CALL MON1(32,(last$user:=USER)); + END SETUSER; + +SETCUSER: PROCEDURE; + CALL SETUSER(CUSER); + END SETCUSER; + +setduser: procedure; + call setuser(odest.user); + end setduser; + +SETSUSER: PROCEDURE; + CALL SETUSER(source.user); + END SETSUSER; + +RD$RANDOM: PROCEDURE(FCB) BYTE; + DECLARE FCB ADDRESS; +/** $if mpm **/ + call retcodes(mon3(33,fcb)); +/** $else **/ +/** $endif **/ + return dcnt; + END RD$RANDOM; + +write$random: procedure(fcb) byte; + declare fcb address; +/** $if mpm **/ + call retcodes(mon3(34,fcb)); +/** $else **/ +/** $endif **/ + return dcnt; + end write$random; + +retfsize: procedure(fcb) byte; + declare fcb address; + return mon2(35,fcb); + end retfsize; + +SET$RANDOM: PROCEDURE(FCB); + DECLARE FCB ADDRESS; + /* SET RANDOM RECORD POSITION */ + CALL MON1(36,FCB); + END SET$RANDOM; + +/** $if mpm **/ +multsect: procedure(cnt); + declare cnt byte; + if mseccnt <> cnt then + call mon1(44,(mseccnt := cnt)); + end multsect; + +flushbuf: procedure; + call mon1(48, 0ffh); /* 0FFH = flush and discard buffers */ + end flushbuf; + +conatlst: procedure byte; + return mon2(161,0); + end conatlst; +/** $endif **/ + + +MOVE: PROCEDURE(S,D,N); + DECLARE (S,D) ADDRESS, N BYTE; + DECLARE A BASED S BYTE, B BASED D BYTE; + DO WHILE (N:=N-1) <> 255; + B = A; S = S+1; D = D+1; + END; + END MOVE; + + /* errtype error messages */ + declare er00(*) byte data ('DISK READ$'); + declare er01(*) byte data ('DISK WRITE$'); + declare er02(*) byte data ('VERIFY$'); + declare er03(*) byte data ('INVALID DESTINATION$'); + declare er04(*) byte data ('INVALID SOURCE$'); + declare er05(*) byte data ('USER ABORTED$'); + declare er06(*) byte data ('BAD PARAMETER$'); + declare er07(*) byte data ('INVALID USER NUMBER$'); + declare er08(*) byte data ('INVALID FORMAT$'); + declare er09(*) byte data ('HEX RECORD CHECKSUM$'); + declare er10(*) byte data ('FILE NOT FOUND$'); + declare er11(*) byte data ('START NOT FOUND$'); + declare er12(*) byte data ('QUIT NOT FOUND$'); + declare er13(*) byte data ('INVALID HEX DIGIT$'); + declare er14(*) byte data ('CLOSE FILE$'); + declare er15(*) byte data ('UNEXPECTED END OF HEX FILE$'); + declare er16(*) byte data ('INVALID SEPARATOR$'); + declare er17(*) byte data ('NO DIRECTORY SPACE$'); + declare er18(*) byte data ('INVALID FORMAT WITH SPARCE FILE$'); +/** $if mpm **/ + declare er19(*) byte data ('MAKE FILE$'); + declare er20(*) byte data ('OPEN FILE$'); + declare er21(*) byte data ('PRINTER BUSY$'); + declare er22(*) byte data ('CAN''T DELETE TEMP FILE$'); +/** $endif **/ + + declare errmsg(*) address data( + .er00,.er01,.er02,.er03,.er04, + .er05,.er06,.er07,.er08,.er09, + .er10,.er11,.er12,.er13,.er14, + .er15,.er16,.er17,.er18 +/** $if mpm **/ + ,.er19,.er20,.er21,.er22 +/** $endif **/ + ); + + declare sper00(*) byte data ('NO DIRECTORY SPACE$'); + declare sper01(*) byte data ('NO DATA BLOCK$'); + declare sper02(*) byte data ('CAN''T CLOSE CURRENT EXTENT$'); + declare sper03(*) byte data ('SEEK TO UNWRITTEN EXTENT$'); + declare sper05(*) byte data ('RANDOM RECORD OUT OF RANGE$'); + declare sper06(*) byte data ('RECORDS DON''T MATCH$'); + declare sper07(*) byte data ('RECORD LOCKED$'); + declare sper08(*) byte data ('INVALID FILENAME$'); + declare sper09(*) byte data ('FCB CHECKSUM$'); + + declare numspmsgs lit '10'; /* number of extended messages */ + declare special$msg(numspmsgs) address data( + .sper00,.sper01,.sper02,.sper03,.sper00, + .sper05,.sper06,.sper07,.sper08,.sper09); + +/** $if mpm **/ + /* extended error messages */ + declare ex00(*) byte data ('$'); /* NO MESSAGE */ + declare ex01(*) byte data ('NONRECOVERABLE$'); + declare ex02(*) byte data ('R/O DISK$'); + declare ex03(*) byte data ('R/O FILE$'); + declare ex04(*) byte data ('INVALID DISK SELECT$'); + declare ex05(*) byte data ('INCOMPATIBLE MODE$'); + declare ex07(*) byte data ('INVALID PASSWORD$'); + declare ex08(*) byte data ('ALREADY EXISTS$'); + declare ex10(*) byte data ('LIMIT EXCEEDED$'); + + declare nummsgs lit '11'; /* number of extended messages */ + declare extmsg(nummsgs) address data( + .ex00,.ex01,.ex02,.ex03,.ex04, + .ex05,.sper09,.ex07,.ex08,.sper08, + .ex10); +/** $endif **/ + +error$cleanup: procedure; +/** $if mpm **/ + call multsect(1); +/** $endif **/ + eretry = 0; /* initialize to no error retry */ + if opened then /* if source file opened */ + do; call setsuser; + call close(.source); + opened = false; + end; + if made then + do; call setduser; + call close(.dest); + call delete(.dest); /* delete destination scratch file */ + end; + /* Zero the command length in case this is a single command */ + comlen = 0; + retry = true; + call print(.('ERROR: $')); + end error$cleanup; + +error: procedure (errtype); + declare errtype byte; + + call error$cleanup; + call printx(errmsg(errtype)); + call crlf; + go to reset; + end error; + +xerror: procedure (funcno,fileadr); + declare temp byte, + i byte, + sdcnt byte, + sexten byte, + funcno byte, + fileadr address, + fcb based fileadr (fsize) byte; + + declare message$index$tbl(17) byte data + (2,18,13,15,9,3,10,20,14,10,22,17,19,0,1,0,1); + + sdcnt = dcnt; + sexten = exten; + call error$cleanup; + + if (funcno < 6) or (sdcnt <> 0ffh) then + sexten = 0; + else sexten = sexten and 0fh; + + call printx(errmsg(message$index$tbl(funcno))); + + if (funcno > 12) and (funcno < 17) and + (sdcnt <> 0ffh) and (sdcnt <= numspmsgs) then + do; call printchar(' '); + call printx(special$msg(sdcnt-1)); + sexten = 0; + end; + +/** $if mpm **/ + if sexten < nummsgs then + do; call printchar(' '); + call printx(extmsg(sexten)); + end; +/** $endif **/ + + call printx(.(' - $')); + if fileadr <> 0 then + do; call printchar('A' + fcb(0) - 1); + call printchar(':'); + do i = 1 to fnsize; + if (temp := fcb(i) and 07fh) <> ' ' then + do; if i = fext then call printchar('.'); + call printchar(temp); + end; + end; + end; + call crlf; + + if (sdcnt = 3) or (sdcnt = 4) or (sdcnt = 6) or (sdcnt = 8) then + eretry = ambig; + else + if (sexten = 3) or ((sexten > 4) and (sexten < 9)) or (sexten > 9) then + eretry = ambig; + + go to reset; + end xerror; + +FORMERR: PROCEDURE; + call error(8); /* invalid format */ + END FORMERR; + +CONBRK: PROCEDURE; + /* CHECK CONSOLE CHARACTER READY */ + if mon2(11,0) <> 0 then + if mon2(6,0fdh) = cntrlc then + call error(5); + END CONBRK; + +MAXSIZE: procedure byte; + /* three byte compare of random record field + returns true if source.fcb.ranrec >= filesize */ + + if (source.fcb(35) < filsize(2)) then + return false; + if (source.fcb(35) = filsize(2)) then + do; + if (source.fcb(34) < filsize(1)) then + return false; + if (source.fcb(34) = filsize(1)) then + do; + if (source.fcb(33) < filsize(0)) then + return false; + end; + end; + return true; + end maxsize; + +SETUPDEST: PROCEDURE; + call setduser; /* destination user */ +/** $if mpm **/ + call move(.odest,.dest,(frsize + nsize + 1)); /* save original dest */ +/** $else **/ +/** $endif **/ + /* MOVE THREE CHARACTER EXTENT INTO DEST FCB */ + CALL MOVE(.('$$$'),.DEST.FCB(FEXT),FEXTL); +/** $if mpm **/ + odest.fcb(6) = odest.fcb(6) or 80h; + call open(.odest); /* try to open destination file */ + odcnt = dcnt; /* and save error code */ + if odcnt <> 255 then + call close(.odest); + else if (exten and 0fh) <> 0 then /* file exists */ + call xerror(7,.odest); /* but can't open - error */ + + CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */ + if dcnt = 255 and exten <> 0 then + /* cant delete temp file */ + call xerror(10,.dest); + CALL MAKE(.DEST); /* CREATE A NEW ONE */ + IF DCNT = 255 THEN + if (exten and 0fh) = 0 then + call xerror(11,.dest); /* no directory space */ + else call xerror(12,.dest); /* make file error */ +/** $else **/ +/** $endif **/ + DEST.FCB(32) = 0; + made = true; + END SETUPDEST; + +SETUPSOURCE: PROCEDURE; + declare (i,j) byte; + CALL SETSUSER; /* SOURCE USER */ +/** $if mpm **/ + source.fcb(6) = source.fcb(6) or 80h; +/** $endif **/ + CALL OPEN(.SOURCE); /* open source */ + if dcnt <> 255 then + opened = true; + IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN + /* skip system file */ + DCNT = 255; + IF DCNT = 255 THEN +/** $if mpm **/ + if (exten and 0fh) = 0 then + call xerror(6,.source); /* file not found */ + else + call xerror(7,.source); /* open file error */ +/** $else **/ +/** $endif **/ + f1 = source.fcb(1) and 80h; /* save file atributes */ + f2 = source.fcb(2) and 80h; + f3 = source.fcb(3) and 80h; + f4 = source.fcb(4) and 80h; + ro = source.fcb(9) and 80h; + sys = source.fcb(10) and 80h; + dcnt = retfsize(.source); + call move(.source.fcb(33),.filsize,3); + SOURCE.FCB(32) = 0; + source.fcb(33),source.fcb(34),source.fcb(35) = 0; + /* cause immediate read with no preceding write */ + NSOURCE = 0ffffh; + END SETUPSOURCE; + +WRITEDEST: PROCEDURE; + /* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION + NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */ + DECLARE (J,DATAOK) BYTE, + (tdest,n) address; + if not made then call setupdest; + if (n := ndest and 0ff80h) = 0 then return; + tdest = 0; + call setduser; /* destination user */ + if (sparfil := (sparfil or insparc)) then + /* set up fcb from random record no. */ + do; +/** $if mpm **/ + call multsect(1); +/** $endif **/ + CALL SETDMA(.dbuff(tdest)); + if write$random(.dest) <> 0 then + call xerror(16,.dest); /* DISK WRITE ERROR */ + end; + else + CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */ +/** $if mpm **/ + if fastcopy then + do; bufsize = maxmbuf; + call multsect(maxmcnt); + end; + else + do; bufsize = 128; + call multsect(1); + end; +/** $endif **/ + + do while n - tdest > 127; +/** $if mpm **/ + if fastcopy and (n - tdest < maxmbuf) then + do; bufsize = n - tdest; + call multsect(low(shr(bufsize,7))); + end; +/** $endif **/ + /* SET DMA ADDRESS TO NEXT BUFFER */ + CALL SETDMA(.dbuff(tdest)); + call diskwrite(.dest); + IF dcnt <> 0 THEN + call xerror(14,.dest); /* DISK WRITE ERROR */ +/** $if mpm **/ + tdest = tdest + bufsize; +/** $else **/ +/** $endif **/ + END; + + IF VERIF THEN /* VERIFY DATA WRITTEN OK */ + DO; + call flushbuf; + tdest = 0; +/** $if mpm **/ + call multsect(1); +/** $endif **/ + CALL SETDMA(.BUFF); /* FOR COMPARE */ + do while tdest < n; + DATAOK = (RDRANDOM(.DEST) = 0); + if (DESTR := DESTR + 1) = 0 then /* 3 byte inc for */ + destr2 = destr2 + 1; /* next random record */ + J = 0; + /* PERFORM COMPARISON */ + DO WHILE DATAOK AND J < 80H; + DATAOK = (BUFF(J) = DBUFF(tdest+J)); + J = J + 1; + END; + tdest = tdest + 128; + IF NOT DATAOK THEN + call xerror(0,.dest); /* VERIFY ERROR */ + END; + call diskrd(.dest); + /* NOW READY TO CONTINUE THE WRITE OPERATION */ + END; + CALL SETRANDOM(.DEST); /* set base record for sparce copy */ + call move(.dbuff(tdest),.dbuff(0),low(ndest := ndest - tdest)); + END WRITEDEST; + +FILLSOURCE: PROCEDURE; + /* FILL THE SOURCE BUFFER */ + call conbrk; +/** $if mpm **/ + if fastcopy then + do; bufsize = maxmbuf; + call multsect(maxmcnt); + end; + else do; + bufsize = 128; + call multsect(1); + end; +/** $endif **/ + CALL SETSUSER; /* SOURCE USER NUMBER SET */ + nsource = nsbuf; + do while sblen - nsbuf > 127; + if fastcopy and (sblen - nsbuf < maxmbuf) then + do; bufsize = (sblen - nsbuf) and 0ff80h; + call multsect(low(shr(bufsize,7))); + end; + /* SET DMA ADDRESS TO NEXT BUFFER POSIITION */ + CALL SETDMA(.SBUFF(nsbuf)); + extsave = source.fcb(12); /* save extent field */ + call diskrd(.source); + IF dcnt <> 0 THEN + DO; IF dcnt <> 1 THEN + call xerror(13,.source); /* DISK READ ERROR */ + /* END - OF - FILE */ +/** $if mpm **/ + if fastcopy then /* add no. sectors copied */ + nsbuf = nsbuf + shl(double(exten),7); + /* nsbuf = nsbuf + shl(double(exten and 0f0h),3); */ +/** $endif **/ + /* check boundry condition for bug in bdos and correct */ + if (source.fcb(12) <> extsave) and (source.fcb(32) = 80h) then + source.fcb(32) = 0; /* zero current record */ + call set$random(.source); + if (insparc := not maxsize) then + do; + if concat or (not fastcopy) then + /* invalid format with sparce file */ + call xerror(1,.source); + end; + else + do; + call close(.source); + opened = false; + end; + endofsrc = true; /* set end of source file */ + SBUFF(nsbuf) = ENDFILE; return; + END; + ELSE +/** $if mpm **/ + nsbuf = nsbuf + bufsize; +/** $else **/ +/** $endif **/ + END; + END FILLSOURCE; + +PUTDCHAR: PROCEDURE(B); + DECLARE B BYTE; + /* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY ODEST.TYPE */ + IF B >= ' ' THEN + DO; COLUMN = COLUMN + 1; + IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */ + DO; IF COLUMN > DELET THEN RETURN; + END; + END; + if echo then call mon1(2,b); /* echo to console */ + do case odest.type; + /* CASE 0 IS OUT */ + CALL OUTD(B); + /* CASE 1 IS PRN, TABS EXPANDED, LINES LISTED */ + call mon1(5,b); + /* CASE 2 IS LST */ + CALL MON1(5,B); + /* CASE 3 IS axo */ +axocase: +/** $if not mpm **/ + CALL MON1(4,B); +/** $else **/ +/** $endif **/ + /* CASE 4 IS DESTINATION FILE */ + DO; + IF NDEST >= DBLEN THEN CALL WRITEDEST; + DBUFF(NDEST) = B; + NDEST = NDEST+1; + END; + /* CASE 5 IS AUX */ + goto axocase; + /* CASE 6 IS CON */ + CALL MON1(2,B); + END; /* of case */ + END PUTDCHAR; + +PUTDESTC: PROCEDURE(B); + DECLARE (B,I) BYTE; + /* WRITE DESTINATION CHARACTER, TAB EXPANSION */ + IF B <> TAB THEN CALL PUTDCHAR(B); + ELSE IF TABS = 0 THEN CALL PUTDCHAR(B); + ELSE /* B IS TAB CHAR, TABS > 0 */ + DO; I = COLUMN; + DO WHILE I >= TABS; + I = I - TABS; + END; + I = TABS - I; + DO WHILE I > 0; + I = I - 1; + CALL PUTDCHAR(' '); + END; + END; + IF B = CR THEN COLUMN = 0; + END PUTDESTC; + +PRINT1: PROCEDURE(B); + DECLARE B BYTE; + IF (ZEROSUP := ZEROSUP AND B = 0) THEN + CALL PUTDESTC(' '); + ELSE + CALL PUTDESTC('0'+B); + END PRINT1; + +PRINTDIG: PROCEDURE(D); + DECLARE D BYTE; + CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B); + END PRINTDIG; + +NEWLINE: PROCEDURE; + DECLARE ONE BYTE; + ONE = 1; + ZEROSUP = (NUMB = 1); + C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0); + CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1); + IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */ + DO; CALL PUTDESTC(':'); CALL PUTDESTC(' '); + END; + ELSE + CALL PUTDESTC(TAB); + END NEWLINE; + +PUTDEST: PROCEDURE(B); + DECLARE (I,B) BYTE; + /* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */ + IF FORMF THEN /* SKIP FORM FEEDS */ + DO; IF B = FF THEN RETURN; + END; + IF PUTNUM THEN /* END OF LINE OR START OF FILE */ + DO; + IF (B <> FF) and (b <> endfile) THEN + DO; /* NOT FORM FEED or end of file */ + IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */ + DO; IF I=1 THEN I=LPP; + IF (LINENO := LINENO + 1) >= I THEN + DO; LINENO = 0; /* NEW PAGE */ + CALL PUTDESTC(FF); + END; + END; + IF NUMB > 0 THEN + CALL NEWLINE; + PUTNUM = FALSE; + END; + END; + IF B = FF THEN LINENO = 0; + CALL PUTDESTC(B); + IF B = LF THEN PUTNUM = TRUE; + END PUTDEST; + + +UTRAN: PROCEDURE(B) BYTE; + DECLARE B BYTE; + /* TRANSLATE ALPHA TO UPPER CASE */ + IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */ + B = B AND 101$1111B; /* TO UPPER CASE */ + RETURN B; + END UTRAN; + +LTRAN: PROCEDURE(B) BYTE; + DECLARE B BYTE; + /* TRANSLATE TO LOWER CASE ALPHA */ + IF B >= 'A' AND B <= 'Z' THEN + B = B OR 10$0000B; /* TO LOWER */ + RETURN B; + END LTRAN; + +GETSOURCEC: PROCEDURE BYTE; + /* READ NEXT SOURCE CHARACTER */ + DECLARE (B,CONCHK) BYTE; + + CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */ + DO CASE source.type; + /* CASE 0 IS out */ + go to notsource; + /* CASE 1 IS prn */ + go to notsource; + /* CASE 2 IS lst */ + notsource: + call error(4); /* INVALID SOURCE */ + /* CASE 3 IS axo */ + go to notsource; + /* CASE 4 IS SOURCE FILE */ + DO; + IF NSOURCE >= SBLEN THEN + do; if dblbuf or (not dfile) then + nsbuf = 0; + else if (nsource <> 0ffffh) then + do; call writedest; + nsbuf = ndest; + end; + CALL FILLSOURCE; + end; + B = SBUFF(NSOURCE); + NSOURCE = NSOURCE + 1; + END; + /* CASE 5 IS AUX */ + goto axicase; + /* CASE 6 IS CON */ + DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */ + B = MON2(1,0); + END; + /* CASE 7 IS axi */ +axicase: +/** $if not mpm **/ + B = MON2(3,0) AND 7FH; +/** $else **/ +/** $endif **/ + /* CASE 7 IS INP */ + B = INPD; + END; /* OF CASES */ + + IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */ + DO; + IF obj THEN /* SOURCE IS AN OBJECT FILE */ + CONCHK = ((CONCNT := CONCNT + 1) = 0); + ELSE /* ASCII */ + CONCHK = (B = LF); + IF CONCHK THEN + DO; + call CONBRK; + END; + END; + IF ZEROP THEN B = B AND 7FH; + IF UPPER THEN RETURN UTRAN(B); + IF LOWER THEN RETURN LTRAN(B); + RETURN B; + END GETSOURCEC; + +GETSOURCE: PROCEDURE BYTE; + /* GET NEXT SOURCE CHARACTER */ + DECLARE CHAR BYTE; + MATCH: PROCEDURE(B) BYTE; + /* MATCH START AND QUIT STRINGS */ + DECLARE (B,C) BYTE; + IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */ + DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */ + RETURN TRUE; + END; + IF C = CHAR THEN MATCHLEN = MATCHLEN + 1; + ELSE + MATCHLEN = 0; /* NO MATCH */ + RETURN FALSE; + END MATCH; + + IF QUITLEN > 0 THEN + DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF; + RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */ + END; + DO FOREVER; /* LOOKING FOR START */ + IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */ + DO; FEEDLEN = FEEDLEN - 1; + CHAR = COMBUFF(FEEDBASE); + FEEDBASE = FEEDBASE + 1; + RETURN CHAR; + END; + IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE; + IF STARTS > 0 THEN /* LOOKING FOR START STRING */ + DO; IF MATCH(STARTS) THEN + DO; FEEDBASE = STARTS; STARTS = 0; + FEEDLEN = MATCHLEN + 1; + matchlen = 0; + END; /* OTHERWISE NO MATCH, SKIP CHARACTER */ + END; + ELSE IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */ + DO; IF MATCH(QUITS) THEN + DO; QUITS = 0; QUITLEN = 2; + /* SUBSEQUENTLY RETURN CR, LF, ENDFILE */ + RETURN CR; + END; + RETURN CHAR; + END; + ELSE + RETURN CHAR; + END; /* OF DO FOREVER */ + END GETSOURCE; + +RD$EOF: PROCEDURE BYTE; + /* RETURN TRUE IF END OF FILE */ + CHAR = GETSOURCE; + IF obj THEN RETURN (endofsrc and (nsource > nsbuf)); + RETURN (CHAR = ENDFILE); + END RD$EOF; + + +HEXRECORD: PROCEDURE; + DECLARE (h, hbuf, RL, CS, RT) BYTE, + zerorec byte, /* true if last record had length of zero */ + LDA ADDRESS; /* LOAD ADDRESS WHICH FOLLOWS : */ + + ckhex: procedure byte; + IF H - '0' <= 9 THEN + RETURN H-'0'; + IF H - 'A' > 5 THEN + CALL xerror(2,.source); /* invalid hex digit */ + RETURN H - 'A' + 10; + end ckhex; + + rdhex: procedure byte; + call putdest(h := getsource); + return ckhex; + end rdhex; + + RDCS: PROCEDURE BYTE; + /* READ BYTE WITH CHECKSUM */ + RETURN CS := CS + (SHL(RDHEX,4) OR RDHEX); + END RDCS; + + RDADDR: PROCEDURE ADDRESS; + /* READ DOUBLE BYTE WITH CHECKSUM */ + RETURN SHL(DOUBLE(RDCS),8) OR RDCS; + END RDADDR; + + /* READ HEX FILE AND CHECK EACH RECORD + FOR VALID DIGITS, AND PROPER CHECKSUM */ + zerorec = false; + /* READ NEXT RECORD */ + h = getsource; + do forever; + /* SCAN FOR THE ':' */ + DO WHILE h <> ':'; + IF (h = ENDFILE) THEN + do; if zerorec then return; + CALL xerror(3,.source); /* unexpected end of hex file */ + end; + call putdest(h); + h = getsource; + END; + + /* ':' FOUND */ + /* check for end of hex record */ + h = getsource; + rl = shl(ckhex,4); + hbuf = h; h = getsource; + rl = rl or ckhex; + if (rl = 0) then zerorec = true; + else zerorec = false; + if (zerorec and ignor) then + do while (h <> ':') and (h <> endfile); + h = getsource; + end; + else do; call putdest(':'); + call putdest(hbuf); + call putdest(h); + cs = rl; + LDA = RDADDR; /* LOAD ADDRESS */ + + /* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */ + RT = RDCS; /* RECORD TYPE */ + DO WHILE RL <> 0; RL = RL - 1; + hbuf = RDCS; + /* INCREMENT LA HERE FOR EXACT ADDRESS */ + END; + + /* CHECK SUM */ + IF rdcs <> 0 THEN + CALL xerror(4,.source); /* hex record checksum */ + h = getsource; + end; + end; /* do forever */ + END HEXRECORD; + +CK$STRINGS: PROCEDURE; + IF STARTS > 0 THEN + call error(11); /* START NOT FOUND */ + IF QUITS > 0 THEN + call error(12); /* QUIT NOT FOUND */ + END CK$STRINGS; + +CLOSEDEST: PROCEDURE; + DO WHILE (LOW(NDEST) AND 7FH) <> 0; + CALL PUTDEST(ENDFILE); + END; + CALL CK$STRINGS; + CALL WRITEDEST; + call setduser; /* destination user */ + CALL CLOSE(.DEST); + IF DCNT = 255 THEN +/** $if mpm **/ + call xerror(8,.dest); /* CLOSE FILE */ + IF odcnt <> 255 THEN /* FILE EXISTS */ + do; +/** $else **/ +/** $endif **/ + IF ROL(odest.fcb(9),1) THEN /* READ ONLY */ + DO; + IF NOT WRROF THEN + DO; + do while ((dcnt <> 'Y') and (dcnt <> 'N')); + CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)? $')); + dcnt = utran(rdchar); + end; + IF dcnt <> 'Y' THEN + DO; CALL PRINT(.('**NOT DELETED**$')); + CALL CRLF; + CALL DELETE(.DEST); + RETURN; + END; + CALL CRLF; + END; + END; + /* reset r/o and sys attributes */ + odest.fcb(9) = odest.fcb(9) and 7fh; + odest.fcb(10) = odest.fcb(10) AND 7FH; + CALL SETIND(.odest); + CALL DELETE(.odest); + END; + CALL MOVE(.odest.fcb,.dest.fcb(16),16); /* READY FOR RENAME */ + CALL RENAME(.DEST); + /* set destination attributes same as source */ + odest.fcb(1) = (odest.fcb(1) and 07fh) or f1; + odest.fcb(2) = (odest.fcb(2) and 07fh) or f2; + odest.fcb(3) = (odest.fcb(3) and 07fh) or f3; + odest.fcb(4) = (odest.fcb(4) and 07fh) or f4; + odest.fcb(8) = (odest.fcb(8) and 07fh); + odest.fcb(9) = (odest.fcb(9) and 07fh) or ro; + odest.fcb(10) = (odest.fcb(10) and 07fh) or sys; + odest.fcb(11) = (odest.fcb(11) and 07fh); + call setind(.odest); + if archiv then /* set archive bit */ + do; call setsuser; + source.fcb(11) = source.fcb(11) or 080h; + source.fcb(12) = 0; + call setind(.source); + end; + END CLOSEDEST; + +SIZE$MEMORY: PROCEDURE; + /* SET UP SOURCE AND DESTINATION BUFFERS */ + if not dblbuf then + do; /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */ + sbase = .memory; + sblen,dblen = ((maxb - .memory) and 0ff80h) - 128; + end; + else do; /* may need to write destination buffer */ + sblen,dblen = (shr((maxb - .memory),1) and 0ff80h) - 128; + sbase = .memory + dblen + 128; + if ndest >= dblen then call writedest; + nsbuf = 0; + end; + END SIZE$MEMORY; + +setupeob: procedure; + /* sets nsbuf to end of source buffer */ + declare i byte; + if (not obj) and (nsbuf <> 0) then + do; tblen = nsbuf - 128; + do i = 0 to 128; + if (sbuff(tblen + i)) = endfile then + do; nsbuf = tblen + i; + return; + end; + end; + end; + end setupeob; + +SIMPLECOPY: PROCEDURE; + DECLARE I BYTE; + declare + fast lit '0', /* fast file to file copy */ + chrt lit '1', /* character transfer option */ + dubl lit '2'; /* double buffer required for file copy */ + declare optype(26) byte data ( + /* option type for each option character */ + fast, /* for A option */ + fast, /* for B option */ + fast, /* for C option */ + dubl, /* for D option */ + chrt, /* for E option */ + dubl, /* for F option */ + fast, /* for G option */ + chrt, /* for H option */ + dubl, /* for I option */ + fast, /* for J option */ + fast, /* for K option */ + chrt, /* for L option */ + fast, /* for M option */ + dubl, /* for N option */ + fast, /* for O option */ + dubl, /* for P option */ + dubl, /* for Q option */ + fast, /* for R option */ + dubl, /* for S option */ + dubl, /* for T option */ + chrt, /* for U option */ + fast, /* for V option */ + fast, /* for W option */ + fast, /* for X option */ + fast, /* for Y option */ + chrt); /* for Z option */ + + chkrandom: procedure; + call setsuser; + call set$random(.source); +/** $if mpm **/ + call multsect(1); +/** $endif **/ + call setdma(.buff); + do forever; + if (((dcnt := rd$random(.source)) = 0) or maxsize) then + do; destr = sourcer; + destr2 = sourcer2; + endofsrc = false; + return; + end; + if dcnt = 1 then + do; if (sourcer := sourcer + 1) = 0 then + sourcer2 = sourcer2 + 1; + end; + else if dcnt = 4 then + do; + if (sourcer := (sourcer + 128) and 0ff80h) = 0 then + sourcer2 = sourcer2 + 1; + end; + else + call xerror(15,.source); + end; + end chkrandom; + + fastcopy = (sfile and dfile); + endofsrc = false; + dblbuf = false; + sparfil = false; + insparc = false; + /* LOOK FOR PARAMETERS */ + DO I = 0 TO 25; + IF CONT(I) <> 0 THEN + DO; + IF optype(i) = chrt THEN + FASTCOPY = FALSE; + else + if optype(i) = dubl then + do; dblbuf = (sfile and dfile); + fastcopy = false; + end; + END; + END; + + CALL SIZE$MEMORY; + if sfile then + CALL SETUPSOURCE; + /* FILES READY FOR COPY */ + + if fastcopy then + do while not endofsrc; + CALL FILLSOURCE; + if endofsrc and concat then + do; call setupeob; + ndest = nsbuf; + if nendcmd then return; + end; + ndest = nsbuf; + CALL WRITEDEST; + nsbuf = ndest; + if (endofsrc and insparc) then + call chkrandom; + end; + + else do; + /* PERFORM THE ACTUAL COPY FUNCTION */ + IF HEXT OR IGNOR THEN /* HEX FILE */ + call hexrecord; + ELSE + DO WHILE NOT RD$EOF; + CALL PUTDEST(CHAR); + END; + if concat and nendcmd then + do; nsbuf = ndest; + return; + end; + end; + + if dfile then + CALL CLOSEDEST; + END SIMPLECOPY; + +MULTCOPY: PROCEDURE; + DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS; + + PRNAME: PROCEDURE; + /* PRINT CURRENT FILE NAME */ + DECLARE (I,C) BYTE; + CALL CRLF; + DO I = 1 TO FNSIZE; + IF (C := odest.fcb(I)) <> ' ' THEN + DO; IF I = FEXT THEN CALL PRINTCHAR('.'); + CALL PRINTCHAR(C); + END; + END; + END PRNAME; + + archck: procedure byte; + /* check if archive bit is set in any extent of source file */ + if not archiv then + return 1; + call setsuser; + source.fcb(12) = what; + call search(.source); + do while dcnt <> 255; + /* [JCE] Patch 6: the last parameter on this line was 15 */ + call move(.buff+shl(dcnt and 11b,5)+1,.source.fcb(1),11); + if not rol(source.fcb(11),1) then + return 1; + call searchn; + end; + return 0; + end archck; + +/** $if mpm **/ + /* initialize counters if not error retry */ + if eretry = 0 then NEXTDIR, NCOPIED = 0; +/** $else **/ +/** $endif **/ + + DO FOREVER; + /* FIND A MATCHING ENTRY */ + CALL SETSUSER; /* SOURCE USER */ + CALL SETDMA(.BUFF); + searfcb(12) = 0; + CALL SEARCH(.SEARFCB); + NDCNT = 0; + DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR; + NDCNT = NDCNT + 1; + CALL SEARCHN; + END; + /* FILE CONTROL BLOCK IN BUFFER */ + IF DCNT = 255 THEN + DO; IF NCOPIED = 0 THEN + call xerror(9,.searfcb); /* file not found */ + if not kilds then + CALL CRLF; + RETURN; + END; + NEXTDIR = NDCNT + 1; + /* GET THE FILE CONTROL BLOCK NAME TO DEST */ + CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.odest.fcb(1),15); + CALL MOVE(.odest.fcb(1),.SOURCE.FCB(1),15); /* FILL BOTH FCB'S */ + if archck then + do; odest.fcb(12) = 0; + source.fcb(12) = 0; + IF RSYS OR NOT ROL(odest.fcb(10),1) THEN /* OK TO READ */ + DO; if not kilds then /* kill display option */ + do; IF NCOPIED = 0 THEN + CALL PRINT(.('COPYING -$')); + dcnt = false; + do while ((dcnt <> 'Y') and (dcnt <> 'N')); + call prname; + if confrm then + do; call printx(.(' (Y/N)? $')); + dcnt = utran(rdchar); + end; + else + dcnt = 'Y'; + end; + end; + ncopied = ncopied + 1; + made = false; /* destination file not made */ + if (dcnt = 'Y') or (kilds) then + CALL SIMPLECOPY; + END; + end; + END; + END MULTCOPY; + +CK$DISK: PROCEDURE; + /* error if same user and same disk */ + IF (odest.user = source.user) and (odest.fcb(0) = source.fcb(0)) THEN + CALL FORMERR; + END CK$DISK; + +GNC: PROCEDURE BYTE; + IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR; + RETURN UTRAN(COMBUFF(CBP)); + END GNC; + +DEBLANK: PROCEDURE; + DO WHILE (CHAR := GNC) = ' '; + END; + END DEBLANK; + +CK$EOL: PROCEDURE; + CALL DEBLANK; + IF CHAR <> CR THEN CALL FORMERR; + END CK$EOL; + +SCAN: PROCEDURE(FCBA); + DECLARE FCBA ADDRESS, /* ADDRESS OF FCB TO FILL */ + fcbs based fcba structure ( /* FCB STRUCTURE */ + fcb(frsize) byte, +/** $if mpm **/ + pwnam(nsize) byte, + pwmode byte, +/** $endif **/ + user byte, + type byte ); + DECLARE (I,K) BYTE; /* TEMP COUNTERS */ + + /* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME. + THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */ + + DELIMITER: PROCEDURE(C) BYTE; + DECLARE (I,C) BYTE; + DECLARE DEL(*) BYTE DATA + (' =.:;,<>',CR,LA,LB,RB); + DO I = 0 TO LAST(DEL); + IF C = DEL(I) THEN RETURN TRUE; + END; + RETURN FALSE; + END DELIMITER; + + PUTCHAR: PROCEDURE; + FCBS.FCB(FLEN:=FLEN+1) = CHAR; + IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */ + END PUTCHAR; + + FILLQ: PROCEDURE(LEN); + /* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */ + DECLARE LEN BYTE; + CHAR = WHAT; /* QUESTION MARK */ + DO WHILE FLEN < LEN; + CALL PUTCHAR; + END; + END FILLQ; + + SCANPAR: PROCEDURE; + DECLARE (I,J) BYTE; + /* SCAN OPTIONAL PARAMETERS */ + CHAR = GNC; /* SCAN PAST BRACKET */ + DO WHILE NOT(CHAR = CR OR CHAR = RB); + IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */ + DO; IF CHAR = ' ' THEN + CHAR = GNC; + ELSE + call error(6); /* BAD PARAMETER */ + END; + ELSE + DO; /* SCAN PARAMETER VALUE */ + IF CHAR = 'S' OR CHAR = 'Q' THEN + DO; /* START OR QUIT COMMAND */ + J = CBP + 1; /* START OF STRING */ + DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR); + END; + CHAR=GNC; + END; + ELSE IF (J := (CHAR := GNC) - '0') > 9 THEN + J = 1; + ELSE + DO WHILE (K := (CHAR := GNC) - '0') <= 9; + J = J * 10 + K; + END; + CONT(I) = J; + IF I = 6 THEN /* SET SOURCE USER */ + DO; + IF J > 15 THEN + call error(7); /* INVALID USER NUMBER */ + fcbs.user = J; + END; + END; + END; + CHAR = GNC; + END SCANPAR; + + + /* scan procedure entry point */ + + /* INITIALIZE FILE CONTROL BLOCK TO EMPTY */ + fcbs.type = ERR; CHAR = ' '; FLEN = 0; +/** $if mpm **/ + DO WHILE FLEN < (FRSIZE + NSIZE); + IF FLEN = FNSIZE THEN CHAR = 0; + ELSE IF FLEN = FRSIZE THEN CHAR = ' '; + call putchar; + END; + fcbs.pwnam(0) = 0; + fcbs.pwmode = 1; +/** $else **/ +/** $endif **/ + fcbs.fcb(0) = cdisk +1; /* initialize to current disk */ + fcbs.user = cuser; /* and current user */ + /* CLEAR PARAMETERS */ + DO I = 0 TO 25; CONT(I) = 0; + END; + FEEDLEN,MATCHLEN,QUITLEN = 0; + + /* DEBLANK COMMAND BUFFER */ + CALL DEBLANK; + + /* CHECK PERIPHERALS AND DISK FILES */ + /* SCAN NEXT NAME */ + DO FOREVER; + FLEN = 0; + DO WHILE NOT DELIMITER(CHAR); + IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */ + RETURN; + IF CHAR = '*' THEN CALL FILLQ(NSIZE); + ELSE CALL PUTCHAR; + CHAR = GNC; + END; + + /* CHECK FOR DISK NAME OR DEVICE NAME */ + IF CHAR = ':' THEN + DO; IF FLEN = 1 THEN + /* MAY BE DISK NAME A ... P */ + DO; + IF (fcbs.fcb(0) := fcbs.fcb(1) - 'A' + 1) > 16 THEN + RETURN; /* ERROR, INVALID DISK NAME */ + CALL DEBLANK; /* MAY BE DISK NAME ONLY */ + IF DELIMITER(CHAR) THEN + DO; IF CHAR = LB THEN + CALL SCANPAR; + CBP = CBP - 1; + fcbs.type = DISKNAME; + RETURN; + END; + END; + ELSE + /* MAY BE A THREE CHARACTER DEVICE NAME */ + IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */ + RETURN; + ELSE + /* LOOK FOR DEVICE NAME */ + DO; DECLARE (I,J,K) BYTE, M LITERALLY '9', + IO(*) BYTE DATA + ('OUTPRNLSTAXO', + 0,0,0, /* fake area for file type */ + 'AUX', + 'CONAXIINPNULEOF',0); + + J = 255; + DO K = 0 TO M; + I = 0; + DO WHILE ((I:=I+1) <= 3) AND + IO(J+I) = fcbs.fcb(I); + END; + IF I = 4 THEN /* COMPLETE MATCH */ + DO; fcbs.type = k; + /* SCAN PARAMETERS */ + IF GNC = LB THEN CALL SCANPAR; + CBP = CBP - 1; + RETURN; + END; + J = J + 3; /* OTHERWISE TRY NEXT DEVICE */ + END; + RETURN; /* ERROR, NO DEVICE NAME MATCH */ + END; + IF CHAR = LB THEN /* PARAMETERS FOLLOW */ + CALL SCANPAR; + END; + ELSE + /* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */ + DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */ + RETURN; + FLEN = NSIZE; + IF CHAR = '.' THEN /* SCAN FILE TYPE */ + DO WHILE NOT DELIMITER(CHAR := GNC); + IF FLEN >= FNSIZE THEN + RETURN; /* ERROR, TYPE FIELD TOO LONG */ + IF CHAR = '*' THEN CALL FILLQ(FNSIZE); + ELSE CALL PUTCHAR; + END; +/** $if mpm **/ + FLEN = 0; + IF CHAR = ';' THEN /* SCAN PASSWORD */ + DO WHILE NOT DELIMITER(CHAR := GNC); + IF FLEN >= NSIZE THEN + /* ERROR, PW TOO LONG */ RETURN; + ELSE /* SAVE PASSWORD */ + FCBS.PWNAM(FLEN) = CHAR; + FLEN = FLEN + 1; + END; +/** $endif **/ + IF CHAR = LB THEN + CALL SCANPAR; + /* RESCAN DELIMITER NEXT TIME AROUND */ + CBP = CBP - 1; + fcbs.type = FILE; + FCBS.FCB(32) = 0; + RETURN; + END; + END; + END SCAN; + + +/* PLM (PIP) ENTRY POINT */ + /* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED + FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */ + + if not retry then + do; CALL MOVE(.BUFF,.COMLEN,80H); + MULTCOM = (COMLEN = 0); + + /* GET CURRENT CP/M VERSION */ + IF low(CVERSION) < VERSION THEN + DO; +/** $if cpm3 **/ + CALL PRINT(.('REQUIRES CP/M 3$')); +/** $else **/ +/** $endif **/ + CALL BOOT; + END; + + call mon1(45,255); /* set return error mode */ + +/** $if cpm3 **/ + call mon1(109,1); /* set CP/M 3 control-C status mode */ +/** $endif **/ + + if multcom then + do; +/** $if cpm3 **/ + call printx(.('CP/M 3 PIP VERSION 3.0$')); +/** $else **/ +/** $endif **/ + call crlf; + end; + + cuser,last$user = getuser; /* GET CURRENT USER */ + cdisk = getdisk; /* GET CURRENT DISK */ +/** $if mpm **/ + mseccnt = 1; +/** $endif **/ + eretry = false; /* need to initialize here for first time */ + end; + + + /* START HERE ON RESET EXIT FROM THE PROCEDURE 'ERROR' */ +/** $if mpm **/ + if eretry <> 0 then + do; call multcopy; + comlen = multcom; + end; +/** $endif **/ + /* MAIN PROCESSING LOOP. PROCESS UNTIL CR ONLY */ + DO FOREVER; + C1, C2, C3 = 0; /* LINE COUNT = 000000 */ + CONCNT,COLUMN = 0; /* PRINTER TABS */ + ndest,nsbuf = 0; + ambig = false; + made = false; /* destination file not made */ + opened = false; /* source file not opened */ + concat = false; + eretry = false; + PUTNUM = TRUE; /* ACTS LIKE LF OCCURRED ON ASCII FILE */ + dfile,sfile = true; + nendcmd = true; + LINENO = 254; /* INCREMENTED TO 255 > PAGCNT */ + /* READ FROM CONSOLE IF NOT A ONELINER */ + IF MULTCOM THEN + DO; CALL PRINTCHAR('*'); CALL RDCOM; + CALL CRLF; + END; + CBP = 255; + IF COMLEN = 0 THEN /* character = */ + do; call setcuser; /* restore current user */ + CALL BOOT; /* normal exit from pip here */ + end; + + /* LOOK FOR SPECIAL CASES FIRST */ + + CALL SCAN(.odest); + if ambig then + call xerror(5,.odest); /* invalid destination */ + call deblank; /* check for equal sign or left arrow */ + if (char <> '=') and (char <> la) then call formerr; + call scan(.source); + + IF odest.type = DISKNAME THEN + DO; + IF source.type <> file then call formerr; + CALL CK$EOL; + CALL CK$DISK; + odest.type = file; /* set for character transfer */ + /* MAY BE MULTI COPY */ + IF AMBIG THEN /* FORM IS A:=B:AFN */ + DO; + CALL MOVE(.source.fcb(0),.searfcb(0),frsize); + CALL MULTCOPY; + END; + ELSE DO; /* FORM IS A:=B:UFN */ + CALL MOVE(.source.fcb(1),.odest.fcb(1),frsize - 1); + CALL SIMPLECOPY; + END; + END; + + else IF (odest.type = FILE) and (source.type = DISKNAME) THEN + DO; + CALL CK$EOL; + CALL CK$DISK; + source.type = file; /* set for character transfer */ +/** $if mpm **/ + call move(.odest.fcb(1),.source.fcb(1),(frsize+nsize)); +/** $else **/ +/** $endif **/ + CALL SIMPLECOPY; + END; + + else if (odest.type > cons) then + call error(3); /* invalid destination */ + else do; + IF odest.type <> FILE THEN dfile = false; +/** $if not mpm **/ + /* no conditional attach list device */ +/** $else **/ +/** $endif **/ + /* SCAN AND COPY UNTIL CR */ + DO WHILE nendcmd; + sfile = true; + call deblank; + IF (CHAR <> ',' AND CHAR <> CR) THEN + call error(16); /* invalid separator */ + concat = concat or (nendcmd := (char = ',')); + IF odest.type = PRNT THEN + DO; NUMB = 1; + IF TABS = 0 THEN TABS = 8; + IF PAGCNT = 0 THEN PAGCNT = 1; + END; + IF (source.type < file) or (source.type > eoft) or ambig THEN + call error(4); /* invalid source */ + IF source.type <> FILE THEN /* NOT A SOURCE FILE */ + sfile = false; + IF source.type = NULT THEN + /* SEND 40 NULLS TO OUTPUT DEVICE */ + DO sfile = 0 TO 39; CALL PUTDEST(0); + END; + ELSE IF source.type = EOFT THEN + CALL PUTDEST(ENDFILE); + else call simplecopy; + + CALL CK$STRINGS; + /* READ ENDFILE, GO TO NEXT SOURCE */ + + if nendcmd then call scan(.source); + END; + end; + + /* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */ + COMLEN = MULTCOM; + + END; /* DO FOREVER */ + end plm; + END; + +EOF diff --git a/software/CPM/cpm3/plibios.asm b/software/CPM/cpm3/plibios.asm new file mode 100644 index 0000000..3a08678 --- /dev/null +++ b/software/CPM/cpm3/plibios.asm @@ -0,0 +1,170 @@ + + name 'PLIBIOS' + title 'Direct BIOS Calls From PL/I-80' +; +;*********************************************************** +;* * +;* bios calls from pl/i for track, sector io * +;* * +;*********************************************************** + public seldsk ;select disk drive + public settrk ;set track number + public setsec ;set sector number + public rdsec ;read sector + public wrsec ;write sector + public sectrn ;translate sector number + public bstdma ;set dma + public bflush ;flush deblocking buffers +; +; + extrn ?boot ;system reboot entry point + extrn ?bdos ;bdos entry point +; +;*********************************************************** +;* * +;* equates for interface to cp/m bios * +;* * +;*********************************************************** +cr equ 0dh ;carriage return +lf equ 0ah ;line feed +eof equ 1ah ;end of file +; +base equ 0 +wboot equ base+1h ;warm boot entry point stored here +sdsk equ 18h ;bios select disk entry point +strk equ 1bh ;bios set track entry point +ssec equ 1eh ;bios set sector entry point +sdma equ 21h ;bios set dma entry point +read equ 24h ;bios read sector entry point +write equ 27h ;bios write sector entry point +stran equ 2dh ;bios sector translation entry point +; +; utility functions +; +;*********************************************************** +;*********************************************************** +;* * +;* general purpose routines used upon entry * +;* * +;*********************************************************** +; +; +getp: ;get parameter + mov e,m ;low (addr) + inx h + mov d,m ;high (addr) + inx h + push h ;save for next parameter + xchg ;hl = .char + mov e,m ;to register e + inx h + mov d,m ;get high byte as well + pop h ;ready for next parameter + ret +; +; +;*********************************************************** +;* * +;*********************************************************** +seldsk: ;select drive number 0-15, in C + ;1-> drive no. + ;returns-> pointer to translate table in HL + call getp + mov c,e ;c = drive no. + lxi d,sdsk + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +settrk: ;set track number 0-76, 0-65535 in BC + ;1-> track no. + call getp + mov b,d + mov c,e ;bc = track no. + lxi d,strk + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +setsec: ;set sector number 1 - sectors per track + ;1-> sector no. + call getp + mov b,d + mov c,e ;bc = sector no. + lxi d,ssec + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +rdsec: ;read current sector into sector at dma addr + ;returns in A register: 0 if no errors + ; 1 non-recoverable error + lxi d,read + jmp gobios +;*********************************************************** +;* * +;*********************************************************** +wrsec: ;writes contents of sector at dma addr to current sector + ;returns in A register: 0 errors occured + ; 1 non-recoverable error + lxi d,write + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +sectrn: ;translate sector number + ;1-> logical sector number (fixed(15)) + ;2-> pointer to translate table + ;returns-> physical sector number + call getp ;first parameter + mov b,d + mov c,e ;bc = logical sector no. + call getp ;second parameter + push d ;save it + lxi d,stran + lhld wboot + dad d ;hl = sectran entry point + pop d ;de = .translate-table + pchl +; +;*********************************************************** +;* +;* +;*********************************************************** +bstdma: ;set dma + call getp + mov b,d + mov c,e + lxi d,sdma + jmp gobios +; +bflush: ;flush deblocking buffers +; lxi b,0ffffh +; lxi d,setdmf +; jmp gobios + ret + +;*********************************************************** +;*********************************************************** +;*********************************************************** +;* * +;* compute offset from warm boot and jump to bios * +;* * +;*********************************************************** +; +; +gobios: ;jump to bios entry point + ;de -> offset from warm boot entry point + lhld wboot + dad d + pchl +; + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + db 0 + end + diff --git a/software/CPM/cpm3/plibios3.asm b/software/CPM/cpm3/plibios3.asm new file mode 100644 index 0000000..03ccc46 --- /dev/null +++ b/software/CPM/cpm3/plibios3.asm @@ -0,0 +1,147 @@ + name 'BIOSMOD' + title 'Direct BIOS Calls From PL/I-80 for CP/M 3.0' +; +;*********************************************************** +;* * +;* bios calls from pl/i for track, sector io * +;* * +;*********************************************************** + public settrk ;set track number + public setsec ;set sector number + public rdsec ;read sector + public wrsec ;write sector + public seldsk ;select disk & return the addr(DPH) + public sectrn ;translate sector # given translate table + public bstdma ;set dma +; +; + extrn ?boot ;system reboot entry point + extrn ?bdos ;bdos entry point +; +; utility functions +; +;*********************************************************** +;*********************************************************** +;* * +;* general purpose routines used upon entry * +;* * +;*********************************************************** +; +; +getp2: ;get single word value to DE + mov e,m + inx h + mov d,m + inx h + push h + xchg + mov e,m + inx h + mov d,m + pop h + ret +; +; +;*********************************************************** +;* * +;*********************************************************** +settrk: ;set track number 0-76, 0-65535 in BC + ;1-> track # + call getp2 + xchg + shld BCREG + mvi a,0ah + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +setsec: ;set sector number 1 - sectors per track + ;1-> sector # + call getp2 + xchg + shld BCREG + mvi a,0bh + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +rdsec: ;read current sector into sector at dma addr + ;returns 0 if no errors + ; 1 non-recoverable error + mvi a,0dh + jmp gobios +;*********************************************************** +;* * +;*********************************************************** +wrsec: ;writes contents of sector at dma addr to current sector + ;returns 0 errors occured + ; 1 non-recoverable error + call getp2 + xchg + shld BCREG + mvi a,0eh + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +; +seldsk: ; selects disk + + call getp2 + mov a,e + sta BCREG + mvi a,9 + jmp gobios +; +;*********************************************************** +;* * +;*********************************************************** +; +sectrn: ;translate sector # + call getp2 + xchg + shld BCREG + xchg + call getp2 + xchg + shld DEREG + mvi a,10h + jmp gobios +; +bstdma: ;set dma + call getp2 + xchg + shld BCREG + mvi a,0ch +; jmp gobios +; +;*********************************************************** +;*********************************************************** +;*********************************************************** +;* * +;* call BDOS * +;* * +;*********************************************************** +; +; +gobios: + sta FUNC ;load BIOS function # + lxi h,FUNC + xchg ; address of BIOSPB in DE + mvi c,032h ; BDOS function 50 call + jmp ?bdos +; +; +BIOSPB: dw FUNC +FUNC: db 0 +AREG: db 0 +BCREG: dw 0 +DEREG: dw 0 +HLREG: dw 0 +; + end + + \ No newline at end of file diff --git a/software/CPM/cpm3/plidio.asm b/software/CPM/cpm3/plidio.asm new file mode 100644 index 0000000..52d0bac --- /dev/null +++ b/software/CPM/cpm3/plidio.asm @@ -0,0 +1,619 @@ + name 'DIOMOD' + title 'Direct CP/M Calls From PL/I-80' +; +;*********************************************************** +;* * +;* cp/m calls from pl/i for direct i/o * +;* * +;*********************************************************** + public memptr ;return pointer to base of free mem + public memsiz ;return size of memory in bytes + public memwds ;return size of memory in words + public dfcb0 ;return address of default fcb 0 + public dfcb1 ;return address of default fcb 1 + public dbuff ;return address of default buffer + public reboot ;system reboot (#0) + public rdcon ;read console character (#1) + public wrcon ;write console character(#2) + public rdrdr ;read reader character (#3) + public wrpun ;write punch character (#4) + public wrlst ;write list character (#5) + public coninp ;direct console input (#6a) + public conout ;direct console output (#6b) + public rdstat ;read console status (#6c) + public getio ;get io byte (#8) + public setio ;set i/o byte (#9) + public wrstr ;write string (#10) + public rdbuf ;read console buffer (#10) + public break ;get console status (#11) + public vers ;get version number (#12) + public reset ;reset disk system (#13) + public select ;select disk (#14) + public open ;open file (#15) + public close ;close file (#16) + public sear ;search for file (#17) + public searn ;search for next (#18) + public delete ;delete file (#19) + public rdseq ;read file sequential mode (#20) + public wrseq ;write file sequential mode (#21) + public make ;create file (#22) + public rename ;rename file (#23) + public logvec ;return login vector (#24) + public curdsk ;return current disk number (#25) + public setdma ;set DMA address (#26) + public allvec ;return address of alloc vector (#27) + public wpdisk ;write protect disk (#28) + public rovec ;return read/only vector (#29) + public filatt ;set file attributes (#30) + public getdpb ;get base of disk parm block (#31) + public getusr ;get user code (#32a) + public setusr ;set user code (#32b) + public rdran ;read random (#33) + public wrran ;write random (#34) + public filsiz ;random file size (#35) + public setrec ;set random record pos (#36) + public resdrv ;reset drive (#37) + public wrranz ;write random, zero fill (#40) + public sgscb ;set/get System Control Block byte/word +; +; + extrn ?begin ;beginning of free list + extrn ?boot ;system reboot entry point + extrn ?bdos ;bdos entry point + extrn ?dfcb0 ;default fcb 0 + extrn ?dfcb1 ;default fcb 1 + extrn ?dbuff ;default buffer +; +;*********************************************************** +;* * +;* equates for interface to cp/m bdos * +;* * +;*********************************************************** +cr equ 0dh ;carriage return +lf equ 0ah ;line feed +eof equ 1ah ;end of file +; +readc equ 1 ;read character from console +writc equ 2 ;write console character +rdrf equ 3 ;reader input +punf equ 4 ;punch output +listf equ 5 ;list output function +diof equ 6 ;direct i/o, version 2.0 +getiof equ 7 ;get i/o byte +setiof equ 8 ;set i/o byte +printf equ 9 ;print string function +rdconf equ 10 ;read console buffer +statf equ 11 ;return console status +versf equ 12 ;get version number +resetf equ 13 ;system reset +seldf equ 14 ;select disk function +openf equ 15 ;open file function +closef equ 16 ;close file +serchf equ 17 ;search for file +serchn equ 18 ;search next +deletf equ 19 ;delete file +readf equ 20 ;read next record +writf equ 21 ;write next record +makef equ 22 ;make file +renamf equ 23 ;rename file +loginf equ 24 ;get login vector +cdiskf equ 25 ;get current disk number +setdmf equ 26 ;set dma function +getalf equ 27 ;get allocation base +wrprof equ 28 ;write protect disk +getrof equ 29 ;get r/o vector +setatf equ 30 ;set file attributes +getdpf equ 31 ;get disk parameter block +userf equ 32 ;set/get user code +rdranf equ 33 ;read random +wrranf equ 34 ;write random +filszf equ 35 ;compute file size +setrcf equ 36 ;set random record position +rsdrvf equ 37 ;reset drive function +wrrnzf equ 40 ;write random zero fill +scbf equ 49 ;set/get SCB +; +; utility functions +;*********************************************************** +;* * +;* general purpose routines used upon entry * +;* * +;*********************************************************** +; +getp1: ;get single byte parameter to register e + mov e,m ;low (addr) + inx h + mov d,m ;high(addr) + xchg ;hl = .char + mov e,m ;to register e + ret +; +getp2: ;get single word value to DE +getp2i: ;(equivalent to getp2) + call getp1 + inx h + mov d,m ;get high byte as well + ret +; +getver: ;get cp/m or mp/m version number + push h ;save possible data adr + mvi c,versf + call ?bdos + pop h ;recall data addr + ret +; +chkv20: ;check for version 2.0 or greater + call getver + cpi 20 + rnc ;return if > 2.0 +; error message and stop + jmp vererr ;version error +; +chkv22: ;check for version 2.2 or greater + call getver + cpi 22h + rnc ;return if >= 2.2 +vererr: + ;version error, report and terminate + lxi d,vermsg + mvi c,printf + call ?bdos ;write message + jmp ?boot ;and reboot +vermsg: db cr,lf,'Later CP/M or MP/M Version Required$' +; +;*********************************************************** +;* * +;*********************************************************** +memptr: ;return pointer to base of free storage + lhld ?begin + ret +; +;*********************************************************** +;* * +;*********************************************************** +memsiz: ;return size of free memory in bytes + lhld ?bdos+1 ;base of bdos + xchg ;de = .bdos + lhld ?begin ;beginning of free storage + mov a,e ;low(.bdos) + sub l ;-low(begin) + mov l,a ;back to l + mov a,d ;high(.bdos) + sbb h + mov h,a ;hl = mem size remaining + ret +; +;*********************************************************** +;* * +;*********************************************************** +memwds: ;return size of free memory in words + call memsiz ;hl = size in bytes + mov a,h ;high(size) + ora a ;cy = 0 + rar ;cy = ls bit + mov h,a ;back to h + mov a,l ;low(size) + rar ;include ls bit + mov l,a ;back to l + ret ;with wds in hl +; +;*********************************************************** +;* * +;*********************************************************** +dfcb0: ;return address of default fcb 0 + lxi h,?dfcb0 + ret +; +;*********************************************************** +;* * +;*********************************************************** +dfcb1: ;return address of default fcb 1 + lxi h,?dfcb1 + ret +; +;*********************************************************** +;* * +;*********************************************************** +dbuff: ;return address of default buffer + lxi h,?dbuff + ret +; +;*********************************************************** +;* * +;*********************************************************** +reboot: ;system reboot (#0) + jmp ?boot +; +;*********************************************************** +;* * +;*********************************************************** +rdcon: ;read console character (#1) + ;return character value to stack + mvi c,readc + jmp chrin ;common code to read char +; +;*********************************************************** +;* * +;*********************************************************** +wrcon: ;write console character(#2) + ;1->char(1) + mvi c,writc ;console write function + jmp chrout ;to write the character +; +;*********************************************************** +;* * +;*********************************************************** +rdrdr: ;read reader character (#3) + mvi c,rdrf ;reader function +chrin: + ;common code for character input + call ?bdos ;value returned to A + pop h ;return address + push psw ;character to stack + inx sp ;delete flags + mvi a,1 ;character length is 1 + pchl ;back to calling routine +; +;*********************************************************** +;* * +;*********************************************************** +wrpun: ;write punch character (#4) + ;1->char(1) + mvi c,punf ;punch output function + jmp chrout ;common code to write chr +; +;*********************************************************** +;* * +;*********************************************************** +wrlst: ;write list character (#5) + ;1->char(1) + mvi c,listf ;list output function +chrout: + ;common code to write character + ;1-> character to write + call getp1 ;output char to register e + jmp ?bdos ;to write and return +; +;*********************************************************** +;* * +;*********************************************************** +coninp: ;perform console input, char returned in stack + lxi h,chrstr ;return address + push h ;to stack for return + lhld ?boot+1 ;base of bios jmp vector + lxi d,2*3 ;offset to jmp conin + dad d + pchl ;return to chrstr +; +chrstr: ;create character string, length 1 + pop h ;recall return address + push psw ;save character + inx sp ;delete psw + mvi a,1 ;string length is 1 + pchl ;return to caller +; +;*********************************************************** +;* * +;*********************************************************** +conout: ;direct console output + ;1->char(1) + call getp1 ;get parameter + mov c,e ;character to c + lhld ?boot+1 ;base of bios jmp + lxi d,3*3 ;console output offset + dad d ;hl = .jmp conout + pchl ;return through handler +; +;*********************************************************** +;* * +;*********************************************************** +rdstat: ;direct console status read + lxi h,rdsret ;read status return + push h ;return to rdsret + lhld ?boot+1 ;base of jmp vector + lxi d,1*3 ;offset to .jmp const + dad d ;hl = .jmp const + pchl +; +;*********************************************************** +;* * +;*********************************************************** +getio: ;get io byte (#8) + mvi c,getiof + jmp ?bdos ;value returned to A +; +;*********************************************************** +;* * +;*********************************************************** +setio: ;set i/o byte (#9) + ;1->i/o byte + call getp1 ;new i/o byte to E + mvi c,setiof + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrstr: ;write string (#10) + ;1->addr(string) + call getp2 ;get parameter value to DE + mvi c,printf ;print string function + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +rdbuf: ;read console buffer (#10) + ;1->addr(buff) + call getp2i ;DE = .buff + mvi c,rdconf ;read console function + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +break: ;get console status (#11) + mvi c,statf + call ?bdos ;return through bdos +; +rdsret: ;return clean true value + ora a ;zero? + rz ;return if so + mvi a,0ffh ;clean true value + ret +; +;*********************************************************** +;* * +;*********************************************************** +vers: ;get version number (#12) + mvi c,versf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +reset: ;reset disk system (#13) + mvi c,resetf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +select: ;select disk (#14) + ;1->fixed(7) drive number + call getp1 ;disk number to E + mvi c,seldf + jmp ?bdos ;return through bdos +;*********************************************************** +;* * +;*********************************************************** +open: ;open file (#15) + ;1-> addr(fcb) + call getp2i ;fcb address to de + mvi c,openf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +close: ;close file (#16) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,closef + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +sear: ;search for file (#17) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,serchf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +searn: ;search for next (#18) + mvi c,serchn ;search next function + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +delete: ;delete file (#19) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,deletf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +rdseq: ;read file sequential mode (#20) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,readf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrseq: ;write file sequential mode (#21) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,writf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +make: ;create file (#22) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,makef + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +rename: ;rename file (#23) + ;1-> addr(fcb) + call getp2i ;.fcb to DE + mvi c,renamf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +logvec: ;return login vector (#24) + mvi c,loginf + jmp ?bdos ;return through BDOS +; +;*********************************************************** +;* * +;*********************************************************** +curdsk: ;return current disk number (#25) + mvi c,cdiskf + jmp ?bdos ;return value in A +; +;*********************************************************** +;* * +;*********************************************************** +setdma: ;set DMA address (#26) + ;1-> pointer (dma address) + call getp2 ;dma address to DE + mvi c,setdmf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +allvec: ;return address of allocation vector (#27) + mvi c,getalf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wpdisk: ;write protect disk (#28) + call chkv20 ;must be 2.0 or greater + mvi c,wrprof + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +rovec: ;return read/only vector (#29) + call chkv20 ;must be 2.0 or greater + mvi c,getrof + jmp ?bdos ;value returned in HL +; +;*********************************************************** +;* * +;*********************************************************** +filatt: ;set file attributes (#30) + ;1-> addr(fcb) + call chkv20 ;must be 2.0 or greater + call getp2i ;.fcb to DE + mvi c,setatf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +getdpb: ;get base of current disk parm block (#31) + call chkv20 ;check for 2.0 or greater + mvi c,getdpf + jmp ?bdos ;addr returned in HL +; +;*********************************************************** +;* * +;*********************************************************** +getusr: ;get user code to register A + call chkv20 ;check for 2.0 or greater + mvi e,0ffh ;to get user code + mvi c,userf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +setusr: ;set user code + call chkv20 ;check for 2.0 or greater + call getp1 ;code to E + mvi c,userf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +rdran: ;read random (#33) + ;1-> addr(fcb) + call chkv20 ;check for 2.0 or greater + call getp2i ;.fcb to DE + mvi c,rdranf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrran: ;write random (#34) + ;1-> addr(fcb) + call chkv20 ;check for 2.0 or greater + call getp2i ;.fcb to DE + mvi c,wrranf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +filsiz: ;compute file size (#35) + call chkv20 ;must be 2.0 or greater + call getp2 ;.fcb to DE + mvi c,filszf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +setrec: ;set random record position (#36) + call chkv20 ;must be 2.0 or greater + call getp2 ;.fcb to DE + mvi c,setrcf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +resdrv: ;reset drive function (#37) + ;1->drive vector - bit(16) + call chkv22 ;must be 2.2 or greater + call getp2 ;drive reset vector to DE + mvi c,rsdrvf + jmp ?bdos ;return through bdos +; +;*********************************************************** +;* * +;*********************************************************** +wrranz: ;write random, zero fill function + ;1-> addr(fcb) + call chkv22 ;must be 2.2 or greater + call getp2i ;.fcb to DE + mvi c,wrrnzf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** +sgscb: ;set/get SCB byte/word + ;1-> addr(SCB structure) + call getp2 + mvi c,scbf + jmp ?bdos +; +;*********************************************************** +;* * +;*********************************************************** + end + \ No newline at end of file diff --git a/software/CPM/cpm3/plm80/common.lit b/software/CPM/cpm3/plm80/common.lit new file mode 100644 index 0000000..c40232f --- /dev/null +++ b/software/CPM/cpm3/plm80/common.lit @@ -0,0 +1,32 @@ +/* Some useful defines for the remote program */ + +declare lit literally 'literally'; +declare word lit 'address'; +declare pointer lit 'address'; +declare connection lit 'address'; + +declare cr lit '0dh', + lf lit '0ah', + TAB lit '09h', + SOH lit '01h', + STX lit '02h', + ETX lit '03h', + EOT lit '04h', + ACK lit '06h', + NAK lit '15h', + XON lit '11h', + XOF lit '13h', + CAN lit '18h', + SUB lit '1ah', + RUBOUT lit '7fh'; + +declare forever lit 'while 1'; + +declare false lit '0', + true lit 'not false'; + +declare read$only lit '1', + write$only lit '2', + read$write lit '3'; + +$list diff --git a/software/CPM/cpm3/plm80/conv86 b/software/CPM/cpm3/plm80/conv86 new file mode 100644 index 0000000..b4ee6ba Binary files /dev/null and b/software/CPM/cpm3/plm80/conv86 differ diff --git a/software/CPM/cpm3/plm80/fpal.lib b/software/CPM/cpm3/plm80/fpal.lib new file mode 100644 index 0000000..eadd36e Binary files /dev/null and b/software/CPM/cpm3/plm80/fpal.lib differ diff --git a/software/CPM/cpm3/plm80/hexobj b/software/CPM/cpm3/plm80/hexobj new file mode 100644 index 0000000..136e296 Binary files /dev/null and b/software/CPM/cpm3/plm80/hexobj differ diff --git a/software/CPM/cpm3/plm80/isis.doc b/software/CPM/cpm3/plm80/isis.doc new file mode 100644 index 0000000..b01e041 --- /dev/null +++ b/software/CPM/cpm3/plm80/isis.doc @@ -0,0 +1,59 @@ + + + Instructions for ISIS environment V1.0 + ====================================== + +The ISIS environment is designed to allow 8080 based Intel tools to run on +an 8086 PCDOS based system. The ISIS environment does not support all ISIS +calls, but sufficient to run 8051 translators and utilities. (If the program +uses an unsupported ISIS call an error message is generated). + + +DOS instructions +---------------- + +Load the software(ISIS) onto the harddisk. If ISIS is installed in the DOS +search path it will be directly loadable by entering "ISIS". + +Before entering ISIS, logical names must be set to match any ISIS disk drives +used by the ISIS tools. This includes :F0: - the ISIS environment does NOT +default to the current drive. As with 8080 ISIS, filenames without a drive +prefix are directed to :F0:. + + +C>SET :F0:=\ISIS /* make sure there is no before the "=" */ +C>SET :F1:=\BITBUS + +C>ISIS /* invoke ISIS emulator */ +DOS ISIS Environment X003 +=ASM51 :F1:SAMP1.A51 /* enter ISIS commands */ +... +... +=EXIT /* return to DOS */ + + +The ISIS environment will also run under DOS in batch mode + +Command file (DEMO.CMD) contains: + +ASM51 :F1:SAMP1.A51 +ASM51 :F1:SAMP2.A51 +ASM51 :F1:SAMP3.A51 +RL51 :F1:SAMP1.OBJ, & +:F1:SAMP2.OBJ, & +:F1:SAMP3.OBJ TO :F1:SAMPLE +EXIT /* must include EXIT since all program + input must be in command file + otherwise DOS will wait forever */ + +To invoke the command file + +C>ISIS < DEMO.CMD /* This could be part of a batch job */ + + or will abort the ISIS environment. You will need to +enter also if the ISIS environment is at the prompt level. Also the +command "BREAK ON" should be included in the AUTOEXEC.BAT file to permit DOS +to recognise all the time (not just when performing DOS calls). + + +Known Bugs/Problems: None diff --git a/software/CPM/cpm3/plm80/isis.exe b/software/CPM/cpm3/plm80/isis.exe new file mode 100644 index 0000000..75b4e6d Binary files /dev/null and b/software/CPM/cpm3/plm80/isis.exe differ diff --git a/software/CPM/cpm3/plm80/isis.ext b/software/CPM/cpm3/plm80/isis.ext new file mode 100644 index 0000000..6028c9a --- /dev/null +++ b/software/CPM/cpm3/plm80/isis.ext @@ -0,0 +1,114 @@ +isis: procedure (type, parameter$ptr) external; + declare type byte, + parameter$ptr address; +end isis; + +open: procedure (conn$p, path$p, access, echo, status$p) external; + declare (conn$p, path$p, access, echo, status$p) address; +end open; + +close: procedure (conn, status$p) external; + declare (conn, status$p) address; +end close; + +read: procedure (conn, buff$p, count, actual$p, status$p) external; + declare (conn, buff$p, count, actual$p, status$p) address; +end read; + +write: procedure (conn, buff$p, count, status$p) external; + declare (conn, buff$p, count, status$p) address; +end write; + +seek: procedure (conn, mode, block$p, byte$p, status$p) external; + declare (conn, mode, block$p, byte$p, status$p) address; +end seek; + +rescan: procedure (conn, status$p) external; + declare (conn, status$p) address; +end rescan; + +spath: procedure (path$p, info$p, status$p) external; + declare (path$p, info$p, status$p) address; +end spath; + +delete: procedure (path$p, status$p) external; + declare (path$p, status$p) address; +end delete; + +rename: procedure (old$p, new$p, status$p) external; + declare (old$p, new$p, status$p) address; +end rename; + +attrib: procedure (path$p, attrib, on$off, status$p) external; + declare (path$p, attrib, on$off, status$p) address; +end attrib; + +consol: procedure (ci$p, co$p, status$p) external; + declare (ci$p, co$p, status$p) address; +end consol; + +load: procedure (path$p, load$offset, switch, entry$p, status$p) external; + declare (path$p, load$offset, switch, entry$p, status$p) address; +end load; + +whocon: procedure (conn, buff$p) external; + declare (conn, buff$p) address; +end whocon; + +error: procedure (error$num) external; + declare (error$num) address; +end error; + +de$time: procedure (dt$p, status$p) external; + declare (dt$p, status$p) address; +end de$time; + +filinf: procedure (file$table$p, mode, file$info$p, status$p) external; + declare (file$table$p, file$info$p, status$p) address, + mode byte; +end filinf; + +getd: procedure (did, conn$p, count, actual$p, table$p, status$p) external; + declare (did, conn$p, count, actual$p, table$p, status$p) address; +end getd; + +exit: procedure external; +end exit; + +ci: procedure byte external; +end ci; + +co: procedure (char) external; + declare (char) byte; +end co; + +ri: procedure byte external; +end ri; + +po: procedure (char) external; + declare (char) byte; +end po; + +lo: procedure (char) external; + declare (char) byte; +end lo; + +csts: procedure byte external; +end csts; + +iodef: procedure (type, entry) external; + declare type byte, + entry address; +end iodef; + +iochk: procedure byte external; +end iochk; + +ioset: procedure (value) external; + declare value byte; +end ioset; + +memck: procedure address external; +end memck; + +$list diff --git a/software/CPM/cpm3/plm80/ixref b/software/CPM/cpm3/plm80/ixref new file mode 100644 index 0000000..d7d1d30 Binary files /dev/null and b/software/CPM/cpm3/plm80/ixref differ diff --git a/software/CPM/cpm3/plm80/lib b/software/CPM/cpm3/plm80/lib new file mode 100644 index 0000000..2913c75 Binary files /dev/null and b/software/CPM/cpm3/plm80/lib differ diff --git a/software/CPM/cpm3/plm80/link b/software/CPM/cpm3/plm80/link new file mode 100644 index 0000000..f44e717 Binary files /dev/null and b/software/CPM/cpm3/plm80/link differ diff --git a/software/CPM/cpm3/plm80/link.ovl b/software/CPM/cpm3/plm80/link.ovl new file mode 100644 index 0000000..31aa7a2 Binary files /dev/null and b/software/CPM/cpm3/plm80/link.ovl differ diff --git a/software/CPM/cpm3/plm80/locate b/software/CPM/cpm3/plm80/locate new file mode 100644 index 0000000..0020ac7 Binary files /dev/null and b/software/CPM/cpm3/plm80/locate differ diff --git a/software/CPM/cpm3/plm80/objhex b/software/CPM/cpm3/plm80/objhex new file mode 100644 index 0000000..3ebad01 Binary files /dev/null and b/software/CPM/cpm3/plm80/objhex differ diff --git a/software/CPM/cpm3/plm80/plm51.lib b/software/CPM/cpm3/plm80/plm51.lib new file mode 100644 index 0000000..ea1038a Binary files /dev/null and b/software/CPM/cpm3/plm80/plm51.lib differ diff --git a/software/CPM/cpm3/plm80/plm80 b/software/CPM/cpm3/plm80/plm80 new file mode 100644 index 0000000..12872f5 Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80 differ diff --git a/software/CPM/cpm3/plm80/plm80.com b/software/CPM/cpm3/plm80/plm80.com new file mode 100644 index 0000000..12872f5 Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.com differ diff --git a/software/CPM/cpm3/plm80/plm80.lib b/software/CPM/cpm3/plm80/plm80.lib new file mode 100644 index 0000000..ebb685a Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.lib differ diff --git a/software/CPM/cpm3/plm80/plm80.ov0 b/software/CPM/cpm3/plm80/plm80.ov0 new file mode 100644 index 0000000..19f0a5d Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov0 differ diff --git a/software/CPM/cpm3/plm80/plm80.ov1 b/software/CPM/cpm3/plm80/plm80.ov1 new file mode 100644 index 0000000..a5c0ad2 Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov1 differ diff --git a/software/CPM/cpm3/plm80/plm80.ov2 b/software/CPM/cpm3/plm80/plm80.ov2 new file mode 100644 index 0000000..35ada06 Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov2 differ diff --git a/software/CPM/cpm3/plm80/plm80.ov3 b/software/CPM/cpm3/plm80/plm80.ov3 new file mode 100644 index 0000000..9ee405f Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov3 differ diff --git a/software/CPM/cpm3/plm80/plm80.ov4 b/software/CPM/cpm3/plm80/plm80.ov4 new file mode 100644 index 0000000..d89058c Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov4 differ diff --git a/software/CPM/cpm3/plm80/plm80.ov5 b/software/CPM/cpm3/plm80/plm80.ov5 new file mode 100644 index 0000000..42d4e4e Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov5 differ diff --git a/software/CPM/cpm3/plm80/plm80.ov6 b/software/CPM/cpm3/plm80/plm80.ov6 new file mode 100644 index 0000000..7873ff3 Binary files /dev/null and b/software/CPM/cpm3/plm80/plm80.ov6 differ diff --git a/software/CPM/cpm3/plm80/submit b/software/CPM/cpm3/plm80/submit new file mode 100644 index 0000000..d9a6e2f Binary files /dev/null and b/software/CPM/cpm3/plm80/submit differ diff --git a/software/CPM/cpm3/plm80/system.lib b/software/CPM/cpm3/plm80/system.lib new file mode 100644 index 0000000..c6e06ef Binary files /dev/null and b/software/CPM/cpm3/plm80/system.lib differ diff --git a/software/CPM/cpm3/prs0mov.asm b/software/CPM/cpm3/prs0mov.asm new file mode 100644 index 0000000..cc03140 --- /dev/null +++ b/software/CPM/cpm3/prs0mov.asm @@ -0,0 +1,99 @@ +VERSION EQU 30 +; SID RELOCATOR PROGRAM, INCLUDED WITH THE MODULE TO PERFORM +; THE MOVE FROM 200H TO THE DESTINATION ADDRESS + ORG 100H +STACK EQU 200H +BDOS EQU 0005H +PRNT EQU 9 ;BDOS PRINT FUNCTION +MODULE EQU 200H ;MODULE ADDRESS +LXIM equ 01h +; + db LXIM + ds 2 +; lxi b,00 ;set at merge +; + JMP START + +; PATCH AREA, DATE, VERSION & SERIAL NOS. + + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0,0,0,0 + dw 0,0,0,0,0 + + db 'CP/M Version 3.0' + maclib makedate + @LCOPY ;[JCE] Copyright & build date moved to their own + @BDATE ; files. + db 0,0,0,0 ; patch bit map + db '654321' ; Serial no. + +SIGNON: DB 'CP/M 3 SID - Version ' + DB VERSION/10+'0','.' + DB VERSION MOD 10 + '0','$' +START: LXI SP,STACK + PUSH B + PUSH B + LXI D,SIGNON + MVI C,PRNT + CALL BDOS + POP B ;RECOVER LENGTH OF MOVE + LXI H,BDOS+2;ADDRESS FIELD OF JUMP TO BDOS (TOP MEMORY) + MOV A,M ;A HAS HIGH ORDER ADDRESS OF MEMORY TOP + DCR A ;PAGE DIRECTLY BELOW BDOS + SUB B ;A HAS HIGH ORDER ADDRESS OF RELOC AREA + MOV D,A + MVI E,0 ;D,E ADDRESSES BASE OF RELOC AREA + PUSH D ;SAVE FOR RELOCATION BELOW +; + LXI H,MODULE;READY FOR THE MOVE +MOVE: MOV A,B ;BC=0? + ORA C + JZ RELOC + DCX B ;COUNT MODULE SIZE DOWN TO ZERO + MOV A,M ;GET NEXT ABSOLUTE LOCATION + STAX D ;PLACE IT INTO THE RELOC AREA + INX D + INX H + JMP MOVE +; +RELOC: ;STORAGE MOVED, READY FOR RELOCATION +; HL ADDRESSES BEGINNING OF THE BIT MAP FOR RELOCATION + POP D ;RECALL BASE OF RELOCATION AREA + POP B ;RECALL MODULE LENGTH + PUSH H ;SAVE BIT MAP BASE IN STACK + MOV H,D ;RELOCATION BIAS IS IN D +; +REL0: MOV A,B ;BC=0? + ORA C + JZ ENDREL +; +; NOT END OF THE RELOCATION, MAY BE INTO NEXT BYTE OF BIT MAP + DCX B ;COUNT LENGTH DOWN + MOV A,E + ANI 111B ;0 CAUSES FETCH OF NEXT BYTE + JNZ REL1 +; FETCH BIT MAP FROM STACKED ADDRESS + XTHL + MOV A,M ;NEXT 8 BITS OF MAP + INX H + XTHL ;BASE ADDRESS GOES BACK TO STACK + MOV L,A ;L HOLDS THE MAP AS WE PROCESS 8 LOCATIONS +REL1: MOV A,L + RAL ;CY SET TO 1 IF RELOCATION NECESSARY + MOV L,A ;BACK TO L FOR NEXT TIME AROUND + JNC REL2 ;SKIP RELOCATION IF CY=0 +; +; CURRENT ADDRESS REQUIRES RELOCATION + LDAX D + ADD H ;APPLY BIAS IN H + STAX D +REL2: INX D ;TO NEXT ADDRESS + JMP REL0 ;FOR ANOTHER BYTE TO RELOCATE +; +ENDREL: ;END OF RELOCATION + POP D ;CLEAR STACKED ADDRESS + MVI L,0 + PCHL ;GO TO RELOCATED PROGRAM + END + \ No newline at end of file diff --git a/software/CPM/cpm3/prs1asm.asm b/software/CPM/cpm3/prs1asm.asm new file mode 100644 index 0000000..00933d5 --- /dev/null +++ b/software/CPM/cpm3/prs1asm.asm @@ -0,0 +1,1093 @@ +; CP/M DEBUGGER DISASSEMBLER/ASSEMBLER MODULE + TITLE 'SYMBOLIC INTERACTIVE DEBUGGER (ASMOD) 12/16/77' +; +; COPYRIGHT (C) 1976, 1977 +; DIGITAL RESEARCH +; BOX 579 PACIFIC GROVE, CA +; 93950 +; +FALSE EQU 0 ;VALUE OF "FALSE" +TRUE EQU NOT FALSE ;VALUE OF "TRUE" +ISIS2 EQU FALSE ;TRUE IF ASSEMBLING FOR "IS" +DEBUG EQU FALSE ;TRUE IF CHECK-OUT TIME +RELOC EQU FALSE ;TRUE IF GENERATING RELOC IMAGE +RMAC EQU TRUE ;[JCE] True if using RMAC to link & relocate +; +; [JCE] Use of RMAC makes relocation easier +; + IF DEBUG + ORG 1000H ;IN LOW MEMORY FOR DEBUG + ELSE + IF ISIS2 + ORG 0E500H + ELSE + IF RELOC + ORG 0000H ;READY FOR RELOCATION + ELSE + IF RMAC ;[JCE] No ORGs. + cseg ;[JCE] + ELSE ;[JCE] + ORG 0D000H ;DEBUG IN 64K + ENDIF + ENDIF + ENDIF + ENDIF +; +JLOC1 EQU 0005H ;BDOS JUMP LOCATION +; +; +; ENTRY POINTS FOR DEBUGGING MONITOR +DEMON EQU $+680H +BEGIN EQU DEMON+03H ;BEGINNING OF DEBUGGING MONITOR +GETBUFF EQU DEMON+9H ;READ BUFFER +GNC EQU DEMON+0CH +PCHAR EQU DEMON+0FH ;PRINT CHARACTER IN REG A +PBYTE EQU DEMON+12H ;PRINT BYTE +PADDX EQU DEMON+15H ;PRINT ADDRESS IN REG D,E +SCANEXP EQU DEMON+18H ;SCAN 0,1, OR 2 EXPRESSIONS +BREAK EQU DEMON+1EH ;CHECK FOR BREAK AT CONSOLE +PRLABEL EQU DEMON+21H ;PRINT SYMBOLIC LABEL +; +; +CI EQU GNC ;SYNONYM FOR GNC +; +CR EQU 0DH +LF EQU 0AH +TAB EQU 09H +; + IF RMAC + PUBLIC MODBAS, DISIN, DISEN, ASSEM, DISPC, DISPM, DISPG + ENDIF + +MODBAS: ;MODULE LOCATION + JMP BEGIN ;ADDRESS FIELD IS ALTERED AT "BEGIN" +DISIN: DB 0,0,0 ;FILLER (USED IN SYMBOL TABLE) +DISEN: JMP DISENT +ASSEM: JMP ASMEN ;ENTRY POINT FOR ASSEMBLER +DISPC: +PC: DS 2 ;CURRENT FAKED PC DURING DISASSEMBLY +DISPM: +MPC: DS 2 ;MAX VALUE FOR PC (STOP ADDRESS) +DISPG: +PAGM: DS 1 ;PAGE MODE IF NON ZERO +TPC: DS 2 ;TEMPORARY PC FOR ASSEMBLER RESTORE ON ERROR +OLDSP: DS 2 ;ENTRY SP VALUE +; +; +CO: ;PRINT CHARACTER IN REGISTER C + PUSH PSW + MOV A,C ;PCHAR EXPECTS VALUE IN C + CALL PCHAR ;TO PRINT THE CHARACTER + POP PSW + RET +; +; +DELIM: ;CHECK FOR DELIMITER + CPI ' ' + RZ + CPI TAB + RZ + CPI ',' + RZ + CPI CR + RZ + CPI 7FH + JZ ASMEN ;RESTART CURRENT LINE + RET +; +CRLF: ;RETURN AND LINE FEED + MVI C,CR + CALL CO + MVI C,LF + CALL CO + RET +; +SCAN: ;FILL OPCODE WITH CHARACTERS +; +SC1: CALL CI +SCAN0: ;ENTER HERE IF CHARACTER SCANNED + CPI CR + JZ ERR + CALL DELIM + JZ SC1 +; +; CLEAR BUFFER + MVI C,4 + LXI H,OPCODE +SC0: MVI M,' ' + INX H + DCR C + JNZ SC0 +; +; GARBAGE REMOVED AT BEGINNING OF SCAN + MVI C,5 + LXI H,OPCODE +SC2: MOV M,A ;STORE CHARACTER + CALL CI + CALL DELIM + JZ SC3 + INX H + DCR C + JZ ERR ;TOO LONG + JMP SC2 +; +SC3: ;END OF CURRENT SCAN, COMPARE FOR EMPTY + LDA OPCODE + CPI ' ' + RET +; +HEX: ;CONVERT ACCUMULATOR TO HEXADECIMAL + SUI '0' + CPI 10 + RC ;'0' - '9' + ADI ('0'-'A'+10) AND 0FFH + CPI 16 + RC + JMP ERR +; +GADDR: ;GET ADDRESS VALUE TO B (HIGH ORDER) AND C (LOW) WITH COPY OF C IN A + CALL SCANEXP ;READ 1 EXPRESSION + DCR A ;GOES TO ZERO + JNZ ERR ;? IF NOT A SINGLE EXPRESSION + XCHG ;ADDRESS OF EXPRESSION TO HL + MOV C,M ;LOW BYTE + INX H + MOV B,M ;HIGH BYTE + MOV A,C ;COPY OF LOW BYTE TO A + DCR B + INR B ;SETS ZERO FLAG IF B IS ZERO + RET +; +GBYTE: ;GET BYTE VALUE TO ACCUMULATOR AND C, CHECK FOR HIGH ORDER ZERO + CALL GADDR + JNZ ERR + RET +; +; +; ************************************************************ +; ********* ASSEMBLER MODULE STARTS HERE ********************* +; ************************************************************ +; +ADJ: ;MOVE REGISTER INDICATOR TO MIDDLE FIELD OF CODE + RAL + RAL + RAL + ANI 111000B + RET +; +ADJ4: ;MOVE TO LEFT BY 4 AND MASK + RAL + RAL + RAL + RAL + ANI 110000B + RET +; +SEAR2: ;SAME AS SEAR, EXCEPT 2 CHARACTER MATCH +; H,L ADDRESS TABLE TO MATCH ON + XCHG + LHLD OPCODE ;2ND BYTE IN D, 1ST BYTE IN E + XCHG ;H,L ADDRESS TABLE +SEA0: MOV A,E ;GET 1ST BYTE + CMP M ;MATCH? + JNZ SEA1 ;TO ADDRESS NEXT ELT + INX H ;NEXT TO MATCH + MOV A,D ;2ND CHAR + CMP M + RZ ;MATCH AT CURRENT ENTRY + DCX H +SEA1: DCX H + DCX H ;ADDRESSES NEXT ELEMENT + DCR C + JNZ SEA0 ;FOR ANOTHER COMPARE +; +; NO MATCH IN TABLE, RETURN WITH NON-ZERO VALUE + DCR C + RET +; +; +SEAR: ;SEARCH FOR MATCH IN OPCODE TABLE, LENGTH OF TABLE IN REG-C +; D,E CONTAINS ADDRESS OF BINARY EQUIVALENT OF OPCODE +; H,L ADDRESS FOUR CHARACTER OPCODE TO MATCH +; OPCODE CONTAINS FOUR BYTE OPCODE TYPED AT CONSOLE +; RETURNS WITH ZERO VALUE IF OPCOE FOUND, WITH D,E +; ADDRESSING PROPER BYTE, NON-ZERO IF NOT FOUND. + MVI B,4 ;4 CHARACTER MATCH +; + PUSH D ;SAVE THE CURRENT BYTE VALUE LOCATION + LXI D,OPCODE ;ADDRESS CHARACTERS TYPED +SE1: LDAX D ;POINT TO FIRST BYTE TO MATCH + CMP M ;SAME CHARACTER AS TABLE? + JNZ SE2 ;NO, SKIP TO NXT TABLE ENTRY + INX H ;YES, LOOK AT NEXT CHARACTER + INX D ;MOVE TO NEXT CHARACTER TYPED + DCR B ;DECREMENT CHARACTER COUNT + JNZ SE1 ;MORE TO MATCH? +; +; COMPLETE MATCH, RETURN WITH D,E ADDRESSING BYTE VALUE + POP D + RET +; +; MISMATCH, FINISH COUNT +SE2: INX H + DCR B + JNZ SE2 +; +; H,L AT END OF FOUR BYTE AREA, MOVE BACK 8 + LXI D,-8 + DAD D ;H,L READY FOR NXT MATCH +; + POP D ;RESTORE BYTE POINTER + INX D ;MOVE TO NEXT IN CASE MATCH OK + DCR C ;MORE OPCODES TO MATCH? + JNZ SEAR ;LOOK FOR MORE +; +; NO MATCH FOUND IN TABLE, SET NON-ZERO VALUE AND RETURN + DCR C + RET +; +; +GETREG: ;SCAN FOR SIMPLE REGISTER REFERENCE + PUSH B + CALL SCAN + JZ ERR + MVI C,8 ;8 REGISTERS + LXI H,SREG ;SIMPLE REGISTERS + CALL SEAR2 ;LOOK FOR 2 CHAR MATCH + JNZ ERR + DCR C + MOV A,C + POP B + RET +; +GETD: ;GET DOUBLE PRECISION REGISTER + PUSH B + CALL SCAN + JZ ERR + MVI C,5 + LXI H,DREG + CALL SEAR + JNZ ERR + DCR C + MOV A,C + POP B + RET +; +GETDR: ;GET DOUBLE REGISTER (BDHSP) + CALL GETD + CPI 4 ;PSW? + JZ ERR + RET +; +GETPR: ;GET PUSH/POP REGISTER (BDH OR PSW) + CALL GETD + CPI 3 + JZ ERR + CPI 4 + RNZ + DCR A ;PSW MUST BE ADJUSTED + RET +; +GCON: ;GET CONDITION CODE +; BUFFER IS SCANNED, MOVE LEFT BEFORE COMPARE + LXI H,OPCODE + LXI D,OPCODE+1 + MVI C,2 ;MOVE TWO CHARACTERS +MOP: LDAX D ;LOAD CHARACTER TO MOVE + MOV M,A ;MOVE LEFT + INX H ;NEXT DESTINATION + INX D ;NEXT SOURCE + DCR C + JNZ MOP +; +; MUST BE BLANK AT END + LDAX D + CPI ' ' + JNZ ERR + MOV M,A +; +; NOW READY TO DO THE COMPARE + LXI H,CREG + MVI C,8 + CALL SEAR2 + JNZ ERR + DCR C + MOV A,C + CALL ADJ ;MOVE TO BITS 3,4,5 OF BYTE (LSB = 0) + RET +; +GCONA: ;GET CONDITION CODE TO REGISTER A, DOUBLE ADDRESS TO B,C + CALL GCON ;CONDITION CODE TO A + PUSH PSW + CALL GADDR ;VALUE TO B,C + POP PSW +; INCLUDE HIGH ORDER 11'S FOR J AND C OPCODES + ORI 11000000B + RET +; +SETMD: ;SET MEMORY AT LOCATION PC TO VALUE ADDRESSED BY D + LDAX D ;VALUE TO ACCUM +; +SETM: ;SET MEMORY AT LOCATION PC TO VALUE IN ACCUM, INC PC + LHLD TPC + MOV M,A ;STORE AT PC + INX H ;PC=PC+1 + SHLD TPC + RET +; +; +; +GETOP: ;PROCESS NEXT OPCODE + CALL CI + CPI CR + JZ GOBACK ;RETURN IF SIMPLE INPUT + CPI '.' ;ALTERNATE RETURN IS . + JZ GOBACK + CALL SCAN0 + JZ ERR +; +CHK0: ;CHECK FOR OPCODES WITH NO OPERANDS + MVI C,17 ;LENGTH OF GROUP-0 + LXI H,ETAB1 ;END OF GROUP-0 + LXI D,TABLE ;FIRST BYTE VALUE + CALL SEAR ;LOOK FOR MATCH + JNZ CHK1 ;NO MATCH, CHECK FOR GROUP-1 +; +; MATCHED OPCODE, D,E ADDRESS BYTE VALUE + JMP SETMD ;SET MEMORY AT PC AND INC PC +; +; CHECK GROUP-1 VALUES +CHK1: MVI C,10 ;LENGTH OF GROUP-1 + LXI H,ETAB2 + CALL SEAR ;D,E REMAIN SET + JNZ CHK2 ;NO MATCH, CHECK NEXT GROUP +; +; MATCH FOUND, SET BYTE AND GET BYTE OPERAND + CALL SETMD + CALL GBYTE ;GETS BYTE VALUE TO ACCUMULATOR + JMP SETM ;PUTS BYTE VALUE TO MEMORY AT PC +; +; CHECK GROUP-2 OPCODES, REQUIRE DOUBLE BYTE OPERAND +CHK2: MVI C,6 + LXI H,ETAB3 + CALL SEAR + JNZ CHK3 ;NO MATCH +; +; FOUND MATCH, GET OPCODE BIT PATTERN AND STORE + CALL SETMD +OP2: ;ENTER HERE FOR DOUBLE BYTE OPERANDS + CALL GADDR ;VALUE IN B,A + CALL SETM + MOV A,B + JMP SETM +; +CHK3: ;CHECK FOR MOV INSTRUCTION + MVI C,1 + LXI H,PMOV + CALL SEAR + JNZ CHK4 +; +; MOV INSTRUCTION GET DESTINATION OPERAND + CALL GETREG ;VALUE TO ACCUMULATOR + CALL ADJ + MOV B,A ;SAVE IN B + MVI C,01000000B ;BIT PATTERN FOR MOV +; +OP1: ;GET NEXT OPERAND FOR MOV, FIRST OPERAND FOR ACCUM/REG OPERATOR + CALL GETREG + ORA C ;SETS HIGH ORDER TWO BITS + ORA B ;SETS DESTINATION/OPERATOR + JMP SETM +; +CHK4: ;CHECK FOR GROUP-5 (ACCUM/REG OPERATOR) + MVI C,8 + LXI H,ETAB5 + CALL SEAR + JNZ CHK5 +; +; ACCUM/REG INSTRUCTION, C COUNTS OPERATORS AS SEARCH PROCEEDS + DCR C + MOV A,C + CALL ADJ + MOV B,A +; OPERATOR NUMBER (SHIFTED) SAVED FOR LATER MASK + MVI C,10000000B ;ACCUM/REG OPERATOR INDICATOR + JMP OP1 ;GETS OPERAND AND SAVES BYTE IN MEMORY +; +CHK5: ;MAY BE INR/DCR + MVI C,2 + LXI H,PDCR + CALL SEAR + JNZ CHK6 +; +; C=2 IF DCR, =1 IF INR + INR C ;+1 + INR C ;+2 + INR C ;+3 + CALL GETREG ;VALUE TO ACCUM + CALL ADJ + ORA C ;FILL PROPER INSTRUCTION INDICATOR + JMP SETM +; +CHK6: ;MAY BE A MVI INSTRUCTION + MVI C,1 + LXI H,PMVI + CALL SEAR + JNZ CHK7 +; +; MVI INSTRUCTION, GET REGISTER + CALL GETREG ;VALUE GOES TO ACCUMULATOR + CALL ADJ + ORI 110B + CALL SETM + CALL GBYTE + JMP SETM +; +CHK7: ;CHECK FOR GROUP-7 + MVI C,6 + LXI H,ETAB7 + CALL SEAR + JNZ CHK8 +; +; LXI,STAX,INX,DAD,LDA, OR DCX + MOV A,C ;A=1...6 + CPI 4 + JC IN0 +; +; MUST BE DAD,LDA, OR DCX + ADI 5 ;CHANGES ACCUM TO 9,10, OR 11 +IN0: ;ACCUMULATOR CONTAINS CODE, SAVE IT + MOV B,A + CALL GETDR ;DOUBLE REGISTER VALUE TO ACCUM + CALL ADJ4 ;ADJUST VALUE TO MIDDLE FIELD + ORA B ;FILLS REMAINING BITS + CALL SETM +; MAY BE LXI + ANI 11001111B + CPI 1 + RNZ ;NOT LXI + JMP OP2 ;PICK UP OPERAND +; +; +; +CHK8: ;RST? + MVI C,1 + LXI H,PRST + CALL SEAR + JNZ CHK9 +; +; RST, GET OPERAND + CALL GBYTE + CPI 8 + JNC ERR + CALL ADJ + ORI 11000111B + JMP SETM +; +CHK9: ;POP/PUSH? + MVI C,2 + LXI H,PPOP+4 + CALL SEAR + JNZ CHK10 +; +; C=2 IF PUSH, 1 IF POP + DCR C + JNZ PP0 +; +; POP, SET BIT PATTERN + MVI C,11000001B + JMP PP1 +; +PP0: ;PUSH + MVI C,11000101B +PP1: CALL GETPR ;DOUBLE PUSH/POP REGISTER TO PROPER FIELD + CALL ADJ4 ;MOVE TO FIELD + ORA C + JMP SETM +; +CHK10: ;J/C/R? + LDA OPCODE + CPI 'J' + JNZ CHK11 + CALL GCONA +; CONDITION CODE TO FIELD IN ACCUM, ADDRESS TO B,C + ORI 010B + JMP FADDR ;FILL ADDRESS +; +CHK11: CPI 'C' + JNZ CHK12 + CALL GCONA + ORI 100B +; +FADDR: CALL SETM + MOV A,C + CALL SETM + MOV A,B + JMP SETM +; +CHK12: CPI 'R' + JNZ ERR + CALL GCON + ORI 11000000B + JMP SETM +; +; ************************************************************ +; *********** END OF ASSEMBLER MODULE, START DISASSEMBLER **** +; ************************************************************ +; +RDBYTE: LHLD MPC + PUSH D ;SAVE DE + XCHG ;MAX PC TO D,E + LHLD PC ;CURRENT PC +; SUBTRACT PC FROM MPC, STOP IF CARRY GENERATED + MOV A,E + SUB L + MOV A,D + SBB H + JNC RD0 +; +; PC EXCEEDS MPC, RETURN + LHLD OLDSP + SPHL ;RESTORE ORIGINAL STACK POINTER + RET +; +RD0: POP D ;RESTORE D,E + MOV A,M + INX H + SHLD PC + RET + +RGPRNT: INR A + ANI 07 + CPI 06 + JC RGP1 + ADI 03 +RGP1: CPI 05 + JC RGP2 + ADI 02 +RGP2: ADI 41H + MOV C,A + JMP CO + +DECODE: MOV B,A + ANI 0F0H + RRC + RRC + RRC + RRC + ADI 90H + DAA + ACI 40H + DAA + MOV C,A + CALL CO + MOV A,B + ANI 0FH + ADI 90H + DAA + ACI 40H + DAA + MOV C,A + JMP CO + +PRINT: MVI B,4 +P1: MOV C,M + CALL CO + INX H + DCR B + JNZ P1 + MVI C,' ' + JMP CO +; +; EXTRACT THE REGISTER FIELD FROM THE OPCODE +XTRACT: MOV A,D + ANI 0011$1000B + RRC + RRC + RRC + RET +; +; PRINT CONDITION CODE +CCPRNT: CALL XTRACT + ADD A + MOV C,A + LXI H,CCODE + DAD B + MOV C,M + CALL CO + INX H + MOV C,M + CALL CO + MVI C,' ' + CALL CO + JMP CO + +; PRINT REGISTER REFERENCE +RPPRNT: CALL XTRACT + ANI 06 + CPI 06 + JNZ RGPRNT + MVI C,'S' + CALL CO + MVI C,'P' + JMP CO +; +; +PRPC: ;PRINT CRLF FOLLOWED BY PC VALUE + CALL CRLF +; (ENTER HERE FROM DISASSEMBLER) +PRPC0: LHLD PC + MOV A,H + CALL DECODE + MOV A,L + CALL DECODE + MVI C,' ' + CALL CO + CALL CO + RET +; +DISENT: ;ENTER HERE FROM DEBUGGER + LXI H,0 + DAD SP + SHLD OLDSP ;SP SAVED FOR LATER RETURN +; +; CHECK FOR PAGE MODE DISPLAY + LDA PAGM ;GET PAGE MODE (NUMBER OF LINES TO PRINT) + ORA A ;SET FLAGS + JZ DISASM ;NOT PAGE MODE +; +; SET MPC TO 0FFFFH + LXI H,0FFFFH + SHLD MPC +; 255 IMPLIES TRACE MODE + INR A + JNZ DISASM ;NOT TRACE MODE IF BR +; TRACE MODE, SET TO 1 AND IGNORE ADDRESS FIELD + INR A ;1 IN ACC + STA PAGM + LHLD PC ;RECOVER PC + JMP DIS1 +; +; +DISASM: +; CHECK FOR BREAK AT CONSOLE + CALL BREAK + JNZ GOBACK +; +; CHECK TO SEE IF ENOUGH LINES PRINTED IN PAGE MODE + LXI H,PAGM + MOV A,M + ORA A ;ZERO? + JZ DIS0 ;JMP IF NOT PAGE MODE +; +; PAGE MODE, DECREMENT AND CHECK FOR ZERO + DCR M + JZ GOBACK +; +DIS0: LHLD PC ;CURRENT PC + CALL PRLABEL ;OPTIONAL LABEL + CALL CRLF ;NEW LINE + MVI C,' ' + CALL CO + CALL CO ;TWO LEADING BLANKS + CALL PRPC0 ;PRINT THE VALUE +DIS1: CALL RDBYTE +; SAVE THE OPCODE IN THE D REGISTER + MOV D,A +; SEARCH THE FIRST 17 ITEMS FOR SIMPLE OPCODES +; EI (FB) THROUGH NOP (00). NOTE THAT THE SEARCH PROCEEDS +; THROUGH "TABLE" STARTING AT THE BEGINNING, BUT THE OPCODES +; ARE ACTUALLY STORED IN SYMBOLIC FORM IN REVERSE ORDER. +; + LXI H,TABLE + LXI B,17 ;FIRST 17 SIMPLE OPCODES +GROUP1: CMP M ;TABLE VALUE = OPCODE? + JZ TYPE1 ;SKIP TO PRINT IF SO + INX H ;MOVE TO THE NEXT TABLE ELEMENT + DCR C ;COUNT THE SIMPLE OPCODES DOWN + JNZ GROUP1 ;TRY FOR ANOTHER +; +; NOT A SIMPLE OPERATION CODE, CHECK FOR IMMEDIATE OP +; ADI, ACI, OUT, SUI, IN, SBI, ANI, XRI, ORI, CPI + MVI C,10 +GROUP2: CMP M + JZ TYPE2 + INX H + DCR C + JNZ GROUP2 +; +; NOT AN IMMEDIATE OPERATION, CHECK FOR +; SHLD LHLD STA LDA JMP OR CALL + MVI C,6 +GROUP3: CMP M + JZ TYPE3 + INX H + DCR C + JNZ GROUP3 +; +; NOT TYPE3 OPERATION CODE, CHECK FOR MOV +; BY MASKING THE HIGH ORDER TWO FIBITS - +; XX00 0000 IS PRODUCED IN THE ACCUMULATOR + ANI 0C0H +; MOV IS GIVEN BY 01 DDD SSS (DDD IS DEST, SSS IS SOURCE) + CPI 40H + JZ MOVOP +; +; NOT A MOV INSTRUCTION, CHECK FOR ACCUMLATOR-REGISTER OPS +; BIT PATTERN 10 CCC RRR CORRESPONDS TO +; ADD (0), ADC (1), SUB (2), SBB (3), ANA (4), +; XRA (5), ORA (6), CMP (7) + CPI 80H + JZ ACCREG +; +; NOT ACCUM-REGISTER, RESTORE OPCODE FOR FURTHER CHECKS + MOV A,D +; +; LOOK FOR INR, DCR, AND MVI OPERATIONS +; INR = 00 RRR 100, DCR = 00 RRR 101, MVI = 00 RRR 110 +; OR, INR = 00 RRR 4, DCR = 00 RRR 5, MVI = 00 RRR 6 + ANI 1100$0111B + SUI 04 +; INR GOES TO ZERO + JZ INRREG +; NOT INR, MAY BE DCR + DCR A + JZ DCRREG + DCR A +; NOT DCR, MAY BE MVI + JZ MVIREG +; NOT INR, DCR, OR MVI INSTRUCTION +; +; RESTORE THE OPCODE + MOV A,D +; LOOK FOR LXI STAX INX DAD LDAX DCX OPCODES +; LXI = 00 RR 0001, +; STAX= 00 RR 0010, +; INX = 00 RR 0011, +; DAD = 00 RR 1001, +; LDAX= 00 RR 1010 +; DCX = 00 RR 1011 + ANI 0C0H + JZ LXILST ;TO PROCESS FURTHER +; +; NOT ONE OF THE ABOVE, CHECK FURTHER +; MUST BE OF THE FORM - 11 XXX XXX + MOV A,D + ANI 0000$0111B ;TO EXTRACT THE RIGHTMOST BITS +; RETURN CONDITIONALS TAKE THE FORM 11 XXX 000 + JZ RETCON ;RETURN CONDITIONALLY +; JUMP CONDITIONALS TAKE THE FORM 11 XXX 010 = 2 + SUI 02 + JZ JMPCON +; CALL CONDITIONALS TAKE THE FORM 11 XXX 100 = 4 - 2 = 2 + SUI 02 + JZ CALLCON +; RST'S TAKE THE FORM 11 XXX 111 = 7 - 4 = 3 + SUI 03 + JZ RSTOP +; +; NONE OF THE ABOVE, PUSHES AND POP'S REMAIN + MOV A,D ;RESTORE OPCODE +; FIRST CAPTURE REMAINING OPCODES CB, D9, DD, ED, FD + ANI 0000$1000B ;THIS BIT RESET FOR POP,PUSH + JNZ N8080 ;NOT 8080 OPCODE IF SET + MOV A,D ;RESTORE IT +; PUSH = 11 XX0 101 = 5, POP = 11 XX0 001 = 1 + ANI 07 +; USE THE RESULTING VALUE TO INDEX TO REGISTER TABLE + MOV C,A + DCR A ;POP GOES TO 00 + LXI H,PPOP-1 + DAD B + CALL PRINT +; GET THE RELEVANT REGISTER + CALL XTRACT +; CHECK FOR PSW OPERATION CODE + CPI 06 + JNZ D6 + LXI H,PPSW + CALL PRINT + JMP DISASM +; +; PRINT RST XXX INSTRUCTION +RSTOP: LXI H,PRST + CALL PRINT + CALL XTRACT + CALL DECODE + JMP DISASM +; +; CALL CONDITIONAL 'C' +CALLCON: + MVI C,'C' + CALL CO + CALL CCPRNT + JMP PREXT ;TO PRINT THE ADDRESS +; +; JUMP CONDITIONAL 'J' +JMPCON: + MVI C,'J' + CALL CO + CALL CCPRNT + JMP PREXT ;TO PRINT THE ADDRESS +; +; RETURN CONDITIONAL 'R' +RETCON: + MVI C,'R' + CALL CO + CALL CCPRNT + JMP DISASM +; +; +; PROCESS ONE OF LXI STAX INX DAD LDAX DCX +LXILST: LXI H,PLXI +; CAPTURE 08, 10, 18, 20, 28, 30, AND 38 + MOV A,D ;GET OPCODE + ANI 111B ;RIGHTMOST BITS ZERO? + JZ N8080 ;NOT 8080 IF SO +; RECALL OPCODE TO DETERMINE WHICH ONE + MOV A,D +; FIND THE PARTICULAR OPCODE + ANI 0FH +; LXI HAS LEAST SIGNIFICANT FOUR BITS = 0001 + DCR A + JZ LXIREG +; STAX 0010 BECOMES 0001 = 1 +; INX 0011 BECOMES 0010 = 2 +; DAD 1001 BECOMES 1000 = 8 +; LDAX 1010 BECOMES 1001 = 9 +; DCX 1011 BECOMES 1010 = 10 + CPI 03 + JC D4 +; MUST BE DAD, LDAX OR DCX + SUI 05 +; DAD 8 BECOMES 3 +; LDAX9 BECOMES 4 +; DCX10 BECOMES 5 +; ACCUMULATOR NORMALIZED +D4: ADD A + ADD A +; VALUE IN ACCUM MULTIPLIED BY FOUR + MOV C,A + DAD B + CALL PRINT +; STAX, INX, DAD, LDAX, OR DC X PRINTED, PRINT REGISTER + CALL RPPRNT + JMP DISASM +; +; PRINT REGISTER ADDRESSED BY HL (E.G., IN LXI) +LXIREG: CALL PRINT + CALL RPPRNT + MVI C,',' + CALL CO + JMP PREXT ;TO PRINT THE EXTENDED INSTRUCTION +; +; +MVIREG: LXI H,PMVI + CALL PRINT + CALL XTRACT + CALL RGPRNT + MVI C,',' + CALL CO + JMP DATA8 +; +DCRREG: LXI H,PDCR + JMP D5 +; +INRREG: LXI H,PINR +; +; PRINT THE INSTRUCTION GIVEN BY HL, FOLLOWED BY REGISTER +D5: CALL PRINT + CALL XTRACT +D6: CALL RGPRNT + JMP DISASM +; +; FOUND ACCUM REGISTER OPERATION - MIDDLE BITS GIVE PCODE +ACCREG: MOV A,D + ANI 38H ;SELECT OPCODE BITS + RRC ;OPCODE * 4 FOR LENGTH FOUR STRING + MOV C,A + LXI H,PADD ;ADDRESS THE ACCUM-REGISTER LIST + DAD B + CALL PRINT + JMP D9 +; +; MOV OPERATION FOUND +MOVOP: LXI H,PMOV + CALL PRINT + CALL XTRACT + CALL RGPRNT + MVI C,',' ;REGISTER DELIMITER + CALL CO +D9: MOV A,D + ANI 07 + CALL RGPRNT + JMP DISASM +; +; TYPE GROUP3: CALL JMP LDA STA LHLD SHLD +TYPE3: + MOV A,C ;*4 FOR LENGTH 4 + ADD A + ADD A + MOV C,A + LXI H,TAB3-4 + DAD B + CALL PRINT +; +; ARRIVE HERE TO PRINT THE ADDRESS FIELD +PREXT: CALL RDBYTE ;LOW ADDRESS TO A + PUSH PSW ;SAVE IT + CALL RDBYTE + MOV D,A ;SET HIGH ADDRESS + POP PSW ;RECALL LOW ADDRESS + MOV E,A ;DE IS THE ADDRESS TO PRINT + CALL PADDX + JMP DISASM +; +; TYPE THE IMMEDIATE OPCODES (INCLUDING IN/OUT) +TYPE2: MOV A,C ;TYPE IMMEDIATE OPERATION CODE + ADD A ;*2 + ADD A ;*4 FOR LENGTH FOUR CHAR STRING + MOV C,A ;BC = INDEX * 4 FOR OPCODE + LXI H,TAB2-4 + DAD B + CALL PRINT +; +; ARRIVE HERE TO PRINT THE IMMEDIATE VALUE +DATA8: CALL RDBYTE + CALL PBYTE ;BYTE VALUE PRINTED + JMP DISASM +; +; FOUND OPCODE IN TABLE, POSITION GIVEN +; BY COUNT IN BC (NOTE THAT C IS COUNTED DOWN, WHILE +; INDEX WAS MOVING UP THE TABLE DURING THE SEARCH) +TYPE1: MOV A,C ;TYPE SIMPLE OPCODES FROM GROUP 1 + ADD A ;POSITION * 2 + ADD A ;POSITION * 4 (FOUR CHAR CODES) + MOV C,A ;BC IS INDEX * 4 OF OPCODE + LXI H,TAB1-4 + DAD B ;HL NOW HOLDS ADDRESS OF CODE TO PRINT + CALL PRINT + JMP DISASM +; +N8080: ;NOT AN 8080 OPERATION CODE + LXI H,DBOP + CALL PRINT ;PRINT THE '??=' + MOV A,D ;GET THE OPCODE + CALL PBYTE ;AND PRINT IT + JMP DISASM +; +ERR: ;ENTER HERE FOR ERROR REPORTING + CALL CRLF + MVI C,'?' + CALL CO +; + LHLD OLDSP + SPHL +; PC REMAINS UNCHANGED +; +; +ASMEN: ;ENTER HERE FROM DEBUGGER + LXI H,0 + DAD SP + SHLD OLDSP +; +ASM0: CALL PRPC ;PRINT PC VALUE + SHLD TPC ;SAVE PC VALUE + CALL GETBUFF ;FILL INPUT BUFFER + CALL GETOP ;GET OPERATION +; UPDATE PC, MUST BE CORRECT INPUT + LHLD TPC + SHLD PC + JMP ASM0 +; +GOBACK: LHLD OLDSP + SPHL + RET +; +; THE FIRST 17 ITEMS CORRESPOND TO SIMPLE OPCODES +; (NOP BACKWARD THROUGH EI) +TABLE: DB 000H,007H,00FH,017H ;NOP RLC RRC RAL + DB 01FH,027H,02FH,037H ;RAR DAA CMA STC + DB 03FH,076H,0C9H,0E3H ;CMC HLT RET XTHL + DB 0E9H,0EBH,0F3H,0F9H ;PCHL XCHG DI SPHL + DB 0FBH ;EI +; +; THE NEXT 10 ITEMS CORRESPOND TO THE IMMEDIATE OPCODES + DB 0C6H,0CEH,0D3H ;ADI ACI OUT + DB 0D6H,0DBH,0DEH,0E6H ;SUI IN SBI ANI + DB 0EEH,0F6H,0FEH ;XRI ORI + + DB 022H ;SHLD + DB 02AH,032H,03AH,0C3H + DB 0CDH +TAB1: DB 'EI ','SPHL','DI ','XCHG' + + + + DB 'PCHL','XTHL','RET ','HLT ' + + + DB 'CMC ','STC ','CMA ','DAA ' + + + DB 'RAR ','RAL ','RRC ','RLC ' + + +ETAB1: DB 'NOP ' +TAB2: DB 'CPI ','ORI ','XRI ','ANI ' + + + DB 'SBI ','IN ','SUI ','OUT ' + + + DB 'ACI ' +ETAB2: DB 'ADI ' +; +TAB3: DB 'CALL','JMP ','LDA ','STA ' + + + DB 'LHLD' +ETAB3: DB 'SHLD' +; + +PMOV: DB 'MOV ' +PADD: DB 'ADD ','ADC ','SUB ','SBB ' + + + DB 'ANA ','XRA ','ORA ' +ETAB5: DB 'CMP ' + +PINR: DB 'INR ' +PDCR: DB 'DCR ' +PMVI: DB 'MVI ' +PLXI: DB 'LXI ','STAX','INX ','DAD ' + + + DB 'LDAX' +ETAB7: DB 'DCX ' +; + +PRST: DB 'RST ' +PPSW: DB 'PSW ' +PPOP: DB 'POP ','PUSH' + +CCODE: DB 'NZ','Z ','NC','C ' + + DB 'PO','PE','P ' +CREG: DB 'M ' + + DB 'B ','C ','D ','E ' + DB 'H ','L ','M ' +SREG: DB 'A ' +; + DB 'B ','D ','H ','SP ' +DREG: DB 'PSW ' +; +DBOP: DB '??= ' +OPCODE: DS 4 + + IF RMAC ;[JCE] Pack the module out to exactly 680h bytes + DS 2 ; so that DEMON: shows as 0680 in the output + ENDIF ; from LINK.COM + + END diff --git a/software/CPM/cpm3/prs2mon.asm b/software/CPM/cpm3/prs2mon.asm new file mode 100644 index 0000000..01a9a38 --- /dev/null +++ b/software/CPM/cpm3/prs2mon.asm @@ -0,0 +1,3859 @@ +; cp/m symbolic debugger main module + title 'Symbolic Interactive Debugger (demon) 7/12/82' +; +; copyright (c) 1976,1977,1982 +; Digital Research +; box 579 Pacific Grove +; California 93950 +; +false equ 0 +true equ not false +isis2 equ false ;true if running under is interface +debug equ false ;true if debugging in cp/m environment +reloc equ false ;true if relocation image +rmac equ true ;[JCE] true if RMAC is used for relocation +rst6 equ true ;[JCE] true if using RST6 (RST7 is used by Z80 CPU) + + if debug + org 8000h ;base if debugging + else + if isis2 + org 0e500h + else + if reloc ;building relocation image + org 0000h ;base for relocation + else + if rmac + cseg ;[JCE] no ORG for RMAC + else + org 0d000h ;testing in 64 k + endif + endif + endif + endif +; +; + if rmac + extrn modbas, disin, disen, dispc, assem, dispm, dispg + public demon + else +modbas equ $ ;base of assem/disassem/debug +disin equ modbas+3 +disen equ disin+3 ;disassembler entry point +assem equ disen+3 ;assembler entry point +dispc equ assem+3 ;disassembler pc value +dispm equ dispc+2 ;disassembler pc max value +dispg equ dispm+2 ;disassembler page mode if non zero + ds 680h ;space for disassem/assem module + endif + +demon equ $ ;base of debugging monitor +bdose equ 0005h ;primary bdos entry point +; + if isis2 +bdos equ 103h ;real bdos entry +pcbase equ 3180h +spbase equ 3180h +dstart equ 107h ;start of debugger code +dbase equ dstart+2;start of loaded program +dnext equ dbase+2 ;next free address +bdbase equ 100h ;low bdos location +bdtop equ 3180h ;high bdos location + else +;bdos equ modbas+1806h +bdos equ demon+1186h +bdbase equ bdos ;base of bdos +bdtop equ bdbase+0d00h ;top of bdos +pcbase equ 100h ;default pc +spbase equ 100h ;default sp + endif +; +psize equ 12 ;number of assembly lines to list with 'l' +csize equ 64 ;command buffer size +ssize equ 50 ;local stack size +pbsize equ 8 ;number of permanent breaks +pbelt equ 4 ;size of each perm break element +; +; basic disk operating system constants +cif equ 1 +cof equ 2 +rif equ 3 +pof equ 4 +lof equ 5 +; +ids equ 7 +getf equ 10 ;fill buffer from console +chkio equ 11 ;check io status +lift equ 12 ;lift head on disk +opf equ 15 ;disk file open +DELF equ 19 ;delete file func +rdf equ 20 ;read disk file +WRITF equ 21 ;sequential write func +dmaf equ 26 ;set dma address +; +dbp equ 5bh ;disk buffer pointer +dbf equ 80h ;disk buffer address +dfcb equ 5ch ;disk file control block +fcb equ dfcb +fcbl equ 32 ;length of file control block +fcb2 equ fcb+16 ;second file control block +fdn equ 0 ;disk name +ffn equ 1 ;file name +ffnl equ 8 ;length of file name +fft equ 9 ;file type +fftl equ 3 ;length of file type +frl equ 12 ;reel number +frc equ 15 ;record count +fcr equ 32 ;current record +fln equ fcbl+1 ;fcb length including current rec +; +deof equ 1ah ;control-z (eof) +eof equ deof ;eof=deof +tab equ 09h ;horizontal tab +cr equ 0dh +lf equ 0ah +; + if debug +rstnum equ 6 ;use restart 6 for debug mode + else + if rst6 +rstnum equ 6 + else +rstnum equ 7 ;restart number + endif + endif +rstloc equ rstnum*8 ;restart location +rstin equ 0c7h or (rstnum shl 3) ;restart instruction +; +; template for programmed breakpoints +; --------- +; pch : pcl +; hlh : hll +; sph : spl +; ra : flg +; b : c +; d : e +; --------- +; flg field: mz0i0e1c (minus,zero,idc,even,carry) +; +aval equ 5 ;a register count in header +bval equ 6 +dval equ 7 +hval equ 8 +sval equ 9 +pval equ 10 +; +; +; demon entry points +TPATOP: + jmp trapad ;trap address for return in case interrupt + jmp begin +breaka: + jmp breakp +; useful entry points for programs running with ddt + jmp getbuff ;get another buffer full + jmp gnc ;get next character + jmp pchar ;print a character from a + jmp pbyte ;print byte in register a + jmp paddsy ;print address/symbol reference + jmp scanexp ;scan 0,1,2, or 3 expressions + jmp getval ;get value to h,l + jmp break ;check for console ready + jmp prlabel ;print label given by hl, if it exists +; +; +trapad: ;get the return address for this jump to bdos in case of +; a soft interrupt during bdos processing. + xthl ;pc to hl + shld retloc ;may not need it + xthl +trapjmp: +; address field of the following jump is set at "begin" + jmp 0000h +; +begin: +; set the bdos entry address to reflect the reduced memory +; size, as well as to trap the calls on the bdos. upon +; entry to "begin" the memory addresses are set as follows- +; bdose: jmp bdos +; modbas: jmp begin +; demon: jmp trapad +; trapad: ... +; trapjmp:jmp xxxx +; begin: ... +; bdose: bdos (or next module) +; +; change the memory map to appear as follows- +; bdose: jmp modbas +; modbas: jmp trapad +; demon: jmp trapad +; trapad: ... +; trapjmp:jmp bdos +; ... +; bdos: bdos (or next module) +; +; note that we do not assume that the next module above +; the debugger is the bdos. in fact, the next module up may +; be another copy of the debugger itself. +; + lhld bdose+1 ;address of next module in memory + shld trapjmp+1;change jump instruction address in trap code + lxi h,trapad;address of trap code + shld modbas+1 ;change address field of jump at beginning + lxi h,modbas ;base of dis/assembler code + shld bdose+1 ;change primary bdos entry address + shld sytop ;mark symbol table empty +; +; note that -a will change the bdose jump address to +; the base of the debugger module only, which removes the +; dis/assembler from the memory image. +; "a-" is implied if the load address exceeds modbas. +; + if isis2 + pop h ;recall return address to is.com + shld dbase ;set up as base of program + lxi h,beginr;read beginning of ddt + shld dstart;mark as debug mode +beginr: + endif + xra a ;zero acc + sta breaks ;clears break point count + sta dasm ;00 in dasm marks dis/assembler present + sta pbtrace ;perm break trace set false + sta tmode ;trace mode cleared +; + + if isis2 + lhld dbase ;base address of program + else + lxi h,pcbase + endif + shld dispc ;initial value for disassembler pc + shld disloc ;initial value for display + shld ploc ;pc in restart template + if isis2 + lxi h,pcbase ;primary entry to ddt, no high addr + endif + shld mload ;max load local + shld DEFLOAD + lxi h,spbase + lxi sp,stack-4 + push h ;initial sp + lxi h,10b ;initial psw + push h + dcx h + dcx h ;cleared + shld hloc ;h,l cleared + push h ;b,c cleared + push h ;d,e cleared + shld userbrk ;clear user break during trace/untrace +; + mvi a,jmp ;(jmp restart) + sta rstloc + lxi h,breaka ;break point subroutine + shld rstloc+1 ;restart location address field +; +; check for file name passed to demon, and load if present + lda fcb+ffn ;blank if no name passed + cpi ' ' + jz start +; +; use a zero bias and read + lda FCB+9 ;is COM specified? + cpi ' ' ;blank if not + jnz DEFREAD ;read it in +; + call COMDEF +; + lda FCB+010h ;sym file location + cpi ' ' ;is it there? + jz DEFREAD ;jump over if no sym file +; + lda FCB+019h + cpi ' ' ;is the type specified? + jnz DEFREAD ;bypass if present +; + call SYMDEF ;insert .SYM file type +; +DEFREAD: + lxi h,0 + jmp readn +; +; +; ********************************* +; * * +; * main command loop * +; * * +; ********************************* +; +start: + lxi sp,stack-12 ;initialize sp in case of error + call break ;any active characters? + mvi c,cif ;console input function + cnz trapad ;to clear the character + call crlf ;initial crlf + if debug + mvi a,'@' + else + mvi a,'#' + endif + call pchar ;output prompt +; +; get input buffer + call getbuff ;fill command buffer +; + call gnc ;get character + cpi cr + jz start +; check for negated command + lxi h,negcom + mvi m,0 + cpi '-' ;preceding "-"? + jnz poscom ;skip to positive command if not +; negated command, mark by negcom=true + dcr m ;00 becomes ff + call gnc ;to read the command +poscom: + sui 'A' ;legal character? + jc cerror ;command error + cpi 'Z'-'A'+1 + jnc cerror +; character in register a is command, must be in the range a-z + mov e,a ;index to e + mvi d,0 ;double precision index + lxi h,jmptab;base of table + dad d + dad d ;indexed + mov e,m ;lo byte + inx h + mov d,m ;ho byte + xchg ;to h,l + pchl ;gone... +; +jmptab: ;jump table to subroutines + dw assm ;a enter assembler language + dw cerror ;b + dw callpr ;c call program + dw display ;d display ram memory + dw EXECUTE ;e + dw fill ;f fill memory + dw goto ;g go to memory address + dw hexari ;h hexadecimal sum and difference + dw infcb ;i fill input file control block + dw cerror ;j + dw cerror ;k + dw lassm ;l list assembly language + dw move ;m move memory + dw cerror ;n + dw cerror ;o + dw permbrk ;p + dw 0 ;q [JCE] q=quit, as in SID-86 + dw read ;r read hexadecimal file + dw setmem ;s set memory command + dw trace ;t + dw untrace ;u + dw VALUE ;v + dw WRITE ;w + dw examine ;x examine and modify registers + dw cerror ;y + dw cerror ;z +; + +; +; ********************************* +; * * +; * a - assemble * +; * * +; ********************************* +; +assm: ;assembler language input +; check for assm present + call chkdis ;generate "no carry" if not there + jnc cerror ;not there + call scanexp ;read the expressions + ora a ;none given? + jnz assm0 ;skip to check for single parameter +; +; no parms, must be -a or a command + lda negcom ;must be set + ora a ;ff? + jz assm1 ;use old dispc for base + call nodis ;remove disassembler + jmp start ;for another command +; +assm0: + dcr a ;one expression expected + jnz cerror + call getval ;get expression to h,l + shld dispc +assm1: call assem + jmp start + +; +; ********************************* +; * * +; * c - call * +; * * +; ********************************* +callpr: +; call user program from ddt + call scanexp + jc cerror ;cannot be ,xxx + jz cerror ;cannot be c alone + call getval ;address to call in h,l + push h ;ready for call +; get remaining parameters +; reg-a contains 1,2,or 3 corresponding to number of values + lxi b,0 + dcr a + jnz call0 +; no parameters, stack two zeroes + push b + push b + jmp call2 +call0: ;at least one parameter + call getval + push h + dcr a + jnz call1 +; only one parameter, stack a zero + push b + jmp call2 +call1: ;must be two parameters for the call + call getval + push h +call2: ;set up parameters in b,c and d,e + pop d ;recall second parameter + pop b ;recall first parameter +; ready for the user program call + lxi h,start ;return address + xthl ;call address in h,l return in stack + pchl ;call user +; +; ********************************* +; * * +; * d - display RAM * +; * * +; ********************************* +; +; display memory, forms are +; d display from current display line +; dnnn set display line and assume d +; dnnn,mmm display nnn to mmm +; new display line is set to next to display +display: + call scanword + jz disp1 ;assume current disloc + call getval ;get value to h,l + jc disp0 ;carry set if ,b form + shld disloc ;otherwise dispc already set +disp0: ;get next value + ani 7fh ;in case ,b + dcr a + jz disp1 ;set half page mode + call getval + dcr a ;a,b,c not allowed + jnz cerror + jmp DISP2 ;store it +; +; +disp1: +;0 or 1 expn, display half screen + lhld disloc + lxi d,psize*16-1 + dad d + jnc DISP2 ;this is O.K. +; + lxi h,0FFFFh ;end of RAM in this case +disp2: + shld dismax +; +; display memory from disloc to dismax +disp3: +; + call break ;break key? + jnz start ;stop current expansion +; +; + lhld DISMAX ;check for the end + xchg ;DE=DISMAX + lhld disloc ;HL=current location + shld tdisp + xchg ;get set for check + call HLDE ;are we done? +; jz START ;yes + jc START ;yes + ;no we have more + call CRLF ;next line + lhld DISLOC ; + call paddr ;print line address + mvi a,':' + call pchar ;to delimit address + lda wdisp ;word display? + ora a + jz disp4 ;skip to byte display if not +; + mvi c,8 ;display 8 items per line (double bytes) +; full word display, get next value to de +word0: call blank ;blank delimiter + mov e,m ;low byte + inx h + mov d,m ;high byte + inx h ;ready for next address + xchg ;hl is address + call paddr ;print the address value + call blank + xchg ;back to DE with the address value + dcr c ; + push a ;save flags + call DISCOM + jc WORD1 + pop a ;restore flags + jnz word0 ;for another item + jmp disch ;to display characters +; +WORD1: + pop a +WORD2: + mov a,c + ora c ;are we at the end of the line? + jz DISCH ;yes, branc to char print + ;no, continue + call BLANK ! call BLANK ! call BLANK + call BLANK ! call BLANK ! call BLANK + dcr c ;finished this char + jnz WORD2 ;were not done yet + jmp DISCH + +disp4: + mvi c,16 ;counter +disp5: + call blank ;blank byte delimiter + mov a,m ;get next data byte + call pbyte ;print byte + dcr c ;decrement counter + push a ;save it + inx h + xchg ;DE = current address + lhld DISMAX ;HL = top of ram + call HLDE + xchg + +; jz DISP6 ;end of the line print blanks + + jc DISP6 ;go print the ending characters + pop a ;restore status + jnz DISP5 ;print next byte + jmp DISCH +; +DISP6: + pop a +DISP7: + mov a,c + ora c ;are we at the end of the line? + jz DISCH ;yes, branc to char print + ;no, continue + call BLANK ; + call BLANK ; + call BLANK ; + dcr c ;finished this char + jnz DISP7 ;were not done yet +; +; +;DISP7: +; dcr c ;to adjust the printer count +; mov a,c +; ora c +; jz DISP7 + +; call blank ;print the blank +; mov a,m ;print the last character +; call PBYTE ; +; inx h ;adjust the RAM pointer +; dcr c ;decrement counter +; mvi a,TRUE +; sta DISEND ;end flag +; +; +; +DISCH: ;display area in character form + shld disloc ;update for next write + lda negcom ;negated command? + ora a ;ff if negated + jnz DISP3 ;to skip the character display + lhld tdisp + xchg + call blank + mvi c,16 ;set up loop counter +; +disch0: ldax d ;get byte + call pgraph ;print if graphic character + inx d + lhld DISMAX ;compare for end of line + call HLDE ;HL=disloc + jz DISP8 ;we have reached the end + jc DISP3 + dcr c ;16 characters? + jnz DISCH0 ;no, do it again + jmp DISP3 +; +DISP8: + ldax d ;get last character + call PGRAPH ;print it +; + lda DISEND + cpi TRUE ; + jnz DISP3 ;we have finished + mvi a,FALSE + sta DISEND + jmp START +; +; +; +; +; ********************************* +; * * +; * e - execute * +; * * +; ********************************* +; +execute: + lda CURLEN + ora a + jz CERROR ; +; +EX1: + call FCBIN ;read in the FCBs +; Check for default + lda FCB+9 + cpi ' ' + jnz EX2 + call COMDEF +EX2: + lda FCB+019h + cpi ' ' + jnz EX3 + call SYMDEF +EX3: + lxi h,0 ;HL = BIAS for load into program + jmp readn ;now read it in +; +; +; ********************************* +; * * +; * f - fill * +; * * +; ********************************* +; +fill: + call scan3 ;expressions scanned bc , de , hl + mov a,h ;must be zero + ora a + jnz cerror +fill0: + call WRPCHK ;check for wrap +; + jc START ;back to start + call bcde ;end of fill? + jc start + mov a,l ;data + stax b ;to memory + inx b ;next to fill + jmp fill0 +; +; ********************************* +; * * +; * g - goto * +; * * +; ********************************* +; +goto: + xra a ;clear autou flag to indicate goto + sta autou ;autou=00 if goto, ff if tr/untr or perm brk + call crlf ;ready for go. + call scanexp ;0,1, or 2 exps + sta gobrks ;save go count + call getval + push h ;start address + call getval + shld gobrk1 ;primary break point + push h ;bkpt1 + call getval + shld gobrk2 ;secondary break point + mov b,h ;bkpt2 + mov c,l + pop d ;bkpt1 + pop h ;goto address + jmp gopr1 ;to skip autou=ff +; +gopr: +; mark autou with ff to indicate trace/untrace or perm break + push h ;save go address + lxi h,autou ;00 if "go" ff if tr/untr/perm brk + mvi m,0ffh ;mark as tr/untr/perm brk + pop h ;recall go address +; +gopr1: ;arrive here from "goto" above with autou=00 + di + jz gop1 ;no break points + jc gop0 +; set pc + shld ploc ;into machine state +gop0: ;set breaks + ani 7fh ;clear , bit + dcr a ;if 1 then skip (2,3 if breakpoints) + jz gop1 + call setbk ;break point from d,e + dcr a + jz gop1 +; second break point + mov e,c + mov d,b ;to d,e + call setbk ;second break point set +; +gop1: ;now check the permanent break points +; scan the permanent break point table, forms are +; count low(addr) high(addr) data + lxi h,pbtable + mvi c,pbsize ;number of elements +setper0: + push h ;save next table elt address + mov a,m ;low(count) + ora a ;00 if not in use + jz setper2 ;skip if not + inx h ;to low(addr) + mov e,m + inx h ;to high(addr) + mov d,m ;de is the break address + push h ;save data address-1 +; may be continue from current perm break address +; or a trace/untrace mode operation + lda autou ;00 if not + ora a ;set flags + jz setper1 ;set the break point +; this is a continuation from a perm break/or a trace/untrace + lhld ploc ;auto "u" necessary? + mov a,e ;low(addr) + cmp l ;=low(ploc)? + jnz setper1 ;skip if not + mov a,d ;high(addr) + cmp h ;=high(ploc)? + jnz setper1 ;skip if addr <> ploc +; +; address match, set auto "u" command + pop h ;recall data address-1 + pop h ;recall table address + shld pbloc ;table location for "u" + push h ;save for next iteration + mov a,m ;count + mvi m,0 ;cleared in memory + sta pbcnt ;marks as auto u command necessary + jmp setper2 ;to iterate +; +setper1: + ;break is not at current address + pop h ;recall data address-1 + inx h ;.data + ldax d ;memory data + mov m,a ;saved in the table + xchg ;memory addr to hl + mvi m,rstin ;set to restart instruction +setper2: + pop h ;recall table base + lxi d,pbelt ;element size + dad d ;incremented to next element + dcr c ;end of table? + jnz setper0 ;for another element +; +gop2: ;permanent break points set, now start the program + lxi sp,stack-12 + pop d + pop b + pop psw + pop h ;sp in hl + sphl + lhld ploc ;pc in hl + push h ;into user's stack + lhld hloc ;hl restored + ei + ret +; +setbk: ;set break point at location d,e + push psw + push b + lxi h,breaks ;number of breaks set so far + mov a,m + inr m ;count breaks up + ora a ;one set already? + jz setbk0 +; already set, move past addr,data fields + inx h + mov a,m ;check = addresses + inx h + mov b,m ;check ho address + inx h +; don't set two breakpoints if equal + cmp e ;low =? + jnz setbk0 + mov a,b + cmp d ;high =? + jnz setbk0 +; equal addresses, replace real data + mov a,m ;get data byte + stax d ;put back into code +setbk0: inx h ;address field + mov m,e ;lsb + inx h + mov m,d ;msb + inx h ;data field + ldax d ;get byte from program + mov m,a ;to breaks vector + mvi a,rstin ;restart instruction + stax d ;to code + pop b + pop psw + ret +; +; ********************************* +; * * +; * h - hex arithmetic * +; * * +; ********************************* +; +hexari: + call scanexp + jz hexlist ;to list the symbol table + call getval ;ready the first value + dcr a ;1 becomes 0, 2 becomes 1 + jz hexsym ;print the symbol only + dcr a ;2 became 1, now becomes 0 + jnz cerror +; first value is in hl + push h + call getval ;second value to h,l + pop d ;first value to d,e + push h ;save a copy of second vaalue + call crlf ;new line + dad d ;sum in h,l + call paddr + call blank + pop h ;restore second value + xra a ;clear accum for subtraction + sub l + mov l,a ;back to l + mvi a,0 ;clear it again + sbb h + mov h,a + dad d ;difference in hl + call paddr + jmp start +; + +hexsym: ;print symbol name + xchg + call crlf ;new line for symbol + push d ;save de (address value) for ascii printout + push d ;save de for the decimal printout + call paddsy +; print the value in decimal + call blank + mvi a,'#' + call pchar +; + mvi b,1 shl 7 or 5 ;five digits, zero suppress on + lxi h,dtable ;decimal value table +; initial/partial dividend is stacked at this point +nxtdig: ;convert first/next digit in dvalue table + mov e,m ;low order divisor + inx h ;to next value + mov d,m ;high order divisor + inx h ;ready for next digit + xthl ;dividend to hl, dtable addr to stack + mvi c,'0' ;count c up while subtracting +hdig0: mov a,l ;low order dividend + sub e ;low order dividend + mov l,a ;partial difference + mov a,h ;high order dividend + sbb d ;high order divisor + mov h,a ;hl = hl - decade + jc hdig1 ;carry gen'ed if too many subtracts + inr c ;to next ascii digit + jmp hdig0 ;for another subtract +; +hdig1: ;counted down too many times + dad d ;add decade back + mov a,b ;check for zero suppress + ora a ;sign bit set? + jp hdig2 ;skip if 0 bit set + push psw ;save the zero suppress / count +; high order bit set, must be zero suppression + mov a,c ;check for ascii zero + cpi '0' + jz hdig3 ;skip print if zero +; digit is not zero, clear the zero suppress flag + call pchar + pop psw + ani 7fh ;remove suppress flag + mov b,a ;back to b register + jmp hdig4 ;to decrement the b register +; +hdig2: ;zero suppression not set, print the digit + mov a,c ;ready to print + call pchar ;printed to console + jmp hdig4 ;to decrement the b register +; +hdig3: ;character is zero, suppression set +; may be the last digit + pop psw ;recall digit count + ani 7fh ;mask low bits + cpi 1 ;last digit? + jnz hdig4 ;to decrement the b register + mov b,a ;clear zero suppression + jmp hdig2 ;to print the character +; +hdig4: ;digit suppressed or printed, decrement count + xthl ;dtable address to hl, partial to stack + dcr b ;count b down + jnz nxtdig ;for another digit +; +; operation complete, remove partial result + pop d ;removed + pop d ;original value to de +; print the character in ascii if graphic + mov a,d ;must be zero + ora a + jnz start ;skip the test + mov a,e ;character graphic? + ani 7fh ;strip parity + cpi ' ' ;below space? + jc start ;skip if so + inr a ;7fh (rubout) becomes 00 + jz start ;skip if so + call blank ;blank before quotes + mvi a,'''' ;first quote + call pchar + mov a,e + ani 7fh ;remove parity (again) + call pchar ;character + mvi a,'''' + call pchar + jmp start +; +hexlist: + ;dump the symbol table to the console + lhld sytop ;topmost element + inx h ;to low address + inx h ;to high address +hexlis0: + mov d,m ;high address to d + dcx h ;move down to low + mov e,m ;low address to e + dcx h ;move down to length + mov c,m ;length to c + dcx h ;to the first character + mov a,c ;to accumulator for compare + cpi 16 ;stop if length > 16 + jnc start ;for the next instruction +; otherwise, print the symbol + call crlf ;newline for symbol + xchg ;symbol address to hl + call paddr ;address is printed + xchg ;hl is the first symbol + call blank ;to print a blank after address + inr c ;in case c = 00 +hexlis1: + dcr c ;count = count - 1 + jz hexlis2 ;skip to end of symbol if so + mov a,m ;character in a + dcx h ;to next symbol to get + call pchar ;to print the character + jmp hexlis1 ;for another character +hexlis2: + ;end of symbol, carriage return line feed + call break + jnz start ;to skip the remainder + jmp hexlis0 ;for another symbol + + +; +; ********************************* +; * * +; * i - input fcb * +; * * +; ********************************* +infcb: + lda negcom ;negated? + ora a + jnz cerror ;command error if so +; + call FCBIN +; + + jmp start ;for another command +; +; ********************************* +; * * +; * l - list mnemonics * +; * * +; ********************************* +; +lassm: +; assembler language output listing +; l lists from current disassm pc for several lines +; l lists from for several lines +; l, lists between locations + call chkdis ;disassm present? + jnc cerror +; + call scanexp ;scan expressions which follow + jz spage ;branch if no expressions + call getval ;exp1 to h,l + shld dispc ;sets base pc for list + dcr a ;only expression? + jz spage ;sets single page mode +; +; another expression follows + call getval + shld dispm ;sets max value + dcr a + jnz cerror ;error if more expn's + xra a ;clear page mode + jmp spag0 +; +spage: mvi a,psize ;screen size for list +spag0: sta dispg + call disen ;call disassembler + jmp start ;for another command +; + +; +; ********************************* +; * * +; * m - move memory * +; * * +; ********************************* +; +move: + call scan3 ;bc,de,hl +move0: ;has b,c passed d,e? + call bcde + jc start ;end of move +; Check for wrap around + push b ;save state + push d + push h + lxi h,0FFFFh + mov a,h ;get high order + cmp b ;are they the same? + jnz MOVE1 ;B < H so keep movin.... +; + mov a,l ;B = H so check low order + cmp c ;set flags + jnz MOVE1 +; + jmp START ;they are equal,BC = FFFFh do not wrap +MOVE1: + pop h + pop d + pop b ;restore registers +; Else continue + ldax b ;char to accum + inx b ;next to get + mov m,a ;move it to memory + inx h + jmp move0 ;for another +; + +; +; ********************************* +; * * +; * p - permanent break * +; * * +; ********************************* +permbrk: + + call scanexp ;0,1, or 2 values + jc cerror ;p, not allowed + jz permzer ;no expressions +; 1 or 2 expressions found + call getval ;first value to hl (bp name) + push h ;saved to stack + lxi h,1 ;set to one break if not there + dcr a ;item count + lda negcom ;ready negated command flag + jz setpval ;skip if 1 expression + ora a ;negated if ff + jnz cerror ;command error if form is -px,y + call getval ;may be zero, usually pass count + jmp setpval0 +setpval: + ;only one expression, may be negated + lxi h,0 + ora a ;negated if ff + jnz setpval0;to store the 00 + lxi h,1 ;otherwise the pass count is 1 +setpval0: + mov a,h ;high byte must be zero + ora a ;00? + jnz cerror ;command error if not +; + shld bias ;held in bias + lxi h,pbtable;search for the stacked address + mvi c,pbsize +perm0: push h ;save current element + mov a,m ;is count=00? + ora a ;set flags + jz perm2 +; count is non-zero, may be current address + inx h ;low(addr) + mov a,m + inx h + mov d,m ;da is table address to compare + pop h ;table element base to hl + xthl ;stacked search address to hl + cmp l ;low(addr) = low(search)? + jnz perm1 ;skip if not + mov a,d + cmp h ;high(addr) = high(search)? + jnz perm1 ;skip if addr <> search +; +; found the address to operate upon + lda bias ;new count + pop h ;table element base to hl + mov m,a ;set to memory, may be zero + ora a + jmp start ;get next command +; +perm1: xthl ;search address back to stack + push h ;table address back to stack +perm2: pop h ;table address revived + lxi d,pbelt ;element size + dad d ;hl is next to scan + dcr c ;count down table length + jnz perm0 ;for another try +; +; arrive here if item cannot be found, must be setting break + lda bias ;=00? + ora a ;set flags + jz cerror ;error if not found +; search address is still stacked +; +; setting non zero permanent pass count, find free entry + lxi h,pbtable + mvi c,pbsize +lperm0: push h ;save current table base + mov a,m ;get low(count) + ora a ;count=00? + jnz lperm1 ;skip if in use +; free location, use it + lda bias ;count in reg-a + pop h ;table base to hl + mov m,a ;non zero count set + pop d ;search address + inx h + mov m,e ;set low search + inx h + mov m,d ;set high search address + jmp start ;for another command +; +lperm1: pop h ;recall table base + lxi d,pbelt + dad d ;hl is next to scan + dcr c ;count table size down + jnz lperm0 +; +; no table space available + jmp cerror +; +; +permzer: + ;no expressions encountered, must be display or clear + lxi h,pbtable ;search for display or reset + mvi c,pbsize +permz0: push h ;save next table element addr + mov a,m ;count to a + ora a ;skip if zero count + jz permz2 ;skip if inactive +; display or clear + lda negcom ;-p? + ora a + jz permz1 +; +; this is a clear, so count = 00 + mvi m,0 ;clear count + jmp permz2 ;to go to next item +; +permz1: ;this is a display + push b ;save pbtable count (c) + call crlf ;new line + mov a,m ;recall count to register a + call pbyte ;print byte + call blank ;blank delimiter + inx h ;low of address + mov e,m + inx h + mov d,m ;de is address of break point + call paddsy ;print symbol reference + pop b ;recall pbtable count in c +permz2: pop h ;recall table base + lxi d,pbelt ;element size + dad d ;to hl + dcr c ;count table down + jnz permz0 ;for another + jmp start ;for a command +; +; ********************************* +; * * +; * r - read * +; * * +; ********************************* +read: + lda CURLEN + ora a + jz CERROR ;no file after read command +; + lxi h,DFCB ;HL = default fcb + call GETFILE ;get filename + mvi m,00 + inx h ;bump FCB pointer + mvi a,020h ;Blank in Acc + mvi c,11 ;counter for file blank +r1: + mov m,a ;blank at mem + inx h + dcr c ; + jnz r1 ;back if more + mvi a,00 + mvi c,4 ; +r2: mov m,a ;zero out rest of FCB + inx h + dcr c + jnz r2 + mvi m,0 +; + call scanexp ;check for offset expression + lxi h,0 ;HL = initial BIAS offset + jz readn ;if none to readn + dcr a ;one expression? + jnz cerror + lhld EXPLIST+1 ;HL = new BIAS value +; +readn: +;hl holds bias value for load operation + shld bias +; copy the second half of the file control block to temp + lxi h,fcb2 + lxi d,tfcb + mvi c,fcbl/2 ;half of the fcb size +read0: mov a,m + stax d ;store to temp position + inx h + inx d + dcr c ;count to end of fcb + jnz read0 +; second half now saved, look at first name + lda fcb+1 ;* specified? + cpi '?' + jz checksy ;skip load if so +rinit: call opn ;open input file + cpi 255 + jz cerror +; continue if file open went ok +; disk file opened and initialized +; check for 'hex' file and load til eof +; + lxi h,PCBASE + shld DEFLOAD + mvi a,'H' ;hex file? + lxi b,'XE' ;remainder of name to bc + call qtype ;look for 'hex' + lhld bias ;recall bias value + push h ;save to mem for loader + jz hread +; +; com/utl file, load with offset given by "bias" + pop h ;recall bias + lxi d,pcbase ;base of transient area + dad d +; reg h holds load address +lcom0: ;load com file + push h ;save dma address + lxi d,dfcb + mvi c,rdf ;read sector + call trapad + pop h + ora a ;set flags to check return code + jnz checksy +; move from 80h to load address in h,l + lxi d,dbf + mvi c,80h ;buffer size +lcom1: ldax d ;load next byte + inx d + mov m,a ;store next byte + inx h + dcr c + jnz lcom1 +; loaded, check address against mload + call ckmload + call CKDFLD + xchg ;HL & DE correct + lhld BDOSE+1 ;HL = top of memory + call HLDE ;is DMA address > base of SID? + xchg + jnc LCOM0 ;if so then error. + lxi h,PCBASE + shld DEFLOAD + shld MLOAD + jmp CERROR +; +; +; otherwise assume hex file is being loaded +hread: call diskr ;next char to accum + cpi deof ;past end of tape? + jz cerror ;for another command + sbi ':' + jnz hread ;looking for start of record +; +; start found, clear checksum + mov d,a + pop h + push h + call rbyte + mov e,a ;save length + call rbyte ;high order addr + push psw + call rbyte ;low order addr + pop b + mov c,a + dad b ;biased addr in h + mov a,e ;check for last record + ora a + jnz rdtype +; end of tape, set load address + mov a,b + ora c ;load address = 00? + lxi h,pcbase;default = pcbase if 0000 + jz setpc +; otherwise, pc at end of tape non zero + mov l,c ;low byte + mov h,b ;high byte +setpc: shld ploc ;set pc value + jmp checksy ;for symbol command +; +rdtype: + call rbyte ;record type = 0 +; +; load record +red1: call rbyte + mov m,a + inx h + dcr e + jnz red1 ;for another byte +; otherwise at end of record - checksum + call rbyte + push psw ;for checksum check + call ckmload ;check against mload + call CKDFLD + pop psw + jnz cerror ;checksum error + jmp hread ;for another record +; +rdhex: ;read one hex byte without accumulating checksum + call diskr ;get one character +rdhex0: call hexcon ;convert to hex + rlc + rlc + rlc + rlc ;moved to high order nibble + ani 0f0h ;masked low order to 0000 + push psw ;and stacked + call diskr ;get second character + call hexcon ;converted to hex in accum + pop b ;old accum to register b + ora b ;and'ed into result + ret +; +rbyte: ;read one byte from buff at wbp to reg-a +; compute checksum in reg-d + push b + push h + push d +; + call rdhex ;read one hex value + mov b,a ;value is now in b temporarily + pop d ;checksum + add d ;accumulating + mov d,a ;back to cs +; zero flag remains set + mov a,b ;bring byte back to accumulator + pop h + pop b ;back to initial state with accum set + ret +; +checksy: +; check for dis/assem overload + lxi h,modbas + call comload ;hl > mload? carry if so + jc chksym ;no dis/assem overlay + lda dasm ;00 if present + ora a + cz nodis ;remove if not already +; +chksym: ;check for symbol table file +; first save utl condition, if present + mvi a,'U' ;first character of utl + lxi b,'LT' ;remainder of name + call qtype ;find the file type - may be utl + push psw ;save condition for below + lxi h,tfcb ;name held here + lxi d,fcb ;source file control block + mvi c,fcbl/2 +chksy0: mov a,m ;get character + stax d ;save into fcb + inx h + inx d ;pointers to next chars + dcr c + jnz chksy0 +; +; fcb filled with second file name, clear cr field + xra a + sta fcb+fcr + lda fcb+1 + cpi ' ' + jz prstat ;skip if no file name +; +; symbol load follows + lxi h,symsg ;write ''symbols' + call prmsg ;print the message +; bias value is stored in "bias" + call opn ;open the symbol file + inr a ;255 becomes 00 + jz cerror ;cannot open? +; file opened, load symbol table from file +; +; symbol table load routine - load elements of the +; form - +; (cr/lf/tab)hhhh(space)aaaaa(tab/cr) +; where hhhh is the hex address, aaaaa is a list of +; characters of length <16. add bias address to each loc'n +; +loadsy: call diskr ;get next starting character +loadsy0: + cpi eof + jz prstat ;completes the load + cpi ' '+1 ;graphic? + jc loadsy ;until graphic found +; +; get the symbol address to hl + call rdhex0 ;pre-read first character + push psw ;high order byte saved + call rdhex ;second half + pop d ;high order byte goes to d + mov e,a ;low order byte to e + lhld bias ;bias value in r command + dad d ;hl is offset address + push h ;save the address for later + call diskr ;get the blank char + cpi ' ' + jz okload ;ok to load symbol if blank +; +; clear to the next non graphic character + pop h ;throw out the load address +skload: + ;skip to non graphic character + call diskr ;read the next character + cpi ' ' ;below space if non graphic + jc loadsy0 ;for the next character test + jmp skload ;to bypass another character +; +okload: + lhld bdose+1 ;pointer to topmost jmp xxx around table + mvi e,0 ;counts the symbol length +loadch: ;load characters + dcx h ;next to fill + call diskr ;next char to a + cpi tab ;end of symbol? + jz syend + cpi cr ;may be end of line + jz syend + cpi ' '+1 ;graphic? + jc cerror ;it must be + mov m,a ;save it in memory + inr e ;count the length up + mov a,e ;past 16? + cpi 16 + jnc cerror ;error if longer than 16 chars + jmp loadch ;for another character +; +syend: ;end of current symbol, set pointers for this one +; structure is: +; high bdos +; low bdos +; bjump: jmp +; ... +; high bjump +; low bjump +; bdose: jmp +; +; constructing symbol below bjump of the form +; high addr +; low addr +; bjump: length +; char1 +; ... +; char length +; +; then move jmp bdos down below the symbol +; + push d ;save the length + push h ;save the next to fill + xchg ;de contains the next to fill + lhld bdose+1 ;address of the jmp xxx above symbol + inx h ;low jump address + mov e,m ;to e for now + inx h ;high jump address + mov d,m ;de is the xxx for the jmp xxx to install + pop h ;next to fill address + mov m,d ;high order address + dcx h ;.low address + mov m,e ;xxx filled below symbol + dcx h ;.jmp + mvi m,jmp ;jump instruction filled +; hl address the base of the table, ensure not below mload + call comload ;hl > mload ? + jnc cerror ;cy if so + xchg ;jmp xxx address to de + lhld bdose+1 ;previous jmp xxx address + xchg ;to de, hl is new jmp xxx address + shld bdose+1 ;changed jump address in low mem + xchg ;old jump address back to hl + pop d ;length is in e + mov m,e ;stored to memory + inx h ;low address location + pop d ;low address in de + mov m,e + inx h ;high address location + mov m,d +; now ready for another symbol + jmp loadsy +; +; end of the symbol load subroutine +prstat: ;print the statistics for the load or start utility + pop psw ;zero flag set if this is a utility + jnz prstat0 ;skip if not utility +; +; this is a ddt utility, start it + lxi h,retutl ;return address from utility + push h ;to stack + lhld ploc ;probably = pcbase + pchl ;gone to the utility ... +; +retutl: + ;return here to reset the symbol table base + lhld bdose+1 ;new base of modules + dad d ;de is length of symbols inserted by utility + shld sytop ;new symbol top + jmp start ;for another command +; +; +prstat0: +; not a ddt utility, print statistics + lxi h,lmsg ;'next pc end' + call prmsg ;printed to console + lhld DEFLOAD ;default load address + call PADDR + call BLANK + lhld mload ;next address + call paddr + call blank ;following blank + lhld ploc ;pc value + call paddr + call blank ;next and pc printed + lhld bdose+1 ;end of memory+1 + dcx h ;real end of memory + call paddr + jmp start ;for the crlf +; + +; +; +; ********************************* +; * * +; * s - set memory * +; * * +; ********************************* +; +setmem: ;one expression expected + call scanword ;sets flags + dcr a ;one expression only + jnz cerror + call getval ;start address is in h,l +setm0: call crlf ;new line + push h ;save current address + call paddr ;address printed + call blank ;separator + pop h ;get data + push h ;save address to fill +; check for display mode + lda wdisp + ora a ;word mode? + jz setbyte +; set words of memory + mov e,m ;low order byte + inx h + mov d,m ;high order byte + xchg + call paddr ;address value printed + jmp setget ;get value from input +; +setbyte: +; byte mode set + mov a,m + call pbyte ;print byte +setget: call blank ;another separator + call getbuff ;fill input buffer + call gnc ;may be empty (no change) + pop h ;restore address to fill + cpi cr + jz setm1 + cpi '.' + jnz chkasc ;skip to check ascii +; must be length zero (otherwise .symbol) + lda curlen + ora a + jz start ;for next command + mvi a,'.' ;otherwise restore +chkasc: + cpi '"' ;ascii input? +; filling ascii/ byte/ address data + push h ;save address to fill + jnz sethex ;hex single or double precision +; set ascii data to memory +setasc: call gnlc ;next byte to fill + pop h ;next address to fill + cpi cr ;end of line + jz setm0 ;for next input + mov m,a ;otherwise store it + inx h ;to next address to fill + push h ;save the address + jmp setasc +; +; byte or address data is being changed +sethex: + call scanex ;first character already scanned + dcr a ;one item? + jnz cerror ;more than one + call getval ;value to h,l + lda wdisp ;word mode? + ora a ;word mode=ff + jz setbyt0 +; filling double precision value + xchg ;value to de + pop h ;recall fill address + mov m,e ;low order + inx h ;addressing high order position + mov m,d ;filled + inx h ;move to next address + jmp setm0 ;for the next address +; +; filling byte value +setbyt0: + ora a ;high order must be zero + jnz cerror ;data is in l + mov a,l + pop h ;restore data value + mov m,a +setm1: inx h ;next address ready + lda wdisp + ora a ;word mode? + jz setm0 ;skip inx if so + inx h ;to next double word + jmp setm0 +; +; ********************************* +; * * +; * u - untrace mode * +; * * +; ********************************* +; +untrace: + mvi a,1 ;untrace mode = 1 + jmp etrace +; +; ********************************* +; * * +; * t - start trace * +; * * +; ********************************* +; +trace: mvi a,2 ;set trace mode flag=2 +etrace: + sta tmode +; allow tw/uw to suppress out-of-line trace + call scanword + lxi h,0 + shld userbrk ;clear userbrk + inx h ;default to one trace + jz trac0 +; expressions were given, forms are +; tx trace for x steps acc = 1 +; tx,brk trace for x steps, call "brk" at each stop acc=2 +; t,brk call "brk" acc = 1, cy = 1 +; + jc settr0 + call getval ;to h,l + push psw + mov a,l ;check for zero + ora h + jz cerror + pop psw ;recall number of parameters +settr0: ;h,l contains trace count, save it for later + push h +; look for break address + dcr a ;if only one specified, then skip userbrk + jz settr1 + dcr a ;must be two values + jnz cerror ;more than two specified + call getval ;value to h,l + shld userbrk +settr1: ;recall trace count + pop h +trac0: shld tracer + xra a ;00 to accum + sta gobrks ;mark as no user breaks + call dstate ;starting state is displayed + jmp gopr ;sets breakpoints and starts execution +; +; ********************************* +; * * +; * v - value * +; * * +; ********************************* +; +VALUE: + jmp PRSTAT0 +; +; +; ********************************* +; * * +; * w - write * +; * * +; ********************************* +; +WRITE: + lda CURLEN + ora a + jz CERROR ;exit if no file present +; +; + lxi h,FCB ;load HL with fcb address + call GETFILE ;obtain file from command string + mvi a,00h + sta FCB+32 ;zero out the record count + lxi h,0100h + shld WBEGIN ;store begining address + lhld DEFLOAD ;get default end address + shld WEND ;store in Write END +; + call SCANEXP ;check for specified address + lda EXPLIST ;get number of experessions + ora a ; + jz NOWRPRM +; + cpi 2 + jnz CERROR ;error if not two expr + lhld EXPLIST+1 ;HL = start address + shld WBEGIN ;store in begin + lhld EXPLIST+3 ;HL = finish address + shld WEND ;store in end +; +; Continue with WRITE +NOWRPRM: +; + lhld WBEGIN ;HL = beginning address + call CHKEND ;is end > begin ? + jc CERROR ; if so error +; + lxi h,00h ;get ready to zero out + shld WRTREC ;# of records written + +; Now that FCB is set up get ready to write out +; to the specified file. +; + lxi d,DFCB + call DELETE +; + call MAKE + inr a + jz CERROR + lhld WBEGIN ;get beginning address +; +WLOOP0: + call WFLAG + lxi d,DBF ;DE = default DMA address + mvi c,80h ;counter for loop +; +WLOOP1: + mov a,m ;get byte + inx h ;bump pointer + stax d ;store in buffer + inx d ;bump pointer + dcr c ;decrement counter + jnz WLOOP1 ;again if not finished +; + lxi d,DFCB + call DWRITE ;write it out + ora a ;set flags for write check + jnz CERROR ;error if not 0 + push h ;save source address + lhld WRTREC ;get # of records written + inx h ;bump it by one + shld WRTREC ;put it back + pop h ;get source address back +; + call CHKEND +; + lda ONEFLG ;set for flag check + cpi TRUE ;last record? + jnz WLOOP0 ;next record if not finished +WCLOSE: + lxi d,DFCB + call CLOSE +; + lxi h,WRTMSG + call PRMSG + lhld WRTREC ;# of records + call PADDR + lxi h,WRTMSG1 + call PRMSG ;print out end of string +; + jmp START ;exit +; +CHKEND: + lda WEND ;get high order end byte + sub l ;get low order + sta rslt ;low order in rslt + lda WEND+1 ;high order equal check + sbb h ;sub high order + sta rslt+1 ;high order answer + ret +; +WFLAG: + mvi a,FALSE ;zero out flag + sta ONEFLG ;store + lda RSLT+1 + cpi 00h + rnz + lda RSLT + cpi 080h ;record length + jc WFLAG1 + jz WFLAG1 + ret +WFLAG1: + mvi a,TRUE + sta ONEFLG + ret +; +ONEFLG: db 0 +RSLT: dw 0 +; +; ********************************* +; * * +; * x - examine * +; * * +; ********************************* +; +examine: + call gnc ;cr? + cpi cr + jnz exam0 + call dstate ;display cpu state + jmp start +; +exam0: ;register change operation + lxi b,pval+1 ;b=0,c=pval (max register number) +; look for register match in rvect + lxi h,rvect +exam1: cmp m ;match in rvect? + jz exam2 + inx h ;next rvect + inr b ;increment count + dcr c ;end of rvect? + jnz exam1 +; no match + jmp cerror +; +exam2: ;match in rvect, b has register number + call gnc + cpi cr ;only character? + jnz cerror +; +; write contents, and get another buffer + push b ;save count + call crlf ;new line for element + call delt ;element written + call blank + call getbuff ;fill command buffer + call scanexp ;get input expression + ora a ;none? + jz start + dcr a ;must be only one + jnz cerror + call getval ;value is in h,l + pop b ;recall register number +; check cases for flags, reg-a, or double register + mov a,b + cpi aval + jnc exam4 +; setting flags, must be zero or one + mov a,h + ora a + jnz cerror + mov a,l + cpi 2 + jnc cerror +; 0 or 1 in h,l registers - get current flags and mask position + call flgshf +; shift count in c, d,e address flag position + mov h,a ;flags to h + mov b,c ;shift count to b + mvi a,0feh ;111111110 in accum to rotate + call lrotate ;rotate reg-a left + ana h ;mask all but altered bit + mov b,c ;restore shift count to b + mov h,a ;save masked flags + mov a,l ;0/1 to lsb of accum + call lrotate ;rotated to changed position + ora h ;restore all other flags + stax d ;back to machine state + jmp start ;for another command +; +lrotate: ;left rotate for flag setting +; pattern is in register a, count in register b + dcr b + rz ;rotate complete + rlc ;end-around rotate + jmp lrotate +; +exam4: ;may be accumulator change + jnz exam5 +; must be byte value + mov a,h + ora a + jnz cerror + mov a,l ;get byte to store + lxi h,aloc ;a reg location in machine state + mov m,a ;store it away + jmp start +; +exam5: ;must be double register pair + push h ;save value + call getdba ;double address to hl + pop d ;value to d,e + mov m,e + inx h + mov m,d ;altered machine state + jmp start +; +diskr: ;disk read + push h + push d + push b +; +rdi: ;read disk input + lda dbp + ani 7fh + jz ndi ;get next disk input record +; +; read character +rdc: + mvi d,0 + mov e,a + lxi h,dbf + dad d + mov a,m + cpi deof + jz RRET ;end of file + lxi h,dbp + inr m + ora a + jmp rret +; +ndi: ;next buffer in + mvi c,rdf + lxi d,dfcb + call trapad + ora a + jnz def +; +; buffer read ok + sta dbp ;store 00h + jmp rdc +; +def: ;store EOF and return (end file) + mvi a,DEOF +rret: + pop b + pop d + pop h + ret +; +; ********************************* +; * * +; * ERROR ROUTINES * +; * * +; ********************************* +; +cerror: +;error in command + call crlf + mvi a,'?' + call pchar + jmp start +; +; ********************************* +; * * +; * general purpose subroutines * +; * * +; ********************************* +; +COMDEF: + lxi h,FCB+9 ;set up address + mvi a,'C' + mov m,a ;store it + inx h + mvi a,'O' + mov m,a ;store it + inx h + mvi a,'M' + mov m,a + ret +; +; +SYMDEF: + lxi h,FCB+019h ;set up address + mvi a,'S' + mov m,a ;store it + inx h + mvi a,'Y' + mov m,a ;store it + inx h + mvi a,'M' + mov m,a + ret +; +; +fildel: +;file character delimiter in a? + cpi '.' + rz +fildel0: + cpi ',' ;comma? + rz + cpi cr + rz + cpi '*' + rz ;series of ?'s + cpi ' ' + ret ;zero for cr, ., or blank +; +filfield: + ;fill the current fcb field to max c characters + call fildel ;delimiter? + jz filf1 ;skip if so + mov m,a + inx h ;character filled + call gnfcb ;get next character + dcr c ;field length exhausted? + jnz filfield;for another character +; clear to delimiter +filf0: call fildel + rz ;return with delimiter in a + call gnfcb ;get another char + jmp filf0 ;to remove it +; +filf1: ;delimiter found before field exhausted + mvi d,' ' ;fill with blanks? + cpi '*' + jnz filf2 ;yes, if not * + call gnfcb ;read past the * + mvi d,'?' ;otherwise fill with ?'s +filf2: mov m,d ;fill remainder with blanks/questions + inx h ;to next character + dcr c ;count field length down + jnz filf2 ;for another blank + ret ;with delimiter in reg-a +; +; +bcde: ;compare bc > de (carry gen'd if true) + mov a,e + sub c + mov a,d + sbb b + ret +; +WRPCHK: + push h + push d + push b + mov d,b + mov e,c + lxi h,0FFFFh + call HLDE + pop b + pop d + pop h + ret +; +HLDE: + mov a,h ;Acc = H + cmp d ;is H <= D + rc ;return if H < D with carry + rnz ;return if H > D + mov a,l ;low order check H = D + cmp e ;what is the relationship +; H = D so test lower byte + rc ;return if L < E with carry + rnz ;return if L > E + xra a ;set zero for equality + ret +; +nodis: ;remove dis/assembler from memory image + mvi a,1 + sta dasm ;marks dis/assem as missing + lxi h,demon + shld bdose+1 ;exclude dis/assembler + shld sytop ;mark top of symbol table + ret +; + +; Scanners for various needs +; +; move the command buffer to the default area at dbf +FCBIN: lxi d,curlen ;current length dec'ed at gnc + lxi h,dbf ;default buffer + ldax d ;dec'ed length (exclude i) + mov c,a ;ready for loop + mov m,a ;store dec'ed length + inr c ;length ready for looping + inx d ;past 'i' +dbfill: inx d ;to first/next char + inx h ;to first/next to fill + ldax d ;get next char + ani 07Fh ;zero out lower case bit + mov m,a ;to buffer + dcr c ;end of buffer? + jnz dbfill ;loop if not + mov m,c ;00 at end of buffer +; +; now fill the file control blocks at fcb and fcb2 + mvi e,2 ;fill fcb/fcb2 + lxi h,fcb ;start of default fcb + call GETFILE +; +; +; now check for both fcb's complete + dcr e + cnz GETFILE ;to scan the second half + mvi m,0 ;fill current record field + ret +; +; +; +getbuff: ;fill command buffer and set pointers + mvi c,getf ;get buffer function + lxi d,comlen;start of command buffer + call trapad ;fill buffer + lxi h,combuf;next to get + shld nextcom + ret +; +; +scan3: ;scan three expn's for fill and move + call scanexp + cpi 3 + jnz cerror + call getval + push h + call getval + push h + call getval + pop d + pop b ;bc,de,hl + ret +; +; +scanword: + ;perform scan, with possible word mode + call gnc ;check for w + lxi h,wdisp + mvi m,0 ;clear it now, check for w + cpi 'W' + jnz scanex ;skip if not w and continue +; w encountered, set word mode + mvi m,0ffh +; and drop through for remainder of scan +; +scanexp: ;scan expressions - carry set if ,b +; zero set if no expressions, a set to number of expressions +; hi order bit set if ,b also + call gnc +; +scanex: ;enter here if character already scanned + lxi h,explist + mvi m,0 ;zero expressions + inx h ;ready to fill expression list + cpi cr ;end of line? + jz scanret +; +; not cr, must be digit or comma + cpi ',' + jnz scane0 +; mark as comma + mvi a,80h + sta explist + lxi d,0 + jmp scane1 +; +scane0: ;not cr or comma + call getexp ;expression to d,e +scane1: call scstore ;store the expression and increment h,l + cpi cr + jz scanret + call gnc + call getexp + call scstore +; second digit scanned + cpi cr + jz scanret + call gnc + call getexp + call scstore + cpi cr + jnz cerror +scanret: + lxi d,explist ;look at count + ldax d ;load count to acc + cpi 81h ;, without b? + jz cerror + inx d ;ready to extract expn's + ora a ;zero flag may be set + rlc + rrc ;set carry if ho bit set (,b) + ret ;with flags set +; +; +GETFILE: +; Get filename for FCB routine +fildisk: + call gnfcb0 ;read and clear lookahead character + cpi ' ' + jz fildisk ;deblank input line +; + push psw ;save first character + call gnfcb ;get second character + cpi ':' + jnz nodisk ;skip if not disk drive +; +; disk specified, fill with drive name + pop psw + sui 'A'-1 ;normalized to 1,2,... + mov m,a + inx h ;filled to memory + call gnfcb0 ;scan another character + jmp filnam +; +nodisk: ;use default drive (00 in fcb/fcb2) + mov b,a ;save second char + mvi m,0 + inx h ;character filled + pop psw ;recall original character +; +filnam: +;fill the file name field, first character in a + mvi c,ffnl ;file name length + call filfield;filed filled, padded with blanks + cpi '.' ;delimiter period filename.filetype + cz gnfcb ;clear the period +; + mvi c,fftl ;file type length in c + call filfield;fill the type field +; +filext: ;now cleared to next blank or cr + mvi c,fcbl/2-ffnl-fftl-1 ;number of bytes remaining +filex0: + mvi m,0 + inx h ;fill a zero + dcr c + jnz filex0 + ret +; +; +; set input file control block (at 5ch) to simulate console command +; useful subroutines for infcb: +gnfcb0: ;zero the lookahead character and read + mvi b,0 +gnfcb: ;get next fcb character from lookahead or input + mov a,b ;lookahead active? + mvi b,0 ;clear if so + ora a ;set flags + rnz + jmp gnc ;otherwise get real character +; +gnc: ;get next console character with translation + call gnlc ;get next lower case char + ;drop through to translate +trans: +; translate to upper case + cpi 7fh ;rubout? + rz + cpi ('A' or 0100000b) ;upper case a + rc + ani 1011111b ;clear upper case bit + ret +; +gnlc: +; get next buffer character from console w/o translation + push h ;save for reuse locally + lxi h,curlen + mov a,m + ora a ;zero? + mvi a,cr + jz gncret ;return with cr if exhausted + dcr m ;curlen=curlen-1 + lhld nextcom + mov a,m ;get next character + inx h ;nextcom=nextcom+1 + shld nextcom ;updated +gncret: pop h ;restore environment + ret; +; +; ********************************* +; * * +; * Disk I/O routines * +; * * +; ********************************* +; +opn: +;file open routine. this subroutine opens the disk input + push h + push d + push b + xra a + sta dbp ;clear buffer pointer + mvi c,opf + lxi d,dfcb + call trapad ;to bds + pop b + pop d + pop h + ret +CLOSE: + push b + push d + push h + mvi c,16 + call TRAPAD + pop h + pop d + pop b + ret +; +DWRITE: +; Disk write routine + push b + push d + push h + mvi c,WRITF ;write func + call TRAPAD + pop h + pop d + pop b + ret +; +; +SETDMA: +; DMA address set routine + push b + push d + push h + mvi c,DMAF ;DMA func # + call TRAPAD + pop h + pop d + pop b + ret +; +MAKE: +;make a file + push b + push d + push h + mvi c,22 + call TRAPAD + pop h + pop d + pop b + ret +; +DELETE: +; File delete routine + push b + push d + push h + mvi c,DELF + call TRAPAD + pop h + pop d + pop b + ret +; +; read files (hex or com) +; +; +qtype: ;check for command file type (com, hex, utl) +; regs a,b,c contain characters to match + lxi h,fcb+fft + cmp m + rnz ;return with no match? + mov a,b ;matched, check next + inx h ;next fcb char + cmp m + rnz ;matched? + mov a,c ;yes, get next char + inx h + cmp m ;compare, and + ret ;return with nz flag if no match +; +; +comload: ;compare hl > mload + xchg ;h,l to d,e + lhld mload ;mload to h,l + mov a,l ;mload lsb + sub e + mov a,h + sbb d ;mload-oldhl gens carry if hl>mload + xchg + ret +; +ckmload: ;check for hl > mload and set mload if so + call comload ;carry if hl>mload + rnc + shld mload ;change it + ret +; +; +CKDFLD: + xchg + lhld DEFLOAD + mov a,l ;lsb + sub e ; + mov a,h ;msb + sbb d ;is it smaller? + xchg + rnc ;no change + shld DEFLOAD ;return new value + ret +; +; +chkdis: ;check for disassm present + lda dasm ;=00 if present + cpi 1 ;00-1 generates carry + rnc ;01-1 generates "no carry" +; otherwise, check high load address + push h + lxi h,modbas ;base address + call comload + pop h + ret +; +; Print routines for sscreen display +; +blank: + mvi a,' ' +; +pchar: ;print character to console + push h + push d + push b + mov e,a + mvi c,cof + call trapad + pop b + pop d + pop h + ret +; +prmsg: ;print message at hl until 00 encountered + mov a,m + ora a + rz ;end if 00 found + call pchar ;print the current char + inx h ;move to next char + jmp prmsg ;for another char + +; +pnib: ;print nibble in lo accum + cpi 10 + jnc pnibh ;jump if a-f + adi '0' + jmp pchar ;ret thru pchar +pnibh: adi 'A'-10 + jmp pchar +; +pbyte: push psw ;save a copy for lo nibble + rar + rar + rar + rar + ani 0fh ;mask ho nibble to lo nibble + call pnib + pop psw ;recall byte + ani 0fh + jmp pnib +; +crlf: ;carriage return line feed + mvi a,cr + call pchar + mvi a,lf + jmp pchar +; +break: ;check for break key + push b + push d + push h + mvi c,chkio + call trapad + ani 1b + pop h + pop d + pop b + ret +; +paddsh: ;print address reference given by hl + xchg +; +paddsy: ;print address reference given by de, along +; with symbol at that address (if it exists) + push d ;save the address for symbol lookup + xchg ;ready for the address dump + call paddr ;hex value printed + pop d ;recall search address + lda negcom ;negated command? + ora a ;ff? + rnz ;return if true + call alookup ;address lookup + rz ;skip symbol if not found +; symbol found, print it +prdotsy: + ;print symbol preceded by . + call blank + mvi a,'.' + call pchar +; +; drop through to print symbol +prsym: + mov e,m ;get length of symbol +prsy0: dcx h ;to first/next character + mov a,m ;next to print + call pchar ;character out + dcr e ;count length down + jnz prsy0 + ret ;return to caller +; +; enter here to print optional label at hl +prlabel: + push h ;save address + lda negcom ;negated? + ora a + pop d ;recalled in case return + rnz ;continue if not negated + call alookup ;does the label exist? + rz ;return if not present + call crlf ;go to newline + call prsym ;print the symbol + mvi a,':' + call pchar ;label: + ret +; +; +paddr: ;print the address value in h,l + mov a,h + call pbyte + mov a,l + jmp pbyte +; +pgraph: ;print graphic character in reg-a or '.' if not + cpi 7fh + jnc pperiod + cpi ' ' + jnc pchar +pperiod: + mvi a,'.' + jmp pchar +; +discom: ;compare h,l against dismax. carry set if hl > dismax and + xchg + lhld dismax + mov a,l + sub e + mov l,a ;replace for zero tests later + mov a,h + sbb d + xchg + ret +; +; +; sydelim checks for / + - cr , or blank +; sysep checks for + - cr , or blank +; delim checks for cr , or blank +; +; +sydelim:;check for symbol delimiter + cpi '/' ;separator + rz +sysep: ;separator? + cpi '+' + rz + cpi '-' + rz +; +delim: ;check for delimiter character + cpi cr + rz + cpi ',' + rz + cpi ' ' + ret +; +hexcon: ;convert accumulator to pure binary from external hex + sui '0' + cpi 10 + rc ;must be 0-9 + adi ('0'-'A'+10) and 0ffh + cpi 16 + rc ;must be 0-15 + jmp cerror ;bad hex digit +; +getval: ;get next expression value to h,l (pointer in d,e assumed) + xchg + mov e,m + inx h + mov d,m + inx h + xchg + ret +; +getsymv: + ;lookup symbol preceded by =, @, or . operator + push d ;save next to fill in address vector + call gnc ;read the next character + lhld sytop ;hl is beginning of search +getsy0: push psw ;save first character + mov c,m ;length of current symbol + mov a,c ;to a for end of search check + cpi 16 ;length 16 or more ends search + jnc cerror ;? error if not there + pop psw ;recall first character + xchg ;symbol address to de + push d ;save search address + push psw ;save character + lhld nextcom ;next buffer position + push h ;saved to memory + lhld comlen ;comlen and curlen + push h ;save to memory +; stacked: curlen/nextcom/char/symaddr + xchg ;de is next to match+1 + inr c ;count+1 +sychar: ;check next character + call sydelim ;/, comma, cr, or space? + jz sydel ;stop scan if so +; not a delimiter in the input, end of symbol? + dcr c ;count=count-1 + jz synxt ;skip to next symbol if so +; not end of symbol, check for match + dcx h ;next symbol address + cmp m ;same? + jnz synxt ;skip if not + call gnc ;otherwise, get next input character + jmp sychar ;for another match attempt +; +sydel: ;delimiter found, count should go to zero + dcr c + jnz synxt ;skip symbol if not +; +; symbol matched, return symbol's value + pop h ;discard comlen + pop h ;discard nextcom + pop h ;discard first character + call sysep ;+ - cr, comma, or space? (not / test) + jz syloc ;return if not a / at end + call gnc ;remove the / and continue the scan + jmp synxt0 ;for another symbol +; +; end of input, get value to de +syloc: pop h ;recall symbol address + inx h ;to low address + mov e,m ;low address to de + inx h ;to high address + mov d,m ;to d + pop h ;re-instate hl + ret ;with de=value, hl=next to fill +; +; +synxt: ;move to the next symbol + pop h ;comlen + shld comlen ;restored + pop h ;nextcom + shld nextcom ;restored + pop psw ;first character to a +synxt0: pop h ;symbol address + push psw ;save first character + mov a,m ;symbol length + cma ;1's complement of length + add l ;hl=hl-length-1 + mov l,a + mvi a,0ffh ;extend sign of length + adc h ;high order bits + mov h,a ;now move past address field + dcx h ;-1 + dcx h ;total is: hl=hl-length-3 + pop psw ;recall first character + jmp getsy0 ;for another search +; +; +; otherwise, numeric operand expected +getoper: ;get hex value to d,e (possible symbol reference) + xchg ;next to fill in de + lxi h,0 ;ready to accumulate value + cpi '.' ;address reference? + jz getsymv ;return through getsymv + cpi '@' ;value reference? + jnz getoper0 ;skip if not + call getsymv ;address to de + push h ;save next to fill + xchg ;address of double prec value to hl + mov e,m + inx h + mov d,m ;double value to de + pop h ;restore next to fill + ret ;with de=value, hl=next to fill +getoper0: + cpi '=' ;byte reference? + jnz getoper1 ;skip if not +; found a byte reference, look up symbol + call getsymv ;de = address, hl = next to fill + push h ;save hl + xchg ;operand address to hl + mov e,m ;get byte value + mvi d,0 ;high byte is zero + pop h ;restore next to fill + ret ;with de=value, hl=next to fill +; +getoper1: +; not ., @, or . + cpi '''' ;start of string? + jnz getoper2 +; start of string, scan until matching quote + xchg ;return 0000 to de, next to fill to hl +getstr0: + call gnlc ;inside quoted string + cpi ' ' ;must be grapic + jc cerror ;otherwise report error +; character is graphic, check for embedded quotes + cpi '''' + jnz getstr1 ;skip if not +; must be embedded quote or end of string + call gnlc ;character following quote + call sysep ;symbol separator? + rz ;return with value in de +; otherwise the symbol is not a separator, must be quote + cpi '''' + jnz cerror ;report error if not +getstr1: + ;store the ascii character into low order de + mov d,e ;low character to high character + mov e,a ;low character from accumulator + jmp getstr0 ;for another character scan +; +getoper2: + ;check for decimal input + cpi '#' + jnz getoper3 ;must be hex +; decimal input, convert +getdec0: + call gnc ;get next digit + call sysep ;separator? + jz getdec1 ;skip to end if so + sui '0' ;decimal digit? + cpi 10 + jnc cerror ;error if above 9 + dad h ;hl=hl*2 + mov b,h ;save high order + mov c,l ;save low order + dad h ;*4 + dad h ;*8 + dad b ;*10 + mov c,a ;ready to add digit + mvi b,0 + dad b ;digit added to hl + jmp getdec0 ;for another digit +; +getdec1: + xchg + ret ;with de=value +; +getoper3: + cpi '^' ;stacked value? + jnz getoper4;skip if not +; +; get stacked value + push d ;save next to fill + lhld sloc ;stack pointer +getstk: mov e,m + inx h + mov d,m ;de is stacked value + inx h ;in case another ^ + call gnc ;get another char + cpi '^' ;^ ... ^ + jz getstk + pop h ;de=value, hl=next to fill + ret ;with value in de +; +getoper4: +; not ., @, =, or ', must be numeric + call hexcon + dad h ;*2 + dad h ;*4 + dad h ;*8 + dad h ;*16 + ora l ;hl=hl+hex + mov l,a + call gnc + call sysep ;delimiter? + jnz getoper3 + xchg + ret +; +scstore: ;store d,e to h,l and increment address + xchg + shld lastexp ;save as "last expression" + xchg + mov m,e + inx h + mov m,d + inx h + push h + lxi h,explist + inr m ;count number of expn's + pop h + ret +; +getexp: + ;scan the next expression with embedded +,- symbols + cpi '-' ;leading minus? + jnz getexpp ;skip to next if not + lxi d,0 ;assume a starting 0, with following minus + jmp getexp2 ;to continue with the scan +; +getexpp: + ;check for leading + operator + cpi '+' + jnz getexp0 ;to continue the scan +; leading + found, use last expression + xchg ;de=hl + lhld lastexp ;last expression to hl + xchg ;then to de + jmp getplus ;handle the plus operator +getexp0: + ;scan next item + call getoper ;value to de +getexpo: + ;get expression operator + cpi '+' ;stopped on +? + jnz getexp1 ;skip to next test if not +; + delimiter found, scan following operand +getplus: + push d ;save current value + call gnc ;scan past the + + call getoper ;next value to de + pop b ;recall previous value + xchg ;next value to hl + dad b ;sum in hl + xchg ;back to position + jmp getexpo ;to test for following operand +; +getexp1: + ;not a +, check for - operator + cpi '-' + rnz ;return with delimiter in a if not +; - delimiter found +getexp2: + call gnc ;to clear the operator + push d ;save current value + call getoper ;to get the next value + pop b ;recall original value to bc + push psw ;save character + mov a,c ;low byte to a + sub e ;diff in low bytes + mov e,a ;back to e + mov a,b ;high byte to a + sbb d ;diff in high bytes + mov d,a ;back to de + pop psw ;restore next character + jmp getexpo ;for the remainder of the expression + +; +; +; subroutines for cpu state display +flgshf: ;shift computation for flag given by reg-b +; reg a contains flag upon exit (unshifted) +; reg c contains number of shifts required+1 +; regs d,e contain address of flags in template + push h + lxi h,flgtab ;shift table + mov e,b + mvi d,0 + dad d + mov c,m ;shift count to c + lxi h,floc ;address of flags + mov a,m ;to reg a + xchg ;save address + pop h + ret +; +getflg: ;get flag given by reg-b to reg-a and mask + call flgshf ;bits to shift in reg-a +getfl0: dcr c + jz getfl1 + rar + jmp getfl0 +getfl1: ani 1b + ret +; +getdba: ;get double byte address corresponding to reg-a to hl + sui bval ;normalize to 0,1,... + lxi h,rinx ;index to stacked values + mov e,a ;index to e + mvi d,0 ;double precision + dad d ;indexed into vector + mov e,m ;offset to e + mvi d,0ffh ;-1 + lxi h,stack + dad d ;hl has base address + ret +; +getdbl: ;get double byte corresponding to reg-a to hl + call getdba ;address of elt in hl + mov e,m ;lsb + inx h + mov d,m ;msb + xchg ;back to hl + ret +; +delt: ;display cpu element given by count in reg-b, address in h,l + mov a,b ;get count + cpi aval ;past a? + jnc delt0 ;jmp if not flag +; +; display flag + call getflg ;flag to reg-a + ora a ;flag=0? + mvi a,'-' ;for false display + jz pchar ;return through pchar + mov a,m ;otherwise get the character + jmp pchar ;print the flag name if true +; +delt0: ;not flag, display x= and data + push psw + mov a,m + call pchar ;register name + mvi a,'=' + call pchar + pop psw + jnz delt1 ;jump if not reg-a +; +; register a, display byte value + lxi h,aloc + mov a,m + call pbyte + ret +; +delt1: ;double byte display + call getdbl ;to h,l + call paddr ;printed + ret +; +dstate: ;display cpu state + call crlf ;new line + call blank ;single blank + lxi h,rvect ;register vector + mvi b,0 ;register count +dsta0: push b + push h + call delt ;element displayed + pop h ;rvect address restored + pop b ;count restored + inr b ;next count + inx h ;next register + mov a,b ;last count? + cpi pval+1 + jnc dsta1 ;jmp if past end + cpi aval ;blank after? + jc dsta0 +; yes, blank and go again + call blank + jmp dsta0 +; +; ready to send decoded instruction +dsta1: + call blank + call nbrk ;compute breakpoints in case of trace + push psw ;save expression count - b,c and d,e have bpts + push d ;save bp address + push b ;save aux breakpoint + call chkdis ;check to see if disassember is here + jnc dchex ;display hex if not +; disassemble code + lhld ploc ;get current pc + shld dispc ;set disassm pc + lxi h,dispg;page mode = 0ffh to trace + mvi m,0ffh + call disen + jmp dstret +; +dchex: ;display hex + dcx h ;point to last to write + shld dismax ;save for compare below + lhld ploc ;start address of trace + mov a,m ;get opcode + call pbyte + inx h ;ready for next byte + call discom ;zero set if one byte to print, carry if no more + jc dstret + push psw ;save result of zero test + call blank ;separator + pop psw ;recall zero test + ora e ;zero test + jz dsta2 +; display double byte + mov e,m + inx h + mov d,m + call paddsy ;print address + jmp dstret +; +dsta2: ;print byte value + mov a,m + call pbyte +dstret: +; now print symbol for this instruction if implied memory op + lhld ploc ;instruction location + mov a,m ;instruction to a register + mov b,a ;copy to b register +; check for adc, add, ana, cmp, ora, sbb, sub, xra m + ani 1100$0000b ;high order bits 11? + cpi 1000$0000b ;check + jnz notacc +; found acc-reg operation, involving memory? + mov a,b ;restore op code + ani 0000$0111b + cpi 6 ;memory = 6 + jnz disrest ;skip to restore registers if not + jmp dismem ;to display symbol +; +notacc: ;not an accumulator operation, check for mov x,m or m,x + cpi 0100$0000b ;mov operation? + jnz notmov + mov a,b ;mov operation or halt + cpi hlt ;skip halt test + jz disrest ;to skip tests + ani 111b ;move from memory? + cpi 6 + jz dishl ;skip to print hl if so +; not move from memory, move to memory? + mov a,b ;restore operation code + ani 111000b ;select high order register + cpi 6 shl 3 ;check for memory op + jnz disrest ;skip to restore if not + jmp dishl ;to display hl register +; +notmov: ;not a move operation, check for mvi m + mov a,b ;restore operation code + cpi 0011$0110b ;mvi m,xx? + jz dishl ;display hl address if so +; now look for inr m, dcr m + cpi 0011$0100b ;inr m? + jz dismem ;skip to print hl if so + cpi 0011$0101b ;dcr m? + jnz notidcr ;skip if not inr / dcr m +dismem: ;display memory value first + mvi a,'=' + call pchar + lhld hloc + mov a,m + call pbyte +; +dishl: ;display the hl symbol, if it exists + lhld hloc + jmp dissym ;to retrieve the symbol +; +notidcr: + ;check for ldax/stax b/d + ani 1110$0111b ;ldax = 000 x1 010 + cpi 0000$0010b ;stax = 000 x0 010 + jnz disrest ;skip if not + mov a,b ;ldax/stax, get register + ani 0001$0000b ;get the b register bit + lhld dloc + jnz dissym ;skip to display + lhld bloc ;display b instead +dissym: ;enter here with the hl register set to symbol location + lda negcom ;negated? + ora a + jnz disrest ;forget it. + xchg ;search address to de + call alookup ;zero set if not found + jz disrest ;restore if not found + call prdotsy ;.symbol printed +; drop through to restore the registers +disrest: + pop b ;aux breakpoint + pop d ;restore breakpoint + pop psw ;restore count + ret +; +; data vectors for cpu display +rvect: db 'CZMEIABDHSP' +rinx: db (bloc-stack) and 0ffh ;location of bc + db (dloc-stack) and 0ffh ;location of de + db (hloc-stack) and 0ffh ;location of hl + db (sloc-stack) and 0ffh ;location of sp + db (ploc-stack) and 0ffh ;location of pc +; flgtab elements determine shift count to set/extract flags +flgtab: db 1,7,8,3,5 ;cy, zer, sign, par, idcy +; +clrtrace: ;clear the trace flag + lxi h,0 + shld tracer + xra a ;clear accumulator + sta tmode ;clear trace mode + ret +; +breakp: ;arrive here when programmed break occurs + di + shld hloc ;hl saved + pop h ;recall return address + dcx h ;decrement for restart + shld ploc +; dad sp below destroys cy, so save and recall + push psw ;into user's stack + lxi h,2 ;bias sp by 2 because of push + dad sp ;sp in hl + pop psw ;restore cy and flags + lxi sp,stack-4;local stack + push h ;sp saved + push psw + push b + push d +; machine state saved, clear break points + ei ;in case interrupt driven io + lhld ploc ;check for rst instruction + mov a,m ;opcode to a + cpi rstin +; save condition codes for later test + push psw +; save ploc for later increment or decrement + push h +; +; clear any permanent break points +; +; check for auto "u" command from perm break pass + lda pbcnt ;=00 if no auto u in effect + sta autou ;hold this condition in auto u +; +; permanent breaks may be active, clear them +; + lxi h,pbtable+(pbsize-1)*pbelt ;set to last elt + mvi c,pbsize ;number of elements +resper0: + push h ;save element address + mov a,m ;(count) + ora a ;set flags + jz resper1 ;skip if not in use + inx h ;to next address + mov e,m ;low(addr) + inx h + mov d,m ;high(addr) + inx h + mov a,m ;data to set at addr + stax d ;data back to memory +resper1: + pop h ;base of element + lxi d,-pbelt ;element size + dad d ;addressing previous element + dcr c ;count table douwn + jnz resper0 ;for another element +; +; drop through when we have replaced all elements, +; now check for an "auto u" command from the last +; permanent break point bypass + call respbc ;restore pbcnt +; +clergo: +; clear "go" breakpoints which are pending + lxi h,breaks + mov a,m + mvi m,0 ;set to zero breaks +cler0: ora a ;any more? + jz cler1 + dcr a + mov b,a ;save count + inx h ;address of break + mov e,m ;low addr + inx h + mov d,m ;high addr + inx h + mov a,m ;instruction + stax d ;back to program + mov a,b ;restore count + jmp cler0 +; +cler1: +; all breakpoints have been cleared, check type of interrupt + pop h ;restore ploc + pop psw ;restore condition rstin=instruction + jz softbrk ;skip to softbreak if rst instruction + inx h ;front panel interrupt, don't dec ploc + shld ploc ;incremented + xchg ;ploc to de + if isis2 ;check for below bdtop + lxi b,bdtop + call bcde + jnc softbrk + else + lxi h,trapjmp+1 ;address ifeld of jmp bdos + mov c,m ;low address + inx h ;.high address + mov b,m ;bc is bdos address + call bcde ;to compare + jc softbrk + endif +; +; in the bdos, don't break until the return occurs + call clrtrace + lhld retloc ;trapped upon entry to bdos + xchg + mvi a,82h ;looks like g,bbbb + ora a ;sets flags + stc ;"," after g + jmp gopr ;to set break points +; +softbrk: + ;now check for a matching address for a permanent break +; a matching address for a permanent break + lda pbtrace ;ff if trace from last perm break + ora a ;ff if traced + jnz stopcrx ;stop if so +; +; may be active permanent breaks, are we at one now? + lxi h,pbtable + mvi c,pbsize +chkpb0: ;check next element for permanent break address + push h ;save current pbtable address + mov a,m ;(count) + ora a ;set flags + jz chkpb3 ;skip if zero + inx h ;.low(addr) + mov a,m ;low(addr) in a + inx h + mov d,m ;high(addr) in d + lhld ploc ;program location + cmp l ;low(addr) = low(ploc)? + jnz chkpb3 ;skip if not + mov a,d ;check high bytes + cmp h + jnz chkpb3 ;skip if addr <> ploc +; +; addresses match, print trace or stop + pop h ;recall element address + mov a,m ;pass count + dcr a ;1 becomes 0 + jnz chkpb1 ;skip if not last count +; +; stop execution at this point + push psw ;for "pass" report below + dcr a ;00 becomes ff + sta pbtrace ;perm break trace on +; trace is cleared on next iteration through code +; zero in accumulator printed in trace heading + jmp chktra0 ;to trace and stop +; +chkpb1: ;not the last count, decrement and set autou mode + mov m,a ;count=count-1 + push psw ;save count + call dectra ;decrement trace counters + cpi 2 ;trace mode = 2? + jz chktra0 ;skip to print trace if so +; +; must be u/-u or g/-g, check negative command + lda negcom + ora a ;set to ff if -u or -g + jz chktra0 ;00 if u or g, so trace it +; +; must be -u or -g, so suppress the trace through +; ploc will match perm break address in gopr, so compute breaks + call nbrk ;setup break addresses + jmp gopr ;to move past break address +; +chktra0: + ;print the header and go around again (may be one more time) +; (decremeted count is currently stacked) + call crlf + pop psw + inr a ;restore count + call pbyte ;print the byte value + lxi h,passmsg ;hh pass + call prmsg ;pass message printed + lhld ploc ;location counter + xchg ;readied for paddsy + call paddsy ;print address and symbol + call dstate ;display the current cpu state + jmp gopr ;to iterate one last time +; +chkpb3: ;move to next element + pop h ;recall element address + lxi d,pbelt ;element size + dad d ;to next element + dcr c ;count table down + jnz chkpb0 +; +cler2: ;end of permanent breakpoint scan +; arrive here following simple break from a g command, or +; following an autou past a permanent break point +; may also be trace/untrace mode +; + call break ;break at the console? + jnz stopcrx ;stop execution if so + call dectra ;decrement trace flags + jz stopcr ;end if auto u not set (tmode=0) + dcr a ;1=untrace becomes 0 + jnz break1 ;skip to print trace if not +; +; untrace mode, with or without autou set +; current ploc is not a permanent break address + call nbrk ;next break computed + jmp gopr ;go to the program untraced +; +break1: ;must be trace mode, not a permanent break address +; with or without the autou flag set + lhld ploc ;label trace + call prlabel + call dstate ;display cpu state + jmp gopr ;to next machine instruction +; +stopcr: ;not untrace/trace mode, if autou set then continue +; since this must be a step through a break point + lda autou + ora a ;zero set? + jz stopcrx ;skip if autou not set +; auto u set, must be step through a break point, next address +; is not a permanent break point, so go to user breaks + lhld gobrk2 ;auxiliary break point + mov c,l ;to bc + mov b,h ;in case set + lhld gobrk1 ;primary break point + xchg ;to de + lda gobrks ;number of breaks set by user + ora a ;may set the zero flag + stc ;carry indicates use current ploc + jmp gopr ;to continue +; +stopcrx: + call crlf +; +stopex: + call respbc ;restore pbcnt/pbloc, if necessary + lxi h,0 + shld userbrk ;clear user break address + call clrtrace ;trace flags go to zero + sta pbtrace ;clear perm trace flag + mvi a,'*' + call pchar + lhld ploc +; check to ensure disassembler is present + call chkdis + jnc stop0 + shld dispc +stop0: call paddsh ;print address with symbol location + lhld hloc + shld disloc + jmp start +; +passmsg: + db ' PASS ',0 ;printed in pass trace +; +dectra: ;decrement trace flags if trace mode + lxi h,tmode ;trace mode 0 if off, 1 un, 2 tr + mov a,m ;to accum + ora a ;set condition flags + rz ;no action if off + push h ;save tmode address + lhld tracer ;get count + dcx h ;count=count-1 + shld tracer ;back to memory + mov a,h ;now zero? + ora l ;hl=0000? + pop h ;restore tmode address + jnz dectr0 ;skip if not + mov m,a ;tmode = 0 + dcr a ;accum = ff + sta pbtrace ;to stop on next iteration +dectr0: mov a,m ;recall tmode + ora a ;set flags + ret +; +cat: ;determine opcode category - code in register b +; d,e contain double precision category number on return + lxi d,opmax ;d=0,e=opmax + lxi h,oplist +cat0: mov a,m ;mask to a + ana b ;mask opcode from b + inx h ;ready for compare + cmp m ;same after mask? + inx h ;ready for next compare + jz cat1 ;exit if compared ok + inr d ;up count if not matched + dcr e ;finished? + jnz cat0 +cat1: mov e,d ;e is category number + mvi d,0 ;double precision + ret +; +respbc: ;restore pbcnt to pbloc, if req'd + lda pbcnt ;00 if no auto u + ora a ;set flags + rz ;no further actions if so + lhld pbloc ;pbtable element to restore + mov m,a ;(count) + xra a ;clear accumulator + sta pbcnt ;clear auto u mode + ret +; +nbrk: ;find next break point address +; upon return, register a is setup as if user typed g,b1,b2 or +; g,b1 depending upon operator category. b,c contains second bp, +; d,e contains primary bp. hl address next opcode byte + lhld ploc + mov b,m ;get operator + inx h ;hl address byte following opcode + push h ;save it for later + call cat ;determine operator category + lxi h,catno ;save category number + mov m,e + lxi h,cattab;category table base + dad d ;inxed + dad d ;inxed*2 + mov e,m ;low byte to e + inx h + mov d,m ;high byte to d + xchg + pchl ;jump into table +; +; opcode category table +callop equ 2 ;position of call operator +callcon equ 3 ;position of call conditional +cattab: dw jmpop ;jump operator + dw ccop ;jump conditional + dw jmpop ;call operator (treated as jmp) + dw ccop ;call conditional + dw retop ;return from subroutine + dw rstop ;restart + dw pcop ;pchl + dw imop ;single precision immediate (2 byte) + dw imop ;adi ... cpi + dw dimop ;double precision immediate (3 bytes) + dw dimop ;lhld ... sta + dw rcond ;return conditional + dw imop ;in/out +; next dw must be the last in the sequence + dw simop ;simple operator (1 byte) +; +jmpop: ;get operand field, check for bdos + call getopa ;get operand address to d,e and compare with bdos + jnz endop ;treat as simple operator if not bdos +; otherwise, treat as a return instruction +retop: call getsp ;address at stacktop to d,e + jmp endop ;treat as simple operator +; +cbdos: ;de addresses a possible break point - check to ensure +; it is not a jump to the bdos +; + lda trapjmp+1 ;low bdos address + cmp e + rnz + lda trapjmp+2 ;high bdos address + cmp d + ret +; +getopa: ;get operand address and compare with bdos + pop b ;get return address + pop h ;get operand address + mov e,m + inx h + mov d,m + inx h + push h ;updated pc into stack + push b ;return address to stack + jmp cbdos ;return through cbdos with zero flag set +; +getsp: ;get return address from user's stack to d,e + lhld sloc + mov e,m + inx h + mov d,m + ret +; +ccop: ;call conditional operator + call getopa ;get operand address to d,e / compare with bdos + jz ccop1 +; not the bdos, break at operand address and next address + pop b ;next address to b,c + push b ;back to stack + mvi a,2 ;two breakpoints + jmp retcat ;return from nbrk +; +ccop1: ;break address at next location only, wait for return from bdos + pop d + push d ;back to stack + jmp endop ;one breakpoint address +; +rstop: ;restart instruction - check for rst 7 + mov a,b + cpi rstin ;restart instruction used for soft int + jnz rst0 +; +; soft rst, no break point since it will occur immediately + xra a + jmp retcat1 ;zero accumulator +rst0: ani 111000b ;get restart number + mov e,a + mvi d,0 ;double precision breakpoint to d,e + jmp endop +; +pcop: ;pchl + lhld hloc + xchg ;hl value to d,e for breakpoint + call cbdos ;bdos value? + jnz endop +; pchl to bdos, use return address + jmp retop +; +chkcall: + ;check for call or call conditional operator, + ;if found, use the return address (pc+3) as break + ;return "no carry" if call or call conditional + lda catno ;category number + cpi callop ;category number for call operator + rc ;carry if below callop +; must be call operator or above + cpi callcon+1 +; carry set if below callcon+1, so complement + cmc ;carry if callcon+1 or above + rc ;carry implies not between callop and callcon +; must be between callop and callcon (inclusive) +; use pc+3 as the break for tw/uw or rom entry + lhld ploc + inx h + inx h + inx h ;ploc+3 + xchg ;to de + ret ;with the no-carry bit set +; +; +simop: ;simple operator, use stacked pc + pop d + push d + jmp endop +; +rcond: ;return conditional + call getsp ;get return address from stack + pop b ;b,c alternate location + push b ;replace it + mvi a,2 + jmp retcat ;to set flags and return +; +dimop: ;double precision immediate operator + pop d + inx d ;incremented once, drop thru for another + push d ;copy back +; +imop: ;single precision immediate + pop d + inx d + push d +; +endop: ;end operator scan + mvi a,1 ;single breakpoint +retcat: ;return from nbrk + inr a ;count up for g,... + stc +retcat1: + push psw ;save register state in case userbrk + lhld userbrk + mov a,h + ora l + jz retcat2 ;no userbrk if zero +; + push d ;save break point + push b ;save aux break point + push h ;save userbrk address for pchl below +; user break occurs here, call user routine and check return + lxi h,catno + mov c,m ;opcode category is in c + lhld ploc + xchg ;location of instruction in d,e + lxi h,retuser + xthl ;return address to stack, userbrk to h,l + pchl +retuser: ;return from user break, check register a + ora a + pop b ;restore breakpoints + pop d + jz retcat2 +; abort the operation with a condition + push psw + mvi a,'#' + call pchar + pop psw + call pbyte + mvi a,' ' + call pchar + jmp stopex ;stop execution +retcat2: + ;check for call operator with tw or uw mode set + lda tmode + lxi h,wdisp ;wdisp=ff if w encountered + ana m ;non zero if tmode>0, wmode set + jz notcall ;skip if not a call +; +; this may be a call or call condition in tw/uw mode + call chkcall ;check for call, nc set if found + jc notcall ;skip if not a call +; +; this is a call in tw/uw mode, de is pc+3, use it for break + pop psw ;previous break count in a + mvi a,2 ;use only one break + jmp retcat4 ;to return from nbrk +; +notcall: + pop psw ;recall g, state + push psw ;save for final return below +; +; now check to ensure that break is not in rom + ora a ;zero break points set? + jz retcat3 ;skip to end if so +; +; must be 2/3 in accumulator + dcr a ;resulting in 1/2 breakpoints +; bc = aux breakpoint, de = primary breakpoint +romram: xchg ;first/aux breakpoint to hl + mov e,a ;breakpoint count to e (1/2) + mov a,m ;get code byte + cma ;complement for rom test + mov m,a ;store to rom/ram + cmp m ;did it change? + cma ;complement back to orginal + mov m,a ;restore in case ram + mov a,e ;restore breakpoint count +; arrive here with zero flag set if ram break + xchg ;break address back to de + push psw ;save count + jz ramloc ;skip if ram location +; +; break address is in rom. if conditional call, let +; it go, the return break is already set. if a simple +; call, set break at the ploc+3. otherwise, assume that +; the stack contains the return address + call chkcall ;check for call or call conditional + jnc ramloc ;nc if found, de is return address + ;not a call operation, must be pchl or jmp + call getsp ;get the return address from stack +; +ramloc: pop psw ;restore break count + dcr a ;1/2 breaks becomes 0/1 + jz retcat3 ;stop analysis if breaks exhausted +; otherwise, exchange bc/de and retry + push d ;de saved for exchange + mov e,c ;low bc to low de + mov d,b ;high bc to high de + pop b ;old de to bc + jmp romram ;to analze next break +; +retcat3: + ;analysis of rom/ram complete, restore counts + pop psw ;break count and carry +retcat4: + pop h ;next address recalled + ret +; +; +; +; opcode category tables +oplist: db 1111$1111b, 1100$0011b ;0 jmp + db 1100$0111b, 1100$0010b ;1 jcond + db 1111$1111b, 1100$1101b ;2 call + db 1100$0111b, 1100$0100b ;3 ccond + db 1111$1111b, 1100$1001b ;4 ret + db 1100$0111b, 1100$0111b ;5 rst 0..7 + db 1111$1111b, 1110$1001b ;6 pchl + db 1100$0111b, 0000$0110b ;7 mvi + db 1100$0111b, 1100$0110b ;8 adi...cpi + db 1100$1111b, 0000$0001b ;9 lxi + db 1110$0111b, 0010$0010b ;10 lhld shld lda sta + db 1100$0111b, 1100$0000b ;11 rcond + db 1111$0111b, 1101$0011b ;in out +opmax equ ($-oplist)/2 +; +; symbol access algorithms +alookup: +;look for the symbol with address given by de +;return with non zero flag if found, zero if not found +;when found, base address is returned in hl: +; : high addr : +; : low addr: +; hl: : length : +; : char 1 : +; . . . +; : char len: +; (list terminated by length > 15) + lhld sytop ;top symbol in table + inx h ;to low address + inx h ;to high address field +alook0: mov b,m ;high address + dcx h + mov c,m ;low address + dcx h ;.length + mov a,m ;get length + cpi 16 ;max length is 15 + jnc alook2 ;to stop the search + push h ;save current location in case matched + cma ;1's complement of low(length) + add l ;add to hl + mov l,a + mvi a,0ffh ;1's complement of high(length) + adc h ;propagate carry for subtract + mov h,a ;hl is hl-length-1 +; now compare symbol address + mov a,e ;low of search address + cmp c ;-low of symbol address + jnz alook1 ;skip if unequal + mov a,d + sub b ;skip if unequal + jnz alook1 +; symbol matched, return hl as symbol address + pop h + inr a ;difference was zero + ret ;with non zero flag set +; +alook1: ;symbol not matched, look for next + inx sp + inx sp ;remove stacked address + jmp alook0 ;for another search +; +; symbol address not found +alook2: xra a + ret ;with zero flag set +; +; +; ********************************* +; * * +; * Data Structures * +; * * +; ********************************* +; +; D - structures +disloc: ds 2 ;display location +DISEND: db FALSE ;storage for end of display +dismax: ds 2 ;max value for current display +tdisp: ds 2 ;temp 16 bit location +DISTMP: ds 2 ;temp storage for 16bit add +; +; G - structures +autou: ds 1 ;ff if auto "u" command in effect +gobrks: ds 1 ;number of breaks in go command +gobrk1: ds 2 ;primary break in go command +gobrk2: ds 2 ;secondary break in go command +pbloc: ds 2 ;pbtable location for auto u +pbcnt: db 00 ;permanent break temp counter +; +; H - structures +dtable: ;decimal division table + dw 10000 + dw 1000 + dw 100 + dw 10 + dw 1 +; +; R - structures +bias: ds 2 ;holds r bias value for load +sytop: ds 2 ;high symbol table address +mload: ds 2 ;max load address +dasm: ds 1 ;00 if dis/assem present, 01 if not +symsg: db cr,lf,'SYMBOLS',0 +lmsg: db cr,lf,'NEXT MSZE PC END',cr,lf,0 +DEFLOAD: ds 2 ;holds the default read address +; +; T - structures +tmode: ds 1 ;trace mode +userbrk:ds 2 ;user break address if non-zero +tracer: ds 2 ;trace count +; +; W - structures +WRTREC: ds 2 ;# of written records +WBEGIN: ds 2 ;Beginning address of write +WEND: ds 2 ;ending address of write +WRTMSG: db CR,LF,0 +WRTMSG1: db 'h record(s) written.',0 +; +; Common to all routines +; +lastexp:dw 0000 ;last expression encountered +; +pbtrace: + ds 1 ;trace on for perm break +pbtable: + rept pbsize ;one for each element + db 0 ;counter + ds 2 ;address + ds 1 ;data + endm +; each perm table element takes the form: +; low(count) high(count) low(addr) high(addr) data +; +; +negcom: ds 1 ;00 if normal command, ff if "-x" +wdisp: ds 1 ;00 if byte display, ff if word display +catno: ds 1 ;category number saved in nbrk +retloc: ds 2 ;return address to user from bdos +breaks: ds 7 ;#breaks/bkpt1/dat1/bkpt2/dat2 +explist:ds 7 ;count+(exp1)(exp2)(exp3) +nextcom:ds 2 ;next location from command buffer +comlen: db csize ;max command length +curlen: ds 1 ;current command length +combuf: ds csize ;command buffer +; temporary values used in "r" command share end of buffer +tfcb equ $-fcbl/2;holds name of symbol file during code load +; + ds ssize ;stack area +stack: +ploc equ stack-2 ;pc in template +hloc equ stack-4 ;hl +sloc equ stack-6 ;sp +aloc equ stack-7 ;a +floc equ stack-8 ;flags +bloc equ stack-10 ;bc +dloc equ stack-12;d,e +; + nop ;for relocation boundary + end diff --git a/software/CPM/cpm3/put.plm b/software/CPM/cpm3/put.plm new file mode 100644 index 0000000..896f635 --- /dev/null +++ b/software/CPM/cpm3/put.plm @@ -0,0 +1,975 @@ +$ TITLE('CP/M 3.0 --- PUT user interface') +put: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* +Written: 02 Aug 82 by John Knight +9/6/82 - changed RSX deletion & sub-function codes + - modified syntax & messages + - fixed password handling +9/11/82 - sign-on message +11/30/82 - interaction with SAVE + - PUT CONSOLE INPUT TO FILE +*/ + +/******************************************** +* * +* LITERALS AND GLOBAL VARIABLES * +* * +********************************************/ + +declare + true literally '1', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + lf literally '10', + ctrlc literally '3', + ctrlx literally '18h', + bksp literally '8', + con$type literally '0', + aux$type literally '1', + list$type literally '2', + input$type literally '3', + con$width$offset literally '1ah', + ccp$flag$offset literally '18h', + init$rsx literally '132', + kill$con$rsx literally '133', + kill$lst$rsx literally '137', + kill$journal$rsx literally '141', + get$con$fcb literally '134', + get$lst$fcb literally '138', + get$journal$fcb literally '142', + cpmversion literally '30h'; + + declare ccp$flag byte; + declare con$width byte; + declare i byte; + declare begin$buffer address; + declare buf$length byte; + declare no$chars byte; + declare rsx$kill$pb byte initial(kill$con$rsx); + declare rsx$fcb$pb byte initial(get$con$fcb); + declare + warning (*) byte data ('WARNING:',cr,lf,'$'); + + /* scanner variables and data */ + declare + options(*) byte data + ('OUTPUT~TO~FILE~CONSOLE~CONOUT:~AUXILIARY~', + 'AUXOUT:~END~CON:~AUX:~LIST~LST:~PRINTER~INPUT',0FFH), + + options$offset(*) byte data + (0,7,10,15,23,31,41,49,53,58,63,68,73,81,86), + + put$options(*) byte data + ('NOT~ECHO~RAW~FILTERED~SYSTEM~PROGRAM',0FFH), + + put$options$offset(*) byte data + (0,4,9,13,22,29,36), + + end$list byte data (0ffh), + + delimiters(*) byte data (0,'[]=, ./;',0,0ffh), + + SPACE byte data(5), + + j byte initial(0), + buf$ptr address, + index byte, + endbuf byte, + delimiter byte; + + declare end$of$string byte initial ('~'); + + declare scbpd structure + (offset byte, + set byte, + value address); + + declare putpb structure + (output$type byte, + echo$flag byte, + filtered$flag byte, + program$flag byte) + initial(con$type,true,true,true); + + declare parse$fn structure + (buff$adr address, + fcb$adr address); + + declare passwd (8) byte; + + declare plm label public; + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + read$console: + procedure byte; + return mon2(1,0); + end read$console; + + printchar: + procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + + conin: + procedure byte; + return mon2(6,0fdh); + end conin; + + print$buf: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buf; + + read$console$buf: + procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address address; + declare max byte; + new$max = max; + call mon1(10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of characters input */ + end read$console$buf; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + check$con$stat: procedure byte; + return mon2(11,0); + end check$con$stat; + + delete$file: + procedure (fcb$address) address; + declare fcb$address address; + return mon3(19,fcb$address); + end delete$file; + + make$file: procedure (fcb) address; + declare fcb address; + return mon3(22,fcb); + end make$file; + + set$dma: procedure(dma); + declare dma address; + call mon1(26,dma); + end set$dma; + + /* 0ffh ==> return BDOS errors */ + return$errors: procedure (mode); + declare mode byte; + call mon1(45,mode); + end return$errors; + + getscbbyte: procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); + end getscbbyte; + + setscbbyte: + procedure (offset,value); + declare offset byte; + declare value byte; + scbpd.offset = offset; + scbpd.set = 0ffh; + scbpd.value = double(value); + call mon1(49,.scbpd); + end setscbbyte; + +rsx$call: procedure (rsxpb) address; +/* call Resident System Extension */ + declare rsxpb address; + return mon3(60,rsxpb); +end rsx$call; + + +get$console$mode: procedure address; +/* returns console mode */ + return mon3(6dh,0ffffh); +end get$console$mode; + +set$console$mode: procedure (new$value); + declare new$value address; + call mon1(6dh,new$value); +end set$console$mode; + +parse: procedure (pfcb) address external; + declare pfcb address; +end parse; + +putf: procedure (param$block) external; + declare param$block address; +end putf; + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr,idx$ptr); + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + idx$ptr address, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index based idx$ptr byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + /* No skip for PUT */ + do while ((delimiter < 1) or (delimiter > 9)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while ((delimiter := separator(charac)) = SPACE); + buf$ptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + if delimiter = 9 then + return; /* return if at end of buffer */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return; + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return; + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then + buf$ptr = buf$ptr + 1; + else + delimiter = 5; + return; + +end opt$scanner; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* fill string @ s for c bytes with f */ +fill: procedure(s,f,c); + declare s address; + declare (f,c) byte; + declare a based s byte; + do while (c:=c-1) <> 255; + a=f; + s=s+1; + end; +end fill; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* The error processor. This routine prints the command line + with a carot '^' under the offending delimiter, or sub-string. + The code passed to the routine determines the error message + to be printed beneath the command string. */ + +error: procedure (code); + declare (code,i,j,nlines,rem) byte; + declare (string$ptr,tstring$ptr) address; + declare chr1 based string$ptr byte; + declare chr2 based tstring$ptr byte; + declare carot$flag byte; + +print$command: procedure (size); + declare size byte; + do j=1 to size; /* print command string */ + call printchar(chr1); + string$ptr = string$ptr + 1; + end; + call crlf; + do j=1 to size; /* print carot if applicable */ + if .chr2 = buf$ptr then do; + carot$flag = true; + call printchar('^'); + end; + else + call printchar(' '); + tstring$ptr = tstring$ptr + 1; + end; + call crlf; +end print$command; + + carot$flag = false; + string$ptr,tstring$ptr = begin$buffer; + con$width = getscbbyte(con$width$offset); + if con$width < 40 then con$width = 40; + nlines = buf$length / con$width; /* num lines to print */ + rem = buf$length mod con$width; /* num extra chars to print */ + if code <> 2 then do; + if ((code = 1) or (code = 4)) then /* adjust carot pointer */ + buf$ptr = buf$ptr - 1; /* for delimiter errors */ + else if code <> 5 then + buf$ptr = buf$ptr - endbuf - 1; /* all other errors */ + end; + call crlf; + do i=1 to nlines; + tstring$ptr = string$ptr; + call print$command(con$width); + end; + call print$command(rem); + if carot$flag then + call print$buf(.('Error at the ''^'': $')); + else + call print$buf(.('Error at end of line: $')); + if con$width < 65 then + call crlf; + do case code; + call print$buf(.('Invalid option or modifier$')); + call print$buf(.('End of line expected$')); + call print$buf(.('Invalid file specification$')); + call print$buf(.('Invalid command$')); + call print$buf(.('Invalid delimiter$')); + call print$buf(.('File is Read Only$')); + end; + call mon1(0,0); +end error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +user$abort: procedure (a); + declare a address; + declare response byte; + + call print$buf(a); + call print$buf(.(' (Y/N)? $')); + response=read$console; + call crlf; + if not((response='y') or (response='Y')) then do; + call print$buf(.('PUT aborted$')); + call mon1(0,0); + end; + end user$abort; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +ucase: procedure (char) byte; + declare char byte; + if char >= 'a' then + if char < '{' then + return (char-20h); + return char; +end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +getucase: procedure byte; + declare c byte; + c = ucase(conin); + return c; +end getucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +getpasswd: procedure; + declare (i,c) byte; + call crlf; + call crlf; + call print$buf(.('Enter Password: $')); +retry: + call fill(.passwd,' ',8); + do i=0 to 7; +nxtchr: + if (c:=getucase) >= ' ' then + passwd(i)=c; + if c = cr then + return; + if c = ctrlx then + go to retry; + if c = bksp then do; + if i < 1 then + goto retry; + else do; + passwd(i := i - 1) = ' '; + goto nxtchr; + end; + end; + if c = 3 then + call mon1(0,0); + end; +end getpasswd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +put$msg: procedure; + call print$buf(.('Putting $')); + if putpb.output$type = list$type then + call print$buf(.('list$')); + else + call print$buf(.('console$')); + if putpb.output$type = input$type then + call print$buf(.(' input to $')); + else + call print$buf(.(' output to $')); +end put$msg; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +print$fn: procedure (fcb$ad); + declare k byte; + declare fcb$ad address; + declare driv based fcb$ad byte; + declare fn based fcb$ad (12) byte; + + if getscbbyte(26) < 48 then + call crlf; /* console width */ + call print$buf(.('file: $')); + if driv <> 0 then do; + call printchar('@'+driv); + call printchar(':'); + end; + do k=1 to 11; + if k=9 then + call printchar('.'); + if fn(k) <> ' ' then + call printchar(fn(k)); + end; +end print$fn; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +try$open: procedure; + declare (error$code,a) address; + declare prog$flag based a byte; + declare code byte; + + error$code = rsx$call(.rsx$fcb$pb); + if error$code <> 0ffh then do; /* ff means no active PUT file */ + a = error$code - 2; /* program output only? */ + if prog$flag then + a = rsx$call(.rsx$kill$pb); /* kill it if so */ + else do; + call print$buf(.warning); + call put$msg; + call print$fn(error$code); /* print the file name */ + call user$abort(.(cr,lf,'Do you want another file$')); + end; + end; + + call return$errors(0ffh); + call setdma(.passwd); /* set dma to password */ + if passwd(0) <> ' ' then + fcb(6) = fcb(6) or 80h; + error$code=make$file(.fcb); + if low(error$code)=0ffh then do; /* make failed? */ + code = high(error$code); + if code = 8 then do; /* file already exists */ + call print$buf(.warning); + call user$abort(.('File already exists; Delete it$')); + error$code = delete$file(.fcb); + if low(error$code) = 0ffh then do; + code = high(error$code); + if code = 3 then /* file is read only */ + call error(5); + if code = 7 then do; /* Password protected */ + call getpasswd; + call crlf; + end; + call return$errors(0); + error$code=delete$file(.fcb); + end; + end; + call return$errors(0); + if passwd(0) <> ' ' then + fcb(6) = fcb(6) or 80h; + error$code = make$file(.fcb); + end; + call return$errors(0); + call put$msg; + call print$fn(.fcb); /* print the file name */ + call putf(.putpb); /* do PUT processing */ +/*call mon1(0,0); debug exit */ +end try$open; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +kill$rsx: procedure; + declare (fcb$adr,a) address; + + if (delimiter <> 9) and (delimiter <> 2) then /* check for eoln or ']' */ + call error(1); + /* remove PUT RSX */ + do while (fcb$adr:=rsx$call(.rsx$fcb$pb)) <> 0ffh; + a = rsx$call(.rsx$kill$pb); + call print$buf(.('PUT completed for $')); + call print$fn(fcb$adr); + call crlf; + end; + call put$msg; + if putpb.output$type = list$type then + call print$buf(.('printer$')); + else + call print$buf(.('console$')); + call mon1(0,0); +end kill$rsx; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +output$options: procedure; + declare negate byte; + do while ((delimiter<>2) and (delimiter<>9)); + negate = false; + call opt$scanner(.put$options(0),.put$options$offset(0),.index); + if index = 1 then do; /* NOT */ + negate = true; + call opt$scanner(.put$options(0),.put$options$offset(0),.index); + end; + if (index=0) or (index=1) then + call error(0); + if index = 2 then do; /* ECHO */ + if negate then + putpb.echo$flag = false; + else + putpb.echo$flag = true; + end; + if index = 3 then do; /* RAW output */ + if negate then + putpb.filtered$flag = true; + else + putpb.filtered$flag = false; + end; + if index = 4 then do; /* FILTERED output */ + if negate then + putpb.filtered$flag = false; + else + putpb.filtered$flag = true; + end; + if index = 5 then do; /* SYSTEM output */ + if negate then + putpb.program$flag = true; + else + putpb.program$flag = false; + end; + if index = 6 then do; /* PROGRAM output */ + if negate then + putpb.program$flag = false; + else + putpb.program$flag = true; + end; + end; +end output$options; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +process$file: procedure(buf$adr); + declare status address; + declare buf$adr address; + declare char based status byte; + parse$fn.buff$adr = buf$adr; + parse$fn.fcb$adr = .fcb; + status = parse(.parse$fn); + if status = 0ffffh then do; + buf$ptr = parse$fn.buff$adr; + call error(2); /* bad file */ + end; + call move(8,.fcb16,.passwd); + if status = 0 then /* eoln */ + call try$open; + else do; + buf$ptr = status + 1; /* position buf$ptr past '[' */ + if char <> '[' then + call error(4); /* Invalid delimiter */ + else do; + call output$options; /* process output options */ + call try$open; + end; + end; +end process$file; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = 9); /* tabs & spaces */ + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /********************************* +* * +* M A I N P R O G R A M * +* * +*********************************/ + +plm: + do; + if (low(version) < cpmversion) or (high(version)=1) then do; + call print$buf(.('Requires CP/M 3.0$')); + call mon1(0,0); + end; + /* default modes for putf call */ + if not input$found(.tbuff(1)) then do; /* just PUT, no command tail */ + call print$buf(.('CP/M 3 PUT Version 3.0',cr,lf,'$')); + call print$buf(.('Put console output to a file$')); + call print$buf(.(cr,lf,'Enter file: $')); + no$chars = read$console$buf(.tbuff(0),128); + call crlf; + tbuff(1) = ' '; /* blank out nc field */ + tbuff(no$chars+2) = 0; /* mark eoln */ + if not input$found(.tbuff(1)) then /* quit, no file name */ + call mon1(0,0); + do i=1 to no$chars; /* make input capitals */ + tbuff(i+1) = ucase(tbuff(i+1)); + end; + begin$buffer = .tbuff(2); + buf$length = no$chars; + buf$ptr = .tbuff(2); + call process$file(.tbuff(2)); + end; + else do; /* Put with input */ + i = 1; /* skip over leading spaces */ + do while (tbuff(i) = ' '); + i = i + 1; + end; + begin$buffer = .tbuff(1); /* note beginning of input */ + buf$length = tbuff(0); /* note length of input */ + buf$ptr = .tbuff(i); /* set up for scanner */ + index = 0; + delimiter = 1; + call opt$scanner(.options(0),.options$offset(0),.index); + if (index=6) or (index=7) or (index=10) then do; /* AUX: */ + putpb.output$type = aux$type; + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 1 then /* OUTPUT */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 2 then /* TO */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 3 then /* FILE */ + call process$file(buf$ptr); + else do; + if (index=6) or (index=7) or (index=10) then /* AUX: */ + call kill$rsx; + else + call error(3); + end; + end; + else do; /* not AUX, check LST */ + if (index=11) or (index=12) or (index=13) then do; /* LIST */ + putpb.output$type = list$type; + putpb.echo$flag = false; /* don't echo list output */ + rsx$fcb$pb = get$lst$fcb; + rsx$kill$pb = kill$lst$rsx; + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 1 then /* OUTPUT */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 2 then /* TO */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 3 then /* FILE */ + call process$file(buf$ptr); + if (index=11) or (index=12) or (index=13) then /* LIST */ + call kill$rsx; + else + call error(3); + end; + else do; /* normal CONSOLE output */ + /* if CONSOLE or CONOUT or CON: */ + if (index=4) or (index=5) or (index=9) then do; /* CONSOLE */ + if delimiter = 9 then + call kill$rsx; + else + call opt$scanner(.options(0),.options$offset(0),.index); + end; + if index = 1 then /* OUTPUT */ + call opt$scanner(.options(0),.options$offset(0),.index); + else if index = 14 then do; /* INPUT */ + putpb.output$type = input$type; + putpb.echo$flag = true; + putpb.filtered$flag = false; + rsx$fcb$pb = get$journal$fcb; + rsx$kill$pb = kill$journal$rsx; + call opt$scanner(.options(0),.options$offset(0),.index); + end; + if index = 2 then /* TO */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index = 3 then /* FILE */ + call process$file(buf$ptr); + if (index=4) or (index=5) or (index=9) then /* CONOUT: or CONSOLE */ + call kill$rsx; + else + call error(3); + end; + end; + end; + end; +end put; diff --git a/software/CPM/cpm3/putf.asm b/software/CPM/cpm3/putf.asm new file mode 100644 index 0000000..e77d175 --- /dev/null +++ b/software/CPM/cpm3/putf.asm @@ -0,0 +1,578 @@ +$title ('PUTF - CP/M 3.0 Output Redirection - August 1982') +;****************************************************************** +; +; PUT 'Redirection Initializer' version 3.0 +; +; 11/30/82 - Doug Huskey +;****************************************************************** +; +; +; Copyright (c) 1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, Ca. +; 93950 +; +; +; generation procedure +; +; seteof put.plm +; seteof getscan.dcl +; seteof putf.asm +; seteof getscan.plm +; seteof parse.asm +; is14 +; asm80 putf.asm debug +; asm80 mcd80a.asm debug +; asm80 parse.asm debug +; plm80 put.plm pagewidth(100) debug optimize +; link mcd80a.obj,put.obj,parse.obj,putf.obj,plm80.lib to put.mod +; locate put.mod code(0100H) stacksize(100) +; era put.mod +; cpm +; objcpm put +; rmac putrsx +; link putrsx[op] +; era put.rsx +; ren put.rsx=putrsx.prl +; gencom put.com +; gencom put.com put.rsx +; +; +; This module is called as an external routine by the +; PL/M program PUT. The address of a the following +; structure is passed: +; +; declare putpb structure +; (output$type byte, +; echo$flag byte, +; filtered$flag byte, +; system$flag byte); +; +; output$type = 0 > console output (default) +; = 1 > auxiliary output +; = 2 > list output +; = 3 > console input +; +; echo = true > echo output to real device +; (default) +; = false > don't echo output (input is +; still echoed) +; filtered = true > convert control characters +; to a printable form +; preceeded by an ^ +; = false > no character conversions +; program = true > continue until user uses +; PUT command to revert to +; console +; = false > active only until program +; termination + public putf + extrn mon1,fcb,memsiz +; +; +true equ 0ffffh +false equ 00000h +; +biosfunctions equ true ;intercept BIOS list or conout +; +; +; low memory locations +; +wboot equ 0000h +wboota equ wboot+1 +; +; equates for non graphic characters +; +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +; +; BDOS function equates +; +cinf equ 1 ;read character +coutf equ 2 ;output character +crawf equ 6 ;raw console I/O +creadf equ 10 ;read buffer +cstatf equ 11 ;status +lchrf equ 5 ;list character +pbuff equ 9 ;print buffer +resetf equ 13 ;disk reset +selectf equ 14 ;select disk +openf equ 15 ;open file +closef equ 16 ;close file +delf equ 19 ;delete file +dreadf equ 20 ;disk read +makef equ 22 ;make file +dmaf equ 26 ;set dma function +curdrv equ 25 ;get current drive +dpbf equ 31 ;get dpb address +userf equ 32 ;set/get user number +resdvf equ 37 ;reset drive +scbf equ 49 ;set/get system control block word +rsxf equ 60 ;RSX function call +resalvf equ 99 ;reset allocation vector +pblkf equ 111 ;print block to console +lblkf equ 112 ;print block to list device +ginitf equ 128 ;GET initialization sub-function no. +gkillf equ 129 ;GET delete sub-function no. +gfcbf equ 130 ;GET file display sub-function no. +pinitf equ 132 ;PUT initialization sub-funct no. +pckillf equ 133 ;PUT CON: delete sub-function no. +pcfcbf equ 134 ;return PUT CON: fcb address +plkillf equ 137 ;PUT LST: delete sub-function no. +plfcbf equ 138 ;return PUT LST:fcb address +jinitf equ 140 ;JOURNAL initialization sub-funct no. +jkillf equ 141 ;JOURNAL delete sub-function no. +jfcbf equ 142 ;return JOURNAL fcb address +skillf equ 144 ;SUBMIT delete sub-function no. +sfcbf equ 145 ;SUBMIT fcb address function +svkillf equ 160 ;SAVE delete sub-function no. +; +; System Control Block definitions +; +scba equ 03ah ;offset of scbadr from SCB base +ccpflg1 equ 0b3h ;offset of ccpflags word from page boundary +submit equ 040h ;mask for active submit or get test +errflg equ 0aah ;offset of error flag from page boundary +conmode equ 0cfh ;offset of console mode from page boundary +listcp equ 0d4h ;offset of ^P flag from page boundary +common equ 0f9h ;offset of common memory base from pg. bound +wbootfx equ 068h ;offset of warm boot jmp from page. bound +constfx equ 06eh ;offset of constat jmp from page. bound +coninfx equ 074h ;offset of conin jmp from page. bound +conoufx equ 07ah ;offset of conout jmp from page. bound +listfx equ 080h ;offset of list jmp from page. bound +cstjmp equ 003h ;offset of console status jmp from warm boot +cinjmp equ 006h ;offset of console input jmp from warm boot +coujmp equ 009h ;offset of console output jmp from warm boot +lstjmp equ 00ch ;offset of list output jmp from warm boot + +; +; Restore mode equates (used with inr a, rz, rm, ret) +; +norestore equ 0ffh ;no BIOS interception +biosonly equ 07fh ;restore BIOS jump table only +everything equ 0 ;restore BIOS jump table and jmps in + ;RESBDOS (default mode) +; +; Instructions +; +lxih equ 21h ;LXI H, instruction +jmpi equ 0c3h ;jump instruction +; +;****************************************************************** +; START OF INITIALIZATION CODE +;****************************************************************** + cseg + +putf: + ;get parameters + mov h,b + mov l,c ;HL = .(parameter block) + mov a,m ;output type 0=con:,1=aux:,2=lst:,3=conin: + cpi 1 ;is it aux? + jz notimp ;error if so + cpi 3 ;is it console input only + jnz setlst + sta input ;non-zero => console input + xra a +setlst: sta list ;non-zero => list device + inx h + mov a,m ;echo/noecho mode + sta echo + inx h + mov a,m ;cooked/raw mode + sta cooked + inx h + mov a,m ;system/program mode + sta program + ; + ;check if enough memory + ; + lhld memsiz + mov a,h + cpi 20h + lxi d,memerr + jc error + ; + ;check if drive specified + lxi h,fcb + mov a,m ;drive code + dcr a ;drive specified? + jp movfcb ;jump if so + ; + ;set to current drive, if not + ; + mvi c,curdrv + push h ;save .fcb + call mon1 + pop h ;a=current drive, hl=.fcb + mov m,a ;set fcb to force drive select + inr m ;must be relative to 1 + ; +movfcb: ;copy default fcb up into data area for move to RSX + ; + mov e,a + mvi c,selectf ;make sure drive is selected + push h ;save .fcb + call mon1 ;so we get the right DPB + pop h + lxi d,putfcb + lxi b,32 ;length of fcb + call ldir ;move it to putfcb + ; + ;initialize other variables to be moved to RSX + ; + call getusr ;get current user number + sta putusr ;save for redirection file I/O + call getscbadr + shld scbadr ;System Control Block address + ; + ;initialize records per block (BLM) + ; + mvi c,dpbf + call mon1 ;HL = .disk parameter block + inx h + inx h + inx h ;HL = .blm + mov a,m + sta blm + ; + ;initialize function table (functions to be intercepted) + ; + lda list + ora a + lxi b,funcend-functbl ;count + lxi d,functbl ;destination + lxi h,pcfcbf*256+pckillf ;rsx function codes + jz ckinput + lxi h,listfunc ;list function table + call ldir + mvi a,lchrf + sta bdosfunc ;use list output for bios trap + mvi a,listfx + sta resoff ;offset of fixup for bios list + mvi a,lstjmp + sta biosoff ;offset of bios lst jmp + lxi h,plfcbf*256+plkillf + jmp getrsxadr +ckinput: + lda input + ora a + jz getrsxadr + lxi h,inputfunc + call ldir + mvi a,cinf + sta bdosfunc ;use console input + mvi a,coninfx + sta resoff ;offset of fixup for bios conin + mvi a,cinjmp + sta biosoff + sta echo ;must be non-zero for input + lhld scbadr + mvi l,ccpflg+1 + mov a,m + ani submit ;SUBMIT or GET active? + lxi d,noget + jnz error ;error if so + lxi h,jfcbf*256+jkillf + ; + ;get address of initialization table in RSX + ; +getrsxadr: + shld rsxfun + mvi c,rsxf ;PUT is not compatible with SAVE.RSX + lxi d,savkill ;as both SAVE & PUT trap warm starts + call mon1 ;eliminate SAVE.RSX if active + mvi c,rsxf + lxi d,rsxinit + call mon1 ;call PUT.RSX initialization routine + push h ;save address of destination for move + mov e,m + inx h + mov d,m ;DE = .kill flag + push d ;save for later set + ; +if biosfunctions + ; + inx h + inx h + inx h ;HL = .(.(bios entry in RSX)) + push h ;save for getting RSX entry point + ;later (in trap:) + ;check if BIOS jump table looks valid (jmp in right places) +check: lhld biosoff + xchg + lhld wboota + mov a,m + cpi jmpi ;should be a jump + dad d ;HL = .(jmp address) + mov a,m + cpi jmpi ;should be a jump + jnz bioserr ;skip bios redirection if not + ; + ;fix up RESBDOS to do BIOS calls to intercepted functions + ; + lhld scbadr + mvi l,common+1 + mov a,m ;get high byte of common base + ora a + jnz fix0 ;high byte = zero if non-banked + mvi a,biosonly + sta biosmode + jmp trap ;skip code that fixes resbdos + ;fix warmboot BIOS jmp in resbdos +fix0: mvi l,wbootfx ;HL = .warm boot fix in SCB + shld wmfix ;save for RSX restore at end + mov a,m + cpi jmpi ;is it a jump instruction? + jz fix1 ;jump if so + mvi a,biosonly ;whoops already traped + sta biosmode +fix1: mvi m,lxih ;change jump to an lxi h, + ;fix list bios jmp in resbdos + lda resoff + mov l,a + shld biosfix + mov a,m + cpi jmpi ;is it a jump instruction? + jz biosck ;jump if so + mvi a,biosonly ;whoops already changed + sta biosmode ;restore jump table only +fix3: mvi m,lxih + ; + ;get address of list entry point + ; +trap: pop h ;.(.(bios entry point in RSX)) + mov c,m + inx h + mov b,m + push h + lhld biosoff + xchg + lhld wboota + dad d ;HL = .(jmp address) + inx h ;move past jmp instruction + shld biosjmp ;save for RSX restore at end + mov e,m + mov m,c + inx h + mov d,m ;DE = bios routine address + mov m,b ;BIOS jmp jumps to RSX + xchg + shld biosout ;save bios routine address + ;get addresses of RSX bios trap + pop h + inx h + mov c,m ;HL = .(.(bios warm start in RSX)) + inx h + mov b,m ;BC = .bios warmstart entry in RSX + ; + ;patch RSX wmboot entry into BIOS jump table + ;save real wmboot address in RSX exit table + ; + lhld wboota + inx h + shld wmjmp ;save for RSX restore at end + mov e,m + mov m,c + inx h + mov d,m + mov m,b + xchg + shld wmsta ;save real bios warm start routine +endif + ; + ;move data area to RSX + ; +rsxmov: + pop h ;HL = .(kill flag = 0FFh) + inr m ;set to zero for redirection active + lxi h,movstart + pop d ;RSX data area address + lxi b,movend-movstart + call ldir + jmp wboot +; +; auxiliary redirection +; +notimp: + lxi d,notdone +error: + mvi c,pbuff + call mon1 + mvi c,closef + lxi d,fcb + call mon1 + mvi c,delf + lxi d,fcb + call mon1 + jmp wboot + + +if biosfunctions +; +; check if warm boot was fixed up by someone +; and list or console output was not +; +biosck: lda biosmode + cpi biosonly + jnz fix3 ;warm boot not fixed up +; +; can't do BIOS redirection +; +bioserr: + lxi d,nobios + mvi c,pbuff + call mon1 + lxi h,biosmode + mvi m,norestore + pop h ;throw away stacked bios entry + jmp rsxmov +endif +; +; get/set user number +; +getusr: mvi a,0ffh ;get current user number +setusr: mov e,a ;set current user number (in A) + mvi c,userf + jmp mon1 +; +; get system control block address +; (BDOS function #49) +; +; exit: hl = system control block address +; +getscbadr: + mvi c,scbf + lxi d,data49 + jmp mon1 +; +data49: db scba,0 ;data structure for getscbadd +; +; +; copy memory bytes (emulates z80 ldir instruction) +; +ldir: mov a,m ;get byte + stax d ;store it at destination + inx h ;advance pointers + inx d + dcx b ;decrement byte count + mov a,c ;loop if non-zero + ora b + jnz ldir + ret +; +;****************************************************************** +; DATA AREA +;****************************************************************** + +; +; equates function table +; +eot equ 0ffh ; end of function table +skipf equ 0feh ; skip this function +; +listfunc: + db lchrf, lblkf, coutf, cstatf, crawf + db pbuff, cinf, creadf, resetf, resdvf + db resalvf, pblkf, eot + +; Note that the list routines precede the console +; routines so that the CKLIST: routine in PUTRSX +; can distinquish list functions from console +; functions. + +inputfunc: ;preset for console input + db skipf, skipf, skipf, skipf, crawf + db skipf, cinf, creadf, resetf, resdvf + db resalvf, eot, skipf + + +; +savkill: db svkillf +rsxinit: db Pinitf +nobios: db cr,lf,'WARNING: Cannot redirect from BIOS',cr,lf,'$' +notdone: + db cr,lf + db 'ERROR: Auxiliary device redirection not implemented',cr,lf,'$' +memerr: + db cr,lf + db 'ERROR: Insufficient Memory',cr,lf,'$' +noget: + db cr,lf + db 'ERROR: You cannot PUT INPUT to a file',cr,lf + db ' when using GET or SUBMIT.',cr,lf,'$' +resoff: db conoufx +biosoff: dw coujmp +aux: db 0 + ; +;****************************************************************** +; Following variables are initialized by PUT.COM +; and moved to the PUT RSX - Their order must not be changed +;****************************************************************** + ; + ; +movstart: +inittable: ;addresses used by PUT.COM for +scbadr: dw 0 ;address of System Control Block + ; + if biosfunctions ;PUT.RSX initialization + ; +gobios: mov c,e + db jmpi +biosout: + dw 0 ;set to real BIOS routine + ; + ;restore only if changed when removed. +biosjmp: + dw 0 ;address of bios jmp initialized by COM +biosfix: + dw 0 ;address of jmp in resbdos to restore + db jmpi +wmsta: dw 0 ;address of real warm start routine +wmjmp: dw 0 ;address of jmp in bios to restore +wmfix: dw 0 ;address of jmp in resbdos to restore +bdosfunc: + db coutf +biosmode: + db 0 ;0FFh = no bios restore, 07fh = restore + ;only bios jmp, 0 = restore bios jump and + ;resbdos jmp when removed. + endif + +functbl: ;preset for console output + db skipf, skipf, coutf, cstatf, crawf, pbuff + db cinf, creadf, resetf, resdvf, resalvf, pblkf, eot + +funcend: + ; +input: db 0 ;non-zero if putting input to a file +list: db 0 ;TRUE if list output redirection +echo: db 1 ;echo output to device +cooked: ;must be next after echo + db 0 ;TRUE if ctrl chars displayed with ^ +rsxfun: +pkillf: db 255 ;put abort routine code +pfcbf: db 255 ;put FCB display function no. + ; ********** remaining variables must be in this order +record: db 0 ;counts down records to block boundary +blm: db 0 ;block mask = records per block (rel 0) +program: ;This must be @ .putfcb-2 + db 0 +putusr: db 0 ;user number for redirection file +putfcb: db 1 ;a + db 'SYSOUT ' + db '$$$' + db 0,0 +putmod: db 0 +putrc: db 0 + ds 16 ;map +putcr: db 0 + ; +cbufp: db 0 +movend: +;******************************************************************* + end + + \ No newline at end of file diff --git a/software/CPM/cpm3/putrsx.asm b/software/CPM/cpm3/putrsx.asm new file mode 100644 index 0000000..3e08b19 --- /dev/null +++ b/software/CPM/cpm3/putrsx.asm @@ -0,0 +1,881 @@ +title 'PUT.RSX 3.0 - CP/M 3.0 Output Redirection - August 1982' +;****************************************************************** +; +; PUT 'Output Redirection Facility' version 3.0 +; +; 11/30/82 - Doug Huskey +; This RSX redirects console or list output to a file. +;****************************************************************** +; +; +; generation procedure +; +; rmac putrsx +; xref putrsx +; link putrsx[op] +; ERA put.RSX +; REN put.RSX=putRSX.PRL +; GENCOM put.com put.rsx +; +; initialization procedure +; +; PUTF makes a RSX function 60 call with a sub-function of +; 128. PUTRSX returns the address of a data table containing: +; +; init$table: +; dw kill ;remove PUT at warmboot flg +; dw 0 ;reserved +; dw bios$output ;BIOS entry point into PUT +; dw putfcb ;FCB address +; +; PUTF initializes the data are between movstart: and movend: +; and moves it into PUT.RSX. This means that data should not +; be reordered without also changing PUTF.ASM. +; +; +true equ 0ffffh +false equ 00000h +; +bios$functions equ true ;intercept BIOS console functions +remove$rsx equ false ;this RSX does its own removal +; +; low memory locations +; +wboot equ 0000h +wboota equ wboot+1 +bdos equ 0005h +bdosl equ bdos+1 +buf equ 0080h +; +; equates for non graphic characters +; +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlh equ 08h ; backspace +ctlp equ 10h ; prnt toggle +ctlr equ 12h ; repeat line +ctls equ 13h ; stop/start screen +ctlu equ 15h ; line delete +ctlx equ 18h ; =ctl-u +ctlz equ 1ah ; end of file +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow +; +; BDOS function equates +; +cinf equ 1 ;read character +coutf equ 2 ;output character +crawf equ 6 ;raw console I/O +creadf equ 10 ;read buffer +cstatf equ 11 ;status +lchrf equ 5 ;print character +pbuff equ 9 ;print buffer +resetf equ 13 ;reset drive +openf equ 15 ;open file +closef equ 16 ;close file +delf equ 19 ;delete file +dreadf equ 20 ;disk read +writef equ 21 ;disk write +dmaf equ 26 ;set dma function +userf equ 32 ;set/PUT user number +resdvf equ 37 ;reset drive function +flushf equ 48 ;flush buffers function +scbf equ 49 ;set/PUT system control block word +loadf equ 59 ;Program load function +rsxf equ 60 ;RSX function call +resalvf equ 98 ;reset allocation vector +pblkf equ 111 ;print block to console +lblkf equ 112 ;print block to list device +ginitf equ 128 ;GET initialization sub-function no. +gkillf equ 129 ;GET delete sub-function no. +gfcbf equ 130 ;GET file display sub-function no. +pinitf equ 132 ;PUT initialization sub-function no. +pckillf equ 133 ;PUT console delete sub-function no. +plkillf equ 137 ;PUT list delete sub-function no. +pcfcbf equ 134 ;return PUT console fcb address +plfcbf equ 138 ;return PUT list fcb address +jinitf equ 140 ;JOURNAL initialization sub-function no. +jkillf equ 141 ;JOURNAL delete sub-function no. +jfcbf equ 142 ;return JOURNAL fcb address +; +; System Control Block definitions +; +scba equ 03ah ;offset of scbadr from SCB base +ccpflg equ 0b3h ;offset of ccpflags word from page boundary +ccpres equ 020h ;ccp resident flag = bit 5 +bdosoff equ 0feh ;offset of BDOS address from page boundary +errflg equ 0aah ;offset of error flag from page boundary +conmode equ 0cfh ;offset of console mode word from pag. bound. +outdel equ 0d3h ;offset of print buffer delimiter +listcp equ 0d4h ;offset of ^P flag from page boundary +usrcode equ 0e0h ;offset of user number from pg bnd. +dcnt equ 0e1h ;offset of dcnt, searcha & searchl from pg bnd. +constfx equ 06eh ;offset of constat JMP from page boundary +coninfx equ 074h ;offset of conin JMP from page boundary +; +; +;****************************************************************** +; RSX HEADER +;****************************************************************** + +serial: db 0,0,0,0,0,0 + +trapjmp: + jmp trap ;trap read buff and DMA functions +next: jmp 0 ;go to BDOS +prev: dw bdos +kill: db 0FFh ;Remove at wstart if not zero +nbank: db 0 +rname: db 'PUT ' ;RSX name +space: dw 0 +patch: db 0 + +;****************************************************************** +; START OF CODE +;****************************************************************** +; +; ABORT ROUTINE +; +puteof: ;close output file and abort + lda cbufp + ora a + jz restor + mvi e,ctlz + call putc + jmp puteof + + +; +;****************************************************************** +; BIOS TRAP ENTRY POINT +;****************************************************************** +; +; +; ARRIVE HERE ON EACH INTERCEPTED BIOS CALL +; +; +bios$output: + ; +if bios$functions + ; + ;enter here from BIOS constat + mov e,c ;character in E + lda bdosfunc ;BDOS function to use + mov c,a + mvi a,1 ;offset in exit table = 1 + jmp bios$trap +endif +; +; +;****************************************************************** +; BDOS TRAP ENTRY POINT +;****************************************************************** +; +; +; ARRIVE HERE AT EACH BDOS CALL +; +trap: + ; +if bios$functions + ; + xra a +biostrap: + ;enter here on BIOS calls + sta exit$off +endif + pop h ;return address + push h ;back to stack + lda trapjmp+2 ;PUT.RSX page address + cmp h ;high byte of return address + jc exit ;skip calls on bdos above here + mov a,c + cpi rsxf + jz rsxfunc ;check for initialize or abort + cpi dmaf + jz dmafunc ;save users DMA address + cpi 14 ;reset function + 1 + jc tbl$srch ;search if func < 14 + cpi 98 + jnc tbl$srch ;search if func >= 98 + cpi resdvf + jz tbl$srch ;search if func = 37 + ; + ; EXIT - FUNCTION NOT MATCHED + ; +exit: + +if not bios$functions + ; +exit1: jmp next ;go to next RSX or BDOS + +else + lda exit$off ;PUT type of call: +exit1: lxi h,exit$table ;0=BDOS call, 1=BIOS call +endif + +tbl$jmp: + + ; a = offset (rel 0) + ; hl = table address + add a ;double for 2 byte addresses + call addhla ;HL = .(exit routine) + mov b,m ;get low byte from table + inx h + mov h,m + mov l,b ;HL = exit routine + pchl ;gone to BDOS or BIOS + +tbl$srch: + + ; + ;CHECK IF THIS FUNCTION IS IN FUNCTION TABLE + ;if matched b = offset in table (rel 0) + ;FF terminates table + ;FE is used to mark non-intercepted functions + ; + lxi h,func$tbl ;list of intercepted functions + mvi b,0 ;start at beginning +tbl$srch1: + mov a,m ;get next table entry + cmp c ;is it the same? + jz intercept ;we found a match, B = offset + inr b + inx h + inr a ;0FFh terminates list + jnz tbl$srch1 ;try next one + jmp exit ;end of table - not found + +; +; +;****************************************************************** +; REDIRECTION PROCESSOR +;****************************************************************** +; +; +; INTERCEPTED BDOS FUNCTIONS ARRIVE HERE +; +; enter with +; B = routine offset in table +; C = function number +; DE = BDOS parameters + +intercept: + + ;switch to local stack + lxi h,0 + dad sp + shld oldstack + lxi sp,stack + +redirect: + + push d ;save info + push b ;save function + lhld scbadr + ; + ;are we active now? + ; + lda program + ora a ;program output only? + cnz ckccp ;if not, test if CCP is calling + jz cklist ;jump if not CCP or program output + mov a,c + cpi 0ah ;is it function 10? + jnz skip ;skip if not + lxi h,ccpcnt ;decrement once for each + dcr m ;CCP function 10 + cm puteof ;if 2nd appearance of CCP + jmp skip ;if CCP is active + ; + ;check for list processing and ^P status + ; +cklist: + lda list + ora a ;list redirection? + jz ckecho ;jump if not + mvi l,listcp ;HL = .^P flag + mov a,m + ora a ; ^P on? + jnz setecho ;set echo on if so + mov a,b + cpi 2 ;console function? + jnc skip ;skip if so +ckecho: lda echoflg ;echo parameter +setecho: + sta echo + ; + ;go to function trap routine + ; +gofunct: + lxi h,retmon ;program return routine + push h ;push on stack + mov a,b ;offset + lxi h,trap$tbl + jmp tbl$jmp ;go to table address +; +; +rawio: + ;direct console i/o - read if 0ffh + ;returns to retmon + mov a,e + cpi 0fdh + jc putchr + cpi 0feh + rz ;make the status call (FE) + jc conin ;make the input call (FD) + call next ;call for input/status (FF) + ora a + jz retmon1 + jmp conin1 + ; + ;input function + ; +conin: + call exit ;make the call +conin1: mov e,a ;put character in E + push psw ;save character + call conout ;put character into file + pop psw ;character in A + ; + ; RETURN FROM FUNCTION TRAP ROUTINE + ; + cpi cr + jnz retmon1 + +retmon2: + ;output linefeed before returning + push psw ;save character + lda echo + ora a ;no echo mode + mvi e,lf + mvi c,coutf + cz next ;output lf if so + lda input + ora a + cnz conout + pop psw ;restore character + +retmon1: + ;return to calling program + lhld old$stack + sphl + mov l,a +retmon0: + ret ;to calling program + ; +retmon: + ;echo before returning? + lda echo + ora a + jz retmon1 ;return to program if no echo + ;otherwise continue + ; + ; PERFORM INTERCEPTED BDOS CALL + ; +skip: + ;restore BDOS call and stack + pop b ;restore BDOS function no. + pop d ;restore BDOS parameter + lhld old$stack + sphl + jmp exit ;goto BDOS + +;****************************************************************** +; BIOS FUNCTIONS (REDIRECTION ROUTINES) +;****************************************************************** +; +putchr: + ;put out character in E unless putting input + lda input! ora a! rnz ;return (retmon) if input redirection +listf: +conout: +conoutf: +ctlout: + ;send E character with possible preceding up-arrow + mov a,e! cpi ctlz! jz ctlout1 ;always convert ^Z + call echoc ;cy if not graphic (or special case) + jnc putc ;skip if graphic, tab, cr, lf, or ctlh + + ctlout1: + ;send preceding up arrow + push psw! mvi e,ctl! call putc ;up arrow + pop psw! ori 40h ;becomes graphic letter + mov e,a ;ready to print + ;(drop through to PUTC) +; +; +; put next character into file +; +; +putc: ;write sector if full, close in each physical block + ;abort PUT if any disk error occurs + ;character in E + lxi h,cbufp + mov a,m ; A = cbufp + push h + inx h ;HL = .cbuf + call addhla ;HL = .char + mov m,e ;store character + pop h + inr m ;next chr position + rp ;minus flag set after 128 chars +; +; WRITE NEXT RECORD +; +write: + mvi c,writef + call putdos + cnz restor ;abort RSX if error + xra a + sta cbufp ;reset buffer position to 0 + lxi h,record + dcr m ;did we cross the block boundary? + rp ;return if not + call close ;close the file if so + cnz restor ;abort RSX if error + lxi h,blm ;HL = .blm + mov a,m + dcx h + mov m,a ;set record = blm + ret +; +; CLOSE THE FILE +; +close: + mvi c,closef +; +; PUT FILE OPERATION +; +putdos: + push b ;function no. in C + lxi d,cbuf + call setdma ;set DMA to our buffer + pop b ;function no. in C + lhld scbadr + push h ;save for restore + lxi d,sav$area ;10 byte save area + push d ;save for restore + call mov7 ;save hash info in save area + mvi l,usrcode ;HL = .BDOS user number in SCB + call mov7 ;save user, dcnt, search addr, len & + dcx h ; multi-sector count + mvi m,1 ;set multi-sector count=1 + mvi l,usrcode ;HL = .BDOS user number + lxi d,putusr + ldax d + mov m,a ;set BDOS user = putusr + inx d ;DE = .putfcb + call next ;write next record or close file + pop h ;HL = .sav$area + pop d ;DE = .scb + push psw ;save A (non-zero if error) + call mov7 ;restore hash info + mvi e,usrcode ;DE = .user num in scb + call mov7 ;restore dcnt search addr & len + lhld udma + xchg + call setdma ;restore DMA to program's buffer + pop psw + ora a + ret ;zero flag set if successful +; +; CLOSE FILE AND TERMINATE RSX +; +restor: + call close + lxi d,close$err + cnz msg ;print message if close error + lxi h,0ffffh + shld rsxfunctions ;set killf and fcbf to inactive + ; + ;set RSX aborted flag + ; + lxi h,kill ;0=active, 0ffh=aborted + mvi m,0ffh ;set to 0ffh (in-active) + ;are we the bottom RSX, if so remove ourselves immediately + ;to save memory + lda bdosl+1 ;get high byte of top of tpa + CMP H ;Does location 6 point to us + +if remove$rsx + jnz bios$fixup ;done, if not + lhld next+1 + shld bdosl + xchg + lhld scbadr + mvi l,bdosoff ;HL = "BDOS" address in SCB + mov m,e ;put next address into SCB + inx h + mov m,d + xchg + mvi l,0ch ;HL = .previous RSX field in next RSX + mvi m,7 + inx h + mvi m,0 ;put previous into previous +else + mvi c,loadf + lxi d,0 + cz next ;fixup RSX chain, if this RSX on bottom +endif + +if bios$functions + +bios$fixup: + ; + ;restore bios jumps + lda restore$mode ;may be FF, 7f or 0 + inr a + rz ; FF = no bios interception + lhld wmsta ;real warm start routine + xchg + lhld wmjmp ;wboot jump in bios + mov m,e + inx h + mov m,d ;restore real routine in jump + lhld biosout ;conin,conout or list jmp + xchg + lhld biosjmp ;address of real bios routine + mov m,e + inx h + mov m,d + rm ; 7f = RESBDOS jmps not changed + lhld wmfix + mvi m,jmp ;replace jmp for warm start + lhld biosfix + mvi m,jmp ;replace jmp for other trapped jump +endif + ret ; 0 = everything done +; +; set DMA address in DE +; +setdma: mvi c,dmaf + jmp next +; +; print message to console +; +msg: mvi c,pbuff + jmp next +; +; move routine +; +mov7: mvi b,7 + ; HL = source + ; DE = destination + ; B = count +move: mov a,m + stax d + inx h + inx d + dcr b + jnz move + ret +; +; add a to hl +; +addhla: add l + mov l,a + rnc + inr h + ret + +; +; check if CCP is calling +; +ckccp: + ;returns zero flag set if not CCP + lhld scbadr + mvi l,ccpflg+1 ;HL = .ccp flag 2 + mov a,m + ani ccpres ;is it the CCP? + ret +; +;****************************************************************** +; BDOS FUNCTION HANDLERS +;****************************************************************** +; +; +; FUNCTION 26 - SET DMA ADDRESS +; +dmafunc: + xchg ;dma to hl + shld udma ;save it + xchg + jmp next +; +; +; BIOS WARM START TRAP FUNCTION +; +warmtrap: + lxi sp,stack + call close ;close if wboot originated below RSX + jmp wstart +; +; BDOS FUNCTION 60 - RSX FUNCTION CALL +; +rsxfunc: ;check for initialize or delete RSX functions + ldax d ;get sub-function number + cpi pinitf ;is it a PUT initialization + lxi h,init$table + rz ;return to caller if init call + ;check for FCB display functions + mov b,a + lda fcbf ;is it a a PUT fcb request + cmp b + lxi h,putfcb + rz ;return if so + ;check for kill function + lda killf ;local kill (kill only this one) + cmp b + jz puteof ;kill and return to caller + jmp exit ;abort any higher PUTs + +; +; +;****************************************************************** +; BDOS OUTPUT ROUTINES +;****************************************************************** +; +; +; July 1982 +; +; +; Console handlers +; +echoc: + ;are we in cooked or raw mode? + lda cooked! ora a! mov a,e! rz ;return if raw + ;echo character if graphic + ;cr, lf, tab, or backspace + cpi cr! rz ;carriage return? + cpi lf! rz ;line feed? + cpi tab! rz ;tab? + cpi ctlh! rz ;backspace? + cpi ' '! ret ;carry set if not graphic +; +; +print: + ;print message until M(DE) = '$' + lhld scbadr + mvi l,OUTDEL + ldax d! CMP M! rz ;stop on delimiter + ;more to print + inx d! push d! mov e,a ;char to E + call conout ;another character printed + pop d! jmp print +; +; +read: + ;put prompt if in no echo mode + lda echo! ora a! jnz read1 + push d + lxi d,prompt! call msg ;output prompt + pop d! mvi c,creadf ;set for read call +read1: + ;read console buffer + pop h ;throw away return address + push d + call next ;make the call + pop h! inx h! mov b,m! inr b ;get the buffer length +putnxt: dcr b! jz read2 + inx h! mov e,m! push b! push h + call conout! pop h! pop b ;put character + jmp putnxt + +read2: lda input! ora a! push psw + mvi e,cr! cnz conout ;call if putting input + pop psw! mvi e,lf! cnz conout ;call if putting input + jmp retmon1 + + +; +func1: equ conin +; +func2: equ conout + ;write console character +; +func5: equ listf + ;write list character + ;write to list device +; +func6: equ rawio +; +func9: equ print + ;write line until $ encountered +; +func10: equ read +; +func11: equ retmon0 +; +func13: equ close +; +func37: equ close +; +func98: equ close +; +FUNC111: ;PRINT BLOCK TO CONSOLE +FUNC112: ;LIST BLOCK + XCHG! MOV E,M! INX H! MOV D,M! INX H + MOV C,M! INX H! MOV B,M! XCHG + ;HL = ADDR OF STRING + ;BC = LENGTH OF STRING +BLK$OUT: + MOV A,B! ORA C! RZ ;is length 0, return if so + PUSH B! PUSH H + mov e,m! call conout ;put character + POP H! INX H! POP B! DCX B + JMP BLK$OUT + +; end of BDOS Console module + +;****************************************************************** +; DATA AREA +;****************************************************************** + +exit$off db 0 ;offset in exit$table of destination + +trap$tbl: + ;function dispatch table (must match func$tbl below) +; db lchrf, lblkf, coutf, cstatf, crawf +; db pbuff, cinf, creadf, resetf, resdvf +; db resalvf, pblkf, eot + + dw func5 ;function 5 - list output + dw func112 ;function 112 - list block + dw func2 ;function 2 - console output + dw func11 ;function 11 - console status + dw func6 ;function 6 - raw console I/O + dw func9 ;function 9 - print string + dw func1 ;function 1 - console input + dw func10 ;function 10 - read console buffer + dw func13 ;function 13 - disk reset (close first) + dw func37 ;function 37 - drive reset (close first) + dw func98 ;function 98 - reset allocation vector + dw func111 ;function 111 - print block + +;****************************************************************** +; Following variables and entry points are used by PUT.COM +; Their order and contents must not be changed without also +; changing PUT.COM. +;****************************************************************** + +movstart: +init$table: ;addresses used by PUT.COM for initial. +scbadr: ;address of System Control Block + dw kill ;kill flag for error on file make + ;(passed to PUT.COM by RSX init function) + ; + if bios$functions ;PUT.RSX initialization + ; +gobios: mov c,e + db jmp +biosout dw bios$output ;set to real BIOS routine + ;(passed to PUT.COM by RSXFUNC) +biosjmp + dw warm$trap ;address of bios jmp initialized by COM +biosfix + dw 0 ;address of jmp in resbdos to restore + ;restore only if changed when removed. +wstart: db jmp +wmsta: dw 0 ;address of real warm start routine +wmjmp: dw 0 ;address of jmp in bios to restore +wmfix: dw 0 ;address of jmp in resbdos to restore +bdosfunc: + db coutf +restore$mode + db 0 ;0FFh = no bios restore, 07fh = restore + ;only bios jmp, 0 = restore bios jump and + ;resbdos jmp when removed. + endif +; +; equates function table +; +eot equ 0ffh ; end of function table +skipf equ 0feh ; skip this function +; +; +func$tbl: ;no trapping until initialized by PUT.COM + db eot,0,0,0,0,0,0,0,0,0,0,0,0 +; db lchrf, lblkf, coutf, cstatf, crawf +; db pbuff, cinf, creadf, resetf, resdvf +; db resalvf, pblkf, eot + ; +input db 0 ;put console input to a file +list db 0 ;intercept list functions +echoflg: + db 1 ;echo output to device +cooked: ;must be next after echo + db 0 ;TRUE if ctrl chars (except ^Z) placed + ;in the output file +rsxfunctions: +killf: db 0ffh ;not used until PUT initialized +fcbf: db 0ffh ;not used until PUT initialized +record: db 0 ;counts down records to block boundary +blm: db 0 ;block mask = records per block (rel 0) +program: ;this flag must be @ .PUTFCB-2 + db 0 ;true if put program output only +putusr: db 0 ;user number for redirection file +putfcb: db 0ffh ;preset to 0ffh to indicate not active + db 'SYSOUT ' + db '$$$' + db 0,0 +putmod: db 0 +putrc: ds 1 + ds 16 ;map +putcr: ds 1 + ; +cbufp db 0 ;current character position in cbuf +movend: +;******************************************************************* + +cbuf: ;128 byte buffer (could be ds 128) + + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + + ; + if bios$functions + ; +exit$table: ;addresses to go to on exit + dw next ;BDOS + dw gobios + endif + ; +udma: dw buf ;user dma +user: db 0 ;user user number +echo: db 0 ;echo output to console flag +ccpcnt: db 1 ;start at 1 (decremented each CCP) +sav$area: ;14 byte save area + db 68h,68h,68h,68h,68h, 68h,68h,68h,68h,68h + db 68h,68h,68h,68h +close$err: + db cr,lf,'PUT ERROR: FILE ERASED',cr,lf,'$' +prompt: db cr,lf,'PUT>$' + ; +patch$area: + ds 30h + + maclib makedate ;[JCE] move all dates to one file + db ' ' + @BDATE + db ' ' + @SCOPY + + db 67h,67h,67h,67h, 67h,67h,67h,67h, 67h,67h,67h,67h + db 67h,67h,67h,67h, 67h,67h,67h,67h, 67h,67h,67h,67h + db 67h,67h,67h,67h, 67h,67h,67h,67h + ; +stack: ;16 level stack +oldstack: + dw 0 + end + \ No newline at end of file diff --git a/software/CPM/cpm3/random.asm b/software/CPM/cpm3/random.asm new file mode 100644 index 0000000..1cd60a1 --- /dev/null +++ b/software/CPM/cpm3/random.asm @@ -0,0 +1,358 @@ +;*************************************************** +;* * +;* sample random access program for cp/m 3 * +;* * +;*************************************************** + org 100h ;base of tpa +; +reboot equ 0000h ;system reboot +bdos equ 0005h ;bdos entry point +; +coninp equ 1 ;console input function +conout equ 2 ;console output function +pstring equ 9 ;print string until '$' +rstring equ 10 ;read console buffer +version equ 12 ;return version number +openf equ 15 ;file open function +closef equ 16 ;close function +makef equ 22 ;make file function +readr equ 33 ;read random +writer equ 34 ;write random +wrtrzf equ 40 ;write random zero fill +parsef equ 152 ;parse function +; +fcb equ 005ch ;default file control block +ranrec equ fcb+33 ;random record position +ranovf equ fcb+35 ;high order (overflow) byte +buff equ 0080h ;buffer address +; +cr equ 0dh ;carriage return +lf equ 0ah ;line feed +; +;*************************************************** +;* * +;* load SP, set-up file for random access * +;* * +;*************************************************** + lxi sp,stack +; +; version 3.1? + mvi c,version + call bdos + cpi 31h ;version 3.1 or better? + jnc versok +; bad version, message and go back + lxi d,badver + call print + jmp reboot +; +versok: +; correct version for random access + mvi c,openf ;open default fcb +rdname: lda fcb+1 + cpi ' ' + jnz opfile + lxi d,entmsg + call print + call parse + jmp versok +opfile: lxi d,fcb + call bdos + inr a ;err 255 becomes zero + jnz ready +; +; cannot open file, so create it + mvi c,makef + lxi d,fcb + call bdos + inr a ;err 255 becomes zero + jnz ready +; +; cannot create file, directory full + lxi d,nospace + call print + jmp reboot ;back to ccp +; +;*************************************************** +;* * +;* loop back to "ready" after each command * +;* * +;*************************************************** +; +ready: +; file is ready for processing +; + call readcom ;read next command + shld ranrec ;store input record# + lxi h,ranovf + mov m,c ;set ranrec high byte + cpi 'Q' ;quit? + jnz notq +; +; quit processing, close file + mvi c,closef + lxi d,fcb + call bdos + inr a ;err 255 becomes 0 + jz error ;error message, retry + jmp reboot ;back to ccp +; +;*************************************************** +;* * +;* end of quit command, process write * +;* * +;*************************************************** +notq: +; not the quit command, random write? + cpi 'W' + jnz notw +; +; this is a random write, fill buffer until cr + lxi d,datmsg + call print ;data prompt + mvi c,127 ;up to 127 characters + lxi h,buff ;destination +rloop: ;read next character to buff + push b ;save counter + push h ;next destination + call getchr ;character to a + pop h ;restore counter + pop b ;restore next to fill + cpi cr ;end of line? + jz erloop +; not end, store character + mov m,a + inx h ;next to fill + dcr c ;counter goes down + jnz rloop ;end of buffer? +erloop: +; end of read loop, store 00 + mvi m,0 +; +; write the record to selected record number + mvi c,writer + lxi d,fcb + call bdos + ora a ;error code zero? + jnz error ;message if not + jmp ready ;for another record +; +; +;******************************************************** +;* * +;* end of write command, process write random zero fill * +;* * +;******************************************************** +notw: +; not the quit command, random write zero fill? + cpi 'F' + jnz notf +; +; this is a random write, fill buffer until cr + lxi d,datmsg + call print ;data prompt + mvi c,127 ;up to 127 characters + lxi h,buff ;destination +rloop1: ;read next character to buff + push b ;save counter + push h ;next destination + call getchr ;character to a + pop h ;restore counter + pop b ;restore next to fill + cpi cr ;end of line? + jz erloop1 +; not end, store character + mov m,a + inx h ;next to fill + dcr c ;counter goes down + jnz rloop1 ;end of buffer? +erloop1: +; end of read loop, store 00 + mvi m,0 +; +; write the record to selected record number + mvi c,wrtrzf + lxi d,fcb + call bdos + ora a ;error code zero? + jnz error ;message if not + jmp ready ;for another record +; +;*************************************************** +;* * +;* end of write commands, process read * +;* * +;*************************************************** +notf: +; not a write command, read record? + cpi 'R' + jnz error ;skip if not +; +; read random record + mvi c,readr + lxi d,fcb + call bdos + ora a ;return code 00? + jnz error +; +; read was successful, write to console + call crlf ;new line + mvi c,128 ;max 128 characters + lxi h,buff ;next to get +wloop: + mov a,m ;next character + inx h ;next to get + ani 7fh ;mask parity + jz ready ;for another command if 00 + push b ;save counter + push h ;save next to get + cpi ' ' ;graphic? + cnc putchr ;skip output if not + pop h + pop b + dcr c ;count=count-1 + jnz wloop + jmp ready +; +;*************************************************** +;* * +;* end of read command, all errors end-up here * +;* * +;*************************************************** +; +error: + lxi d,errmsg + call print + jmp ready +; +;*************************************************** +;* * +;* utility subroutines for console i/o * +;* * +;*************************************************** +getchr: + ;read next console character to a + mvi c,coninp + call bdos + ret +; +putchr: + ;write character from a to console + mvi c,conout + mov e,a ;character to send + call bdos ;send character + ret +; +crlf: + ;send carriage return line feed + mvi a,cr ;carriage return + call putchr + mvi a,lf ;line feed + call putchr + ret +; +parse: + ;read and parse filespec + lxi d,conbuf + mvi c,rstring + call bdos + lxi d,pfncb + mvi c,parsef + call bdos + ret +; +print: + ;print the buffer addressed by de until $ + push d + call crlf + pop d ;new line + mvi c,pstring + call bdos ;print the string + ret +; +readcom: + ;read the next command line to the conbuf + lxi d,prompt + call print ;command? + mvi c,rstring + lxi d,conbuf + call bdos ;read command line +; command line is present, scan it + mvi c,0 ;start with 00 + lxi h,0 ; 0000 + lxi d,conlin;command line +readc: ldax d ;next command character + inx d ;to next command position + ora a ;cannot be end of command + rz +; not zero, numeric? + sui '0' + cpi 10 ;carry if numeric + jnc endrd +; add-in next digit + push psw + mov a,c ;value = ahl + dad h + adc a ;*2 + push a ;save value * 2 + push h + dad h ;*4 + adc a + dad h ;*8 + adc a + pop b ;*2 + *8 = *10 + dad b + pop b + adc b + pop b ;+digit + mov c,b + mvi b,0 + dad b + aci 0 + mov c,a + jnc readc + jmp readcom +endrd: +; end of read, restore value in a + adi '0' ;command + cpi 'a' ;translate case? + rc +; lower case, mask lower case bits + ani 101$1111b + ret ;return with value in chl +; +;*************************************************** +;* * +;* string data area for console messages * +;* * +;*************************************************** +badver: + db 'sorry, you need cp/m version 3$' +nospace: + db 'no directory space$' +datmsg: + db 'type data: $' +errmsg: + db 'error, try again.$' +prompt: + db 'next command? $' +entmsg: + db 'enter filename: $' +; +;*************************************************** +;* * +;* fixed and variable data area * +;* * +;*************************************************** +conbuf: db conlen ;length of console buffer +consiz: ds 1 ;resulting size after read +conlin: ds 32 ;length 32 buffer +conlen equ $-consiz +; +pfncb: + dw conlin + dw fcb +; + ds 32 ;16 level stack +stack: + end diff --git a/software/CPM/cpm3/rename.plm b/software/CPM/cpm3/rename.plm new file mode 100644 index 0000000..1387647 --- /dev/null +++ b/software/CPM/cpm3/rename.plm @@ -0,0 +1,608 @@ +$ TITLE('CP/M 3.0 --- REN ') +ren: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 19 Jan 80 by Thomas Rolander + 14 Sept 81 by Doug Huskey + 23 June 82 by John Knight + 29 Sept 82 by Thomas J. Mason + 03 Dec 82 by Bruce Skidmore +*/ + +declare + mpmproduct literally '01h', /* requires mp/m */ + cpmversion literally '30h'; /* requires 3.0 cp/m */ + + +declare + true literally '0FFh', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + lf literally '10', + ctrlc literally '3', + ctrlx literally '18h', + bksp literally '8', + dcnt$offset literally '45h', + searcha$offset literally '47h', + searchl$offset literally '49h', + hash1$offset literally '00h', + hash2$offset literally '02h', + hash3$offset literally '04h'; + + + declare plm label public; + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + read$console: + procedure byte; + return mon2 (1,0); + end read$console; + + conin: + procedure byte; + return mon2(6,0ffh); + end conin; + + printchar: + procedure (char); + declare char byte; + call mon1 (2,char); + end printchar; + + print$buf: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buf; + + read$console$buf: + procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address byte; + declare max byte; + new$max = max; + call mon1 (10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of chars input */ +end read$console$buf; + + check$con$stat: + procedure byte; + return mon2 (11,0); + end check$con$stat; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + search$first: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (17,fcb$address); + end search$first; + + search$next: + procedure byte; + return mon2 (18,0); + end search$next; + + delete$file: + procedure (fcb$address); + declare fcb$address address; + call mon1 (19,fcb$address); + end delete$file; + + rename$file: + procedure (fcb$address) address; + declare fcb$address address; + return mon3 (23,fcb$address); + end rename$file; + + setdma: procedure(dma); + declare dma address; + call mon1(26,dma); + end setdma; + + /* 0ff => return BDOS errors */ + return$errors: + procedure(mode); + declare mode byte; + call mon1 (45,mode); + end return$errors; + + declare + parse$fn structure ( + buff$adr address, + fcb$adr address); + + parse: procedure (pfcb) address external; + declare pfcb address; + end parse; + + declare scbpd structure + (offset byte, + set byte, + value address); + + getscbbyte: + procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); + end getscbbyte; + + getscbword: + procedure (offset) address; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon3(49,.scbpd); + end getscbword; + + setscbword: + procedure (offset,value); + declare offset byte; + declare value address; + scbpd.offset = offset; + scbpd.set = 0FEh; + scbpd.value = value; + call mon1(49,.scbpd); + end setscbword; + + + /************************************** + * * + * GLOBAL VARIABLES * + * * + **************************************/ + + /* Note: there are three fcbs used by + this program: + + 1) new$fcb: the new file name + (this can be a wildcard if it + has the same pattern of question + marks as the old file name) + Any question marks are replaced + with the corresponding filename + character in the old$fcb before + doing the rename function. + + 2) cur$fcb: the file to be renamed + specified in the rename command. + (any question marks must correspond + to question marks in new$fcb). + + 3) old$fcb: a fcb in the directory + matching the cur$fcb and used in + the bdos rename function. This + cannot contain any question marks. + */ + + declare successful lit '0FFh'; + declare failed (*) byte data(cr,lf,'ERROR: Not renamed, $'), + read$only (*) byte data(cr,lf,'ERROR: Drive read only.$'), + bad$wildcard (*) byte data('Invalid wildcard.$'); + declare passwd (8) byte; + declare + new$fcb$adr address, /* new name */ + new$fcb based new$fcb$adr (32) byte; + declare cur$fcb (33) byte; /* current fcb (old name) */ + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + + + /* upper case character from console */ +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* fill string @ s for c bytes with f */ +fill: proc(s,f,c); + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* error message routine */ +error: proc(code); + declare + code byte; + + if code = 0 then do; + call print$buf(.('ERROR: No such file to rename.$')); + call mon1(0,0); + end; + if code=1 then do; + call print$buf(.(cr,lf,'Disk I/O.$')); + call mon1(0,0); + end; + if code=2 then do; + call print$buf(.read$only); + call mon1(0,0); + end; + if code = 3 then + call print$buf(.read$only(15)); + if code = 5 then + call print$buf(.('Currently Opened.$')); + if code = 7 then + call print$buf(.('Bad password.$')); + if code = 8 then + call print$buf(.('file already exists$')); + if code = 9 then do; + call print$buf(.bad$wildcard); + call mon1(0,0); + end; + end error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* print file name */ +print$file: procedure(fcbp); + declare k byte; + declare typ lit '9'; /* file type */ + declare fnam lit '11'; /* file type */ + declare + fcbp addr, + fcbv based fcbp (32) byte; + + do k = 1 to fnam; + if k = typ then + call printchar('.'); + call printchar(fcbv(k) and 7fh); + end; + end print$file; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* try to rename fcb at old$fcb$adr to name at new$fcb$adr + return error code if unsuccessful */ + rename: + procedure(old$fcb$adr) byte; + declare + old$fcb$adr address, + old$fcb based old$fcb$adr (32) byte, + error$code address, + code byte; + + call move (16,new$fcb$adr,old$fcb$adr+16); + call setdma(.passwd); /* password */ + call return$errors(0FFh); /* return bdos errors */ + error$code = rename$file (old$fcb$adr); + call return$errors(0); /* normal error mode */ + if low(error$code) = 0FFh then do; + code = high(error$code); + if code < 3 then + call error(code); + return code; + end; + return successful; + end rename; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* upper case character from console */ +ucase: proc(c) byte; + dcl c byte; + + if c >= 'a' then + if c < '{' then + return(c-20h); + return c; + end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* get password and place at fcb + 16 */ +getpasswd: proc; + dcl (i,c) byte; + + call crlf; + call print$buf(.('Enter password: ','$')); +retry: + call fill(.passwd,' ',8); + do i = 0 to 7; +nxtchr: + if (c:=ucase(conin)) >= ' ' then + passwd(i)=c; + if c = cr then do; + call crlf; + go to exit; + end; + if c = ctrlx then + goto retry; + if c = bksp then do; + if i<1 then + goto retry; + else do; + passwd(i:=i-1)=' '; + goto nxtchr; + end; + end; + if c = ctrlc then + call mon1(0,0); + end; +exit: + c = check$con$stat; /* clear raw I/O mode */ + end getpasswd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* check for wildcard in rename command */ +wildcard: proc byte; + dcl (i,wild) byte; + + wild = false; + do i=1 to 11; + if cur$fcb(i) = '?' then + if new$fcb(i) <> '?' then do; + call print$buf(.failed); + call print$buf(.bad$wildcard); + call mon1(0,0); + end; + else + wild = true; + end; + return wild; + end wildcard; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* set up new name for rename function */ +set$new$fcb: proc(old$fcb$adr); + dcl old$fcb$adr address, + old$fcb based old$fcb$adr (32) byte; + dcl i byte; + + old$fcb(0) = cur$fcb(0); /* set up drive */ + do i=1 to 11; + if cur$fcb(i) = '?' then + new$fcb(i) = old$fcb(i); + end; + end set$new$fcb; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* try deleting files one at a time */ + single$file: + procedure; + declare (code,dcnt) byte; + declare (old$fcb$adr,savdcnt,savsearcha,savsearchl) addr; + declare old$fcb based old$fcb$adr (32) byte; + declare (hash1,hash2,hash3) address; + + file$err: procedure(fcba); + dcl fcba address; + call print$buf(.failed); + call print$file(fcba); + call printchar(' '); + call error(code); + end file$err; + + call setdma(.tbuff); + if (dcnt:=search$first(.cur$fcb)) = 0ffh then + call error(0); + + do while dcnt <> 0ffh; + old$fcb$adr = shl(dcnt,5) + .tbuff; + savdcnt = getscbword(dcnt$offset); + savsearcha = getscbword(searcha$offset); + savsearchl = getscbword(searchl$offset); + /* save searched fcb's hash code (5 bytes) */ + hash1 = getscbword(hash1$offset); + hash2 = getscbword(hash2$offset); + hash3 = getscbword(hash3$offset); /* saved one extra byte */ + call set$new$fcb(old$fcb$adr); + if (code:=rename(old$fcb$adr)) = 8 then do; + call file$err(new$fcb$adr); + call print$buf(.(', delete (Y/N)?$')); + if ucase(read$console) = 'Y' then do; + call delete$file(new$fcb$adr); + code = rename(old$fcb$adr); + end; + else + go to next; + end; + if code = 7 then do; + call file$err(old$fcb$adr); + call getpasswd; + code = rename(old$fcb$adr); + end; + if code <> successful then + call file$err(old$fcb$adr); + else do; + call crlf; + call print$file(new$fcb$adr); + call printchar('='); + call print$file(old$fcb$adr); + end; +next: + call setdma(.tbuff); + call setscbword(dcnt$offset,savdcnt); + call setscbword(searcha$offset,savsearcha); + call setscbword(searchl$offset,savsearchl); + /* restore hash code */ + call setscbword(hash1$offset,hash1); + call setscbword(hash2$offset,hash2); + call setscbword(hash3$offset,hash3); + if .cur$fcb <> savsearcha then /*restore orig fcb if destroyed*/ + call move(16,.cur$fcb,savsearcha); + dcnt = search$next; + end; + end single$file; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* invalid rename command */ +bad$entry: proc; + + call print$buf(.failed); + call print$buf(.('ERROR: Invalid File.',cr,lf,'$')); + call mon1(0,0); + end bad$entry; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +finish$parse: procedure; + parse$fn.buff$adr = parse$fn.fcb$adr+1; /* skip delimiter */ + parse$fn.fcb$adr = .cur$fcb; + parse$fn.fcb$adr = parse(.parse$fn); + call move(8,.cur$fcb+16,.passwd); +end finish$parse; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = 9); /* tabs & spaces */ + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /************************************** + * * + * M A I N P R O G R A M * + * * + **************************************/ + +declare ver address; +declare i byte; +declare no$chars byte; /* number characters input */ +declare second$string$ptr address; /* points to second filename input */ +declare ptr based second$string$ptr byte; +declare last$dseg$byte byte + initial (0); + +plm: + ver = version; + if (low(ver) < cpmversion) or (high(ver) = mpmproduct) then do; + call print$buf(.('Requires CP/M 3.0','$')); + call mon1(0,0); + end; + + parse$fn.buff$adr = .tbuff(1); + new$fcb$adr, parse$fn.fcb$adr = .fcb; + if input$found(.tbuff(1)) then do; + if (parse$fn.fcb$adr:=parse(.parse$fn)) <> 0FFFFh then + call finish$parse; + end; + else do; + + /* prompt for files */ + call print$buf(.('Enter New Name: $')); + no$chars = read$console$buf(.tbuff(0),40); + if no$chars <= 0 then do; + call print$buf(.(cr,lf,'ERROR: Incorrect file specification.',cr,lf,'$')); + call mon1(0,0); + end; /* no$char check */ + + tbuff(1)= ' '; /* blank out nc field for file 1 */ + second$string$ptr = .tbuff(no$chars + 2); + call crlf; + + call print$buf(.('Enter Old Name: $')); + no$chars = read$console$buf(second$string$ptr,40); + call crlf; + ptr = ' '; /* blank out mx field */ + second$string$ptr = second$string$ptr + 1; + ptr = '='; /* insert delimiter for parse */ + second$string$ptr = second$string$ptr + no$chars + 1; /* eoln */ + ptr = cr; /* put eoln delimeter in string */ + parse$fn.buff$adr = .tbuff(1); + new$fcb$adr, parse$fn.fcb$adr = .fcb; + if (parse$fn.fcb$adr := parse(.parse$fn)) <> 0FFFFh then + call finish$parse; + end; + if parse$fn.fcb$adr = 0FFFFh then + call bad$entry; + if fcb(0) <> 0 then + if cur$fcb(0) <> 0 then do; + if fcb(0) <> cur$fcb(0) then + call bad$entry; + end; + else + cur$fcb(0) = new$fcb(0); /* set drive */ + if wildcard then + call singlefile; + else if rename(.cur$fcb) <> successful then + call singlefile; + call mon1(0,0); +end ren; diff --git a/software/CPM/cpm3/resbdos.asm b/software/CPM/cpm3/resbdos.asm new file mode 100644 index 0000000..0f2c32b --- /dev/null +++ b/software/CPM/cpm3/resbdos.asm @@ -0,0 +1,713 @@ + title 'CP/M 3 Banked BDOS Resident Module, Dec 1982' +;*************************************************************** +;*************************************************************** +;** ** +;** B a s i c D i s k O p e r a t i n g S y s t e m ** +;** ** +;** R e s i d e n t M o d u l e - B a n k e d B D O S ** +;** ** +;*************************************************************** +;*************************************************************** + +;/* +; Copyright (C) 1978,1979,1980,1981,1982 +; Digital Research +; P.O. Box 579 +; Pacific Grove, CA 93950 +; +; December, 1982 +; +;*/ +; +ssize equ 30 +diskfx equ 12 +conoutfxx equ 2 +printfx equ 9 +constatfx equ 11 +setdmafx equ 26 +chainfx equ 47 +ioloc equ 3 + + org 0000h +base equ $ + +bnkbdos$pg equ base+0fc00h +resbdos$pg equ base+0fd00h +scb$pg equ base+0fe00h +bios$pg equ base+0ff00h + +bnkbdos equ bnkbdos$pg+6 +error$jmp equ bnkbdos$pg+7ch + +bios equ bios$pg +bootf equ bios$pg ; 00. cold boot function +wbootf equ bios$pg+3 ; 01. warm boot function +constf equ bios$pg+6 ; 02. console status function +coninf equ bios$pg+9 ; 03. console input function +conoutf equ bios$pg+12 ; 04. console output function +listf equ bios$pg+15 ; 05. list output function +punchf equ bios$pg+18 ; 06. punch output function +readerf equ bios$pg+21 ; 07. reader input function +homef equ bios$pg+24 ; 08. disk home function +seldskf equ bios$pg+27 ; 09. select disk function +settrkf equ bios$pg+30 ; 10. set track function +setsecf equ bios$pg+33 ; 11. set sector function +setdmaf equ bios$pg+36 ; 12. set dma function +readf equ bios$pg+39 ; 13. read disk function +writef equ bios$pg+42 ; 14. write disk function +liststf equ bios$pg+45 ; 15. list status function +sectran equ bios$pg+48 ; 16. sector translate +conoutstf equ bios$pg+51 ; 17. console output status function +auxinstf equ bios$pg+54 ; 18. aux input status function +auxoutstf equ bios$pg+57 ; 19. aux output status function +devtblf equ bios$pg+60 ; 20. return device table address fx +devinitf equ bios$pg+63 ; 21. initialize device function +drvtblf equ bios$pg+66 ; 22. return drive table address +multiof equ bios$pg+69 ; 23. multiple i/o function +flushf equ bios$pg+72 ; 24. flush function +movef equ bios$pg+75 ; 25. memory move function +timef equ bios$pg+78 ; 26. get/set system time function +selmemf equ bios$pg+81 ; 27. select memory function +setbnkf equ bios$pg+84 ; 28. set dma bank function +xmovef equ bios$pg+78 ; 29. extended move function + +sconoutf equ conoutf ; 31. escape sequence decoded conout +screenf equ 0ffffh ; 32. screen function + +serial: db '654321' + + jmp bdos + jmp move$out ;A = bank # + ;HL = dest, DE = srce + jmp move$tpa ;A = bank # + ;HL = dest, DE = srce + jmp search$hash ;A = bank # + ;HL = hash table address + + ; on return, Z flag set for eligible DCNTs + ; Z flag reset implies unsuccessful search + + ; Additional variables referenced directly by bnkbdos + +hashmx: dw 0 ;max hash search dcnt +rd$dir: db 0 ;read directory flag +make$xfcb: db 0 ;Make XFCB flag +find$xfcb: db 0 ;Search XFCB flag +xdcnt: dw 0 ;current xdcnt + +xdmaadd: dw common$dma +curdma: dw 0 +copy$cr$only: db 0 +user$info: dw 0 +kbchar: db 0 + jmp qconinx + +bdos: ;arrive here from user programs + mov a,c ; c = BDOS function # + + ;switch to local stack + + lxi h,0! shld aret + dad sp! shld entsp ; save stack pointer + lxi sp,lstack! lxi h,goback! push h + + cpi diskfx! jnc disk$func + + sta fx ;[JCE] DRI patch 1 + + lxi h,functab! mvi b,0 + dad b! dad b! mov a,m + inx h! mov h,m! mov l,a! pchl + + maclib makedate ;[JCE] Dates all go in one file + @LCOPY + @BDATE + dw 0,0,0,0,0,0,0,0,0,0,0 + +functab: + dw wbootf, bank$bdos, bank$bdos, func3 + dw func4, func5, func6, func7 + dw func8, func9, func10, bank$bdos + +func3: + call readerf! jmp sta$ret + +func4: + mov c,e! jmp punchf + +func5: + mov c,e! jmp listf + +func6: + mov a,e! inr a! jz dirinp ;0ffh -> cond. input + inr a! jz dirstat ;0feh -> status + inr a! jz dirinp1 ;0fdh -> input + mov c,e! jmp conoutf ; output +dirstat: + call constx! jmp sta$ret +dirinp: + call constx! ora a! rz +dirinp1: + call conin! jmp sta$ret + +constx: + lda kbchar! ora a! mvi a,0ffh! rnz + jmp constf + +conin: + lxi h,kbchar! mov a,m! mvi m,0! ora a! rnz + jmp coninf + +func7: + call auxinstf! jmp sta$ret + +func8: + call auxoutstf! jmp sta$ret + +func9: + mov b,d! mov c,e +print: + lxi h,outdelim + ldax b! cmp m! rz + inx b! push b! mov c,a + call blk$out0 + pop b! jmp print + +func10: + xchg + mov a,l! ora h! jnz func10a + lxi h,buffer+2! shld conbuffadd + lhld dmaad +func10a: + push h! lxi d,buffer! push d + mvi b,0! mov c,m! inx b! inx b! inx b + xchg! call movef! mvi m,0 + pop d! push d! mvi c,10 + call bank$bdos + lda buffer+1! mov c,a! mvi b,0 + inx b! inx b + pop d! pop h! jmp movef + +func111: +func112: + sta res$fx + xchg! mov e,m! inx h! mov d,m! inx h + mov c,m! inx h! mov b,m! xchg + ; hl = addr of string + ; bc = length of string +blk$out: + mov a,b! ora c! rz + push b! push h! mov c,m + lxi d,blk$out2! push d + lda res$fx! cpi 112! jz listf + +blk$out0: + lda conmode! mov b,a! ani 2! jz blk$out1 + mov a,b! ani 14h! jz blk$out1 + ani 10h! jnz sconoutf + jmp conoutf + +blk$out1: + mov e,c! mvi c,conoutfxx! jmp bank$bdos + +blk$out2: + pop h! inx h! pop b! dcx b + jmp blk$out + +qconinx: + ; switch to bank 1 + mvi a,1! call selmemf + ; get character + mov b,m + ; return to bank zero + xra a! call selmemf + ; return with character in A + mov a,b! ret + +switch1: + lxi d,switch0! push d + mvi a,1! call selmemf! pchl +switch0: + mov b,a! xra a! call selmemf + mov a,b! ret + +disk$func: + cpi ndf! jc OKdf ;func < ndf + cpi 98! jc badfunc ;ndf < func < 98 + cpi nxdf! jnc badfunc ;func >= nxdf + cpi 111! jz func111 + cpi 112! jz func112 + jmp disk$function + + OKdf: + cpi 17! jz search + cpi 18! jz searchn + cpi setdmafx! jnz disk$function + + ; Set dma addr + xchg! shld dmaad! shld curdma! ret + + search: + xchg! shld searcha + + searchn: + lhld searcha! xchg + +disk$function: + +; +; Perform the required buffer tranfers from +; the user bank to common memory +; + + lxi h,dfctbl-12 + mov a,c! cpi 98! jc normalCPM + lxi h,xdfctbl-98 + normalCPM: + mvi b,0! dad b! mov a,m + +; **** SAVE DFTBL ITEM, INFO, & FUNCTION ***** + + mov b,a! push b! push d + + rar! jc cpycdmain ;cdmain test + rar! jc cpyfcbin ;fcbin test + jmp nocpyin + + cpycdmain: + lhld dmaad! xchg + lxi h,common$dma! lxi b,16 + call movef + pop d! push d + + cpyfcbin: + xra a! sta copy$cr$only + lxi h,commonfcb! lxi b,36 + call movef + lxi d,commonfcb + pop h! pop b! push b! push h + shld user$info + + nocpyin: + + call bank$bdos + + pop d ;restore FCB address + pop b! mov a,b ;restore fcbtbl byte & function # + ani 0fch! rz ;[JCE] DRI Patch 13: F8 -> FC + lxi h,commonfcb! xchg! lxi b,33 + ral! jc copy$fcb$back ;fcbout test + mvi c,36! ral! jc copy$fcb$back ;pfcbout test + ral! jc cdmacpyout128 ;cdmaout128 test + mvi c,4! ral! jc movef ;timeout test + ral! jc cdmacpyout003 ;cdmaout003 test + mvi c,6! jmp movef ;seriout + + copy$fcb$back: + lda copy$cr$only! ora a! jz movef + lxi b,14! dad b! xchg! dad b + mov a,m! stax d + inx h! inx d + mov a,m! stax d + inx b! inx b! inx b! dad b! xchg! dad b + ldax d! mov m,a! ret + + cdmacpyout003: + lhld dmaad! lxi b,3! lxi d,common$dma + jmp movef + + cdmacpyout128: + lhld dmaad! lxi b,128! lxi d,common$dma + jmp movef + +parse: + xchg! mov e,m! inx h! mov d,m + inx h! mov c,m! inx h! mov b,m + lxi h,buffer+133! push h! push b! push d + shld buffer+2! lxi h,buffer+4! shld buffer + lxi b,128! call movef! mvi m,0 + mvi c,152! lxi d,buffer! call bank$bdos + pop b! mov a,l! ora h! jz parse1 + mov a,l! ana h! inr a! jz parse1 + lxi d,buffer+4 + mov a,l! sub e! mov l,a + mov a,h! sbb d! mov h,a + dad b! shld aret +parse1: + pop h! pop d! lxi b,36! jmp movef + +bad$func: + cpi 152! jz parse + + ; A = 0 if fx >= 128, 0ffh otherwise + ral! mvi a,0! jc sta$ret + + dcr a + +sta$ret: + sta aret + +goback: + lhld entsp! sphl ;user stack restored + lhld aret! mov a,l! mov b,h ;BA = HL = aret + ret + +BANK$BDOS: + + xra a! call selmemf + + call bnkbdos + + shld aret + mvi a,1! jmp selmemf ;ret + + +move$out: + ora a! jz move$f + call selmemf +move$ret: + call movef + xra a! jmp selmemf + +move$tpa: + mvi a,1! call selmemf + jmp move$ret + +search$hash: ; A = bank # , HL = hash table addr + + ; Hash format + ; xxsuuuuu xxxxxxxx xxxxxxxx ssssssss + ; x = hash code of fcb name field + ; u = low 5 bits of fcb user field + ; 1st bit is on for XFCB's + ; s = shiftr(mod || ext,extshf) + + shld hash$tbla! call selmemf + ; Push return address + lxi h,search$h7! push h + ; Reset read directory record flag + xra a! sta rd$dir + + lhld hash$tbla! mov b,h! mov c,l + lhld hashmx! xchg + ; Return with Z flag set if dcnt = hash$mx + lhld dcnt! push h! call subdh! pop d! ora l! rz + ; Push hash$mx-dcnt (# of hash$tbl entries to search) + ; Push dcnt+1 + push h! inx d! xchg! push h + ; Compute .hash$tbl(dcnt-1) + dcx h! dad h! dad h! dad b +search$h1: + ; Advance hl to address of next hash$tbl entry + lxi d,4! dad d! lxi d,hash + ; Do hash u fields match? + ldax d! xra m! ani 1fh! jnz search$h3 ; no + ; Do hash's match? + call search$h6! jz search$h4 ; yes +search$h2: + xchg! pop h +search$h25: + ; de = .hash$tbl(dcnt), hl = dcnt + ; dcnt = dcnt + 1 + inx h! xthl + ; hl = # of hash$tbl entries to search + ; decrement & test for zero + ; Restore stack & hl to .hash$tbl(dcnt) + dcx h! mov a,l! ora h! xthl! push h + ; Are we done? + xchg! jnz search$h1 ; no - keep searching + ; Search unsuccessful - return with Z flag reset + inr a! pop h! pop h! ret +search$h3: + ; Does xdcnt+1 = 0ffh? + lda xdcnt+1! inr a! jz search$h5 ; yes + ; Does xdcnt+1 = 0feh? + inr a! jnz search$h2 ; no - continue searching + ; Do hash's match? + push d! call search$h6! pop d! jnz search$h2 ; no + ; Does find$xfcb = 0ffh? + lda find$xfcb! inr a! jz search$h45 ; yes + ; Does find$xfcb = 0feh? + inr a! jz search$h35 ; yes + ; xdcnt+1 = 0feh & find$xfcb < 0feh + ; Open user 0 search + ; Does hash u field = 0? + mov a,m! ani 1fh! jnz search$h2 ; no + ; Search successful + jmp search$h4 +search$h35: + ; xdcnt+1 = 0feh & find$xfcb = 0feh + ; Delete search to return matching fcb's & xfcbs + ; Do hash user fields match? + ldax d! xra m! ani 0fh! jnz search$h2 ; no + ; Exclude empty fcbs, sfcbs, and dir lbls + mov a,m! ani 30h! cpi 30h! jz search$h2 +search$h4: + ; successful search + ; Set dcnt to search$hash dcnt-1 + ; dcnt gets incremented by read$dir + ; Also discard search$hash loop count + lhld dcnt! xchg + pop h! dcx h! shld dcnt! pop b + ; Does dcnt&3 = 3? + mov a,l! ani 03h! cpi 03h! rz ; yes + ; Does old dcnt & new dcnt reside in same sector? + mov a,e! ani 0fch! mov e,a + mov a,l! ani 0fch! mov l,a + call subdh! ora l! rz ; yes + ; Set directory read flag + mvi a,0ffh! sta rd$dir + xra a! ret +search$h45: + ; xdcnt+1 = 0feh, find$xfcb = 0ffh + ; Rename search to save dcnt of xfcb in xdcnt + ; Is hash entry an xfcb? + mov a,m! ani 10h! jz search$h2 ; no + ; Do hash user fields agree? + ldax d! xra m! ani 0fh! jnz search$h2 ; no + ; set xdcnt + jmp search$h55 +search$h5: + ; xdcnt+1 = 0ffh + ; Make search to save dcnt of empty fcb + ; is hash$tbl entry empty? + mov a,m! cpi 0f5h! jnz search$h2 ; no +search$h55: + ; xdcnt = dcnt + xchg! pop h! shld xdcnt! jmp search$h25 +search$h6: + ; hash compare routine + ; Is hashl = 0? + lda hashl! ora a! rz ; yes - hash compare successful + ; hash$mask = 0e0h if hashl = 3 + ; = 0c0h if hashl = 2 + mov c,a! rrc! rrc! rar! mov b,a + ; hash s field does not pertain if hashl ~= 3 + ; Does hash(0) fields match? + ldax d! xra m! ana b! rnz ; no + ; Compare remainder of hash fields for hashl bytes + push h! inx h! inx d! call compare + pop h! ret +search$h7: + ; Return to bnkbdos + push a! xra a! call selmemf! pop a! ret + +subdh: + ;compute HL = DE - HL + mov a,e! sub l! mov l,a + mov a,d! sbb h! mov h,a + ret + +compare: + ldax d! cmp m! rnz + inx h! inx d! dcr c! rz + jmp compare + +; Disk Function Copy Table + +cdmain equ 00000001B ;copy 1ST 16 bytes of DMA to + ;common$dma on entry +fcbin equ 00000010b ;fcb copy on entry +fcbout equ 10000000b ;fcb copy on exit +pfcbout equ 01000000b ;random fcb copy on exit +cdma128 equ 00100000b ;copy 1st 128 bytes of common$dma + ;to DMA on exit +timeout equ 00010000b ;copy date & time on exit +cdma003 equ 00001000B ;copy 1ST 3 bytes of common$dma + ;to DMA on exit +serout equ 00000100b ;copy serial # on exit + +dfctbl: + db 0 ; 12=return version # + db 0 ; 13=reset disk system + db 0 ; 14=select disk + db fcbin+fcbout+cdmain ; 15=open file + db fcbin+fcbout ; 16=close file + db fcbin+cdma128 ; 17=search first + db fcbin+cdma128 ; 18=search next + db fcbin+cdmain ; 19=delete file + db fcbin+fcbout ; 20=read sequential + db fcbin+fcbout ; 21=write sequential + db fcbin+fcbout+cdmain ; 22=make file + db fcbin+cdmain ; 23=rename file + db 0 ; 24=return login vector + db 0 ; 25=return current disk + db 0 ; 26=set DMA address + db 0 ; 27=get alloc address + db 0 ; 28=write protect disk + db 0 ; 29=get R/O vector + db fcbin+fcbout+cdmain ; 30=set file attributes + db 0 ; 31=get disk param addr + db 0 ; 32=get/set user code + db fcbin+fcbout ; 33=read random + db fcbin+fcbout ; 34=write random + db fcbin+pfcbout ; 35=compute file size + db fcbin+pfcbout ; 36=set random record + db 0 ; 37=drive reset + db 0 ; 38=access drive + db 0 ; 39=free drive + db fcbin+fcbout ; 40=write random w/ zero fill + + db fcbin+fcbout ; 41=test & write record + db 0 ; 42=record lock + db 0 ; 43=record unlock + db 0 ; 44=set multi-sector count + db 0 ; 45=set BDOS error mode + db cdma003 ; 46=get disk free space + db 0 ; 47=chain to program + db 0 ; 48=flush buffers + db fcbin ; 49=Get/Set system control block + db fcbin ; 50=direct BIOS call (CP/M) +ndf equ ($-dfctbl)+12 + +xdfctbl: + db 0 ; 98=reset allocation vectors + db fcbin+cdmain ; 99=truncate file + db fcbin+cdmain ; 100=set directory label + db 0 ; 101=return directory label data + db fcbin+fcbout+cdmain ; 102=read file xfcb + db fcbin+cdmain ; 103=write or update file xfcb + db fcbin ; 104=set current date and time + db fcbin+timeout ; 105=get current date and time + db fcbin ; 106=set default password + db fcbin+serout ; 107=return serial number + db 0 ; 108=get/set program return code + db 0 ; 109=get/set console mode + db 0 ; 110=get/set output delimiter + db 0 ; 111=print block + db 0 ; 112=list block + +nxdf equ ($-xdfctbl)+98 + +res$fx: ds 1 +hash$tbla: + ds 2 +bank: ds 1 +aret: ds 2 ;address value to return + +buffer: ;function 10 256 byte buffer + +commonfcb: + ds 36 ;fcb copy in common memory + +common$dma: + ds 220 ;function 10 buffer cont. + + ds ssize*2 +lstack: +entsp: ds 2 + +; BIOS intercept vector + +wbootfx: jmp wbootf + jmp switch1 +constfx: jmp constf + jmp switch1 +coninfx: jmp coninf + jmp switch1 +conoutfx: jmp conoutf + jmp switch1 +listfx: jmp listf + jmp switch1 + + dw 0,0,0 + dw 0 + dw 0 + +olog: dw 0 +rlog: dw 0 + +patch$flgs: db 0,0,0,7 ;[JCE] Patchlevel 7 + +; Base of RESBDOS + + dw base+6 + +; Reserved for use by non-banked BDOS + + ds 2 + +; System Control Block + +SCB: + +; Expansion Area - 6 bytes + +hashl: db 0 ;hash length (0,2,3) +hash: dw 0,0 ;hash entry +version: db 31h ;version 3.1 + +; Utilities Section - 8 bytes + +util$flgs: dw 0,0 +dspl$flgs: dw 0 + dw 0 + +; CLP Section - 4 bytes + +clp$flgs: dw 0 +clp$errcde: dw 0 + +; CCP Section - 8 bytes + +ccp$comlen: db 0 +ccp$curdrv: db 0 +ccp$curusr: db 0 +ccp$conbuff: dw 0 +ccp$flgs: dw 0 + db 0 + +; Device I/O Section - 32 bytes + +conwidth: db 0 +column: db 0 +conpage: db 0 +conline: db 0 +conbuffadd: dw 0 +conbufflen: dw 0 +conin$rflg: dw 0 +conout$rflg: dw 0 +auxin$rflg: dw 0 +auxout$rflg: dw 0 +lstout$rflg: dw 0 +page$mode: db 0 +pm$default: db 0 +ctlh$act: db 0 +rubout$act: db 0 +type$ahead: db 0 +contran: dw 0 +conmode: dw 0 + dw buffer+64 +outdelim: db '$' +listcp: db 0 +qflag: db 0 + +; BDOS Section - 42 bytes + +scbadd: dw scb +dmaad: dw 0080h +seldsk: db 0 +info: dw 0 +resel: db 0 +relog: db 0 +fx: db 0 +usrcode: db 0 +dcnt: dw 0 +searcha: dw 0 +searchl: db 0 +multcnt: db 1 +errormode: db 0 +searchchain: db 0,0ffh,0ffh,0ffh +temp$drive: db 0 +errdrv: db 0 + dw 0 +media$flag: db 0 + dw 0 +bdos$flags: db 80h +stamp: db 0ffh,0ffh,0ffh,0ffh,0ffh +commonbase: dw 0 +error: jmp error$jmp +bdosadd: dw base+6 + end + + \ No newline at end of file diff --git a/software/CPM/cpm3/rmac.com b/software/CPM/cpm3/rmac.com new file mode 100644 index 0000000..4d2393c Binary files /dev/null and b/software/CPM/cpm3/rmac.com differ diff --git a/software/CPM/cpm3/runthames b/software/CPM/cpm3/runthames new file mode 100755 index 0000000..a92e701 --- /dev/null +++ b/software/CPM/cpm3/runthames @@ -0,0 +1,11 @@ +#! /bin/sh +# +# Set up environment variables for thames, and run it +# +ISIS_F0=`pwd` +ISIS_F1=`pwd`/plm80 +ISIS_F2=`pwd`/asm80 +ISIS_F3=`pwd`/utils +export ISIS_F0 ISIS_F1 ISIS_F2 ISIS_F3 + +thames $* diff --git a/software/CPM/cpm3/save.asm b/software/CPM/cpm3/save.asm new file mode 100644 index 0000000..926961a --- /dev/null +++ b/software/CPM/cpm3/save.asm @@ -0,0 +1,820 @@ + title 'SAVE.RSX - CP/M 3.0 save routine. July 1982' +; ************************************************* +; * +; * Title: SAVE.RSX Resident System eXtension +; * Date: 7/28/82 +; * Author: Thomas J. Mason +; * +; * Modified: +; * 11/30/82 - Thomas J. Mason +; * Added trap for function 60 to fix PUT and SAVE +; * bios vector mods. +; * +; * Modified: +; * 17 May 1998 - John Elliott +; * Apply DRI patch 18 and "multiple calls" bug fix +; * +; ********************************************************* +; +; Copyright (c) 1982 +; Digital Research +; PO Box 579 +; Pacific Grove, Ca. 93950 +; +TRUE equ 0FFFFh +FALSE equ not TRUE +; +; BIOS and BDOS Jump vectors +; +WBOOT equ 0 +WBTADR equ 1 ;address of boot in BIOS +BDOS equ 5 ;BDOS jump vector +BDOSAD equ 6 ;location of instructions +DFCB equ 05Ch ;default FCB +; +; BDOS Function calls +; +BDOSAD equ 6 ;BDOS jump address +PSTRING equ 9 ;print string +BUFIN equ 10 ;console buffer input +CFILE equ 16 ;file close +DFILE equ 19 ;file delete +WFILE equ 21 ;file write +MFILE equ 22 ;make file +SETDMA equ 26 ;set DMA function +BDOSER equ 45 ;Set BDOS error mode +GETSCB equ 49 ;get/set scb func # +LDRSX equ 59 ;function for RSX load +CALRSX equ 60 ;call rsx func # +CONMOD equ 109 ;GET/SET Console Mode +; +; Non Printable ASCII characters +; +CTL$C equ 03 ;CONTROL-C +CR equ 13 ;ASCII Carrige Return +LF equ 10 ;ASCII Line Feed +; +VERSION equ 31 ;[JCE] Version 3.1 +; +; Buffer size +; +CONMAX equ 14 ;[JCE] Patch 18: console buffer maximum should be 14 +STKSZE equ 010h ;size fo stack +SCBOST equ 068h ;page boundary + to jmp instr +RETDSP equ 0FEh ;RETurn and DiSPlay mode +JUMP equ 0C3h ;opcode for jump +LXIH equ 21h ;lxi instr to poke +BSNLY equ 07Fh ;restore bios jump table only +CMMON equ 0F9h ;offset of common memory base from pg. bound +; +; ********************************* +; * * +; * The Save Program * +; * * +; ********************************* +; + db 0,0,0,0,0,0 + jmp PREFIX +NEXTJ: + db JUMP ;jump +NEXT: + db 0,0 ;next module in line +PREV: + dw 5 ;previous, initialized to 5 +STKYBT: db 00h ;for warm start + db 0 + db 'SAVE ' + ds 3 +; +; +; This is the check performed every time the BDOS is +; called to see if the RSX is to be invoked +; +PREFIX: + mov a,c ;set up for compare + cpi CALRSX + jnz GETGOING + + push b + push d + push h + lxi h,0000h ;zero out HL + dad d ; -> RSXPB + mov a,m ;get the byte + cpi 160 ; sub function defined + + pop h + pop d + pop b + jz GOODBYE ;remove this RSX + +GETGOING: +; + cpi LDRSX ;do the compare +NOPME: jz START ;[JCE] For the bug fix, see below + lhld NEXT ;get address for continue + pchl ;get going..... +; +; +; +START: +; +;[JCE] Bug. This rewires the jump vectors every time the Loader is called, +; and some programs call the Loader more than once to load overlays. +; The second time it is called, SAVE is left pointing at itself rather +; than the real BIOS. +; +; They are equal so get the BIOS address to point here +; in case of a Func 0 call +; + push b ;save state + push d ; of registers +; +; check for jump byte before the SCB + call GETSET$SCB + shld SCBADR ;save address for later +; + mvi l,CMMON+1 ;offset into scb to check BIOS + mov a,m ;get byte + ora a ;check for zero + mvi a,FALSE ;store for insurance + sta CHGJMP ;non-banked = FALSE + jz NBNKED ;high byte zero if non-banked +; + lhld SCBADR ;restor SCB + mvi l,SCBOST ;offset from page for instr + mov a,m ;get byte + cpi JUMP ;is it a jump? + jnz MORRSX ;we are not alone + mvi a,TRUE + sta CHGJMP ;set flag + mvi m,LXIH ;put in lxi h,xxxx mnemonic +; +MORRSX: +; continue with processing +NBNKED: +; +; + lhld WBTADR ;get address at 01h + inx h ;now points to address of jmp xxxx + mov a,m ;get low order byte + sta BIOSAD + inx h ;next byte + mov a,m + sta BIOSAD+1 ;high order byte +; +; Now poke the BIOS address to point to +; the save routine. +; + lxi d,BEGIN ;begining of routine + mov m,d + dcx h ;point back to first byte + mov m,e ;low order +; + mvi c,BDOSER ;now set BDOS errormode + mvi e,RETDSP ;to trap any hard + call BDOS ;errors +; +; +; [JCE] Fix for the bug I mentioned earlier +; + lxi h,0 ;[JCE] Nop out the jump to this routine. Crude + shld NOPME ;[JCE] but effective! + shld NOPME+1 ;[JCE] + + pop d + pop b + lhld NEXT + pchl ;continue on +; +BEGIN: +; Start of the save routine +; Notify the user which program is running +; + lxi sp,STACK ;initialize stack + lxi d,SIGNON ;prompt + call PSTR +; +; Get the file from the user +; +FLEGET: + lxi d,FLEPRMPT ;ask for file name + call PSTR + call GETBUF +; zero at end of string for parser + lxi h,CONBUF-1 ;address of # + mov a,m ;get it + cpi 0 + jz REPLCE + inx h ;HL->CONBUF + mvi d,0 ;zero out high order + mov e,a ;fill low + dad d ;add to h + mvi m,00 ;zero out byte for parse + push h +; +; + call PARSE + mov a,h + cpi 0FFh + jz FLEGET +; + pop h ;get end of string address back + inx h + mvi m,'?' ;put in question mark + inx h ;bump + mvi m,' ' ;blank in string + inx h ;bump + mvi m,'$' ;end of string +; + mvi c,17 ;Search for first + lxi d,DFCB + call BDOS ;find it + inr a ;bump Acc + jz FLECLR ;file no present skip prompt +; + lxi d,DELFLE + call PSTR ;print out delete prompt + lxi d,CONBUF ;buffer address + call PSTR ;print out filename + call GETBUF ;get answer + call GNC ;get the next char + cpi 'Y' ;is it yes + jnz FLEGET ;another name if not +; +; Delete any existing file, then make a new one +FLECLR: + mvi c,DFILE ;file delete func + lxi d,DFCB ;default FCB + call BDOS ;real BDOS call +; + mvi a,0 + lxi h,07ch ;M -> record count in FCB + mov m,a ;zero out record count +; + mvi c,MFILE ;make file function + lxi d,DFCB ;default FCB + call BDOS +; Get the address of start of write +; +STRADD: + lxi d,SPRMPT ;first address + call PSTR + call GETBUF +; + lda BUFFER+1 ;get # of chars read + cpi 0 + jz STRADD +; + call SCANAD ;get address + jc STRADD +; + shld SADDR ;store in SADDR +; +; Get the finish address +ENDADD: + lxi d,FPRMPT ;load prompt + call PSTR ;print + call GETBUF ;read in +; + lda BUFFER+1 + cpi 0 + jz ENDADD +; + call SCANAD ;get finish address + jc ENDADD +; + shld FADDR ;store it + xchg + lhld SADDR + xchg +; + call CHECK + jc STRADD +; +; + lhld SADDR ;beginning DMA address + xchg ;DE=DMA address +; +; Write the first record then check the beginning address +; if DMA address ends up larger exit +; +WLOOP: + call WFLAG + push d ;save DMA address + mvi c,SETDMA + call BDOS ;set DMA address +; + mvi c,WFILE + lxi d,DFCB + call BDOS ;write +; +; Check for directory space on disk for extents + lxi d,NODIR + cpi 01h ;no more directory + jz FINIS +; +; CHECK data block error + lxi d,NOBLK + cpi 02h + jz FINIS ;out of disk space! +; final check + ora a ;if bad write occured... + jnz REPLCE ;restore BIOS address +; +; Write OK now check write address + pop d ;get DMA address + lxi h,080h + dad d + xchg + lhld FADDR ;HL=end of write +; + call CHECK +; + lda ONEFLG + cpi TRUE + jnz WLOOP ;WLOOP if not done +; +; Else, Close file and print out ending prompt +CLOSE: + mvi c,CFILE ;close function + lxi d,DFCB ;get filename + call BDOS +; + inr a ;check for close error + lxi d,CERROR + jz FINIS ;maybe write protected +; +;good copy + lxi d,ENDMSG +FINIS: + call PSTR +; +; Replace the BIOS Address to correct one +REPLCE: + lhld BIOSAD ;HL=BIOS warm jump + xchg ;DE=" " " + lhld WBTADR + inx h + mov m,e + inx h + mov m,d +; +GOODBYE: + mvi a,0FFh + sta STKYBT ;change sticky byte for +; ; removal of RSX +; +; check to see if JMP changed for BANKED system + lda CHGJMP + cpi TRUE ;has it been done? + jnz CHGBIOS + lhld SCBADR ;retreive SCB address + mvi l,SCBOST ;points to page + offset + mvi m,JUMP ;restore original code +; +CHGBIOS: + mvi c,13 ;reset the disk system + call BDOS +; + mvi c,0 ;set up for wboot + call BDOS +;**************************************** +;* * +;* Logical end of the program * +;* * +;**************************************** +; +GETSET$SCB: + mvi c,GETSCB + lxi d,SCBPB + call BDOS + ret +; +WFLAG: + mvi a,FALSE + sta ONEFLG + lda RSLT+1 + cpi 00h + rnz + lda RSLT + cpi 080h + jc WFLAG1 + jz WFLAG1 + ret +; +WFLAG1: + mvi a,TRUE + sta ONEFLG + ret +; +; +; +CHECK: +; Subtract the two to find out if finished + mov a,l ;low order + sub e ;subtraction + sta RSLT + mov a,h ;now ... + sbb d ;high order subtraction + sta RSLT+1 ;saved + ret +; +GETBUF: +;buffer input routine +; + lxi h,CONBUF ;address of buffer + shld NEXTCOM ;store it + mvi c,BUFIN + lxi d,BUFFER + call BDOS + ret +; +PSTR: +; String output routine for messages +; + mvi c,PSTRING + call BDOS + ret +; +PARSE: +; General purpose parser +; +; Filename = [d:]file[.type][;password] +; +; FCB assignments +; +; 0 => drive, 0=default, 1=A, 2=B +; 1-8 => file, converted to upper case, +; padded with blanks +; 9-11 => type, converted to upper case, +; padded with blanks +; 12-15 => set to zero +; 16-23 => passwords, converted to upper case, +; padded with blanks +; 24-25 => address of password field in "filename", +; set to zero if password length=0. +; 26 => length of password (0-8) +; +; Upon return, HL is set to FFFFh if BC locates +; an invalid file name; +; otherwise, HL is set to 0000h if the delimiter +; following the file name is a 00h (null) +; or a 0Dh (CR); +; otherwise, HL is set to the address of the delimiter +; following the file name. +; +; + lxi h,0 + push h + push h + lxi d,CONBUF ;set up source address + lxi h,DFCB ;set up dest address + call DEBLNK ;scan the blanks + call DELIM ;check for delimeter + jnz PARSE1 + mov a,c + ora a + jnz PARSE9 + mov m,a + jmp PARSE3 +; +PARSE1: + mov b,a + inx d + ldax d + cpi ':' + jnz PARSE2 +; + mov a,b + sui 'A' + jc PARSE9 + cpi 16 + jnc PARSE9 + inr a + mov m,a + inx d + call DELIM + jnz PARSE3 + cpi '.' + jz PARSE9 + cpi ':' + jz PARSE9 + cpi ';' + jz PARSE9 + jmp PARSE3 +; +PARSE2: + dcx d + mvi m,0 +PARSE3: + mvi b,8 + call SETFLD + mvi b,3 + cpi '.' + jz PARSE4 + call PADFLD + jmp PARSE5 +; +PARSE4: + inx d + call SETFLD +PARSE5: + mvi b,4 +PARSE6: + inx h + mvi m,0 + dcr b + jnz PARSE6 + mvi b,8 + cpi ';' + jz PARSE7 + call PADFLD + jmp PARSE8 +PARSE7: + inx d + call PWFLD +PARSE8: + push d + call DEBLNK + call DELIM + jnz PARSE81 + inx sp + inx sp + jmp PARSE82 +PARSE81: + pop d +PARSE82: + mov a,c + ora a + pop b + mov a,c + pop b + inx h + mov m,c + inx h + mov m,b + inx h + mov m,a + xchg + rnz + lxi h,0 + ret +PARSE9: + pop h + pop h + lxi h,0FFFFh + ret +; +SETFLD: + call DELIM + jz PADFLD + inx h + cpi '*' + jnz SETFD1 + mvi m,'?' + dcr b + jnz SETFLD + jmp SETFD2 +SETFD1: + mov m,a + dcr b +SETFD2: + inx d + jnz SETFLD +SETFD3: + call DELIM + rz + pop h + jmp PARSE9 +; +PWFLD: + call DELIM + jz PADFLD + inx sp + inx sp + inx sp + inx sp + inx sp + inx sp + push d + push h + mvi l,0 + xthl + dcx sp + dcx sp +PWFLD1: + inx sp + inx sp + xthl + inr l + xthl + dcx sp + dcx sp + inx h + mov m,a + inx d + dcr b + jz SETFD3 + call DELIM + jnz PWFLD1 +; +PADFLD: + inx h + mvi m,' ' + dcr b + jnz PADFLD + ret +; +DELIM: + ldax d + mov c,a + ora a + rz + mvi c,0 + cpi 0Dh + rz + mov c,a + cpi 09h + rz + cpi ' ' + jc DELIM2 + rz + cpi '.' + rz + cpi ':' + rz + cpi ';' + rz + cpi '=' + rz + cpi ',' + rz + cpi '/' + rz + cpi '[' + rz + cpi ']' + rz + cpi '<' + rz + cpi '>' + rz + cpi 'a' + rc + cpi 'z'+1 + jnc DELIM1 + ani 05Fh +DELIM1: + ani 07Fh + ret +DELIM2: + pop h + jmp PARSE9 +; +DEBLNK: + ldax d + cpi ' ' + jz DBLNK1 + cpi 09h + jz DBLNK1 + ret +DBLNK1: + inx d + jmp DEBLNK +; End of the Parser +; +; GET a character from the console buffer +GNC: + push h + lxi h,CONBUF-1 ;get length + mov a,m + ora a ;zero? + mvi a,CR ;return with CR if so + jz GNCRET + dcr m ;lenght = length-1 + lhld NEXTCOM ;next char address + mov a,m + inx h ;bump to next + shld NEXTCOM ;update +GNCRET: + pop h +TRANS: + cpi 7Fh ;Rubout? + rz + cpi ('A' or 0100000b) + rc + ani 1011111b ; clear upper case bit + ret +; +; +; Scan the buffer for the address read in ASCII from the terminal +; +SCANAD: + lxi d,00h ;zero out address + push d ;and save +; + lda CONBUF-1 ;get character count + cpi 05 ;5 is too many + jc SCAN0 + stc ;set carry for routine + jmp SCNRET +SCAN0: + call GNC ;get a char + cpi CR ;end? + jz SCNRET ;to scnret if so + cpi '0' ;is it >0? + jnc SCAN01 ;bad character + jmp SCNRET +SCAN01: + cpi '@' + jnz SCAN02 ;bad character + stc + jmp SCNRET ;return on bad file +SCAN02: + jnc SCAN1 ;must be A-F + sui 030h ;normalize 0-9 + jmp SCAN2 +SCAN1: + cpi 'G' ;is it out of range? + jc SCAN11 + stc + jmp SCNRET +SCAN11: + sui 037h ;normalize +SCAN2: + mov l,a ;character in low of DE + lda CONBUF-1 ;get # left + adi 1 ;readjust + mov c,a + mvi h,00 ;zero out high order +SCAN3: + dcr c ;dec to set flag + jz SCAN4 ;were done + dad h ;shift 1bit left + dad h ;same + dad h ;same + dad h ;finally + jmp SCAN3 ;back for more +; +SCAN4: + pop d ;ready for or + mov a,d ;high order + ora h ; + mov d,a + mov a,e ;low order + ora l ;ORed + mov e,a ;back + push d ;save + jmp SCAN0 ;get more characters +SCNRET: + pop d ;hl = address + xchg ;DE->HL + ret +; +; +; ********************************* +; * * +; * Data Structures * +; * * +; ********************************* +; +SCBPB: + db 03Ah ;SCB address + db 0 +; +SADDR: dw 0 ;write start address +FADDR: dw 0 ;write finish address +BIOSAD: dw 0 ;WarmBOOT bios address +NEXTCOM: dw 0 ;address of next character to read +ONEFLG: db 0 +RSLT: dw 0 +CHGJMP db FALSE +; +SCBADR: dw 0 ;Scb address +; +BIOSMD: db 0 ;if non-zero change LXI @jmpadr to + ;JUMP when removed. +; +BUFFER: db CONMAX + db 0 ;# of console characters read +CONBUF: ds CONMAX +; +SIGNON: db CR,LF,'CP/M 3 SAVE - Version ',VERSION/10+'0','.',VERSION mod 10+'0','$' +FLEPRMPT: db CR,LF,'Enter file ' + db '(type RETURN to exit): $' +DELFLE: db CR,LF,'Delete $' +SPRMPT: db CR,LF,'Beginning hex address $' +FPRMPT: db CR,LF,'Ending hex address $' +ENDMSG: db CR,LF,'$' +; +; Error messages...... +CERROR: db CR,LF,'ERROR: Bad close.$' +NODIR: db CR,LF,'ERROR: No directory space.$' +NOBLK: db CR,LF,'ERROR: No disk space.$' +; +; Stack for program + ds STKSZE +STACK: + end ;Physical end of program + \ No newline at end of file diff --git a/software/CPM/cpm3/scan.lit b/software/CPM/cpm3/scan.lit new file mode 100644 index 0000000..ec3d30a --- /dev/null +++ b/software/CPM/cpm3/scan.lit @@ -0,0 +1,22 @@ + +declare + pcb$structure literally 'structure ( + state address, + scan$adr address, + token$adr address, + tok$typ byte, + token$len byte, + p$level byte, + nxt$token byte)'; + +declare + t$null lit '0', + t$param lit '1', + t$op lit '2', + t$mod lit '4', + t$identifier lit '8', + t$string lit '16', + t$numeric lit '32', + t$filespec lit '64', + t$error lit '128'; + diff --git a/software/CPM/cpm3/scan.plm b/software/CPM/cpm3/scan.plm new file mode 100644 index 0000000..e5d64ff --- /dev/null +++ b/software/CPM/cpm3/scan.plm @@ -0,0 +1,731 @@ +$title ('Utility Command Line Scanner') +scanner: +do; + +$include(comlit.lit) +$include(mon.plm) + +dcl debug boolean initial (false); + +dcl eob lit '0'; /* end of buffer */ + +$include(fcb.lit) + + +/* -------- Some routines used for diagnostics if debug mode is on -------- */ + +printchar: procedure(char) external; + declare char byte; +end printchar; + +printb: procedure external; +end printb; + +crlf: procedure external; +end crlf; + +pdecimal: procedure(v,prec,zerosup) external; + /* print value v, field size = (log10 prec) + 1 */ + /* with leading zero suppression if zerosup = true */ + declare v address, /* value to print */ + prec address, /* precision */ + zerosup boolean, /* zero suppression flag */ + d byte; /* current decimal digit */ + +end pdecimal; + +/* +show$buf: procedure; +dcl i byte; +i = 1; +call crlf; +call mon1(9,.('buff = $')); +do while buff(i) <> 0; + i = i + 1; +end; +buff(i) = '$'; +call mon1(9,.buff(1)); +buff(i) = 0; +end show$buf; */ + + +/* -------- -------- */ + +white$space: procedure (str$adr) byte; + dcl str$adr address, + str based str$adr (1) byte, + i byte; + i = 0; + do while (str(i) = ' ') or (str(i) = tab); + i = i + 1; + end; + return(i); +end white$space; + +delimiter: procedure(char) boolean; + dcl char byte; + if char = '[' or char = ']' or char = '(' or char = ')' or + char = '=' or char = ',' or char = 0 then + return (true); + return(false); +end delimiter; + +dcl string$marker lit '05ch'; + +deblank: procedure(buf$adr); + dcl (buf$adr,dest) address, + buf based buf$adr (128) byte, + (i,numspaces) byte, + string boolean; + + string = false; + if (numspaces := white$space(.buf(1))) > 0 then + call move(buf(0) - numspaces + 1,.buf(numspaces+1),.buf(1)); + i = 1; + do while buf(i) <> 0; + +/* call show$buf;*/ + + do while ((numspaces := white$space(.buf(i))) = 0 and (buf(i) <> 0)) + and not string; + /* call mon1(9,.(cr,lf,'2numspaces = $')); + call pdecimal(numspaces,100,false);*/ +/* call show$buf;*/ + if buf(i) = '"' then + do; + string = true; + buf(i) = string$marker; + end; + i = i + 1; + end; + + do while string and buf(i) <> 0; + if buf(i) = '"' then + if buf(i+1) = '"' then + call move(buf(0) - i + 1,.buf(i+1), .buf(i)); + else + do; + buf(i) = string$marker; + string = false; + end; + i = i + 1; + end; + + if (numspaces := white$space(.buf(i))) > 0 then + do; +/* call mon1(9,.(cr,lf,'1numspaces = $')); + call pdecimal(numspaces,100,false);*/ + buf(i) = ' '; + dest = .buf(i+1); /* save space for ',' */ + if i > 1 then + if delimiter(buf(i-1)) or delimiter(buf(i+numspaces)) then + /* write over ' ' with */ + dest = dest - 1; /* a = [ ] ( ) */ + + call move(((buf(0)+1)-(i+numspaces-1)), + .buf(i+numspaces),dest); + if buf(i) = '"' then + string = true; + i = i + 1; + end; + + end; + if buf(i - 1) = ' ' then /* no trailing blanks */ + buf(i - 1) = 0; + /* if debug then + call show$buf; */ +end deblank; + +upper$case: procedure (buf$adr); + dcl buf$adr address, + buf based buf$adr (1) byte, + i byte; + + i = 0; + do while buf(i) <> eob; + if buf(i) >= 'a' and buf(i) <= 'z' then + buf(i) = buf(i) - ('a' - 'A'); + i = i + 1; + end; +end upper$case; + +dcl option$max lit '11'; +dcl done$scan lit '0ffffh'; +dcl ident$max lit '11'; +dcl token$max lit '11'; + +dcl t$null lit '0', + t$param lit '1', + t$option lit '2', + t$modifier lit '4', + t$identifier lit '8', + t$string lit '16', + t$numeric lit '32', + t$filespec lit '64', + t$error lit '128'; + +dcl pcb$base address; +dcl pcb based pcb$base structure ( + state address, + scan$adr address, + token$adr address, + token$type byte, + token$len byte, + p$level byte, + nxt$token byte); + +dcl scan$adr address, + inbuf based scan$adr (1) byte, + in$ptr byte, + token$adr address, + token based token$adr (1) byte, + t$ptr byte, + (char, nxtchar, tcount) byte; + +digit: procedure (char) boolean; + dcl char byte; + return (char >= '0' and char <= '9'); +end digit; + +letter: procedure (char) boolean; + dcl char byte; + return (char >= 'A' and char <= 'Z'); +end letter; + + eat$char: procedure; + char = inbuf(in$ptr := inptr + 1); + nxtchar = inbuf(in$ptr + 1); + end eat$char; + + put$char: procedure(charx); + dcl charx byte; + if pcb.token$adr <> 0ffffh then + token(t$ptr := t$ptr + 1) = charx; + end put$char; + + get$identifier: procedure (max) byte; + dcl max byte; + + tcount = 0; + /* call mon1(9,.(cr,lf,'getindentifier$'));*/ + if not letter(char) and char <> '$' then + return(tcount); + do while (letter(char) or digit(char) or char = '_' or + char = '$' ) and tcount <= max; + call put$char(char); + call eat$char; + tcount = tcount + 1; + end; + do while letter(char) or digit(char) or char = '_' + or char = '$' ; + call eat$char; + tcount = tcount + 1; + end; + pcb.token$type = t$identifier; +/* call mon1(9,.(cr,lf,'end of getident$')); */ + pcb.token$len = tcount; + return(tcount); + end get$identifier; + + file$char: procedure (x) boolean; + dcl x byte; + return(letter(x) or digit(x) or x = '*' or x = '?' + or x = '_' or x = '$'); + end file$char; + + expand$wild$cards: procedure(field$size) boolean; + dcl (i,leftover,field$size) byte, + save$inptr address; + + field$size = field$size + t$ptr; + do while filechar(char) and t$ptr < field$size; + if char = '*' then + do; leftover = t$ptr; + save$inptr = inptr; + call eatchar; + do while filechar(char); + leftover = leftover + 1; + call eatchar; + end; + if leftover >= field$size then /* too many chars */ + do; inptr = save$inptr; + return(false); + end; + do i = 1 to field$size - leftover; + call putchar('?'); + end; + inptr = save$inptr; + end; + else + call putchar(char); + call eatchar; + end; + return(true); + end expand$wild$cards; + + get$file$spec: procedure boolean; + dcl i byte; + do i = 1 to f$name$len + f$type$len; + token(i) = ' '; + end; + if nxtchar = ':' then + if char >= 'A' and char <= 'P' then + do; + call putchar(char - 'A' + 1); + call eat$char; /* skip ':' */ + call eat$char; /* 1st char of file name */ + end; + else + return(false); + else + call putchar(0); /* use default drive */ + + if not (letter(char) or char = '$' or char = '_' + or char = '*' or char = '?' ) then /* no leading numerics */ + if token(0) = 0 then /* ambiguous with numeric token */ + return(false); + + if not expand$wild$cards(f$namelen) then + return(false); /* blank name is illegal */ + if char = '.' then + do; call eat$char; + if filechar(char) then + do; t$ptr = f$namelen; + if not expand$wild$cards(f$typelen) then + return(false); + end; + end; + + pcb.token$len = f$name$len + f$type$len + 1; + pcb.token$type = t$file$spec; + return(true); + end get$file$spec; + + get$numeric: procedure(max) boolean; + dcl max byte; + if not digit(char) then + return(false); + do while digit(char) and pcb.token$len <= max and + char <> eob; + call putchar(char); + call eat$char; + pcb.token$len = pcb.token$len + 1; + end; + if char = 'H' or char = 'D' or char = 'B' then + if pcb.token$len < max then + do; + call putchar(char); + call eat$char; + pcb.token$len = pcb.token$len + 1; + end; + else + return(false); + pcb.token$type = t$numeric; + return(true); + end get$numeric; + + get$string: procedure(max) boolean; + dcl max byte; + if char <> string$marker then + return(false); + call eatchar; + do while char <> string$marker and char <> eob + and pcb.token$len < token$max; + call putchar(char); + call eatchar; + pcb.token$len = pcb.token$len + 1; + end; + + do while char <> string$marker and char <> eob; + call eat$char; + end; + if char <> string$marker then + return(false); + pcb.token$type = t$string; + call eat$char; + return(true); + end get$string; + + get$token$all: procedure boolean; + dcl save$inptr byte; + +/* call mon1(9,.(cr,lf,'gettokenall$'));*/ + + save$inptr = in$ptr; + if get$file$spec then + return(true); + +/* call mon1(9,.(cr,lf,'gettokenall - no file$')); */ + in$ptr = save$inptr - 1; /* need to re-scan, reset buffer pointers */ + call eat$char; + t$ptr = 255; + call putchar(0); /* zero drive byte */ + + if get$identifier(token$max) = 0 then + if not get$string(token$max) then + if not get$numeric(token$max) then + return(false); + /* call mon1(9,.(cr,lf,'end gettokenall$'));*/ + return(true); + end get$token$all; + + get$modifier: procedure boolean; + if char = ',' or char = ')' or char = 0 then + do; + pcb.token$type = t$modifier or t$null; + return(true); + end; + if get$token$all then + do; + pcb.token$type = pcb.token$type or t$modifier; + return(true); + end; + return(false); + end get$modifier; + + get$option: procedure boolean; + call putchar(0); + if get$identifier(token$max) > 0 then + do; + pcb.token$type = pcb.token$type or t$option; + if pcb.token$len > token$max then + pcb.token$len = token$max; + return(true); + end; + return(false); + end get$option; + + get$param: procedure boolean; + if char = ',' or char = ')' or char = 0 then + do; + pcb.token$type = t$param or t$null; + return(true); + end; + if get$token$all then + do; + pcb.token$type = pcb.token$type or t$param; + return(true); + end; + return(false); + end get$param; + + dcl gotatoken boolean; + dcl parens byte initial (0); + + end$state: procedure boolean; + if gotatoken then + do; + pcb.state = .end$state; + return(true); + end; + pcb.token$type = t$null; + pcb.scan$adr = 0ffffh; + return(true); + end end$state; + + state8: procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state8, char = $')); + call printchar(char); end; + if char = 0 then + return(end$state); + if char = ']' then + do; + call eatchar; + if char = ',' or nxtchar = '(' or nxtchar = ')' then + return(state2); + else if char = 0 then + return(end$state); + else + return(state1); + end; + else if char = ' ' or char = ',' then + do; + call eatchar; + return(state3); + end; + return(state3); + end state8; + + state7:procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state7, char = $')); + call printchar(char); end; + if char = 0 then + return(end$state); + if char = ' ' or char = ',' then + do; + call eat$char; + return(state6); + end; + else + if char = ')' then + do; + call eat$char; + return(state8); + end; + return(false); + end state7; + + state6: procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state6, char = $')); + call printchar(char); end; + if gotatoken then + do; + pcb.state = .state6; + pcb.nxt$token = t$modifier; + return(true); + end; + if (gotatoken := get$modifier) then + return(state7); + return(false); + end state6; + + state5:procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state5, nxtchar = $')); + call printchar(nxtchar); end; + if char = '(' then + do; + call eat$char; + return(state6); + end; + if gotatoken then + do; + pcb.state = .state5; + pcb.nxt$token = t$modifier; + return(true); + end; + if (gotatoken := get$modifier) then + return(state8); + return(false); + end state5; + + state4: procedure boolean reentrant; + dcl temp byte; + if debug then do; + call mon1(9,.(cr,lf,'state4, char = $')); + call printchar(char); end; + if char = 0 then + return(end$state); + temp = char; + call eatchar; + if temp = ',' or temp = ' ' then + return(state3); + if temp = ']' then + if char = '(' or char = ',' or char = ')' then + return(state2); + else if char = 0 then + return(end$state); + else + return(state1); + if temp = '=' then + return(state5); + return(false); + end state4; + + state3: procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state3, char = $')); + call printchar(char); end; + if gotatoken then + do; + pcb.state = .state3; + pcb.nxt$token = t$option; + return(true); + end; + if (pcb.plevel := parens ) > 128 then + return(false); + if (gotatoken := get$option) then + return(state4); + return(false); + end state3; + + state2: procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state2, char = $')); + call printchar(char); end; + do while char = ')' or char = 0; + if char = 0 then + return(end$state); + call eat$char; + parens = parens - 1; + end; + if char = '[' then + do; + call eat$char; + return(state3); + end; + if char = ' ' or char = ',' or char = '(' then + do; + if char = '(' then + parens = parens + 1; + call eat$char; + return(state1); + end; + return(state1); + end state$2; + + state1: procedure boolean reentrant; + if debug then do; + call mon1(9,.(cr,lf,'state1, char = $')); + call printchar(char); end; + + if gotatoken then + do; + pcb.nxt$token = t$param; + pcb.state = .state1; + return(true); + end; + do while char = '(' ; + parens = parens + 1; + call eat$char; + end; + if (pcb.plevel := parens) > 128 then + return(false); + if (gotatoken := get$param) then + return(state2); + return(false); + end state1; + + start$state: procedure boolean; + if char = '@' then do; + debug = true; + call eat$char; + call mon1(9,.(cr,lf,'startstate, char = $')); + call printchar(char); end; + + if char = 0 then + return(end$state); + if char = ')' then + return(false); + if char = '(' then + do; + parens = parens + 1; + call eat$char; + return(state1); + end; + if char = '[' then + do; + call eat$char; + return(state3); + end; + if (gotatoken := get$param) then + return(state2); + return(false); + end start$state; + +/* display$all: procedure; /* called if debug set */ + + /* call mon1(9,.(cr,lf,'scanadr=$')); + call pdecimal(pcb.scanadr,10000,false); + call mon1(9,.(', tadr=$')); + call pdecimal(pcb.token$adr,10000, false); + call mon1(9,.(', tlen=$')); + call pdecimal(double(pcb.token$len),100, false); + call mon1(9,.(', ttype=$')); + call pdecimal(double(pcb.token$type),100,false); + call mon1(9,.(', plevel=$')); + call pdecimal(double(pcb.plevel),100,false); + call mon1(9,.(', ntok=$')); + call pdecimal(double(pcb.nxt$token),100,false); + + if (pcb.token$type and t$option) <> 0 then + call mon1(9,.(cr,lf,'option =$')); + if (pcb.token$type and t$param) <> 0 then + call mon1(9,.(cr,lf,'parm =$')); + if (pcb.token$type and t$modifier) <> 0 then + call mon1(9,.(cr,lf,'modifier=$')); + + if (pcb.token$type and t$filespec) <> 0 then + do; + if fcb(0) = 0 then + call print$char('0'); + else call print$char(fcb(0) + 'A' - 1); + call print$char(':'); + fcb(12) = '$'; + call mon1(9,.fcb(1)); + call mon1(9,.(' (filespec)$')); + end; + if ((pcb.token$type and t$string) or (pcb.token$type and + t$identifier) or (pcb.token$type and t$numeric)) <> 0 then + do; + fcb(pcb.token$len + 1) = '$'; + call mon1(9,.fcb(1)); + end; + if pcb.token$type = t$error then + do; + call mon1(9,.(cr,lf,'scanner error$')); + return; + end; + + if (pcb.token$type and t$identifier) <> 0 then + call mon1(9,.(' (identifier)$')); + if (pcb.token$type and t$string) <> 0 then + call mon1(9,.(' (string)$')); + if (pcb.token$type and t$numeric) <> 0 then + call mon1(9,.(' (numeric)$')); + + if (pcb.nxt$token and t$option) <> 0 then + call mon1(9,.(cr,lf,'nxt tok = option $')); + if (pcb.nxt$token and t$param) <> 0 then + call mon1(9,.(cr,lf,'nxt tok = parm $')); + if (pcb.nxt$token and t$modifier) <> 0 then + call mon1(9,.(cr,lf,'nxt tok = modifier$')); + call crlf; + +end display$all; */ + +scan: procedure (pcb$adr) public; + + dcl status boolean, + pcb$adr address; + + pcb$base = pcb$adr; + scan$adr = pcb.scan$adr; + token$adr = pcb.token$adr; + + in$ptr, t$ptr = 255; + call eatchar; + + gotatoken = false; + pcb.nxt$token = t$null; + pcb.token$len = 0; + + if pcb.token$type = t$error then /* after one error, return */ + return; /* on any following calls */ + else if pcb.state = .start$state then + status = start$state; + else if pcb.state = .state$1 then + status = state$1; + else if pcb.state = .state$3 then + status = state$3; + else if pcb.state = .state$5 then + status = state$5; + else if pcb.state = .state$6 then + status = state$6; + else if pcb.state = .end$state then /* repeated calls go here */ + status = end$state; /* after first end$state */ + else + status = false; + + if not status then + pcb.token$type = t$error; + + if pcb.scan$adr <> 0ffffh then + pcb.scan$adr = pcb.scan$adr + inptr; + /* if debug then + call display$all; */ +end scan; + +scan$init: procedure(pcb$adr) public; + dcl pcb$adr address; + + pcb$base = pcb$adr; + call deblank(pcb.scan$adr); + call upper$case(pcb.scan$adr := pcb.scan$adr + 1); + pcb.state = .start$state; +end scan$init; + +end scanner; diff --git a/software/CPM/cpm3/scb.asm b/software/CPM/cpm3/scb.asm new file mode 100644 index 0000000..49234c6 --- /dev/null +++ b/software/CPM/cpm3/scb.asm @@ -0,0 +1,49 @@ + title 'System Control Block Definition for CP/M3 BIOS' + + public @civec, @covec, @aivec, @aovec, @lovec, @bnkbf + public @crdma, @crdsk, @vinfo, @resel, @fx, @usrcd + public @mltio, @ermde, @erdsk, @media, @bflgs + public @date, @hour, @min, @sec, ?erjmp, @mxtpa + + +scb$base equ 0FE00H ; Base of the SCB + +@CIVEC equ scb$base+22h ; Console Input Redirection + ; Vector (word, r/w) +@COVEC equ scb$base+24h ; Console Output Redirection + ; Vector (word, r/w) +@AIVEC equ scb$base+26h ; Auxiliary Input Redirection + ; Vector (word, r/w) +@AOVEC equ scb$base+28h ; Auxiliary Output Redirection + ; Vector (word, r/w) +@LOVEC equ scb$base+2Ah ; List Output Redirection + ; Vector (word, r/w) +@BNKBF equ scb$base+35h ; Address of 128 Byte Buffer + ; for Banked BIOS (word, r/o) +@CRDMA equ scb$base+3Ch ; Current DMA Address + ; (word, r/o) +@CRDSK equ scb$base+3Eh ; Current Disk (byte, r/o) +@VINFO equ scb$base+3Fh ; BDOS Variable "INFO" + ; (word, r/o) +@RESEL equ scb$base+41h ; FCB Flag (byte, r/o) +@FX equ scb$base+43h ; BDOS Function for Error + ; Messages (byte, r/o) +@USRCD equ scb$base+44h ; Current User Code (byte, r/o) +@MLTIO equ scb$base+4Ah ; Current Multi-Sector Count + ; (byte,r/w) +@ERMDE equ scb$base+4Bh ; BDOS Error Mode (byte, r/o) +@ERDSK equ scb$base+51h ; BDOS Error Disk (byte,r/o) +@MEDIA equ scb$base+54h ; Set by BIOS to indicate + ; open door (byte,r/w) +@BFLGS equ scb$base+57h ; BDOS Message Size Flag (byte,r/o) +@DATE equ scb$base+58h ; Date in Days Since 1 Jan 78 + ; (word, r/w) +@HOUR equ scb$base+5Ah ; Hour in BCD (byte, r/w) +@MIN equ scb$base+5Bh ; Minute in BCD (byte, r/w) +@SEC equ scb$base+5Ch ; Second in BCD (byte, r/w) +?ERJMP equ scb$base+5Fh ; BDOS Error Message Jump + ; (word, r/w) +@MXTPA equ scb$base+62h ; Top of User TPA + ; (address at 6,7)(word, r/o) + end + diff --git a/software/CPM/cpm3/search.lit b/software/CPM/cpm3/search.lit new file mode 100644 index 0000000..9c59ed9 --- /dev/null +++ b/software/CPM/cpm3/search.lit @@ -0,0 +1,22 @@ + +declare /* what kind of file user wants to find */ + find$structure lit 'structure ( + dir byte, + sys byte, + ro byte, + rw byte, + pass byte, + xfcb byte, + nonxfcb byte, + exclude byte)'; + +declare + max$search$files literally '10'; + +declare + search$structure lit 'structure( + drv byte, + name(8) byte, + type(3) byte, + anyfile boolean)'; /* match on any drive if true */ + diff --git a/software/CPM/cpm3/search.plm b/software/CPM/cpm3/search.plm new file mode 100644 index 0000000..ff717d4 --- /dev/null +++ b/software/CPM/cpm3/search.plm @@ -0,0 +1,436 @@ +$title ('SDIR - Search For Files') +search: +do; + /* search module for extended dir */ + +$include (comlit.lit) +$include (mon.plm) + +dcl debug boolean external; + +dcl first$pass boolean external; +dcl get$all$dir$entries boolean external; +dcl usr$vector address external; +dcl active$usr$vector address external; +dcl used$de address public; /* used directory entries */ +dcl filesfound address public; /* num files collected in memory */ + +$include(fcb.lit) +$include(xfcb.lit) + +declare + sfcb$type lit '21H', + deleted$type lit '0E5H'; + +$include (search.lit) +dcl find find$structure external; /* what kind of files to look for */ +dcl num$search$files byte external; +dcl search (max$search$files) search$structure external; + /* file specs to match on */ + + /* other globals */ + +dcl cur$usr byte external, + cur$drv byte external, /* current drive " " */ + dir$label byte public; /* directory label for BDOS 3.0 */ + + +/* -------- BDOS calls -------- */ + +read$char: procedure byte; + return mon2 (1,0); +end read$char; + + +/* -------- in sort.plm -------- */ + +mult23: procedure(f$info$index) address external; + dcl f$info$index address; +end mult23; + + +/* -------- in util.plm -------- */ + +print: procedure(string$adr) external; + dcl string$adr address; +end print; + +print$char: procedure(char) external; + dcl char byte; +end print$char; + +pdecimal:procedure(val,prec,zsup) external; + dcl (val, prec) address; + dcl zsup boolean; +end pdecimal; + +printfn: procedure(fnameadr) external; + dcl fnameadr address; +end printfn; + +crlf: procedure external; /* print carriage return, linefeed */ +end crlf; + +add3byte: procedure(byte3adr,num) external; + dcl (byte3adr,num) address; +end add3byte; + + /* add three byte number to 3 byte accumulater */ +add3byte3: procedure(totalb,numb) external; + dcl (totalb,numb) address; +end add3byte3; + + /* divide 3 byte value by 8 */ +shr3byte: procedure(byte3adr) external; + dcl byte3adr address; +end shr3byte; + +/* -------- In dpb86.plm -------- */ + +$include(dpb.lit) + +dcl k$per$block byte external; /* set in dpb module */ + +base$dpb: procedure external; +end base$dpb; + +dpb$byte: procedure(param) byte external; + dcl param byte; +end dpb$byte; + +dpb$word: procedure(param) address external; + dcl param byte; +end dpb$word; + + +/* -------- Some Utility Routines -------- */ + +check$console$status: procedure byte; + return mon2 (11,0); +end check$console$status; + +search$first: procedure (fcb$address) byte public; + declare fcb$address address; /* shared with disp.plm */ + return mon2 (17,fcb$address); /* for short display */ +end search$first; + +search$next: procedure byte public; /* shared with disp.plm */ + return mon2 (18,0); +end search$next; + +terminate: procedure external; /* in main.plm */ +end terminate; + +set$vec: procedure(vector,value) external; /* in main.plm */ +dcl vector address, + value byte; +end set$vec; + +break: procedure public; /* shared with disp.plm */ + dcl x byte; + if check$console$status then + do; + x = read$char; + call terminate; + end; +end break; + + +/* -------- file information record declaration -------- */ + +$include(finfo.lit) + +declare + buf$fcb$adr address public, /* index into directory buffer */ + buf$fcb based buf$fcb$adr (32) byte, + /* fcb template for dir */ + (first$f$i$adr, f$i$adr, last$f$i$adr) address public, + /* indices into file$info array */ + file$info based f$i$adr f$info$structure, + sfcb$adr address, + dir$type based sfcb$adr byte, + sfcbs$present byte public, + x$i$adr address public, + xfcb$info based x$i$adr x$info$structure; + +compare: procedure(length, str1$adr, str2$adr) boolean; + dcl (length,i) byte, + (str1$adr, str2$adr) address, + str1 based str1$adr (1) byte, + str2 based str2$adr (1) byte; + /* str2 is the possibly wildcarded filename we are looking for */ + + do i = 0 to length - 1; + if ((str1(i) and 7fh) <> (str2(i) and 7fh)) and str2(i) <> '?' then + return(false); + end; + return(true); +end compare; + +match: procedure boolean public; +dcl i byte, + temp address; + if (i := (buf$fcb(f$drvusr) and 0fh)) <> cur$usr then + if not get$all$dir$entries then /* Not looking for this user */ + return(false); /* and not buffering all other*/ + else /* specified user files on */ + do; temp = 0; /* this drive. */ + call set$vec(.temp,i); + if (temp and usr$vector) = 0 then /* Getting all dir entries, */ + return(false); /* with user number corresp'g */ + end; /* to a bit on in usr$vector */ + + if usr$vector <> 0 and i <> 0 and first$pass <> 0 then + call set$vec(.active$usr$vector,i); /* skip cur$usr files */ + /* build active usr vector for this drive */ + + do i = 0 to num$search$files - 1; + if search(i).drv = 0ffh or search(i).drv = cur$drv then + /* match on any drive if 0ffh */ + if search(i).anyfile = true then + return(not find.exclude); /* file found */ + else if compare(11,.buf$fcb(f$name),.search(i).name(0)) then + return(not find.exclude); /* file found */ + end; + return(find.exclude); /* file not found */ +end match; /* find.exclude = the exclude option value */ + +dcl hash$table$size lit '128', /* must be power of 2 */ + hash$table (hash$table$size) address at (.memory), + /* must be initialized on each*/ + hash$entry$adr address, /* disk scan */ + hash$entry based hash$entry$adr address; /* where to put a new entry's */ + /* address */ + +hash$look$up: procedure boolean; + dcl (i,found,hash$index) byte; + hash$index = 0; + do i = f$name to f$namelen + f$typelen; + hash$index = hash$index + (buf$fcb(i) and 7fh); /* attributes may */ + end; /* only be set w/ 1st extent */ + hash$index = hash$index + cur$usr; + hash$index = hash$index and (hash$table$size - 1); + hash$entry$adr = .hash$table(hash$index); /* put new entry in table if */ + f$i$adr = hash$table(hash$index); /* unused ( = 0) */ + + found = false; + do while f$i$adr <> 0 and not found; + if file$info.usr = (buf$fcb(f$drvusr) and 0fh) and + compare(f$namelen + f$typelen,.file$info.name(0),.buf$fcb(f$name)) + then + found = true; + else /* table entry used - collison */ + do; hash$entry$adr = .file$info.hash$link; /* resolve by linked */ + f$i$adr = file$info.hash$link; /* list */ + end; + end; + if f$i$adr = 0 then + return(false); /* didn't find it, used hash$entry to keep new info */ + else return(true); /* found it, file$info at matched entry */ +end hash$look$up; + +$eject +store$file$info: procedure boolean; + /* Look for file name of last found fcb or xfcb in fileinfo */ + /* array, if not found put name in fileinfo array. Copy other */ + /* info to fileinfo or xfcbinfo. The lookup is hash coded with */ + /* collisions handled by linking up file$info records through */ + /* the hash$link field of the previous file$info record. */ + /* The file$info array grows upward in memory and the xfcbinfo */ + /* grows downward. */ + /* + + -------------------------<---.memory + __ | HASH TABLE | +hash = \ of filename -->| root of file$info list|------------>-----------| +func /__ letters | . | | + | . | | + lower memory ------------------------- <-- first$f$i$adr | + | file$info entry | | + (hash) -----<--| . | <----------------------| + (collision) | | . | + ------->| . | + | . |-------------------->| + | last file$info entry | <- last$f$i$adr | + |-----------------------| | + | | | + | | | + | unused by dsearch, | | + | used by dsort | | + | for indices | | + | | | + | | | + |-----------------------| | + | last$xfcb entry | <- x$i$adr | + | . | | + | . | | + | . | <-------------------| + | first xfcb entry | + |-----------------------| + | un-usuable memory | <- maxb + higher memory ------------------------- */ + + + dcl (i, j, d$map$cnt) byte, + temp address; + + store$file: procedure; + call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name); + /* attributes are not in XFCBs to copy again in case */ + /* XFCB came first in directory */ + + file$info.name(f$arc-1) = file$info.name(f$arc-1) and buf$fcb(f$arc); + /* 0 archive bit if it is 0 in any dir entry */ + d$map$cnt = 0; /* count kilobytes for current dir entry */ + i = 1; /* 1 or 2 byte block numbers ? */ + if dpb$word(blk$max$w) > 255 then + i = 2; + do j = f$diskmap to f$diskmap + diskmaplen - 1 by i; + temp = buf$fcb(j); + if i = 2 then /* word block numbers */ + temp = temp or buf$fcb(j+1); + if temp <> 0 then /* allocated */ + d$map$cnt = d$map$cnt + 1; + end; + if d$map$cnt > 0 then + do; + call add3byte + (.file$info.recs$lword, + d$map$cnt * (dpb$byte(blkmsk$b) + 1) - + ( (128 - buf$fcb(f$rc)) and dpb$byte(blkmsk$b) ) + ); + file$info.onekblocks = file$info.onekblocks + + d$map$cnt * k$per$block - + shr( (128 - buf$fcb(f$rc)) and dpb$byte(blkmsk$b), 3 ); + /* treat each directory entry separately for sparse files */ + /* if copied to single density diskette, the number of 1kblocks */ + file$info.kbytes = file$info.kbytes + d$map$cnt * k$per$block; + end; + end; + + if buf$fcb(f$drvusr) <> sfcb$type then do; /* don't put SFCB's in table */ + if not hash$look$up then /* not in table already */ + /* hash$entry is where to put adr of new entry */ + do; /* copy to new position in file info array */ + if (temp := mult23(files$found + 1)) > x$i$adr then + return(false); /* out of memory */ + if (temp < first$f$i$adr) then + return(false); /* wrap around - out of memory */ + f$i$adr = (last$f$i$adr := last$f$i$adr + size(file$info)); + filesfound = filesfound + 1; + call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name); + file$info.usr = buf$fcb(f$drvusr) and 0fh; + file$info.onekblocks,file$info.kbytes,file$info.recs$lword, + file$info.recs$hbyte, file$info.x$i$adr,file$info.hash$link = 0; + hash$entry = f$i$adr; /* save the address of file$info */ + end; /* zero totals for the new file */ + end; + + /* else hash$lookup has set f$i$adr to the file entry already in the */ + /* hash table */ + /* save sfcb,xfcb or fcb type info */ + if sfcbs$present then do; + if (buf$fcb(f$drvusr) and xfcb$type) = 0 then do; + if buf$fcb(f$drvusr) <> sfcb$type then do; + /* store sfcb info into xfcb table */ + if buf$fcb(f$ex) <= dpb$byte(extmsk$b) then do; + if last$f$i$adr + size(file$info) > x$i$adr - size(xfcb$info) then + return(false); /* out of memory */ + x$i$adr = x$i$adr - size(xfcb$info); + call move(9,sfcb$adr,.xfcb$info.create); + file$info.x$i$adr = x$i$adr; + end; /* extent check */ + call store$file; + end; + end; + end; + else do; /* no SFCB's present */ + if (buf$fcb(f$drvusr) and xfcb$type) <> 0 then + do; /* XFCB */ +/* + if last$f$i$adr + size(file$info) > x$i$adr - size(xfcb$info) then + return(false); + x$i$adr = x$i$adr - size(xfcb$info); + call move(8,.buf$fcb(xf$create),.xfcb$info.create); + xfcb$info.passmode = buf$fcb(xf$passmode); + file$info.x$i$adr = x$i$adr; +*/ + end; + else do; + call store$file; /* must be a regular fcb then */ + end; + end; + return(true); /* success */ +end store$file$info; + + + /* Module Entry Point */ + +get$files: procedure public; /* with one scan through directory get */ + dcl dcnt byte; /* files from currently selected drive */ + + call print(.(cr,lf,'Scanning Directory...',cr,lf,'$')); + last$f$i$adr = first$f$i$adr - size(file$info); + /* after hash table */ + /* last$f$i$adr is the address of the highest file info record */ + /* in memory */ + + do dcnt = 0 to hash$table$size - 1; /* init hash table */ + hash$table(dcnt) = 0; + end; + + x$i$adr = maxb; /* top of mem, put xfcb info here */ + call base$dpb; + dir$label,filesfound, used$de = 0; + + fcb(f$drvusr) = '?'; /* match all dir entries */ + dcnt = search$first(.fcb); + sfcb$adr = 96 + .buff; /* determine if SFCB's are present */ + + if dir$type = sfcb$type then + sfcbs$present = true; + else + sfcbs$present = false; + + do while dcnt <> 255; + buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */ + + if sfcbs$present then + sfcb$adr = 97 + (dcnt * 10) + .buff; /* SFCB time & date stamp adr */ + + if buf$fcb(f$drvusr) <> deleted$type then + do; + used$de = used$de + 1; + + if buf$fcb(f$drvusr) = dirlabel$type then /* dir label ? */ + dir$label = buf$fcb(f$ex); /* save label info */ + else + if (match) then + do; + if not store$file$info then /* store fcb or xfcb info */ + do; /* out of space */ + call print (.('Out of Memory',cr,lf,'$')); + return; + end; /* not store$file$info */ + + end; /* else if match */ + + end; /* buf$fcb(f$drvusr) <> deleted$type */ + + call break; + dcnt = search$next; /* to next entry in directory */ + + end; /* of do while dcnt <> 255 */ +end get$files; + +search$init: procedure public; /* called once from main.plm */ + + if (first$f$i$adr := (.hash$table + size(hash$table))) + size(file$info) + > maxb then + do; + call print(.('Not Enough Memory',cr,lf,'$')); + call terminate; + end; +end search$init; + +end search; diff --git a/software/CPM/cpm3/set.plm b/software/CPM/cpm3/set.plm new file mode 100644 index 0000000..8c03946 --- /dev/null +++ b/software/CPM/cpm3/set.plm @@ -0,0 +1,1853 @@ +$ TITLE('CPM 3.0 --- SET 1.3') + +/* MULTI FILE INPUT VERSION 11/11/82 */ +/* took out call passwd in readlabel */ +/* added test for NONBANK in password, protect and default 11/19/82 */ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * SET * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +set: +do; + +declare + mpmproduct literally '01h', /* requires mp/m */ + cpmversion literally '30h'; /* requires 3.0 cp/m */ + + +declare + true literally '1', + false literally '0', + dcl literally 'declare', + lit literally 'literally', + proc literally 'procedure', + addr literally 'address', + tab literally '9', + cr literally '13', + lf literally '10', + ctrlc literally '3h', + ctrlx literally '18h', + ctrlh literally '8h'; + +declare + opt$access literally '0', + opt$archive literally '1', + opt$create literally '2', + opt$default literally '3', + opt$dir literally '4', + opt$f1 literally '5', + opt$f2 literally '6', + opt$f3 literally '7', + opt$f4 literally '8', + opt$name literally '9', + opt$pass literally '10', + opt$prot literally '11', + opt$ro literally '12', + opt$rw literally '13', + opt$sys literally '14', + opt$update literally '15', + opt$page literally '16', + opt$nopage literally '17', + + PERIOD literally '02eh', + PAGE byte initial(false); + +declare plm label public; + +declare copyright (*) byte data ( + ' Copyright (c) 1982 Digital Research '); + +/* + Digital Research + Box 579 + Pacific Grove, Ca + 93950 +*/ +$ eject +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * MESSAGES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + declare + not$found (*) byte data (' File not found',0), + no$space (*) byte data (' or no directory space',0), + invalid (*) byte data ('Invalid file name.',0), + dirlabel (*) byte data ('Directory Label ',0), + option$set (*) byte data (' attribute set ',0), + read$only (*) byte data ('Read Only',0), + ro (*) byte data (' (RO)',0), + read$write (*) byte data ('Read Write (RW)',0), + comma (*) byte data (', ',0), + set$to (*) byte data ('set to ',0), + error$msg (*) byte data ('ERROR: ',0), + readmode (*) byte data ('READ',0), + writemode (*) byte data ('WRITE',0), + deletemode (*) byte data ('DELETE',0), + nopasswd (*) byte data ('NONE',0), + on (*) byte data (' on ',0), + off (*) byte data (' off ',0), + label$name (*) byte data ('LABEL'); + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * CP/M INTERFACE * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + +declare + maxb address external, /* addr field of jmp BDOS */ + fcb (33) byte external, /* default file control block */ + buff(128) byte external, /* default buffer */ + buffa literally '.buff', /* default buffer */ + fcba literally '.fcb', /* default file control block */ + user$code byte; /* current user code */ + + +/* Routines used in SET for CPM 3.0 */ + + /* reset drive mask */ + declare reset$mask (16) address data ( + 0000000000000001b, + 0000000000000010b, + 0000000000000100b, + 0000000000001000b, + 0000000000010000b, + 0000000000100000b, + 0000000001000000b, + 0000000010000000b, + 0000000100000000b, + 0000001000000000b, + 0000010000000000b, + 0000100000000000b, + 0001000000000000b, + 0010000000000000b, + 0100000000000000b, + 1000000000000000b ); + + +boot: procedure external; + /* reboot */ + end boot; + +mon1: procedure(f,a) external; + declare f byte, a address; + end mon1; + +mon2: procedure(f,a) byte external; + declare f byte, a address; + end mon2; + +declare mon3 literally 'mon2a'; + +mon3: procedure(f,a) address external; + declare f byte, a address; + end mon3; + + /********** SYSTEM FUNCTION CALLS *********************/ + +printchar: procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + +printb: procedure; /* print blank character */ + + call printchar(' '); + +end printb; + +printx: procedure(a); + declare a address; + declare s based a byte; + do while s <> 0; + call printchar(s); + a = a + 1; + end; + end printx; + +check$con$stat: procedure byte; + + return mon2(11,0); /* console ready */ + +end check$con$stat; + + +crlf2: procedure; + + call printchar(cr); + call printchar(lf); + +end crlf2; + + +terminate: procedure; + call crlf2; + call mon1 (0,0); +end terminate; + + +crlf: procedure; + declare charin byte; + + if PAGE then do; + line$out = line$out + 1; /* output > page size ? */ + if line$out + 2 > line$page then do; + call crlf2; + call crlf2; + call printx(.('Press RETURN to continue.',0)); + + do while not check$con$stat; + end; + + charin = mon2(1,0); /* read character */ + if charin = ctrlc then call terminate; + line$out = 1; + call crlf2; + end; + end; + + call crlf2; + +end crlf; + +print: procedure(a); /* print the string starting at address a until the + next 0 is encountered */ + declare a address; + + call crlf; + call printx(a); + +end print; + +get$version: procedure addr; /* returns current cp/m version # */ + + return mon3(12,0); + +end get$version; + + +conin: procedure byte; + + return mon2(6,0fdh); + +end conin; + +select: procedure(d); + declare d byte; + call mon1(14,d); + end select; + +search$first: procedure(fcb) byte; + declare fcb address; + return mon2(17,fcb); + end search$first; + +search$next: procedure byte; + return mon2(18,0); + end search$next; + +cselect: procedure byte; + /* return current disk number */ + return mon2(25,0); + end cselect; + +setdma: procedure(dma); + declare dma address; + call mon1(26,dma); + end setdma; + +writeprot: procedure byte; /* write protect the current disk */ + + return mon2(28,0); + +end writeprot; + +getuser: procedure byte; /* return current user number */ + + return mon2(32,0ffh); + +end getuser; + +return$errors: procedure(mode); /* 0ff => return BDOS errors */ + declare mode byte; + + call mon1 (45,mode); + +end return$errors; + +setind: procedure(fcb) address; /* SFA for current fcb */ + dcl fcb addr; + + call setdma(.passwd); + return mon3(30,fcb); + +end setind; + + /********** DISK PARAMETER BLOCK **********************/ + +declare + dpba address, + dpb based dpba structure( + scptrk address, + blkshf byte, + blkmsk byte, + extmsk byte, + maxall address, + dirmax address, + dirblk address, + chksiz address, + offset address, + physhf byte, + phymsk byte); + + +set$dpb: procedure; /* set disk parameter block values */ + + dpba = mon3(31,0); /* base of dpb */ + +end set$dpb; + + /******************************************************/ + +wrlbl: procedure(fcb) address; + declare fcb address; + + call setdma(.passwd); /* set dma=password */ + return mon3(100,fcb); + +end wrlbl; + +getlbl: procedure(d) byte; + declare d byte; + + return mon2(101,d); + +end getlbl; + +readxfcb: procedure(fcb) address; + declare fcb address; + + call setdma(.passwd); /* set dma=password */ + return mon3(102,fcb); + +end readxfcb; + +wrxfcb: procedure(fcb) address; + declare fcb address; + + call setdma(.passwd); + return mon3(103,fcb); + +end wrxfcb; + + +reset$drv: procedure(drv) byte; + dcl drv byte; + + return mon2(37,reset$mask(drv)); + end reset$drv; + +parse: procedure(pfcb) address external; + declare pfcb address; + +end parse; + +delete: procedure(fcb) byte; + declare fcb address; + + return mon2(19,fcb); + +end delete; + +$ eject + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * GLOBAL DATA * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + declare + fnam literally '11', + ftyp literally '9', + rofile literally '9', /* read/only file */ + sysfile literally '10', /* system file */ + archiv literally '11', /* archived file */ + attrb1 literally '1', /* attribute F1' */ + attrb2 literally '2', /* attribute F2' */ + attrb3 literally '3', /* attribute F3' */ + attrb4 literally '4'; /* attribute F4' */ + + declare + pwmask$on literally '80h', + pwmask$off literally '7fh', + acmask$on literally '40h', + acmask$off literally '0bfh', + upmask$on literally '20h', + upmask$off literally '0dfh', + crmask$on literally '10h', + crmask$off literally '0efh', + dlmask$on literally '1h', + dlmask$off literally '0feh'; + + declare + fcbp address, + fcbv based fcbp (32) byte, + fext literally 'fcbv(12)'; + + declare + xfcb (32) byte, + xfcbmode byte at (.xfcb(12)); /* password mode */ + + declare /* command buffer */ + cmd (27) byte initial(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0), + passwd (17) byte; /* password buffer */ + + declare + sfacmd byte initial(false), /* file attributes */ + fileref byte initial(false), /* file reference */ + lblcmd byte initial(false), /* label attribute */ + xfcbcmd byte initial(false), /* xfcb attribute */ + wild byte initial(false), /* file = a wildcard */ + optdel byte initial(false), /* delimiter = option */ + multi byte initial(false), + newpass byte initial(false), + passmsg byte initial(false), + NONBANK byte initial(false), + passmode byte, + password byte initial(false); /* file has password */ + + declare /* parsing */ + more byte initial(true), /* more to parse */ + ibp addr; /* input buffer ptr */ + + declare + (sav$dcnt, sav$searcha) addr, + sav$searchl byte, + dirbuf (128) byte; /* used for searches */ + + declare + cdisk byte, /* current disk */ + ver addr; /* version checking */ + + declare + error$code addr; /* for bdos returned + errors */ + declare + parse$fn structure ( + buff$adr addr, + fcb$adr addr), + last$buff$adr addr; /* used for parsing */ + + declare + err$nofile(*) byte data('Option requires a file reference',0), + + err$driveonly(*) byte data('Option only for drives.',0), + errWASSPASS(*) byte data('Assign passwords to input files.',0), + + errASSPASS(*) byte data('Assign a password to this file.',0), + errFORMAT(*) byte data( + 'Directory needs to be re-formatted for time/date stamps.',cr, + lf,' Please see INITDIR.',0), + errNOPROT(*) byte data('Protection not enabled for disk.',0), + + errUNREC(*) byte data('Unrecognized option.',0), + errNOMOD(*) byte data + ('There are no modifiers for this option.',0), + errUNRECM(*) byte data + ('Modifier missing or unrecognizable.',0), + errVALM(*) byte data + ('Not a valid modifier for this option.',0), + errOPTMOD(*) byte data('This option needs a modifier.',0), + errBIGDEF(*) byte data + ('Only first 8 characters of default password used.',0), + errBIGNAME(*) byte data + ('Only first 11 characters of label name used.',0), + errBIGPASS(*) byte data + ('Only first 8 characters of password used.',0), + errCRAC(*) byte data + ('Cannot have both create and access time stamps.',0), + errSYSDIR(*) byte data('Cannot set both sys and dir.',0), + errRORW(*) byte data('Cannot set RO and RW.',0), + errNOPT(*) byte data('No options specified.',0), + errPAGE(*) byte data('Page and nopage option selected.', + ' Nopage in effect.',0), + errGLOBAL(*) byte data + ('Cannot set local options for file.',0), + errDrvProt(*) byte data + ('Protection modifier is only ON/OFF for drives.',0), + errNBANK(*) byte data + ('Password protection is not supported in NON-BANKED SYS.',0), + errVERS(*) byte data('Requires CP/M 3 or higher.',0); + +$include (sopt.dcl) + + declare + scbpd structure( + offs byte, + set byte, + value address); + + declare + line$page byte, + line$out byte, + savefcb(16) byte, + save$dcnt address, + save$searcha address, + save$searchl address, + save$hash1 address, + save$hash2 address, + save$hash3 address, + + COMbase literally '05dh', + page$off literally '01ch', + searcha$off literally '47h', + searchl$off literally '49h', + dcnt$off literally '45h', + hash1$off literally '00h', + hash2$off literally '02h', + hash3$off literally '04h'; + + /* get the scb word */ +getscbword: procedure(off) address; + declare off byte; + + scbpd.offs = off; + scbpd.set = 0; + return mon3(49,.scbpd); + +end getscbword; + +setscb: procedure(off,value); + declare off byte, + value address; + + scbpd.offs = off; + scbpd.set = 0feh; + scbpd.value = value; + call mon1(49,.scbpd); + +end setscb; + +getpage: procedure byte; + + scbpd.offs = page$off; + scbpd.set = 0; + return mon2(49,.scbpd); + +end getpage; + +$eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * BASIC ROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + /* invalid command error */ +perror: proc; + + call print(.error$msg); + if ibp = 0 then call printx(parse$fn.buff$adr); + else call printx(last$buff$adr); + + call printx(.(' ?',0)); + call print(.invalid); + call terminate; +end perror; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* parse the next lexical item in the command line + parse$fn must filled in with input parameters */ +parser: procedure address; + declare p address; + declare c based p byte; + + p = parse(.parse$fn); + if p = 0FFFFh then call perror; + else if p <> 0 then do; + if c = '[' then optdel = true; + else if c = ']' then optdel = false; + p = p + 1; + end; + else optdel = false; + + return p; + +end parser; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +fill: proc(s,f,c); /* fill string @ s for c bytes with f */ + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +copy: proc(s,d,c); /* copy c bytes from s to d */ + dcl (s,d) addr, c byte; + dcl a based s byte, b based d byte; + + do while (c:=c-1)<>255; + b=a; s=s+1; d=d+1; + end; +end copy; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +ucase: proc byte; /* upper case character from console */ + dcl c byte; + + if (c:=conin) >= 'a' then + if c < '{' then + return(c-20h); + return c; +end ucase; + +errprint: procedure(msg); + declare msg address; + + call print(.errormsg); + call printx(msg); + call crlf; + +end errprint; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* get password and place in passwd */ +getpasswd: proc; + dcl (i,c) byte; + + call print(.('Password ? ',0)); + +retry: + call fill(.passwd,' ',8); + do i = 0 to 7; + +nxtchr: + if (c:=ucase) >= ' ' then passwd(i)=c; + else + if c = cr then go to exit; + + if c = ctrlx then goto retry; + if c = ctrlh then do; + + if i<1 then goto retry; + else do; + passwd(i:=i-1)=' '; + goto nxtchr; + end; + end; + + if c = ctrlc then call terminate; /* end of program */ + end; + +exit: + c = check$con$stat; /* clear raw I/O mode */ + +end getpasswd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print drive name */ +printdrv: procedure; + + call printchar(cdisk+'A'); + call printchar(':'); + +end printdrv; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print file name */ +printfn: procedure; + declare k byte; + + call printdrv; + + do k = 1 to fnam; + if k = ftyp then call printchar('.'); + call printchar(fcbv(k) and 7fh); + end; + +end printfn; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +bdos$error: procedure; /* error message routine */ + declare + code byte; + + call print(.error$msg); + if (code:=high(error$code)) < 3 then do; + call print(.error$msg); + call printdrv; + call printb; + + if code = 1 then call printx(.('Disk I/O',0)); + if code=2 then do; + call printx(.('Drive ',0)); + call printx(.read$only); + end; + call terminate; + end; + + if code = 3 then call printx(.read$only); + if code = 4 then call printx(.('Invalid Drive.',0)); + if code = 7 then call printx(.('Wrong Password',0)); + if code = 9 then call printx(.('? in filespec.',0)); + +end bdos$error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +set$search: procedure(dcnt); + declare dcnt byte; + + call setdma(.dirbuf); + dcnt = search$first(.('?')); + +end set$search; + + + /* get address of FCB in dirbuf */ +set$up$file: procedure(dir$index); + dcl dir$index byte; + + if dir$index <> 0ffh then do; + fcbp = shl(dir$index,5) + .dirbuf; + fcbv(0) = fcb(0); /* set drive byte */ + end; + +end set$up$file; + +getnext: procedure byte; + /* get the next fcb that matches fcb */ + + declare (dcnt,i) byte; + + xfcbcmd,sfacmd = false; + + + call setdma(.dirbuf); + + /* restore saved search parameters */ + call setscb(dcnt$off,save$dcnt); + call setscb(searcha$off,save$searcha); + call setscb(searchl$off,save$searchl); + call setscb(hash1$off,save$hash1); + call setscb(hash2$off,save$hash2); + call setscb(hash3$off,save$hash3); + call copy(.savefcb,save$searcha,16); + + if (dcnt := search$next) = 0ffh then return(false); + call set$up$file(dcnt); + return(true); + +end getnext; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* print boolean option value */ +pbool: procedure(value); + declare + value byte; + + call printx(.option$set); + if value then call printx(.('ON',0)); + else call printx(.('OFF',0)); + +end pbool; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/******************************************************* + + F I L E A T T R I B U T E S + +********************************************************/ + + + +printatt: procedure; /* print attribute set */ + + attribute: procedure(i) byte; /* test if attribute fcbv(i) is on */ + declare i byte; + + if rol(fcbv(i),1) then return true; + return false; + end attribute; + + /* display attributes: sys,ro,a,f1-f4 */ + + call printx(.set$to); + if attribute(sysfile) then call printx(.('system (SYS)',0)); + else call printx(.('directory (DIR)',0)); + + call printx(.(', ',0)); + if attribute(rofile) then do; + call printx(.read$only); + call printx(.ro); + end; + else call printx(.read$write); + + call printchar(tab); + if attribute(archiv) then call printchar('A'); + if attribute( attrb1 ) then call printchar('1'); + if attribute( attrb2 ) then call printchar('2'); + if attribute( attrb3 ) then call printchar('3'); + if attribute( attrb4 ) then call printchar('4'); + +end print$att; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* read current file attributes */ +rd$attributes: procedure; + + if not sfacmd then /* have read the FCB yet? */ + if not wild then do; + call setdma(.dirbuf); + call set$up$file(search$first(.fcb)); + end; + +end rd$attributes; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/******************************************************* + + D R I V E A T T R I B U T E S + +********************************************************/ + + +setdrvstatus: procedure(func); /* set drive attributes */ + + declare + code byte, + func byte; + + /* set the drive */ + if func = opt$ro then code = writeprot; /* read only */ + else + code = reset$drv(cdisk); /* read/write */ + + /* display */ + if code <> 0ffh then do; + call print(.('Drive ',0)); + call printdrv; + call printb; + call printx(.set$to); + if func = opt$ro then do; + call printx(.read$only); + call printx(.ro); + end; + else + call printx(.read$write); + end; + +end setdrvstatus; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/******************************************************* + + L A B E L A T T R I B U T E S + +********************************************************/ + + + /* read the directory label before + writing the label to preserve the + name, type, and stamps */ +readlabel: procedure; + dcl (mode, dcnt) byte; + +/*--------------------------------------------------------------*/ +readlbl: proc; + dcl d byte data('?'); + + call setdma(.dirbuf); + dcnt = search$first(.d); /* position to first dcnt in dir */ + do while dcnt <> 0ffh; /* read entire directory */ + /* is the user# a label = 20h */ + if dirbuf(ror(dcnt,3) and 110$0000b)=20H then return; + dcnt = search$next; + end; + +end readlbl; + +/*---------------------------------------------------------------*/ + + if lblcmd then return; + + mode = getlbl(cdisk); /* get the dir label data byte */ + password = false; + if mode > 0 then do; /* if ok then ...*/ + call readlbl; /* get label */ + fcbp = shl(dcnt,5) + .dirbuf; + fext = fext and 11110000b; /* turn off set passwd */ + if fcbv(16) <> ' ' then + if fcbv(16) <> 0 then + password = true; + end; + + else do; /* no dir label */ + fcbp = .fcb; + call copy(.label$name,.fcb(1),length(label$name)); + end; + +/* if password then call getpasswd;*/ /* does the user have the password*/ + lblcmd = true; + +end readlabel; + + +/**************************************************************************/ + + +put$file: procedure; /* display the file or xfcb */ + + call crlf; + call printfn; + call printb; + call printb; + +end put$file; + + +/******************************************************* + + S F C B A T T R I B U T E S + +********************************************************/ + + + +set$up$xfcb: procedure; /* read xfcb into xfcb buffer */ + + if not xfcbcmd then do; + xfcbcmd = true; + call copy(.fcbv,.xfcb,12); + password,passmode = 0; + + if low(errorcode := readxfcb(.xfcb)) = 0ffh then do; + if high(errorcode) <> 0 then call bdos$error; + else do; + call errprint(.not$found); + call put$file; + end; + return; + end; + + passmode = xfcb(12); + if passmode <> 0 then password = true; /* must have a pass if + mode ~= NONE */ + end; + +end set$up$xfcb; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/******************************************************* + + PASSWORD AND PASSWORD MODE ROUTINES + +********************************************************/ + + +defaultpass: procedure; + + if NONBANK then do; + call errprint(.errNBANK); + return; + end; + + call fill(.passwd(0),' ',8); + call copy(defpass,.passwd(0),lendef); + call mon1(106,.passwd); + call print(.('Default password = ',0)); + passwd(8) = 0; + call printx(.passwd); + +end defaultpass; + + +set$password: procedure; + + if fileref then do; + + if NONBANK then do; + call errprint(.errNBANK); + return; + end; + + call set$up$xfcb; + passmode = passmode or 1; /* turn on password bit */ + end; + else do; + call readlabel; + fext = fext or 1; + end; + + call fill(.passwd(8),' ',8); /* clear passwd */ + + if lenpass = 0 then do; + passmode = 1; + return; + end; + + newpass = true; + call copy(passname,.passwd(8),lenpass); /* copy it to fcb */ + +end set$password; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/******************************************************* + + LABEL ATTRIBUTE ROUTINES + +********************************************************/ + +lname: procedure; /* sets the label name */ + declare i byte, + ln based labname (1) byte; + + if drvmsg then return; + + if fileref then do; + call errprint(.err$driveonly); + drvmsg = true; + return; + end; + + call readlabel; + + call fill(.fcbv(1),' ',11); /* clear name */ + + if lenlab > 0 then do; + do i = 0 to lenlab-1; + if ln(i) = PERIOD then do; + call copy(labname,.fcbv(1),i); + call copy(labname+i+1,.fcbv(9),3); + return; + end; + end; + + call copy(labname,.fcbv(1),lenlab); /* copy label name */ + + end; + +end lname; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +set$extent: procedure(function,maskon,maskoff); + declare + function byte, + maskon byte, + maskoff byte; + + if drvmsg then return; + + if fileref then do; + drvmsg = true; + call errprint(.err$driveonly); + return; + end; + + call readlabel; + if mods$map(function) then fext = fext or maskon; /* turn stamp on */ + else fext = fext and maskoff; /* turn stamp off */ + + return; + +end set$extent; + + +protect: procedure; /* set drive protection mode */ + declare pmode byte; + + if fileref then do; + call set$up$xfcb; + pmode = mods$map(opt$prot); + + if pmode = 2 then passmode = 80h; /* read only */ + else + if pmode = 3 then passmode = 40h; /* write,read */ + else + if pmode = 4 then passmode = 20h; /* r,w,delete */ + else do ; + passmode = 1; /* turn off protection*/ + + call fill(.passwd(8),' ',8); + end; + if newpass then passmode = passmode or 1; + end; + else do; + + if NONBANK then do; + call errprint(.errNBANK); + return; + end; + + pmode = mods$map(opt$prot); + if pmode > 1 then do; + call errprint(.errDrvProt); + return; + end; + + call set$extent(opt$prot,pwmask$on,pwmask$off); + call fill(.fcbv(16),' ',8); /* erase password */ + end; + +end protect; + +/*------------------------------------------------------------*/ + + /* set attribute bits: + f1 --> f4 flags + t1 --> t3 flags or + RO + SYS + Archive */ + +setatt: procedure(func,bytes); + declare func byte, + bytes byte; + + + if sfamsg then return; /* printed msg before? */ + if not fileref then do; + sfamsg = true; + call errprint(.err$nofile); + return; + end; + + if mods$map(func) then fcbv(bytes) = fcbv(bytes) or 80h; + else fcbv(bytes) = fcbv(bytes) and 7fh; + + sfacmd = true; +end setatt; + +/******************************************************* + + S H O W L A B E L & X F C B + +********************************************************/ + + +show$passwd: procedure; /* display the new password */ + + call printx(.('Password = ',0)); + passwd(16) = 0; + call printx(.passwd(8)); + +end show$passwd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +dcl label1 (*) byte data ( +'Directory Passwds Stamp Stamp Stamp',cr,lf, +'Label Reqd Create Access Update',cr,lf, +'-------------- ------- ------- ------- -------',cr,lf,0); + +showlbl: procedure; /* show the label options */ + declare (make,access) byte; + + call print(.('Label for drive ',0)); + call printdrv; + call crlf; + call print(.label1); + call printfn; + + if (fext and 80h) = 80h then /* PASSWORDS REQUIRED */ + call printx(.on); + else + call printx(.off); + + access = (fext and 40h) = 40h; /* STAMP CREATE */ + if (fext and 10h) = 10h then + call printx(.on); + else + call printx(.off); + + if access then /* STAMP ACCESS */ + call printx(.on); + else + call printx(.off); + + if (fext and 20h) = 20h then /* STAMP UPDATE */ + call printx(.on); + else + call printx(.off); + + call crlf; + if fext then do; + call crlf; + call show$passwd; + end; + +end showlbl; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +show$xfcb: procedure; /* display xfcb attributes */ + + call printx(.('Protection = ',0)); + + if (passmode and 80h) = 80h then call printx(.readmode); + else + if (passmode and 40h) = 40h then call printx(.writemode); + else + if (passmode and 20h) = 20h then call printx(.deletemode); + else + if (not passmode) or (passwd(8) = ' ') then call printx(.nopasswd); + else + call printx(.readmode); + + if passmode then do; /* lsb on */ + call printx(.comma); + call show$passwd; + end; + +end show$xfcb; + + +/******************************************************* + + WRITE XFCB, LABEL AND FILE ATTRIBUTES + +********************************************************/ + +pass$check: procedure(which) byte; + declare which byte; + /* did we fail because of password? + if so, then get it and re-try. + which = 1 <-- put$attribute + 2 <-- write$label + 3 <-- write$xfcb */ + if high(error$code) = 7 then do; + call crlf; + if which <> 2 then call put$file; + else call print(.dirlabel); + call getpasswd; + if fileref then call crlf; + /* put attributes ? */ + if which = 1 then error$code = setind(fcbp); + else /* write label ? */ + if which = 2 then error$code = wrlbl(fcbp); + else /* update xfcb */ + error$code = wrxfcb(.xfcb); + + if high(error$code) <> 0 then do; + call bdos$error; + if which = 2 then call print(.dirlabel); + else call put$file; + return(false); + end; + end; + + return(true); + +end pass$check; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +put$attributes: procedure; /* write file attributes */ + + error$code = setind(fcbp); + + if low(error$code) = 0ffh then + if high(error$code) <> 0 then do; + if not pass$check(1) then return; + if high(error$code) <> 0 then do; + call bdos$error; + call put$file; + return; + end; + end; + else do; + call errprint(.not$found); + call put$file; + end; + + if low(error$code) <> 0ffh then + if fext <= dpb.extmsk then do; + call put$file; + call print$att; + end; + +end put$attributes; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +write$label: procedure; /* write new label */ + + error$code = wrlbl(fcbp); + + if low(error$code) = 0ffh then + if high(error$code) <> 0 then do; + if not pass$check(2) then return; + if high(error$code) <> 0 then do; + call bdos$error; + call print(.dirlabel); + return; + end; + call crlf; + end; + else do; + call errprint(.errFORMAT); + return; + end; + + call showlbl; + +end write$label; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +write$xfcb: procedure; /* write out new xfcb */ + + if passmode > 1 then do; + if password then go to wr0; + if newpass then go to wr0; + + if passmsg then return; + + if wild then + call errprint(.errWASSPASS); + else do; + call errprint(.errASSPASS); + call put$file; + end; + + passmsg = true; + return; + end; + +wr0: if passmode = 1 then + if newpass then passmode = passmode or 80h; /* read mode = def */ + + xfcbmode = passmode; + error$code = wrxfcb(.xfcb); + + if low(error$code) = 0ffh then + if high(error$code) <> 0 then do; + if not pass$check(3) then return; + if high(error$code) <> 0 then do; + call bdos$error; + call put$file; + return; + end; + end; + else do; + call errprint(.not$found); + call print(.(' or protection not enabled for disk.',0)); + return; + end; + + if passmode = 1 then do; /* delete xfcb */ +wr1: xfcb(5) = xfcb(5) or 80h; + error$code = delete(.xfcb); /* no need to check for error*/ + end; /* previous write-> failed!*/ + + + call put$file; + call show$xfcb; /* errcode is good if we are here */ + +end write$xfcb; + + + + +/******************************************************* + + C O M M A N D P R O C E S S I N G + +********************************************************/ + + + +setdisk: procedure; /* select the disk specified in cmd line */ + + if cmd(0) <> 0 then do; + cdisk = cmd(0)-1; + call select(cdisk); + call set$dpb; + end; + +end setdisk; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +wildcard: procedure byte; /* test if the file is a wildcard */ + declare + i byte; + + do i=1 to fnam; + if fcb(i) = '?' then return true; + end; + return false; +end wildcard; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +setup$fcb: procedure; /* set up the next file or drive reference */ + declare dcnt byte; + + call setdisk; + call copy(.cmd,.fcb,12); /* name */ + call copy(.cmd(16),.passwd,8); /* password */ + + if fcb(1) <> ' ' or fcb(ftyp) <> ' ' then do; + fileref = true; + call setdma(.dirbuf); + if (dcnt := search$first(.fcb)) = 0ffh then do; + fcbp = .fcb; + call errprint(.not$found); + call put$file; + call terminate; + end; + call set$up$file(dcnt); + end; + else fileref = false; + +end setup$fcb; + +$include (sopt.inc) + +parse$options: procedure; + + declare + charac based buf$ptr byte, + l byte; + + delimiter = 1; + index = 0; + mindex = 0; + +loop: + if delimiter = 0 then return; + if delimiter = RBRACKET then return; + if delimiter = ENDFF then return; + + /* get the index into list */ + if (index := opt$scanner(.options,.off$opt)) = 0 then go to error1; + + /* if we have more to parse, + check for valid modifiers */ + if (delimiter <> RBRACKET and delimiter <> ENDFF) then do; + + /* is this a mod delimiter? + test for equal sign. */ + if delimiter = EQUAL then do; + /* does option have a modifier?*/ + + if not opt$mod(index-1).modifier(0) then go to error2; + + /* is this a string modifier, ie., + password,default,name option */ + + if not opt$mod(index-1).modifier(7) then do; + + if (mindex := opt$scanner(.mods,.off$mods)) = 0 + then go to error3; + + /* invalid option-modifier pair */ + + if not opt$mod(index-1).modifier(mindex) then + go to error4; + + end; /* ends getting non-string mod */ + + else do; + /* get string */ + string$ptr = buf$ptr; + mindex = 8; + delimiter = 0; + l = 0; + do while delimiter = 0; + delimiter = separator(charac); + buf$ptr = buf$ptr + 1; + l = l + 1; + end; + + if delimiter = SPACE then do; + delimiter = separator(charac); + buf$ptr = buf$ptr + 1; + end; + + l = l - 1; + if l > 0 then do; + if (index -1) = opt$default then do; + defpass = string$ptr; + if (lendef := l) > 8 then do; + call errprint(.errBIGDEF); + lendef = 8; + end; + end; + else + if (index -1) = opt$name then do; + labname = string$ptr; + if (lenlab := l) > 11 then do; + lenlab = 11; + call errprint(.errBIGNAME); + end; + end; + else do; + passname = string$ptr; + if (lenpass := l) > 8 then do; + call errprint(.errBIGPASS); + lenpass= 8; + end; + end; + end; + end; + end; /* ends mod delimiter? */ + end; /* ends last delimiter */ + + /* option without modifier... + index must be > 0 */ + if mindex = 0 and opt$mod(index-1).modifier(0) then go to error5; + + option$map(index - 1) = true; + if mindex > 0 then mods$map(index - 1) = mindex - 1; + + go to loop; /* skip error routine */ + +error1: call errprint(.errUNREC); + go to optprt; +error2: call errprint(.errNOMOD); + go to optprt; +error3: call errprint(.errUNRECM); + go to modprt; +error4: call errprint(.errVALM); + go to modprt; +error5: call errprint(.errOPTMOD); + go to optprt; +modprt: call print(.('Modifier: ',0)); + go to errprt; +optprt: call print(.('Option: ',0)); +errprt: call error$prt; + + go to loop; + +end parse$options; + +do$options: procedure; + declare dump byte; + + if option$map(opt$archive) then + call setatt(opt$archive,archiv); + + if option$map(opt$f1) then call setatt(opt$f1,attrb1); + if option$map(opt$f2) then call setatt(opt$f2,attrb2); + if option$map(opt$f3) then call setatt(opt$f3,attrb3); + if option$map(opt$f4) then call setatt(opt$f4,attrb4); + + if option$map(opt$name) then call lname; /*Dir name*/ + if option$map(opt$pass) then call set$password; + if option$map(opt$prot) then call protect; + if option$map(opt$default) then call defaultpass; + + if option$map(opt$access) and option$map(opt$create) then do; + if mods$map(opt$access) and mods$map(opt$create) then do; + if fileref then call errprint(.err$driveonly); + call errprint(.errCRAC); + call crlf; + go to do1; + end; + end; + + if option$map(opt$access) then do; + if mods$map(opt$access) then do; /* turn off create */ + mods$map(opt$create) = 0; + call set$extent(opt$create,crmask$on,crmask$off); + end; + call set$extent(opt$access,acmask$on,acmask$off); + end; + if option$map(opt$create) then do; + if mods$map(opt$create) then do; /* turn off access */ + mods$map(opt$access) = 0; + call set$extent(opt$access,acmask$on,acmask$off); + end; + call set$extent(opt$create,crmask$on,crmask$off); + end; + + /* Note that sys and dir do NOT have + modifiers; thus the option scanner + did not fill in the modifier map, + which setatt looks at to turn things + on/off. So we have to set the mod + map here. applies to archive too */ + +do1: if option$map(opt$dir) and option$map(opt$sys) then do; + if not fileref then call errprint(.err$nofile); + call errprint(.errSYSDIR); + call crlf; + end; + else do; + if option$map(opt$dir) then + /* do not turn sys on */ + call setatt(opt$sys,sysfile); + + else if option$map(opt$sys) then do; + mods$map(opt$sys) = true; + call setatt(opt$sys,sysfile); + end; + end; + + if option$map(opt$update) then + call set$extent(opt$update,upmask$on,upmask$off); + + if option$map(opt$ro) and option$map(opt$rw) then do; + call errprint(.errRORW); + call crlf; + end; + else do; + if option$map(opt$ro) then + if fileref then do; + mods$map(opt$ro) = 1; + call setatt(opt$ro,rofile); + end; + else call setdrvstatus(opt$ro); + else + if option$map(opt$rw) then + if fileref then do; + /* turn ro off */ + mods$map(opt$ro) = 0; + call setatt(opt$ro,rofile); + end; + else call setdrvstatus(opt$rw); + end; +end do$options; + +save: procedure; + + /* save search parameters for later wild + card processing */ + + save$dcnt = getscbword(dcnt$off); + save$searcha = getscbword(searcha$off); + save$searchl = getscbword(searchl$off); + save$hash1 = getscbword(hash1$off); + save$hash2 = getscbword(hash2$off); + save$hash3 = getscbword(hash3$off); + +end save; + + +savewild: procedure; + + /* save wildcard name for later processing */ + if (wild := wildcard) then call copy(.cmd,.savefcb,12); + call setup$fcb; + +end savewild; + + +getfilename: procedure(buffadd); + declare buffadd address; + + parse$fn.buff$adr = buffadd; + last$buff$adr = buffadd; /* used by perror routine */ + parse$fn.fcb$adr = .cmd; + ibp = parser; /* parse file name */ + +end getfilename; + +getfname: procedure; + + call getfilename(bufptr); + + if optdel then do; /* no local options */ + call errprint(.errGLOBAL); + cmd(12) = 0; + call print(.('FILE: ',0)); + call printx(.cmd(1)); + call terminate; + end; + /* F152 returns ~= 0 if + another file name + follows in buffer */ + if ibp <> 0 then multi = true; + else multi = false; + + call copy(.cmd,.fcb,16); /* copy file name to + default buffer..*/ + call savewild; + +end getfname; + +$eject +/******************************************************* + + M A I N P R O G R A M + +********************************************************/ + +declare + i byte initial (1), + last$dseg$byte byte initial (0), + (vlow,vhigh) byte; + +/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ + +exec: procedure; + + + do while more; + + if wild then call save; + + call do$options; /* perform options specified */ + + call return$errors(0FFh); /* Return mode */ + + if lblcmd then /* label options */ + call write$label; + else do; + if sfacmd then /* file attributes*/ + call put$attributes; + if xfcbcmd then /* xfcb attributes*/ + call write$xfcb; + end; + + call return$errors(0); + + if not wild then more = false; + /*wild card expansion */ + else + if not getnext then more = false; + + end; + +end exec; + +/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ + +plm: + ver = get$version; + vlow = low(ver); + vhigh = high(ver); + + line$page = getpage; /* #lines per page */ + line$out = 0; + + if vlow < cpmversion then go to errver; + + user$code = getuser; + call set$dpb; /* get disk parameter blk */ + cdisk=cselect; /* get current disk */ + + do while buff(i)=' '; + i = i + 1; + end; + buf$ptr = .buff(i); + + if buff(i) = '[' then do; /* first, options */ + buf$ptr = buf$ptr + 1; + call parse$options; /* delimiter = ] or + null if end of cmd tail */ + + if delimiter = RBRACKET then call getfname; + else do; + call fill(.cmd(1),' ',26); /* blank out command line */ + cmd(0) = 0; + end; + end; + else do; /* filename ? */ + call getfilename(.buff(1)); /* will set multi */ + + if optdel then do; + buf$ptr = ibp; + call parseoptions; + end; + else do; + call errprint(.errNOPT); + call terminate; + end; + call savewild; + end; + + if option$map(opt$page) and option$map(opt$nopage) then do; + call errprint(.errPAGE); + call crlf; + PAGE = false; + end; + else if option$map(opt$nopage) then PAGE = false; + else if option$map(opt$page) then PAGE = true; + + if high(getscbword(COMbase)) = 0 then NONBANK = true; + + call exec; + do while multi; + buf$ptr = ibp; + more = true; + call getfname; + call exec; + end; + + call terminate; + +errver: call errprint(.errVERS); + call terminate; +end; + diff --git a/software/CPM/cpm3/setbuf.plm b/software/CPM/cpm3/setbuf.plm new file mode 100644 index 0000000..db69a26 --- /dev/null +++ b/software/CPM/cpm3/setbuf.plm @@ -0,0 +1,1077 @@ +$title ('GENCPM - Buffer allocation module') +setup$buffers: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 09 Dec 82 by Bruce Skidmore +*/ + + declare true literally '0FFH'; + declare false literally '0'; + declare forever literally 'while true'; + declare boolean literally 'byte'; + declare cr literally '0dh'; + declare lf literally '0ah'; + +/* + D a t a S t r u c t u r e s +*/ + + declare query boolean external; + declare quest(155) boolean external; + + declare offset byte external; + declare prgsiz address external; + declare bufsiz address external; + declare codsiz address external; + declare bios$pg byte external; + declare scb$pg byte external; + declare res$pg byte external; + declare bnk$pg byte external; + declare bnk$off byte external; + declare res$len byte external; + declare non$bnk byte external; + + declare dma address external; + declare lnbfr (14) byte external; + + declare bios$atts(3) address external; + declare res$atts(3) address external; + declare bnk$atts(3) address external; + + declare res$bios$len byte external; + declare res$base byte external; + declare pg$dif byte external; + declare xmove$implemented boolean external; + + declare mem$top byte external; + declare common$len byte external; + declare bnk$top byte external; + declare banked$len byte external; + declare sys$entry address external; + declare bnk$swt boolean external; + + declare drvtbl$adr address external; + declare drvtbl based drvtbl$adr (16) address; + + declare dph$adr address external; + declare dph based dph$adr structure ( + xlt address, + scratch1(4) address, + scratch2 byte, + mf byte, + dpb address, + csv address, + alv address, + dirbcb address, + dtabcb address, + hash address, + hbank byte); + + declare dpb$adr address external; + declare dpb based dpb$adr structure ( + spt address, + bsh byte, + blm byte, + exm byte, + dsm address, + drm address, + al0 byte, + al1 byte, + cks address, + off address, + psh byte, + phm byte); + + declare mem$tbl (17) structure( + base byte, + len byte, + bank byte, + attr address) external; + + declare num$seg byte external; + + declare record(16) structure( + size address, + attr byte, + altbnks byte, + no$dirrecs byte, + no$dtarecs byte, + ovlydir$dr byte, + ovlydta$dr byte, + dir$resp byte, + dta$resp byte) external; + + declare hash$data(16) address external; + declare hash$space address external; + declare hash(16) boolean external; + declare alloc(16) address external; + declare alloc$space address external; + declare chk(16) address external; + declare chk$space address external; + +/* + B D O S P r o c e d u r e & F u n c t i o n C a l l s +*/ + + system$reset: + procedure external; + end system$reset; + + write$console: + procedure (char) external; + declare char byte; + end write$console; + + print$console$buffer: + procedure (buffer$address) external; + declare buffer$address address; + end print$console$buffer; + + read$console$buffer: + procedure (buffer$address) external; + declare buffer$address address; + declare buf based buffer$address (1) byte; + end read$console$buffer; + +/* + L o c a l P r o c e d u r e s +*/ + + shift$left: + procedure (pattern, count) address external; + declare count byte; + declare pattern address; + end shift$left; + + crlf: + procedure external; + end crlf; + +error: + procedure (term$code,err$type,err$msg$adr) external; + declare (term$code,err$type) byte; + declare err$msg$adr address; + end error; + +upper: + procedure (b) byte external; + declare b byte; + end upper; + +valid$drive: + procedure(drv) boolean external; + declare drv byte; + end valid$drive; + +get$response: + procedure (val$adr) external; + declare val$adr address; + end get$response; + +dsply$hex$adr: + procedure (val) external; + declare val address; + end dsply$hex$adr; + +get$param: + procedure (string$adr,val$adr,pbase) external; + declare (string$adr,val$adr) address; + declare pbase byte; + end get$param; + +get$seg: + procedure(type,record$size) byte external; + declare type byte; + declare record$size address; + end get$seg; + +setbuf: + procedure public; + declare (i,j,k,ii,save,data$cnt,temp) byte; + declare (first$dir,first$dta,first$drive,other$banks) boolean; + declare (ok,perm$media,printed) boolean; + declare (link$cnt,seg$no,dir$data$field) byte; + declare mem$sav$tbl(17) address; + declare sav$mem$len (17) byte; + declare (rec$siz,drives,save$dph$adr,save$bcb$adr) address; + declare (bcb$cnt,bcb$buf$siz,buff$space) address; + declare (data$adr,l$buf$adr,act$buf$adr,l$head$adr) address; + declare (max$dir$buf,max$attr,tpa,defined$drives) address; + declare l$head based l$head$adr address; + + declare bcb$len byte; + declare bcb$buf$cnt address; + declare bcb$buf$ptr byte; + + declare bcb$adr address; + declare bcb based bcb$adr structure( + drv byte, + rec$no(3) byte, + wflag byte, + seq$no byte, + track address, + sector address, + buff$adr address, + bank byte, + link address); + + declare psect (16) structure( + size address, + drives address); + + disp$space: + procedure; + declare (seg0,obanks) address; + declare ii byte; + + seg0, obanks = 0; + do ii = 1 to num$seg; + if mem$tbl(ii).bank = 0 then + seg0 = seg0 + shr(mem$tbl(ii).attr,8); + else + obanks = obanks + shr(mem$tbl(ii).attr,8); + end; + call print$console$buffer(.(lf,cr,' ', + 'Available space in 256 byte pages:', + lf,cr,' ','$')); + + call print$console$buffer(.('TPA =$')); + call dsply$hex$adr(shr(tpa,8)); + if bnk$swt then + do; + call print$console$buffer(.(', Bank 0 =$')); + call dsply$hex$adr(seg0); + if xmove$implemented then + do; + call print$console$buffer(.(', Other banks =$')); + call dsply$hex$adr(obanks); + end; + if (obanks <> 0) or (seg0 <> 0) then + other$banks = true; + else + other$banks = false; + end; + call crlf; + call crlf; + end disp$space; + + get$space: + procedure(index,parm) byte; + declare (index,parm,count,ii) byte; + declare (i,j,k,save) byte; + declare seg$no byte; + declare rsize address; + + rsize = record(index).size; + if not bnk$swt then + do; + tpa = tpa - (rsize + bcb$len); + end; + else + do; + bcb$buf$ptr = bcb$buf$ptr - 2; + if parm = 1 then /* directory records */ + do; + count = record(index).no$dirrecs; + do ii = 1 to count; + if bcb$buf$ptr < bcb$len then + do; + bcb$buf$ptr = 0ffh; + bcb$buf$cnt = bcb$buf$cnt + 1; + j = 0ffh; + save = 0; + do i = 1 to num$seg; + k = mem$tbl(i).len + mem$tbl(i).base; + if (mem$tbl(i).bank = 0) and k > save then + do; + j = i; + save = k; /* pre allocate space for BCBs */ + end; + end; + mem$tbl(j).attr = mem$tbl(j).attr - 100h; + end; + else + bcb$buf$ptr = bcb$buf$ptr - bcb$len; + + if (seg$no := get$seg(1,rsize)) = 0ffh then + do; + call error(false,0, + .('Unable to allocate Dir deblocking ', + 'buffer space.$')); + return false; + end; + else + mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - rsize; + end; + end; + else /* data records */ + do; + count = record(index).no$dtarecs; + do ii = 1 to count; + if bcb$buf$ptr < bcb$len then + do; + bcb$buf$ptr = 0ffh; + bcb$buf$cnt = bcb$buf$cnt + 1; + j = 0ffh; + save = 0; + do i = 1 to num$seg; + k = mem$tbl(i).len + mem$tbl(i).base; + if (mem$tbl(i).bank = 0) and k > save then + do; + j = i; + save = k; /* pre allocate space for BCBs */ + end; + end; + mem$tbl(j).attr = mem$tbl(j).attr - 100h; + end; + else + bcb$buf$ptr = bcb$buf$ptr - bcb$len; + if not record(index).altbnks then + do; + tpa = tpa - rsize; + if shr(tpa,8) < bnk$top then + do; + call error(false,0, + .('Unable to allocate Data ', + 'deblocking buffer space.$')); + return false; + end; + end; + else + do; + if (seg$no := get$seg(2,rsize)) = 0ffh then + do; + call error(false,0, + .('Unable to allocate Data deblocking ', + 'buffer space.$')); + return false; + end; + else + mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - rsize; + end; + end; + end; + end; + return true; + end get$space; + + drive$not$defined: + procedure(val) boolean; + declare val byte; + if (defined$drives and shift$left(double(1),val)) <> 0 then + return false; + call error(false,0,.('Drive specified has not ', + 'been defined. $')); + return true; + end drive$not$defined; + + do i = 0 to 15; + if drvtbl(i) <> 0 then + do; + dph$adr = drvtbl(i) + .memory; + if (dph.dirbcb = 0fffeh) or (dph.dtabcb = 0fffeh) then + do; + dpb$adr = dph.dpb + .memory; + record(i).size = shift$left(double(128),dpb.psh); + record(i).attr = 0; + end; + if dph.dirbcb = 0ffffh then + do; + call error(true,0,.('0FFFFH is an invalid value in the', + cr,lf, + 'DPH directory BCB address field.$')); + + end; + end; + end; + + do j = 0 to 15; + rec$siz = 0; + do i = 0 to 15; + if (record(i).size > rec$siz) and (record(i).attr = 0) then + rec$siz = record(i).size; + end; + psect(j).size = rec$siz; + psect(j).drives = 0; + do i = 0 to 15; + if (record(i).size = rec$siz) and (rec$siz <> 0) then + do; + psect(j).drives = psect(j).drives or shift$left(double(1),i); + record(i).attr = 0ffh; + end; + end; + end; + + + do i = 0 to 16; + mem$sav$tbl(i) = mem$tbl(i).attr; + sav$mem$len(i) = mem$tbl(i).len; + end; + + + if bnk$swt then + bcb$len = 15; + else + bcb$len = 12; + + ok = false; + do while not ok; + + bcb$buf$ptr = bcb$len - 1; + bcb$buf$cnt = 0; + defined$drives = 0; + data$cnt = 0; + first$drive = true; + tpa = shl(double(res$pg),8) - hash$space; + if not bnk$swt then + tpa = tpa - alloc$space - chk$space; + + do i = 0 to 15; + mem$tbl(i+1).attr = mem$sav$tbl(i+1); + record(i).attr = 0; + end; + + printed = false; + first$dir, first$dta = true; + + ii = 0; + drives = psect(ii).drives; + do while (psect(ii).size <> 0) and (ii < 16); + + if not printed then + do; + call print$console$buffer(.(lf,cr,'Setting up ', + 'Blocking/Deblocking buffers:', + lf,cr,'$')); + printed = true; + end; + + call print$console$buffer( + .(cr,lf,'The physical record size is$')); + call dsply$hex$adr(psect(ii).size); + call print$console$buffer(.(':',lf,cr,'$')); + + i = 0; + do while((drives and 1) <> 1) and (i < 16); + drives = shr(drives,1); + i = i + 1; + end; + drives = shr(drives,1); + do while (i <> 16); + dph$adr = drvtbl(i) + .memory; + dpb$adr = dph.dpb + .memory; + max$dir$buf = shr(dpb.drm + 4,2); + if (dpb.cks = 08000h) then + perm$media = true; + else + perm$media = false; + if dph.dirbcb = 0fffeh then + do; + call disp$space; + record(i).attr = record(i).attr or 1; + if not bnk$swt then + do; + if first$dir then + do; + first$dir = false; + record(i).no$dirrecs = 1; + call print$console$buffer( + .(' ', + '*** Directory buffer required ***', + cr,lf,' ', + '*** and allocated for drive $')); + call write$console('A'+i); + call print$console$buffer(.(': ***',cr,lf,'$')); + end; + else + do; + query = quest(123 + i); + call print$console$buffer( + .(' ', + 'Overlay Directory buffer for drive $')); + call write$console('A'+i); + call print$console$buffer(.(': $')); + call get$response(.record(i).dir$resp); + call crlf; + if not record(i).dir$resp then + do; + record(i).no$dirrecs = 1; + end; + else + record(i).no$dirrecs = 0; + end; + end; + else + do; + query = quest(59 + i); + call print$console$buffer( + .(' ', + 'Number of directory buffers for drive $')); + call write$console('A'+i); + call get$param(.(': $'),.record(i).no$dirrecs,10); + if first$dir then + do; + first$dir = false; + do while (record(i).no$dirrecs = 0); + call error(false,0, + .('Minumum number of buffers is 1. $')); + call print$console$buffer( + .(' ', + 'Number of directory buffers for drive $')); + call write$console('A'+i); + call get$param(.(': $'),.record(i).no$dirrecs,10); + end; + end; + end; + + if record(i).no$dirrecs > max$dir$buf then + do; + call print$console$buffer( + .(cr,lf,'*** Maximum number of directory buffers ***', + cr,lf,'*** for the current drive is$')); + call dsply$hex$adr(max$dir$buf); + call print$console$buffer(.('. ***', + cr,lf,'*** Number of directory buffers reduced ***', + cr,lf,'*** accordingly. ***', + cr,lf,'$')); + record(i).no$dirrecs = max$dir$buf; + end; + + if record(i).no$dirrecs = 0 then + do; + query = quest(91 + i); + err4: + call print$console$buffer( + .(' ', + 'Share buffer(s) with which drive ($')); + call write$console('A'+record(i).ovlydir$dr); + call print$console$buffer(.(':) ? $')); + call read$console$buffer(.lnbfr); + if lnbfr(1) <> 0 then + do; + temp = upper(lnbfr(2))-'A'; + if not valid$drive(temp) then + goto err4; + if drive$not$defined(temp) then + goto err4; + record(i).ovlydir$dr = temp; + end; + call crlf; + end; + else + if (get$space(i,1) = 0) then + goto notok; + end; + + if (dph.dtabcb = 0fffeh) then + do; + dir$data$field = 0; + if record(i).size = 80h then + do; + dph.dtabcb = 0ffffh; + record(i).no$dtarecs = 0; + end; + else + do; + call disp$space; + record(i).attr = record(i).attr or 2; + if not bnk$swt then + do; + if data$cnt <> 2 then + do; + if not perm$media then + do; + data$cnt = 2; + dir$data$field = 0ffh; + record(i).no$dtarecs = 1; + call print$console$buffer( + .(' ', + '*** Data buffer required and ***', + cr,lf,' ', + '*** allocated for drive $')); + call write$console('A'+i); + call print$console$buffer(.(': ***',cr,lf,'$')); + end; + else + do; + if first$dta then + dir$data$field = 10h; + end; + end; + + first$dta = false; + if dir$data$field <> 0ffh then + do; + query = quest(139 + i); + call print$console$buffer( + .(' ', + 'Overlay Data buffer for drive $')); + call write$console('A'+i); + call print$console$buffer(.(': $')); + call get$response(.record(i).dta$resp); + call crlf; + if record(i).dta$resp then /* Y */ + record(i).no$dtarecs = 0; + else + do; + record(i).no$dtarecs = 1; + data$cnt = 2; + end; + end; + end; + else + do; + query = quest(75 + i); + call print$console$buffer( + .(' ', + 'Number of data buffers for drive $')); + call write$console('A'+i); + call get$param(.(': $'),.record(i).no$dtarecs,10); + record(i).attr = record(i).attr or 2; + if first$dta then + do; + first$dta = false; + do while (record(i).no$dtarecs = 0); + call error(false,0, + .('Minumum number of buffers is 1. $')); + call print$console$buffer( + .(' ', + 'Number of data buffers for drive $')); + call write$console('A'+i); + call get$param(.(': $'),.record(i).no$dtarecs,10); + end; + end; + end; + + if record(i).no$dtarecs = 0 then + do; + if first$drive then + do; + first$drive = false; + record(i).ovlydta$dr = i; + end; + else + do; + query = quest(107 + i); + err5: + call print$console$buffer( + .(' ', + 'Share buffer(s) with which drive ($')); + call write$console('A'+record(i).ovlydta$dr); + call print$console$buffer(.(':) ? $')); + call read$console$buffer(.lnbfr); + if lnbfr(1) <> 0 then + do; + temp = upper(lnbfr(2))-'A'; + if not valid$drive(temp) then + goto err5; + if drive$not$defined(temp) then + goto err5; + record(i).ovlydta$dr = temp; + end; + call crlf; + end; + record(i).ovlydta$dr = record(i).ovlydta$dr + or dir$data$field; + end; + else + do; + if (other$banks and xmove$implemented) then + do; + query = quest(43 + i); + call print$console$buffer( + .(' ', + 'Allocate buffers outside of Common $')); + call get$response(.record(i).altbnks); + call crlf; + end; + if (get$space(i,2) = 0) then + goto notok; + end; + end; + end; + first$drive = false; + defined$drives = defined$drives or shift$left(double(1),i); + i = i + 1; + do while((drives and 1) <> 1) and (i < 16); + drives = shr(drives,1); + i = i + 1; + end; + drives = shr(drives,1); + end; + ii = ii + 1; + drives = psect(ii).drives; + end; + + query = false; + ok = true; + if printed then + do; + call disp$space; + call print$console$buffer(. + (cr,lf,'Accept new buffer definitions $')); + call get$response(.ok); + call crlf; + end; + + notok: /*** start over here upon error ***/ + end; /*** do while not ok ***/ + + /* calculate BCB requirements */ + + bcb$cnt,link$cnt,buff$space = 0; + do i = 0 to 15; + if record(i).attr <> 0 then + do; + if (record(i).no$dirrecs <> 0) and + ((record(i).attr and 1) = 1) then + do; + if bnk$swt then + link$cnt = link$cnt + 1; + else + buff$space = buff$space + + (record(i).size * record(i).no$dirrecs); + bcb$cnt = bcb$cnt + record(i).no$dirrecs; + end; + if (record(i).no$dtarecs <> 0) and + ((record(i).attr and 2) = 2) then + do; + if bnk$swt then + do; + link$cnt = link$cnt + 1; + if not record(i).altbnks then + buff$space = buff$space + record(i).size + * record(i).no$dtarecs; + end; + else + buff$space = buff$space + + (record(i).size * record(i).no$dtarecs); + bcb$cnt = bcb$cnt + record(i).no$dtarecs; + end; + end; + end; + bcb$buf$siz = bcb$cnt * bcb$len + link$cnt * 2; + + /*** allocate deblocking buffers ***/ + + if not bnk$swt then /* for non-banked system */ + do; + bcb$adr = bios$atts(0) + .memory; + pg$dif = bios$pg - (mem$top - high(bios$atts(0) + bcb$buf$siz + + buff$space + hash$space + + chk$space + alloc$space + 255)); + bios$pg = bios$pg - pg$dif; + res$pg = res$pg - pg$dif; + scb$pg = scb$pg - pg$dif; + res$bios$len = high(bios$atts(0) + bcb$buf$siz + 255); + mem$top = bios$pg + res$bios$len; + dma = bios$atts(0) + bcb$buf$siz + .memory; + act$buf$adr = shl(double(bios$pg),8) + bios$atts(0); + data$adr = act$buf$adr + bcb$buf$siz; + + /*** zero memory for the BCB buffers ***/ + + max$attr = prgsiz; + do while(.memory(max$attr) < dma); + memory(max$attr) = 0; + max$attr = max$attr + 1; + end; + + ii = 0; + drives = psect(ii).drives; + do while (psect(ii).size <> 0) and (ii < 16); + i = 0; + do while((drives and 1) <> 1) and (i < 16); + drives = shr(drives,1); + i = i + 1; + end; + drives = shr(drives,1); + do while(i <> 16); + dph$adr = drvtbl(i) + .memory; + if (record(i).attr and 1) = 1 then + do; + if record(i).no$dirrecs <> 0 then + do; + bcb.drv = 0ffh; + bcb.buff$adr = data$adr; + data$adr = data$adr + record(i).size; + dph.dirbcb = act$buf$adr; + act$buf$adr = act$buf$adr + bcb$len; + bcb$adr = bcb$adr + bcb$len; + end; + else + do; + save$dph$adr = dph$adr; + dph$adr = drvtbl(record(i).ovlydir$dr) + .memory; + save$bcb$adr = dph.dirbcb; + dph$adr = save$dph$adr; + dph.dirbcb = save$bcb$adr; + end; + end; + + if (record(i).attr and 2) = 2 then + do; + if record(i).no$dtarecs <> 0 then + do; + bcb.drv = 0ffh; + bcb.buff$adr = data$adr; + data$adr = data$adr + record(i).size; + dph.dtabcb = act$buf$adr; + act$buf$adr = act$buf$adr + bcb$len; + bcb$adr = bcb$adr + bcb$len; + end; + else + do; + save$dph$adr = dph$adr; + dph$adr = drvtbl((record(i).ovlydta$dr) and 0fh) + .memory; + if (record(i).ovlydta$dr and 10h) <> 0 then + save$bcb$adr = dph.dirbcb; + else + save$bcb$adr = dph.dtabcb; + dph$adr = save$dph$adr; + dph.dtabcb = save$bcb$adr; + end; + end; + i = i + 1; + do while((drives and 1) <> 1) and (i < 16); + drives = shr(drives,1); + i = i + 1; + end; + drives = shr(drives,1); + end; + ii = ii + 1; + drives = psect(ii).drives; + end; + + do i = 0 to 15; /* allocate hash for non-bank system */ + if hash$data(i) <> 0 then + do; + dph$adr = drvtbl(i) + .memory; + dph.hash = data$adr; + data$adr = data$adr + hash$data(i); + end; + end; + + do i = 0 to 15; /* allocate allocation vectors and */ + /* checksub vectors for non-bank system */ + dph$adr = drvtbl(i) + .memory; + if alloc(i) <> 0 then + do; + dph.alv = data$adr; + data$adr = data$adr + alloc(i); + end; + if chk(i) <> 0 then + do; + dph.csv = data$adr; + data$adr = data$adr + chk(i); + end; + end; + + end; + else /* allocate deblocking buffers for banked system */ + do; + /* restore memory table */ + do i = 0 to 16; + mem$tbl(i).attr = mem$sav$tbl(i); + end; + + bcb$buf$siz = bcb$buf$siz + chk$space + alloc$space; + if (bios$atts(2) = 0) or (bios$atts(0) = bios$atts(2)) then + pg$dif = bios$pg - (mem$top - high(bios$atts(0) + buff$space + 255)); + else + pg$dif = bios$pg - (mem$top - high(bios$atts(2) + buff$space + 255)); + bios$pg = bios$pg - pg$dif; + res$pg = res$pg - pg$dif; + scb$pg = scb$pg - pg$dif; + mem$top = mem$top - pg$dif; + max$attr = bios$atts(0) - (bios$atts(2) + low(256-low(bios$atts(2)))); + if (bios$atts(2) = 0) or (bios$atts(0) = bios$atts(2)) then + do; + bnk$off = bnk$top - high(bcb$buf$siz + 255); + l$head$adr = bios$atts(0) + low(256-low(bios$atts(0))) + .memory; + l$buf$adr = shl(double(bnk$off),8); + data$adr = shl(double(bios$pg),8) + bios$atts(0); + end; + else + do; + bnk$off = bnk$top - high(max$attr + bcb$buf$siz + 255); + l$head$adr = bios$atts(0) + .memory; + l$buf$adr = shl(double(bnk$off),8) + max$attr; + data$adr = shl(double(bios$pg),8) + bios$atts(2); + end; + dma = l$head$adr + bcb$buf$siz; + bnk$pg = bnk$off - high(bnk$atts(0) + 255); + bcb$adr = l$head$adr + link$cnt * 2; + act$buf$adr = l$buf$adr + link$cnt * 2; + bios$atts(0) = dma - .memory; + + /*** zero memory for the BCB buffers ***/ + + max$attr = prgsiz; + do while(.memory(max$attr) < dma); + memory(max$attr) = 0; + max$attr = max$attr + 1; + end; + + /*** allocate memory table space for BCB's ***/ + j = 0ffh; + save = 0; + do i = 1 to num$seg; + k = mem$tbl(i).len + mem$tbl(i).base; + if (mem$tbl(i).bank = 0) and (k > save) then + do; + j = i; + save = k; + end; + end; + mem$tbl(0).base = bnk$pg; + mem$tbl(0).len = bnk$top - bnk$pg; + if j <> 0ffh then + do; + if (mem$tbl(j).len + mem$tbl(j).base) > bnk$pg then + do; + max$attr = shl(double(mem$tbl(j).len),8) - mem$tbl(j).attr; + mem$tbl(j).len = bnk$pg - mem$tbl(j).base; + mem$tbl(j).attr = shl(double(mem$tbl(j).len),8) - max$attr; + end; + end; + + /*** allocate directory buffers for banked system ***/ + + ii = 0; + drives = psect(ii).drives; + do while (psect(ii).size <> 0) and (ii < 16); + i = 0; + do while((drives and 1) <> 1) and (i < 16); + drives = shr(drives,1); + i = i + 1; + end; + drives = shr(drives,1); + do while (i <> 16); + dph$adr = drvtbl(i) + .memory; + if (record(i).attr and 1) = 1 then + do; + if record(i).no$dirrecs = 0 then + do; + save$dph$adr = dph$adr; + dph$adr = drvtbl(record(i).ovlydir$dr) + .memory; + save$bcb$adr = dph.dirbcb; + dph$adr = save$dph$adr; + dph.dirbcb = save$bcb$adr; + end; + else + do; + l$head = act$buf$adr; /*** set up list head ***/ + dph.dirbcb = l$buf$adr; + l$buf$adr = l$buf$adr + 2; + l$head$adr = l$head$adr + 2; + /*** create bcbs ***/ + do j = 1 to record(i).no$dirrecs; + seg$no = get$seg(1,record(i).size); + bcb.drv = 0ffh; + bcb.buff$adr = shl(double(mem$tbl(seg$no).base),8) + + (shl(double(mem$tbl(seg$no).len),8) - + mem$tbl(seg$no).attr); + bcb.bank = 0; + mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - + record(i).size; + act$buf$adr = act$buf$adr + bcb$len; + bcb.link = act$buf$adr; + bcb$adr = bcb$adr + bcb$len; + end; + bcb$adr = bcb$adr - bcb$len; + bcb.link = 0; + bcb$adr = bcb$adr + bcb$len; + end; + end; + + /*** allocate data deblocking buffers for banked system ***/ + + if (record(i).attr and 2) = 2 then + do; + if record(i).no$dtarecs = 0 then + do; + save$dph$adr = dph$adr; + dph$adr = drvtbl(record(i).ovlydta$dr) + .memory; + save$bcb$adr = dph.dtabcb; + dph$adr = save$dph$adr; + dph.dtabcb = save$bcb$adr; + end; + else + do; + l$head = act$buf$adr; /*** set up list head ***/ + dph.dtabcb = l$buf$adr; + l$buf$adr = l$buf$adr + 2; + l$head$adr = l$head$adr + 2; + /*** create bcbs ***/ + do j = 1 to record(i).no$dtarecs; + if record(i).altbnks then + do; + seg$no = get$seg(2,record(i).size); + bcb.drv = 0ffh; + bcb.buff$adr = shl(double(mem$tbl(seg$no).base),8) + + (shl(double(mem$tbl(seg$no).len),8) + - mem$tbl(seg$no).attr); + bcb.bank = mem$tbl(seg$no).bank; + mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - + record(i).size; + end; + else + do; + bcb.drv = 0ffh; + bcb.buff$adr = data$adr; + data$adr = data$adr + record(i).size; + bcb.bank = 0; + end; + act$buf$adr = act$buf$adr + bcb$len; + bcb.link = act$buf$adr; + bcb$adr = bcb$adr + bcb$len; + end; + bcb$adr = bcb$adr - bcb$len; + bcb.link = 0; + bcb$adr = bcb$adr + bcb$len; + end; + end; + i = i + 1; + do while((drives and 1) <> 1) and (i < 16); + drives = shr(drives,1); + i = i + 1; + end; + drives = shr(drives,1); + end; + ii = ii + 1; + drives = psect(ii).drives; + end; + + do i = 0 to 16; + mem$tbl(i).len = sav$mem$len(i); + end; + + do i = 0 to 15; /* allocate allocation vectors and */ + /* checksum vectors for banked system */ + dph$adr = drvtbl(i) + .memory; + if alloc(i) <> 0 then + do; + dph.alv = act$buf$adr; + act$buf$adr = act$buf$adr + alloc(i); + end; + if chk(i) <> 0 then + do; + dph.csv = act$buf$adr; + act$buf$adr = act$buf$adr + chk(i); + end; + end; + + end; + + end setbuf; +end setup$buffers; diff --git a/software/CPM/cpm3/setdef.plm b/software/CPM/cpm3/setdef.plm new file mode 100644 index 0000000..d6d1247 --- /dev/null +++ b/software/CPM/cpm3/setdef.plm @@ -0,0 +1,907 @@ +$ TITLE('CP/M 3.0 --- SETDEF') +setdef: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* +Written: 27 July 82 by John Knight +Modified: 30 Sept 82 by Doug Huskey +Modified: 03 Dec 82 by Bruce Skidmore +Modified: 18 May 1998 by John Elliott +Modified: 18 Sep 1998 by John Elliott +*/ + +/******************************************** +* * +* LITERALS AND GLOBAL VARIABLES * +* * +********************************************/ + +declare + true literally '1', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + tab literally '9', + lf literally '10', + ctrlc literally '3', + ctrlx literally '18h', + bksp literally '8', + date$flag$offset literally '0ch', /* [JCE] Date in UK order? */ + con$width$offset literally '1ah', + drive0$offset literally '4ch', + drive1$offset literally '4dh', + drive2$offset literally '4eh', + drive3$offset literally '4fh', + temp$drive$offset literally '50h', + ccp$flag1$offset literally '17h', + ccp$flag2$offset literally '18h', + pg$mode$offset literally '2ch', + pg$def$offset literally '2dh', + cpmversion literally '30h'; + + declare drive$table (4) byte; + declare order$table (2) byte initial(0); + declare drive (4) byte; + declare temp$drive byte; + declare date$flag byte; /* [JCE] Date in UK form? */ + declare ccp$flag1 byte; + declare ccp$flag2 byte; + declare con$width byte; + declare i byte; + declare begin$buffer address; + declare buf$length byte; + + /* display control variables */ + declare show$drive byte initial(true); + declare show$order byte initial(true); + declare show$temp byte initial(true); + declare show$page byte initial(true); + declare show$display byte initial(true); + declare show$date byte initial(true); /* [JCE] */ + + declare scbpd structure + (offset byte, + set byte, + value address); + + /* scanner variables and data */ + declare + options(*) byte data + ('TEMPORARY~ORDER~PAGE~DISPLAY~NO~COM~SUB~NOPAGE~NODISPLAY', + '~ON~OFF~UK~US~YMD',0ffh), /* [JCE] added US / UK / YMD */ + + options$offset(*) byte data + (0,10,16,21,29,32,36,40,47,57,60,64,67,70), + + drives(*) byte data + ('*~A:~B:~C:~D:~E:~F:~G:~H:~I:~J:~K:~', + 'L:~M:~N:~O:~P:',0ffh), + + drives$offset(*) byte data + (0,2,5,8,11,14,17,20,23,26,29,32, + 35,38,41,44,47,49), + + end$list byte data (0ffh), + + delimiters(*) byte data (0,'[]=, ./;()',0,0ffh), + + SPACE byte data(5), + j byte initial(0), + buf$ptr address, + index byte, + endbuf byte, + delimiter byte; + + declare end$of$string byte initial ('~'); + + declare plm label public; + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + printchar: + procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + + print$buf: + procedure (buffer$address); + declare buffer$address address; + call mon1 (9,buffer$address); + end print$buf; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + getscbbyte: procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); + end getscbbyte; + + setscbbyte: + procedure (offset,value); + declare offset byte; + declare value byte; + scbpd.offset = offset; + scbpd.set = 0ffh; + scbpd.value = double(value); + call mon1(49,.scbpd); + end setscbbyte; + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr,idx$ptr); + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + idx$ptr address, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index based idx$ptr byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + /* No skip for SETPATH */ + do while ((delimiter < 1) or (delimiter > 11)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while ((delimiter := separator(charac)) = SPACE); + buf$ptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return; + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return; + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then + buf$ptr = buf$ptr + 1; + else + delimiter = 5; + return; + +end opt$scanner; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* The error processor. This routine prints the command line + with a carot '^' under the offending delimiter, or sub-string. + The code passed to the routine determines the error message + to be printed beneath the command string. */ + +error: procedure (code); + declare (code,i,j,nlines,rem) byte; + declare (string$ptr,tstring$ptr) address; + declare chr1 based string$ptr byte; + declare chr2 based tstring$ptr byte; + declare carot$flag byte; + +print$command: procedure (size); + declare size byte; + do j=1 to size; /* print command string */ + call printchar(chr1); + string$ptr = string$ptr + 1; + end; + call crlf; + do j=1 to size; /* print carot if applicable */ + if .chr2 = buf$ptr then do; + carot$flag = true; + call printchar('^'); + end; + else + call printchar(' '); + tstring$ptr = tstring$ptr + 1; + end; + call crlf; +end print$command; + + carot$flag = false; + string$ptr,tstring$ptr = begin$buffer; + con$width = getscbbyte(con$width$offset); + if con$width < 40 then con$width = 40; + nlines = buf$length / con$width; /* num lines to print */ + rem = buf$length mod con$width; /* num extra chars to print */ + if ((code = 1) or (code = 5)) then /* adjust carot pointer */ + buf$ptr = buf$ptr - 1; /* for delimiter errors */ + else + buf$ptr = buf$ptr - endbuf - 1; /* all other errors */ + call crlf; + do i=1 to nlines; + tstring$ptr = string$ptr; + call print$command(con$width); + end; + call print$command(rem); + if carot$flag then + call print$buf(.('Error at the ''^''; $')); + else + call print$buf(.('Error at end of line; $')); + if con$width < 65 then + call crlf; + do case code; + call print$buf(.('More than four drives specified$')); + call print$buf(.('Invalid delimiter$')); + call print$buf(.('Invalid drive$')); + call print$buf(.('Invalid type for ORDER option$')); + call print$buf(.('Invalid option$')); + call print$buf(.('End of line expected$')); + call print$buf(.('Drive defined twice in search path$')); + call print$buf(.('Invalid ORDER specification$')); + call print$buf(.('Must be ON or OFF$')); + end; + call crlf; + call mon1(0,0); +end error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This is the main screen display for SETPATH. After every + successful operation, this procedure will be called to + show the results. This routine is also called whenever the + user just types SETPATH with no options. */ + +display$path: procedure; + declare i byte; + declare (display$flag,pg$mode,order,date) byte; /* [JCE] Date */ + + /* GET SETTINGS FROM SYSTEM CONTROL BLOCK */ + drive(0) = getscbbyte(drive0$offset); + drive(1) = getscbbyte(drive1$offset); + drive(2) = getscbbyte(drive2$offset); + drive(3) = getscbbyte(drive3$offset); + temp$drive = getscbbyte(temp$drive$offset); + pg$mode = getscbbyte(pg$mode$offset); + ccp$flag2 = getscbbyte(ccp$flag2$offset); + date$flag = getscbbyte(date$flag$offset); + display$flag = ccp$flag2 and 00$000$011b; + order = shr((ccp$flag2 and 00$011$000b),3); + date = (date$flag and 3); + + /* 0 = COM, 1 = COM,SUB, 2 = SUB,COM */ + + /* DRIVE SEARCH PATH */ + if show$drive then do; + call crlf; + call print$buf(.('Drive Search Path:',cr,lf,'$')); + i = 0; + do while ((drive(i) <> 0ffh) and (i < 4)); + call printchar(i + '1'); + do case i; + call print$buf(.('st$')); + call print$buf(.('nd$')); + call print$buf(.('rd$')); + call print$buf(.('th$')); + end; + call print$buf(.(' Drive - $')); + if drive(i) = 0 then + call print$buf(.('Default$')); + else do; + call printchar(drive(i) + 40h); + call printchar(':'); + end; + call crlf; + i = i + 1; + end; + end; + + /* PROGRAM vs. SUBMIT SEARCH ORDER */ + if show$order then do; + call crlf; + call print$buf(.('Search Order - $')); + do case order; + call print$buf(.('COM$')); + call print$buf(.('COM, SUB$')); + call print$buf(.('SUB, COM$')); + end; + end; + + /* TEMPORARY FILE DRIVE */ + if show$temp then do; + call crlf; + call print$buf(.('Temporary Drive - $')); + if temp$drive > 16 + then temp$drive = 0; + if temp$drive = 0 then + call print$buf(.('Default$')); + else do; + call printchar(temp$drive + 40h); + call printchar(':'); + end; + end; + + /* CONSOLE PAGE MODE */ + if show$page then do; + call crlf; + call print$buf(.('Console Page Mode - $')); + if pg$mode = 0 then + call print$buf(.('On$')); + else + call print$buf(.('Off$')); + end; + + /* PROGRAM NAME & DRIVE DISPLAY */ + if show$display then do; + call crlf; + call print$buf(.('Program Name Display - $')); + if display$flag = 0 then + call print$buf(.('Off$')); + else + call print$buf(.('On$')); + end; + + /* [JCE] TIME FORMAT DISPLAY */ + if show$date then do; + call crlf; + call print$buf(.('Date format used - $')); + if date = 0 then + call print$buf(.('US$')); + else if date = 1 then + call print$buf(.('UK$')); + else + call print$buf(.('YMD$')); /* [JCE 18-9-1998] */ + end; + +call crlf; +end display$path; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine processes the search drives string. When called + this routine scans the command line expecting a drive name, a:-p:. + It puts the drive code in a drive table and continues the scan + collecting drives until more than 4 drives are specified (an error) + or an eoln or the delimiter '[' is encountered. Next it modifies + the SCB searchchain bytes so that it reflects the drive order as + inputed. No check is made to insure that the drive specified is + a known drive to the particular system being used. */ + +process$drives: procedure; + declare (i,ct) byte; + show$drive = true; + index = 0; + delimiter = 0; + do i=0 to 3; /* clear drive table */ + drive$table(i) = 0ffh; + end; + ct = 0; + do while ((delimiter <> 1) and (delimiter <> 11)); /* not eoln */ + call opt$scanner(.drives(0),.drives$offset(0),.index); + if ct > 3 then /* too many drives */ + call error(0); + if index = 0 then /* invalid drive */ + call error(2); + do i=0 to 3; + if drive$table(i) = (index-1) then + call error(6); /* Drive already defined */ + end; + drive$table(ct) = index-1; + ct = ct + 1; + end; + do i=0 to 3; /* update scb drive table */ + call setscbbyte(drive0$offset+i,drive$table(i)); + end; +end process$drives; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* This routine does all the processing for the options. Ie. any + string beginning with a '['. The routine will handle basically + five options: Temporary, Order, Display, Page, No Display and + No Page. Each routine is fairly short and can be found as a + branch in the case statement. + */ + +process$options: procedure; + declare next$delim based buf$ptr byte; + declare (first$sub,paren,val) byte; + do while (delimiter <> 2) and (delimiter <> 11); + index = 0; + delimiter = 1; + call opt$scanner(.options(0),.options$offset(0),.index); + do case index; + + call error(4); /* not in options list (INVALID) */ + + do; /* temporary drive option */ + show$temp = true; + if delimiter <> 3 then /* = */ + call error(1); + call opt$scanner(.drives(0),.drives$offset(0),.index); + if index = 0 then + call error(2); + call setscbbyte(temp$drive$offset,index-1); + end; + + do; /* order option */ + show$order = true; + first$sub,paren = false; + if delimiter <> 3 then /* = */ + call error(1); + do while ((next$delim = ' ') or (next$delim = tab)); /* skip spaces */ + buf$ptr = buf$ptr + 1; + end; + if next$delim = '(' then do; + paren = true; + buf$ptr = buf$ptr + 1; + end; + call opt$scanner(.options(0),.options$offset(0),.index); + if ((index <> 6) and (index <> 7)) then + call error(3); + if index = 7 then /* note that the first entry was SUB */ + first$sub = true; + order$table(0) = index - 6; + if (first$sub and ((delimiter = 10) or not paren)) then + call error(7); /* (SUB) not allowed */ + if (delimiter <> 10) and paren then do; + call opt$scanner(.options(0),.options$offset(0),.index); + if ((index <> 6) and (index <> 7)) then + call error(3); + order$table(1) = index - 6; + if (first$sub and (index = 7)) then /* can't have SUB,SUB */ + call error(7); + end; + ccp$flag2 = getscbbyte(ccp$flag2$offset); + if order$table(0) = 0 then + ccp$flag2 = ccp$flag2 and 111$0$1111b; + else + ccp$flag2 = ccp$flag2 or 000$1$0000b; + if order$table(1) = 0 then + ccp$flag2 = ccp$flag2 and 1111$0$111b; + else + ccp$flag2 = ccp$flag2 or 0000$1$000b; + call setscbbyte(ccp$flag2$offset,ccp$flag2); + if paren then do; + if delimiter <> 10 then + call error(1); + else + buf$ptr = buf$ptr + 1; + end; + else if delimiter = 10 then + call error(1); + if next$delim = ']' or next$delim = 0 then /* two delimiters */ + delimiter = 11; /* eoln, so exit loop */ + end; + + /* PAGE Option */ + do; + show$page = true; + val = 0; + if delimiter = 3 then do; /* = */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index <> 10 then + if index = 11 then + val = 0ffh; + else + call error(8); + end; + call setscbbyte(pg$mode$offset,val); + call setscbbyte(pg$def$offset,val); + end; + + /* call error(4); page option now an error */ + + do; /* DISPLAY option */ + show$display,val = true; + if delimiter = 3 then do; /* = */ + call opt$scanner(.options(0),.options$offset(0),.index); + if index <> 10 then + if index = 11 then + val = false; + else + call error(8); + end; + ccp$flag2 = getscbbyte(ccp$flag2$offset); + if val then + ccp$flag2 = ccp$flag2 or 00000$0$11b; /* set bits */ + else + ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */ + call setscbbyte(ccp$flag2$offset,ccp$flag2); + end; + + /* call error(4); Display option now an error */ + + do; /* NO keyword */ + call opt$scanner(.options(0),.options$offset(0),.index); + if (index <> 3) and (index <> 4) then + call error(4); + if index = 3 then do; /* NO PAGE option */ + show$page = true; + call setscbbyte(pg$mode$offset,0FFh); + call setscbbyte(pg$def$offset,0FFh); + end; + else do; /* NO DISPLAY option */ + show$display = true; + ccp$flag2 = getscbbyte(ccp$flag2$offset); + ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */ + call setscbbyte(ccp$flag2$offset,ccp$flag2); + end; + end; + + /* call error(4); NO keyword is now an error */ + + call error(4); /* COM is not an option */ + + call error(4); /* SUB is not an option */ + + /* NOPAGE option */ + do; + show$page = true; + call setscbbyte(pg$mode$offset,0FFh); + call setscbbyte(pg$def$offset,0FFh); + end; + + /* NODISPLAY option */ + do; + show$display = true; + ccp$flag2 = getscbbyte(ccp$flag2$offset); + ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */ + call setscbbyte(ccp$flag2$offset,ccp$flag2); + end; + + call error(4); /* ON is not an option */ + + call error(4); /* OFF is not an option */ + + /* [JCE] UK option */ + do; + show$date = true; + date$flag = getscbbyte(date$flag$offset); + date$flag = date$flag and 11111100b; /* Clear time settings */ + date$flag = date$flag or 1; /* Set that bit */ + call setscbbyte(date$flag$offset, date$flag); + end; + + /* [JCE] US option */ + do; + show$date = true; + date$flag = getscbbyte(date$flag$offset); + date$flag = date$flag and 11111100b; /* Clear time settings */ + call setscbbyte(date$flag$offset, date$flag); + end; + + /* [JCE] YMD option */ + do; + show$date = true; + date$flag = getscbbyte(date$flag$offset); + date$flag = date$flag and 11111100b; /* Clear time settings */ + date$flag = date$flag or 2; /* Set that bit */ + call setscbbyte(date$flag$offset, date$flag); + end; + + end; + end; +end process$options; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = 9); /* tabs & spaces */ + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /************************************** +* * +* M A I N P R O G R A M * +* * +**************************************/ + +plm: + do; + if (low(version) < cpmversion) or (high(version) = 1) then do; + call print$buf(.('Requires CP/M 3.0$')); + call mon1(0,0); + end; + if not input$found(.tbuff(1)) then do; + /* SHOW DEFAULTS */ + call display$path; + call mon1(0,0); /* & terminate */ + end; + + /* SET DEFAULTS */ + i = 1; /* skip over leading spaces */ + do while (tbuff(i) = ' '); + i = i + 1; + end; + show$drive,show$order,show$temp,show$page,show$display,show$date /*[JCE]*/ + = false; + begin$buffer = .tbuff(1); /* note beginning of input */ + buf$length = tbuff(0); /* note length of input */ + buf$ptr = .tbuff(i); /* set up for scanner */ + if tbuff(i) = '[' then do; /* options, no drives */ + buf$ptr = buf$ptr + 1; /* skip over '[' */ + call process$options; + end; + else do; /* drives first, maybe options too */ + call process$drives; + if delimiter = 1 then /* options, because we found an '[' */ + call process$options; + end; + call display$path; /* show results */ + call mon1(0,0); /* & terminate */ + end; +end setdef; diff --git a/software/CPM/cpm3/show.plm b/software/CPM/cpm3/show.plm new file mode 100644 index 0000000..11f6731 --- /dev/null +++ b/software/CPM/cpm3/show.plm @@ -0,0 +1,1913 @@ +$ TITLE('CP/M 3.0 --- SHOW 3.1') +/* + Revised: + 18 Sep 1998 by John Elliott (YMD format dates) + 17 May 1998 by John Elliott (year 2000 fix, CP/M Patch 16) + Oct 82 by Phillip Balma + 14 Sept 81 by Doug Huskey +*/ + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * SHOW * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +show: +do; +declare + mpm literally '30h'; + +declare plm label public; + +declare copyright(*) byte data + (' Copyright (c) 1982, 1998 Caldera, Inc. '); + +declare verdate(*) byte data('18Sep98 '), + version(*) byte data('Show 3.1'); + + +/* + copyright(c) 1975, 1976, 1977, 1978, 1979, 1980, 1981,1982 + digital research + box 579 + pacific grove, ca + 93950 + + */ + +/* modified 10/30/78 to fix the space computation */ +/* modified 01/28/79 to remove despool dependencies */ +/* modified 07/26/79 to operate under cp/m 2.0 */ +/* modified 01/20/80 by Thomas Rolander */ +/* show created 05/19/81 */ +/* modified 7/82 to add new options parser, # dir FCB's left, new DISK option, + # of files by Phillip Balma */ +/* added paging, # SFCB's Phillip Balma*/ +/* Modified 17 May 1998 for Year 2000 fix (John Elliott) */ +/* Modified 18 Sep 1998 for YMD format dates (John Elliott) */ + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * DISK INTERFACE * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +declare dcnt byte, + anything byte, + dirbuf(128) byte; + +declare + line$page byte, + line$out byte, + drives(16) byte, + drive byte, + all byte initial(0), + once$only byte initial(0), + done$drive(16) byte initial(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0), + + PAGE byte initial(0), + NONBANK byte initial(0), + + user(16) byte, /* any files in user i? */ + used(16) address, /* # files in user i */ + free$dir address, /* # free directories */ + nSFCB address, /* # SFCB's */ + + SCBPB structure( + where byte, + set byte, + value address) initial(0,0,0), + + ERRORM(*) byte data('ERROR: ',0), + input(*) byte data('INPUT: ',0), + eoption(*) byte data('OPTION: ',0), + dirdrive(*) byte data('DRIVE: ',0), + + err$unrecopt(*) byte data('Unrecognized Option.',0), + err$unrecd(*) byte data('Unrecognized drive.',0), + err$version(*) byte data('Requires CP/M 3 or higher.',0), + err$nolabel(*) byte + data('No directory label exists on drive ',0), + err$input(*) byte data('Unrecognized input.',0), + + opt$dir byte data(1), + opt$drive byte data(2), + opt$label byte data(3), + opt$space byte data(0), + opt$user byte data(4), + opt$page byte data(6), /*rel to 1 */ + opt$nopage byte data(7); + + declare + + dirs(*) byte data + ('A:0B:0C:0D:0E:0F:0G:0H:0I:0J:0K:0L:0M:0N:0', + 'O:0P:',0ffh), + options(*) byte data('SPACE0DIRECTORY0DRIVES0LABEL0USERS0', + 'PAGE0NOPAGE',0ffh), + + off$dirs(*) byte data(0,3,6,9,12,15,18,21,24,27,30,33,36,39,42, + 45,47), + off$opt(*) byte data(0,6,16,23,29,35,40,46), + + end$list byte data (0ffh), + end$of$string byte data (0), + + delimiters(*) byte data (0,'[]=, :;<>%\|"()/#!@&+-*?',0,0ffh), + SPACE byte data(5), /* index into delim to space */ + EOS byte data(25), + COMMA byte data(4), + COLON byte data(6), + LBRACKET byte data(1), + RBRACKET byte data(2), + + opt$map(21) structure ( option(5) byte), + + j byte initial(0), + buf$ptr address, + opt$index byte, + endbuf byte, + delimiter byte; +$ eject + +declare + maxb address external, /* addr field of jmp BDOS */ + fcb(33) byte external, /* default fcb */ + buff(128) byte external, /* default buffer */ + fcba literally '.fcb', /* default fcb */ + dolla literally '.fcb(6dh-5ch)', /* $ position */ + rreca literally '.fcb(7dh-5ch)', /* ran rcd 7d,7e,7f */ + rreco literally '.fcb(7fh-5ch)', /* ran overflow */ + sectorlen literally '128', /* sector length */ + rrec address at(rreca), /* random record address */ + rovf byte at(rreco), /* overflow on getfile */ + doll byte at(dolla), /* dollar parameter */ + user$code byte, /* current user code */ + cversion address, /* BDOS version # */ + cdisk byte, /* current disk */ + +/* function call 32 returns the address of the disk parameter +block for the currently selected disk, which consists of: + scptrk (2 by) number of sectors per track + blkshf (1 by) log2 of blocksize (2**blkshf=blksize) + blkmsk (1 by) 2**blkshf-1 + extmsk (1 by) logical/physical extents + maxall (2 by) max alloc number + dirmax (2 by) size of directory-1 + alloc (2 by) reservation bits for directory + chksiz (2 by) size of checksum vector + offset (2 by) offset for operating system + psh (1 by) log2 of physical record size(2**psh * 128 = size) + psm (1 by) 2**psh - 1 +*/ + + dpba address, /* disk parameter block address */ + dpb based dpba structure( + spt address, + bls byte, + bms byte, + exm byte, + mxa address, + dmx address, + dbl address, + cks address, + ofs address, + psh byte, + psm byte), + + scptrk literally 'dpb.spt', + blkshf literally 'dpb.bls', + blkmsk literally 'dpb.bms', + extmsk literally 'dpb.exm', + maxall literally 'dpb.mxa', + dirmax literally 'dpb.dmx', + dirblk literally 'dpb.dbl', + chksiz literally 'dpb.cks', + offset literally 'dpb.ofs', + physhf literally 'dpb.psh', + phymsk literally 'dpb.psm'; + + +boot: procedure external; + /* reboot */ + end boot; + +mon1: procedure(f,a) external; + declare f byte, a address; + end mon1; + +mon2: procedure(f,a) byte external; + declare f byte, a address; + end mon2; + +declare mon3 literally 'mon2a'; + +mon3: procedure(f,a) address external; + declare f byte, a address; + end mon3; + +declare alloca address, + /* alloca is the address of the disk allocation vector */ + alloc based alloca (1024) byte; /* allocation vector */ + +declare + true literally '1', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + ctlc literally '3', + cr literally '13', + lf literally '10'; + + +printchar: procedure(char); + declare char byte; + call mon1(2,char); +end printchar; + +printb: procedure; + /* print blank character */ + call printchar(' '); +end printb; + +printx: procedure(a); + declare a address; + declare s based a byte; + + do while s <> 0; + call printchar(s); + a = a + 1; + end; + +end printx; + +break: procedure byte; + return mon2(11,0); /* console ready */ +end break; + + +crlf2: procedure; + + call printchar(cr); + call printchar(lf); + +end crlf2; + + +terminate: procedure; + call crlf2; + call mon1 (0,0); /* system reset */ +end terminate; + + + +crlf: procedure; + + if PAGE then do; + line$out = line$out + 1; + if line$out + 2 > line$page then do; + + call crlf2; + call crlf2; + + call printx(.('Press RETURN to continue.',0)); + + do while not break; /* wait until a console break*/ + end; + if mon2(1,0) = ctlc then call terminate; + line$out = 1; + call crlf2; + end; + end; + + call crlf2; + +end crlf; + + +print: procedure(a); + declare a address; + /* print the string starting at address a until the + next 0 is encountered */ + call crlf; + call printx(a); + +end print; + + +get$version: procedure byte; + /* returns current cp/m version # */ + return mon3(12,0); +end get$version; + +select: procedure(d); + declare d byte; + + call mon1(14,d); +end select; + +check$user: procedure; + do forever; + if anything then return; + if dcnt = 0ffh then return; + if dirbuf(ror (dcnt,3) and 110$0000b) = user$code then return; + + dcnt = mon2(18,0); + + end; +end check$user; + +search: procedure(fcb); + declare fcb address; + declare fcb0 based fcb byte; + + anything = (fcb0 = '?'); + dcnt = mon2(17,fcb); + call check$user; +end search; + +searchn: procedure; + dcnt = mon2(18,0); + call check$user; +end searchn; + +cselect: procedure byte; + /* return current disk number */ + return mon2(25,0); +end cselect; + +setdma: procedure(dma); + declare dma address; + + call mon1(26,dma); +end setdma; + +getalloca: procedure address; + /* get base address of alloc vector */ + return mon3(27,0); +end getalloca; + +getlogin: procedure address; + /* get the login vector */ + return mon3(24,0); +end getlogin; + +getukdate: procedure byte; /* [JCE] Date in UK format? */ + + SCBPB.where = 0ch; + return (mon2(49,.SCBPB) and 3); + +end getukdate; + + +getpage: procedure byte; /* get the conole page length */ + + SCBPB.where = 01ch; + return mon2(49,.SCBPB); + +end getpage; + + +getpagemode: procedure byte; + + SCBPB.where = 02ch; + return mon2(49,.SCBPB); + +end getpagemode; + +getNB: procedure byte; + SCBPB.where = 05dh; + return high(mon3(49,.SCBPB)); +end getNB; + +getrodisk: procedure address; + /* get the read-only disk vector */ + return mon3(29,0); +end getrodisk; + +/*setind: procedure; + call mon1(30,fcba); +end setind; +*/ + +set$dpb: procedure; + /* set disk parameter block values */ + dpba = mon3(31,0); /* base of dpb */ +end set$dpb; + +getuser: procedure byte; + /* return current user number */ + return mon2(32,0ffh); +end getuser; + +/*setuser: procedure(user); + declare user byte; + + call mon1(32,user); +end setuser; +*/ + +getfreesp: procedure(d); + declare d byte; + + call mon1(46,d); +end getfreesp; + +getlbl: procedure(d) byte; + declare d byte; + + return mon2(101,d); +end getlbl; + +e$print: procedure(msg); + declare msg address; + + call print(.ERRORM); + call printx(msg); + +end e$print; + + +/***************************************************** + + Time & Date ASCII Conversion Code + + *****************************************************/ + +declare tod$adr address; +declare tod based tod$adr structure ( + opcode byte, + date address, + hrs byte, + min byte, + sec byte, + ASCII (21) byte ); + +declare string$adr address; +declare string based string$adr (1) byte; +declare index byte; + +emitchar: procedure(c); + declare c byte; + string(index := index + 1) = c; + end emitchar; + +emitn: procedure(a); + declare a address; + declare c based a byte; + do while c <> '$'; + string(index := index + 1) = c; + a = a + 1; + end; + end emitn; + + +emit$bcd: procedure(b); + declare b byte; + call emitchar('0'+b); + end emit$bcd; + +emit$bcd$pair: procedure(b); + declare b byte; + call emit$bcd(shr(b,4)); + call emit$bcd(b and 0fh); + end emit$bcd$pair; + +emit$colon: procedure(b); + declare b byte; + call emit$bcd$pair(b); + call emitchar(':'); + end emit$colon; + +emit$bin$pair: procedure(b); + declare b byte; + b = b mod 100; /* [JCE] Year 2000 fix */ + call emit$bcd(b/10); /* makes garbage if not < 10 */ + call emit$bcd(b mod 10); + end emit$bin$pair; + +emit$slant: procedure(b); + declare b byte; + call emit$bin$pair(b); + call emitchar('/'); + end emit$slant; + +emit$dash: procedure(b); /* [JCE] for YMD format dates */ + declare b byte; + call emit$bin$pair(b); + call emitchar('-'); + end emit$dash; + +declare chr byte; + +gnc: procedure; + /* get next command byte */ + if chr = 0 then return; + if index = 20 then + do; + chr = 0; + return; + end; + chr = string(index := index + 1); + end gnc; + +deblank: procedure; + do while chr = ' '; + call gnc; + end; + end deblank; + +numeric: procedure byte; + /* test for numeric */ + return (chr - '0') < 10; + end numeric; + +scan$numeric: procedure(lb,ub) byte; + declare (lb,ub) byte; + declare b byte; + b = 0; + call deblank; + if not numeric then call terminate; + do while numeric; + if (b and 1110$0000b) <> 0 then call terminate; + b = shl(b,3) + shl(b,1); /* b = b * 10 */ + if carry then call terminate; + b = b + (chr - '0'); + if carry then call terminate; + call gnc; + end; + if (b < lb) or (b > ub) then call terminate; + return b; + end scan$numeric; + +scan$delimiter: procedure(d,lb,ub) byte; + declare (d,lb,ub) byte; + call deblank; + if chr <> d then call terminate; + call gnc; + return scan$numeric(lb,ub); + end scan$delimiter; + +declare + base$year lit '78', /* base year for computations */ + base$day lit '0', /* starting day for base$year 0..6 */ + month$size (*) byte data + /* jan feb mar apr may jun jul aug sep oct nov dec */ + ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), + month$days (*) address data + /* jan feb mar apr may jun jul aug sep oct nov dec */ + ( 000,031,059,090,120,151,181,212,243,273,304,334); + +leap$days: procedure(y,m) byte; + declare (y,m) byte; + /* compute days accumulated by leap years */ + declare yp byte; + yp = shr(y,2); /* yp = y/4 */ + if (y and 11b) = 0 and month$days(m) < 59 then + /* y not 00, y mod 4 = 0, before march, so not leap yr */ + return yp - 1; + /* otherwise, yp is the number of accumulated leap days */ + return yp; + end leap$days; + +declare word$value address; + +bcd: + procedure (val) byte; + declare val byte; + return shl((val/10),4) + val mod 10; + end bcd; + +declare (month, day, year, hrs, min, sec) byte; + + set$date$time: procedure; + declare + (i, leap$flag) byte; /* temporaries */ + month = scan$numeric(1,12) - 1; + /* may be feb 29 */ + if (leap$flag := month = 1) then i = 29; + else i = month$size(month); + day = scan$delimiter('/',1,i); + year = scan$delimiter('/',base$year,99); + /* ensure that feb 29 is in a leap year */ + if leap$flag and day = 29 and (year and 11b) <> 0 then + /* feb 29 of non-leap year */ call terminate; + /* compute total days */ + tod.date = month$days(month) + + 365 * (year - base$year) + + day + - leap$days(base$year,0) + + leap$days(year,month); + + tod.hrs = bcd (scan$numeric(0,23)); + tod.min = bcd (scan$delimiter(':',0,59)); + if tod.opcode = 2 then + /* date, hours and minutes only */ + do; + if chr = ':' + then i = scan$delimiter (':',0,59); + tod.sec = 0; + end; + /* include seconds */ + else tod.sec = bcd (scan$delimiter(':',0,59)); + + end set$date$time; + +bcd$pair: procedure(a,b) byte; + declare (a,b) byte; + return shl(a,4) or b; + end bcd$pair; + + +compute$year: procedure; + /* compute year from number of days in word$value */ + declare year$length address; + year = base$year; + do forever; + year$length = 365; + if (year and 11b) = 0 then /* leap year */ + year$length = 366; + if word$value <= year$length then + return; + word$value = word$value - year$length; + year = year + 1; + end; + end compute$year; + +declare + week$day byte, /* day of week 0 ... 6 */ + day$list (*) byte data + ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'), + leap$bias byte; /* bias for feb 29 */ + +compute$month: procedure; + month = 12; + do while month > 0; + if (month := month - 1) < 2 then /* jan or feb */ + leapbias = 0; + if month$days(month) + leap$bias < word$value then return; + end; + end compute$month; + +get$date$time: procedure; + /* get date and time */ + hrs = tod.hrs; + min = tod.min; + sec = tod.sec; + word$value = tod.date; + /* word$value contains total number of days */ + week$day = (word$value + base$day - 1) mod 7; + call compute$year; + /* year has been set, word$value is remainder */ + leap$bias = 0; + if (year and 11b) = 0 and word$value > 59 then + /* after feb 29 on leap year */ leap$bias = 1; + call compute$month; + day = word$value - (month$days(month) + leap$bias); + month = month + 1; + end get$date$time; + +emit$date$time: procedure; + + if tod.opcode = 0 then + do; + call emitn(.day$list(shl(week$day,2))); + call emitchar(' '); + end; + if getukdate = 0 then /* [JCE] Vary the date format */ + do; + call emit$slant(month); + call emit$slant(day); + call emit$bin$pair(year); + end; + else if getukdate = 1 then + do; + call emit$slant(day); + call emit$slant(month); + call emit$bin$pair(year); + end; + else + do; + call emit$dash(year); + call emit$dash(month); + call emit$bin$pair(day); /* [JCE] ends */ + end; + call emitchar(' '); + call emit$colon(hrs); + call emit$colon(min); + if tod.opcode = 0 then + call emit$bcd$pair(sec); + end emit$date$time; + +tod$ASCII: + procedure (parameter); + declare parameter address; + declare ret address; + + ret = 0; + tod$adr = parameter; + string$adr = .tod.ASCII; + if (tod.opcode = 0) or + (tod.opcode = 3) then + do; + call get$date$time; + index = -1; + call emit$date$time; + end; + else + do; + if (tod.opcode = 1) or + (tod.opcode = 2) then + do; + chr = string(index:=0); + call set$date$time; + ret = .string(index); + end; + else + do; + call terminate; + end; + end; + end tod$ASCII; + +/******************************************************** + + + TOD INTERFACE TO SHOW + + + ********************************************************/ + + + declare lcltod structure ( + opcode byte, + date address, + hrs byte, + min byte, + sec byte, + ASCII (21) byte ); + +/* declare extrnl$todadr address; + declare extrnl$tod based extrnl$todadr structure ( + date address, + hrs byte, + min byte, + sec byte ); +*/ + + declare ret address; + +/* display$tod: + procedure; + lcltod.opcode = 0; + call move (5,.extrnl$tod.date,.lcltod.date); + call tod$ASCII (.lcltod); + call write$console (0dh); + do i = 0 to 20; + call write$console (lcltod.ASCII(i)); + end; + end display$tod; */ + + display$ts: + procedure (tsadr); + dcl i byte; + dcl tsadr address; + lcltod.opcode = 3; /* display time and date stamp, no seconds */ + call move (4,tsadr,.lcltod.date); /* don't copy seconds */ + call tod$ASCII (.lcltod); + do i = 0 to 13; + call printchar (lcltod.ASCII(i)); + end; + end display$ts; + +/******** End TOD Code ********/ + + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * BASIC ROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +declare + fcbmax literally '512'; /* max fcb count */ + +declare bpb address; /* bytes per block */ + + +set$bpb: procedure; + + call set$dpb; /* disk parameters set */ + bpb = shl(double(1),blkshf) * sectorlen; + +end set$bpb; + + +select$disk: procedure(d); + declare d byte; + /* select disk and set bpb */ + call select(cdisk:=d); + call set$bpb; /* bytes per block */ + +end select$disk; + + +getalloc: procedure(i) byte; /* return the ith bit of the alloc vector */ + declare i address; + + return + rol(alloc(shr(i,3)), (i and 111b) + 1); + end getalloc; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* fill string @ s for c bytes with f */ +fill: proc(s,f,c); + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * PRINT A NUMBER * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +declare + val (7) byte initial(0,0,0,0,0,0,0), /* BCD digits */ + fac (7) byte initial(0,0,0,0,0,0,0), /* hibyte factor */ + f0 (7) byte initial(6,3,5,5,6,0,0), /* 65,536 */ + f1 (7) byte initial(2,7,0,1,3,1,0), /* 131,072 */ + f2 (7) byte initial(4,4,1,2,6,2,0), /* 262,144 */ + f3 (7) byte initial(8,8,2,4,2,5,0), /* 524,288 */ + f4 (7) byte initial(6,7,5,8,4,0,1), /* 1,048,576 */ + f5 (7) byte initial(2,5,1,7,9,0,2), /* 2,097,152 */ + f6 (7) byte initial(4,0,3,4,9,1,4), /* 4,194,304 */ + ptr (7) address initial(.f0,.f1,.f2,.f3,.f4,.f5,.f6); + + + + /* print decimal value of address v */ +pdecimal: procedure(v,prec,zerosup); + /* print value v with precision prec (1,10,100,1000,10000) + with leading zero suppression if zerosup = true */ + declare + v address, /* value to print */ + prec address, /* precision */ + zerosup byte, /* zero suppression flag */ + d byte; /* current decimal digit */ + + do while prec <> 0; + d = v / prec; /* get next digit */ + v = v mod prec; /* get remainder back to v */ + prec = prec/10; /* ready for next digit */ + + if prec = 0 then go to pd0; + if d <> 0 then go to pd0; + if zerosup then do; + call printb; + go to pd1; + end; +pd0: zerosup = false; + call printchar('0'+d); +pd1: end; + +end pdecimal; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* BCD - convert 16 bit binary to + 7 one byte BCD digits */ +getbcd: procedure(value); + declare + (value,prec) address, + i byte; + + prec = 10000; + i = 5; /* digits: 4,3,2,1,0 */ + do while prec <> 0; + val(i:=i-1) = value / prec; /* get next digit */ + value = value mod prec; /* remainder in value */ + prec = prec / 10; + end; + end getbcd; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print BCD number in val array */ +printbcd: procedure; + declare + (zerosup, i) byte; + + pchar: procedure(c); + declare c byte; + if val(i) = 0 then + if zerosup then + if i <> 0 then do; + call printb; + return; + end; + /* else */ + call printchar(c); + zerosup = false; + end pchar; + + zerosup = true; + i = 7; + do while (i:=i-1) <> -1; + call pchar('0'+val(i)); + if i = 6 or i = 3 then + call pchar(','); + end; + end printbcd; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* add two BCD numbers result in second */ +add: procedure(ap,bp); + declare + (ap,bp) address, + a based ap (7) byte, + b based bp (7) byte, + (c,i) byte; + + c = 0; /* carry */ + do i = 0 to 6; /* 0 = LSB */ + b(i) = a(i) + b(i) + c; + c = b(i) / 10; + b(i) = b(i) mod 10; + end; + end add; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* print 3 byte value based at byte3adr */ +p3byte: procedure(byte3adr); + declare + i byte, + high$byte byte, + byte3adr address, + b3 based byte3adr structure ( + lword address, + hbyte byte); + + call fill(.val,0,7); + call fill(.fac,0,7); + call getbcd(b3.lword); /* put 16 bit value in val */ + high$byte = b3.hbyte; + do i = 0 to 6; /* factor for bit i */ + if high$byte then /* LSB is 1 */ + call add(ptr(i),.fac); /* add in factor */ + high$byte = shr(high$byte,1); /* get next bit */ + end; + call add(.fac,.val); /* add factor to value */ + call printbcd; /* print value */ + end p3byte; + + + /* divide 3 byte value by 8 */ +shr3byte: procedure(byte3adr); + dcl byte3adr address, + b3 based byte3adr structure ( + lword address, + hbyte byte), + temp1 based byte3adr (2) byte, + temp2 byte; + + temp2 = ror(b3.hbyte,3) and 11100000b; /* get 3 bits */ + b3.hbyte = shr(b3.hbyte,3); + b3.lword = shr(b3.lword,3); + temp1(1) = temp1(1) or temp2; /* or in 3 bits from hbyte */ + end shr3byte; + + + /* multiply 3 byte value by #records per block */ +shl3byte: procedure(byte3adr); + dcl byte3adr address, + b3 based byte3adr structure ( + lword address, + hbyte byte), + temp1 based byte3adr (2) byte; + + b3.hbyte = (rol(temp1(1),blkshf) and blkmsk) or shl(b3.hbyte,blkshf); + b3.lword = shl(b3.lword,blkshf); + end shl3byte; + + +show$drive: procedure; + + call printchar(cdisk+'A'); + call printx(.(': ',0)); + +end show$drive; + + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * CALCULATE SIZE * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +add$block: procedure(ak,ab); + declare (ak, ab) address; + /* add one block to the kilobyte accumulator */ + declare kaccum based ak address; /* kilobyte accum */ + declare baccum based ab address; /* byte accum */ + baccum = baccum + bpb; + do while baccum >= 1024; + baccum = baccum - 1024; + kaccum = kaccum + 1; + end; + end add$block; + +count: procedure(mode) address; + declare mode byte; /* true if counting 0's */ + /* count kb remaining, kaccum set upon exit */ + declare + ka address, /* kb accumulator */ + ba address, /* byte accumulator */ + i address, /* local index */ + bit byte; /* always 1 if mode = false */ + ka, ba = 0; + bit = 0; + do i = 0 to maxall; + if mode then bit = getalloc(i); + if not bit then call add$block(.ka,.ba); + end; + return ka; + end count; + + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * STATUS ROUTINES * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + + /* characteristics of current drive */ +drivestatus: procedure; + dcl b3a address, + b3 based b3a structure ( + lword address, + hbyte byte), + + psize address; + + + /* print 3 byte value */ + pv3: procedure; + call crlf; + call p3byte(.dirbuf); + call printchar(':'); + call printb; + end pv3; + + /* print address value v */ + pv: procedure(v); + dcl v address; + b3.hbyte = 0; + b3.lword = v; + call pv3; + end pv; + + /* print the characteristics of the currently selected drive */ + + b3a = .dirbuf; + call print(.(' ',0)); + call show$drive; + call printx(.('Drive Characteristics',0)); + b3.hbyte = 0; + b3.lword = maxall + 1; /* = # blocks */ + call shl3byte(.dirbuf); /* # blocks * records/block */ + call pv3; + call printx(.('128 Byte Record Capacity',0)); + call shr3byte(.dirbuf); /* divide by 8 */ + call pv3; + call printx(.('Kilobyte Drive Capacity',0)); + call pv(dirmax+1); + call printx(.('32 Byte Directory Entries',0)); + call pv(shl(chksiz,2)); + call printx(.('Checked Directory Entries',0)); + call pv((extmsk+1) * 128); + call printx(.('Records / Directory Entry',0)); + call pv(shl(double(1),blkshf)); + call printx(.('Records / Block',0)); + call pv(scptrk); + call printx(.('Records / Track',0)); /* [JCE] Saying "Sectors" is */ + call pv(offset); /* misleading if sector size */ + call printx(.('Reserved Tracks',0)); /* is >128 bytes */ + + psize = 128; /* 2**psh * 128 */ + if physhf > 0 then psize = shl(psize,physhf); + + call pv(psize); + call printx(.('Bytes / Physical Record',0)); + call crlf; + + end drivestatus; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * DISK STATUS * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +pvalue: procedure(v); + declare (d,zero) byte, + (k,v) address; + k = 10000; + zero = false; + do while k <> 0; + d = low(v/k); v = v mod k; + k = k / 10; + if zero or k = 0 or d <> 0 then + do; zero = true; call printchar('0'+d); + end; + end; + end pvalue; + + +prcount: procedure; + + /* print the actual byte count */ + if cversion < mpm then do; + alloca = getalloca; + call pvalue(count(true)); + end; + else do; + call setdma(.dirbuf); + call getfreesp(cdisk); + call shr3byte(.dirbuf); + call p3byte(.dirbuf); + end; + call printchar('k'); + end prcount; + +stat: procedure(rodisk); + declare rodisk address; + + call crlf; + call show$drive; + call printchar('R'); + if low(rodisk) then + call printchar('O'); else + call printchar('W'); + call printx(.(', Space: ',0)); + call prcount; + end stat; + +prstatus: procedure; /* print the status of the disk system */ + declare (login, rodisk) address; + declare (d,save) byte; + + if once$only then return; /* only execute this once if + all was specified > 1 */ + + save = cdisk; + login = getlogin; /* login vector set */ + rodisk = getrodisk; /* read only disk vector set */ + + d = 0; + do while login <> 0; + if low(login) then do; + if not all then do; /* do specified disk */ + if d = save then call stat(rodisk); + end; + + else do; + call select$disk(d); /* do all disks */ + call stat(rodisk); + end; + end; + + login = shr(login,1); rodisk = shr(rodisk,1); + d = d + 1; + end; + + if all then once$only = true; + call crlf; + + end prstatus; + + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * USER STATUS * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +prdir: procedure; + + call crlf; + call crlf; + call show$drive; + + if nSFCB > 0 then do; + call printx(.('Number of time/date directory entries: ',0)); + call pdecimal(nSFCB,1000,true); + call crlf; + call show$drive; + end; + + call printx(.('Number of free directory entries: ',0)); + call pdecimal(free$dir,1000,true); + call crlf; + +end prdir; + + +get$usr$files: procedure; + declare ufcb(*) byte data ('????????????',0,0,0), + (i,j) byte, + nfcbs address, + extptr address, + modptr address, + fmod based modptr byte, + fext based extptr byte; + + do i = 0 to 15; + user(i),used(i) = 0; + end; + nSFCB = 0; + + call setdma(.dirbuf); + call search(.ufcb); + nfcbs = 0; + + do while dcnt <> 255; + j = shl(dcnt,5); /* which fcb in dirbuf */ + +ge0: if (i := dirbuf(j)) <> 0e5h then do; + if i <> 33 then do; /* SFCB ? */ + extptr = .dirbuf(j + 12); + modptr = extptr + 2; + nfcbs = nfcbs + 1; + j = i; /* save for xfcb test */ + user(i := i and 0fh) = true; + + if j > 15 then go to ge2; + if fext > extmsk then go to ge2; + if fmod = 0 then used(i) = used(i) + 1; + end; + else nSFCB = nSFCB + 1; + end; + +ge2: call searchn; + end; + + done$drive(cdisk) = true; + if nSFCB > 0 then nSFCB = shr(dirmax+1,2); /* because search ends + at high water mark*/ + free$dir = ((dirmax + 1) - nSFCB) - nfcbs; + +end get$usr$files; + + +userstatus: procedure; /* display active user numbers */ + declare i byte; + + call crlf; + call show$drive; + call printx(.('Active User :',0,0)); /* [JCE] Patch 16 */ + call pdecimal(getuser,1000,true); + call crlf; + call show$drive; + call printx(.('Active Files:',0,0)); /* [JCE] Patch 16 */ + + if not done$drive(cdisk) then call get$usr$files; + + do i = 0 to last(user); + if user(i) then call pdecimal(i,1000,true); + end; + + call crlf; + call show$drive; + call printx(.('# of files :',0,0)); /* [JCE] Patch 16 */ + do i = 0 to last(user); + if user(i) then call pdecimal(used(i),1000,true); + end; + + call prdir; + +end userstatus; + + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * DISK & FILE STATUS * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + + +directory: procedure; + + if not done$drive(cdisk) then call get$usr$files; + call prdir; + +end directory; + +/******************************************************* + + L A B E L S T A T U S + +********************************************************/ + +readlbl: proc(relog); + declare relog byte, + d byte data('?'); + + call setdma(.dirbuf); + call search(.d); + if relog > 0 then return; + + do while dcnt <> 0ffH; + if dirbuf(ror(dcnt,3) and 110$0000b)=20H then return; + call searchn; + end; + +end readlbl; + +/* HEADER */ + +dcl label1 (*) byte data ( +'Directory Passwds Stamp Stamp',0); +dcl label2 (*) byte data ( +'Label Reqd ',0); +dcl label3 (*) byte data ( + ' Update Label Created Label Updated',0) + +; +dcl label4 (*) byte data ( +'------------ ------- ------ ------ -------------- --------------',0 + +); + + +labelstatus: procedure; + dcl lbl byte; + dcl fnam lit '11'; + dcl ftyp lit '9'; + dcl fcbp address; + dcl fcbv based fcbp (32) byte; /* template over dirbuf */ + + printfn: proc; /* print file name */ + declare k byte; + + do k = 1 to fnam; + if k = ftyp then + call printchar('.'); + call printchar(fcbv(k) and 7fh); + end; + end printfn; + + + lbl = getlbl(cdisk); + if lbl > 0 then do; + call readlbl(0); + fcbp = shl(dcnt,5) + .dirbuf; + + call print(.('Label for drive ',0)); /* print heading */ + call show$drive; + call crlf; + call print(.label1); + call print(.label2); + if (lbl and 40h) = 40h then + call printx(.('Access',0)); + else + call printx(.('Create',0)); + call printx(.label3); + call print(.label4); + call crlf; + call printfn; + if not NONBANK and ((lbl and 80h) = 80h) then + call printx(.(' on ',0)); + else + call printx(.(' off ',0)); + + if (lbl and 40h) = 40h then + call printx(.(' on ',0)); + else if(lbl and 10h) = 10h then + call printx(.(' on ',0)); + else call printx(.(' off ',0)); + + if (lbl and 20h) = 20h then + call printx(.(' on ',0)); + else + call printx(.(' off',0)); + + call printx(.(' ',0)); + call display$ts(.fcbv(24)); + call printx(.(' ',0)); + call display$ts(.fcbv(28)); + end; + else do; + call e$print(.err$nolabel); + call printchar(cdisk+'A'); + end; + + call crlf; + +end labelstatus; + + +$eject +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr) byte; + /* scans the list pointed at by idxptr + for any strings that are in the + list pointed at by list$ptr. + Offptr points at an array that + contains the indices for the known + list. Idxptr points at the index + into the list. If the input string + is unrecognizable then the index is + 0, otherwise > 0. + + First, find the string in the known + list that starts with the same first + character. Compare up until the next + delimiter on the input. if every input + character matches then check for + uniqueness. Otherwise try to find + another known string that has its first + character match, and repeat. If none + can be found then return invalid. + + To test for uniqueness, start at the + next string in the knwon list and try + to get another match with the input. + If there is a match then return invalid. + + else move pointer past delimiter and + return. + + P.Balma */ + + declare + buff based buf$ptr (1) byte, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5) + and (delimiter <> 25)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + + do while(delimiter := separator(charac)) = SPACE; + bufptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return(index); + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + index = 0; + call skip; /* skip input field to next delimiter*/ + return(0); + +finished: /* unambiguous reference */ + index = save$index; + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then buf$ptr = buf$ptr + 1; + else delimiter = SPACE; + return(index); + +end opt$scanner; + +error$prt: procedure; + declare i byte, + t address, + char based t byte; + + t = buf$ptr - endbuf - 1; + do i = 1 to endbuf; + call printchar(char); + t = t + 1; + end; + +end error$prt; + +$eject +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * EXECUTE * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +do$option: procedure(i); + declare i byte; + + + if opt$map(i).option(opt$space) <> 0 then call prstatus; + if opt$map(i).option(opt$label) <> 0 then call labelstatus; + if opt$map(i).option(opt$drive) <> 0 then call drivestatus; + if opt$map(i).option(opt$user) <> 0 then call userstatus; + if opt$map(i).option(opt$dir) <> 0 then call directory; + +end do$option; + +$eject + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * PARSING * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +declare character based buf$ptr byte; + +setdef$drive: procedure; + + if drive = 0ffh then do; + drive = cdisk; + drives(drive) = drive; + end; + + return; + +end setdef$drive; + + +parseoptions: procedure byte; + /* find all options within [...] */ + + buf$ptr = buf$ptr + 1; + delimiter = separator(character); + call setdef$drive; + + if delimiter = 0 then go to preloop; + if delimiter <> RBRACKET then + if delimiter <> EOS then go to preloop; + + /* [], turn on space */ + opt$map(drive).option(opt$space) = 1; + buf$ptr = buf$ptr + 1; + return(2); + +preloop: + if opt$map(drive).option(opt$space) = 0ffh then /* reset forced space*/ + opt$map(drive).option(opt$space) = 0; + +loop: if (opt$index := optscanner(.options,.off$opt)) = 0 then go to error; + + if opt$index = opt$page then PAGE = true; + else if opt$index = opt$nopage then PAGE = false; + else opt$map(drive).option(opt$index - 1) = 1; + + go to looptest; + +error: call e$print(.err$unrecopt); + call print(.eoption); + call error$prt; + +looptest: + if delimiter = EOS then return(25); + if delimiter = RBRACKET then return(2); + + go to loop; + +end parseoptions; + +parsedir: procedure; + + declare dirindex byte; + + if (dir$index := optscanner(.dirs,.off$dirs)) = 0 then go to error1; + + drive = dir$index - 1; + drives(drive) = drive; + opt$map(drive).option(opt$space) = 0ffh;/* only drive:,reset + if other options and + not space picked */ + if delimiter <> COLON then buf$ptr = buf$ptr - 1; + + return; + +error1: call e$print(.err$unrecd); +dprint: call print(.dirdrive); + call error$prt; + call terminate; + +end parsedir; + + +parser: procedure; + + drive = 0ffh; + + if (delimiter := separator(character)) = EOS then do; + call setdef$drive; + opt$map(drive).option(opt$space) = 1; /* default*/ + all = true; + return; + end; + +loop: if delimiter = LBRACKET then delimiter = parseoptions; + else if delimiter = 0 then call parsedir; + + else do; + if delimiter <> COMMA then + if delimiter <> SPACE then go to error; + + drive = 0ffh; + buf$ptr = buf$ptr + 1; + end; + + +looptest: + if delimiter <> EOS then + if (delimiter := separator(character)) <> EOS then go to loop; + + return; + +error: call e$print(.err$input); + call print(.input); + call error$prt; + call terminate; + +end parser; + +$eject +/************************************************************************* + + + *** MAIN PROGRAM *** + + +**************************************************************************/ + + declare + i byte initial(1); + + plm: + cversion = get$version; + if cversion < mpm then call e$print(.err$version); + else do; + + do while buff(i) = ' '; + i = i + 1; + end; + buf$ptr = .buff(i); + + cdisk = cselect; + user$code = getuser; + + do i = 0 to 15; + drives(i) = 0ffh; + end; + + if getpagemode = 0 then PAGE = true; + line$page = getpage; + line$out = 0; + if getNB = 0 then NONBANK = true; + + call parser; + + do i = 0 to 15; + if (drive := drives(i)) <> 0ffh then do; + call select$disk(drives(i)); + call readlbl(1); /* force login + by wild card drive + search. */ + call do$option(i); + end; + end; + + end; + call terminate; + +end; diff --git a/software/CPM/cpm3/sopt.dcl b/software/CPM/cpm3/sopt.dcl new file mode 100644 index 0000000..68ed61e --- /dev/null +++ b/software/CPM/cpm3/sopt.dcl @@ -0,0 +1,63 @@ + + declare + opt$mod(19) structure(modifier(8) byte) + data(1,1,1,0,0,0,0,0, /* 0 access */ + 1,1,1,0,0,0,0,0, /* 1 archive */ + 1,1,1,0,0,0,0,0, /* 2 create */ + 1,0,0,0,0,0,0,1, /* 3 default */ + 0,0,0,0,0,0,0,0, /* 4 directory */ + 1,1,1,0,0,0,0,0, /* 5 f1 */ + 1,1,1,0,0,0,0,0, + 1,1,1,0,0,0,0,0, + 1,1,1,0,0,0,0,0, + 1,0,0,0,0,0,0,1, /* 9 name */ + 1,0,0,0,0,0,0,1, /* 10 password */ + 1,1,1,1,1,1,1,0, /* 11 protect */ + 0,0,0,0,0,0,0,0, /* 12 ro */ + 0,0,0,0,0,0,0,0, /* 13 rw */ + 0,0,0,0,0,0,0,0, /* 14 sys */ + 1,1,1,0,0,0,0,0, /* 15 update */ + 0,0,0,0,0,0,0,0, /* 16 page */ + 0,0,0,0,0,0,0,0), /* 17 nopage */ + + options(*) byte + data('ACCESS0ARCHIVE0CREATE0DEFAULT0DIR0F10F20F30F40', + 'NAME0PASSWORD0PROTECT0RO0RW0SYS', + '0UPDATE0PAGE0NOPAGE',0ffh), + off$opt(20) byte data(0,7,15,22,30,34,37,40,43,46,51,60,68,71, + 74,78,85,90,96), + mods(*) byte + data('OFF0ON0READ0WRITE0DELETE0NONE',0ffh), + off$mods(7) byte data(0,4,7,12,18,25,29), + + end$list byte data (0ffh), + end$of$string byte data(0), + + delimiters(*) byte data (0,'[]=, :;<>%\|"()/#!@&+-*?',0,0ffh), + SPACE byte data (5), /* index in delim to space */ + RBRACKET byte data(2), /* ] in delim */ + ENDFF byte data(25), + EQUAL byte data (3), + LBRACKET byte data (1), + + option$map(19) byte, + mods$map(19) byte; + + declare + sfamsg byte initial(false), + drvmsg byte initial(false), + j byte initial(0), + string$ptr address, + defpass address, + labname address, + passname address, + lendef byte, + lenpass byte, + lenlab byte, + buf$ptr address, + index byte, + endbuf byte, + mindex byte, + delimiter byte; +$ eject + diff --git a/software/CPM/cpm3/sopt.inc b/software/CPM/cpm3/sopt.inc new file mode 100644 index 0000000..444f4ec --- /dev/null +++ b/software/CPM/cpm3/sopt.inc @@ -0,0 +1,286 @@ +$eject +check$choice: procedure(index,mindex) byte; + /* does this modifier go with this + option? */ + declare + index byte, + mindex byte; + + return(opt$mod(index).modifier(mindex)); + +end check$choice; + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + + * * * Option scanner * * * + + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + + +separator: procedure(character) byte; + + /* determines if character is a + delimiter and which one */ + declare k byte, + character byte; + + k = 1; +loop: if delimiters(k) = end$list then return(0); + if delimiters(k) = character then return(k); /* null = 25 */ + k = k + 1; + go to loop; + +end separator; + +opt$scanner: procedure(list$ptr,off$ptr) byte; + + /* list$ptr - pointer to list of known strings + off$ptr - pointer to offsets into known string + list + buf$ptr - pointer to input string + + Scans the known string list for an occurrance of the input + string. If the input string is not found in the known list + then return(0). Otherwise, return the index of the known string + that matches the input. + + 1. Find the known string that matches the input string on the + first letter. + + do i = 1 to #known_strings + if Known_string(i,1) = input(1) then do + + if length(Known_string(i)) < end_of_input + then return(0) + + do j = 2 to end_of_input + + if Known_string(i,j) ~= input(j) then + go to again + end + + go to 2 + end + again: end + + return (0) !no matchs + + 2. Test to see if the input string does not match another Known + string. This may happen if the input string is not a + unique sub-string of the Known string, ie., DI is a + sub-string of DIRECTORY and DISK. + + index = i + + do i = index+1 to #known_strings + do j = 1 to end of input + + if Known_string(i,j) ~= input(j) then + go to next + end + + return(0) !not unique + next: end; + + return(index) !unique substring + + P.Balma 10/82 */ + + declare + buff based buf$ptr (1) byte, + off$ptr address, + list$ptr address; + + declare + i byte, + j byte, + list based list$ptr (1) byte, + offsets based off$ptr (1) byte, + wrd$pos byte, + character byte, + letter$in$word byte, + found$first byte, + start byte, + index byte, + save$index byte, + (len$new,len$found) byte, + valid byte; + +/*****************************************************************************/ +/* internal subroutines */ +/*****************************************************************************/ + +check$in$list: procedure; + /* find known string that has a match with + input on the first character. Set index + = invalid if none found. */ + + declare i byte; + + i = start; + wrd$pos = offsets(i); + do while list(wrd$pos) <> end$list; + i = i + 1; + index = i; + if list(wrd$pos) = character then return; + wrd$pos = offsets(i); + end; + /* could not find character */ + index = 0; + return; +end check$in$list; + +setup: procedure; + character = buff(0); + call check$in$list; + letter$in$word = wrd$pos; + /* even though no match may have occurred, position + to next input character. */ + i = 1; + character = buff(1); +end setup; + +test$letter: procedure; + /* test each letter in input and known string */ + + letter$in$word = letter$in$word + 1; + + /* too many chars input? 0 means + past end of known string */ + if list(letter$in$word) = end$of$string then valid = false; + else + if list(letter$in$word) <> character then valid = false; + + i = i + 1; + character = buff(i); + +end test$letter; + +skip: procedure; + /* scan past the offending string; + position buf$ptr to next string... + skip entire offending string; + ie., falseopt=mod, [note: comma or + space is considered to be group + delimiter] */ + character = buff(i); + delimiter = separator(character); + do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5) + and (delimiter <> 25)); + i = i + 1; + character = buff(i); + delimiter = separator(character); + end; + endbuf = i; + buf$ptr = buf$ptr + endbuf + 1; + return; +end skip; + +eat$blanks: procedure; + + declare charac based buf$ptr byte; + + do while(delimiter := separator(charac)) = SPACE; + buf$ptr = buf$ptr + 1; + end; + +end eat$blanks; + +/*****************************************************************************/ +/* end of internals */ +/*****************************************************************************/ + + + /* start of procedure */ + call eat$blanks; + start = 0; + call setup; + + /* match each character with the option + for as many chars as input + Please note that due to the array + indices being relative to 0 and the + use of index both as a validity flag + and as a index into the option/mods + list, index is forced to be +1 as an + index into array and 0 as a flag*/ + + do while index <> 0; + start = index; + delimiter = separator(character); + + /* check up to input delimiter */ + + valid = true; /* test$letter resets this */ + do while delimiter = 0; + call test$letter; + if not valid then go to exit1; + delimiter = separator(character); + end; + + go to good; + + /* input ~= this known string; + get next known string that + matches */ +exit1: call setup; + end; + /* fell through from above, did + not find a good match*/ + endbuf = i; /* skip over string & return*/ + call skip; + return(0); + + /* is it a unique match in options + list? */ +good: endbuf = i; + len$found = endbuf; + save$index = index; + valid = false; +next$opt: + start = index; + call setup; + if index = 0 then go to finished; + + /* look at other options and check + uniqueness */ + + len$new = offsets(index + 1) - offsets(index) - 1; + if len$new = len$found then do; + valid = true; + do j = 1 to len$found; + call test$letter; + if not valid then go to next$opt; + end; + end; + else go to nextopt; + /* fell through...found another valid + match --> ambiguous reference */ + call skip; /* skip input field to next delimiter*/ + return(0); + +finished: /* unambiguous reference */ + buf$ptr = buf$ptr + endbuf; + call eat$blanks; + if delimiter <> 0 then buf$ptr = buf$ptr + 1; + else delimiter = SPACE; + + return(save$index); + +end opt$scanner; + +error$prt: procedure; + declare i byte, + t address, + char based t byte; + + t = buf$ptr - endbuf - 1; + do i = 1 to endbuf; + call printchar(char); + t = t + 1; + end; + +end error$prt; + diff --git a/software/CPM/cpm3/sort.plm b/software/CPM/cpm3/sort.plm new file mode 100644 index 0000000..72d39e6 --- /dev/null +++ b/software/CPM/cpm3/sort.plm @@ -0,0 +1,119 @@ +$title ('SDIR - Sort Module') +sort: +do; + /* sort module for extended dir */ + +$include(comlit.lit) + +print: procedure(str$adr) external; /* in util.plm */ +dcl str$adr address; +end print; + +dcl sorted boolean public; /* set by this module if successful sort */ + +$include(finfo.lit) + +declare + buf$fcb$adr address external, /* index into directory buffer */ + buf$fcb based buf$fcb$adr (32) byte, + /* fcb template for dir */ + + (f$i$adr, first$f$i$adr, last$f$i$adr, x$i$adr, filesfound) + address external, + /* indices into file$info array */ + file$info based f$i$adr f$info$structure, + + mid$adr address, + mid$file$info based mid$adr f$info$structure; + + +mult23: procedure(index) address public; + dcl index address; /* return address of file$info numbered by index */ + return shl(index, 4) + shl(index,2) + shl(index,1) + index + first$f$i$adr; + /* index * size(file$info) + base of file$info array */ +end mult23; + +lessthan: procedure( str1$adr, str2$adr) boolean; + dcl (i,c1,c2) byte, /* true if str1 < str2 */ + (str1$adr, str2$adr) address, /* sorting on name and type field */ + str1 based str1$adr (1) byte, /* only, assumed to be first in */ + str2 based str2$adr (1) byte; /* file$info record */ + do i = 1 to 11; + if (c1:=(str1(i) and 7fh)) <> (c2:=(str2(i) and 7fh)) then + return(c1 < c2); + end; + return(false); +end lessthan; + +dcl f$i$indices$base address public, + f$i$indices based f$i$indices$base (1) address; + +qsort: procedure(l,r); /* no recursive quick sort, sorting largest */ +dcl (l,r,i,j,temp) address,/* partition first */ + stacksiz lit '14', /* should always be able to sort 2 ** stacksiz */ + stack (stack$siz) structure (l address, r address), + sp byte; + + sp = 0; stack(0).l = l; stack(0).r = r; + + do while sp < stack$siz - 1; + l = stack(sp).l; r = stack(sp).r; sp = sp - 1; + do while l < r; + i = l; j = r; + mid$adr = mult23(f$i$indices(shr(l+r,1))); + do while i <= j; + f$i$adr = mult23(f$i$indices(i)); + do while lessthan(f$i$adr,mid$adr); + i = i + 1; + f$i$adr = mult23(f$i$indices(i)); + end; + f$i$adr = mult23(f$i$indices(j)); + do while lessthan(mid$adr,f$i$adr); + j = j - 1; + f$i$adr = mult23(f$i$indices(j)); + end; + if i <= j then + do; temp = f$i$indices(i); f$i$indices(i) = f$i$indices(j); + f$i$indices(j) = temp; + i = i + 1; + if j > 0 then j = j - 1; + end; + end; /* while i <= j */ + if j - l < r - i then /* which partition is larger */ + do; if i < r then + do; sp = sp + 1; stack(sp).l = i; stack(sp).r = r; + end; + r = j; /* continue sorting left partition */ + end; + else + do; if l < j then + do; sp = sp + 1; stack(sp).l = l; stack(sp).r = j; + end; + l = i; /* continue sorting right partition */ + end; + end; /* while l < r */ + end; /* while sp < stack$siz - 1 */ + if sp <> 255 then + call print(.(cr,lf,lf,'Sort Stack Overflow',cr,lf,'$')); + else sorted = true; +end qsort; + +sort: procedure public; + dcl i address; + f$i$indices$base = last$f$i$adr + size(file$info); + if filesfound < 2 then + return; + if shr((x$i$adr - f$i$indices$base),1) < filesfound then + do; + call print(.('Not Enough Memory for Sort',cr,lf,'$')); + return; + end; + do i = 0 to filesfound - 1; + f$i$indices(i) = i; /* initialize f$i$indices */ + end; + call print(.(cr,lf,'Sorting Directory...',cr,lf,'$')); + call qsort(0,filesfound - 1); + sorted = true; +end sort; + +end sort; diff --git a/software/CPM/cpm3/submit.plm b/software/CPM/cpm3/submit.plm new file mode 100644 index 0000000..acd3239 --- /dev/null +++ b/software/CPM/cpm3/submit.plm @@ -0,0 +1,663 @@ +$ TITLE('CP/M 3.0 --- SUBMIT') +sub: +do; +$include (copyrt.lit) +/* + Revised: + 26 July 79 for CP/M 2.0 + 01 July 82 for CP/M 3.0 by John Knight + 23 Aug 82 for CP/M 3.0 by Doug Huskey + 11 Sept 82 for CP/M 3.0 by Doug Huskey + 1 Nov 82 for CP/M 3.0 by Doug Huskey + +*/ + +/* + generation procedure + +seteof submit.plm +seteof copyrt.lit +is14 +asm80 mcd80a.asm debug +asm80 getf.asm debug +asm80 parse.asm debug +plm80 submit.plm pagewidth(100) debug optimize +link mcd80a.obj,submit.obj,parse.obj,getf.obj,plm80.lib to submit.mod +locate submit.mod code(0100H) stacksize(100) +era submit.mod +cpm +objcpm submit +rmac getrsx +xref getrsx +link getrsx[op] +era get.rsx +ren get.rsx=getrsx.prl +gencom submit.com get.rsx + +*/ + +declare plm label public; + + +/********************************* +* * +* B D O S I N T E R F A C E * +* * +*********************************/ + +declare + sfcb(33) byte external, /* default fcb */ + buff(128) byte external; /* default buffer */ + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + +mon1: procedure(f,a) external; + declare f byte, a address; + /* bdos interface, no returned value */ + end mon1; + +mon2a: procedure(f,a) external; + declare f byte, a byte; + /* bdos interface, no returned value */ + end mon2a; + +mon2: procedure(f,a) byte external; + declare f byte, a address; + /* bdos interface, return byte value */ + end mon2; + +mon3: procedure(func,info) address external; + declare func byte; + declare info address; + end mon3; + +parse: + procedure (pfcb) address external; + declare pfcb address; +end parse; + +getf: + procedure (input$type) external; /* does submit file processing */ + declare input$type address; +end getf; + +/************************************ +* * +* L I T E R A L S * +* * +************************************/ + + declare lit literally 'literally', + dcl lit 'declare', + proc lit 'procedure', + addr lit 'address', + ctll lit '0ch', + lca lit '110$0001b', /* lower case a */ + lcz lit '111$1010b', /* lower case z */ + endfile lit '1ah', /* cp/m end of file */ + sysin$endfile lit '0ffh', + true literally '1', + false literally '0', + forever literally 'while true', + cr literally '13', + lf literally '10', + what literally '63', + temp$file$drive$offset literally '50h', + con$type literally '0', + cpmversion literally '30h', + ctrli literally '09h'; + +/**************************************** +* * +* G L O B A L V A R I A B L E S * +* * +****************************************/ + +declare + ln(9) byte initial('00001 : $'), + ln1 byte at(.ln(0)), + ln2 byte at(.ln(1)), + ln3 byte at(.ln(2)), + ln4 byte at(.ln(3)), + ln5 byte at(.ln(4)), + dfcb(36) byte initial(0,'SYSIN $$$',0,0,0), + drec byte at(.dfcb(32)), /* current record */ + drrec address at(.dfcb(33)), /* random record */ + drr2 byte at(.dfcb(35)), /* random record byte 3 */ + dcnt byte, + get$init$pb byte initial(128), /* getrsx sub-functions */ + get$kill$pb byte initial(129), + get$fcb$pb byte initial(130), + sstring(128) byte, /* substitute string */ + sbp byte, /* source buffer pointer */ + ssbp byte, /* sub string buffer pointer */ + ver address, + a address, /* calling program's stack pointer */ + prog$flag based a address; + +declare scbpd structure + (offset byte, + set byte, + value address); + +declare parse$fn structure + (buff$adr address, + fcb$adr address); + +declare subpb structure + (io$type byte, + echo$flag byte, + filtered$flag byte, + program$flag byte) + initial (con$type,true,true,false); + + +declare + ctrlc literally '3', + ctrlx literally '18h', + bksp literally '8', + submit$file$drv literally '15'; + + +/**************************************** +* * +* B D O S F U N C T I O N C A L L S * +* * +****************************************/ + + + +printchar: + procedure(char); + declare char byte; + call mon1(2,char); + end printchar; + +conin: + procedure byte; + return mon2(6,0fdh); + end conin; + +print: procedure(a); + declare a address; + /* print the string starting at address a until the + next dollar sign is encountered */ + call mon1(9,a); + end print; + +read$console$buf: procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address address; + declare max byte; + new$max = max; + call mon1(10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of characters input */ +end read$console$buf; + +version: procedure address; + /* returns current cp/m version */ + return mon3(12,0); + end version; + +open: procedure(fcb) address; + declare fcb address; + return (mon3(15,fcb)); + end open; + +close: procedure(fcb); + declare fcb address; + dcnt = mon2(16,fcb); + end close; + +delete: procedure(fcb); + declare fcb address; + call mon1(19,fcb); + end delete; + +diskread: procedure(fcb) byte; + declare fcb address; + return mon2(20,fcb); + end diskread; + +diskwrite: procedure(fcb) byte; + declare fcb address; + return mon2(21,fcb); + end diskwrite; + + +ranread: procedure(fcb) byte; + declare fcb address; + return mon2(33,fcb); + end ranread; + +make: procedure(fcb); + declare fcb address; + dcnt = mon2(22,fcb); + end make; + +setdma: procedure(dma); + declare dma address; + call mon1(26,dma); + end setdma; + +errormode: procedure(mode); + declare mode byte; + call mon2a(45,mode); + end errormode; + +getscbbyte: procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); +end getscbbyte; + +setscbbyte: + procedure (offset,value); + declare offset byte; + declare value byte; + scbpd.offset = offset; + scbpd.set = 0ffh; + scbpd.value = double(value); + call mon1(49,.scbpd); + end setscbbyte; + +rsx$call: procedure (rsxpb) address; +/* call Resident System Extension */ + declare rsxpb address; + return mon3(60,rsxpb); +end rsx$call; + +/************************************************* +* * +* M A I N S U B R O U T I N E S * +* * +*************************************************/ + +move: procedure(s,d,n); + declare (s,d) address, n byte; + declare a based s byte, b based d byte; + do while (n := n - 1) <> 255; + b = a; s = s + 1; d = d + 1; + end; + end move; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +bad$file: proc; + call print(.('Invalid file name $')); + call mon1(0,0); +end bad$file; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +/* fill string @ s for c bytes with f */ +fill: procedure(s,f,c); + declare s address; + declare (f,c) byte; + declare a based s byte; + do while (c:=c-1) <> 255; + a=f; + s=s+1; + end; +end fill; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +error: procedure(a); + declare a address; + call crlf; + call print(.('Error On Line $')); + call print(.ln1); + call print(a); + call move(.dfcb(0),.sfcb(0),33); + call delete(.sfcb(0)); /* cleanup before exit */ + call mon1(0,0); + /* return to ccp */ + end error; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +ucase: procedure (char) byte; + declare char byte; + if char >= 'a' then + if char < '{' then + return (char-20h); + return char; +end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +getucase: procedure byte; + declare c byte; + c = ucase(conin); + return c; +end getucase; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +getpasswd: procedure; + declare (i,c) byte; + call crlf; + call crlf; + call print(.('Enter Password: $')); +retry: + call fill(.fcb16,' ',8); + do i=0 to 7; +nxtchr: + if (c:=getucase) >= ' ' then + fcb16(i)=c; + if c = cr then + return; + if c = ctrlx then + go to retry; + if c = bksp then do; + if i < 1 then + goto retry; + else do; + fcb16(i := i - 1) = ' '; + goto nxtchr; + end; + end; + if c = 3 then + call mon1(0,0); + end; +end getpasswd; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +deblankparm: procedure; + /* clear to next non-blank substitute string */ + do while (sstring(ssbp) = ' ' or sstring(ssbp) = ctrli); + ssbp = ssbp + 1; + end; +end deblankparm; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +try$open: procedure; + declare error$code address; + call fill(.fcb16,' ',8); /* blank storage for password */ + if len0 <> 0 then + call move(pass0,.fcb16,len0); + call error$mode(0feh); + call setdma(.fcb16); /* set dma to password */ + error$code = open(.sfcb); + if low(error$code) = 0ffh then + if high(error$code) = 7 then do; + call getpasswd; + call crlf; + call setdma(.fcb16); + call error$mode(0); + error$code=open(.sfcb); + end; + else do; + if high(error$code) = 0 then + call print(.('ERROR: No ''SUB'' File Found$')); + call mon1(0,0); + end; + call setdma(.buff(0)); + call error$mode(0); +end try$open; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +setup: procedure; + declare no$chars byte; + declare pstatus address; + declare b byte; + /* move buffer to substitute string */ + call move(.buff(1),.sstring(0),127); + sstring(buff(0))=0; /* mark end of string */ + /* check to see if there are parameters */ + ssbp = 0; + call deblankparm; /* skip over leading spaces */ + if sstring(ssbp) = 0 then do; /* no sub file, prompt for it */ + call print(.('CP/M 3 SUBMIT Version 3.0',cr,lf,'$')); + call print(.('Enter File to SUBMIT: $')); + no$chars = read$console$buf(.buff(0),40); + buff(no$chars+2)=0; /* mark end of input */ + call crlf; + parse$fn.buff$adr = .buff(2); + parse$fn.fcb$adr = .sfcb(0); + pstatus = parse(.parse$fn); + if pstatus = 0FFFFh then + call bad$file; + call move(.buff(2),.sstring(0),127); + end; + call move(.('SUB'),.sfcb(9),3); /* set file type to SUB */ + if sfcb(0) = 0 then + if (b:=getscbbyte(submit$file$drv)) > 0 then do; + sfcb(0)=b; /* set file drive to that saved by CCP */ + call setscbbyte(submit$file$drv,0); + end; + call try$open; + do while (sstring(ssbp) <> ' ' and sstring(ssbp) <> 0 + and sstring(ssbp) <> ctrli); + ssbp = ssbp + 1; /* skip over file name */ + end; + call deblankparm; /* skip over any spaces */ + b = sstring(ssbp); + /* File is open if this point reached */ + sbp = 128; /* causes read below */ + + end setup; + +getsource: procedure byte; + /* read the next source character */ + declare b byte; + if sbp > 127 then + do; if diskread(.sfcb(0)) <> 0 then + return endfile; + sbp = 0; + end; + if (b := buff((sbp:=sbp+1)-1)) = cr then do; + /* increment line */ + if (ln5:=ln5+1) > '9' then do; + ln5 = '0'; + if (ln4:=ln4+1) > '9' then do; + ln4 = '0'; + if (ln3:=ln3+1) > '9' then do; + ln3 = '0'; + if (ln2:=ln2+1) > '9' then do; + ln2 = '0'; + ln1 = ln1 + 1; + end; + end; + end; + end; + end; + return b; + end getsource; + +writebuff: procedure; + /* write the contents of the buffer to disk */ + if diskwrite(.dfcb) <> 0 then /* error */ + call error(.('Disk Write Error$')); + end writebuff; + +declare rbuff(2048) byte, /* jcl buffer */ + rbp address, /* jcl buffer pointer */ + rlen byte; /* length of current command */ + +fillrbuff: procedure; + declare s byte; /* sub string buffer pointer */ + + notend: procedure byte; + /* look at next character in sstring, return + true if not at the end of the string - char passed + back in 's' */ + if not ((s := sstring(ssbp)) = ' ' or s = 0) then + do; + ssbp = ssbp + 1; + return true; + end; + return false; + end notend; + + write$rbuff: procedure; + declare j byte; + declare i address; + rbp=0; i=0; + do while (i < 2048); + do j=0 to 127; + if rbuff(i+j)=sysin$endfile + then goto close$file; + end; + call setdma(.rbuff(i)); + call writebuff; + i=i+128; + end; + call setdma(.buff(0)); + return; + + close$file: + call setdma(.rbuff(i)); + call writebuff; + call setdma(.buff(0)); + drrec, drr2 = 0; /* set to 1st record in file */ + dcnt = ranread(.dfcb); /* read to position at start */ + if dcnt <> 0 then + call error(.('Random Read $')); + goto exit$from$process; + end write$rbuff; + + putrbuff: procedure(b); + declare b byte; + if (rbp > last(rbuff)) then do; + call print(.('.$')); + call write$rbuff; + end; + rbuff(rbp) = b; + if b = sysin$endfile then + call write$rbuff; + rbp = rbp + 1; + end putrbuff; + + declare (reading,b,newline,progline) byte; + /* fill the jcl buffer */ + rbp = 0; + reading = true; + do while reading; + rlen = 0; /* reset command length */ + newline,progline = true; + do while (b:=getsource) <> endfile and b <> cr; + if b <> lf then + do; if b = sysin$endfile then + call error(.('Invalid ASCII Character$')); + if newline then do; /* program input begins with < */ + newline = false; + if b <> '<' then + progline = false; + end; + if b = '$' then /* copy substitute string */ + do; if (b:=getsource) = '$' then + /* $$ replaced by $ */ + call putrbuff(b); else + if (b := b - '0') > 9 then + call error(.('Parameter Error$')); else + do; /* find string 'b' in sstring */ + ssbp = 0; call deblankparm; /* ready to scan string */ + do while b <> 0; b = b - 1; + /* clear next parameter */ + do while notend; + end; + call deblankparm; + end; + /* ready to copy substitute string from position ssbp */ + do while notend; + call putrbuff(s); + end; + end; + end; else /* not a '$' */ + if b = '^' then do; /* possible control character */ + b=getsource; + if b = '^' then + call putrbuff('^'); /* '^^' ==> '^' */ + else do; + if b < '@' then /* number symbols */ + call putrbuff(b-' '); + else + if b < '`' then /* upper case */ + call putrbuff(b-'@'); + else + call putrbuff(b-'`'); /* lower case */ + end; + end; + /* check for multiple commands !! */ + else if b = '!' and not progline then do; + call putrbuff(cr); /* mark eoln with cr, lf */ + call putrbuff(lf); + end; + else /* not $ or ^ */ + call putrbuff(b); + end; + end; /* of line or input file - compute length */ + reading = b = cr; + call putrbuff(cr); /* mark eoln with cr, lf */ + call putrbuff(lf); + end; + /* entire file has been read and processed */ + rbp = rbp - 2; /* back up; too many cr,lf's on last line */ + call putrbuff(sysin$endfile); /* mark end of file */ + end fillrbuff; + +makefile: procedure; + declare i byte; + declare rsxadr addr; + declare rsxbase based rsxadr addr; + + rsxadr = rsx$call(.get$init$pb); + i = high(rsxbase); /* rsxbase = addr of kill flag */ + i = shr(i,2); + dfcb(6) = i/10 + '0'; + dfcb(7) = i mod 10 + '0'; + call errormode(0ffh); /* set to return errors */ + drec = 0; /* zero the next record to write */ + call make(.dfcb); + if dcnt = 255 then do; + call delete(.dfcb); /* file might exist */ + call errormode(0); + call make(.dfcb); /* try make again */ + if dcnt = 255 then do; + call print(.('ERROR: Directory Full$')); + call mon1(0,0); + end; + end; + call errormode(0); +end makefile; + +/************************************************* +* * +* M A I N P R O G R A M * +* * +*************************************************/ + +plm: + ver = version; + if (low(ver) < cpmversion) or (high(ver) = 1) then do; + call print(.('Requires CP/M 3.0 $')); + call mon1(0,0); + end; + dfcb(0)=getscbbyte(temp$file$drive$offset); + call setup; + call makefile; + call fillrbuff; +exit$from$process: + /* check if GET is above us and about to abort */ + a = rsx$call(.get$fcb$pb); + if a <> 0ffh then do; + a = a - 2; + if prog$flag then + a = rsx$call(.get$kill$pb); + end; + call move(.dfcb(0),.sfcb(0),33); /* move to fcb @ 5ch */ + call getf(.subpb); /* GETF also does submit processing */ +end sub; diff --git a/software/CPM/cpm3/subrsx.asm b/software/CPM/cpm3/subrsx.asm new file mode 100644 index 0000000..8759abd --- /dev/null +++ b/software/CPM/cpm3/subrsx.asm @@ -0,0 +1,873 @@ +title 'GET.RSX 3.0 - CP/M 3.0 Input Redirection - August 1982' +;****************************************************************** +; +; get 'Input Redirection Facility' version 3.0 +; +; 11/30/82 - Doug Huskey +; This RSX redirects console input and status from a file. +;****************************************************************** +; +; +true equ 0ffffh +false equ 00000h +; + maclib getrsx ;[JCE] The Get/Submit equate + maclib makedate ;[JCE] Build date +remove$rsx equ false ;true if RSX removes itself +; ;false if LOADER does removes +; +; +; generation procedure +; +; rmac getrsx +; xref getrsx +; link getrsx[op] +; ERA get.RSX +; REN get.RSX=getRSX.PRL +; GENCOM $1.COM get.RSX ($1 is either SUBMIT or GET) +; +; +; initialization procedure +; +; GETF makes a RSX function 60 call with a sub-function of +; 128. GETRSX returns the address of a data table containing: +; +; init$table: +; dw kill ;RSX remove flag addr in GET +; dw bios$constat ;bios entry point in GET +; dw bios$conin ;bios entry point in GET +; +; GETF initializes the data are between movstart: and movend: +; and moves it into GET.RSX. This means that data should not +; be reordered without also changing GETF.ASM. +; +bios$functions equ true ;intercept BIOS console functions +; +; low memory locations +; +wboot equ 0000h +bdos equ 0005h +bdosl equ bdos+1 +buf equ 0080h +; +; equates for non graphic characters +; +ctlc equ 03h ; control c +ctle equ 05h ; physical eol +ctlh equ 08h ; backspace +ctlp equ 10h ; prnt toggle +ctlr equ 12h ; repeat line +ctls equ 13h ; stop/start screen +ctlu equ 15h ; line delete +ctlx equ 18h ; =ctl-u + if submit +ctlz equ 0ffh + else +ctlz equ 1ah ; end of file + endif +rubout equ 7fh ; char delete +tab equ 09h ; tab char +cr equ 0dh ; carriage return +lf equ 0ah ; line feed +ctl equ 5eh ; up arrow +; +; BDOS function equates +; +cinf equ 1 ;read character +coutf equ 2 ;output character +crawf equ 6 ;raw console I/O +creadf equ 10 ;read buffer +cstatf equ 11 ;status +pchrf equ 5 ;print character +pbuff equ 9 ;print buffer +openf equ 15 ;open file +closef equ 16 ;close file +delf equ 19 ;delete file +dreadf equ 20 ;disk read +dmaf equ 26 ;set dma function +userf equ 32 ;set/get user number +scbf equ 49 ;set/get system control block word +loadf equ 59 ;loader function call +rsxf equ 60 ;RSX function call +ginitf equ 128 ;GET initialization sub-function no. +gkillf equ 129 ;GET delete sub-function no. +gfcbf equ 130 ;GET file display sub-function no. +pinitf equ 132 ;PUT initialization sub-funct no. +pckillf equ 133 ;PUT CON: delete sub-function no. +pcfcbf equ 134 ;return PUT CON: fcb address +plkillf equ 137 ;PUT LST: delete sub-function no. +plfcbf equ 138 ;return PUT LST:fcb address +gsigf equ 140 ;signal GET without [SYSTEM] option +jinitf equ 141 ;JOURNAL initialization sub-funct no. +jkillf equ 142 ;JOURNAL delete sub-function no. +jfcbf equ 143 ;return JOURNAL fcb address +; +; System Control Block definitions +; +scba equ 03ah ;offset of scbadr from SCB base +ccpflg equ 0b3h ;offset of ccpflags word from page boundary +ccpres equ 020h ;ccp resident flag = bit 5 +bdosoff equ 0feh ;offset of BDOS address from page boundary +errflg equ 0ach ;offset of error flag from page boundary +pg$mode equ 0c8h ;offset of page mode byte from pag. bound. +pg$def equ 0c9h ;offset of page mode default from pag. bound. +conmode equ 0cfh ;offset of console mode word from pag. bound. +listcp equ 0d4h ;offset of ^P flag from page boundary +dmaad equ 0d8h ;offset of DMA address from pg bnd. +usrcode equ 0e0h ;offset of user number from pg bnd. +dcnt equ 0e1h ;offset of dcnt, searcha & searchl from pg bnd. +constfx equ 06eh ;offset of constat JMP from page boundary +coninfx equ 074h ;offset of conin JMP from page boundary + + +;****************************************************************** +; RSX HEADER +;****************************************************************** + +serial: db 0,0,0,0,0,0 + +trapjmp: + jmp trap ;trap read buff and DMA functions +next: jmp 0 ;go to BDOS +prev: dw bdos +kill: db 0FFh ;0FFh => remove RSX at wstart +nbank: db 0 +rname: db 'GET ' ;RSX name +space: dw 0 +patch: db 0 + +;****************************************************************** +; START OF CODE +;****************************************************************** + +; +; ABORT ROUTINE +; +getout: + ; +if bios$functions + ; + ;restore bios jumps + lda restore$mode ;may be FF, 7f, 80 or 0 + inr a + rz ; FF = no bios interception + lhld biosin + xchg + lhld biosta + call restore$bios ;restore BIOS constat & conin jmps + rm ; 7f = RESBDOS jmps not changed + lhld scbadr + mvi l,constfx + mvi m,jmp + rpe ; 80 = conin jmp not changed + mvi l,coninfx + mvi m,jmp +endif + ret ; 0 = everything done +; +; ARRIVE HERE ON EACH BIOS CONIN OR CONSTAT CALL +; +; +bios$constat: + ; +if bios$functions + ; + ;enter here from BIOS constat + lxi b,4*256+cstatf ;b=offset in exit table + jmp bios$trap +endif +; +bios$conin: + ; +if bios$functions + ; + ;enter here from BIOS conin + lxi b,6*256+crawf ;b=offset in exit table + mvi e,0fdh + jmp biostrap +endif +; +; ARRIVE HERE AT EACH BDOS CALL +; +trap: + ; + ; + lxi h,excess + mvi b,0 + mov m,b +biostrap: + ;enter here on BIOS calls + + pop h ;return address + push h ;back to stack + lda trapjmp+2 ;GET.RSX page address + cmp h ;high byte of return address + jc exit ;skip calls on bdos above here + mov a,c ;function number + ; + ; + cpi cstatf ;status + jz intercept + cpi crawf + jz intercept ;raw I/O + lxi h,statflg ;zero conditional status flag + mvi m,0 + cpi cinf + jz intercept ;read character + cpi creadf + jz intercept ;read buffer + cpi rsxf + jz rsxfunc ;rsx function + cpi dmaf + jnz exit ;skip if not setting DMA + xchg + shld udma ;save user's DMA address + xchg +; +exit: + ;go to real BDOS + +if not bios$functions + ; + jmp next ;go to next RSX or BDOS + +else + mov a,b ;get type of call: + lxi h,exit$table ;0=BDOS call, 4=BIOS CONIN, 6=BIOS CONSTAT + call addhla + mov b,m ;low byte to b + inx h + mov h,m ;high byte to h + mov l,b ;HL = .exit routine + pchl ;gone to BDOS or BIOS +endif +; +; +rsxfunc: ;check for initialize or delete RSX functions + ldax d ;get RSX sub-function number + lxi h,init$table ;address of area initialized by COM file + cpi ginitf + rz + lda kill + ora a + jnz exit + ldax d + cpi gfcbf + lxi h,subfcb + rz +cksig: + cpi gsigf + jnz ckkill + lxi h,get$active + mvi a,gkillf + sub m ;toggle get$active flag + mov m,a ;gkillf->0 0->gkillf + +ckkill: + cpi gkillf ;remove this instance of GET? + jnz exit ;jump if not + + +restor: + lda get$active + ora a + rz + call getout ;bios jump fixup + +if submit + mvi c,closef + call subdos + mvi c,delf + call subdos ;delete SYSIN??.$$$ if not +endif + lxi h,kill + dcr m ;set to 0ffh, so we are removed + xchg ; D = base of this RSX + lhld scbadr + mvi l,ccpflg+1 ;hl = .ccp flag 2 in SCB + mov a,m + ani 0bfh + mov m,a ;turn off redirection flag + ;we must remove this RSX if it is the lowest one + lda bdosl+1 ;location 6 high byte + cmp d ;Does location 6 point to us + RNZ ;return if not +if remove$rsx + xchg ;D = scb page + lhld next+1 + shld bdosl + xchg ;H = scb page + mvi l,bdosoff ;HL = "BDOS" address in SCB + mov m,e ;put next address into SCB + inx h + mov m,d + xchg + mvi l,0ch ;HL = .previous RSX field in next RSX + mvi m,7 + inx h + mvi m,0 ;put previous into previous + ret +else + ; CP/M 3 loader does RSX removal if DE=0 + mvi c,loadf + lxi d,0 + jmp next ;ask loader to remove me +endif + +; +; +; INTERCEPT EACH BDOS CONSOLE INPUT FUNCTION CALL HERE +; +; enter with funct in A, info in DE +; +intercept: +; + lda kill + ora a + jnz exit ;skip if remove flag turned on + ; + ;switch stacks + lxi h,0 + dad sp + shld old$stack + lxi sp,stack + push b ;save function # + push d ;save info + ;check redirection mode + call getmode ;returns with H=SCB page + cpi 2 + jz skip ;skip if no redirection flag on + +if submit +; +; SUBMIT PROCESSOR +; + ;check if CCP is calling +ckccp: mvi l,pg$mode + mov m,H ;set to non-zero for no paging + mvi l,ccpflg+1 ;CCP FLAG 2 in SCB + mov a,m ;ccp flag byte 2 to A + ori 040h + mov m,a ;set redirection flag on + ani ccpres ;zero flag set if not CCP calling + lda ccp$line + jz not$ccp + ;yes, CCP is calling + ora a + jnz redirect ;we have a CCP line + ;CCP & not a CCP line + push h + call coninf ;throw away until next CCP line + lxi h,excess + mov a,m + ora a ;is this the first time? + mvi m,true + lxi d,garbage + mvi c,pbuff + cz next ;print the warning if so + pop h + lda kill + ora a + jz ckccp ;get next character (unless eof) + mov a,m + ani 7fh ;turn off disk reset (CCP) flag + mov m,a + jmp wboot ;skip if remove flag turned on +; +not$ccp: + ;no, its not the CCP + ora a + jnz skip ;skip if no program line + +else + lda program + ora a ;program input only? + mvi l,ccpflg+1 ;CCP FLAG 2 in SCB + mov a,m ;ccp flag byte 2 to A + jz set$no$page ;jump if [system] option + ;check if CCP is calling + ani ccpres ;zero flag set if not CCP calling + jz redirect ;jump if not the CCP + lxi h,ccpcnt ;decrement once for each + dcr m ;time CCP active + cm restor ;if 2nd CCP appearance + lxi d,cksig+1 + mvi c,rsxf ;terminate any GETs waiting for + call next ;us to finish + jmp skip + ; +set$no$page: + ori 40h ;A=ccpflag2, HL=.ccpflag2 + mov m,a ;set redirection flag on + mvi l,pg$mode + mov m,h ;set to non-zero for no paging +endif + ; + ; REDIRECTION PROCESSOR + ; +redirect: + ;break if control-C typed on console + call break + pop d + pop b ;recover function no. & info + push b ;save function + push d ;save info + mov a,c ;function no. to A + lxi h,retmon ;program return routine + push h ;push on stack + ; + ; + cpi creadf + jz func10 ;read buffer (returns to retmon) + cpi cinf + jz func1 ;read character (returns to retmon) + cpi cstatf + jz func11 ;status (returns to retmon) +; +func6: + ;direct console i/o - read if 0ffh + ;returns to retmon + mov a,e + inr a + jz dirinp ;0ffh in E for status/input + inr a + jz CONBRK ;0feh in E for status + lxi h,statflg + mvi m,0 + inr a + jz coninf ;0fdh in E for input + ; + ;direct output function + ; + jmp skip1 + ; +break: ; + ;quit if ^C typed + mvi c,cstatf + call real$bdos + ora a ;was ^C typed? + rz + pop h ;throw away return address + call restor ;remove this RSX, if so + mvi c,crawf + mvi e,0ffh + call next ;eat ^C if not nested + ; +skip: ; + ;reset ^C status mode + call getmode ;returns .conmode+1 + dcx h ;hl = .conmode in SCB + mov a,m + ani 0feh ;turn off control C status + mov m,a + ;restore the BDOS call + pop d ;restore BDOS function no. + pop b ;restore BDOS parameter + ;restore the user's stack +skip1: lhld old$stack + sphl + jmp exit ;goto BDOS + +; +retmon: + ;normal entry point, char in A + cpi ctlz + jz skip + lhld old$stack + sphl + mov l,a + ret ;to calling program + + +;****************************************************************** +; BIOS FUNCTIONS (REDIRECTION ROUTINES) +;****************************************************************** +; +; ;direct console input +dirinp: + call conbrk + ora a + rz +; +; +; get next character from file +; + ; +coninf: +getc: ;return ^Z if end of file + xra a + lxi h,cbufp ;cbuf index + inr m ;next chr position + cm readf ;read a new record + ora a + mvi b,ctlz ;EOF indicator + jnz getc1 ;jump if end of file + lda cbufp + lxi h,cbuf + call addhla ;HL = .char + ;one character look ahead + ;new char in B, current char in nextchr + mov b,m ;new character in B +getc1: mov a,b + cpi ctlz + push b + cz restor + pop b + lxi h,nextchr + mov a,m ;current character + cpi cr + mov m,b ;save next character + rnz + mov a,b ;A=character after CR + cpi lf ;is it a line feed + cz getc ;eat line feeds after a CR + ;this must return from above + ;rnz because nextchr = lf + ; +if submit + ; + mov a,b ;get nextchr + sui '<' ;program line? + sta ccp$line ;zero if so + cz getc ;eat '<' char + ;this must return from above + ;rnz because nextchr = < +endif + mvi a,cr ;get back the cr + ret ;with character in a +; +; set DMA address in DE +; +setdma: mvi c,dmaf + jmp next +; +; read next record +; +readf: mvi c,dreadf ;read next record of input to cbuf +subdos: push b + lxi d,cbuf + call setdma ;set DMA to our buffer + lhld scbadr + lxi d,sav$area ;10 byte save area + pop b ;C = function no. + push h ;save for restore + push d ;save for restore + call mov7 ;save hash info in save area + mvi l,usrcode ;HL = .dcnt in SCB + call mov7 ;save dcnt, searcha & l, user# & + dcx h ;multi-sector I/O count + mvi m,1 ;set multi-sector count = 1 + lxi d,subusr ;DE = .submit user # + mvi l,usrcode ;HL = .BDOS user number + ldax d + mov m,a + inx d + call next ;read next record + pop h ;HL = .sav$area + pop d ;DE = .scb + push psw ;save A (non-zero if error) + call mov7 ;restore hash info + mvi e,usrcode ;DE = .dcnt in scb + call mov7 ;restore dcnt search addr & len + lhld udma + xchg + call setdma ;restore DMA to program's buffer + xra a + sta cbufp ;reset buffer position to 0 + pop psw + ora a + ret ;zero flag set, if successful +; +; reboot from ^C +; +rebootx: + ;store 0fffeh in clp$errcode in SCB + lhld scbadr + mvi l,errflg + mvi m,0feh + inx h + mvi m,0ffh + jmp wboot +; +; +; get input redirection mode to A +; turn on ^C status mode for break +; return .conmode+1 in HL +; preserve registers BC and DE +; +getmode: + lhld scbadr + mvi l,conmode + mov a,m + ori 1 ;turn on ^C status + mov m,a + inx h + mov a,m + ani 3 ;mask off redirection bits + dcr a ;255=false, 0=conditional, 1=true, + ret ; 2=don't redirect input +; +; move routine +; +mov7: mvi b,7 + ; HL = source + ; DE = destination + ; B = count +move: mov a,m + stax d + inx h + inx d + dcr b + jnz move + ret +; +; add a to hl +; +addhla: add l + mov l,a + rnc + inr h + ret +; +;****************************************************************** +; BDOS CONSOLE INPUT ROUTINES +;****************************************************************** + +; +; February 3, 1981 +; +; +; console handlers + +conin: equ coninf +; +conech: + ;read character with echo + call conin! call echoc! rc ;echo character? + ;character must be echoed before return + push psw! call conout! pop psw + ret ;with character in A +; +echoc: + ;are we in cooked or raw mode? + lxi h,cooked! dcr m! inr m! rz ;return if raw + ;echo character if graphic + ;cr, lf, tab, or backspace + cpi cr! rz ;carriage return? + cpi lf! rz ;line feed? + cpi tab! rz ;tab? + cpi ctlh! rz ;backspace? + cpi ' '! ret ;carry set if not graphic +; +conbrk: ;STATUS - check for character ready + lxi h,statflg + mov b,m! mvi m,0ffh ;set conditional status flag true + call getmode ;check input redirection status mode + cpi 1! rz ;actual status mode => return true + ora a! rz ;false status mode => return false + ;conditional status mode => false unless prev func was status + mov a,b! ret ; return false if statflg false + ; return true if statflg true +; +; +ctlout: + ;send character in A with possible preceding up-arrow + call echoc ;cy if not graphic (or special case) + jnc conout ;skip if graphic, tab, cr, lf, or ctlh + ;send preceding up arrow + push psw! mvi a,ctl! call conout ;up arrow + pop psw! ori 40h ;becomes graphic letter + ;(drop through to conout) +; +; +; send character in A to console +; +conout: + mov e,a + lda echo + ora a + rz + mvi c,coutf + jmp next +; +; +read: ;read to buffer address (max length, current length, buffer) + xchg ;buffer address to HL + mov c,m! inx h! push h! mvi b,0 ;save .(current length) + ;B = current buffer length, + ;C = maximum buffer length, + ;HL= next to fill - 1 + readnx: + ;read next character, BC, HL active + push b! push h ;blen, cmax, HL saved + readn0: + call conin ;next char in A + pop h! pop b ;reactivate counters + cpi ctlz! jnz noteof ;end of file? + dcr b! inr b! jz readen ;skip if buffer empty + mvi a,cr ;otherwise return + noteof: + cpi cr! jz readen ;end of line? + cpi lf! jz readen ;also end of line + cpi ctlp! jnz notp ;skip if not ctlp + ;list toggle - change parity + push h! push b ;save counters + lhld scbadr! mvi l,listcp ;hl =.listcp + mvi a,1! sub m ;True-listcp + mov m,a ;listcp = not listcp + pop b! pop h! jmp readnx ;for another char + notp: + ;not a ctlp + ;place into buffer + rdecho: + inx h! mov m,a ;character filled to mem + inr b ;blen = blen + 1 + rdech1: + ;look for a random control character + push b! push h ;active values saved + call ctlout ;may be up-arrow C + pop h! pop b! mov a,m ;recall char + cpi ctlc ;set flags for reboot test + mov a,b ;move length to A + jnz notc ;skip if not a control c + cpi 1 ;control C, must be length 1 + jz rebootx ;reboot if blen = 1 + ;length not one, so skip reboot + notc: + ;not reboot, are we at end of buffer? + cmp c! jc readnx ;go for another if not + readen: + ;end of read operation, store blen + pop h! mov m,b ;M(current len) = B + push psw ;may be a ctl-z + mvi a,cr! call conout ;return carriage + pop psw ;restore character + ret +; +func1: equ conech + ;return console character with echo +; +;func6: see intercept routine at front of module +; +func10: equ read + ;read a buffered console line +; +func11: equ conbrk + ;check console status +; +; + +;****************************************************************** +; DATA AREA +;****************************************************************** + +statflg: db 0 ;non-zero if prev funct was status + ; + ; + +;****************************************************************** +; Following variables and entry points are used by GET.COM +; Their order and contents must not be changed without also +; changing GET.COM. +;****************************************************************** + ; + if bios$functions + ; +exit$table: ;addresses to go to on exit + dw next ;BDOS + endif + ; +movstart: +init$table: ;addresses used by GET.COM for +scbadr: dw kill ;address of System Control Block + ; + if bios$functions ;GET.RSX initialization + ; +biosta dw bios$constat ;set to real BIOS routine +biosin dw bios$conin ;set to real BIOS routine + ; + ;restore only if changed when removed. +restore$mode + db 0 ;if non-zero change LXI @jmpadr to JMP + ;when removed. +restore$bios: + ;hl = real constat routine + ;de = real conin routine + shld 0 ;address of const jmp initialized by COM + xchg + shld 0 ;address of conin jmp initialized by COM + ret + endif + ; +real$bdos: + jmp bdos ;address filled in by COM + ; + ; +echo: db 1 +cooked: db 0 + ; +program: + db 0 ;true if program input only +subusr: db 0 ;user number for redirection file +subfcb: db 1 ;a: + db 'SYSIN ' + db 'SUB' + db 0,0 +submod: db 0 +subrc: ds 1 + ds 16 ;map +subcr: ds 1 + ; +movend: +;******************************************************************* + +cbufp db 128 ;current character position in cbuf +nextchr db cr ;next character (1 char lookahead) + + if submit +ccp$line: + db false ;nonzero if line is for CCP + endif + +cbuf: ;128 byte record buffer + + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + db 3,3,3,3, 3,3,3,3, 3,3,3,3, 3,3,3,3 + +udma: dw buf ;user dma address +get$active: + db gkillf + ; +sav$area: ;14 byte save area (searchn) + db 68h,68h,68h,68h,68h, 68h,68h,68h,68h,68h + db 68h,68h,68h,68h +excess: db 0 +old$stack: + dw 0 + if submit +garbage: +; db cr,lf + db 'WARNING: PROGRAM INPUT IGNORED',cr,lf,'$' + else +ccpcnt: db 1 + endif +patch$area: + ds 30h + db ' ' + @BDATE + db ' ' + @SCOPY + db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h + db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h + db 67h,67h,67h,67h,67h, 67h,67h,67h,67h,67h + ; +stack: ;15 level stack + end + \ No newline at end of file diff --git a/software/CPM/cpm3/timest.plm b/software/CPM/cpm3/timest.plm new file mode 100644 index 0000000..ee8ea87 --- /dev/null +++ b/software/CPM/cpm3/timest.plm @@ -0,0 +1,255 @@ +$title('SDIR - Display Time Stamps') +timestamp: +do; + /* Display time stamp module for extended directory */ + /* Time & Date ASCII Conversion Code */ + /* From MP/M 1.1 TOD program */ + +$include(comlit.lit) + +getscbbyte: procedure (offset) byte external; + declare offset byte; +end getscbbyte; + +print$char: procedure (char) external; + declare char byte; +end print$char; + +terminate: procedure external; +end terminate; + +declare tod$adr address; +declare tod based tod$adr structure ( + opcode byte, + date address, + hrs byte, + min byte, + sec byte, + ASCII (21) byte ); + +declare string$adr address; +declare string based string$adr (1) byte; +declare index byte; + +emitchar: procedure(c); + declare c byte; + string(index := index + 1) = c; + end emitchar; + +emitn: procedure(a); + declare a address; + declare c based a byte; + do while c <> '$'; + string(index := index + 1) = c; + a = a + 1; + end; + end emitn; + +emit$bcd: procedure(b); + declare b byte; + call emitchar('0'+b); + end emit$bcd; + +emit$bcd$pair: procedure(b); + declare b byte; + call emit$bcd(shr(b,4)); + call emit$bcd(b and 0fh); + end emit$bcd$pair; + +emit$colon: procedure(b); + declare b byte; + call emit$bcd$pair(b); + call emitchar(':'); + end emit$colon; + +emit$bin$pair: procedure(b); + declare b byte; + +/* [JCE 17-5-1998] As the comment below makes clear, DIR is not Year2000 + compliant as supplied in 1982. Hence the line below: */ + + b = b mod 100; + call emit$bcd(b/10); /* makes garbage if not < 10 */ + call emit$bcd(b mod 10); + end emit$bin$pair; + +emit$slant: procedure(b); + declare b byte; + call emit$bin$pair(b); + call emitchar('/'); + end emit$slant; + +emit$dash: procedure(b); /* [JCE 18-9-1998] for YMD format dates */ + declare b byte; + call emit$bin$pair(b); + call emitchar('-'); + end emit$dash; + +declare + base$year lit '78', /* base year for computations */ + base$day lit '0', /* starting day for base$year 0..6 */ + month$days (*) address data + /* jan feb mar apr may jun jul aug sep oct nov dec */ + ( 000,031,059,090,120,151,181,212,243,273,304,334); + +leap$days: procedure(y,m) byte; + declare (y,m) byte; + /* compute days accumulated by leap years */ + declare yp byte; + yp = shr(y,2); /* yp = y/4 */ + if (y and 11b) = 0 and month$days(m) < 59 then + /* y not 00, y mod 4 = 0, before march, so not leap yr */ + return yp - 1; + /* otherwise, yp is the number of accumulated leap days */ + return yp; + end leap$days; + +declare word$value address; + +get$next$digit: procedure byte; + /* get next lsd from word$value */ + declare lsd byte; + lsd = word$value mod 10; + word$value = word$value / 10; + return lsd; + end get$next$digit; + +bcd: + procedure (val) byte; + declare val byte; + return shl((val/10),4) + val mod 10; + end bcd; + +declare (month, day, year, hrs, min, sec) byte; + +bcd$pair: procedure(a,b) byte; + declare (a,b) byte; + return shl(a,4) or b; + end bcd$pair; + + +compute$year: procedure; + /* compute year from number of days in word$value */ + declare year$length address; + year = base$year; + do while true; + year$length = 365; + if (year and 11b) = 0 then /* leap year */ + year$length = 366; + if word$value <= year$length then + return; + word$value = word$value - year$length; + year = year + 1; + end; + end compute$year; + +declare + week$day byte, /* day of week 0 ... 6 */ + day$list (*) byte data + ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'), + leap$bias byte; /* bias for feb 29 */ + +compute$month: procedure; + month = 12; + do while month > 0; + if (month := month - 1) < 2 then /* jan or feb */ + leapbias = 0; + if month$days(month) + leap$bias < word$value then return; + end; + end compute$month; + +declare + date$test byte, /* true if testing date */ + test$value address; /* sequential date value under test */ + +get$date$time: procedure; + /* get date and time */ + hrs = tod.hrs; + min = tod.min; + sec = tod.sec; + word$value = tod.date; + /* word$value contains total number of days */ + week$day = (word$value + base$day - 1) mod 7; + call compute$year; + /* year has been set, word$value is remainder */ + leap$bias = 0; + if (year and 11b) = 0 and word$value > 59 then + /* after feb 29 on leap year */ leap$bias = 1; + call compute$month; + day = word$value - (month$days(month) + leap$bias); + month = month + 1; + end get$date$time; + +emit$date$time: procedure; + if tod.opcode = 0 then + do; + call emitn(.day$list(shl(week$day,2))); + call emitchar(' '); + end; + if (get$scb$byte(date$flag$offset) and 3) = 2 then /* [JCE 18-9-1998] YMD-format dates */ + do; + call emit$dash(year); + call emit$dash(month); + call emit$bin$pair(day); + end; + else if (get$scb$byte(date$flag$offset) and 3) = 1 then /* [JCE] UK-format dates */ + do; + call emit$slant(day); + call emit$slant(month); + call emit$bin$pair(year); + end; + else + do; + call emit$slant(month); + call emit$slant(day); + call emit$bin$pair(year); + end; + call emitchar(' '); + call emit$colon(hrs); + call emit$colon(min); + if tod.opcode = 0 then + call emit$bcd$pair(sec); + end emit$date$time; + +tod$ASCII: + procedure (parameter); + declare parameter address; + declare ret address; + + ret = 0; + tod$adr = parameter; + string$adr = .tod.ASCII; + if (tod.opcode = 0) or (tod.opcode = 3) then + do; + call get$date$time; + index = -1; + call emit$date$time; + end; + else + call terminate; /* error */ +end tod$ASCII; + + declare lcltod structure ( + opcode byte, + date address, + hrs byte, + min byte, + sec byte, + ASCII (21) byte ); + +display$time$stamp: procedure (tsadr) public; + dcl tsadr address, + i byte; + + lcltod.opcode = 3; /* display time and date stamp, no seconds */ + call move (4,tsadr,.lcltod.date); /* don't copy seconds */ + + call tod$ASCII (.lcltod); + do i = 0 to 13; + call printchar (lcltod.ASCII(i)); + end; +end display$time$stamp; + +dcl last$data$byte byte initial(0); + +end timestamp; diff --git a/software/CPM/cpm3/type.plm b/software/CPM/cpm3/type.plm new file mode 100644 index 0000000..af53a99 --- /dev/null +++ b/software/CPM/cpm3/type.plm @@ -0,0 +1,676 @@ +$ TITLE('CP/M 3.0 --- TYPE ') +type: +do; + +/* + Copyright (C) 1982 + Digital Research + P.O. Box 579 + Pacific Grove, CA 93950 +*/ + +/* + Revised: + 19 Jan 80 by Thomas Rolander + 14 Sept 81 by Doug Huskey + 07 July 82 by John Knight + 06 Oct 82 by Doug Huskey + 02 Dec 82 by Bruce Skidmore +*/ + +declare + mpmproduct literally '01h', /* requires mp/m */ + cpmversion literally '30h'; /* requires 3.0 cp/m */ + + + /************************************** + * * + * EQUATES (LITERALS) * + * * + **************************************/ + + +declare + true literally '0FFh', + false literally '0', + forever literally 'while true', + lit literally 'literally', + proc literally 'procedure', + dcl literally 'declare', + addr literally 'address', + cr literally '13', + lf literally '10', + ctrli literally '9', + ctrlc literally '3', + ctrlo literally '0fh', + ctrlx literally '18h', + bksp literally '8', + dcnt$offset literally '45h', + searcha$offset literally '47h', + searchl$offset literally '49h', + hash1$offset literally '00h', + hash2$offset literally '02h', + hash3$offset literally '04h', + con$page$mode literally '2ch', + con$page$size literally '1ch'; + + /************************************** + * * + * GLOBAL VARIABLES * + * * + **************************************/ + +declare plm label public; +declare (eod,i,char) byte; +declare control$z literally '1AH'; +declare (cnt,tcnt,code) byte; +declare (ver, error$code) address; +declare paging byte initial (true); +declare negate byte initial (false); +declare status address; +declare m based status byte; +declare no$chars byte; +declare last$dseg$byte byte initial (0); +declare wflag byte initial (false); +declare cur$fcb (33) byte; /* current fcb (to type) */ + +declare + more (*) byte data (cr,lf,cr,lf,'Press RETURN to Continue $'), + failed (*) byte data(cr,lf,'ERROR: Not typed: $'); + + + + /************************************** + * * + * B D O S INTERFACE * + * * + **************************************/ + + + mon1: + procedure (func,info) external; + declare func byte; + declare info address; + end mon1; + + mon2: + procedure (func,info) byte external; + declare func byte; + declare info address; + end mon2; + + mon3: + procedure (func,info) address external; + declare func byte; + declare info address; + end mon3; + + declare cmdrv byte external; /* command drive */ + declare fcb (1) byte external; /* 1st default fcb */ + declare fcb16 (1) byte external; /* 2nd default fcb */ + declare pass0 address external; /* 1st password ptr */ + declare len0 byte external; /* 1st passwd length */ + declare pass1 address external; /* 2nd password ptr */ + declare len1 byte external; /* 2nd passwd length */ + declare tbuff (1) byte external; /* default dma buffer */ + + + /************************************** + * * + * B D O S Externals * + * * + **************************************/ + + read$console: + procedure byte; + return mon2 (1,0); + end read$console; + + printchar: + procedure (char); + declare char byte; + call mon1 (2,char); + end printchar; + + conin: + procedure byte; + return mon2(6,0fdh); + end conin; + + print$buf: + procedure (buff$adr); + declare buff$adr address; + call mon1 (9,buff$adr); + end print$buf; + + read$console$buf: + procedure (buffer$address,max) byte; + declare buffer$address address; + declare new$max based buffer$address address; + declare max byte; + new$max = max; + call mon1(10,buffer$address); + buffer$address = buffer$address + 1; + return new$max; /* actually number of chars input */ + end read$console$buf; + + version: procedure address; + /* returns current cp/m version # */ + return mon3(12,0); + end version; + + check$con$stat: + procedure byte; + return mon2 (11,0); + end check$con$stat; + + open$file: + procedure (fcb$address) address; + declare fcb$address address; + return mon3(15,fcb$address); + end open$file; + + close$file: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (16,fcb$address); + end close$file; + + read$record: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (20,fcb$address); + end read$record; + + setdma: procedure(dma); + declare dma address; + call mon1(26,dma); + end setdma; + + /* 0ff & 0fe = return BDOS errors */ + return$errors: + procedure(mode); + declare mode byte; + call mon1 (45,mode); + end return$errors; + + terminate: + procedure; + call mon1 (0,0); + end terminate; + + + search$first: + procedure (fcb$address) byte; + declare fcb$address address; + return mon2 (17,fcb$address); + end search$first; + + search$next: + procedure byte; + return mon2 (18,0); + end search$next; + + declare scbpd structure + (offset byte, + set byte, + value address); + + getscbbyte: + procedure (offset) byte; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon2(49,.scbpd); + end getscbbyte; + + getscbword: + procedure (offset) address; + declare offset byte; + scbpd.offset = offset; + scbpd.set = 0; + return mon3(49,.scbpd); + end getscbword; + + setscbword: + procedure (offset,value); + declare offset byte; + declare value address; + scbpd.offset = offset; + scbpd.set = 0FEh; + scbpd.value = value; + call mon1(49,.scbpd); + end setscbword; + + set$console$mode: procedure; + /* set console mode to control-c only */ + call mon1(109,1); + end set$console$mode; + + declare + parse$fn structure ( + buff$adr address, + fcb$adr address); + + parse: procedure(pfcb) address external; + declare pfcb address; + end parse; + + + /************************************** + * * + * S U B R O U T I N E S * + * * + **************************************/ + + /* upper case character from console */ +crlf: proc; + call printchar(cr); + call printchar(lf); + end crlf; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /* fill string @ s for c bytes with f */ +fill: proc(s,f,c); + dcl s addr, + (f,c) byte, + a based s byte; + + do while (c:=c-1)<>255; + a = f; + s = s+1; + end; + end fill; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* upper case character from console */ +ucase: proc byte; + dcl c byte; + + if (c:=conin) >= 'a' then + if c < '{' then + return(c-20h); + return c; + end ucase; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* get password and place at fcb + 16 */ +getpasswd: proc; + dcl (i,c) byte; + + call crlf; + call crlf; + call print$buf(.('Password: ','$')); +retry: + call fill(.fcb16,' ',8); + do i = 0 to 7; +nxtchr: + if (c:=ucase) >= ' ' then + fcb16(i)=c; + if c = cr then + go to exit; + if c = ctrlx then + goto retry; + if c = bksp then do; + if i<1 then + goto retry; + else do; + fcb16(i:=i-1)=' '; + goto nxtchr; + end; + end; + if c = 3 then + call terminate; + end; +exit: + c = check$con$stat; /* clear raw I/O mode */ + end getpasswd; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* error message routine */ +error: proc(code); + declare + code byte; + + if code=0 then do; + call print$buf (.('No File','$')); + call terminate; + end; + if code=1 then do; + call print$buf(.(cr,lf,'BDOS Bad Sector$')); + call terminate; + end; + if code=4 then do; + call print$buf(.(cr,lf,'Invalid Drive$')); + call terminate; + end; + if code = 5 then + call print$buf(.('Currently Opened$')); + if code = 7 then + call print$buf(.('Password Error$')); + end error; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* print file name */ +print$file: procedure(fcbp); + declare (k,c) byte; + declare typ lit '9'; /* file type */ + declare fnam lit '11'; /* file type */ + declare + fcbp addr, + fcbv based fcbp (32) byte; + + if fcbv(0) <> 0 then do; + call printchar(fcbv(0)+'@'); + call printchar(':'); + end; + + do k = 1 to fnam; + if k = typ then + call printchar('.'); + if (c := (fcbv(k) and 7fh)) <> ' ' then + call printchar(c); + end; + +end print$file; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +error$opt: procedure (code); + declare code byte; + call print$buf(.('ERROR: $')); + if code = 0 then + call print$buf(.('Invalid or missing delimiter(s) $')); + if code = 1 then + call print$buf(.('Try ''PAGE'' or ''NO PAGE'' $')); + call terminate; +end error$opt; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +input$found: procedure (buffer$adr) byte; + declare buffer$adr address; + declare char based buffer$adr byte; + do while (char = ' ') or (char = 9); /* tabs & spaces */ + buffer$adr = buffer$adr + 1; + end; + if char = 0 then /* eoln */ + return false; /* input not found */ + else + return true; /* input found */ +end input$found; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +scanques: procedure(str$addr) byte; + declare str$addr address; + declare char based str$addr byte; + declare i byte; + declare wildcard byte; + + i = 0; + wildcard = false; + do while (i < 11); + if char = '?' then + wildcard = true; + i = i + 1; + str$addr = str$addr + 1; + end; /* do while */ + return wildcard; +end scanques; + +/*- - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ + + /* skip over blanks or tabs in command */ +page$test: procedure; + + if cnt <> 0 then + if (tcnt:=tcnt+1) >= cnt then do; + call print$buf(.more); + tcnt = conin; + call print$char(cr); + if tcnt = ctrlc then + call terminate; + if tcnt = ctrlo then + eod = true; + tcnt = -1; + end; +end page$test; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + /* type a file specified by FCB */ +type$file: procedure; + + call return$errors(0FFh); /* return after error message */ + call setdma(.fcb16); /* set dma to password */ + curfcb(6) = curfcb(6) or 80h; /* open in RO mode */ + curfcb(12) = 0; /* open zero extent */ + error$code = open$file (.curfcb); + if low(error$code) = 0FFh then + if (code := high(error$code)) = 7 then do; + call getpasswd; + call crlf; + call setdma(.fcb16); /* set dma to password */ + curfcb(6) = curfcb(6) or 80h; /* open in RO mode */ + call return$errors(0); + error$code = open$file(.curfcb); + end; + else do; + call print$buf(.failed); + call print$file(.curfcb); + call printchar(' '); + call error(code); + end; + if low(error$code) <> 0FFH then + do; + call return$errors(0); /* reset error mode */ + call setdma(.tbuff); + curfcb(32) = 0; + eod = 0; + do while (not eod) and (read$record (.curfcb) = 0); + do i = 0 to 127; + if (char := tbuff(i)) = control$z + then eod = true; + if not eod then + do; + if check$con$stat then do; + tcnt = conin; + call terminate; /* terminate only on ctrl-c */ + end; + if cnt <> 0 then + do; + if char = 0ah then + call page$test; + end; + call printchar (char); + end; + end; + end; + /* necessary to close under MP/M & Concurrent + call close (.curfcb); + */ + end; + else call error(0); + +end type$file; + +/*- - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ + + /* try typing files one at a time */ +multi$file: + procedure; + declare (code,dcnt) byte; + declare (nextfcb$adr,savdcnt,savsearcha,savsearchl) addr; + declare nextfcb based nextfcb$adr (32) byte; + declare (hash1,hash2,hash3) address; + + call setdma(.tbuff); + if (dcnt:=search$first(.fcb)) = 0ffh then + call error(0); + + do while dcnt <> 0ffh; + nextfcb$adr = shl(dcnt,5) + .tbuff; + savdcnt = getscbword(dcnt$offset); + savsearcha = getscbword(searcha$offset); + savsearchl = getscbword(searchl$offset); + /* save searched fcb's hash code (5 bytes) */ + hash1 = getscbword(hash1$offset); + hash2 = getscbword(hash2$offset); + hash3 = getscbword(hash3$offset); /* saved one extra byte */ + call move(16,nextfcb$adr,.curfcb); /* copy matched filename */ + curfcb(0) = fcb(0); /* set drive */ + call page$test; + call crlf; + call print$file(.curfcb); + call printchar(':'); + call page$test; + call crlf; + call type$file; + call setdma(.tbuff); + call setscbword(dcnt$offset,savdcnt); + call setscbword(searcha$offset,savsearcha); + call setscbword(searchl$offset,savsearchl); + /* restore hash code */ + call setscbword(hash1$offset,hash1); + call setscbword(hash2$offset,hash2); + call setscbword(hash3$offset,hash3); + if .fcb <> savsearcha then /*restore orig fcb if destroyed*/ + call move(16,.fcb,savsearcha); + dcnt = search$next; + end; +end multi$file; + +/*- - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ + + /* skip over blanks or tabs in command */ +eat$blanks: procedure; + do while (m = ' ') or (m = ctrli); + status = status + 1; + end; +end eat$blanks; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + /************************************** + * * + * M A I N P R O G R A M * + * * + **************************************/ + +plm: + do; + ver = version; + if (low(ver) < cpmversion) or (high(ver) = mpmproduct) then do; + call print$buf (.('Requires CP/M 3.0','$')); + call terminate; + end; + + call set$console$mode; /* set program interrupt to control-c only */ + + /* get command */ + if not input$found(.tbuff(1)) then do; + /* prompt for file */ + call print$buf(.('Enter file: $')); + no$chars = read$console$buf(.tbuff(0),40); + call print$buf(.(cr,lf,'$')); + tbuff(1) = ' '; /* blank out nc field */ + tbuff(no$chars+2)=0; /* mark eoln */ + /* convert input to upper case */ + do i = 2 to no$chars+1; + if tbuff(i) >= 'a' then + if tbuff(i) < '}' then + tbuff(i) = tbuff(i) - 20h; + end; + end; + + /* parse command for file and options */ + tcnt,cnt = 0; + parse$fn.buff$adr = .tbuff(1); + parse$fn.fcb$adr = .fcb; + status = parse(.parse$fn); + if status = 0FFFFh then do; + call print$buf(.('ERROR: Invalid file name. $')); + call terminate; + end; + + /* get default paging mode */ + if getscbbyte(con$page$mode) <> 0 then + paging = false; + + /* check for options */ + if (status <> 0) then do; /* options follow? */ + call eat$blanks; + if m = 0 then goto continue; /* no options found */ + /* check for page option */ + if m <> '[' then + call error$opt(0); + status = status + 1; + call eat$blanks; + if m = 'N' then do; + status = status + 1; + if (m = 'O') or (m = ' ') then do; + status = status + 1; + negate = true; + end; + else + call error$opt(1); + call eat$blanks; + end; + + if m = 'P' then + paging = true; + else + call error$opt(1); + status = status + 1; + if ( m = ']' ) or ( m = 0 ) then + goto continue; + else if m <> 'A' then + goto end$opt; + status = status + 1; + if ( m = ']' ) or ( m = 0 ) then + goto continue; + else if m <> 'G' then + goto end$opt; + status = status + 1; + if ( m = ']' ) or ( m = 0 ) then + goto continue; + else if m <> 'E' then + goto end$opt; + status = status + 1; + end$opt: + call eat$blanks; + if ( m <> ']' ) and ( m <> 0 ) then + call error$opt(1); + end; + continue: + + /* check for negation of paging */ + if negate then + paging = not paging; + + /* get page size */ + if paging then do; + cnt = getscbbyte(con$page$size)-2; + if cnt = 0 then cnt = 22; /* by default, 22 lines on screen */ + end; + else + cnt = 0; /* no paging */ + + /* check for wild card or single file */ + wflag = scanques(.fcb); + if wflag = true then + call multi$file; + else do; + call move(16,.fcb,.curfcb); + call type$file; + end; + call terminate; + end; +end type; diff --git a/software/CPM/cpm3/util.plm b/software/CPM/cpm3/util.plm new file mode 100644 index 0000000..6037a65 --- /dev/null +++ b/software/CPM/cpm3/util.plm @@ -0,0 +1,148 @@ +$title('SDIR - Utility Routines') +utility: +do; + +/* Utility Module for SDIR */ + +$include(comlit.lit) + + +/* -------- arithmetic functions -------- */ + +add3byte: procedure(byte3adr,num) public; + dcl (byte3adr,num) address, + b3 based byte3adr structure ( + lword address, + hbyte byte), + temp address; + + temp = b3.lword; + if (b3.lword := b3.lword + num) < temp then /* overflow */ + b3.hbyte = b3.hbyte + 1; +end add3byte; + + /* add three byte number to 3 byte value structure */ +add3byte3: procedure(totalb,numb) public; + dcl (totalb,numb) address, + num based numb structure ( + lword address, + hbyte byte), + total based totalb structure ( + lword address, + hbyte byte); + + call add3byte(totalb,num.lword); + total.hbyte = num.hbyte + total.hbyte; +end add3byte3; + + /* divide 3 byte value by 8 */ +shr3byte: procedure(byte3adr) public; + dcl byte3adr address, + b3 based byte3adr structure ( + lword address, + hbyte byte), + temp1 based byte3adr (2) byte, + temp2 byte; + + temp2 = ror(b3.hbyte,3) and 11100000b; /* get 3 bits */ + b3.hbyte = shr(b3.hbyte,3); + b3.lword = shr(b3.lword,3); + temp1(1) = temp1(1) or temp2; /* or in 3 bits from hbyte */ +end shr3byte; + + +/* ------- print routines -------- */ + +mon1: procedure(f,a) external; + declare f byte, a address; +end mon1; + +break: procedure external; +end break; + +$include(fcb.lit) + +/* BDOS calls */ + +print$char: procedure(char) public; + declare char byte; + call mon1(2,char); +end print$char; + +print: procedure(string$adr) public; + dcl string$adr address; + call mon1(9,string$adr); +end print; + +printb: procedure public; + call print$char(' '); +end printb; + +crlf: procedure public; + call print$char(cr); + call print$char(lf); +end crlf; + +printfn: procedure(fname$adr) public; + dcl fname$adr address, + file$name based fname$adr (1) byte, + i byte; /* ' ' */ + + do i = 0 to f$namelen - 1; + call printchar(file$name(i) and 7fh); + end; + call printchar(' '); + do i = f$namelen to f$namelen + f$typelen - 1; + call printchar(file$name(i) and 7fh); + end; +end printfn; + +pdecimal: procedure(v,prec,zerosup) public; + /* print value v, field size = (log10 prec) + 1 */ + /* with leading zero suppression if zerosup = true */ + declare v address, /* value to print */ + prec address, /* precision */ + zerosup boolean, /* zero suppression flag */ + d byte; /* current decimal digit */ + + do while prec <> 0; + d = v / prec; /* get next digit */ + v = v mod prec; /* get remainder back to v */ + prec = prec / 10; /* ready for next digit */ + if prec <> 0 and zerosup and d = 0 then + call printb; + else + do; + zerosup = false; + call printchar('0'+d); + end; + end; +end pdecimal; + +p3byte: procedure(byte3adr,prec) public; + /* print 3 byte value with 0 suppression */ + dcl byte3adr address, /* assume high order bit is < 10 */ + prec address, + b3 based byte3adr structure ( + lword address, + hbyte byte), + i byte; + + /* prec = 1 for 6 chars, 2 for 7 */ + if b3.hbyte <> 0 then + do; + call pdecimal(b3.hbyte,prec,true); /* 3 for 8 chars printed */ + call pdecimal(b3.lword,10000,false); + end; + else + do; + i = 1; + do while i <= prec; + call printb; + i = i * 10; + end; + call pdecimal(b3.lword,10000,true); + end; +end p3byte; + +end utility; diff --git a/software/CPM/cpm3/utils/conv86 b/software/CPM/cpm3/utils/conv86 new file mode 100644 index 0000000..b4ee6ba Binary files /dev/null and b/software/CPM/cpm3/utils/conv86 differ diff --git a/software/CPM/cpm3/utils/hexobj b/software/CPM/cpm3/utils/hexobj new file mode 100644 index 0000000..136e296 Binary files /dev/null and b/software/CPM/cpm3/utils/hexobj differ diff --git a/software/CPM/cpm3/utils/link b/software/CPM/cpm3/utils/link new file mode 100644 index 0000000..f44e717 Binary files /dev/null and b/software/CPM/cpm3/utils/link differ diff --git a/software/CPM/cpm3/utils/link.ovl b/software/CPM/cpm3/utils/link.ovl new file mode 100644 index 0000000..31aa7a2 Binary files /dev/null and b/software/CPM/cpm3/utils/link.ovl differ diff --git a/software/CPM/cpm3/utils/locate b/software/CPM/cpm3/utils/locate new file mode 100644 index 0000000..0020ac7 Binary files /dev/null and b/software/CPM/cpm3/utils/locate differ diff --git a/software/CPM/cpm3/utils/objhex b/software/CPM/cpm3/utils/objhex new file mode 100644 index 0000000..3ebad01 Binary files /dev/null and b/software/CPM/cpm3/utils/objhex differ diff --git a/software/CPM/cpm3/utils/submit b/software/CPM/cpm3/utils/submit new file mode 100644 index 0000000..d9a6e2f Binary files /dev/null and b/software/CPM/cpm3/utils/submit differ diff --git a/software/CPM/cpm3/utl0mov.asm b/software/CPM/cpm3/utl0mov.asm new file mode 100644 index 0000000..c2c0b74 --- /dev/null +++ b/software/CPM/cpm3/utl0mov.asm @@ -0,0 +1,104 @@ + TITLE 'SID UTILITY RELOCATOR 12/26/77' +; +; THE SID UTILITY RELOCATOR PERFORMS THE MOVE AND RELOCATION +; REQUIRED TO PLACE THE UTILITY DIRECTLY BELOW THE DEBUGGER. +; +; THE RELOCATABLE IMAGE IS CREATED BY: +; (ASSEMBLE THE ORG 000H FILE) +; MAC X $PP+S +; (SAVE THE REL-0 HEX FILE) +; REN X0.HEX=X.HEX +; (ASSEMBLE THE ORG 100H FILE) +; MAC X $PZ+R +; (COMBINE THE REL0 AND REL1 IMAGES) +; PIP X.HEX=X0.HEX,X.HEX +; (CREATE THE RELOCATABLE IMAGE) +; GENMOD X.HEX X.COM +; (INCLUDE THE RELOCATOR) +; SID X.COM +; (THEN NOTE THE LXI ADDRESS FIELD-) +; L100 +; (ASSUME THE INSTRUCTION IS LXI D,V) +; (INCLUDE THE RELOCATOR) +; IUMOV.HEX +; R +; (PATCH THE LXI B) +; A100 +; LXI B,V +; +; (NOW SAVE THE IMAGE) +; G0 +; (CONVERT THE HIGH ADDRESS, AND) +; SAVE D X.UTL +; (WHERE D IS THE HIGH ADDRESS IN DECIMAL) +; + ORG 100H +BDOS EQU 0005H +MODULE EQU 200H ;MODULE ADDRESS +; + LXI B,0 ;ADDRESS FIELD FILLED-IN WHEN MODULE BUILT + PUSH B ;USING DDT'S STACK + LXI H,BDOS+2;ADDRESS FIELD OF JUMP TO BDOS (TOP MEMORY) +; CHECK LEAST SIGNIFICANT BYTE OF SIZE FIELD + MOV A,C + ORA A ;ZERO FLAG SET IF = 00H + MOV A,M ;A HAS HIGH ORDER ADDRESS OF MEMORY TOP + JZ NODEC + DCR A ;PAGE DIRECTLY BELOW BDOS +NODEC: SUB B ;A HAS HIGH ORDER ADDRESS OF RELOC AREA + MOV D,A + MVI E,0 ;D,E ADDRESSES BASE OF RELOC AREA + PUSH D ;SAVE FOR RELOCATION BELOW +; + LXI H,MODULE;READY FOR THE MOVE +MOVE: MOV A,B ;BC=0? + ORA C + JZ RELOC + DCX B ;COUNT MODULE SIZE DOWN TO ZERO + MOV A,M ;GET NEXT ABSOLUTE LOCATION + STAX D ;PLACE IT INTO THE RELOC AREA + INX D + INX H + JMP MOVE +; +RELOC: ;STORAGE MOVED, READY FOR RELOCATION +; HL ADDRESSES BEGINNING OF THE BIT MAP FOR RELOCATION + POP D ;RECALL BASE OF RELOCATION AREA + POP B ;RECALL MODULE LENGTH + PUSH H ;SAVE BIT MAP BASE IN STACK + MOV H,D ;RELOCATION BIAS IS IN D +; +REL0: MOV A,B ;BC=0? + ORA C + JZ ENDREL +; +; NOT END OF THE RELOCATION, MAY BE INTO NEXT BYTE OF BIT MAP + DCX B ;COUNT LENGTH DOWN + MOV A,E + ANI 111B ;0 CAUSES FETCH OF NEXT BYTE + JNZ REL1 +; FETCH BIT MAP FROM STACKED ADDRESS + XTHL + MOV A,M ;NEXT 8 BITS OF MAP + INX H + XTHL ;BASE ADDRESS GOES BACK TO STACK + MOV L,A ;L HOLDS THE MAP AS WE PROCESS 8 LOCATIONS +REL1: MOV A,L + RAL ;CY SET TO 1 IF RELOCATION NECESSARY + MOV L,A ;BACK TO L FOR NEXT TIME AROUND + JNC REL2 ;SKIP RELOCATION IF CY=0 +; +; CURRENT ADDRESS REQUIRES RELOCATION + LDAX D + ADD H ;APPLY BIAS IN H + STAX D +REL2: INX D ;TO NEXT ADDRESS + JMP REL0 ;FOR ANOTHER BYTE TO RELOCATE +; +ENDREL: ;END OF RELOCATION + POP D ;CLEAR STACKED ADDRESS + MVI L,0 +; HL IS THE MODULE ADDRESS - GO THERE TO ALTER BRANCHES + PCHL ;GONE... + END + \ No newline at end of file diff --git a/software/CPM/cpm3/utl1hst.asm b/software/CPM/cpm3/utl1hst.asm new file mode 100644 index 0000000..d9dc257 --- /dev/null +++ b/software/CPM/cpm3/utl1hst.asm @@ -0,0 +1,364 @@ + ORG 000H + TITLE 'SID HISTOGRAM UTILITY 12/26/77' +; +; COPYRIGHT (C) 1976,1977 +; DIGITAL RESEARCH +; BOX 579 PACIFIC GROVE +; CALIFORNIA 93950 +; +; HISTOGRAM OF PROGRAM EXECUTION FREQUENCY +; DDT ENTRY POINT +BDOSE EQU 5 ;PRIMARY BDOS ENTRY POINT +DDTBASE EQU 7*8+1 ;RESTART ENTRY POINT HAS BASE +HISTO: JMP SETUP ;INITIAL ENTRY FROM RELOCATOR +; +; SYMBOL TABLE INITIALIZED TO INITIAL, COLLECT, DISPLAY +SYBASE: + DB 'YALPSID',7,LOW DISE,HIGH DISE ;DISPLAY + DB 'TCELLOC',7,LOW COLE,HIGH COLE ;COLLECT + DB 'LAITINI',7,LOW INIE,HIGH INIE ;INITIAL +SYLEN EQU $-SYBASE ;LENGTH OF ADDITIONAL SYMBOLS +; +INIE: JMP INITIAL +COLE: JMP COLLECT +DISE: JMP DISPLAY + DB 'COPYRIGHT (C) 1977 DIGITAL RESEARCH ' +; DDT SUBROUTINES +GETBUFF: +; READ NEXT COMMAND BUFFER + LXI B,3 + JMP GODDT +; +GNC: ;READ NEXT CHARACTER TO REGISTER A + + LXI B,6 + JMP GODDT +; +PCHAR: ;PRINT CHARACTER FROM REGISTER A + + LXI B,9 + JMP GODDT +; +PBYTE: ;PRINT DECODED BYTE FROM REGISTER A + + LXI B,12 + JMP GODDT +; +; +PADDR: ;PRINT THE ADDRESS GIVEN BY D,E + PUSH D ;SAVE THE ADDRESS FOR THE PRINT + MOV A,D ;PRINT HIGH ADDRESS + CALL PBYTE + POP D ;RECALL + MOV A,E ;LOW ADDRESS + JMP PBYTE ;RETURN THROUGH PBYTE +; +SCANEXP: +; SCAN COMMAND LINE FOR 1,2, OR 3 EXPRESSIONS + LXI B,18 + JMP GODDT +; +GETVAL: +; READ NEXT VALUE FROM SCANEXP CALL TO H,L + LXI B,21 +; +GODDT: ;PERFORM THE DDT CALL + LHLD DDTBASE + DAD B + PCHL +; +; CONSTANTS +CR EQU 0DH +LF EQU 0AH +HSIZE EQU 64 ;SIZE OF HISTOGRAM (MUST CORRESPOND TO SHR6) +; +; USEFUL SUBROUTINES +DIFF: ;COMPUTE THE DIFFERENCE: DE = DE - HL + MOV A,E + SUB L + MOV E,A + MOV A,D + SBB H + MOV D,A + RET +; +SHR6: ;DIVIDE H,L BY 64 (MUST CORRESPOND TO HSIZE) + MOV A,L + MOV L,H + MVI H,0 + DAD H ;HIGH ORDER * 2 + DAD H ;HIGH ORDER * 4 + RLC ;MOVE HIGH TWO BITS OF LOW BYTE + RLC ;TO POSITION IN A + ANI 11B ;MASK TO REPLACE LOW BITS OF H,L + ORA L + MOV L,A + RET +; +CRLF: ;SEND CRLF CHARACTERS + MVI A,CR + CALL PCHAR + MVI A,LF + CALL PCHAR + RET +; +PRINT: ;PRINT MESSAGE IN D,E 'TIL FIRST ZERO + LDAX D + ORA A + RZ +; MORE TO PRINT + INX D + PUSH D + CALL PCHAR + POP D + JMP PRINT +; +; PRINCIPAL PROCESSORS +SETUP: ;ARRIVE HERE FROM THE RELOCATOR, SET UP JUMPS + LHLD BDOSE+1 ;PRIMARY ENTRY TO BDOS + SHLD HISTO+1 ;CHANGE JUMP AT BASE OF THIS MODULE + LXI H,HISTO ;CHANGE BDOS ENTRY ADDRESS + SHLD BDOSE+1 ;INITIAL JUMP ADDRESS CHANGED +; +; THE PRIMARY BDOS ENTRY ADDRESS NOW REFLECTS THE ADDITION +; OF THE TRACE MODULE, THE SYMBOL TABLE HAS BEEN INCLUDED +; AT THE BEGINNING OF THE MODULE, AND ITS LENGTH WILL BE +; RETURNED WITH THE "INITIAL" CALL IN REGS DE + JMP INITIAL +; +INERR: LXI D,ERMSG + CALL PRINT +; +INITIAL: + LXI D,BOUNDS ;SEND STARTING MESSAGE + CALL PRINT + CALL GETBUFF ;GET BUFFER FULL FOR BOUNDS SCAN + CALL SCANEXP ;SHOULD BE 2 PARAMETERS + JC INERR ;CANNOT BE ,X,X + CPI 2 + JNZ INERR ;1,3? + CALL GETVAL ;FIRST PARAMTER TO H,L + SHLD LB ;LOWER BOUND SAVED + PUSH H ;COMPARED WITH UPPER BOUND LATER + CALL GETVAL ;UPPER BOUND + INX H + SHLD UB + POP D ;LOWER IN D,E UPPER IN H,L + XCHG + CALL DIFF ;UB>=LB? + JC INERR +; DIFFERENCE IN D,E - COMPUTE INCREMENT + XCHG + CALL SHR6 ;DIVIDE BY 64 + SHLD INC + LXI H,HVEC ;CLEAR THE HISTGRAM VECTOR + MVI C,HSIZE*2 +FILL0: MVI M,0 + INX H + DCR C + JNZ FILL0 +; VECTOR FILLED, GO BACK TO THE DEBUGGER + LXI D,INIMSG + CALL PRINT + LXI D,INIE + CALL PADDR ;INITIAL = XXXX + LXI D,COLMSG + CALL PRINT + LXI D,COLE + CALL PADDR ;COLLECT = XXXX + LXI D,DISMSG + CALL PRINT + LXI D,DISE + CALL PADDR ;DISPLAY = XXXX + LXI D,SYLEN ;NUMBER OF SYMBOLS + RET +; +; +; +COLLECT: +; CALLED FROM DEBUGGER WITH REGISTER C HOLDING THE OPERATOR +; CATEGORY (NOT USED HERE), AND D,E HOLDING THE PC + PUSH D ;SAVE THE PC + LHLD UB ;WITHIN THE RANGE LB - UB? + XCHG + CALL DIFF ;X = UB - PC + POP D + JC RET0 ;SKIP IF BELOW LB + LHLD LB + CALL DIFF ;X = PC - LB + JC RET0 +; +; D,E HAS INDEX TO HIST VECTOR + MVI C,0 ;READY TO COUND INDEX TO PROPER ELEMENT IN HVEC + LHLD INC ;AMOUNT IN EACH CATEGORY +FINDCELL: + CALL DIFF ;X = X - INC + JC FOUND + INR C ;TO NEXT HVEC ELEMENT + JMP FINDCELL +; +; REG C HAS INDEX TO HVECT +FOUND: + MVI B,0 ;BECOMES DOUBLE PRECISION + LXI H,HVEC + DAD B + DAD B ;HVECT(X) + MOV E,M ;OLD VALUE OF HVEC(X) + INX H + MOV D,M ;TO D,E, READY FOR INCREMENT + INX D ;COUNT UP BY ONE, CHECK FOR 0FFFFH + MOV M,D + DCX H + MOV M,E ;REPLACED IN MEMORY + INX D ;0FFFFH GOES TO 0000H + MOV A,D + ORA E + JNZ RET0 ;NORMAL RETURN IF NOT 0FFFFH +; +; ONE CATEGORY FILLED, STOP EXECUTION + MVI A,1 + RET +; +RET0: ;RETURN 0 TO CONTINUE COLLECTION + MVI A,0 + RET +; +; +; +DISPLAY: +; DISPLAY THE HISTOGRAM COLLECTED SO FAR +; FIND LARGEST VALUE TO SCAL DIAGRAM + LXI H,HVEC + MVI C,HSIZE + LXI D,0 ;MAX SO FAR +LARG0: PUSH D ;SAVE LARGEST + MOV E,M + INX H + MOV D,M ;D,E HOLDS TEST ELEMENT + INX H ;READY FOR NEXT ELEMENT + XTHL ;LARGEST TO H,L ADDRESS TO STACK + PUSH D ;SAVE TEST + CALL DIFF ;X = TEST - LARGEST + POP D ;RESTORE TEST VALUE + XCHG ;LARGEST IN D,E - TEST IN H,L + JC LARG1 ;CARRY IF LARGEST > TEST + XCHG ;TEST GOES TO D,E +LARG1: DCR C ;COUNT LENGTH DOWN + POP H ;RECALL HVEC ADDRESS + JNZ LARG0 ;FOR ANOTHER TEST +; +; MAX IS IN D,E + XCHG ;TO H,L + PUSH H ;SAVE LARGEST FOR PRINTING BELOW + CALL SHR6 ;DIVIDE BY 64 FOR SCALING + INX H ;IN CASE OF REMAINDER + SHLD SCALE + LXI D,LARMSG + CALL PRINT + POP D ;RECALL LARGEST VALUE + CALL PADDR + XRA A ;CLEAR ZERCNT + STA ZERCNT +; +; NOW STEP THROUGH THE HIST VECTOR AND PRINT '*' FOR EACH LINE + LHLD LB + XCHG ;LOWER BOUND TO D,E + LXI B,HVEC ;BASE OF HIST VECTOR +DISP0: PUSH D ;SAVE CURRENT LINE ADDRESS + LHLD UB ;TEST FOR OVER THE TOP + CALL DIFF + POP D + JNC DISP1 ;NO CARRY IF CURRENT >= UB +; CHECK FOR MULTIPLE BLANK LINES AND PRINT .... INSTEAD + MOV H,B ;HIGH ORDER HVEC INDEX + MOV L,C ;LOW ORDER HVEC INDEX + MOV A,M ;LOW ORDER HVEC VALUE + INX H + ORA M ;VALUE = 0? + LXI H,ZERCNT + JNZ ZCHK1 ;VALUE IS NOT ZERO, PRINT LINE +; VALUE IS ZERO, ALREADY PRINTED? + MOV A,M ;GET ZERCNT + ORA A + JNZ ZCHK0 ;JUMP IF ALREADY PRINTED LINE +; NOT PRINTED YET, SET ZERCNT TO TRUE AND PRINT MSG + MVI M,0FFH + PUSH B + PUSH D + LXI D,PERMSG + CALL PRINT + POP D + POP B +ZCHK0: ;INCREMENT LINE ADDRESS + LHLD INC + DAD D + XCHG +; INCREMENT HVEC ADDRESS + INX B + INX B + JMP DISP0 +; +ZCHK1: ;LINE IS NOT ZERO, FLAG IT AND CONTINUE + MVI M,0 ;ZERCNT SET FALSE + PUSH B ;INDEX TO HVEC SAVED + PUSH D ;CURRENT LINE SAVED + PUSH D ;ANOTHER COPY + CALL CRLF + POP D ;LINE ADDRESS TO DE + CALL PADDR ;PRINTED + POP D ;RECALL LINE ADDRESS + LHLD INC ;INCREMENT BETWEEN LINES + DAD D + XTHL ;LINE ADDRESS STACKED, INDEX TO HVEC IN HL + MOV E,M + INX H + MOV D,M + INX H + PUSH H ;SAVE UPDATED HVEC ADDRESS + CALL STARS ;PRINTS STARS FOR THIS LINE + POP B ;RECALL HVEC BASE + POP D ;RECALL CURRENT LINE + JMP DISP0 +; +DISP1: ;END OF DISPLAY + CALL CRLF + RET ;RETURN TO DDT +; +STARS: ;PRINT STARS ACROSS LINE BASED ON SCALE VALUE + MOV A,E + ORA D + RZ ;RETURN IF ZERO STARS + PUSH D + MVI A,' ' + CALL PCHAR +; + POP D +STAR0: ;LOOP PRINTING STARS + LHLD SCALE ;SCALING FACTOR + CALL DIFF ;X = SIZE - SCALE + RC + PUSH D ;SAVE REMAINING LENGTH + MVI A,'*' + CALL PCHAR + POP D + JMP STAR0 +; +; +; DATA AREAS +ERMSG: DB CR,LF,'ERROR - FORM IS X,Y',0 +BOUNDS: DB CR,LF,'TYPE HISTOGRAM BOUNDS ',0 +LARMSG: DB CR,LF,'HISTOGRAM:' + DB CR,LF,'ADDR RELATIVE FREQUENCY, LARGEST VALUE = ',0 +INIMSG: DB CR,LF,'.INITIAL = ',0 +COLMSG: DB CR,LF,'.COLLECT = ',0 +DISMSG: DB CR,LF,'.DISPLAY = ',0 +PERMSG: DB CR,LF,'....',0 +ZERCNT: DS 1 +LB: DS 2 ;LOWER BOUND +UB: DS 2 ;UPPER BOUND +HVEC: DS HSIZE*2 ;HISTOGRAM VECTOR +SCALE: DS 2 ;SCALE FACTOR +INC: DS 2 ;INCREMENT BETWEEN LINES + NOP + END HISTO + \ No newline at end of file diff --git a/software/CPM/cpm3/utl2trc.asm b/software/CPM/cpm3/utl2trc.asm new file mode 100644 index 0000000..c73f823 --- /dev/null +++ b/software/CPM/cpm3/utl2trc.asm @@ -0,0 +1,230 @@ + ORG 000H + TITLE 'SID INSTRUCTION BACKTRACE UTILITY 12/26/77' +; +; BACKTRACE INSTRUCTIONS IN SID +; +; COPYRIGHT (C) 1977 +; DIGITAL RESEARCH +; BOX 579, PACIFIC GROVE, CA. +; 93950 +; +; ENTRY VECTOR +TRAC: JMP SETUP +; +SYBASE: +; SYMBOL TABLE SET-UP FOR SID + DB 'YALPSID',7,LOW DISE,HIGH DISE ;DISPLAY + DB 'TCELLOC',7,LOW COLE,HIGH COLE ;COLLECT + DB 'LAITINI',7,LOW INIE,HIGH INIE ;INITIAL +SYLEN EQU $-SYBASE ;LENGTH OF SYMBOL TABLE +; +INIE: JMP INITIAL +COLE: JMP COLLECT +DISE: JMP DISPLAY +; + DB 'COPYRIGHT (C) 1977, DIGITAL RESEARCH ' +; +BDOSE EQU 0005H ;PRIMARY BDOS ENTRY POINT +DDTBASE EQU 7*8+1 ;ADDRESS OF DDT ENTRY VECTOR +CR EQU 0DH +LF EQU 0AH +; +PRLABEL: + ;PRINT SYMBOLIC LABEL GIVEN BY HL + LXI B,27 + JMP GODDT +; +PCHAR: ;PRINT CHARACTER FROM REGISTER A + LXI B,9 + JMP GODDT +; +PADDR: ;PRINT ADDRESS FROM D,E + PUSH D ;SAVE A COPY + MOV A,D ;HIGH ADDRESS + CALL PBYTE ;PRINT BYTE VALUE + POP D ;RECALL ADDRESS + MOV A,E ;LOW VALUE +; (DROP THROUGH TO PRINT BYTE) +PBYTE: ;PRINT BYTE VALUE FROM A + LXI B,12 +GODDT: LHLD DDTBASE ;GET ENTRY TO DDT FROM RST 7 LOCATION + DAD B + PCHL +; +PRINT: ;PRINT MESSAGE IN D,E 'TIL FIRST ZERO + LDAX D + ORA A + RZ +; MORE TO PRINT + INX D + PUSH D + CALL PCHAR + POP D + JMP PRINT +; +CRLF: ;PRINT CARRIAGE RETURN LINE FEED + PUSH B + PUSH D + MVI A,CR + CALL PCHAR + MVI A,LF + CALL PCHAR + POP D + POP B + RET +; +SETUP: + ;ARRIVE HERE FROM RELOCATOR TO SETUP BRANCHES + LHLD BDOSE+1 ;PREVIOUS BDOS ENTRY ADDRESS + SHLD TRAC+1 ;CHANGE FIRST JMP ADDRESS + LXI H,TRAC ;ADDRESS OF FIRST JMP + SHLD BDOSE+1 ;CHANGE BDOS ENTRY ADDRESS +; +INITIAL: +; PRINT ENTRY POINT ADDRESSES + LXI D,INIMSG + CALL PRINT + LXI D,INIE + CALL PADDR + LXI D,COLMSG + CALL PRINT + LXI D,COLE + CALL PADDR + LXI D,DISMSG + CALL PRINT + LXI D,DISE + CALL PADDR +; +; DETERMINE IF THE DISASSEMBLER IS PRESENT + LDA DDTBASE+1 ;HIGH ORDER ADDRESS OF DDT TO REG-A + CPI ENDMOD SHR 8 + JNZ INIT1 +; DISASSEMBLER HAS BEEN OVERLAYED + LXI D,OVERMSG + MVI A,1 ;MARK AS ADDRESSES ONLY + JMP INIT2 +INIT1: ;MARK AS FULL TRACE + XRA A + LXI D,UNDMSG +; +INIT2: STA DISFLG ;SET TO 1 IF ADDRESSES ONLY + CALL PRINT + LXI H,COUNT + MVI M,0 ;ZERO THE INSTRUCTION COUNT + LXI H,ABUFF ;ADDRESS BUFFER + SHLD NEXT ;NEXT TO FILL AT BEGINNING OF BUFFER + LXI D,SYLEN ;LENGTH OF SYMBOL TABLE + RET ;BACK TO DDT +; +COLLECT: +; ENTER WITH INSTRUCTION ADDRESS IN D,E + LXI H,COUNT + MOV A,M ;INSTRUCTION COUNT + ORA A + JM FULLC ;STOP AT 128 COUNTS + INR M ;NOT AT 128 YET +FULLC: LHLD NEXT ;NEXT POSITION TO FILL + MOV M,E + INR L ;WRAP-AROUND ON PAGE + MOV M,D + INR L + SHLD NEXT + XRA A + RET ;RETURN TO DDT WITH ZERO FLAG +; +DISPLAY: +; ENTER WITH C=1 IF ONLY ADDRESS TRACE IS REQUESTED + LXI H,DISFLG + MOV A,M + ORA C ;DISFLG = 1 IF DISASSEMBLER NOT PRESENT + MOV C,A + PUSH B + LXI D,TRMSG ;TRACE MESSAGE + CALL PRINT + POP B + LXI H,COUNT + MOV B,M ;QUEUE SIZE IN B + XRA A ;CLEAR COLUMN COUNT + STA COLUMN + MOV A,C + ORA A ;ADDRESS MODE? + JNZ DISP0 +; SAVE OLD PC FROM DISASSEMBLER + LHLD PC + SHLD TPC +DISP0: LHLD NEXT +; +DISP1: ;DISPLAY COLLECTED ADDRESSES OR INSTRUCTIONS + MOV A,B ;QUEUE SIZE + ORA A + JZ ENDISP + DCR B ;COUNT SIZE DOWN + PUSH B ;SAVE COUNT AND MODE + DCR L ;ADDRESS LAST HIGH ORDER ADDRESS + MOV D,M + DCR L ;ADDRESS LAST LOW ORDER ADDRESS + MOV E,M + PUSH H ;SAVE NEXT TO GET + XCHG +; CHECK MODE OF DISPLAY + MOV A,C + ORA A + JZ FDISP ;FULL DISPLAY? +; +; PARTIAL ADDRESS DISPLAY + XCHG ;READY FOR ADDRESS PRINTING + LXI H,COLUMN + MOV A,M + INR M + ANI 111B ;COUNTS 0-7 + CZ CRLF ;START NEW LINE + CALL PADDR + MVI A,' ' + CALL PCHAR + JMP EDISP +; +FDISP: SHLD PC ;READY FOR DECODE + CALL PRLABEL ;OPTIONAL LABEL + MVI A,2 + STA PAGM ;TO DISPLAY ONE LINE + CALL DISENT ;DISPLAYED +EDISP: POP H ;RECOVER NEXT TO DECODE + POP B ;RECOVER COUNT + JMP DISP1 +; +ENDISP: ;END OF DISPLAY + MOV A,C + ORA A + RZ ;RETURN WITHOUT RESTORING PC + LHLD TPC + SHLD PC ;DISASSEMBLER'S PC RESTORED + RET +; +; MESSAGES +INIMSG: DB CR,LF,'INITIAL = ',0 +COLMSG: DB CR,LF,'COLLECT = ',0 +DISMSG: DB CR,LF,'DISPLAY = ',0 +OVERMSG: + DB CR,LF,'"-A" IN EFFECT, ADDRESS BACKTRACE',0 +UNDMSG: DB CR,LF,'READY FOR SYMBOLIC BACKTRACE',0 +TRMSG: DB CR,LF,'BACKTRACE:',0 +; +; DATA AREAS +COUNT: DB 0 +NEXT: DW ABUFF +TPC: DS 2 +DISFLG: DS 1 ;1 IF ADDRESSES ONLY +COLUMN: DS 1 ;COLUMN COUNT IF ADDRESSES ONLY +NPAGE EQU ($ + 100H) AND 0FF00H ;NEXT PAGE ADDRESS + DS NPAGE-$ ;SPACE FROM CURRENT LOCATION +; ADDRESS BUFFER IS ON A PAGE BOUNDARY +ABUFF: DS 255 + DB 0 +ENDMOD EQU $ +; +DISEM EQU ENDMOD ;DISASSEMBLER ENTRY POINTS +PC EQU DISEM+0CH +PAGM EQU DISEM+10H +DISENT EQU DISEM+06H + END + \ No newline at end of file diff --git a/software/CPM/cpm3/vers.lit b/software/CPM/cpm3/vers.lit new file mode 100644 index 0000000..75b4694 --- /dev/null +++ b/software/CPM/cpm3/vers.lit @@ -0,0 +1,5 @@ +declare + bdos20 lit '20h', + bdos30 lit '30h', + mpm lit '01h', + mpm86 lit '11h'; diff --git a/software/CPM/cpm3/xfcb.lit b/software/CPM/cpm3/xfcb.lit new file mode 100644 index 0000000..e95f19a --- /dev/null +++ b/software/CPM/cpm3/xfcb.lit @@ -0,0 +1,22 @@ + +declare /* XFCB */ + xfcb$type lit '10h', /* identifier on disk */ + xf$passmode lit '12', /* pass word protection mode */ + xf$pass lit '16', /* XFCB password */ + passlen lit '8', /* password length */ + xf$create lit '24', /* creation/access time stamp */ + xf$update lit '28'; /* update time stamp */ + +declare /* directory label: special case of XFCB */ + dirlabeltype lit '20h', /* identifier on disk */ + dl$password lit '128', /* masks on data byte */ + dl$access lit '64', + dl$update lit '32', + dl$makexfcb lit '16', + dl$exists lit '1'; + +declare /* password mode of xfcb */ + pm$read lit '80h', + pm$write lit '40h', + pm$delete lit '20h'; + diff --git a/software/MZF/BASIC.MZF b/software/MZF/BASIC.MZF new file mode 100644 index 0000000..eb98bdc Binary files /dev/null and b/software/MZF/BASIC.MZF differ diff --git a/software/MZF/CPM223.MZF b/software/MZF/CPM223.MZF index 888138a..aaecb60 100644 Binary files a/software/MZF/CPM223.MZF and b/software/MZF/CPM223.MZF differ diff --git a/software/MZF/sharpmz-test.mzf b/software/MZF/sharpmz-test.mzf deleted file mode 100644 index 826d0ba..0000000 Binary files a/software/MZF/sharpmz-test.mzf and /dev/null differ diff --git a/software/NASCAS/3dnc.cas b/software/NASCAS/3dnc.cas new file mode 100644 index 0000000..6fc1bde Binary files /dev/null and b/software/NASCAS/3dnc.cas differ diff --git a/software/NASCAS/Adventr.cas b/software/NASCAS/Adventr.cas new file mode 100644 index 0000000..8c8e2d5 Binary files /dev/null and b/software/NASCAS/Adventr.cas differ diff --git a/software/NASCAS/Camel.cas b/software/NASCAS/Camel.cas new file mode 100644 index 0000000..6e4feff Binary files /dev/null and b/software/NASCAS/Camel.cas differ diff --git a/software/NASCAS/Dame.cas b/software/NASCAS/Dame.cas new file mode 100644 index 0000000..d620584 Binary files /dev/null and b/software/NASCAS/Dame.cas differ diff --git a/software/NASCAS/Filter.cas b/software/NASCAS/Filter.cas new file mode 100644 index 0000000..78e2a51 Binary files /dev/null and b/software/NASCAS/Filter.cas differ diff --git a/software/NASCAS/Ldgold.cas b/software/NASCAS/Ldgold.cas new file mode 100644 index 0000000..023e2d8 Binary files /dev/null and b/software/NASCAS/Ldgold.cas differ diff --git a/software/NASCAS/Schiffe.cas b/software/NASCAS/Schiffe.cas new file mode 100644 index 0000000..068fcd2 Binary files /dev/null and b/software/NASCAS/Schiffe.cas differ diff --git a/software/NASCAS/Scramble.cas b/software/NASCAS/Scramble.cas new file mode 100644 index 0000000..7102c5b Binary files /dev/null and b/software/NASCAS/Scramble.cas differ diff --git a/software/NASCAS/Snailr.cas b/software/NASCAS/Snailr.cas new file mode 100644 index 0000000..17f8c47 Binary files /dev/null and b/software/NASCAS/Snailr.cas differ diff --git a/software/NASCAS/Startrek.cas b/software/NASCAS/Startrek.cas new file mode 100644 index 0000000..400cd7b Binary files /dev/null and b/software/NASCAS/Startrek.cas differ diff --git a/software/NASCAS/Swinghs.cas b/software/NASCAS/Swinghs.cas new file mode 100644 index 0000000..6c61121 Binary files /dev/null and b/software/NASCAS/Swinghs.cas differ diff --git a/software/NASCAS/Swords.cas b/software/NASCAS/Swords.cas new file mode 100644 index 0000000..065943b Binary files /dev/null and b/software/NASCAS/Swords.cas differ diff --git a/software/NASCAS/Symdiff.cas b/software/NASCAS/Symdiff.cas new file mode 100644 index 0000000..6087a72 Binary files /dev/null and b/software/NASCAS/Symdiff.cas differ diff --git a/software/NASCAS/The_Invaders.cas b/software/NASCAS/The_Invaders.cas new file mode 100644 index 0000000..351af4c Binary files /dev/null and b/software/NASCAS/The_Invaders.cas differ diff --git a/software/NASCAS/Vector.cas b/software/NASCAS/Vector.cas new file mode 100644 index 0000000..bca54e0 Binary files /dev/null and b/software/NASCAS/Vector.cas differ diff --git a/software/NASCAS/alieninv.cas b/software/NASCAS/alieninv.cas new file mode 100644 index 0000000..069a24f Binary files /dev/null and b/software/NASCAS/alieninv.cas differ diff --git a/software/NASCAS/amaster.cas b/software/NASCAS/amaster.cas new file mode 100644 index 0000000..5b23b04 Binary files /dev/null and b/software/NASCAS/amaster.cas differ diff --git a/software/NASCAS/bio.cas b/software/NASCAS/bio.cas new file mode 100644 index 0000000..6a6cb71 Binary files /dev/null and b/software/NASCAS/bio.cas differ diff --git a/software/NASCAS/bio2.cas b/software/NASCAS/bio2.cas new file mode 100644 index 0000000..f077826 Binary files /dev/null and b/software/NASCAS/bio2.cas differ diff --git a/software/NASCAS/drive.cas b/software/NASCAS/drive.cas new file mode 100644 index 0000000..f780113 Binary files /dev/null and b/software/NASCAS/drive.cas differ diff --git a/software/NASCAS/hangman.cas b/software/NASCAS/hangman.cas new file mode 100644 index 0000000..d91d6fd Binary files /dev/null and b/software/NASCAS/hangman.cas differ diff --git a/software/NASCAS/hello.cas b/software/NASCAS/hello.cas new file mode 100644 index 0000000..0a84a6b Binary files /dev/null and b/software/NASCAS/hello.cas differ diff --git a/software/NASCAS/keyskraal.cas b/software/NASCAS/keyskraal.cas new file mode 100644 index 0000000..1b859f8 Binary files /dev/null and b/software/NASCAS/keyskraal.cas differ diff --git a/software/NASCAS/labyrb.cas b/software/NASCAS/labyrb.cas new file mode 100644 index 0000000..1ebe483 Binary files /dev/null and b/software/NASCAS/labyrb.cas differ diff --git a/software/NASCAS/limo.cas b/software/NASCAS/limo.cas new file mode 100644 index 0000000..c85c759 Binary files /dev/null and b/software/NASCAS/limo.cas differ diff --git a/software/NASCAS/lunar2.cas b/software/NASCAS/lunar2.cas new file mode 100644 index 0000000..a574a5d Binary files /dev/null and b/software/NASCAS/lunar2.cas differ diff --git a/software/NASCAS/maloche.cas b/software/NASCAS/maloche.cas new file mode 100644 index 0000000..fc62902 Binary files /dev/null and b/software/NASCAS/maloche.cas differ diff --git a/software/NASCAS/moonbase.cas b/software/NASCAS/moonbase.cas new file mode 100644 index 0000000..cb7b587 Binary files /dev/null and b/software/NASCAS/moonbase.cas differ diff --git a/software/NASCAS/othello.cas b/software/NASCAS/othello.cas new file mode 100644 index 0000000..fcb75b2 Binary files /dev/null and b/software/NASCAS/othello.cas differ diff --git a/software/NASCAS/quest.cas b/software/NASCAS/quest.cas new file mode 100644 index 0000000..5d70573 Binary files /dev/null and b/software/NASCAS/quest.cas differ diff --git a/software/NASCAS/sheepdog.cas b/software/NASCAS/sheepdog.cas new file mode 100644 index 0000000..caeb02f Binary files /dev/null and b/software/NASCAS/sheepdog.cas differ diff --git a/software/NASCAS/srmbl.cas b/software/NASCAS/srmbl.cas new file mode 100644 index 0000000..359cce8 Binary files /dev/null and b/software/NASCAS/srmbl.cas differ diff --git a/software/NASCAS/startk16.cas b/software/NASCAS/startk16.cas new file mode 100644 index 0000000..a542000 Binary files /dev/null and b/software/NASCAS/startk16.cas differ diff --git a/software/NASCAS/wraptrap.cas b/software/NASCAS/wraptrap.cas new file mode 100644 index 0000000..8114cfc Binary files /dev/null and b/software/NASCAS/wraptrap.cas differ diff --git a/software/asm/BASIC.asm b/software/asm/BASIC.asm new file mode 100644 index 0000000..da5be50 --- /dev/null +++ b/software/asm/BASIC.asm @@ -0,0 +1,7861 @@ +;----------------------------------------------------------------------------------------------- + ; NASCOM ROM BASIC Ver 4.7, (C) 1978 Microsoft +; Scanned from source published in 80-BUS NEWS from Vol 2, Issue 3 +; (May-June 1983) to Vol 3, Issue 3 (May-June 1984) +; Adapted for the freeware Zilog Macro Assembler 2.10 to produce +; the original ROM code (checksum A934H). PA +; +; This BASIC has been created from the original NASCOM v4.7b source and also +; may have elements of Grant Searle's changes as both were used in creating this +; version. +; +; It has undergone extensive modification: +; 1. Restore the CLOAD/CSAVE commands. These commands load/save tokenised cassette +; images. The cassette images are from the NASCOM but converted with the +; 'nasconv' C program which removes the tape formatting, updates the token values +; and address pointers. +; 2. Add LOAD/SAVE commands. These commands load/save BASIC in text format. +; 3. Restored the SCREEN command so it works with the Sharp MZ80A 40/80 column screen. +; 4. Increased the command word table to allow additional commands which I expect to add. +; I've added additional comments as things have been figured out to aid future understanding. +; +; Thus (C)opyright notices: +; Original source is: (C) 1978 Microsoft +; Updates (some reversed out): Grant Searle, http://searle.hostei.com/grant/index.html +; eMail: home.micros01@btinternet.com +; All other updates (C) Philip Smart, 2020. http://www.eaw.app philip.smart\@net2net.org +;----------------------------------------------------------------------------------------------- + + + ; Bring in additional resources. + INCLUDE "BASIC_Definitions.asm" + INCLUDE "Macros.asm" + + ; Sharp MZ-80A Tape Format Header - used by all software including RFS/TZFS + ; in processing/loading of this file. + ; + ORG 10F0h + + DB 01h ; Code Type, 01 = Machine Code. + DB "MZ80A BASIC V1.0", 0Dh ; Title/Name (17 bytes). +HEADER1:IF BUILD_MZ80A = 1 + DW CODEEND - CODESTART ; Size of program. + DW CODESTART ; Load address of program. + DW CODESTART ; Exec address of program. + ENDIF +HEADER2:IF BUILD_TZFS = 1 + DW (CODEEND - CODESTART) + (RELOCEND - RELOC) ; Size of program. + DW 01200H ; Load address of program. + DW RELOC ; Exec address of program. + ENDIF + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h ; Comment (104 bytes). + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h + DB 00h, 00h, 00h, 00h, 00h, 00h, 00h, 00h + + ; Load address of this program when first loaded. + ; +BUILD1: IF BUILD_MZ80A = 1 + ORG 1200H + ENDIF + +BUILD2: IF BUILD_TZFS = 1 + ORG 0000H + ENDIF + +CODESTART: + +COLD: JP STARTB ; Jump for cold start +WARM: JP WARMST ; Jump for warm start +STARTB: + LD IX,0 ; Flag cold start + JP CSTART ; Jump to initialise + + DW DEINT ; Get integer -32768 to 32767 + DW ABPASS ; Return integer in AB + + +VECTORS:IF BUILD_TZFS = 1 + ALIGN 0038H + ORG 0038H +INTVEC: DS 3 ; Space for the Interrupt vector. + + ALIGN 0066H + ORG 0066H +NMIVEC: DS 3 ; Space for the NMI vector. + ENDIF + +CSTART: DI ; Disable Interrupts and sat mode. NB. Interrupts are physically disabled by 8255 Port C2 set to low. + IM 1 + LD SP,STACK ; Start of workspace RAM + +MEMSW0: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_0 ; Ensure the top part of RAM is set to use the mainboard as we need to configure hardware. + OUT (MMCFG),A + ENDIF + +INITST: LD A,0 ; Clear break flag + LD (BRKFLG),A + + LD HL,GVARSTART ; Start of global variable area + LD BC,GVAREND-GVARSTART ; Size of global variable area. + XOR A + LD D,A +INIT1: LD (HL),D ; Clear variable memory including stack space. + INC HL + DEC BC + LD A,B + OR C + JR NZ,INIT1 + ; + CALL MODE ; Configure 8255 port C, set Motor Off, VGATE to 1 (off) and INTMSK to 0 (interrupts disabled). + LD A,000H ; Clear the screen buffer. + LD HL,SCRN + CALL CLR8 + LD A,017H ; Blue background, white characters in colour mode. Bit 7 is set as a write to bit 7 @ DFFFH selects 80Char mode. + LD HL,ARAM + CALL CLR8 + LD A,004H + LD (TEMPW),A ; Setup the tempo for sound output. + +INIT3: ; Setup keyboard buffer control. + LD A,0 + LD (KEYCOUNT),A ; Set keyboard buffer to empty. + LD HL,KEYBUF + LD (KEYWRITE),HL ; Set write pointer to beginning of keyboard buffer. + LD (KEYREAD),HL ; Set read pointer to beginning of keyboard buffer. + + ; Setup keyboard rate control and set to CAPSLOCK mode. + ; (0 = Off, 1 = CAPSLOCK, 2 = SHIFTLOCK). + LD A,000H ; Initialise key repeater. + LD (KEYRPT),A + LD A,001H + LD (SFTLK),A ; Setup shift lock, default = off. + + ; Setup the initial cursor, for CAPSLOCK this is a double underscore. + LD A,03EH + LD (FLSDT),A + LD A,080H ; Cursor on (Bit D7=1). + LD (FLASHCTL),A + + ; Change to 80 character mode. + LD A, 128 ; 80 char mode. + LD (DSPCTL), A + CALL MLDSP + CALL BEL ; Beep to indicate startup - for cases where screen is slow to startup. + LD A,0FFH + LD (SWRK),A + + ; Setup timer interrupts + LD IX,TIMIN ; Pass the interrupt service handler vector. + LD BC,00000H ; Time starts at 00:00:00 01/01/1980 on initialisation. + LD DE,00000H + LD HL,00000H + CALL TIMESET + ; + LD A,05H ; Enable interrupts at hardware level, this must be done before switching memory mode. + LD (KEYPF),A + ; +MEMSW1: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_2 ; Enable the full 64K memory range before starting BASIC initialisation. + OUT (MMCFG),A + ENDIF + + ; Clear memory + LD HL,WRKSPC +MEMSZ1: IF BUILD_MZ80A = 1 + LD BC,MAXMEM - WRKSPC ; Clear to top of physical RAM. + ENDIF +MEMSZ2: IF BUILD_TZFS = 1 + LD BC,10000H - WRKSPC ; Clear to top of physical RAM. + ENDIF + LD E,00H +INIT4: LD (HL),E + INC HL + DEC BC + LD A,B + OR C + JR NZ,INIT4 + ; + EI + ; +INIT: LD DE,INITAB ; Initialise workspace + LD B,INITBE-INITAB+3 ; Bytes to copy + LD HL,WRKSPC ; Into workspace RAM +COPY: LD A,(DE) ; Get source + LD (HL),A ; To destination + INC HL ; Next destination + INC DE ; Next source + DEC B ; Count bytes + JP NZ,COPY ; More to move + ;LD SP,HL ; Temporary stack + CALL CLREG ; Clear registers and stack + CALL PRNTCRLF ; Output CRLF + LD (BUFFER+72+1),A ; Mark end of buffer + LD (PROGST),A ; Initialise program area + + LD HL,MAXMEM + LD DE,0-50 ; 50 Bytes string space + LD (LSTRAM),HL ; Save last available RAM + ADD HL,DE ; Allocate string space + LD (STRSPC),HL ; Save string space + CALL CLRPTR ; Clear program area + LD HL,(STRSPC) ; Get end of memory + LD DE,0-17 ; Offset for free bytes + ADD HL,DE ; Adjust HL + LD DE,PROGST ; Start of program text + LD A,L ; Get LSB + SUB E ; Adjust it + LD L,A ; Re-save + LD A,H ; Get MSB + SBC A,D ; Adjust it + LD H,A ; Re-save + PUSH HL ; Save bytes free + LD HL,SIGNON ; Sign-on message + CALL PRS ; Output string + POP HL ; Get bytes free back + CALL PRNTHL ; Output amount of free memory + LD HL,BFREE ; " Bytes free" message + CALL PRS ; Output string + +WARMST: LD SP,STACK ; Temporary stack +BRKRET: CALL CLREG ; Clear registers and stack + JP PRNTOK ; Go to get command line + +; FUNCTION ADDRESS TABLE + +FNCTAB: DW SGN + DW INT + DW ABS + DW USR + DW FRE + DW INP + DW POS + DW SQR + DW RND + DW LOG + DW EXP + DW COS + DW SIN + DW TAN + DW ATN + DW PEEK + DW DEEK + DW POINT + DW LEN + DW STR + DW VAL + DW ASC + DW CHR + DW HEX + DW BIN + DW LEFT + DW RIGHT + DW MID + +; RESERVED WORD LIST + +WORDS: DB 'E'+80H,"ND" ; 0x80 + DB 'F'+80H,"OR" ; 0x81 + DB 'N'+80H,"EXT" ; 0x82 + DB 'D'+80H,"ATA" ; 0x83 + DB 'I'+80H,"NPUT" ; 0x84 + DB 'D'+80H,"IM" ; 0x85 + DB 'R'+80H,"EAD" ; 0x86 + DB 'L'+80H,"ET" ; 0x87 + DB 'G'+80H,"OTO" ; 0x88 + DB 'R'+80H,"UN" ; 0x89 + DB 'I'+80H,"F" ; 0x8a + DB 'R'+80H,"ESTORE" ; 0x8b + DB 'G'+80H,"OSUB" ; 0x8c + DB 'R'+80H,"ETURN" ; 0x8d + DB 'R'+80H,"EM" ; 0x8e + DB 'S'+80H,"TOP" ; 0x8f + DB 'O'+80H,"UT" ; 0x90 + DB 'O'+80H,"N" ; 0x91 + DB 'N'+80H,"ULL" ; 0x92 + DB 'W'+80H,"AIT" ; 0x93 + DB 'D'+80H,"EF" ; 0x94 + DB 'P'+80H,"OKE" ; 0x95 + DB 'D'+80H,"OKE" ; 0x96 + DB 'S'+80H,"CREEN" ; 0x97 + DB 'L'+80H,"INES" ; 0x98 + DB 'C'+80H,"LS" ; 0x99 + DB 'W'+80H,"IDTH" ; 0x9a + DB 'M'+80H,"ONITOR" ; 0x9b + DB 'S'+80H,"ET" ; 0x9c + DB 'R'+80H,"ESET" ; 0x9d + DB 'P'+80H,"RINT" ; 0x9e + DB 'C'+80H,"ONT" ; 0x9f + DB 'L'+80H,"IST" ; 0xa0 + DB 'C'+80H,"LEAR" ; 0xa1 + DB 'C'+80H,"LOAD" ; 0xa2 + DB 'C'+80H,"SAVE" ; 0xa3 + DB 'L'+80H,"OAD" ; 0xa4 + DB 'S'+80H,"AVE" ; 0xa5 + DB 'N'+80H,"EW" ; 0xa6 <- Command list terminator word, move to lowest command. Update the ZNEW variable below as well. + ; <- Reserved space for new commands. + DB 'R'+80H,"EM" ; 0xa7 + DB 'R'+80H,"EM" ; 0xa8 + DB 'R'+80H,"EM" ; 0xa9 + DB 'R'+80H,"EM" ; 0xaa + DB 'R'+80H,"EM" ; 0xab + DB 'R'+80H,"EM" ; 0xac + DB 'R'+80H,"EM" ; 0xad + DB 'R'+80H,"EM" ; 0xae + DB 'R'+80H,"EM" ; 0xaf + DB 'R'+80H,"EM" ; 0xb0 + DB 'R'+80H,"EM" ; 0xb1 + DB 'R'+80H,"EM" ; 0xb2 + DB 'R'+80H,"EM" ; 0xb3 + DB 'R'+80H,"EM" ; 0xb4 + DB 'R'+80H,"EM" ; 0xb5 + DB 'R'+80H,"EM" ; 0xb6 + DB 'R'+80H,"EM" ; 0xb7 + DB 'R'+80H,"EM" ; 0xb8 + DB 'R'+80H,"EM" ; 0xb9 + DB 'R'+80H,"EM" ; 0xba + DB 'R'+80H,"EM" ; 0xbb + DB 'R'+80H,"EM" ; 0xbc + DB 'R'+80H,"EM" ; 0xbd + DB 'R'+80H,"EM" ; 0xbe + DB 'R'+80H,"EM" ; 0xbf + + DB 'T'+80H,"AB(" ; 0xc0 <- 0xa5 + DB 'T'+80H,"O" ; 0xc1 <- 0xa6 + DB 'F'+80H,"N" ; 0xc2 <- 0xa7 + DB 'S'+80H,"PC(" ; 0xc3 <- 0xa8 + DB 'T'+80H,"HEN" ; 0xc4 <- 0xa9 + DB 'N'+80H,"OT" ; 0xc5 <- 0xaa + DB 'S'+80H,"TEP" ; 0xc6 <- 0xab + + DB '+'+80H ; 0xc7 <- 0xac + DB '-'+80H ; 0xc8 <- 0xad + DB '*'+80H ; 0xc9 <- 0xae + DB '/'+80H ; 0xca <- 0xaf + DB '^'+80H ; 0xcb <- 0xb0 + DB 'A'+80H,"ND" ; 0xcc <- 0xb1 + DB 'O'+80H,"R" ; 0xcd <- 0xb2 + DB '>'+80H ; 0xce <- 0xb3 + DB '='+80H ; 0xcf <- 0xb4 + DB '<'+80H ; 0xd0 <- 0xb5 + + DB 'S'+80H,"GN" ; 0xd1 <- 0xb6 + DB 'I'+80H,"NT" ; 0xd2 <- 0xb7 + DB 'A'+80H,"BS" ; 0xd3 <- 0xb8 + DB 'U'+80H,"SR" ; 0xd4 <- 0xb9 + DB 'F'+80H,"RE" ; 0xd5 <- 0xba + DB 'I'+80H,"NP" ; 0xd6 <- 0xbb + DB 'P'+80H,"OS" ; 0xd7 <- 0xbc + DB 'S'+80H,"QR" ; 0xd8 <- 0xbd + DB 'R'+80H,"ND" ; 0xd9 <- 0xbe + DB 'L'+80H,"OG" ; 0xda <- 0xbf + DB 'E'+80H,"XP" ; 0xdb <- 0xc0 + DB 'C'+80H,"OS" ; 0xdc <- 0xc1 + DB 'S'+80H,"IN" ; 0xdd <- 0xc2 + DB 'T'+80H,"AN" ; 0xde <- 0xc3 + DB 'A'+80H,"TN" ; 0xdf <- 0xc4 + DB 'P'+80H,"EEK" ; 0xe0 <- 0xc5 + DB 'D'+80H,"EEK" ; 0xe1 <- 0xc6 + DB 'P'+80H,"OINT" ; 0xe2 <- 0xc7 + DB 'L'+80H,"EN" ; 0xe3 <- 0xc8 + DB 'S'+80H,"TR$" ; 0xe4 <- 0xc9 + DB 'V'+80H,"AL" ; 0xe5 <- 0xca + DB 'A'+80H,"SC" ; 0xe6 <- 0xcb + DB 'C'+80H,"HR$" ; 0xe7 <- 0xcc + DB 'H'+80H,"EX$" ; 0xe8 <- 0xcd + DB 'B'+80H,"IN$" ; 0xe9 <- 0xce + DB 'L'+80H,"EFT$" ; 0xea <- 0xcf + DB 'R'+80H,"IGHT$" ; 0xeb <- 0xd0 + DB 'M'+80H,"ID$" ; 0xec <- 0xd1 + DB 80H ; End of list marker + +; KEYWORD ADDRESS TABLE + +WORDTB: DW PEND + DW FOR + DW NEXT + DW DATA + DW INPUT + DW DIM + DW READ + DW LET + DW GOTO + DW RUN + DW IF + DW RESTOR + DW GOSUB + DW RETURN + DW REM + DW STOP + DW POUT + DW ON + DW NULL + DW WAIT + DW DEF + DW POKE + DW DOKE + DW SCREEN + DW LINES + DW CLS + DW WIDTH + DW MONITR + DW PSET + DW RESET + DW PRINT + DW CONT + DW LIST + DW CLEAR + DW CLOAD + DW CSAVE + DW LOAD + DW SAVE + DW NEW + +; RESERVED WORD TOKEN VALUES + +ZEND EQU 080H ; END - ZEND marks the start of the table. +ZFOR EQU 081H ; FOR +ZDATA EQU 083H ; DATA +ZGOTO EQU 088H ; GOTO +ZGOSUB EQU 08CH ; GOSUB +ZREM EQU 08EH ; REM +ZPRINT EQU 09EH ; PRINT +ZNEW EQU 0A6H ; NEW - ZNEW marks the end of the table + ; A5..BF are reserved for future commands. + +; Space for expansion, a block of tokens for commands has been created from 0xA5 to 0xBF. + +FUNCSTRT EQU 0C0H ; Function start. +ZTAB EQU FUNCSTRT + 00H ; 0A5H ; TAB +ZTO EQU FUNCSTRT + 01H ; 0A6H ; TO +ZFN EQU FUNCSTRT + 02H ; 0A7H ; FN +ZSPC EQU FUNCSTRT + 03H ; 0A8H ; SPC +ZTHEN EQU FUNCSTRT + 04H ; 0A9H ; THEN +ZNOT EQU FUNCSTRT + 05H ; 0AAH ; NOT +ZSTEP EQU FUNCSTRT + 06H ; 0ABH ; STEP + +ZPLUS EQU FUNCSTRT + 07H ; 0ACH ; + +ZMINUS EQU FUNCSTRT + 08H ; 0ADH ; - +ZTIMES EQU FUNCSTRT + 09H ; 0AEH ; * +ZDIV EQU FUNCSTRT + 0AH ; 0AFH ; / + ; 0B0H + ; 0B1H +ZOR EQU FUNCSTRT + 0dH ; 0B2H ; OR +ZGTR EQU FUNCSTRT + 0eH ; 0B3H ; > +ZEQUAL EQU FUNCSTRT + 0fH ; 0B4H ; M +ZLTH EQU FUNCSTRT + 10H ; 0B5H ; < +ZSGN EQU FUNCSTRT + 11H ; 0B6H ; SGN + ; 0B7H + ; 0B8H + ; 0B9H + ; 0BAH + ; 0BBH + ; 0BCH + ; 0BDH + ; 0BEH + ; 0BFH + ; 0C0H + ; 0C1H + ; 0C2H + ; 0C3H + ; 0C4H + ; 0C5H + ; 0C6H +ZPOINT EQU FUNCSTRT + 22H ; 0C7H ; POINT + ; 0C8H + ; 0C9H + ; 0CAH + ; 0CBH + ; 0CCH +ZLEFT EQU FUNCSTRT + 2aH ; 0CFH ; LEFT$ + +; Space for expansion, reserve a block of tokens for functions. + + +; ARITHMETIC PRECEDENCE TABLE + +PRITAB: DB 79H ; Precedence value + DW PADD ; FPREG = + FPREG + + DB 79H ; Precedence value + DW PSUB ; FPREG = - FPREG + + DB 7CH ; Precedence value + DW MULT ; PPREG = * FPREG + + DB 7CH ; Precedence value + DW DIV ; FPREG = / FPREG + + DB 7FH ; Precedence value + DW POWER ; FPREG = ^ FPREG + + DB 50H ; Precedence value + DW PAND ; FPREG = AND FPREG + + DB 46H ; Precedence value + DW POR ; FPREG = OR FPREG + +; BASIC ERROR CODE LIST + +ERRORS: DB "NF" ; NEXT without FOR + DB "SN" ; Syntax error + DB "RG" ; RETURN without GOSUB + DB "OD" ; Out of DATA + DB "FC" ; Illegal function call + DB "OV" ; Overflow error + DB "OM" ; Out of memory + DB "UL" ; Undefined line + DB "BS" ; Bad subscript + DB "DD" ; Re-DIMensioned array + DB "/0" ; Division by zero + DB "ID" ; Illegal direct + DB "TM" ; Type mis-match + DB "OS" ; Out of string space + DB "LS" ; String too long + DB "ST" ; String formula too complex + DB "CN" ; Can't CONTinue + DB "UF" ; Undefined FN function + DB "MO" ; Missing operand + DB "HX" ; HEX error + DB "BN" ; BIN error + +; INITIALISATION TABLE ------------------------------------------------------- + +INITAB: JP WARMST ; Warm start jump + JP FCERR ; "USR (X)" jump (Set to Error) + + OUT (0),A ; "OUT p,n" skeleton + RET + + SUB 0 ; Division support routine + LD L,A + LD A,H + SBC A,0 + LD H,A + LD A,B + SBC A,0 + LD B,A + LD A,0 + RET + + DB 0,0,0 ; Random number seed + ; Table used by RND + DB 035H,04AH,0CAH,099H ;-2.65145E+07 + DB 039H,01CH,076H,098H ; 1.61291E+07 + DB 022H,095H,0B3H,098H ;-1.17691E+07 + DB 00AH,0DDH,047H,098H ; 1.30983E+07 + DB 053H,0D1H,099H,099H ;-2-01612E+07 + DB 00AH,01AH,09FH,098H ;-1.04269E+07 + DB 065H,0BCH,0CDH,098H ;-1.34831E+07 + DB 0D6H,077H,03EH,098H ; 1.24825E+07 + DB 052H,0C7H,04FH,080H ; Last random number + + IN A,(0) ; INP (x) skeleton + RET + + DB 1 ; POS (x) number (1) + DB 80 ; Terminal width (47) + DB 28 ; Width for commas (3 columns) + DB 0 ; No nulls after input bytes + DB 0 ; Output enabled (^O off) + + DW 20 ; Initial lines counter + DW 20 ; Initial lines number + DW 0 ; Array load/save check sum + + DB 0 ; Break not by NMI + DB 0 ; Break flag + + JP TTYLIN ; Input reflection (set to TTY) + JP 0000H ; POINT reflection unused + JP 0000H ; SET reflection + JP 0000H ; RESET reflection + ;JP POINTB ; POINT reflection unused + ;JP SETB ; SET reflection + ;JP RESETB ; RESET reflection + + DW STLOOK ; Temp string space + DW -2 ; Current line number (cold) + DW PROGST+1 ; Start of program text +INITBE: ; END OF INITIALISATION TABLE + +; END OF INITIALISATION TABLE --------------------------------------------------- + +ERRMSG: DB " Error",0 +INMSG: DB " in ",0 +ZERBYT EQU $-1 ; A zero byte +OKMSG: DB "Ok",CR,LF,0,0 +BRKMSG: DB "Break",0 + +BAKSTK: LD HL,4 ; Look for "FOR" block with + ADD HL,SP ; same index as specified +LOKFOR: LD A,(HL) ; Get block ID + INC HL ; Point to index address + CP ZFOR ; Is it a "FOR" token + RET NZ ; No - exit + LD C,(HL) ; BC = Address of "FOR" index + INC HL + LD B,(HL) + INC HL ; Point to sign of STEP + PUSH HL ; Save pointer to sign + LD L,C ; HL = address of "FOR" index + LD H,B + LD A,D ; See if an index was specified + OR E ; DE = 0 if no index specified + EX DE,HL ; Specified index into HL + JP Z,INDFND ; Skip if no index given + EX DE,HL ; Index back into DE + CALL CPDEHL ; Compare index with one given +INDFND: LD BC,16-3 ; Offset to next block + POP HL ; Restore pointer to sign + RET Z ; Return if block found + ADD HL,BC ; Point to next block + JP LOKFOR ; Keep on looking + +MOVUP: CALL ENFMEM ; See if enough memory +MOVSTR: PUSH BC ; Save end of source + EX (SP),HL ; Swap source and dest" end + POP BC ; Get end of destination +MOVLP: CALL CPDEHL ; See if list moved + LD A,(HL) ; Get byte + LD (BC),A ; Move it + RET Z ; Exit if all done + DEC BC ; Next byte to move to + DEC HL ; Next byte to move + JP MOVLP ; Loop until all bytes moved + +CHKSTK: PUSH HL ; Save code string address + LD HL,(ARREND) ; Lowest free memory + LD B,0 ; BC = Number of levels to test + ADD HL,BC ; 2 Bytes for each level + ADD HL,BC + DB 3EH ; Skip "PUSH HL" +ENFMEM: PUSH HL ; Save code string address + LD A,0D0H ;LOW -48 ; 48 Bytes minimum RAM + SUB L + LD L,A + LD A,0FFH ; HIGH (-48) ; 48 Bytes minimum RAM + SBC A,H + JP C,OMERR ; Not enough - ?OM Error + LD H,A + ADD HL,SP ; Test if stack is overflowed + POP HL ; Restore code string address + RET C ; Return if enough mmory +OMERR: LD E,OM ; ?OM Error + JP BERROR + +DATSNR: LD HL,(DATLIN) ; Get line of current DATA item + LD (LINEAT),HL ; Save as current line +SNERR: LD E,SN ; ?SN Error + DB 01H ; Skip "LD E,DZ" +DZERR: LD E,DZ ; ?/0 Error + DB 01H ; Skip "LD E,NF" +NFERR: LD E,NF ; ?NF Error + DB 01H ; Skip "LD E,DD" +DDERR: LD E,DDA ; ?DD Error + DB 01H ; Skip "LD E,UF" +UFERR: LD E,UF ; ?UF Error + DB 01H ; Skip "LD E,OV +OVERR: LD E,OV ; ?OV Error + DB 01H ; Skip "LD E,TM" +TMERR: LD E,TM ; ?TM Error + +BERROR: CALL CLREG ; Clear registers and stack + LD (CTLOFG),A ; Enable output (A is 0) + CALL STTLIN ; Start new line + LD HL,ERRORS ; Point to error codes + LD D,A ; D = 0 (A is 0) + LD A,'?' + CALL OUTC ; Output '?' + ADD HL,DE ; Offset to correct error code + LD A,(HL) ; First character + CALL OUTC ; Output it + CALL GETCHR ; Get next character + CALL OUTC ; Output it + LD HL,ERRMSG ; "Error" message +ERRIN: CALL PRS ; Output message + LD HL,(LINEAT) ; Get line of error + LD DE,-2 ; Cold start error if -2 + CALL CPDEHL ; See if cold start error + JP Z,CSTART ; Cold start error - Restart + LD A,H ; Was it a direct error? + AND L ; Line = -1 if direct error + INC A + CALL NZ,LINEIN ; No - output line of error + DB 3EH ; Skip "POP BC" +POPNOK: POP BC ; Drop address in input buffer + +PRNTOK: XOR A ; Output "Ok" and get command + LD (CTLOFG),A ; Enable output + CALL STTLIN ; Start new line + LD HL,OKMSG ; "Ok" message + CALL PRS ; Output "Ok" +GETCMD: LD HL,-1 ; Flag direct mode + LD (LINEAT),HL ; Save as current line + CALL GETLIN ; Get an input line + JP C,GETCMD ; Get line again if break + CALL GETCHR ; Get first character + INC A ; Test if end of line + DEC A ; Without affecting Carry + JP Z,GETCMD ; Nothing entered - Get another + PUSH AF ; Save Carry status + CALL ATOH ; Get line number into DE + PUSH DE ; Save line number + CALL CRUNCH ; Tokenise rest of line + LD B,A ; Length of tokenised line -> length is in C, B is zeroed. + POP DE ; Restore line number + POP AF ; Restore Carry + JP NC,EXCUTE ; No line number - Direct mode + PUSH DE ; Save line number + PUSH BC ; Save length of tokenised line + XOR A + LD (LSTBIN),A ; Clear last byte input + CALL GETCHR ; Get next character + OR A ; Set flags + PUSH AF ; And save them + CALL SRCHLN ; Search for line number in DE + JP C,LINFND ; Jump if line found + POP AF ; Get status + PUSH AF ; And re-save + JP Z,ULERR ; Nothing after number - Error + OR A ; Clear Carry +LINFND: PUSH BC ; Save address of line in prog + JP NC,INEWLN ; Line not found - Insert new + EX DE,HL ; Next line address in DE + LD HL,(PROGND) ; End of program +SFTPRG: LD A,(DE) ; Shift rest of program down + LD (BC),A + INC BC ; Next destination + INC DE ; Next source + CALL CPDEHL ; All done? + JP NZ,SFTPRG ; More to do + LD H,B ; HL - New end of program + LD L,C + LD (PROGND),HL ; Update end of program + +INEWLN: POP DE ; Get address of line, + POP AF ; Get status + JP Z,SETPTR ; No text - Set up pointers + LD HL,(PROGND) ; Get end of program + EX (SP),HL ; Get length of input line + POP BC ; End of program to BC + ADD HL,BC ; Find new end + PUSH HL ; Save new end + CALL MOVUP ; Make space for line + POP HL ; Restore new end + LD (PROGND),HL ; Update end of program pointer + EX DE,HL ; Get line to move up in HL + LD (HL),H ; Save MSB + POP DE ; Get new line number + INC HL ; Skip pointer + INC HL + LD (HL),E ; Save LSB of line number + INC HL + LD (HL),D ; Save MSB of line number + INC HL ; To first byte in line + LD DE,BUFFER ; Copy buffer to program +MOVBUF: LD A,(DE) ; Get source + LD (HL),A ; Save destinations + INC HL ; Next source + INC DE ; Next destination + OR A ; Done? + JP NZ,MOVBUF ; No - Repeat +SETPTR: CALL RUNFST ; Set line pointers + INC HL ; To LSB of pointer + EX DE,HL ; Address to DE +PTRLP: LD H,D ; Address to HL + LD L,E + LD A,(HL) ; Get LSB of pointer + INC HL ; To MSB of pointer + OR (HL) ; Compare with MSB pointer + JP Z,GETCMD ; Get command line if end + INC HL ; To LSB of line number + INC HL ; Skip line number + INC HL ; Point to first byte in line + XOR A ; Looking for 00 byte +FNDEND: CP (HL) ; Found end of line? + INC HL ; Move to next byte + JP NZ,FNDEND ; No - Keep looking + EX DE,HL ; Next line address to HL + LD (HL),E ; Save LSB of pointer + INC HL + LD (HL),D ; Save MSB of pointer + JP PTRLP ; Do next line + +SRCHLN: LD HL,(BASTXT) ; Start of program text +SRCHLP: LD B,H ; BC = Address to look at + LD C,L + LD A,(HL) ; Get address of next line + INC HL + OR (HL) ; End of program found? + DEC HL + RET Z ; Yes - Line not found + INC HL + INC HL + LD A,(HL) ; Get LSB of line number + INC HL + LD H,(HL) ; Get MSB of line number + LD L,A + CALL CPDEHL ; Compare with line in DE + LD H,B ; HL = Start of this line + LD L,C + LD A,(HL) ; Get LSB of next line address + INC HL + LD H,(HL) ; Get MSB of next line address + LD L,A ; Next line to HL + CCF + RET Z ; Lines found - Exit + CCF + RET NC ; Line not found,at line after + JP SRCHLP ; Keep looking + +NEW: RET NZ ; Return if any more on line +CLRPTR: LD HL,(BASTXT) ; Point to start of program + XOR A ; Set program area to empty + LD (HL),A ; Save LSB = 00 + INC HL + LD (HL),A ; Save MSB = 00 + INC HL + LD (PROGND),HL ; Set program end + +RUNFST: LD HL,(BASTXT) ; Clear all variables + DEC HL + +INTVAR: LD (BRKLIN),HL ; Initialise RUN variables + LD HL,(LSTRAM) ; Get end of RAM + LD (STRBOT),HL ; Clear string space + XOR A + CALL RESTOR ; Reset DATA pointers + LD HL,(PROGND) ; Get end of program + LD (VAREND),HL ; Clear variables + LD (ARREND),HL ; Clear arrays + +CLREG: POP BC ; Save return address + LD HL,(STRSPC) ; Get end of working RAN + LD SP,HL ; Set stack + LD HL,TMSTPL ; Temporary string pool + LD (TMSTPT),HL ; Reset temporary string ptr + XOR A ; A = 00 + LD L,A ; HL = 0000 + LD H,A + LD (CONTAD),HL ; No CONTinue + LD (FORFLG),A ; Clear FOR flag + LD (FNRGNM),HL ; Clear FN argument + PUSH HL ; HL = 0000 + PUSH BC ; Put back return +DOAGN: LD HL,(BRKLIN) ; Get address of code to RUN + RET ; Return to execution driver + +PROMPT: LD A,'?' ; '?' + CALL OUTC ; Output character + LD A,' ' ; Space + CALL OUTC ; Output character + JP RINPUT ; Get input line + +CRUNCH: XOR A ; Tokenise line @ HL to BUFFER + LD (DATFLG),A ; Reset literal flag + LD C,2+3 ; 2 byte number and 3 nulls + LD DE,BUFFER ; Start of input buffer +CRNCLP: LD A,(HL) ; Get byte + CP ' ' ; Is it a space? + JP Z,MOVDIR ; Yes - Copy direct + LD B,A ; Save character + CP '"' ; Is it a quote? + JP Z,CPYLIT ; Yes - Copy literal string + OR A ; Is it end of buffer? + JP Z,ENDBUF ; Yes - End buffer + LD A,(DATFLG) ; Get data type + OR A ; Literal? + LD A,(HL) ; Get byte to copy + JP NZ,MOVDIR ; Literal - Copy direct + CP '?' ; Is it '?' short for PRINT + LD A,ZPRINT ; "PRINT" token + JP Z,MOVDIR ; Yes - replace it + LD A,(HL) ; Get byte again + CP '0' ; Is it less than '0' + JP C,FNDWRD ; Yes - Look for reserved words + CP 60; ";"+1 ; Is it "0123456789:;" ? + JP C,MOVDIR ; Yes - copy it direct +FNDWRD: PUSH DE ; Look for reserved words + LD DE,WORDS-1 ; Point to table + PUSH BC ; Save count + LD BC,RETNAD ; Where to return to + PUSH BC ; Save return address + LD B,ZEND-1 ; First token value -1 + LD A,(HL) ; Get byte + CP 'a' ; Less than 'a' ? + JP C,SEARCH ; Yes - search for words + CP 'z'+1 ; Greater than 'z' ? + JP NC,SEARCH ; Yes - search for words + AND 01011111B ; Force upper case + LD (HL),A ; Replace byte +SEARCH: LD C,(HL) ; Search for a word + EX DE,HL +GETNXT: INC HL ; Get next reserved word + OR (HL) ; Start of word? + JP P,GETNXT ; No - move on + INC B ; Increment token value + LD A, (HL) ; Get byte from table + AND 01111111B ; Strip bit 7 + RET Z ; Return if end of list + CP C ; Same character as in buffer? + JP NZ,GETNXT ; No - get next word + EX DE,HL + PUSH HL ; Save start of word + +NXTBYT: INC DE ; Look through rest of word + LD A,(DE) ; Get byte from table + OR A ; End of word ? + JP M,MATCH ; Yes - Match found + LD C,A ; Save it + LD A,B ; Get token value + CP ZGOTO ; Is it "GOTO" token ? + JP NZ,NOSPC ; No - Don't allow spaces + CALL GETCHR ; Get next character + DEC HL ; Cancel increment from GETCHR +NOSPC: INC HL ; Next byte + LD A,(HL) ; Get byte + CP 'a' ; Less than 'a' ? + JP C,NOCHNG ; Yes - don't change + AND 01011111B ; Make upper case +NOCHNG: CP C ; Same as in buffer ? + JP Z,NXTBYT ; Yes - keep testing + POP HL ; Get back start of word + JP SEARCH ; Look at next word + +MATCH: LD C,B ; Word found - Save token value + POP AF ; Throw away return + EX DE,HL + RET ; Return to "RETNAD" +RETNAD: EX DE,HL ; Get address in string + LD A,C ; Get token value + POP BC ; Restore buffer length + POP DE ; Get destination address +MOVDIR: INC HL ; Next source in buffer + LD (DE),A ; Put byte in buffer + INC DE ; Move up buffer + INC C ; Increment length of buffer + SUB ':' ; End of statement? + JP Z,SETLIT ; Jump if multi-statement line + CP ZDATA-3AH ; Is it DATA statement ? + JP NZ,TSTREM ; No - see if REM +SETLIT: LD (DATFLG),A ; Set literal flag +TSTREM: SUB ZREM-3AH ; Is it REM? + JP NZ,CRNCLP ; No - Leave flag + LD B,A ; Copy rest of buffer +NXTCHR: LD A,(HL) ; Get byte + OR A ; End of line ? + JP Z,ENDBUF ; Yes - Terminate buffer + CP B ; End of statement ? + JP Z,MOVDIR ; Yes - Get next one +CPYLIT: INC HL ; Move up source string + LD (DE),A ; Save in destination + INC C ; Increment length + INC DE ; Move up destination + JP NXTCHR ; Repeat + +ENDBUF: LD HL,BUFFER-1 ; Point to start of buffer + LD (DE),A ; Mark end of buffer (A = 00) + INC DE + LD (DE),A ; A = 00 + INC DE + LD (DE),A ; A = 00 + RET + +DODEL: LD A,(NULFLG) ; Get null flag status + OR A ; Is it zero? + LD A,0 ; Zero A - Leave flags + LD (NULFLG),A ; Zero null flag + JP NZ,ECHDEL ; Set - Echo it + DEC B ; Decrement length + JP Z,GETLIN ; Get line again if empty + CALL OUTC ; Output null character + DB 3EH ; Skip "DEC B" +ECHDEL: DEC B ; Count bytes in buffer + DEC HL ; Back space buffer + JP Z,OTKLN ; No buffer - Try again + LD A,(HL) ; Get deleted byte + CALL OUTC ; Echo it + JP MORINP ; Get more input + +DELCHR: DEC B ; Count bytes in buffer + DEC HL ; Back space buffer + CALL OUTC ; Output character in A + JP NZ,MORINP ; Not end - Get more +OTKLN: CALL OUTC ; Output character in A +KILIN: CALL PRNTCRLF ; Output CRLF + JP TTYLIN ; Get line again + +GETLIN: +TTYLIN: LD HL,BUFFER ; Get a line by character + LD B,1 ; Set buffer as empty + XOR A + LD (NULFLG),A ; Clear null flag +MORINP: CALL CLOTST ; Get character and test ^O + LD C,A ; Save character in C + CP DELETE ; Delete character? + JP Z,DODEL ; Yes - Process it + LD A,(NULFLG) ; Get null flag + OR A ; Test null flag status + JP Z,PROCES ; Reset - Process character + LD A,0 ; Set a null + CALL OUTC ; Output null + XOR A ; Clear A + LD (NULFLG),A ; Reset null flag +PROCES: LD A,C ; Get character + CP CTRL_G ; Bell? + JP Z,PUTCTL ; Yes - Save it + CP CTRL_C ; Is it control "C"? + CALL Z,PRNTCRLF ; Yes - Output CRLF + SCF ; Flag break + RET Z ; Return if control "C" + CP CR ; Is it enter? + JP Z,ENDINP ; Yes - Terminate input + CP CTRL_U ; Is it control "U"? + JP Z,KILIN ; Yes - Get another line + CP '@' ; Is it "kill line"? + JP Z,OTKLN ; Yes - Kill line + CP DELETE ; Is it delete? + JP Z,DELCHR ; Yes - Delete character + CP BACKS ; Is it backspace? + JP Z,DELCHR ; Yes - Delete character + CP CTRL_R ; Is it control "R"? + JP NZ,PUTBUF ; No - Put in buffer + PUSH BC ; Save buffer length + PUSH DE ; Save DE + PUSH HL ; Save buffer address + LD (HL),0 ; Mark end of buffer + CALL OUTNCR ; Output and do CRLF + LD HL,BUFFER ; Point to buffer start + CALL PRS ; Output buffer + POP HL ; Restore buffer address + POP DE ; Restore DE + POP BC ; Restore buffer length + JP MORINP ; Get another character + +PUTBUF: CP ' ' ; Is it a control code? + JP C,MORINP ; Yes - Ignore +PUTCTL: LD A,B ; Get number of bytes in buffer + CP 72+1 ; Test for line overflow + LD A,CTRL_G ; Set a bell + JP NC,OUTNBS ; Ring bell if buffer full + LD A,C ; Get character + LD (HL),C ; Save in buffer + LD (LSTBIN),A ; Save last input byte + INC HL ; Move up buffer + INC B ; Increment length +OUTIT: CALL OUTC ; Output the character entered + JP MORINP ; Get another character + +OUTNBS: CALL OUTC ; Output bell and back over it + LD A,BACKS ; Set back space + JP OUTIT ; Output it and get more + +CPDEHL: LD A,H ; Get H + SUB D ; Compare with D + RET NZ ; Different - Exit + LD A,L ; Get L + SUB E ; Compare with E + RET ; Return status + +CHKSYN: LD A,(HL) ; Check syntax of character + EX (SP),HL ; Address of test byte + CP (HL) ; Same as in code string? + INC HL ; Return address + EX (SP),HL ; Put it back + JP Z,GETCHR ; Yes - Get next character + JP SNERR ; Different - ?SN Error + +OUTC: PUSH AF ; Save character + LD A,(CTLOFG) ; Get control "O" flag + OR A ; Is it set? + JP NZ,POPAF ; Yes - don't output + POP AF ; Restore character + PUSH BC ; Save buffer length + PUSH AF ; Save character + CP ' ' ; Is it a control code? + JP C,DINPOS ; Yes - Don't INC POS(X) + LD A,(LWIDTH) ; Get line width + LD B,A ; To B + LD A,(CURPOS) ; Get cursor position + INC B ; Width 255? + JP Z,INCLEN ; Yes - No width limit + DEC B ; Restore width + CP B ; At end of line? + CALL Z,PRNTCRLF ; Yes - output CRLF +INCLEN: INC A ; Move on one character + LD (CURPOS),A ; Save new position +DINPOS: POP AF ; Restore character + POP BC ; Restore buffer length +ANSIINC:IF INCLUDE_ANSITERM = 1 + CALL ANSITERM ; Send it via the Ansi processor. + ELSE + CALL PRNT ; Send it . + ENDIF + RET + +CLOTST: CALL GETKY ; Get input character + AND 01111111B ; Strip bit 7 + CP CTRL_O ; Is it control "O"? + RET NZ ; No don't flip flag + LD A,(CTLOFG) ; Get flag + CPL ; Flip it + LD (CTLOFG),A ; Put it back + XOR A ; Null character + RET + +LIST: CALL ATOH ; ASCII number to DE + RET NZ ; Return if anything extra + POP BC ; Rubbish - Not needed + CALL SRCHLN ; Search for line number in DE + PUSH BC ; Save address of line + CALL SETLIN ; Set up lines counter +LISTLP: POP HL ; Restore address of line + LD C,(HL) ; Get LSB of next line + INC HL + LD B,(HL) ; Get MSB of next line + INC HL + LD A,B ; BC = 0 (End of program)? + OR C + JP Z,PRNTOK ; Yes - Go to command mode + CALL COUNT ; Count lines + CALL TSTBRK ; Test for break key + PUSH BC ; Save address of next line + CALL PRNTCRLF ; Output CRLF + LD E,(HL) ; Get LSB of line number + INC HL + LD D,(HL) ; Get MSB of line number + INC HL + PUSH HL ; Save address of line start + EX DE,HL ; Line number to HL + CALL PRNTHL ; Output line number in decimal + LD A,' ' ; Space after line number + POP HL ; Restore start of line address +LSTLP2: CALL OUTC ; Output character in A +LSTLP3: LD A,(HL) ; Get next byte in line + OR A ; End of line? + INC HL ; To next byte in line + JP Z,LISTLP ; Yes - get next line + JP P,LSTLP2 ; No token - output it + SUB ZEND-1 ; Find and output word + LD C,A ; Token offset+1 to C + LD DE,WORDS ; Reserved word list +FNDTOK: LD A,(DE) ; Get character in list + INC DE ; Move on to next + OR A ; Is it start of word? + JP P,FNDTOK ; No - Keep looking for word + DEC C ; Count words + JP NZ,FNDTOK ; Not there - keep looking +OUTWRD: AND 01111111B ; Strip bit 7 + CALL OUTC ; Output first character + LD A,(DE) ; Get next character + INC DE ; Move on to next + OR A ; Is it end of word? + JP P,OUTWRD ; No - output the rest + JP LSTLP3 ; Next byte in line + +SETLIN: PUSH HL ; Set up LINES counter + LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Save in LINES counter + POP HL + RET + +COUNT: PUSH HL ; Save code string address + PUSH DE + LD HL,(LINESC) ; Get LINES counter + LD DE,-1 + ADC HL,DE ; Decrement + LD (LINESC),HL ; Put it back + POP DE + POP HL ; Restore code string address + RET P ; Return if more lines to go + PUSH HL ; Save code string address + LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Reset LINES counter + CALL GETKY ; Get input character + CP CTRL_C ; Is it control "C"? + JP Z,RSLNBK ; Yes - Reset LINES and break + POP HL ; Restore code string address + JP COUNT ; Keep on counting + +RSLNBK: LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Reset LINES counter + JP BRKRET ; Go and output "Break" + +FOR: LD A,64H ; Flag "FOR" assignment + LD (FORFLG),A ; Save "FOR" flag + CALL LET ; Set up initial index + POP BC ; Drop RETurn address + PUSH HL ; Save code string address + CALL DATA ; Get next statement address + LD (LOOPST),HL ; Save it for start of loop + LD HL,2 ; Offset for "FOR" block + ADD HL,SP ; Point to it +FORSLP: CALL LOKFOR ; Look for existing "FOR" block + POP DE ; Get code string address + JP NZ,FORFND ; No nesting found + ADD HL,BC ; Move into "FOR" block + PUSH DE ; Save code string address + DEC HL + LD D,(HL) ; Get MSB of loop statement + DEC HL + LD E,(HL) ; Get LSB of loop statement + INC HL + INC HL + PUSH HL ; Save block address + LD HL,(LOOPST) ; Get address of loop statement + CALL CPDEHL ; Compare the FOR loops + POP HL ; Restore block address + JP NZ,FORSLP ; Different FORs - Find another + POP DE ; Restore code string address + LD SP,HL ; Remove all nested loops + +FORFND: EX DE,HL ; Code string address to HL + LD C,8 + CALL CHKSTK ; Check for 8 levels of stack + PUSH HL ; Save code string address + LD HL,(LOOPST) ; Get first statement of loop + EX (SP),HL ; Save and restore code string + PUSH HL ; Re-save code string address + LD HL,(LINEAT) ; Get current line number + EX (SP),HL ; Save and restore code string + CALL TSTNUM ; Make sure it's a number + CALL CHKSYN ; Make sure "TO" is next + DB ZTO ; "TO" token + CALL GETNUM ; Get "TO" expression value + PUSH HL ; Save code string address + CALL BCDEFP ; Move "TO" value to BCDE + POP HL ; Restore code string address + PUSH BC ; Save "TO" value in block + PUSH DE + LD BC,8100H ; BCDE - 1 (default STEP) + LD D,C ; C=0 + LD E,D ; D=0 + LD A,(HL) ; Get next byte in code string + CP ZSTEP ; See if "STEP" is stated + LD A,1 ; Sign of step = 1 + JP NZ,SAVSTP ; No STEP given - Default to 1 + CALL GETCHR ; Jump over "STEP" token + CALL GETNUM ; Get step value + PUSH HL ; Save code string address + CALL BCDEFP ; Move STEP to BCDE + CALL TSTSGN ; Test sign of FPREG + POP HL ; Restore code string address +SAVSTP: PUSH BC ; Save the STEP value in block + PUSH DE + PUSH AF ; Save sign of STEP + INC SP ; Don't save flags + PUSH HL ; Save code string address + LD HL,(BRKLIN) ; Get address of index variable + EX (SP),HL ; Save and restore code string +PUTFID: LD B,ZFOR ; "FOR" block marker + PUSH BC ; Save it + INC SP ; Don't save C + +RUNCNT: CALL TSTBRK ; Execution driver - Test break + LD (BRKLIN),HL ; Save code address for break + LD A,(HL) ; Get next byte in code string + CP ':' ; Multi statement line? + JP Z,EXCUTE ; Yes - Execute it + OR A ; End of line? + JP NZ,SNERR ; No - Syntax error + INC HL ; Point to address of next line + LD A,(HL) ; Get LSB of line pointer + INC HL + OR (HL) ; Is it zero (End of prog)? + JP Z,ENDPRG ; Yes - Terminate execution + INC HL ; Point to line number + LD E,(HL) ; Get LSB of line number + INC HL + LD D,(HL) ; Get MSB of line number + EX DE,HL ; Line number to HL + LD (LINEAT),HL ; Save as current line number + EX DE,HL ; Line number back to DE +EXCUTE: CALL GETCHR ; Get key word + LD DE,RUNCNT ; Where to RETurn to + PUSH DE ; Save for RETurn +IFJMP: RET Z ; Go to RUNCNT if end of STMT +ONJMP: SUB ZEND ; Is it a token? + JP C,LET ; No - try to assign it + CP ZNEW+1-ZEND ; END to NEW ? + JP NC,SNERR ; Not a key word - ?SN Error + RLCA ; Double it + LD C,A ; BC = Offset into table + LD B,0 + EX DE,HL ; Save code string address + LD HL,WORDTB ; Keyword address table + ADD HL,BC ; Point to routine address + LD C,(HL) ; Get LSB of routine address + INC HL + LD B,(HL) ; Get MSB of routine address + PUSH BC ; Save routine address + EX DE,HL ; Restore code string address + +GETCHR: INC HL ; Point to next character + LD A,(HL) ; Get next code string byte + CP ':' ; Z if ':' + RET NC ; NC if > "9" + CP ' ' + JP Z,GETCHR ; Skip over spaces + CP '0' + CCF ; NC if < '0' + INC A ; Test for zero - Leave carry + DEC A ; Z if Null + RET + +RESTOR: EX DE,HL ; Save code string address + LD HL,(BASTXT) ; Point to start of program + JP Z,RESTNL ; Just RESTORE - reset pointer + EX DE,HL ; Restore code string address + CALL ATOH ; Get line number to DE + PUSH HL ; Save code string address + CALL SRCHLN ; Search for line number in DE + LD H,B ; HL = Address of line + LD L,C + POP DE ; Restore code string address + JP NC,ULERR ; ?UL Error if not found +RESTNL: DEC HL ; Byte before DATA statement +UPDATA: LD (NXTDAT),HL ; Update DATA pointer + EX DE,HL ; Restore code string address + RET + +TSTBRK: CALL CHKKY ; Check input status + OR A + RET Z ; No key, go back + CALL GETKY ; Get the key into A + CP ESC ; Escape key? + JR Z,BRK ; Yes, break + CP CTRL_C ; + JR Z,BRK ; Yes, break + CP CTRL_S ; Stop scrolling? + RET NZ ; Other key, ignore + + +STALL: CALL GETKY ; Wait for key + CP CTRL_Q ; Resume scrolling? + RET Z ; Release the chokehold + CP CTRL_C ; Second break? + JR Z,STOP ; Break during hold exits prog + JR STALL ; Loop until or + +BRK LD A,0FFH ; Set BRKFLG + LD (BRKFLG),A ; Store it + + +STOP: RET NZ ; Exit if anything else + DB 0F6H ; Flag "STOP" +PEND: RET NZ ; Exit if anything else + LD (BRKLIN),HL ; Save point of break + DB 21H ; Skip "OR 11111111B" +INPBRK: OR 11111111B ; Flag "Break" wanted + POP BC ; Return not needed and more +ENDPRG: LD HL,(LINEAT) ; Get current line number + PUSH AF ; Save STOP / END status + LD A,L ; Is it direct break? + AND H + INC A ; Line is -1 if direct break + JP Z,NOLIN ; Yes - No line number + LD (ERRLIN),HL ; Save line of break + LD HL,(BRKLIN) ; Get point of break + LD (CONTAD),HL ; Save point to CONTinue +NOLIN: XOR A + LD (CTLOFG),A ; Enable output + CALL STTLIN ; Start a new line + POP AF ; Restore STOP / END status + LD HL,BRKMSG ; "Break" message + JP NZ,ERRIN ; "in line" wanted? + JP PRNTOK ; Go to command mode + +CONT: LD HL,(CONTAD) ; Get CONTinue address + LD A,H ; Is it zero? + OR L + LD E,CN ; ?CN Error + JP Z,BERROR ; Yes - output "?CN Error" + EX DE,HL ; Save code string address + LD HL,(ERRLIN) ; Get line of last break + LD (LINEAT),HL ; Set up current line number + EX DE,HL ; Restore code string address + RET ; CONTinue where left off + +NULL: CALL GETINT ; Get integer 0-255 + RET NZ ; Return if bad value + LD (NULLS),A ; Set nulls number + RET + + +ACCSUM: PUSH HL ; Save address in array + LD HL,(CHKSUM) ; Get check sum + LD B,0 ; BC - Value of byte + LD C,A + ADD HL,BC ; Add byte to check sum + LD (CHKSUM),HL ; Re-save check sum + POP HL ; Restore address in array + RET + +CHKLTR: LD A,(HL) ; Get byte + CP 'A' ; < 'a' ? + RET C ; Carry set if not letter + CP 'Z'+1 ; > 'z' ? + CCF + RET ; Carry set if not letter + +FPSINT: CALL GETCHR ; Get next character +POSINT: CALL GETNUM ; Get integer 0 to 32767 +DEPINT: CALL TSTSGN ; Test sign of FPREG + JP M,FCERR ; Negative - ?FC Error +DEINT: LD A,(FPEXP) ; Get integer value to DE + CP 80H+16 ; Exponent in range (16 bits)? + JP C,FPINT ; Yes - convert it + LD BC,9080H ; BCDE = -32768 + LD DE,0000 + PUSH HL ; Save code string address + CALL CMPNUM ; Compare FPREG with BCDE + POP HL ; Restore code string address + LD D,C ; MSB to D + RET Z ; Return if in range +FCERR: LD E,FC ; ?FC Error + JP BERROR ; Output error- + +ATOH: DEC HL ; ASCII number to DE binary +GETLN: LD DE,0 ; Get number to DE +GTLNLP: CALL GETCHR ; Get next character + RET NC ; Exit if not a digit + PUSH HL ; Save code string address + PUSH AF ; Save digit + LD HL,65529/10 ; Largest number 65529 + CALL CPDEHL ; Number in range? + JP C,SNERR ; No - ?SN Error + LD H,D ; HL = Number + LD L,E + ADD HL,DE ; Times 2 + ADD HL,HL ; Times 4 + ADD HL,DE ; Times 5 + ADD HL,HL ; Times 10 + POP AF ; Restore digit + SUB '0' ; Make it 0 to 9 + LD E,A ; DE = Value of digit + LD D,0 + ADD HL,DE ; Add to number + EX DE,HL ; Number to DE + POP HL ; Restore code string address + JP GTLNLP ; Go to next character + +CLEAR: JP Z,INTVAR ; Just "CLEAR" Keep parameters + CALL POSINT ; Get integer 0 to 32767 to DE + DEC HL ; Cancel increment + CALL GETCHR ; Get next character + PUSH HL ; Save code string address + LD HL,(LSTRAM) ; Get end of RAM + JP Z,STORED ; No value given - Use stored + POP HL ; Restore code string address + CALL CHKSYN ; Check for comma + DB ',' + PUSH DE ; Save number + CALL POSINT ; Get integer 0 to 32767 + DEC HL ; Cancel increment + CALL GETCHR ; Get next character + JP NZ,SNERR ; ?SN Error if more on line + EX (SP),HL ; Save code string address + EX DE,HL ; Number to DE +STORED: LD A,L ; Get LSB of new RAM top + SUB E ; Subtract LSB of string space + LD E,A ; Save LSB + LD A,H ; Get MSB of new RAM top + SBC A,D ; Subtract MSB of string space + LD D,A ; Save MSB + JP C,OMERR ; ?OM Error if not enough mem + PUSH HL ; Save RAM top + LD HL,(PROGND) ; Get program end + LD BC,40 ; 40 Bytes minimum working RAM + ADD HL,BC ; Get lowest address + CALL CPDEHL ; Enough memory? + JP NC,OMERR ; No - ?OM Error + EX DE,HL ; RAM top to HL + LD (STRSPC),HL ; Set new string space + POP HL ; End of memory to use + LD (LSTRAM),HL ; Set new top of RAM + POP HL ; Restore code string address + JP INTVAR ; Initialise variables + +RUN: JP Z,RUNFST ; RUN from start if just RUN + CALL INTVAR ; Initialise variables + LD BC,RUNCNT ; Execution driver loop + JP RUNLIN ; RUN from line number + +GOSUB: LD C,3 ; 3 Levels of stack needed + CALL CHKSTK ; Check for 3 levels of stack + POP BC ; Get return address + PUSH HL ; Save code string for RETURN + PUSH HL ; And for GOSUB routine + LD HL,(LINEAT) ; Get current line + EX (SP),HL ; Into stack - Code string out + LD A,ZGOSUB ; "GOSUB" token + PUSH AF ; Save token + INC SP ; Don't save flags + +RUNLIN: PUSH BC ; Save return address +GOTO: CALL ATOH ; ASCII number to DE binary + CALL REM ; Get end of line + PUSH HL ; Save end of line + LD HL,(LINEAT) ; Get current line + CALL CPDEHL ; Line after current? + POP HL ; Restore end of line + INC HL ; Start of next line + CALL C,SRCHLP ; Line is after current line + CALL NC,SRCHLN ; Line is before current line + LD H,B ; Set up code string address + LD L,C + DEC HL ; Incremented after + RET C ; Line found +ULERR: LD E,UL ; ?UL Error + JP BERROR ; Output error message + +RETURN: RET NZ ; Return if not just RETURN + LD D,-1 ; Flag "GOSUB" search + CALL BAKSTK ; Look "GOSUB" block + LD SP,HL ; Kill all FORs in subroutine + CP ZGOSUB ; Test for "GOSUB" token + LD E,RG ; ?RG Error + JP NZ,BERROR ; Error if no "GOSUB" found + POP HL ; Get RETURN line number + LD (LINEAT),HL ; Save as current + INC HL ; Was it from direct statement? + LD A,H + OR L ; Return to line + JP NZ,RETLIN ; No - Return to line + LD A,(LSTBIN) ; Any INPUT in subroutine? + OR A ; If so buffer is corrupted + JP NZ,POPNOK ; Yes - Go to command mode +RETLIN: LD HL,RUNCNT ; Execution driver loop + EX (SP),HL ; Into stack - Code string out + DB 3EH ; Skip "POP HL" +NXTDTA: POP HL ; Restore code string address + +DATA: DB 01H,3AH ; ':' End of statement +REM: LD C,0 ; 00 End of statement + LD B,0 +NXTSTL: LD A,C ; Statement and byte + LD C,B + LD B,A ; Statement end byte +NXTSTT: LD A,(HL) ; Get byte + OR A ; End of line? + RET Z ; Yes - Exit + CP B ; End of statement? + RET Z ; Yes - Exit + INC HL ; Next byte + CP '"' ; Literal string? + JP Z,NXTSTL ; Yes - Look for another '"' + JP NXTSTT ; Keep looking + +LET: CALL GETVAR ; Get variable name + CALL CHKSYN ; Make sure "=" follows + DB ZEQUAL ; "=" token + PUSH DE ; Save address of variable + LD A,(TYPE) ; Get data type + PUSH AF ; Save type + CALL EVAL ; Evaluate expression + POP AF ; Restore type + EX (SP),HL ; Save code - Get var addr + LD (BRKLIN),HL ; Save address of variable + RRA ; Adjust type + CALL CHKTYP ; Check types are the same + JP Z,LETNUM ; Numeric - Move value +LETSTR: PUSH HL ; Save address of string var + LD HL,(FPREG) ; Pointer to string entry + PUSH HL ; Save it on stack + INC HL ; Skip over length + INC HL + LD E,(HL) ; LSB of string address + INC HL + LD D,(HL) ; MSB of string address + LD HL,(BASTXT) ; Point to start of program + CALL CPDEHL ; Is string before program? + JP NC,CRESTR ; Yes - Create string entry + LD HL,(STRSPC) ; Point to string space + CALL CPDEHL ; Is string literal in program? + POP DE ; Restore address of string + JP NC,MVSTPT ; Yes - Set up pointer + LD HL,TMPSTR ; Temporary string pool + CALL CPDEHL ; Is string in temporary pool? + JP NC,MVSTPT ; No - Set up pointer + DB 3EH ; Skip "POP DE" +CRESTR: POP DE ; Restore address of string + CALL BAKTMP ; Back to last tmp-str entry + EX DE,HL ; Address of string entry + CALL SAVSTR ; Save string in string area +MVSTPT: CALL BAKTMP ; Back to last tmp-str entry + POP HL ; Get string pointer + CALL DETHL4 ; Move string pointer to var + POP HL ; Restore code string address + RET + +LETNUM: PUSH HL ; Save address of variable + CALL FPTHL ; Move value to variable + POP DE ; Restore address of variable + POP HL ; Restore code string address + RET + +ON: CALL GETINT ; Get integer 0-255 + LD A,(HL) ; Get "GOTO" or "GOSUB" token + LD B,A ; Save in B + CP ZGOSUB ; "GOSUB" token? + JP Z,ONGO ; Yes - Find line number + CALL CHKSYN ; Make sure it's "GOTO" + DB ZGOTO ; "GOTO" token + DEC HL ; Cancel increment +ONGO: LD C,E ; Integer of branch value +ONGOLP: DEC C ; Count branches + LD A,B ; Get "GOTO" or "GOSUB" token + JP Z,ONJMP ; Go to that line if right one + CALL GETLN ; Get line number to DE + CP ',' ; Another line number? + RET NZ ; No - Drop through + JP ONGOLP ; Yes - loop + +IF: CALL EVAL ; Evaluate expression + LD A,(HL) ; Get token + CP ZGOTO ; "GOTO" token? + JP Z,IFGO ; Yes - Get line + CALL CHKSYN ; Make sure it's "THEN" + DB ZTHEN ; "THEN" token + DEC HL ; Cancel increment +IFGO: CALL TSTNUM ; Make sure it's numeric + CALL TSTSGN ; Test state of expression + JP Z,REM ; False - Drop through + CALL GETCHR ; Get next character + JP C,GOTO ; Number - GOTO that line + JP IFJMP ; Otherwise do statement + +MRPRNT: DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character +PRINT: JP Z,PRNTCRLF ; CRLF if just PRINT +PRNTLP: RET Z ; End of list - Exit + CP ZTAB ; "TAB(" token? + JP Z,DOTAB ; Yes - Do TAB routine + CP ZSPC ; "SPC(" token? + JP Z,DOTAB ; Yes - Do SPC routine + PUSH HL ; Save code string address + CP ',' ; Comma? + JP Z,DOCOM ; Yes - Move to next zone + CP 59 ;";" ; Semi-colon? + JP Z,NEXITM ; Do semi-colon routine + POP BC ; Code string address to BC + CALL EVAL ; Evaluate expression + PUSH HL ; Save code string address + LD A,(TYPE) ; Get variable type + OR A ; Is it a string variable? + JP NZ,PRNTST ; Yes - Output string contents + CALL NUMASC ; Convert number to text + CALL CRTST ; Create temporary string + LD (HL),' ' ; Followed by a space + LD HL,(FPREG) ; Get length of output + INC (HL) ; Plus 1 for the space + LD HL,(FPREG) ; < Not needed > + LD A,(LWIDTH) ; Get width of line + LD B,A ; To B + INC B ; Width 255 (No limit)? + JP Z,PRNTNB ; Yes - Output number string + INC B ; Adjust it + LD A,(CURPOS) ; Get cursor position + ADD A,(HL) ; Add length of string + DEC A ; Adjust it + CP B ; Will output fit on this line? + CALL NC,PRNTCRLF ; No - CRLF first +PRNTNB: CALL PRS1 ; Output string at (HL) + XOR A ; Skip CALL by setting 'z' flag +PRNTST: CALL NZ,PRS1 ; Output string at (HL) + POP HL ; Restore code string address + JP MRPRNT ; See if more to PRINT + +STTLIN: LD A,(CURPOS) ; Make sure on new line + OR A ; Already at start? + RET Z ; Yes - Do nothing + JP PRNTCRLF ; Start a new line + +ENDINP: LD (HL),0 ; Mark end of buffer + LD HL,BUFFER-1 ; Point to buffer +PRNTCRLF:LD A,CR ; Load a CR + CALL OUTC ; Output character + LD A,LF ; Load a LF + CALL OUTC ; Output character +DONULL: XOR A ; Set to position 0 + LD (CURPOS),A ; Store it + LD A,(NULLS) ; Get number of nulls +NULLP: DEC A ; Count them + RET Z ; Return if done + PUSH AF ; Save count + XOR A ; Load a null + CALL OUTC ; Output it + POP AF ; Restore count + JP NULLP ; Keep counting + +DOCOM: LD A,(COMMAN) ; Get comma width + LD B,A ; Save in B + LD A,(CURPOS) ; Get current position + CP B ; Within the limit? + CALL NC,PRNTCRLF ; No - output CRLF + JP NC,NEXITM ; Get next item +ZONELP: SUB 14 ; Next zone of 14 characters + JP NC,ZONELP ; Repeat if more zones + CPL ; Number of spaces to output + JP ASPCS ; Output them + +DOTAB: PUSH AF ; Save token + CALL FNDNUM ; Evaluate expression + CALL CHKSYN ; Make sure ")" follows + DB ")" + DEC HL ; Back space on to ")" + POP AF ; Restore token + SUB ZSPC ; Was it "SPC(" ? + PUSH HL ; Save code string address + JP Z,DOSPC ; Yes - Do 'E' spaces + LD A,(CURPOS) ; Get current position +DOSPC: CPL ; Number of spaces to print to + ADD A,E ; Total number to print + JP NC,NEXITM ; TAB < Current POS(X) +ASPCS: INC A ; Output A spaces + LD B,A ; Save number to print + LD A,' ' ; Space +SPCLP: CALL OUTC ; Output character in A + DEC B ; Count them + JP NZ,SPCLP ; Repeat if more +NEXITM: POP HL ; Restore code string address + CALL GETCHR ; Get next character + JP PRNTLP ; More to print + +REDO: DB "?Redo from start",CR,LF,0 + +BADINP: LD A,(READFG) ; READ or INPUT? + OR A + JP NZ,DATSNR ; READ - ?SN Error + POP BC ; Throw away code string addr + LD HL,REDO ; "Redo from start" message + CALL PRS ; Output string + JP DOAGN ; Do last INPUT again + +INPUT: CALL IDTEST ; Test for illegal direct + LD A,(HL) ; Get character after "INPUT" + CP '"' ; Is there a prompt string? + LD A,0 ; Clear A and leave flags + LD (CTLOFG),A ; Enable output + JP NZ,NOPMPT ; No prompt - get input + CALL QTSTR ; Get string terminated by '"' + CALL CHKSYN ; Check for ';' after prompt + DB ';' + PUSH HL ; Save code string address + CALL PRS1 ; Output prompt string + DB 3EH ; Skip "PUSH HL" +NOPMPT: PUSH HL ; Save code string address + CALL PROMPT ; Get input with "? " prompt + POP BC ; Restore code string address + JP C,INPBRK ; Break pressed - Exit + INC HL ; Next byte + LD A,(HL) ; Get it + OR A ; End of line? + DEC HL ; Back again + PUSH BC ; Re-save code string address + JP Z,NXTDTA ; Yes - Find next DATA stmt + LD (HL),',' ; Store comma as separator + JP NXTITM ; Get next item + +READ: PUSH HL ; Save code string address + LD HL,(NXTDAT) ; Next DATA statement + DB 0F6H ; Flag "READ" +NXTITM: XOR A ; Flag "INPUT" + LD (READFG),A ; Save "READ"/"INPUT" flag + EX (SP),HL ; Get code str' , Save pointer + JP GTVLUS ; Get values + +NEDMOR: CALL CHKSYN ; Check for comma between items + DB ',' +GTVLUS: CALL GETVAR ; Get variable name + EX (SP),HL ; Save code str" , Get pointer + PUSH DE ; Save variable address + LD A,(HL) ; Get next "INPUT"/"DATA" byte + CP ',' ; Comma? + JP Z,ANTVLU ; Yes - Get another value + LD A,(READFG) ; Is it READ? + OR A + JP NZ,FDTLP ; Yes - Find next DATA stmt + LD A,'?' ; More INPUT needed + CALL OUTC ; Output character + CALL PROMPT ; Get INPUT with prompt + POP DE ; Variable address + POP BC ; Code string address + JP C,INPBRK ; Break pressed + INC HL ; Point to next DATA byte + LD A,(HL) ; Get byte + OR A ; Is it zero (No input) ? + DEC HL ; Back space INPUT pointer + PUSH BC ; Save code string address + JP Z,NXTDTA ; Find end of buffer + PUSH DE ; Save variable address +ANTVLU: LD A,(TYPE) ; Check data type + OR A ; Is it numeric? + JP Z,INPBIN ; Yes - Convert to binary + CALL GETCHR ; Get next character + LD D,A ; Save input character + LD B,A ; Again + CP '"' ; Start of literal sting? + JP Z,STRENT ; Yes - Create string entry + LD A,(READFG) ; "READ" or "INPUT" ? + OR A + LD D,A ; Save 00 if "INPUT" + JP Z,ITMSEP ; "INPUT" - End with 00 + LD D,':' ; "DATA" - End with 00 or ':' +ITMSEP: LD B,',' ; Item separator + DEC HL ; Back space for DTSTR +STRENT: CALL DTSTR ; Get string terminated by D + EX DE,HL ; String address to DE + LD HL,LTSTND ; Where to go after LETSTR + EX (SP),HL ; Save HL , get input pointer + PUSH DE ; Save address of string + JP LETSTR ; Assign string to variable + +INPBIN: CALL GETCHR ; Get next character + CALL ASCTFP ; Convert ASCII to FP number + EX (SP),HL ; Save input ptr, Get var addr + CALL FPTHL ; Move FPREG to variable + POP HL ; Restore input pointer +LTSTND: DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP Z,MORDT ; End of line - More needed? + CP ',' ; Another value? + JP NZ,BADINP ; No - Bad input +MORDT: EX (SP),HL ; Get code string address + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP NZ,NEDMOR ; More needed - Get it + POP DE ; Restore DATA pointer + LD A,(READFG) ; "READ" or "INPUT" ? + OR A + EX DE,HL ; DATA pointer to HL + JP NZ,UPDATA ; Update DATA pointer if "READ" + PUSH DE ; Save code string address + OR (HL) ; More input given? + LD HL,EXTIG ; "?Extra ignored" message + CALL NZ,PRS ; Output string if extra given + POP HL ; Restore code string address + RET + +EXTIG: DB "?Extra ignored",CR,LF,0 + +FDTLP: CALL DATA ; Get next statement + OR A ; End of line? + JP NZ,FANDT ; No - See if DATA statement + INC HL + LD A,(HL) ; End of program? + INC HL + OR (HL) ; 00 00 Ends program + LD E,OD ; ?OD Error + JP Z,BERROR ; Yes - Out of DATA + INC HL + LD E,(HL) ; LSB of line number + INC HL + LD D,(HL) ; MSB of line number + EX DE,HL + LD (DATLIN),HL ; Set line of current DATA item + EX DE,HL +FANDT: CALL GETCHR ; Get next character + CP ZDATA ; "DATA" token + JP NZ,FDTLP ; No "DATA" - Keep looking + JP ANTVLU ; Found - Convert input + +NEXT: LD DE,0 ; In case no index given +NEXT1: CALL NZ,GETVAR ; Get index address + LD (BRKLIN),HL ; Save code string address + CALL BAKSTK ; Look for "FOR" block + JP NZ,NFERR ; No "FOR" - ?NF Error + LD SP,HL ; Clear nested loops + PUSH DE ; Save index address + LD A,(HL) ; Get sign of STEP + INC HL + PUSH AF ; Save sign of STEP + PUSH DE ; Save index address + CALL PHLTFP ; Move index value to FPREG + EX (SP),HL ; Save address of TO value + PUSH HL ; Save address of index + CALL ADDPHL ; Add STEP to index value + POP HL ; Restore address of index + CALL FPTHL ; Move value to index variable + POP HL ; Restore address of TO value + CALL LOADFP ; Move TO value to BCDE + PUSH HL ; Save address of line of FOR + CALL CMPNUM ; Compare index with TO value + POP HL ; Restore address of line num + POP BC ; Address of sign of STEP + SUB B ; Compare with expected sign + CALL LOADFP ; BC = Loop stmt,DE = Line num + JP Z,KILFOR ; Loop finished - Terminate it + EX DE,HL ; Loop statement line number + LD (LINEAT),HL ; Set loop line number + LD L,C ; Set code string to loop + LD H,B + JP PUTFID ; Put back "FOR" and continue + +KILFOR: LD SP,HL ; Remove "FOR" block + LD HL,(BRKLIN) ; Code string after "NEXT" + LD A,(HL) ; Get next byte in code string + CP ',' ; More NEXTs ? + JP NZ,RUNCNT ; No - Do next statement + CALL GETCHR ; Position to index name + CALL NEXT1 ; Re-enter NEXT routine +; < will not RETurn to here , Exit to RUNCNT or Loop > + +GETNUM: CALL EVAL ; Get a numeric expression +TSTNUM: DB 0F6H ; Clear carry (numeric) +TSTSTR: SCF ; Set carry (string) +CHKTYP: LD A,(TYPE) ; Check types match + ADC A,A ; Expected + actual + OR A ; Clear carry , set parity + RET PE ; Even parity - Types match + JP TMERR ; Different types - Error + +OPNPAR: CALL CHKSYN ; Make sure "(" follows + DB "(" +EVAL: DEC HL ; Evaluate expression & save + LD D,0 ; Precedence value +EVAL1: PUSH DE ; Save precedence + LD C,1 + CALL CHKSTK ; Check for 1 level of stack + CALL OPRND ; Get next expression value +EVAL2: LD (NXTOPR),HL ; Save address of next operator +EVAL3: LD HL,(NXTOPR) ; Restore address of next opr + POP BC ; Precedence value and operator + LD A,B ; Get precedence value + CP 78H ; "AND" or "OR" ? + CALL NC,TSTNUM ; No - Make sure it's a number + LD A,(HL) ; Get next operator / function + LD D,0 ; Clear Last relation +RLTLP: SUB ZGTR ; ">" Token + JP C,FOPRND ; + - * / ^ AND OR - Test it + CP ZLTH+1-ZGTR ; < = > + JP NC,FOPRND ; Function - Call it + CP ZEQUAL-ZGTR ; "=" + RLA ; <- Test for legal + XOR D ; <- combinations of < = > + CP D ; <- by combining last token + LD D,A ; <- with current one + JP C,SNERR ; Error if "<<' '==" or ">>" + LD (CUROPR),HL ; Save address of current token + CALL GETCHR ; Get next character + JP RLTLP ; Treat the two as one + +FOPRND: LD A,D ; < = > found ? + OR A + JP NZ,TSTRED ; Yes - Test for reduction + LD A,(HL) ; Get operator token + LD (CUROPR),HL ; Save operator address + SUB ZPLUS ; Operator or function? + RET C ; Neither - Exit + CP ZOR+1-ZPLUS ; Is it + - * / ^ AND OR ? + RET NC ; No - Exit + LD E,A ; Coded operator + LD A,(TYPE) ; Get data type + DEC A ; FF = numeric , 00 = string + OR E ; Combine with coded operator + LD A,E ; Get coded operator + JP Z,CONCAT ; String concatenation + RLCA ; Times 2 + ADD A,E ; Times 3 + LD E,A ; To DE (D is 0) + LD HL,PRITAB ; Precedence table + ADD HL,DE ; To the operator concerned + LD A,B ; Last operator precedence + LD D,(HL) ; Get evaluation precedence + CP D ; Compare with eval precedence + RET NC ; Exit if higher precedence + INC HL ; Point to routine address + CALL TSTNUM ; Make sure it's a number + +STKTHS: PUSH BC ; Save last precedence & token + LD BC,EVAL3 ; Where to go on prec' break + PUSH BC ; Save on stack for return + LD B,E ; Save operator + LD C,D ; Save precedence + CALL STAKFP ; Move value to stack + LD E,B ; Restore operator + LD D,C ; Restore precedence + LD C,(HL) ; Get LSB of routine address + INC HL + LD B,(HL) ; Get MSB of routine address + INC HL + PUSH BC ; Save routine address + LD HL,(CUROPR) ; Address of current operator + JP EVAL1 ; Loop until prec' break + +OPRND: XOR A ; Get operand routine + LD (TYPE),A ; Set numeric expected + CALL GETCHR ; Get next character + LD E,MO ; ?MO Error + JP Z,BERROR ; No operand - Error + JP C,ASCTFP ; Number - Get value + CALL CHKLTR ; See if a letter + JP NC,CONVAR ; Letter - Find variable + CP '&' ; &H = HEX, &B = BINARY [G. Searle] + JR NZ, NOTAMP + CALL GETCHR ; Get next character + CP 'H' ; Hex number indicated? [function added] + JP Z,HEXTFP ; Convert Hex to FPREG + CP 'B' ; Binary number indicated? [function added] + JP Z,BINTFP ; Convert Bin to FPREG + LD E,SN ; If neither then a ?SN Error + JP Z,BERROR ; +NOTAMP: CP ZPLUS ; '+' Token ? + JP Z,OPRND ; Yes - Look for operand + CP '.' ; '.' ? + JP Z,ASCTFP ; Yes - Create FP number + CP ZMINUS ; '-' Token ? + JP Z,MINUS ; Yes - Do minus + CP '"' ; Literal string ? + JP Z,QTSTR ; Get string terminated by '"' + CP ZNOT ; "NOT" Token ? + JP Z,EVNOT ; Yes - Eval NOT expression + CP ZFN ; "FN" Token ? + JP Z,DOFN ; Yes - Do FN routine + SUB ZSGN ; Is it a function? + JP NC,FNOFST ; Yes - Evaluate function +EVLPAR: CALL OPNPAR ; Evaluate expression in "()" + CALL CHKSYN ; Make sure ")" follows + DB ")" + RET + +MINUS: LD D,7DH ; '-' precedence + CALL EVAL1 ; Evaluate until prec' break + LD HL,(NXTOPR) ; Get next operator address + PUSH HL ; Save next operator address + CALL INVSGN ; Negate value +RETNUM: CALL TSTNUM ; Make sure it's a number + POP HL ; Restore next operator address + RET + +CONVAR: CALL GETVAR ; Get variable address to DE +FRMEVL: PUSH HL ; Save code string address + EX DE,HL ; Variable address to HL + LD (FPREG),HL ; Save address of variable + LD A,(TYPE) ; Get type + OR A ; Numeric? + CALL Z,PHLTFP ; Yes - Move contents to FPREG + POP HL ; Restore code string address + RET + +FNOFST: LD B,0 ; Get address of function + RLCA ; Double function offset + LD C,A ; BC = Offset in function table + PUSH BC ; Save adjusted token value + CALL GETCHR ; Get next character + LD A,C ; Get adjusted token value + CP 2*(ZLEFT-ZSGN)-1 ; Adj' LEFT$,RIGHT$ or MID$ ? + JP C,FNVAL ; No - Do function + CALL OPNPAR ; Evaluate expression (X,... + CALL CHKSYN ; Make sure ',' follows + DB ',' + CALL TSTSTR ; Make sure it's a string + EX DE,HL ; Save code string address + LD HL,(FPREG) ; Get address of string + EX (SP),HL ; Save address of string + PUSH HL ; Save adjusted token value + EX DE,HL ; Restore code string address + CALL GETINT ; Get integer 0-255 + EX DE,HL ; Save code string address + EX (SP),HL ; Save integer,HL = adj' token + JP GOFUNC ; Jump to string function + +FNVAL: CALL EVLPAR ; Evaluate expression + EX (SP),HL ; HL = Adjusted token value + LD DE,RETNUM ; Return number from function + PUSH DE ; Save on stack +GOFUNC: LD BC,FNCTAB ; Function routine addresses + ADD HL,BC ; Point to right address + LD C,(HL) ; Get LSB of address + INC HL ; + LD H,(HL) ; Get MSB of address + LD L,C ; Address to HL + JP (HL) ; Jump to function + +SGNEXP: DEC D ; Dee to flag negative exponent + CP ZMINUS ; '-' token ? + RET Z ; Yes - Return + CP '-' ; '-' ASCII ? + RET Z ; Yes - Return + INC D ; Inc to flag positive exponent + CP '+' ; '+' ASCII ? + RET Z ; Yes - Return + CP ZPLUS ; '+' token ? + RET Z ; Yes - Return + DEC HL ; DEC 'cos GETCHR INCs + RET ; Return "NZ" + +POR: DB 0F6H ; Flag "OR" +PAND: XOR A ; Flag "AND" + PUSH AF ; Save "AND" / "OR" flag + CALL TSTNUM ; Make sure it's a number + CALL DEINT ; Get integer -32768 to 32767 + POP AF ; Restore "AND" / "OR" flag + EX DE,HL ; <- Get last + POP BC ; <- value + EX (SP),HL ; <- from + EX DE,HL ; <- stack + CALL FPBCDE ; Move last value to FPREG + PUSH AF ; Save "AND" / "OR" flag + CALL DEINT ; Get integer -32768 to 32767 + POP AF ; Restore "AND" / "OR" flag + POP BC ; Get value + LD A,C ; Get LSB + LD HL,ACPASS ; Address of save AC as current + JP NZ,POR1 ; Jump if OR + AND E ; "AND" LSBs + LD C,A ; Save LSB + LD A,B ; Get MBS + AND D ; "AND" MSBs + JP (HL) ; Save AC as current (ACPASS) + +POR1: OR E ; "OR" LSBs + LD C,A ; Save LSB + LD A,B ; Get MSB + OR D ; "OR" MSBs + JP (HL) ; Save AC as current (ACPASS) + +TSTRED: LD HL,CMPLOG ; Logical compare routine + LD A,(TYPE) ; Get data type + RRA ; Carry set = string + LD A,D ; Get last precedence value + RLA ; Times 2 plus carry + LD E,A ; To E + LD D,64H ; Relational precedence + LD A,B ; Get current precedence + CP D ; Compare with last + RET NC ; Eval if last was rel' or log' + JP STKTHS ; Stack this one and get next + +CMPLOG: DW CMPLG1 ; Compare two values / strings +CMPLG1: LD A,C ; Get data type + OR A + RRA + POP BC ; Get last expression to BCDE + POP DE + PUSH AF ; Save status + CALL CHKTYP ; Check that types match + LD HL,CMPRES ; Result to comparison + PUSH HL ; Save for RETurn + JP Z,CMPNUM ; Compare values if numeric + XOR A ; Compare two strings + LD (TYPE),A ; Set type to numeric + PUSH DE ; Save string name + CALL GSTRCU ; Get current string + LD A,(HL) ; Get length of string + INC HL + INC HL + LD C,(HL) ; Get LSB of address + INC HL + LD B,(HL) ; Get MSB of address + POP DE ; Restore string name + PUSH BC ; Save address of string + PUSH AF ; Save length of string + CALL GSTRDE ; Get second string + CALL LOADFP ; Get address of second string + POP AF ; Restore length of string 1 + LD D,A ; Length to D + POP HL ; Restore address of string 1 +CMPSTR: LD A,E ; Bytes of string 2 to do + OR D ; Bytes of string 1 to do + RET Z ; Exit if all bytes compared + LD A,D ; Get bytes of string 1 to do + SUB 1 + RET C ; Exit if end of string 1 + XOR A + CP E ; Bytes of string 2 to do + INC A + RET NC ; Exit if end of string 2 + DEC D ; Count bytes in string 1 + DEC E ; Count bytes in string 2 + LD A,(BC) ; Byte in string 2 + CP (HL) ; Compare to byte in string 1 + INC HL ; Move up string 1 + INC BC ; Move up string 2 + JP Z,CMPSTR ; Same - Try next bytes + CCF ; Flag difference (">" or "<") + JP FLGDIF ; "<" gives -1 , ">" gives +1 + +CMPRES: INC A ; Increment current value + ADC A,A ; Double plus carry + POP BC ; Get other value + AND B ; Combine them + ADD A,-1 ; Carry set if different + SBC A,A ; 00 - Equal , FF - Different + JP FLGREL ; Set current value & continue + +EVNOT: LD D,5AH ; Precedence value for "NOT" + CALL EVAL1 ; Eval until precedence break + CALL TSTNUM ; Make sure it's a number + CALL DEINT ; Get integer -32768 - 32767 + LD A,E ; Get LSB + CPL ; Invert LSB + LD C,A ; Save "NOT" of LSB + LD A,D ; Get MSB + CPL ; Invert MSB + CALL ACPASS ; Save AC as current + POP BC ; Clean up stack + JP EVAL3 ; Continue evaluation + +DIMRET: DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + RET Z ; End of DIM statement + CALL CHKSYN ; Make sure ',' follows + DB ',' +DIM: LD BC,DIMRET ; Return to "DIMRET" + PUSH BC ; Save on stack + DB 0F6H ; Flag "Create" variable +GETVAR: XOR A ; Find variable address,to DE + LD (LCRFLG),A ; Set locate / create flag + LD B,(HL) ; Get First byte of name +GTFNAM: CALL CHKLTR ; See if a letter + JP C,SNERR ; ?SN Error if not a letter + XOR A + LD C,A ; Clear second byte of name + LD (TYPE),A ; Set type to numeric + CALL GETCHR ; Get next character + JP C,SVNAM2 ; Numeric - Save in name + CALL CHKLTR ; See if a letter + JP C,CHARTY ; Not a letter - Check type +SVNAM2: LD C,A ; Save second byte of name +ENDNAM: CALL GETCHR ; Get next character + JP C,ENDNAM ; Numeric - Get another + CALL CHKLTR ; See if a letter + JP NC,ENDNAM ; Letter - Get another +CHARTY: SUB '$' ; String variable? + JP NZ,NOTSTR ; No - Numeric variable + INC A ; A = 1 (string type) + LD (TYPE),A ; Set type to string + RRCA ; A = 80H , Flag for string + ADD A,C ; 2nd byte of name has bit 7 on + LD C,A ; Resave second byte on name + CALL GETCHR ; Get next character +NOTSTR: LD A,(FORFLG) ; Array name needed ? + DEC A + JP Z,ARLDSV ; Yes - Get array name + JP P,NSCFOR ; No array with "FOR" or "FN" + LD A,(HL) ; Get byte again + SUB '(' ; Subscripted variable? + JP Z,SBSCPT ; Yes - Sort out subscript + +NSCFOR: XOR A ; Simple variable + LD (FORFLG),A ; Clear "FOR" flag + PUSH HL ; Save code string address + LD D,B ; DE = Variable name to find + LD E,C + LD HL,(FNRGNM) ; FN argument name + CALL CPDEHL ; Is it the FN argument? + LD DE,FNARG ; Point to argument value + JP Z,POPHRT ; Yes - Return FN argument value + LD HL,(VAREND) ; End of variables + EX DE,HL ; Address of end of search + LD HL,(PROGND) ; Start of variables address +FNDVAR: CALL CPDEHL ; End of variable list table? + JP Z,CFEVAL ; Yes - Called from EVAL? + LD A,C ; Get second byte of name + SUB (HL) ; Compare with name in list + INC HL ; Move on to first byte + JP NZ,FNTHR ; Different - Find another + LD A,B ; Get first byte of name + SUB (HL) ; Compare with name in list +FNTHR: INC HL ; Move on to LSB of value + JP Z,RETADR ; Found - Return address + INC HL ; <- Skip + INC HL ; <- over + INC HL ; <- F.P. + INC HL ; <- value + JP FNDVAR ; Keep looking + +CFEVAL: POP HL ; Restore code string address + EX (SP),HL ; Get return address + PUSH DE ; Save address of variable + LD DE,FRMEVL ; Return address in EVAL + CALL CPDEHL ; Called from EVAL ? + POP DE ; Restore address of variable + JP Z,RETNUL ; Yes - Return null variable + EX (SP),HL ; Put back return + PUSH HL ; Save code string address + PUSH BC ; Save variable name + LD BC,6 ; 2 byte name plus 4 byte data + LD HL,(ARREND) ; End of arrays + PUSH HL ; Save end of arrays + ADD HL,BC ; Move up 6 bytes + POP BC ; Source address in BC + PUSH HL ; Save new end address + CALL MOVUP ; Move arrays up + POP HL ; Restore new end address + LD (ARREND),HL ; Set new end address + LD H,B ; End of variables to HL + LD L,C + LD (VAREND),HL ; Set new end address + +ZEROLP: DEC HL ; Back through to zero variable + LD (HL),0 ; Zero byte in variable + CALL CPDEHL ; Done them all? + JP NZ,ZEROLP ; No - Keep on going + POP DE ; Get variable name + LD (HL),E ; Store second character + INC HL + LD (HL),D ; Store first character + INC HL +RETADR: EX DE,HL ; Address of variable in DE + POP HL ; Restore code string address + RET + +RETNUL: LD (FPEXP),A ; Set result to zero + LD HL,ZERBYT ; Also set a null string + LD (FPREG),HL ; Save for EVAL + POP HL ; Restore code string address + RET + +SBSCPT: PUSH HL ; Save code string address + LD HL,(LCRFLG) ; Locate/Create and Type + EX (SP),HL ; Save and get code string + LD D,A ; Zero number of dimensions +SCPTLP: PUSH DE ; Save number of dimensions + PUSH BC ; Save array name + CALL FPSINT ; Get subscript (0-32767) + POP BC ; Restore array name + POP AF ; Get number of dimensions + EX DE,HL + EX (SP),HL ; Save subscript value + PUSH HL ; Save LCRFLG and TYPE + EX DE,HL + INC A ; Count dimensions + LD D,A ; Save in D + LD A,(HL) ; Get next byte in code string + CP ',' ; Comma (more to come)? + JP Z,SCPTLP ; Yes - More subscripts + CALL CHKSYN ; Make sure ")" follows + DB ")" + LD (NXTOPR),HL ; Save code string address + POP HL ; Get LCRFLG and TYPE + LD (LCRFLG),HL ; Restore Locate/create & type + LD E,0 ; Flag not CSAVE* or CLOAD* + PUSH DE ; Save number of dimensions (D) + DB 11H ; Skip "PUSH HL" and "PUSH AF' + +ARLDSV: PUSH HL ; Save code string address + PUSH AF ; A = 00 , Flags set = Z,N + LD HL,(VAREND) ; Start of arrays + DB 3EH ; Skip "ADD HL,DE" +FNDARY: ADD HL,DE ; Move to next array start + EX DE,HL + LD HL,(ARREND) ; End of arrays + EX DE,HL ; Current array pointer + CALL CPDEHL ; End of arrays found? + JP Z,CREARY ; Yes - Create array + LD A,(HL) ; Get second byte of name + CP C ; Compare with name given + INC HL ; Move on + JP NZ,NXTARY ; Different - Find next array + LD A,(HL) ; Get first byte of name + CP B ; Compare with name given +NXTARY: INC HL ; Move on + LD E,(HL) ; Get LSB of next array address + INC HL + LD D,(HL) ; Get MSB of next array address + INC HL + JP NZ,FNDARY ; Not found - Keep looking + LD A,(LCRFLG) ; Found Locate or Create it? + OR A + JP NZ,DDERR ; Create - ?DD Error + POP AF ; Locate - Get number of dim'ns + LD B,H ; BC Points to array dim'ns + LD C,L + JP Z,POPHRT ; Jump if array load/save + SUB (HL) ; Same number of dimensions? + JP Z,FINDEL ; Yes - Find element +BSERR: LD E,BS ; ?BS Error + JP BERROR ; Output error + +CREARY: LD DE,4 ; 4 Bytes per entry + POP AF ; Array to save or 0 dim'ns? + JP Z,FCERR ; Yes - ?FC Error + LD (HL),C ; Save second byte of name + INC HL + LD (HL),B ; Save first byte of name + INC HL + LD C,A ; Number of dimensions to C + CALL CHKSTK ; Check if enough memory + INC HL ; Point to number of dimensions + INC HL + LD (CUROPR),HL ; Save address of pointer + LD (HL),C ; Set number of dimensions + INC HL + LD A,(LCRFLG) ; Locate of Create? + RLA ; Carry set = Create + LD A,C ; Get number of dimensions +CRARLP: LD BC,10+1 ; Default dimension size 10 + JP NC,DEFSIZ ; Locate - Set default size + POP BC ; Get specified dimension size + INC BC ; Include zero element +DEFSIZ: LD (HL),C ; Save LSB of dimension size + INC HL + LD (HL),B ; Save MSB of dimension size + INC HL + PUSH AF ; Save num' of dim'ns an status + PUSH HL ; Save address of dim'n size + CALL MLDEBC ; Multiply DE by BC to find + EX DE,HL ; amount of mem needed (to DE) + POP HL ; Restore address of dimension + POP AF ; Restore number of dimensions + DEC A ; Count them + JP NZ,CRARLP ; Do next dimension if more + PUSH AF ; Save locate/create flag + LD B,D ; MSB of memory needed + LD C,E ; LSB of memory needed + EX DE,HL + ADD HL,DE ; Add bytes to array start + JP C,OMERR ; Too big - Error + CALL ENFMEM ; See if enough memory + LD (ARREND),HL ; Save new end of array + +ZERARY: DEC HL ; Back through array data + LD (HL),0 ; Set array element to zero + CALL CPDEHL ; All elements zeroed? + JP NZ,ZERARY ; No - Keep on going + INC BC ; Number of bytes + 1 + LD D,A ; A=0 + LD HL,(CUROPR) ; Get address of array + LD E,(HL) ; Number of dimensions + EX DE,HL ; To HL + ADD HL,HL ; Two bytes per dimension size + ADD HL,BC ; Add number of bytes + EX DE,HL ; Bytes needed to DE + DEC HL + DEC HL + LD (HL),E ; Save LSB of bytes needed + INC HL + LD (HL),D ; Save MSB of bytes needed + INC HL + POP AF ; Locate / Create? + JP C,ENDDIM ; A is 0 , End if create +FINDEL: LD B,A ; Find array element + LD C,A + LD A,(HL) ; Number of dimensions + INC HL + DB 16H ; Skip "POP HL" +FNDELP: POP HL ; Address of next dim' size + LD E,(HL) ; Get LSB of dim'n size + INC HL + LD D,(HL) ; Get MSB of dim'n size + INC HL + EX (SP),HL ; Save address - Get index + PUSH AF ; Save number of dim'ns + CALL CPDEHL ; Dimension too large? + JP NC,BSERR ; Yes - ?BS Error + PUSH HL ; Save index + CALL MLDEBC ; Multiply previous by size + POP DE ; Index supplied to DE + ADD HL,DE ; Add index to pointer + POP AF ; Number of dimensions + DEC A ; Count them + LD B,H ; MSB of pointer + LD C,L ; LSB of pointer + JP NZ,FNDELP ; More - Keep going + ADD HL,HL ; 4 Bytes per element + ADD HL,HL + POP BC ; Start of array + ADD HL,BC ; Point to element + EX DE,HL ; Address of element to DE +ENDDIM: LD HL,(NXTOPR) ; Got code string address + RET + +FRE: LD HL,(ARREND) ; Start of free memory + EX DE,HL ; To DE + LD HL,0 ; End of free memory + ADD HL,SP ; Current stack value + LD A,(TYPE) ; Dummy argument type + OR A + JP Z,FRENUM ; Numeric - Free variable space + CALL GSTRCU ; Current string to pool + CALL GARBGE ; Garbage collection + LD HL,(STRSPC) ; Bottom of string space in use + EX DE,HL ; To DE + LD HL,(STRBOT) ; Bottom of string space +FRENUM: LD A,L ; Get LSB of end + SUB E ; Subtract LSB of beginning + LD C,A ; Save difference if C + LD A,H ; Get MSB of end + SBC A,D ; Subtract MSB of beginning +ACPASS: LD B,C ; Return integer AC +ABPASS: LD D,B ; Return integer AB + LD E,0 + LD HL,TYPE ; Point to type + LD (HL),E ; Set type to numeric + LD B,80H+16 ; 16 bit integer + JP RETINT ; Return the integr + +POS: LD A,(CURPOS) ; Get cursor position +PASSA: LD B,A ; Put A into AB + XOR A ; Zero A + JP ABPASS ; Return integer AB + +DEF: CALL CHEKFN ; Get "FN" and name + CALL IDTEST ; Test for illegal direct + LD BC,DATA ; To get next statement + PUSH BC ; Save address for RETurn + PUSH DE ; Save address of function ptr + CALL CHKSYN ; Make sure "(" follows + DB "(" + CALL GETVAR ; Get argument variable name + PUSH HL ; Save code string address + EX DE,HL ; Argument address to HL + DEC HL + LD D,(HL) ; Get first byte of arg name + DEC HL + LD E,(HL) ; Get second byte of arg name + POP HL ; Restore code string address + CALL TSTNUM ; Make sure numeric argument + CALL CHKSYN ; Make sure ")" follows + DB ")" + CALL CHKSYN ; Make sure "=" follows + DB ZEQUAL ; "=" token + LD B,H ; Code string address to BC + LD C,L + EX (SP),HL ; Save code str , Get FN ptr + LD (HL),C ; Save LSB of FN code string + INC HL + LD (HL),B ; Save MSB of FN code string + JP SVSTAD ; Save address and do function + +DOFN: CALL CHEKFN ; Make sure FN follows + PUSH DE ; Save function pointer address + CALL EVLPAR ; Evaluate expression in "()" + CALL TSTNUM ; Make sure numeric result + EX (SP),HL ; Save code str , Get FN ptr + LD E,(HL) ; Get LSB of FN code string + INC HL + LD D,(HL) ; Get MSB of FN code string + INC HL + LD A,D ; And function DEFined? + OR E + JP Z,UFERR ; No - ?UF Error + LD A,(HL) ; Get LSB of argument address + INC HL + LD H,(HL) ; Get MSB of argument address + LD L,A ; HL = Arg variable address + PUSH HL ; Save it + LD HL,(FNRGNM) ; Get old argument name + EX (SP),HL ; ; Save old , Get new + LD (FNRGNM),HL ; Set new argument name + LD HL,(FNARG+2) ; Get LSB,NLSB of old arg value + PUSH HL ; Save it + LD HL,(FNARG) ; Get MSB,EXP of old arg value + PUSH HL ; Save it + LD HL,FNARG ; HL = Value of argument + PUSH DE ; Save FN code string address + CALL FPTHL ; Move FPREG to argument + POP HL ; Get FN code string address + CALL GETNUM ; Get value from function + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP NZ,SNERR ; Bad character in FN - Error + POP HL ; Get MSB,EXP of old arg + LD (FNARG),HL ; Restore it + POP HL ; Get LSB,NLSB of old arg + LD (FNARG+2),HL ; Restore it + POP HL ; Get name of old arg + LD (FNRGNM),HL ; Restore it + POP HL ; Restore code string address + RET + +IDTEST: PUSH HL ; Save code string address + LD HL,(LINEAT) ; Get current line number + INC HL ; -1 means direct statement + LD A,H + OR L + POP HL ; Restore code string address + RET NZ ; Return if in program + LD E,ID ; ?ID Error + JP BERROR + +CHEKFN: CALL CHKSYN ; Make sure FN follows + DB ZFN ; "FN" token + LD A,80H + LD (FORFLG),A ; Flag FN name to find + OR (HL) ; FN name has bit 7 set + LD B,A ; in first byte of name + CALL GTFNAM ; Get FN name + JP TSTNUM ; Make sure numeric function + +STR: CALL TSTNUM ; Make sure it's a number + CALL NUMASC ; Turn number into text +STR1: CALL CRTST ; Create string entry for it + CALL GSTRCU ; Current string to pool + LD BC,TOPOOL ; Save in string pool + PUSH BC ; Save address on stack + +SAVSTR: LD A,(HL) ; Get string length + INC HL + INC HL + PUSH HL ; Save pointer to string + CALL TESTR ; See if enough string space + POP HL ; Restore pointer to string + LD C,(HL) ; Get LSB of address + INC HL + LD B,(HL) ; Get MSB of address + CALL CRTMST ; Create string entry + PUSH HL ; Save pointer to MSB of addr + LD L,A ; Length of string + CALL TOSTRA ; Move to string area + POP DE ; Restore pointer to MSB + RET + +MKTMST: CALL TESTR ; See if enough string space +CRTMST: LD HL,TMPSTR ; Temporary string + PUSH HL ; Save it + LD (HL),A ; Save length of string + INC HL +SVSTAD: INC HL + LD (HL),E ; Save LSB of address + INC HL + LD (HL),D ; Save MSB of address + POP HL ; Restore pointer + RET + +CRTST: DEC HL ; DEC - INCed after +QTSTR: LD B,'"' ; Terminating quote + LD D,B ; Quote to D +DTSTR: PUSH HL ; Save start + LD C,-1 ; Set counter to -1 +QTSTLP: INC HL ; Move on + LD A,(HL) ; Get byte + INC C ; Count bytes + OR A ; End of line? + JP Z,CRTSTE ; Yes - Create string entry + CP D ; Terminator D found? + JP Z,CRTSTE ; Yes - Create string entry + CP B ; Terminator B found? + JP NZ,QTSTLP ; No - Keep looking +CRTSTE: CP '"' ; End with '"'? + CALL Z,GETCHR ; Yes - Get next character + EX (SP),HL ; Starting quote + INC HL ; First byte of string + EX DE,HL ; To DE + LD A,C ; Get length + CALL CRTMST ; Create string entry +TSTOPL: LD DE,TMPSTR ; Temporary string + LD HL,(TMSTPT) ; Temporary string pool pointer + LD (FPREG),HL ; Save address of string ptr + LD A,1 + LD (TYPE),A ; Set type to string + CALL DETHL4 ; Move string to pool + CALL CPDEHL ; Out of string pool? + LD (TMSTPT),HL ; Save new pointer + POP HL ; Restore code string address + LD A,(HL) ; Get next code byte + RET NZ ; Return if pool OK + LD E,ST ; ?ST Error + JP BERROR ; String pool overflow + +PRNUMS: INC HL ; Skip leading space +PRS: CALL CRTST ; Create string entry for it +PRS1: CALL GSTRCU ; Current string to pool + CALL LOADFP ; Move string block to BCDE + INC E ; Length + 1 +PRSLP: DEC E ; Count characters + RET Z ; End of string + LD A,(BC) ; Get byte to output + CALL OUTC ; Output character in A + CP CR ; Return? + CALL Z,DONULL ; Yes - Do nulls + INC BC ; Next byte in string + JP PRSLP ; More characters to output + +TESTR: OR A ; Test if enough room + DB 0EH ; No garbage collection done +GRBDON: POP AF ; Garbage collection done + PUSH AF ; Save status + LD HL,(STRSPC) ; Bottom of string space in use + EX DE,HL ; To DE + LD HL,(STRBOT) ; Bottom of string area + CPL ; Negate length (Top down) + LD C,A ; -Length to BC + LD B,-1 ; BC = -ve length of string + ADD HL,BC ; Add to bottom of space in use + INC HL ; Plus one for 2's complement + CALL CPDEHL ; Below string RAM area? + JP C,TESTOS ; Tidy up if not done else err + LD (STRBOT),HL ; Save new bottom of area + INC HL ; Point to first byte of string + EX DE,HL ; Address to DE +POPAF: POP AF ; Throw away status push + RET + +TESTOS: POP AF ; Garbage collect been done? + LD E,OS ; ?OS Error + JP Z,BERROR ; Yes - Not enough string apace + CP A ; Flag garbage collect done + PUSH AF ; Save status + LD BC,GRBDON ; Garbage collection done + PUSH BC ; Save for RETurn +GARBGE: LD HL,(LSTRAM) ; Get end of RAM pointer +GARBLP: LD (STRBOT),HL ; Reset string pointer + LD HL,0 + PUSH HL ; Flag no string found + LD HL,(STRSPC) ; Get bottom of string space + PUSH HL ; Save bottom of string space + LD HL,TMSTPL ; Temporary string pool +GRBLP: EX DE,HL + LD HL,(TMSTPT) ; Temporary string pool pointer + EX DE,HL + CALL CPDEHL ; Temporary string pool done? + LD BC,GRBLP ; Loop until string pool done + JP NZ,STPOOL ; No - See if in string area + LD HL,(PROGND) ; Start of simple variables +SMPVAR: EX DE,HL + LD HL,(VAREND) ; End of simple variables + EX DE,HL + CALL CPDEHL ; All simple strings done? + JP Z,ARRLP ; Yes - Do string arrays + LD A,(HL) ; Get type of variable + INC HL + INC HL + OR A ; "S" flag set if string + CALL STRADD ; See if string in string area + JP SMPVAR ; Loop until simple ones done + +GNXARY: POP BC ; Scrap address of this array +ARRLP: EX DE,HL + LD HL,(ARREND) ; End of string arrays + EX DE,HL + CALL CPDEHL ; All string arrays done? + JP Z,SCNEND ; Yes - Move string if found + CALL LOADFP ; Get array name to BCDE + LD A,E ; Get type of array + PUSH HL ; Save address of num of dim'ns + ADD HL,BC ; Start of next array + OR A ; Test type of array + JP P,GNXARY ; Numeric array - Ignore it + LD (CUROPR),HL ; Save address of next array + POP HL ; Get address of num of dim'ns + LD C,(HL) ; BC = Number of dimensions + LD B,0 + ADD HL,BC ; Two bytes per dimension size + ADD HL,BC + INC HL ; Plus one for number of dim'ns +GRBARY: EX DE,HL + LD HL,(CUROPR) ; Get address of next array + EX DE,HL + CALL CPDEHL ; Is this array finished? + JP Z,ARRLP ; Yes - Get next one + LD BC,GRBARY ; Loop until array all done +STPOOL: PUSH BC ; Save return address + OR 80H ; Flag string type +STRADD: LD A,(HL) ; Get string length + INC HL + INC HL + LD E,(HL) ; Get LSB of string address + INC HL + LD D,(HL) ; Get MSB of string address + INC HL + RET P ; Not a string - Return + OR A ; Set flags on string length + RET Z ; Null string - Return + LD B,H ; Save variable pointer + LD C,L + LD HL,(STRBOT) ; Bottom of new area + CALL CPDEHL ; String been done? + LD H,B ; Restore variable pointer + LD L,C + RET C ; String done - Ignore + POP HL ; Return address + EX (SP),HL ; Lowest available string area + CALL CPDEHL ; String within string area? + EX (SP),HL ; Lowest available string area + PUSH HL ; Re-save return address + LD H,B ; Restore variable pointer + LD L,C + RET NC ; Outside string area - Ignore + POP BC ; Get return , Throw 2 away + POP AF ; + POP AF ; + PUSH HL ; Save variable pointer + PUSH DE ; Save address of current + PUSH BC ; Put back return address + RET ; Go to it + +SCNEND: POP DE ; Addresses of strings + POP HL ; + LD A,L ; HL = 0 if no more to do + OR H + RET Z ; No more to do - Return + DEC HL + LD B,(HL) ; MSB of address of string + DEC HL + LD C,(HL) ; LSB of address of string + PUSH HL ; Save variable address + DEC HL + DEC HL + LD L,(HL) ; HL = Length of string + LD H,0 + ADD HL,BC ; Address of end of string+1 + LD D,B ; String address to DE + LD E,C + DEC HL ; Last byte in string + LD B,H ; Address to BC + LD C,L + LD HL,(STRBOT) ; Current bottom of string area + CALL MOVSTR ; Move string to new address + POP HL ; Restore variable address + LD (HL),C ; Save new LSB of address + INC HL + LD (HL),B ; Save new MSB of address + LD L,C ; Next string area+1 to HL + LD H,B + DEC HL ; Next string area address + JP GARBLP ; Look for more strings + +CONCAT: PUSH BC ; Save prec' opr & code string + PUSH HL ; + LD HL,(FPREG) ; Get first string + EX (SP),HL ; Save first string + CALL OPRND ; Get second string + EX (SP),HL ; Restore first string + CALL TSTSTR ; Make sure it's a string + LD A,(HL) ; Get length of second string + PUSH HL ; Save first string + LD HL,(FPREG) ; Get second string + PUSH HL ; Save second string + ADD A,(HL) ; Add length of second string + LD E,LS ; ?LS Error + JP C,BERROR ; String too long - Error + CALL MKTMST ; Make temporary string + POP DE ; Get second string to DE + CALL GSTRDE ; Move to string pool if needed + EX (SP),HL ; Get first string + CALL GSTRHL ; Move to string pool if needed + PUSH HL ; Save first string + LD HL,(TMPSTR+2) ; Temporary string address + EX DE,HL ; To DE + CALL SSTSA ; First string to string area + CALL SSTSA ; Second string to string area + LD HL,EVAL2 ; Return to evaluation loop + EX (SP),HL ; Save return,get code string + PUSH HL ; Save code string address + JP TSTOPL ; To temporary string to pool + +SSTSA: POP HL ; Return address + EX (SP),HL ; Get string block,save return + LD A,(HL) ; Get length of string + INC HL + INC HL + LD C,(HL) ; Get LSB of string address + INC HL + LD B,(HL) ; Get MSB of string address + LD L,A ; Length to L +TOSTRA: INC L ; INC - DECed after +TSALP: DEC L ; Count bytes moved + RET Z ; End of string - Return + LD A,(BC) ; Get source + LD (DE),A ; Save destination + INC BC ; Next source + INC DE ; Next destination + JP TSALP ; Loop until string moved + +GETSTR: CALL TSTSTR ; Make sure it's a string +GSTRCU: LD HL,(FPREG) ; Get current string +GSTRHL: EX DE,HL ; Save DE +GSTRDE: CALL BAKTMP ; Was it last tmp-str? + EX DE,HL ; Restore DE + RET NZ ; No - Return + PUSH DE ; Save string + LD D,B ; String block address to DE + LD E,C + DEC DE ; Point to length + LD C,(HL) ; Get string length + LD HL,(STRBOT) ; Current bottom of string area + CALL CPDEHL ; Last one in string area? + JP NZ,POPHL ; No - Return + LD B,A ; Clear B (A=0) + ADD HL,BC ; Remove string from str' area + LD (STRBOT),HL ; Save new bottom of str' area +POPHL: POP HL ; Restore string + RET + +BAKTMP: LD HL,(TMSTPT) ; Get temporary string pool top + DEC HL ; Back + LD B,(HL) ; Get MSB of address + DEC HL ; Back + LD C,(HL) ; Get LSB of address + DEC HL ; Back + DEC HL ; Back + CALL CPDEHL ; String last in string pool? + RET NZ ; Yes - Leave it + LD (TMSTPT),HL ; Save new string pool top + RET + +LEN: LD BC,PASSA ; To return integer A + PUSH BC ; Save address +GETLEN: CALL GETSTR ; Get string and its length + XOR A + LD D,A ; Clear D + LD (TYPE),A ; Set type to numeric + LD A,(HL) ; Get length of string + OR A ; Set status flags + RET + +ASC: LD BC,PASSA ; To return integer A + PUSH BC ; Save address +GTFLNM: CALL GETLEN ; Get length of string + JP Z,FCERR ; Null string - Error + INC HL + INC HL + LD E,(HL) ; Get LSB of address + INC HL + LD D,(HL) ; Get MSB of address + LD A,(DE) ; Get first byte of string + RET + +CHR: LD A,1 ; One character string + CALL MKTMST ; Make a temporary string + CALL MAKINT ; Make it integer A + LD HL,(TMPSTR+2) ; Get address of string + LD (HL),E ; Save character +TOPOOL: POP BC ; Clean up stack + JP TSTOPL ; Temporary string to pool + +LEFT: CALL LFRGNM ; Get number and ending ")" + XOR A ; Start at first byte in string +RIGHT1: EX (SP),HL ; Save code string,Get string + LD C,A ; Starting position in string +MID1: PUSH HL ; Save string block address + LD A,(HL) ; Get length of string + CP B ; Compare with number given + JP C,ALLFOL ; All following bytes required + LD A,B ; Get new length + DB 11H ; Skip "LD C,0" +ALLFOL: LD C,0 ; First byte of string + PUSH BC ; Save position in string + CALL TESTR ; See if enough string space + POP BC ; Get position in string + POP HL ; Restore string block address + PUSH HL ; And re-save it + INC HL + INC HL + LD B,(HL) ; Get LSB of address + INC HL + LD H,(HL) ; Get MSB of address + LD L,B ; HL = address of string + LD B,0 ; BC = starting address + ADD HL,BC ; Point to that byte + LD B,H ; BC = source string + LD C,L + CALL CRTMST ; Create a string entry + LD L,A ; Length of new string + CALL TOSTRA ; Move string to string area + POP DE ; Clear stack + CALL GSTRDE ; Move to string pool if needed + JP TSTOPL ; Temporary string to pool + +RIGHT: CALL LFRGNM ; Get number and ending ")" + POP DE ; Get string length + PUSH DE ; And re-save + LD A,(DE) ; Get length + SUB B ; Move back N bytes + JP RIGHT1 ; Go and get sub-string + +MID: EX DE,HL ; Get code string address + LD A,(HL) ; Get next byte ',' or ")" + CALL MIDNUM ; Get number supplied + INC B ; Is it character zero? + DEC B + JP Z,FCERR ; Yes - Error + PUSH BC ; Save starting position + LD E,255 ; All of string + CP ')' ; Any length given? + JP Z,RSTSTR ; No - Rest of string + CALL CHKSYN ; Make sure ',' follows + DB ',' + CALL GETINT ; Get integer 0-255 +RSTSTR: CALL CHKSYN ; Make sure ")" follows + DB ")" + POP AF ; Restore starting position + EX (SP),HL ; Get string,8ave code string + LD BC,MID1 ; Continuation of MID$ routine + PUSH BC ; Save for return + DEC A ; Starting position-1 + CP (HL) ; Compare with length + LD B,0 ; Zero bytes length + RET NC ; Null string if start past end + LD C,A ; Save starting position-1 + LD A,(HL) ; Get length of string + SUB C ; Subtract start + CP E ; Enough string for it? + LD B,A ; Save maximum length available + RET C ; Truncate string if needed + LD B,E ; Set specified length + RET ; Go and create string + +VAL: CALL GETLEN ; Get length of string + JP Z,RESZER ; Result zero + LD E,A ; Save length + INC HL + INC HL + LD A,(HL) ; Get LSB of address + INC HL + LD H,(HL) ; Get MSB of address + LD L,A ; HL = String address + PUSH HL ; Save string address + ADD HL,DE + LD B,(HL) ; Get end of string+1 byte + LD (HL),D ; Zero it to terminate + EX (SP),HL ; Save string end,get start + PUSH BC ; Save end+1 byte + LD A,(HL) ; Get starting byte + CP '$' ; Hex number indicated? [function added G. Searle] + JP NZ,VAL1 + CALL HEXTFP ; Convert Hex to FPREG + JR VAL3 +VAL1: CP '%' ; Binary number indicated? [function added] + JP NZ,VAL2 + CALL BINTFP ; Convert Bin to FPREG + JR VAL3 +VAL2: CALL ASCTFP ; Convert ASCII string to FP +VAL3: POP BC ; Restore end+1 byte + POP HL ; Restore end+1 address + LD (HL),B ; Put back original byte + RET + +LFRGNM: EX DE,HL ; Code string address to HL + CALL CHKSYN ; Make sure ")" follows + DB ")" +MIDNUM: POP BC ; Get return address + POP DE ; Get number supplied + PUSH BC ; Re-save return address + LD B,E ; Number to B + RET + +INP: CALL MAKINT ; Make it integer A + LD (INPORT),A ; Set input port + CALL INPSUB ; Get input from port + JP PASSA ; Return integer A + +POUT: CALL SETIO ; Set up port number + JP OUTSUB ; Output data and return + +WAIT: CALL SETIO ; Set up port number + PUSH AF ; Save AND mask + LD E,0 ; Assume zero if none given + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP Z,NOXOR ; No XOR byte given + CALL CHKSYN ; Make sure ',' follows + DB ',' + CALL GETINT ; Get integer 0-255 to XOR with +NOXOR: POP BC ; Restore AND mask +WAITLP: CALL INPSUB ; Get input + XOR E ; Flip selected bits + AND B ; Result non-zero? + JP Z,WAITLP ; No = keep waiting + RET + +SETIO: CALL GETINT ; Get integer 0-255 + LD (INPORT),A ; Set input port + LD (OTPORT),A ; Set output port + CALL CHKSYN ; Make sure ',' follows + DB ',' + JP GETINT ; Get integer 0-255 and return + +FNDNUM: CALL GETCHR ; Get next character +GETINT: CALL GETNUM ; Get a number from 0 to 255 +MAKINT: CALL DEPINT ; Make sure value 0 - 255 + LD A,D ; Get MSB of number + OR A ; Zero? + JP NZ,FCERR ; No - Error + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + LD A,E ; Get number to A + RET + +PEEK: CALL DEINT ; Get memory address + LD A,(DE) ; Get byte in memory + JP PASSA ; Return integer A + +POKE: CALL GETNUM ; Get memory address + CALL DEINT ; Get integer -32768 to 3276 + PUSH DE ; Save memory address + CALL CHKSYN ; Make sure ',' follows + DB ',' + CALL GETINT ; Get integer 0-255 + POP DE ; Restore memory address + LD (DE),A ; Load it into memory + RET + +ROUND: LD HL,HALF ; Add 0.5 to FPREG +ADDPHL: CALL LOADFP ; Load FP at (HL) to BCDE + JP FPADD ; Add BCDE to FPREG + +SUBPHL: CALL LOADFP ; FPREG = -FPREG + number at HL + DB 21H ; Skip "POP BC" and "POP DE" +PSUB: POP BC ; Get FP number from stack + POP DE +SUBCDE: CALL INVSGN ; Negate FPREG +FPADD: LD A,B ; Get FP exponent + OR A ; Is number zero? + RET Z ; Yes - Nothing to add + LD A,(FPEXP) ; Get FPREG exponent + OR A ; Is this number zero? + JP Z,FPBCDE ; Yes - Move BCDE to FPREG + SUB B ; BCDE number larger? + JP NC,NOSWAP ; No - Don't swap them + CPL ; Two's complement + INC A ; FP exponent + EX DE,HL + CALL STAKFP ; Put FPREG on stack + EX DE,HL + CALL FPBCDE ; Move BCDE to FPREG + POP BC ; Restore number from stack + POP DE +NOSWAP: CP 24+1 ; Second number insignificant? + RET NC ; Yes - First number is result + PUSH AF ; Save number of bits to scale + CALL SIGNS ; Set MSBs & sign of result + LD H,A ; Save sign of result + POP AF ; Restore scaling factor + CALL SCALE ; Scale BCDE to same exponent + OR H ; Result to be positive? + LD HL,FPREG ; Point to FPREG + JP P,MINCDE ; No - Subtract FPREG from CDE + CALL PLUCDE ; Add FPREG to CDE + JP NC,RONDUP ; No overflow - Round it up + INC HL ; Point to exponent + INC (HL) ; Increment it + JP Z,OVERR ; Number overflowed - Error + LD L,1 ; 1 bit to shift right + CALL SHRT1 ; Shift result right + JP RONDUP ; Round it up + +MINCDE: XOR A ; Clear A and carry + SUB B ; Negate exponent + LD B,A ; Re-save exponent + LD A,(HL) ; Get LSB of FPREG + SBC A, E ; Subtract LSB of BCDE + LD E,A ; Save LSB of BCDE + INC HL + LD A,(HL) ; Get NMSB of FPREG + SBC A,D ; Subtract NMSB of BCDE + LD D,A ; Save NMSB of BCDE + INC HL + LD A,(HL) ; Get MSB of FPREG + SBC A,C ; Subtract MSB of BCDE + LD C,A ; Save MSB of BCDE +CONPOS: CALL C,COMPL ; Overflow - Make it positive + +BNORM: LD L,B ; L = Exponent + LD H,E ; H = LSB + XOR A +BNRMLP: LD B,A ; Save bit count + LD A,C ; Get MSB + OR A ; Is it zero? + JP NZ,PNORM ; No - Do it bit at a time + LD C,D ; MSB = NMSB + LD D,H ; NMSB= LSB + LD H,L ; LSB = VLSB + LD L,A ; VLSB= 0 + LD A,B ; Get exponent + SUB 8 ; Count 8 bits + CP -24-8 ; Was number zero? + JP NZ,BNRMLP ; No - Keep normalising +RESZER: XOR A ; Result is zero +SAVEXP: LD (FPEXP),A ; Save result as zero + RET + +NORMAL: DEC B ; Count bits + ADD HL,HL ; Shift HL left + LD A,D ; Get NMSB + RLA ; Shift left with last bit + LD D,A ; Save NMSB + LD A,C ; Get MSB + ADC A,A ; Shift left with last bit + LD C,A ; Save MSB +PNORM: JP P,NORMAL ; Not done - Keep going + LD A,B ; Number of bits shifted + LD E,H ; Save HL in EB + LD B,L + OR A ; Any shifting done? + JP Z,RONDUP ; No - Round it up + LD HL,FPEXP ; Point to exponent + ADD A,(HL) ; Add shifted bits + LD (HL),A ; Re-save exponent + JP NC,RESZER ; Underflow - Result is zero + RET Z ; Result is zero +RONDUP: LD A,B ; Get VLSB of number +RONDB: LD HL,FPEXP ; Point to exponent + OR A ; Any rounding? + CALL M,FPROND ; Yes - Round number up + LD B,(HL) ; B = Exponent + INC HL + LD A,(HL) ; Get sign of result + AND 10000000B ; Only bit 7 needed + XOR C ; Set correct sign + LD C,A ; Save correct sign in number + JP FPBCDE ; Move BCDE to FPREG + +FPROND: INC E ; Round LSB + RET NZ ; Return if ok + INC D ; Round NMSB + RET NZ ; Return if ok + INC C ; Round MSB + RET NZ ; Return if ok + LD C,80H ; Set normal value + INC (HL) ; Increment exponent + RET NZ ; Return if ok + JP OVERR ; Overflow error + +PLUCDE: LD A,(HL) ; Get LSB of FPREG + ADD A,E ; Add LSB of BCDE + LD E,A ; Save LSB of BCDE + INC HL + LD A,(HL) ; Get NMSB of FPREG + ADC A,D ; Add NMSB of BCDE + LD D,A ; Save NMSB of BCDE + INC HL + LD A,(HL) ; Get MSB of FPREG + ADC A,C ; Add MSB of BCDE + LD C,A ; Save MSB of BCDE + RET + +COMPL: LD HL,SGNRES ; Sign of result + LD A,(HL) ; Get sign of result + CPL ; Negate it + LD (HL),A ; Put it back + XOR A + LD L,A ; Set L to zero + SUB B ; Negate exponent,set carry + LD B,A ; Re-save exponent + LD A,L ; Load zero + SBC A,E ; Negate LSB + LD E,A ; Re-save LSB + LD A,L ; Load zero + SBC A,D ; Negate NMSB + LD D,A ; Re-save NMSB + LD A,L ; Load zero + SBC A,C ; Negate MSB + LD C,A ; Re-save MSB + RET + +SCALE: LD B,0 ; Clear underflow +SCALLP: SUB 8 ; 8 bits (a whole byte)? + JP C,SHRITE ; No - Shift right A bits + LD B,E ; <- Shift + LD E,D ; <- right + LD D,C ; <- eight + LD C,0 ; <- bits + JP SCALLP ; More bits to shift + +SHRITE: ADD A,8+1 ; Adjust count + LD L,A ; Save bits to shift +SHRLP: XOR A ; Flag for all done + DEC L ; All shifting done? + RET Z ; Yes - Return + LD A,C ; Get MSB +SHRT1: RRA ; Shift it right + LD C,A ; Re-save + LD A,D ; Get NMSB + RRA ; Shift right with last bit + LD D,A ; Re-save it + LD A,E ; Get LSB + RRA ; Shift right with last bit + LD E,A ; Re-save it + LD A,B ; Get underflow + RRA ; Shift right with last bit + LD B,A ; Re-save underflow + JP SHRLP ; More bits to do + +UNITY: DB 000H,000H,000H,081H ; 1.00000 + +LOGTAB: DB 3 ; Table used by LOG + DB 0AAH,056H,019H,080H ; 0.59898 + DB 0F1H,022H,076H,080H ; 0.96147 + DB 045H,0AAH,038H,082H ; 2.88539 + +LOG: CALL TSTSGN ; Test sign of value + OR A + JP PE,FCERR ; ?FC Error if <= zero + LD HL,FPEXP ; Point to exponent + LD A,(HL) ; Get exponent + LD BC,8035H ; BCDE = SQR(1/2) + LD DE,04F3H + SUB B ; Scale value to be < 1 + PUSH AF ; Save scale factor + LD (HL),B ; Save new exponent + PUSH DE ; Save SQR(1/2) + PUSH BC + CALL FPADD ; Add SQR(1/2) to value + POP BC ; Restore SQR(1/2) + POP DE + INC B ; Make it SQR(2) + CALL DVBCDE ; Divide by SQR(2) + LD HL,UNITY ; Point to 1. + CALL SUBPHL ; Subtract FPREG from 1 + LD HL,LOGTAB ; Coefficient table + CALL SUMSER ; Evaluate sum of series + LD BC,8080H ; BCDE = -0.5 + LD DE,0000H + CALL FPADD ; Subtract 0.5 from FPREG + POP AF ; Restore scale factor + CALL RSCALE ; Re-scale number +MULLN2: LD BC,8031H ; BCDE = Ln(2) + LD DE,7218H + DB 21H ; Skip "POP BC" and "POP DE" + +MULT: POP BC ; Get number from stack + POP DE +FPMULT: CALL TSTSGN ; Test sign of FPREG + RET Z ; Return zero if zero + LD L,0 ; Flag add exponents + CALL ADDEXP ; Add exponents + LD A,C ; Get MSB of multiplier + LD (MULVAL),A ; Save MSB of multiplier + EX DE,HL + LD (MULVAL+1),HL ; Save rest of multiplier + LD BC,0 ; Partial product (BCDE) = zero + LD D,B + LD E,B + LD HL,BNORM ; Address of normalise + PUSH HL ; Save for return + LD HL,MULT8 ; Address of 8 bit multiply + PUSH HL ; Save for NMSB,MSB + PUSH HL ; + LD HL,FPREG ; Point to number +MULT8: LD A,(HL) ; Get LSB of number + INC HL ; Point to NMSB + OR A ; Test LSB + JP Z,BYTSFT ; Zero - shift to next byte + PUSH HL ; Save address of number + LD L,8 ; 8 bits to multiply by +MUL8LP: RRA ; Shift LSB right + LD H,A ; Save LSB + LD A,C ; Get MSB + JP NC,NOMADD ; Bit was zero - Don't add + PUSH HL ; Save LSB and count + LD HL,(MULVAL+1) ; Get LSB and NMSB + ADD HL,DE ; Add NMSB and LSB + EX DE,HL ; Leave sum in DE + POP HL ; Restore MSB and count + LD A,(MULVAL) ; Get MSB of multiplier + ADC A,C ; Add MSB +NOMADD: RRA ; Shift MSB right + LD C,A ; Re-save MSB + LD A,D ; Get NMSB + RRA ; Shift NMSB right + LD D,A ; Re-save NMSB + LD A,E ; Get LSB + RRA ; Shift LSB right + LD E,A ; Re-save LSB + LD A,B ; Get VLSB + RRA ; Shift VLSB right + LD B,A ; Re-save VLSB + DEC L ; Count bits multiplied + LD A,H ; Get LSB of multiplier + JP NZ,MUL8LP ; More - Do it +POPHRT: POP HL ; Restore address of number + RET + +BYTSFT: LD B,E ; Shift partial product left + LD E,D + LD D,C + LD C,A + RET + +DIV10: CALL STAKFP ; Save FPREG on stack + LD BC,8420H ; BCDE = 10. + LD DE,0000H + CALL FPBCDE ; Move 10 to FPREG + +DIV: POP BC ; Get number from stack + POP DE +DVBCDE: CALL TSTSGN ; Test sign of FPREG + JP Z,DZERR ; Error if division by zero + LD L,-1 ; Flag subtract exponents + CALL ADDEXP ; Subtract exponents + INC (HL) ; Add 2 to exponent to adjust + INC (HL) + DEC HL ; Point to MSB + LD A,(HL) ; Get MSB of dividend + LD (DIV3),A ; Save for subtraction + DEC HL + LD A,(HL) ; Get NMSB of dividend + LD (DIV2),A ; Save for subtraction + DEC HL + LD A,(HL) ; Get MSB of dividend + LD (DIV1),A ; Save for subtraction + LD B,C ; Get MSB + EX DE,HL ; NMSB,LSB to HL + XOR A + LD C,A ; Clear MSB of quotient + LD D,A ; Clear NMSB of quotient + LD E,A ; Clear LSB of quotient + LD (DIV4),A ; Clear overflow count +DIVLP: PUSH HL ; Save divisor + PUSH BC + LD A,L ; Get LSB of number + CALL DIVSUP ; Subt' divisor from dividend + SBC A,0 ; Count for overflows + CCF + JP NC,RESDIV ; Restore divisor if borrow + LD (DIV4),A ; Re-save overflow count + POP AF ; Scrap divisor + POP AF + SCF ; Set carry to + DB 0D2H ; Skip "POP BC" and "POP HL" + +RESDIV: POP BC ; Restore divisor + POP HL + LD A,C ; Get MSB of quotient + INC A + DEC A + RRA ; Bit 0 to bit 7 + JP M,RONDB ; Done - Normalise result + RLA ; Restore carry + LD A,E ; Get LSB of quotient + RLA ; Double it + LD E,A ; Put it back + LD A,D ; Get NMSB of quotient + RLA ; Double it + LD D,A ; Put it back + LD A,C ; Get MSB of quotient + RLA ; Double it + LD C,A ; Put it back + ADD HL,HL ; Double NMSB,LSB of divisor + LD A,B ; Get MSB of divisor + RLA ; Double it + LD B,A ; Put it back + LD A,(DIV4) ; Get VLSB of quotient + RLA ; Double it + LD (DIV4),A ; Put it back + LD A,C ; Get MSB of quotient + OR D ; Merge NMSB + OR E ; Merge LSB + JP NZ,DIVLP ; Not done - Keep dividing + PUSH HL ; Save divisor + LD HL,FPEXP ; Point to exponent + DEC (HL) ; Divide by 2 + POP HL ; Restore divisor + JP NZ,DIVLP ; Ok - Keep going + JP OVERR ; Overflow error + +ADDEXP: LD A,B ; Get exponent of dividend + OR A ; Test it + JP Z,OVTST3 ; Zero - Result zero + LD A,L ; Get add/subtract flag + LD HL,FPEXP ; Point to exponent + XOR (HL) ; Add or subtract it + ADD A,B ; Add the other exponent + LD B,A ; Save new exponent + RRA ; Test exponent for overflow + XOR B + LD A,B ; Get exponent + JP P,OVTST2 ; Positive - Test for overflow + ADD A,80H ; Add excess 128 + LD (HL),A ; Save new exponent + JP Z,POPHRT ; Zero - Result zero + CALL SIGNS ; Set MSBs and sign of result + LD (HL),A ; Save new exponent + DEC HL ; Point to MSB + RET + +OVTST1: CALL TSTSGN ; Test sign of FPREG + CPL ; Invert sign + POP HL ; Clean up stack +OVTST2: OR A ; Test if new exponent zero +OVTST3: POP HL ; Clear off return address + JP P,RESZER ; Result zero + JP OVERR ; Overflow error + +MLSP10: CALL BCDEFP ; Move FPREG to BCDE + LD A,B ; Get exponent + OR A ; Is it zero? + RET Z ; Yes - Result is zero + ADD A,2 ; Multiply by 4 + JP C,OVERR ; Overflow - ?OV Error + LD B,A ; Re-save exponent + CALL FPADD ; Add BCDE to FPREG (Times 5) + LD HL,FPEXP ; Point to exponent + INC (HL) ; Double number (Times 10) + RET NZ ; Ok - Return + JP OVERR ; Overflow error + +TSTSGN: LD A,(FPEXP) ; Get sign of FPREG + OR A + RET Z ; RETurn if number is zero + LD A,(FPREG+2) ; Get MSB of FPREG + DB 0FEH ; Test sign +RETREL: CPL ; Invert sign + RLA ; Sign bit to carry +FLGDIF: SBC A,A ; Carry to all bits of A + RET NZ ; Return -1 if negative + INC A ; Bump to +1 + RET ; Positive - Return +1 + +SGN: CALL TSTSGN ; Test sign of FPREG +FLGREL: LD B,80H+8 ; 8 bit integer in exponent + LD DE,0 ; Zero NMSB and LSB +RETINT: LD HL,FPEXP ; Point to exponent + LD C,A ; CDE = MSB,NMSB and LSB + LD (HL),B ; Save exponent + LD B,0 ; CDE = integer to normalise + INC HL ; Point to sign of result + LD (HL),80H ; Set sign of result + RLA ; Carry = sign of integer + JP CONPOS ; Set sign of result + +ABS: CALL TSTSGN ; Test sign of FPREG + RET P ; Return if positive +INVSGN: LD HL,FPREG+2 ; Point to MSB + LD A,(HL) ; Get sign of mantissa + XOR 80H ; Invert sign of mantissa + LD (HL),A ; Re-save sign of mantissa + RET + +STAKFP: EX DE,HL ; Save code string address + LD HL,(FPREG) ; LSB,NLSB of FPREG + EX (SP),HL ; Stack them,get return + PUSH HL ; Re-save return + LD HL,(FPREG+2) ; MSB and exponent of FPREG + EX (SP),HL ; Stack them,get return + PUSH HL ; Re-save return + EX DE,HL ; Restore code string address + RET + +PHLTFP: CALL LOADFP ; Number at HL to BCDE +FPBCDE: EX DE,HL ; Save code string address + LD (FPREG),HL ; Save LSB,NLSB of number + LD H,B ; Exponent of number + LD L,C ; MSB of number + LD (FPREG+2),HL ; Save MSB and exponent + EX DE,HL ; Restore code string address + RET + +BCDEFP: LD HL,FPREG ; Point to FPREG +LOADFP: LD E,(HL) ; Get LSB of number + INC HL + LD D,(HL) ; Get NMSB of number + INC HL + LD C,(HL) ; Get MSB of number + INC HL + LD B,(HL) ; Get exponent of number +INCHL: INC HL ; Used for conditional "INC HL" + RET + +FPTHL: LD DE,FPREG ; Point to FPREG +DETHL4: LD B,4 ; 4 bytes to move +DETHLB: LD A,(DE) ; Get source + LD (HL),A ; Save destination + INC DE ; Next source + INC HL ; Next destination + DEC B ; Count bytes + JP NZ,DETHLB ; Loop if more + RET + +SIGNS: LD HL,FPREG+2 ; Point to MSB of FPREG + LD A,(HL) ; Get MSB + RLCA ; Old sign to carry + SCF ; Set MSBit + RRA ; Set MSBit of MSB + LD (HL),A ; Save new MSB + CCF ; Complement sign + RRA ; Old sign to carry + INC HL + INC HL + LD (HL),A ; Set sign of result + LD A,C ; Get MSB + RLCA ; Old sign to carry + SCF ; Set MSBit + RRA ; Set MSBit of MSB + LD C,A ; Save MSB + RRA + XOR (HL) ; New sign of result + RET + +CMPNUM: LD A,B ; Get exponent of number + OR A + JP Z,TSTSGN ; Zero - Test sign of FPREG + LD HL,RETREL ; Return relation routine + PUSH HL ; Save for return + CALL TSTSGN ; Test sign of FPREG + LD A,C ; Get MSB of number + RET Z ; FPREG zero - Number's MSB + LD HL,FPREG+2 ; MSB of FPREG + XOR (HL) ; Combine signs + LD A,C ; Get MSB of number + RET M ; Exit if signs different + CALL CMPFP ; Compare FP numbers + RRA ; Get carry to sign + XOR C ; Combine with MSB of number + RET + +CMPFP: INC HL ; Point to exponent + LD A,B ; Get exponent + CP (HL) ; Compare exponents + RET NZ ; Different + DEC HL ; Point to MBS + LD A,C ; Get MSB + CP (HL) ; Compare MSBs + RET NZ ; Different + DEC HL ; Point to NMSB + LD A,D ; Get NMSB + CP (HL) ; Compare NMSBs + RET NZ ; Different + DEC HL ; Point to LSB + LD A,E ; Get LSB + SUB (HL) ; Compare LSBs + RET NZ ; Different + POP HL ; Drop RETurn + POP HL ; Drop another RETurn + RET + +FPINT: LD B,A ; <- Move + LD C,A ; <- exponent + LD D,A ; <- to all + LD E,A ; <- bits + OR A ; Test exponent + RET Z ; Zero - Return zero + PUSH HL ; Save pointer to number + CALL BCDEFP ; Move FPREG to BCDE + CALL SIGNS ; Set MSBs & sign of result + XOR (HL) ; Combine with sign of FPREG + LD H,A ; Save combined signs + CALL M,DCBCDE ; Negative - Decrement BCDE + LD A,80H+24 ; 24 bits + SUB B ; Bits to shift + CALL SCALE ; Shift BCDE + LD A,H ; Get combined sign + RLA ; Sign to carry + CALL C,FPROND ; Negative - Round number up + LD B,0 ; Zero exponent + CALL C,COMPL ; If negative make positive + POP HL ; Restore pointer to number + RET + +DCBCDE: DEC DE ; Decrement BCDE + LD A,D ; Test LSBs + AND E + INC A + RET NZ ; Exit if LSBs not FFFF + DEC BC ; Decrement MSBs + RET + +INT: LD HL,FPEXP ; Point to exponent + LD A,(HL) ; Get exponent + CP 80H+24 ; Integer accuracy only? + LD A,(FPREG) ; Get LSB + RET NC ; Yes - Already integer + LD A,(HL) ; Get exponent + CALL FPINT ; F.P to integer + LD (HL),80H+24 ; Save 24 bit integer + LD A,E ; Get LSB of number + PUSH AF ; Save LSB + LD A,C ; Get MSB of number + RLA ; Sign to carry + CALL CONPOS ; Set sign of result + POP AF ; Restore LSB of number + RET + +MLDEBC: LD HL,0 ; Clear partial product + LD A,B ; Test multiplier + OR C + RET Z ; Return zero if zero + LD A,16 ; 16 bits +MLDBLP: ADD HL,HL ; Shift P.P left + JP C,BSERR ; ?BS Error if overflow + EX DE,HL + ADD HL,HL ; Shift multiplier left + EX DE,HL + JP NC,NOMLAD ; Bit was zero - No add + ADD HL,BC ; Add multiplicand + JP C,BSERR ; ?BS Error if overflow +NOMLAD: DEC A ; Count bits + JP NZ,MLDBLP ; More + RET + +ASCTFP: CP '-' ; Negative? + PUSH AF ; Save it and flags + JP Z,CNVNUM ; Yes - Convert number + CP '+' ; Positive? + JP Z,CNVNUM ; Yes - Convert number + DEC HL ; DEC 'cos GETCHR INCs +CNVNUM: CALL RESZER ; Set result to zero + LD B,A ; Digits after point counter + LD D,A ; Sign of exponent + LD E,A ; Exponent of ten + CPL + LD C,A ; Before or after point flag +MANLP: CALL GETCHR ; Get next character + JP C,ADDIG ; Digit - Add to number + CP '.' + JP Z,DPOINT ; '.' - Flag point + CP 'E' + JP NZ,CONEXP ; Not 'E' - Scale number + CALL GETCHR ; Get next character + CALL SGNEXP ; Get sign of exponent +EXPLP: CALL GETCHR ; Get next character + JP C,EDIGIT ; Digit - Add to exponent + INC D ; Is sign negative? + JP NZ,CONEXP ; No - Scale number + XOR A + SUB E ; Negate exponent + LD E,A ; And re-save it + INC C ; Flag end of number +DPOINT: INC C ; Flag point passed + JP Z,MANLP ; Zero - Get another digit +CONEXP: PUSH HL ; Save code string address + LD A,E ; Get exponent + SUB B ; Subtract digits after point +SCALMI: CALL P,SCALPL ; Positive - Multiply number + JP P,ENDCON ; Positive - All done + PUSH AF ; Save number of times to /10 + CALL DIV10 ; Divide by 10 + POP AF ; Restore count + INC A ; Count divides + +ENDCON: JP NZ,SCALMI ; More to do + POP DE ; Restore code string address + POP AF ; Restore sign of number + CALL Z,INVSGN ; Negative - Negate number + EX DE,HL ; Code string address to HL + RET + +SCALPL: RET Z ; Exit if no scaling needed +MULTEN: PUSH AF ; Save count + CALL MLSP10 ; Multiply number by 10 + POP AF ; Restore count + DEC A ; Count multiplies + RET + +ADDIG: PUSH DE ; Save sign of exponent + LD D,A ; Save digit + LD A,B ; Get digits after point + ADC A,C ; Add one if after point + LD B,A ; Re-save counter + PUSH BC ; Save point flags + PUSH HL ; Save code string address + PUSH DE ; Save digit + CALL MLSP10 ; Multiply number by 10 + POP AF ; Restore digit + SUB '0' ; Make it absolute + CALL RSCALE ; Re-scale number + POP HL ; Restore code string address + POP BC ; Restore point flags + POP DE ; Restore sign of exponent + JP MANLP ; Get another digit + +RSCALE: CALL STAKFP ; Put number on stack + CALL FLGREL ; Digit to add to FPREG +PADD: POP BC ; Restore number + POP DE + JP FPADD ; Add BCDE to FPREG and return + +EDIGIT: LD A,E ; Get digit + RLCA ; Times 2 + RLCA ; Times 4 + ADD A,E ; Times 5 + RLCA ; Times 10 + ADD A,(HL) ; Add next digit + SUB '0' ; Make it absolute + LD E,A ; Save new digit + JP EXPLP ; Look for another digit + +LINEIN: PUSH HL ; Save code string address + LD HL,INMSG ; Output " in " + CALL PRS ; Output string at HL + POP HL ; Restore code string address +PRNTHL: EX DE,HL ; Code string address to DE + XOR A + LD B,80H+24 ; 24 bits + CALL RETINT ; Return the integer + LD HL,PRNUMS ; Print number string + PUSH HL ; Save for return +NUMASC: LD HL,PBUFF ; Convert number to ASCII + PUSH HL ; Save for return + CALL TSTSGN ; Test sign of FPREG + LD (HL),' ' ; Space at start + JP P,SPCFST ; Positive - Space to start + LD (HL),'-' ; '-' sign at start +SPCFST: INC HL ; First byte of number + LD (HL),'0' ; '0' if zero + JP Z,JSTZER ; Return '0' if zero + PUSH HL ; Save buffer address + CALL M,INVSGN ; Negate FPREG if negative + XOR A ; Zero A + PUSH AF ; Save it + CALL RNGTST ; Test number is in range +SIXDIG: LD BC,9143H ; BCDE - 99999.9 + LD DE,4FF8H + CALL CMPNUM ; Compare numbers + OR A + JP PO,INRNG ; > 99999.9 - Sort it out + POP AF ; Restore count + CALL MULTEN ; Multiply by ten + PUSH AF ; Re-save count + JP SIXDIG ; Test it again + +GTSIXD: CALL DIV10 ; Divide by 10 + POP AF ; Get count + INC A ; Count divides + PUSH AF ; Re-save count + CALL RNGTST ; Test number is in range +INRNG: CALL ROUND ; Add 0.5 to FPREG + INC A + CALL FPINT ; F.P to integer + CALL FPBCDE ; Move BCDE to FPREG + LD BC,0306H ; 1E+06 to 1E-03 range + POP AF ; Restore count + ADD A,C ; 6 digits before point + INC A ; Add one + JP M,MAKNUM ; Do it in 'E' form if < 1E-02 + CP 6+1+1 ; More than 999999 ? + JP NC,MAKNUM ; Yes - Do it in 'E' form + INC A ; Adjust for exponent + LD B,A ; Exponent of number + LD A,2 ; Make it zero after + +MAKNUM: DEC A ; Adjust for digits to do + DEC A + POP HL ; Restore buffer address + PUSH AF ; Save count + LD DE,POWERS ; Powers of ten + DEC B ; Count digits before point + JP NZ,DIGTXT ; Not zero - Do number + LD (HL),'.' ; Save point + INC HL ; Move on + LD (HL),'0' ; Save zero + INC HL ; Move on +DIGTXT: DEC B ; Count digits before point + LD (HL),'.' ; Save point in case + CALL Z,INCHL ; Last digit - move on + PUSH BC ; Save digits before point + PUSH HL ; Save buffer address + PUSH DE ; Save powers of ten + CALL BCDEFP ; Move FPREG to BCDE + POP HL ; Powers of ten table + LD B, '0'-1 ; ASCII '0' - 1 +TRYAGN: INC B ; Count subtractions + LD A,E ; Get LSB + SUB (HL) ; Subtract LSB + LD E,A ; Save LSB + INC HL + LD A,D ; Get NMSB + SBC A,(HL) ; Subtract NMSB + LD D,A ; Save NMSB + INC HL + LD A,C ; Get MSB + SBC A,(HL) ; Subtract MSB + LD C,A ; Save MSB + DEC HL ; Point back to start + DEC HL + JP NC,TRYAGN ; No overflow - Try again + CALL PLUCDE ; Restore number + INC HL ; Start of next number + CALL FPBCDE ; Move BCDE to FPREG + EX DE,HL ; Save point in table + POP HL ; Restore buffer address + LD (HL),B ; Save digit in buffer + INC HL ; And move on + POP BC ; Restore digit count + DEC C ; Count digits + JP NZ,DIGTXT ; More - Do them + DEC B ; Any decimal part? + JP Z,DOEBIT ; No - Do 'E' bit +SUPTLZ: DEC HL ; Move back through buffer + LD A,(HL) ; Get character + CP '0' ; '0' character? + JP Z,SUPTLZ ; Yes - Look back for more + CP '.' ; A decimal point? + CALL NZ,INCHL ; Move back over digit + +DOEBIT: POP AF ; Get 'E' flag + JP Z,NOENED ; No 'E' needed - End buffer + LD (HL),'E' ; Put 'E' in buffer + INC HL ; And move on + LD (HL),'+' ; Put '+' in buffer + JP P,OUTEXP ; Positive - Output exponent + LD (HL),'-' ; Put '-' in buffer + CPL ; Negate exponent + INC A +OUTEXP: LD B,'0'-1 ; ASCII '0' - 1 +EXPTEN: INC B ; Count subtractions + SUB 10 ; Tens digit + JP NC,EXPTEN ; More to do + ADD A,'0'+10 ; Restore and make ASCII + INC HL ; Move on + LD (HL),B ; Save MSB of exponent +JSTZER: INC HL ; + LD (HL),A ; Save LSB of exponent + INC HL +NOENED: LD (HL),C ; Mark end of buffer + POP HL ; Restore code string address + RET + +RNGTST: LD BC,9474H ; BCDE = 999999. + LD DE,23F7H + CALL CMPNUM ; Compare numbers + OR A + POP HL ; Return address to HL + JP PO,GTSIXD ; Too big - Divide by ten + JP (HL) ; Otherwise return to caller + +HALF: DB 00H,00H,00H,80H ; 0.5 + +POWERS: DB 0A0H,086H,001H ; 100000 + DB 010H,027H,000H ; 10000 + DB 0E8H,003H,000H ; 1000 + DB 064H,000H,000H ; 100 + DB 00AH,000H,000H ; 10 + DB 001H,000H,000H ; 1 + +NEGAFT: LD HL,INVSGN ; Negate result + EX (SP),HL ; To be done after caller + JP (HL) ; Return to caller + +SQR: CALL STAKFP ; Put value on stack + LD HL,HALF ; Set power to 1/2 + CALL PHLTFP ; Move 1/2 to FPREG + +POWER: POP BC ; Get base + POP DE + CALL TSTSGN ; Test sign of power + LD A,B ; Get exponent of base + JP Z,EXP ; Make result 1 if zero + JP P,POWER1 ; Positive base - Ok + OR A ; Zero to negative power? + JP Z,DZERR ; Yes - ?/0 Error +POWER1: OR A ; Base zero? + JP Z,SAVEXP ; Yes - Return zero + PUSH DE ; Save base + PUSH BC + LD A,C ; Get MSB of base + OR 01111111B ; Get sign status + CALL BCDEFP ; Move power to BCDE + JP P,POWER2 ; Positive base - Ok + PUSH DE ; Save power + PUSH BC + CALL INT ; Get integer of power + POP BC ; Restore power + POP DE + PUSH AF ; MSB of base + CALL CMPNUM ; Power an integer? + POP HL ; Restore MSB of base + LD A,H ; but don't affect flags + RRA ; Exponent odd or even? +POWER2: POP HL ; Restore MSB and exponent + LD (FPREG+2),HL ; Save base in FPREG + POP HL ; LSBs of base + LD (FPREG),HL ; Save in FPREG + CALL C,NEGAFT ; Odd power - Negate result + CALL Z,INVSGN ; Negative base - Negate it + PUSH DE ; Save power + PUSH BC + CALL LOG ; Get LOG of base + POP BC ; Restore power + POP DE + CALL FPMULT ; Multiply LOG by power + +EXP: CALL STAKFP ; Put value on stack + LD BC,08138H ; BCDE = 1/Ln(2) + LD DE,0AA3BH + CALL FPMULT ; Multiply value by 1/LN(2) + LD A,(FPEXP) ; Get exponent + CP 80H+8 ; Is it in range? + JP NC,OVTST1 ; No - Test for overflow + CALL INT ; Get INT of FPREG + ADD A,80H ; For excess 128 + ADD A,2 ; Exponent > 126? + JP C,OVTST1 ; Yes - Test for overflow + PUSH AF ; Save scaling factor + LD HL,UNITY ; Point to 1. + CALL ADDPHL ; Add 1 to FPREG + CALL MULLN2 ; Multiply by LN(2) + POP AF ; Restore scaling factor + POP BC ; Restore exponent + POP DE + PUSH AF ; Save scaling factor + CALL SUBCDE ; Subtract exponent from FPREG + CALL INVSGN ; Negate result + LD HL,EXPTAB ; Coefficient table + CALL SMSER1 ; Sum the series + LD DE,0 ; Zero LSBs + POP BC ; Scaling factor + LD C,D ; Zero MSB + JP FPMULT ; Scale result to correct value + +EXPTAB: DB 8 ; Table used by EXP + DB 040H,02EH,094H,074H ; -1/7! (-1/5040) + DB 070H,04FH,02EH,077H ; 1/6! ( 1/720) + DB 06EH,002H,088H,07AH ; -1/5! (-1/120) + DB 0E6H,0A0H,02AH,07CH ; 1/4! ( 1/24) + DB 050H,0AAH,0AAH,07EH ; -1/3! (-1/6) + DB 0FFH,0FFH,07FH,07FH ; 1/2! ( 1/2) + DB 000H,000H,080H,081H ; -1/1! (-1/1) + DB 000H,000H,000H,081H ; 1/0! ( 1/1) + +SUMSER: CALL STAKFP ; Put FPREG on stack + LD DE,MULT ; Multiply by "X" + PUSH DE ; To be done after + PUSH HL ; Save address of table + CALL BCDEFP ; Move FPREG to BCDE + CALL FPMULT ; Square the value + POP HL ; Restore address of table +SMSER1: CALL STAKFP ; Put value on stack + LD A,(HL) ; Get number of coefficients + INC HL ; Point to start of table + CALL PHLTFP ; Move coefficient to FPREG + DB 06H ; Skip "POP AF" +SUMLP: POP AF ; Restore count + POP BC ; Restore number + POP DE + DEC A ; Cont coefficients + RET Z ; All done + PUSH DE ; Save number + PUSH BC + PUSH AF ; Save count + PUSH HL ; Save address in table + CALL FPMULT ; Multiply FPREG by BCDE + POP HL ; Restore address in table + CALL LOADFP ; Number at HL to BCDE + PUSH HL ; Save address in table + CALL FPADD ; Add coefficient to FPREG + POP HL ; Restore address in table + JP SUMLP ; More coefficients + +RND: CALL TSTSGN ; Test sign of FPREG + LD HL,SEED+2 ; Random number seed + JP M,RESEED ; Negative - Re-seed + LD HL,LSTRND ; Last random number + CALL PHLTFP ; Move last RND to FPREG + LD HL,SEED+2 ; Random number seed + RET Z ; Return if RND(0) + ADD A,(HL) ; Add (SEED)+2) + AND 00000111B ; 0 to 7 + LD B,0 + LD (HL),A ; Re-save seed + INC HL ; Move to coefficient table + ADD A,A ; 4 bytes + ADD A,A ; per entry + LD C,A ; BC = Offset into table + ADD HL,BC ; Point to coefficient + CALL LOADFP ; Coefficient to BCDE + CALL FPMULT ; ; Multiply FPREG by coefficient + LD A,(SEED+1) ; Get (SEED+1) + INC A ; Add 1 + AND 00000011B ; 0 to 3 + LD B,0 + CP 1 ; Is it zero? + ADC A,B ; Yes - Make it 1 + LD (SEED+1),A ; Re-save seed + LD HL,RNDTAB-4 ; Addition table + ADD A,A ; 4 bytes + ADD A,A ; per entry + LD C,A ; BC = Offset into table + ADD HL,BC ; Point to value + CALL ADDPHL ; Add value to FPREG +RND1: CALL BCDEFP ; Move FPREG to BCDE + LD A,E ; Get LSB + LD E,C ; LSB = MSB + XOR 01001111B ; Fiddle around + LD C,A ; New MSB + LD (HL),80H ; Set exponent + DEC HL ; Point to MSB + LD B,(HL) ; Get MSB + LD (HL),80H ; Make value -0.5 + LD HL,SEED ; Random number seed + INC (HL) ; Count seed + LD A,(HL) ; Get seed + SUB 171 ; Do it modulo 171 + JP NZ,RND2 ; Non-zero - Ok + LD (HL),A ; Zero seed + INC C ; Fillde about + DEC D ; with the + INC E ; number +RND2: CALL BNORM ; Normalise number + LD HL,LSTRND ; Save random number + JP FPTHL ; Move FPREG to last and return + +RESEED: LD (HL),A ; Re-seed random numbers + DEC HL + LD (HL),A + DEC HL + LD (HL),A + JP RND1 ; Return RND seed + +RNDTAB: DB 068H,0B1H,046H,068H ; Table used by RND + DB 099H,0E9H,092H,069H + DB 010H,0D1H,075H,068H + +COS: LD HL,HALFPI ; Point to PI/2 + CALL ADDPHL ; Add it to PPREG +SIN: CALL STAKFP ; Put angle on stack + LD BC,8349H ; BCDE = 2 PI + LD DE,0FDBH + CALL FPBCDE ; Move 2 PI to FPREG + POP BC ; Restore angle + POP DE + CALL DVBCDE ; Divide angle by 2 PI + CALL STAKFP ; Put it on stack + CALL INT ; Get INT of result + POP BC ; Restore number + POP DE + CALL SUBCDE ; Make it 0 <= value < 1 + LD HL,QUARTR ; Point to 0.25 + CALL SUBPHL ; Subtract value from 0.25 + CALL TSTSGN ; Test sign of value + SCF ; Flag positive + JP P,SIN1 ; Positive - Ok + CALL ROUND ; Add 0.5 to value + CALL TSTSGN ; Test sign of value + OR A ; Flag negative +SIN1: PUSH AF ; Save sign + CALL P,INVSGN ; Negate value if positive + LD HL,QUARTR ; Point to 0.25 + CALL ADDPHL ; Add 0.25 to value + POP AF ; Restore sign + CALL NC,INVSGN ; Negative - Make positive + LD HL,SINTAB ; Coefficient table + JP SUMSER ; Evaluate sum of series + +HALFPI: DB 0DBH,00FH,049H,081H ; 1.5708 (PI/2) + +QUARTR: DB 000H,000H,000H,07FH ; 0.25 + +SINTAB: DB 5 ; Table used by SIN + DB 0BAH,0D7H,01EH,086H ; 39.711 + DB 064H,026H,099H,087H ;-76.575 + DB 058H,034H,023H,087H ; 81.602 + DB 0E0H,05DH,0A5H,086H ;-41.342 + DB 0DAH,00FH,049H,083H ; 6.2832 + +TAN: CALL STAKFP ; Put angle on stack + CALL SIN ; Get SIN of angle + POP BC ; Restore angle + POP HL + CALL STAKFP ; Save SIN of angle + EX DE,HL ; BCDE = Angle + CALL FPBCDE ; Angle to FPREG + CALL COS ; Get COS of angle + JP DIV ; TAN = SIN / COS + +ATN: CALL TSTSGN ; Test sign of value + CALL M,NEGAFT ; Negate result after if -ve + CALL M,INVSGN ; Negate value if -ve + LD A,(FPEXP) ; Get exponent + CP 81H ; Number less than 1? + JP C,ATN1 ; Yes - Get arc tangnt + LD BC,8100H ; BCDE = 1 + LD D,C + LD E,C + CALL DVBCDE ; Get reciprocal of number + LD HL,SUBPHL ; Sub angle from PI/2 + PUSH HL ; Save for angle > 1 +ATN1: LD HL,ATNTAB ; Coefficient table + CALL SUMSER ; Evaluate sum of series + LD HL,HALFPI ; PI/2 - angle in case > 1 + RET ; Number > 1 - Sub from PI/2 + +ATNTAB: DB 9 ; Table used by ATN + DB 04AH,0D7H,03BH,078H ; 1/17 + DB 002H,06EH,084H,07BH ;-1/15 + DB 0FEH,0C1H,02FH,07CH ; 1/13 + DB 074H,031H,09AH,07DH ;-1/11 + DB 084H,03DH,05AH,07DH ; 1/9 + DB 0C8H,07FH,091H,07EH ;-1/7 + DB 0E4H,0BBH,04CH,07EH ; 1/5 + DB 06CH,0AAH,0AAH,07FH ;-1/3 + DB 000H,000H,000H,081H ; 1/1 + + +ARET: RET ; A RETurn instruction + +CLS: LD A,016H ; ASCII Clear screen + JP PRNT ; Output character + +WIDTH: CALL GETINT ; Get integer 0-255 + LD A,E ; Width to A + LD (LWIDTH),A ; Set width + RET + +LINES: CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + LD (LINESC),DE ; Set lines counter + LD (LINESN),DE ; Set lines number + RET + +DEEK: CALL DEINT ; Get integer -32768 to 32767 + PUSH DE ; Save number + POP HL ; Number to HL + LD B,(HL) ; Get LSB of contents + INC HL + LD A,(HL) ; Get MSB of contents + JP ABPASS ; Return integer AB + +DOKE: CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + PUSH DE ; Save address + CALL CHKSYN ; Make sure ',' follows + DB ',' + CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + EX (SP),HL ; Save value,get address + LD (HL),E ; Save LSB of value + INC HL + LD (HL),D ; Save MSB of value + POP HL ; Restore code string address + RET + + +; HEX$(nn) Convert 16 bit number to Hexadecimal string + +HEX: CALL TSTNUM ; Verify it's a number + CALL DEINT ; Get integer -32768 to 32767 + PUSH BC ; Save contents of BC + LD HL,PBUFF + LD A,D ; Get high order into A + CP 000H + JR Z,HEX2 ; Skip output if both high digits are zero + CALL BYT2ASC ; Convert D to ASCII + LD A,B + CP '0' + JR Z,HEX1 ; Don't store high digit if zero + LD (HL),B ; Store it to PBUFF + INC HL ; Next location +HEX1: LD (HL),C ; Store C to PBUFF+1 + INC HL ; Next location +HEX2: LD A,E ; Get lower byte + CALL BYT2ASC ; Convert E to ASCII + LD A,D + CP 000H + JR NZ,HEX3 ; If upper byte was not zero then always print lower byte + LD A,B + CP '0' ; If high digit of lower byte is zero then don't print + JR Z,HEX4 +HEX3: LD (HL),B ; to PBUFF+2 + INC HL ; Next location +HEX4: LD (HL),C ; to PBUFF+3 + INC HL ; PBUFF+4 to zero + XOR A ; Terminating character + LD (HL),A ; Store zero to terminate + INC HL ; Make sure PBUFF is terminated + LD (HL),A ; Store the double zero there + POP BC ; Get BC back + LD HL,PBUFF ; Reset to start of PBUFF + JP STR1 ; Convert the PBUFF to a string and return it + +BYT2ASC LD B,A ; Save original value + AND 00FH ; Strip off upper nybble + CP 00AH ; 0-9? + JR C,ADD30 ; If A-F, add 7 more + ADD A,007H ; Bring value up to ASCII A-F +ADD30 ADD A,030H ; And make ASCII + LD C,A ; Save converted char to C + LD A,B ; Retrieve original value + RRCA ; and Rotate it right + RRCA + RRCA + RRCA + AND 00FH ; Mask off upper nybble + CP 00AH ; 0-9? < A hex? + JR C,ADD301 ; Skip Add 7 + ADD A,007H ; Bring it up to ASCII A-F +ADD301 ADD A,030H ; And make it full ASCII + LD B,A ; Store high order byte + RET + +; Convert "&Hnnnn" to FPREG +; Gets a character from (HL) checks for Hexadecimal ASCII numbers "&Hnnnn" +; Char is in A, NC if char is ;<=>?@ A-z, CY is set if 0-9 +HEXTFP EX DE,HL ; Move code string pointer to DE + LD HL,00000H ; Zero out the value + CALL GETHEX ; Check the number for valid hex + JP C,HXERR ; First value wasn't hex, HX error + JR HEXLP1 ; Convert first character +HEXLP CALL GETHEX ; Get second and addtional characters + JR C,HEXIT ; Exit if not a hex character +HEXLP1 ADD HL,HL ; Rotate 4 bits to the left + ADD HL,HL + ADD HL,HL + ADD HL,HL + OR L ; Add in D0-D3 into L + LD L,A ; Save new value + JR HEXLP ; And continue until all hex characters are in + +GETHEX INC DE ; Next location + LD A,(DE) ; Load character at pointer + CP ' ' + JP Z,GETHEX ; Skip spaces + SUB 030H ; Get absolute value + RET C ; < "0", error + CP 00AH + JR C,NOSUB7 ; Is already in the range 0-9 + SUB 007H ; Reduce to A-F + CP 00AH ; Value should be $0A-$0F at this point + RET C ; CY set if was : ; < = > ? @ +NOSUB7 CP 010H ; > Greater than "F"? + CCF + RET ; CY set if it wasn't valid hex + +HEXIT EX DE,HL ; Value into DE, Code string into HL + LD A,D ; Load DE into AC + LD C,E ; For prep to + PUSH HL + CALL ACPASS ; ACPASS to set AC as integer into FPREG + POP HL + RET + +HXERR: LD E,HX ; ?HEX Error + JP BERROR + +; BIN$(NN) Convert integer to a 1-16 char binary string +BIN: CALL TSTNUM ; Verify it's a number + CALL DEINT ; Get integer -32768 to 32767 +BIN2: PUSH BC ; Save contents of BC + LD HL,PBUFF + LD B,17 ; One higher than max char count +ZEROSUP: ; Suppress leading zeros + DEC B ; Max 16 chars + LD A,B + CP 001H + JR Z,BITOUT ; Always output at least one character + RL E + RL D + JR NC,ZEROSUP + JR BITOUT2 +BITOUT: + RL E + RL D ; Top bit now in carry +BITOUT2: + LD A,'0' ; Char for '0' + ADC A,0 ; If carry set then '0' --> '1' + LD (HL),A + INC HL + DEC B + JR NZ,BITOUT + XOR A ; Terminating character + LD (HL),A ; Store zero to terminate + INC HL ; Make sure PBUFF is terminated + LD (HL),A ; Store the double zero there + POP BC + LD HL,PBUFF + JP STR1 + +; Convert "&Bnnnn" to FPREG +; Gets a character from (HL) checks for Binary ASCII numbers "&Bnnnn" +BINTFP: EX DE,HL ; Move code string pointer to DE + LD HL,00000H ; Zero out the value + CALL CHKBIN ; Check the number for valid bin + JP C,BINERR ; First value wasn't bin, HX error +BINIT: SUB '0' + ADD HL,HL ; Rotate HL left + OR L + LD L,A + CALL CHKBIN ; Get second and addtional characters + JR NC,BINIT ; Process if a bin character + EX DE,HL ; Value into DE, Code string into HL + LD A,D ; Load DE into AC + LD C,E ; For prep to + PUSH HL + CALL ACPASS ; ACPASS to set AC as integer into FPREG + POP HL + RET + +; Char is in A, NC if char is 0 or 1 +CHKBIN: INC DE + LD A,(DE) + CP ' ' + JP Z,CHKBIN ; Skip spaces + CP '0' ; Set C if < '0' + RET C + CP '2' + CCF ; Set C if > '1' + RET + +BINERR: LD E,BN ; ?BIN Error + JP BERROR + +JJUMP1: LD IX,-1 ; Flag cold start + JP CSTART ; Go and initialise + + ; Restored SCREEN command updated for the MZ80A. + ; The MZ80A uses 0,0 -> COLW-1,ROW-1 addressing as opposed to the NASCOM 1,1 -> 48,16 + ; +SCREEN: CALL GETINT ; Get integer 0 to 255 + PUSH AF ; Save column + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETINT ; Get integer 0 to 255 + POP BC ; Column to B + PUSH HL ; Save code string address + PUSH BC ; Save column + CALL SCRADR ; Set screen coordinates. + POP HL ; Rstore code string address + RET + +SCRADR: LD B,A ; Line and column to BC once checked. + OR A ; Test it + JP Z,FCERR ; Zero - ?FC Error + CP ROW+1 ; Number of lines + JP P,FCERR ; > Number of lines then ?FC Error + DEC B ; Sharp uses 0,0 addressing so once value verified, decrement. + POP DE ; RETurn address + POP AF ; Get column + PUSH DE ; Re-save RETurn + LD C,A ; Column to DE + OR A ; Test it + JP Z,FCERR ; Zero - ?FC Error + CP COLW+1 ; Number of characters per line + JP P,FCERR ; > number of characters then ?FC Error + DEC C ; Sharp uses 0,0 addressing. + LD (DSPXY),BC ; Save coordinates. + RET + +ARETN: RETN ; Return from NMI + +TSTBIT: PUSH AF ; Save bit mask + AND B ; Get common bits + POP BC ; Restore bit mask + CP B ; Same bit set? + LD A,0 ; Return 0 in A + RET + +OUTNCR: CALL OUTC ; Output character in A + JP PRNTCRLF ; Output CRLF + + + ; Method to load BASIC text program. +LOAD: LD A,TAPELOAD ; Set the type of operation into the flag var. + JR CLOAD0 + + ; Method to load a cassette image (tokenised basic script). + ; +CLOAD: LD A,CTAPELOAD ; Set the type of operatiom into the flag var. +CLOAD0: LD (TPFLAG),A + LD A,(HL) ; Get byte after "CLOAD" + ;CP ZTIMES ; "*" token? ("CLOAD*") + ;JP Z,ARRLD1 ; Yes - Array load + SUB ZPRINT ; "?" ("PRINT" token) Verify? + JP Z,FLGVER ; Yes - Flag "verify" + XOR A ; Flag "load" + DB 01H ; Skip "CPL" and "INC HL" +FLGVER: CPL ; Flag "verify" + INC HL ; Skip over "?" + PUSH AF ; Save verify flag + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + LD A,0 ; Any file will do + JP Z,SDNONAM ; No name given - error. + CALL EVAL ; Evaluate expression + CALL GTFLNM ; Get file name + POP AF + OR A + JP NZ,SDVERF + ; + LD HL,TZSVC_FILENAME ; Set the filename to be created. + LD A,(TMSTPL) + CP TZSVCFILESZ ; Check size of filename, cant be more than an MZF name of 17 chars. + JP NC,SDFNTG + LD B,A +CLOAD1: LD A,(DE) ; Copy filename into service record. + LD (HL),A + INC DE + INC HL + DJNZ CLOAD1 + XOR A + LD (HL),A ; Terminate filename. + ; + CALL CLRPTR ; Initialise memory to NEW state ready for program load. + LD A,(TPFLAG) ; What are we processing, cassette image or text? + CP CTAPELOAD + JR Z,CLOAD2 ; Is this a cassette image load? + CALL LDTXT ; BASIC text load. + JR SDLOADE +CLOAD2: SCF + CALL PRCFIL ; Process file as a load request. +CLOAD3: PUSH HL + LD HL,(BASTXT) ; Get start of program memory. + LD BC,(TZSVC_LOADSIZE) ; Get the actual load size. + ADD HL,BC ; Find the end. + XOR A + LD (HL),A ; Last two bytes are xeroed as they are for the next line number. + INC HL + LD (HL),A + INC HL + LD (PROGND),HL ; Set it as the end of program memory. + POP HL + JR SDLOADE ; Exit and tidy up. + +SDVERF: +SDLOADE:LD HL,OKMSG ; "Ok" message + CALL PRS ; Output string + JP SETPTR ; Set up line pointers + + ; Methods to open, read and close an SD file for retrieval of basic program data. Cassette files are read/written + ; directly to memory by the K64F but text files, as they are being expanded/compressed, need to be read/written + ; sector by sector. +LDOPEN: XOR A + LD (TZSVC_FILE_SEC),A ; Starting sector number of file to load. + LD A,TZSVC_FTYPE_BAS ; Type of file is CASsette, the K64F will know how to handle it. + LD (TZSVC_FILE_TYPE),A + LD A,TZSVC_CMD_READFILE + CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JP NZ, SDOPER ; Open error, K64F didint respond, cannot read! + LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + JP NZ, SDOPER ; Same thing, if K64F processes request and returns an error, open or read problem! + LD HL,TZSVCSECTOR ; Start at beginning of sector. + LD (SECTPOS),HL + RET + +LDCLOSE:LD A,TZSVC_CMD_CLOSE ; Close file. + CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JP NZ, SDCLER ; Close error, K64F didint respond, cannot close the file. + LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + JP NZ, SDCLER ; Same thing, if K64F closes file and returns an error, closing problem (SD removed!)! + RET + +LDBUF: LD A,(TZSVC_FILE_SEC) ; Update the virtual file sector number so the K64F knows what to read. + INC A + LD (TZSVC_FILE_SEC),A + LD A, TZSVC_CMD_NEXTREADFILE + CALL SVC_CMD ; And make communications with the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JP NZ, SDRDER ; Write error, K64F didint respond, cannot write so flag as error! + LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + JP NZ, SDRDER ; Same thing, if K64F read from file returns an error, read error (SD removed or disk error!)! + RET + + ; Method to load a NASIC program which is stored as TEXT into memory. This is accomplied sector by sector, line by line, + ; each line needs to be read, tokenised and stored. + ; +LDTXT: CALL LDOPEN ; Open file, read the first sector of data. + LD HL,(PROGND) ; After reset the pointer points to the first line number not the first address + DEC HL ; Update it to keep the later logic more simple. + DEC HL + LD (PROGND),HL + ; +LDTXT0: LD HL,(TZSVC_LOADSIZE) ; Get size of sector loaded. + LD BC,TZSVCSECTOR ; Address of sector + ADD HL,BC ; End of sector address + PUSH HL + POP BC ; BC contains sector end address. + LD HL,(SECTPOS) ; Get position in sector for next line. + LD DE,STACKE ; Copy line into temporary area in case we span sectors. +LDTXT1: PUSH HL + OR A + SBC HL,BC ; So long as the end sector address is greater than the pointer we will have carry. + POP HL + JR C,LDTXT2 ; Check that we havent got to the end of the current sector. + CALL LDBUF ; End of current sector so load new. + LD HL,(TZSVC_LOADSIZE) + LD A,H + OR L + JR Z,LDTXTE ; No bytes in sector means end of file,exit. + LD HL,TZSVCSECTOR ; Start at beginning of sector. +LDTXT2: LD A,(HL) ; Copy the string from the sector to the temporary area. + LD (DE),A + INC HL + CP CR + JR Z,LDTXT3 ; CR means EOS. + CP LF + JR Z,LDTXT3 ; LF means EOS. + INC DE + JR LDTXT1 +LDTXT3: LD A,(HL) ; If CR make sure any LF is wasted. + CP LF + JR NZ,LDTXT4 + INC HL +LDTXT4: LD (SECTPOS),HL + LD HL,STACKE ; Start of line to insert. + XOR A + LD (DE),A ; Terminate string, BASIC uses NULL terminated strings. + CALL ATOH ; Get line number into DE + PUSH DE ; Save line number + CALL CRUNCH ; Convert text to tokens. A returns with size of line in BUFFER. + LD L,C ; Length of string to L. + LD H,0 + LD BC,(PROGND) + PUSH BC + ADD HL,BC ; Find new end + LD (PROGND),HL ; Update end of program pointer + POP DE ; Get back old pointer. + EX DE,HL + LD (HL),E ; Set pointer to end of line. + INC HL + LD (HL),D + INC HL ; Move onto line number. + POP DE ; Get back line number, + LD (HL),E + INC HL + LD (HL),D ; Store line number. + INC HL ; HL now points to first location for tokenised line. + LD DE,BUFFER ; Copy buffer to program +LDMVBUF:LD A,(DE) ; Get source + LD (HL),A ; Save destinations + INC HL ; Next source + INC DE ; Next destination + OR A ; Done? + JP NZ,LDMVBUF ; No - Repeat + ; + JP LDTXT0 ; Get next line. +LDTXTE: CALL LDCLOSE ; Close file for exit. + RET + + ; Method to save BASIC text to file. + ; +SAVE: LD A,TAPESAVE ; Set the type of operation into the flag var. + JR CSAVE0 + + ; Method to save a cassette image (tokenised basic script). + ; +CSAVE: LD A,CTAPESAVE ; Set the type of operatiom into the flag var. +CSAVE0: LD (TPFLAG),A + ; + LD B,1 ; Flag "CSAVE" + ;CP ZTIMES ; "*" token? ("CSAVE*") + ;JP Z,ARRSV1 ; Yes - Array save + CALL EVAL ; Evaluate expression + PUSH HL + CALL GTFLNM ; Get file name + ; + LD HL,TZSVC_FILENAME ; Set the filename to be created. + LD A,(TMSTPL) + CP TZSVCFILESZ ; Check size of filename, cant be more than an MZF name of 17 chars. + JP NC,SDFNTG + LD B,A +CSAVE1: LD A,(DE) ; Copy filename into service record. + LD (HL),A + INC DE + INC HL + DJNZ CSAVE1 + XOR A + LD (HL),A ; Terminate filename. + ; + LD A,(TPFLAG) ; What are we processing, cassette image or text? + CP CTAPESAVE + JR Z,CSAVE2 ; Is this a cassette image save? + ; + PUSH DE + CALL SVOPEN ; Open the required file for writing. + CALL SVTXT ; Expand and save text into the file + CALL SVCLOSE ; Finish by closing file so no corruption occurs. + POP DE + JR CSAVEE +CSAVE2: SCF + CCF + CALL PRCFIL ; Process file as a save request. +CSAVEE: POP HL + RET + + + ; Methods to open, write and close an SD file for storage of basic program data. Cassette files are read/written + ; directly to memory by the K64F but text files, as they are being expanded/compressed, need to be read/written + ; sector by sector. + ; +SVOPEN: PUSH HL + XOR A + LD (TZSVC_FILE_SEC),A ; Starting sector number. + LD A,TZSVC_FTYPE_BAS ; Type of file is BASic, the K64F will know how to handle it. + LD (TZSVC_FILE_TYPE),A + LD HL,0 + LD (TZSVC_SAVESIZE),HL ; Initialise the sector size count. + POP HL + LD A,TZSVC_CMD_WRITEFILE + CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JP NZ, SDCRER ; Create error, K64F didint respond, cannot write! + LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + JP NZ, SDCRER ; Same thing, if K64F processes request and returns an error, creation problem! + RET + +SVCLOSE:CALL SVBUF ; Flush out any unwritten data. + LD A,TZSVC_CMD_CLOSE ; Close file. + CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JP NZ, SDCLER ; Close error, K64F didint respond, cannot write so flag as error! + LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + JP NZ, SDCLER ; Same thing, if K64F closes file and returns an error, closing problem (SD removed!)! + RET + +SVBUF: LD A, TZSVC_CMD_NEXTWRITEFILE + CALL SVC_CMD ; And make communications with the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JP NZ, SDWRER ; Write error, K64F didint respond, cannot write so flag as error! + LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + JP NZ, SDWRER ; Same thing, if K64F write to file and returns an error, write error (SD removed or disk full!)! + LD A,(TZSVC_FILE_SEC) ; Update the virtual file sector number + INC A + LD (TZSVC_FILE_SEC),A + LD DE,0 + LD (TZSVC_SAVESIZE),DE ; Initialise to empty sector. + RET + + ; Methods to write into the SD sector a BASIC script as it is expanded into text. + ; +WRLINE: PUSH BC ; Convert line number in DE into text. + XOR A + LD B,80H+24 ; 24 bits + CALL RETINT ; Return the integer + CALL NUMASC ; Output line number in decimal + POP BC + LD HL,PBUFF ; Text version of line number now in PBUFF +WRLINE1:LD A,(HL) ; Loop and write to service command sector, 0 terminates string. + OR A + RET Z + CALL WRBUF + INC HL + JR WRLINE1 + +WRCRLF: LD A,CR ; Carriage return first. + CALL WRBUF + LD A,LF ; Now line feed. +WRBUF: PUSH HL ; Save as were using it. + PUSH DE + LD DE,(TZSVC_SAVESIZE) ; Get current pointer into sector for next char. + LD HL,TZSVCSECTOR ; Add in the absolute address of the service sector. + ADD HL,DE + LD (HL),A ; Save at correct location. + ;CALL PRNT ; Print out what is being saved, debug! + INC DE + LD (TZSVC_SAVESIZE),DE ; Update the sector location for next byte. + LD A,D + CP 2 ; Test to see if buffer full. Hard coded 512 byte msb as Glass isnt resolving shift right correctly. + JR NZ,WRBUF1 + CALL SVBUF ; Save the buffer. + ; Write out buffer. +WRBUF1: POP DE + POP HL ; Restore and get out. + RET + + + ; Method to save the current program in memory to SD card as text. + ; This is the most common way of working with basic scripts, the cassette + ; image type offers speed but in this day and age it is not so much needed. + ; +SVTXT: LD DE,0 + CALL SRCHLN ; Search for line number in DE + PUSH BC ; Save address of line + CALL SETLIN ; Set up lines counter + JR SVTXT1 ; Skip CR on first line. +SVTXT0: CALL WRCRLF ; Write CRLF to buffer. +SVTXT1: POP HL ; Restore address of line + LD C,(HL) ; Get LSB of next line + INC HL + LD B,(HL) ; Get MSB of next line + INC HL + LD A,B ; BC = 0 (End of program)? + OR C + RET Z ; Yes - finish save. + CALL SVCNT ; Count lines + PUSH BC ; Save address of next line + LD E,(HL) ; Get LSB of line number + INC HL + LD D,(HL) ; Get MSB of line number + INC HL + PUSH HL ; Save address of line start + CALL WRLINE ; Write out the line number. + LD A,' ' ; Space after line number + POP HL ; Restore start of line address +SVTXT2: CALL WRBUF ; Output character in A +SVTXT3: LD A,(HL) ; Get next byte in line + OR A ; End of line? + INC HL ; To next byte in line + JP Z,SVTXT0 ; Yes - get next line + JP P,SVTXT2 ; No token - output it + SUB ZEND-1 ; Find and output word + LD C,A ; Token offset+1 to C + LD DE,WORDS ; Reserved word list +SVTXT4: LD A,(DE) ; Get character in list + INC DE ; Move on to next + OR A ; Is it start of word? + JP P,SVTXT4 ; No - Keep looking for word + DEC C ; Count words + JP NZ,SVTXT4 ; Not there - keep looking +SVTXT5: AND 01111111B ; Strip bit 7 + CALL WRBUF ; Output first character + LD A,(DE) ; Get next character + INC DE ; Move on to next + OR A ; Is it end of word? + JP P,SVTXT5 ; No - output the rest + JP SVTXT3 ; Next byte in line + +SVCNT: PUSH HL ; Save code string address + PUSH DE + LD HL,(LINESC) ; Get LINES counter + LD DE,-1 + ADC HL,DE ; Decrement + LD (LINESC),HL ; Put it back + POP DE + POP HL ; Restore code string address + RET P ; Return if more lines to go + PUSH HL ; Save code string address + LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Reset LINES counter + POP HL ; Restore code string address + JP SVCNT ; Keep on counting + + ; Method to process a cassette based file load/save. + ; The file is stored in a tokenised format and maintains a degree + ; of compatibility with NASCOM files. To use NASCOM files please + ; see the 'nasconv' tool which updates the tokens as this version + ; of BASIC adds additional commands which meant adjusting token values. + ; +PRCFIL: JR NC,PRCFIL1 + LD HL,(BASTXT) ; Get start of program memory. + LD (TZSVC_LOADADDR), HL + LD DE,(LSTRAM) + EX DE,HL + SBC HL,DE + LD (TZSVC_LOADSIZE),HL ; Place max size we can load into the service loadsize field. + LD A,TZSVC_CMD_LOADFILE + JR PRCFIL2 +PRCFIL1:LD DE,(BASTXT) ; Get start of program memory. + LD (TZSVC_SAVEADDR), DE + LD HL,(PROGND) ; End of program information + SBC HL,DE ; Get size of program. + LD (TZSVC_SAVESIZE),HL ; Store into service record. + LD A,TZSVC_CMD_SAVEFILE +PRCFIL2:PUSH AF ; Save service command to execute. + ; + ; Setup the service record for the file load/save. + ; + LD A,0FFh ; Tag the filenumber as invalid. + LD (TZSVC_FILE_NO), A + LD A,(TMSTPL) + CP TZSVCFILESZ ; Check size of filename, cant be more than an MZF name of 17 chars. + JR NC,SDFNTG + LD A,TZSVC_FTYPE_CAS ; Type of file is CASsette, the K64F will know how to handle it. + LD (TZSVC_FILE_TYPE),A + POP AF + CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. + OR A ; Zero means no physical error occurred. + JR Z, PRCFIL3 + JR SDPHYER +PRCFIL3: LD A,(TZSVCRESULT) ; Check the result from the K64F, non zero is an error. + OR A + RET Z + LD A,(TZSVCCMD) + CP TZSVC_CMD_LOADFILE + JR Z,SDLDER + JR SDSVER + +SDNONAM:LD HL,BADFN ; Must give a name for SD card load and save. +SDERR: CALL PRS + POP AF ; Waste return address. + JP ERRIN +SDFNTG: LD HL,FNTOOG + JR SDERR +SDPHYER:LD HL,PHYERR + JR SDERR +SDLDER: LD HL,LOADERR + JR SDERR +SDSVER: LD HL,SAVEERR + JR SDERR +SDCRER: LD HL,CREATER + JR SDERR +SDCLER: LD HL,CLOSEER + JR SDERR +SDWRER: LD HL,WRITEER + JR SDERR +SDOPER: LD HL,OPENER + JR SDERR +SDRDER: LD HL,READER + JR SDERR + + +MONITR: +MONITR2 IF BUILD_TZFS = 1 + ; Swtch memory back to TZFS mode. + LD A, TZMM_TZFS + OUT (MMCFG),A + ENDIF + JP REBOOT ; Restart (Normally Monitor Start) + + ;------------------------------------------------------------------------------- + ; TIMER INTERRUPT + ; + ; This is the RTC interrupt, which interrupts every 100msec. RTC is maintained + ; by keeping an in memory count of seconds past 00:00:00 and an AMPM flag. + ;------------------------------------------------------------------------------- +TIMIN: LD (SPISRSAVE),SP ; Use a seperate stack for the interrupt as the hardware is paged in and RAM paged out. + LD SP,ISRSTACK + ; + PUSH AF ; Save used registers. + PUSH BC + PUSH DE + PUSH HL + ; +MEMSW2: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_0 ; We meed to be in memory mode 10 to process the interrupts as this allows us access to the hardware. + OUT (MMCFG),A + ENDIF + ; + ; Reset the interrupt counter. + LD HL,CONTF ; CTC Control register, set to reload the 100ms interrupt time period. + LD (HL),080H ; Select Counter 2, latch counter, read lsb first, mode 0 and binary. + PUSH HL + DEC HL + LD E,(HL) + LD D,(HL) ; Obtain the overrun count if any (due to disabled interrupts). + LD HL, 00001H ; Add full range to count to obtain the period of overrun time. + SBC HL,DE + EX DE,HL + POP HL + LD (HL),0B0H ; Select Counter 2, load lsb first, mode 0 interrupt on terminal count, binary + DEC HL + LD (HL),TMRTICKINTV + LD (HL),000H ; Another 100msec delay till next interrupt. + ; + ; Update the RTC with the time period. + LD HL,(TIMESEC) ; Lower 16bits of counter. + ADD HL,DE + LD (TIMESEC),HL + JR NC,TIMIN1 ; On overflow we increment middle 16bits. + ; + LD HL,(TIMESEC+2) + INC HL + LD (TIMESEC+2),HL + LD A,H + OR L + JR NZ,TIMIN1 ; On overflow we increment upper 16bits. + ; + LD HL,(TIMESEC+4) + INC HL + LD (TIMESEC+4),HL + + ; + ; Flash a cursor at the current XY location. + ; +TIMIN1: LD HL,FLASHCTL + BIT 7,(HL) ; Is cursor enabled? If it isnt, skip further processing. + JR Z,TIMIN3 + ; +FLSHCTL0: LD A,(KEYPC) ; Flashing component, on each timer tick, display the cursor or the original screen character. + LD C,A + XOR (HL) ; Detect a cursor change signal. + RLCA + RLCA + JR NC,TIMIN3 ; No change, skip. + + RES 6,(HL) + LD A,C ; We know there was a change, so decide what to display and write to screen. + RLCA + RLCA + LD A,(FLASH) + JR NC,FLSHCTL1 + SET 6,(HL) ; We are going to display the cursor, so save the underlying character. + LD A,(FLSDT) ; Retrieve the cursor character. +FLSHCTL1: LD HL,(DSPXYADDR) ; Load the desired cursor or character onto the screen. + LD (HL),A + + ; + ; Keyboard processing. + ; +TIMIN3: ; Perform keyboard sweep - inline to avoid overhead of a call. + ; KEYBOARD SWEEP + ; + ; EXIT B,D7=0 NO DATA + ; =1 DATA + ; D6=0 SHIFT OFF + ; =1 SHIFT ON + ; C = ROW & COLUMN + ; +SWEP: XOR A + LD (KDATW),A ; Reset key counter + LD B,0FAH ; Starting scan line, D3:0 = scan = line 10. D5:4 not used, D7=Cursor flash. + LD D,A + + ; BREAK TEST + ; BREAK ON : ZERO = 1 + ; OFF : ZERO = 0 + ; NO KEY : CY = 0 + ; KEY IN : CY = 1 + ; A D6=1: SHIFT ON + ; =0: SHIFT OFF + ; D5=1: CTRL ON + ; =0: CTRL OFF + ; D4=1: GRAPH ON + ; =0: GRAPH OFF +BREAK: LD A,0F0H + LD (KEYPA),A ; Port A scan line 0 + NOP + LD A,(KEYPB) ; Read back key data. + OR A + RLA + JR NC,BREAK3 ; CTRL/BREAK key pressed? + RRA + RRA ; Check if SHIFT key pressed/ + JR NC,BREAK1 ; SHIFT BREAK not pressed, jump. + RRA + JR NC,BREAK2 ; Check for GRAPH. + CCF + JR SWEP6 ;SWEP1 + +BREAK1: LD A,040H ; A D6=1 SHIFT ON + SCF + JR SWEP6 + +BREAK2: LD A,001H ; No keys found to be pressed on scanline 0. + LD (KDATW),A + LD A,010H ; A D4=1 GRAPH + SCF + JR SWEP6 + +BREAK3: AND 006H ; SHIFT + GRAPH + BREAK? + JR Z,SWEP1A + AND 002H ; SHIFT ? + JR Z,SWEP1 ; Z = 1 = SHIFT BREAK pressed/ + LD A,020H ; A D5=1 CTRL + SCF + JR SWEP6 + +SWEP1: LD D,088H ; Break ON + JR SWEP9 +SWEP1A: JP REBOOT ; Shift + Graph + Break ON = RESET. + ; + JR SWEP9 +SWEP6: LD HL,SWPW + PUSH HL + JR NC,SWEP11 + LD D,A + AND 060H ; Shift & Ctrl =no data. + JR NZ,SWEP11 + LD A,D ; Graph Check + XOR (HL) + BIT 4,A + LD (HL),D + JR Z,SWEP0 +SWEP01: SET 7,D ; Data available, set flag. +SWEP0: DEC B + POP HL ; SWEP column work + INC HL + LD A,B + LD (KEYPA),A ; Port A (8255) D3:0 = Scan line output. + CP 0F0H + JR NZ,SWEP3 ; If we are not at scan line 0 then check for key data. + LD A,(HL) ; SWPW + CP 003H ; Have we scanned all lines, if yes then no data? + JR C,SWEP9 + LD (HL),000H ; + RES 7,D ; Reset data in as no data awailable. +SWEP9: LD B,D + JR ISRKEY0 + +SWEP11: LD (HL),000H + JR SWEP0 +SWEP3: LD A,(KEYPB) ; Port B (8255) D7:0 = Key data in for given scan line. + LD E,A + CPL + AND (HL) + LD (HL),E + PUSH HL + LD HL,KDATW + PUSH BC + LD B,008H +SWEP8: RLC E + JR C,SWEP7 + INC (HL) +SWEP7: DJNZ SWEP8 + POP BC + OR A + JR Z,SWEP0 + LD E,A +SWEP2: LD H,008H + LD A,B + DEC A ; TBL adjust + AND 00FH + RLCA + RLCA + RLCA + LD C,A + LD A,E +SWEP12: DEC H + RRCA + JR NC,SWEP12 + LD A,H + ADD A,C + LD C,A + JP SWEP01 + +ISRKEY0: LD A,B + RLCA + JP C,ISRKEY2 ; CY=1 then data available. + LD HL,KDATW + LD A,(HL) ; Is a key being held down? + OR A + JR NZ, ISRAUTORPT ; It is so process as an auto repeat key. + XOR A + LD (KEYRPT),A ; No key held then clear the auto repeat initial pause counter. + LD A,NOKEY ; No key code. +ISRKEY1: LD HL,KDATW + LD E,A + LD A,(HL) ; Current key scan line position. + INC HL + LD D,(HL) ; Previous key position. + LD (HL),A ; Previous <= current + SUB D ; Are they the same? + JR NC,ISRKEY11 + INC (HL) ; +ISRKEY11: LD A,E +ISRKEY10: CP NOKEY + JR Z,ISREXIT + LD (KEYLAST),A +ISRKEYRPT: LD A,(KEYCOUNT) ; Get current count of bytes in the keyboard buffer. + CP KEYBUFSIZE - 1 + JR NC, ISREXIT ; Keyboard buffer full, so waste character. + INC A + LD (KEYCOUNT),A + LD HL,(KEYWRITE) ; Get the write buffer pointer. + LD (HL), E ; Store the character. + INC L + LD A,L + AND KEYBUFSIZE-1 ; Circular buffer, keep boundaries. + LD L,A + LD (KEYWRITE),HL ; Store updated pointer. + ; +ISREXIT: +MEMSW3: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_2 ; Return to the full 64K memory mode. + OUT (MMCFG),A + ENDIF + ; + POP HL + POP DE + POP BC + POP AF + ; + LD SP,(SPISRSAVE) + EI + RET + + ; + ; Helper to determine if a key is being held down and autorepeat should be applied. + ; The criterion is a timer, if this expires then autorepeat is applied. + ; +ISRAUTORPT: LD A,(KEYRPT) ; Increment an initial pause counter. + INC A + CP 10 + JR C,ISRAUTO1 ; Once expired we can auto repeat the last key. + LD A,(KEYLAST) + CP 080H + JR NC,ISREXIT ; Dont auto repeat control keys. + LD E,A + JR ISRKEYRPT +ISRAUTO1: LD (KEYRPT),A + JR ISREXIT + + ; + ; Method to alternate through the 3 shift modes, CAPSLOCK=1, SHIFTLOCK=2, NO LOCK=0 + ; +LOCKTOGGLE: LD HL,FLSDT + LD A,(SFTLK) + INC A + CP 3 + JR C,LOCK0 + XOR A +LOCK0: LD (SFTLK),A + OR A + LD (HL),043H ; Thick block cursor when lower case. + JR Z,LOCK1 + CP 1 + LD (HL),03EH ; Thick underscore when CAPS lock. + JR Z,LOCK1 + LD (HL),0EFH ; Block cursor when SHIFT lock. +LOCK1: JP ISREXIT + + +ISRKEY2: RLCA + RLCA + RLCA + JP C,LOCKTOGGLE ; GRAPH key which acts as the Shift Lock. + RLCA + JP C,ISRBRK ; BREAK key. + LD H,000H + LD L,C + LD A,C + CP 038H ; TEN KEY check. + JR NC,ISRKEY6 ; Jump if TENKEY. + LD A,B + RLCA + LD B,A + LD A,(SFTLK) + OR A + LD A,B + JR Z,ISRKEY14 + RLA + CCF + RRA +ISRKEY14: RLA + RLA + JR NC,ISRKEY3 +ISRKEY15: LD DE,KTBLC +ISRKEY5: ADD HL,DE + LD A,(HL) + JP ISRKEY1 + +ISRKEY3: RRA + JR NC,ISRKEY6 + LD A,(SFTLK) + CP 1 + LD DE,KTBLCL + JR Z,ISRKEY5 + LD DE,KTBLS + JR ISRKEY5 + +ISRKEY6: LD DE,KTBL + JR ISRKEY5 +ISRKEY4: RLCA + RLCA + JR C,ISRKEY15 + LD DE,KTBL + JR ISRKEY5 + + ; Break key pressed, handled in getkey routine. +ISRBRK: LD A,(KEYLAST) + CP BREAKKEY + JP Z,ISREXIT + XOR A ; Reset the keyboard buffer. + LD (KEYCOUNT),A + LD HL,KEYBUF + LD (KEYWRITE),HL + LD (KEYREAD),HL + LD A,BREAKKEY + JP ISRKEY10 + + +KTBL: ; Strobe 0 + DB '"' + DB '!' + DB 'W' + DB 'Q' + DB 'A' + DB INSERT + DB 0 + DB 'Z' + ; Strobe 1 + DB '$' + DB '#' + DB 'R' + DB 'E' + DB 'D' + DB 'S' + DB 'X' + DB 'C' + ; Strobe 2 + DB '&' + DB '%' + DB 'Y' + DB 'T' + DB 'G' + DB 'F' + DB 'V' + DB 'B' + ; Strobe 3 + DB '(' + DB '\'' + DB 'I' + DB 'U' + DB 'J' + DB 'H' + DB 'N' + DB SPACE + ; Strobe 4 + DB '_' + DB ')' + DB 'P' + DB 'O' + DB 'L' + DB 'K' + DB '<' + DB 'M' + ; Strobe 5 + DB '~' + DB '=' + DB '{' + DB '`' + DB '*' + DB '+' + DB CURSLEFT + DB '>' + ; Strobe 6 + DB HOMEKEY + DB '|' + DB CURSRIGHT + DB CURSUP + DB CR + DB '}' + DB 0 + DB CURSUP + ; Strobe 7 + DB '8' + DB '7' + DB '5' + DB '4' + DB '2' + DB '1' + DB DBLZERO + DB '0' + ; Strobe 8 + DB '*' + DB '9' + DB '-' + DB '6' + DB 0 + DB '3' + DB 0 + DB ',' + +KTBLS: ; Strobe 0 + DB '2' + DB '1' + DB 'w' + DB 'q' + DB 'a' + DB DELETE + DB 0 + DB 'z' + ; Strobe 1 + DB '4' + DB '3' + DB 'r' + DB 'e' + DB 'd' + DB 's' + DB 'x' + DB 'c' + ; Strobe 2 + DB '6' + DB '5' + DB 'y' + DB 't' + DB 'g' + DB 'f' + DB 'v' + DB 'b' + ; Strobe 3 + DB '8' + DB '7' + DB 'i' + DB 'u' + DB 'j' + DB 'h' + DB 'n' + DB SPACE + ; Strobe 4 + DB '0' + DB '9' + DB 'p' + DB 'o' + DB 'l' + DB 'k' + DB ',' + DB 'm' + ; Strobe 5 + DB '^' + DB '-' + DB '[' + DB '@' + DB ':' + DB ';' + DB '/' + DB '.' + ; Strobe 6 + DB CLRKEY + DB '\\' + DB CURSLEFT + DB CURSDOWN + DB CR + DB ']' + DB 0 + DB '?' + +KTBLCL: ; Strobe 0 + DB '2' + DB '1' + DB 'W' + DB 'Q' + DB 'A' + DB DELETE + DB 0 + DB 'Z' + ; Strobe 1 + DB '4' + DB '3' + DB 'R' + DB 'E' + DB 'D' + DB 'S' + DB 'X' + DB 'C' + ; Strobe 2 + DB '6' + DB '5' + DB 'Y' + DB 'T' + DB 'G' + DB 'F' + DB 'V' + DB 'B' + ; Strobe 3 + DB '8' + DB '7' + DB 'I' + DB 'U' + DB 'J' + DB 'H' + DB 'N' + DB SPACE + ; Strobe 4 + DB '0' + DB '9' + DB 'P' + DB 'O' + DB 'L' + DB 'K' + DB ',' + DB 'M' + ; Strobe 5 + DB '^' + DB '-' + DB '[' + DB '@' + DB ':' + DB ';' + DB '/' + DB '.' + ; Strobe 6 + DB CLRKEY + DB '\\' + DB CURSLEFT + DB CURSDOWN + DB CR + DB ']' + DB 0 + DB '?' + +KTBLC: ; CTRL ON + ; Strobe 0 + DB NOKEY + DB NOKEY + DB CTRL_W + DB CTRL_Q + DB CTRL_A + DB NOKEY + DB 000H + DB CTRL_Z + ; Strobe 1 + DB NOKEY + DB NOKEY + DB CTRL_R + DB CTRL_E + DB CTRL_D + DB CTRL_S + DB CTRL_X + DB CTRL_C + ; Strobe 2 + DB NOKEY + DB NOKEY + DB CTRL_Y + DB CTRL_T + DB CTRL_G + DB CTRL_F + DB CTRL_V + DB CTRL_B + ; Strobe 3 + DB NOKEY + DB NOKEY + DB CTRL_I + DB CTRL_U + DB CTRL_J + DB CTRL_H + DB CTRL_N + DB NOKEY + ; Strobe 4 + DB NOKEY + DB NOKEY + DB CTRL_P + DB CTRL_O + DB CTRL_L + DB CTRL_K + DB NOKEY + DB CTRL_M + ; Strobe 5 + DB CTRL_CAPPA + DB CTRL_UNDSCR + DB ESC + DB CTRL_AT + DB NOKEY + DB NOKEY + DB NOKEY + DB NOKEY + ; Strobe 6 + DB NOKEY + DB CTRL_SLASH + DB NOKEY + DB NOKEY + DB NOKEY + DB CTRL_RB + DB NOKEY + + ;------------------------------------------------------------------------------- + ; END OF TIMER INTERRUPT + ;------------------------------------------------------------------------------- + + + ;------------------------------------------------------------------------------- + ; SERVICE COMMAND METHODS + ;------------------------------------------------------------------------------- + + ; Method to send a command to the I/O processor and verify it is being acted upon. + ; THe method, after sending the command, polls the service structure result to see if the I/O processor has updated it. If it doesnt update the result + ; then after a period of time the command is resent. After a number of retries the command aborts with error. This is needed in case of the I/O processor crashing + ; we dont want the host to lock up. + ; + ; Inputs: + ; A = Command. + ; Outputs: + ; A = 0 - Success, command being processed. + ; A = 1 - Failure, no contact with I/O processor. + ; A = 2 - Failure, no result from I/O processor, it could have crashed or SD card removed! +SVC_CMD: PUSH BC + LD (TZSVCCMD), A ; Load up the command into the service record. + LD A,TZSVC_STATUS_REQUEST + LD (TZSVCRESULT),A ; Set the service structure result to REQUEST, if this changes then the K64 is processing. + + LD BC, TZSVCWAITIORETRIES ; Safety in case the IO request wasnt seen by the I/O processor, if we havent seen a response in the service + +SVC_CMD1: PUSH BC + LD A,(TZSVCCMD) + OUT (SVCREQ),A ; Make the service request via the service request port. + + LD BC,0 +SVC_CMD2: LD A,(TZSVCRESULT) + CP TZSVC_STATUS_REQUEST ; I/O processor when it recognises the request sets the status to PROCESSING or gives a result, if this hasnt occurred the the K64F hasnt begun processing. + JR NZ, SVC_CMD3 + DEC BC + LD A,B + OR C + JR NZ, SVC_CMD2 + POP BC + DEC BC + LD A,B + OR C + JR NZ,SVC_CMD1 ; Retry sending the I/O command. + ; + PUSH DE + LD DE,SVCIOERR + CALL MONPRTSTR + POP DE + LD A,1 ; No response, error. + RET +SVC_CMD3: POP BC + ; + LD BC,TZSVCWAITCOUNT ; Number of loops to wait for a response before setting error. +SVC_CMD4: PUSH BC + LD BC,0 +SVC_CMD5: LD A,(TZSVCRESULT) + CP TZSVC_STATUS_PROCESSING ; Wait until the I/O processor sets the result, again timeout in case it locks up. + JR NZ, SVC_CMD6 + DEC BC + LD A,B + OR C + JR NZ,SVC_CMD5 + POP BC + DEC BC + LD A,B + OR C + JR NZ,SVC_CMD4 ; Retry polling for result. + ; + PUSH DE + LD DE,SVCRESPERR + CALL MONPRTSTR + POP DE + LD A,2 + RET +SVC_CMD6: XOR A ; Success. + POP BC + POP BC + RET + + ;------------------------------------------------------------------------------- + ; END OF SERVICE COMMAND METHODS + ;------------------------------------------------------------------------------- + + + + ;------------------------------------------------------------------------------- + ; START OF AUDIO CONTROLLER FUNCTIONALITY + ;------------------------------------------------------------------------------- + + ; Melody function. +MLDY: PUSH BC + PUSH DE + PUSH HL + LD A,002H + LD (OCTV),A + LD B,001H +MLD1: LD A,(DE) + CP 00DH + JR Z,MLD4 + CP 0C8H + JR Z,MLD4 + CP 0CFH + JR Z,MLD2 + CP 02DH + JR Z,MLD2 + CP 02BH + JR Z,MLD3 + CP 0D7H + JR Z,MLD3 + CP 023H + LD HL,MTBL + JR NZ,MLD1A + LD HL,M?TBL + INC DE +MLD1A: CALL ONPU + JR C,MLD1 + CALL RYTHM + JR C,MLD5 + CALL MLDST + LD B,C + JR MLD1 +MLD2: LD A,003H +MLD2A: LD (OCTV),A + INC DE + JR MLD1 +MLD3: LD A,001H + JR MLD2A +MLD4: CALL RYTHM +MLD5: PUSH AF + CALL MLDSP + POP AF + POP HL + POP DE + POP BC + RET + +ONPU: PUSH BC + LD B,008H + LD A,(DE) +ONP1A: CP (HL) + JR Z,ONP2 + INC HL + INC HL + INC HL + DJNZ ONP1A + SCF + INC DE + POP BC + RET + +ONP2: INC HL + PUSH DE + LD E,(HL) + INC HL + LD D,(HL) + EX DE,HL + LD A,H + OR A + JR Z,ONP2B + LD A,(OCTV) +ONP2A: DEC A + JR Z,ONP2B + ADD HL,HL + JR ONP2A +ONP2B: LD (RATIO),HL + LD HL,OCTV + LD (HL),002H + DEC HL + POP DE + INC DE + LD A,(DE) + LD B,A + AND 0F0H + CP 030H + JR Z,ONP2C + LD A,(HL) + JR ONP2D +ONP2C: INC DE + LD A,B + AND 00FH + LD (HL),A +ONP2D: LD HL,OPTBL + ADD A,L + LD L,A + LD C,(HL) + LD A,(TEMPW) + LD B,A + XOR A + JP MLDDLY + +RYTHM: LD HL,KEYPA + LD (HL),0F0H + INC HL + LD A,(HL) + AND 081H + JR NZ,L02D5 + SCF + RET + +L02D5: LD A,(SUNDG) + RRCA + JR C,L02D5 +L02DB: LD A,(SUNDG) + RRCA + JR NC,L02DB + DJNZ L02D5 + XOR A + RET + +MLDST: LD HL,(RATIO) + LD A,H + OR A + JR Z,MLDSP + PUSH DE + EX DE,HL + LD HL,CONT0 + LD (HL),E + LD (HL),D + LD A,001H + POP DE + JR L02C4 +MLDSP: LD A,034H + LD (CONTF),A + XOR A +L02C4: LD (SUNDG),A + RET + +MLDDLY: ADD A,C + DJNZ MLDDLY + POP BC + LD C,A + XOR A + RET + + +TEMPO: PUSH AF + PUSH BC + AND 00FH + LD B,A + LD A,008H + SUB B + LD (TEMPW),A + POP BC + POP AF + RET + + ; + ; Method to sound the bell, basically play a constant tone. + ; +BEL: PUSH DE + LD DE,00DB1H + CALL MLDY + POP DE + RET + + ; + ; Melody (note) lookup table. + ; +MTBL: DB 043H + DB 077H + DB 007H + DB 044H + DB 0A7H + DB 006H + DB 045H + DB 0EDH + DB 005H + DB 046H + DB 098H + DB 005H + DB 047H + DB 0FCH + DB 004H + DB 041H + DB 071H + DB 004H + DB 042H + DB 0F5H + DB 003H + DB 052H + DB 000H + DB 000H +M?TBL: DB 043H + DB 00CH + DB 007H + DB 044H + DB 047H + DB 006H + DB 045H + DB 098H + DB 005H + DB 046H + DB 048H + DB 005H + DB 047H + DB 0B4H + DB 004H + DB 041H + DB 031H + DB 004H + DB 042H + DB 0BBH + DB 003H + DB 052H + DB 000H + DB 000H + +OPTBL: DB 001H + DB 002H + DB 003H + DB 004H + DB 006H + DB 008H + DB 00CH + DB 010H + DB 018H + DB 020H + ;------------------------------------------------------------------------------- + ; END OF AUDIO CONTROLLER FUNCTIONALITY + ;------------------------------------------------------------------------------- + + + ;------------------------------------------------------------------------------- + ; START OF RTC FUNCTIONALITY (INTR HANDLER IN MAIN CBIOS) + ;------------------------------------------------------------------------------- + ; + ; BC:DE:HL contains the time in milliseconds (100msec resolution) since 01/01/1980. In IX is held the interrupt service handler routine address for the RTC. + ; HL contains lower 16 bits, DE contains middle 16 bits, BC contains upper 16bits, allows for a time from 00:00:00 to 23:59:59, for > 500000 days! + ; NB. Caller must disable interrupts before calling this method. +TIMESET: LD (TIMESEC),HL ; Load lower 16 bits. + EX DE,HL + LD (TIMESEC+2),HL ; Load middle 16 bits. + PUSH BC + POP HL + LD (TIMESEC+4),HL ; Load upper 16 bits. + ; + LD HL,CONTF + LD (HL),074H ; Set Counter 1, read/load lsb first then msb, mode 2 rate generator, binary + LD (HL),0B0H ; Set Counter 2, read/load lsb first then msb, mode 0 interrupt on terminal count, binary + DEC HL + LD DE,TMRTICKINTV ; 100Hz coming into Timer 2 from Timer 1, set divisor to set interrupts per second. + LD (HL),E ; Place current time in Counter 2 + LD (HL),D + DEC HL + LD (HL),03BH ; Place divisor in Counter 1, = 315, thus 31500/315 = 100 + LD (HL),001H + NOP + NOP + NOP + ; + LD A, 0C3H ; Install the interrupt vector for when interrupts are enabled. + LD (00038H),A + LD (00039H),IX + RET + + ; Time Read; + ; Returns BC:DE:HL where HL is lower 16bits, DE is middle 16bits and BC is upper 16bits of milliseconds since 01/01/1980. +TIMEREAD: LD HL,(TIMESEC+4) + PUSH HL + POP BC + LD HL,(TIMESEC+2) + EX DE,HL + LD HL,(TIMESEC) + RET + ;------------------------------------------------------------------------------- + ; END OF RTC FUNCTIONALITY + ;------------------------------------------------------------------------------- + + + ;------------------------------------------------------------------------------- + ; UTILITIES + ;------------------------------------------------------------------------------- + + ; Function to print a string with control character interpretation. +MONPRTSTR: LD A,(DE) + OR A + RET Z + INC DE +MONPRTSTR2: CALL PRNT + JR MONPRTSTR + + ; Method to clear memory either to 0 or a given pattern. + ; +CLR8Z: XOR A +CLR8: LD BC,00800H +CLRMEM: PUSH DE + LD D,A +L09E8: LD (HL),D + INC HL + DEC BC + LD A,B + OR C + JR NZ,L09E8 + POP DE + RET + + ; A function from the z88dk stdlib, a delay loop with T state accuracy. + ; + ; enter : hl = tstates >= 141 + ; uses : af, bc, hl +T_DELAY: LD BC,-141 + ADD HL,BC + LD BC,-23 +TDELAYLOOP: ADD HL,BC + JR C, TDELAYLOOP + LD A,L + ADD A,15 + JR NC, TDELAYG0 + CP 8 + JR C, TDELAYG1 + OR 0 +TDELAYG0: INC HL +TDELAYG1: RRA + JR C, TDELAYB0 + NOP +TDELAYB0: RRA + JR NC, TDELAYB1 + OR 0 +TDELAYB1: RRA + RET NC + RET + + ; Method to multiply a 16bit number by another 16 bit number to arrive at a 32bit result. + ; Input: DE = Factor 1 + ; BC = Factor 2 + ; Output:DEHL = 32bit Product + ; +MULT16X16: LD HL,0 + LD A,16 +MULT16X1: ADD HL,HL + RL E + RL D + JR NC,$+6 + ADD HL,BC + JR NC,$+3 + INC DE + DEC A + JR NZ,MULT16X1 + RET + + ; Method to add a 16bit number to a 32bit number to obtain a 32bit product. + ; Input: DEHL = 32bit Addend + ; BC = 16bit Addend + ; Output:DEHL = 32bit sum. + ; +ADD3216: ADD HL,BC + EX DE,HL + LD BC,0 + ADC HL,BC + EX DE,HL + RET + + ;------------------------------------------------------------------------------- + ; END OF UTILITIES + ;------------------------------------------------------------------------------- + + + ;------------------------------------------------------------------------------- + ; START OF KEYBOARD FUNCTIONALITY (INTR HANDLER SEPERATE IN CBIOS) + ;------------------------------------------------------------------------------- + +MODE: LD HL,KEYPF + LD (HL),08AH + LD (HL),007H ; Set Motor to Off. + LD (HL),004H ; Disable interrupts by setting INTMSK to 0. + LD (HL),001H ; Set VGATE to 1. + RET + + ; Method to check if a key has been pressed and stored in buffer.. +CHKKY: LD A, (KEYCOUNT) + OR A + JR Z,CHKKY2 + LD A,0FFH + RET +CHKKY2: XOR A + RET + +GETKY: PUSH HL + LD A,(KEYCOUNT) + OR A + JR Z,GETKY2 +GETKY1: DI ; Disable interrupts, we dont want a race state occurring. + LD A,(KEYCOUNT) + DEC A ; Take 1 off the total count as we are reading a character out of the buffer. + LD (KEYCOUNT),A + LD HL,(KEYREAD) ; Get the position in the buffer where the next available character resides. + LD A,(HL) ; Read the character and save. + PUSH AF + INC L ; Update the read pointer and save. + LD A,L + AND KEYBUFSIZE-1 + LD L,A + LD (KEYREAD),HL + POP AF + EI ; Interrupts back on so keys and RTC are actioned. + JR PRCKEY ; Process the key, action any non ASCII keys. + ; +GETKY2: LD A,(KEYCOUNT) ; No key available so loop until one is. + OR A + JR Z,GETKY2 + JR GETKY1 + ; +PRCKEY: CP CR ; CR + JR NZ,PRCKY3 + JR PRCKYE +PRCKY3: CP HOMEKEY ; HOME + JR NZ,PRCKY4 + JR GETKY2 +PRCKY4: CP CLRKEY ; CLR + JR NZ,PRCKY5 + JR GETKY2 +PRCKY5: CP INSERT ; INSERT + JR NZ,PRCKY6 + JR GETKY2 +PRCKY6: CP DBLZERO ; 00 + JR NZ,PRCKY7 + LD A,'0' + LD (KEYBUF),A ; Place a character into the keybuffer so we double up on 0 + JR PRCKYX +PRCKY7: CP BREAKKEY ; Break key processing. + JR NZ,PRCKY8 + +PRCKY8: +PRCKYX: +PRCKYE: + POP HL + RET + + ;------------------------------------------------------------------------------- + ; END OF KEYBOARD FUNCTIONALITY + ;------------------------------------------------------------------------------- + + + ;------------------------------------------------------------------------------- + ; START OF SCREEN FUNCTIONALITY + ;------------------------------------------------------------------------------- + + ; CR PAGE MODE1 +.CR: CALL .MANG + RRCA + JP NC,CURS2 + LD L,000H + INC H + CP ROW - 1 ; End of line? + JR Z,.CP1 + INC H + JP CURS1 + +.CP1: LD (DSPXY),HL + + ; SCROLLER +.SCROL: LD BC,SCRNSZ - COLW ; Scroll COLW -1 lines + LD DE,SCRN ; Start of the screen. + LD HL,SCRN + COLW ; Start of screen + 1 line. + LDIR + EX DE,HL + LD B,COLW ; Clear last line at bottom of screen. + CALL CLER + LD BC,0001AH + LD DE,MANG + LD HL,MANG + 1 + LDIR + LD (HL),000H + LD A,(MANG) + OR A + JP Z,RSTR + LD HL,DSPXY + 1 + DEC (HL) + JR .SCROL + +DPCT: PUSH AF ; Display control, character is mapped to a function call. + PUSH BC + PUSH DE + PUSH HL + LD B,A + AND 0F0H + CP 0C0H + JP NZ,RSTR + XOR B + RLCA + LD C,A + LD B,000H + LD HL,.CTBL +DPCT1: ADD HL,BC + LD E,(HL) + INC HL + LD D,(HL) + EX DE,HL + JP (HL) + + +PRT: LD A,C + CALL ADCN + LD C,A + AND 0F0H + CP 0F0H + RET Z + + CP 0C0H + LD A,C + JR NZ,PRNT3 +PRNT5: CALL DPCT + CP 0C3H + JR Z,PRNT4 + CP 0C5H + JR Z,PRNT2 + CP 0CDH ; CR + JR Z,PRNT2 + CP 0C6H + RET NZ + +PRNT2: XOR A +PRNT2A: LD (DPRNT),A + RET + +PRNT3: CALL DSP +PRNT4: LD A,(DPRNT) + INC A + CP COLW*2 ; 050H + JR C,PRNT4A + SUB COLW*2 ; 050H +PRNT4A: JR PRNT2A + +NL: LD A,(DPRNT) + OR A + RET Z + +LTNL: LD A,0CDH + JR PRNT5 +PRTT: CALL PRTS + LD A,(DPRNT) + OR A + RET Z + +L098C: SUB 00AH + JR C,PRTT + JR NZ,L098C + RET + + ; Delete a character on screen. +DELETECHR: LD A,0C7H + CALL DPCT + JR PRNT1 + +NEWLINE: CALL NL + JR PRNT1 + + ; + ; Function to disable the cursor display. + ; +CURSOROFF: DI + CALL CURSRSTR ; Restore character under the cursor. + LD HL,FLASHCTL ; Indicate cursor is now off. + RES 7,(HL) + EI + RET + + ; + ; Function to enable the cursor display. + ; +CURSORON: DI + CALL DSPXYTOADDR ; Update the screen address for where the cursor should appear. + LD HL,FLASHCTL ; Indicate cursor is now on. + SET 7,(HL) + EI + RET + + ; + ; Function to restore the character beneath the cursor iff the cursor is being dislayed. + ; +CURSRSTR: PUSH HL + PUSH AF + LD HL,FLASHCTL ; Check to see if there is a cursor at the current screen location. + BIT 6,(HL) + JR Z,CURSRSTR1 + RES 6,(HL) + LD HL,(DSPXYADDR) ; There is so we must restore the original character before further processing. + LD A,(FLASH) + LD (HL),A +CURSRSTR1: POP AF + POP HL + RET + + ; + ; Function to convert XY co-ordinates to a physical screen location and save. + ; +DSPXYTOADDR:PUSH HL + PUSH DE + PUSH BC + LD BC,(DSPXY) ; Calculate the new cursor position based on the XY coordinates. + LD DE,COLW + LD HL,SCRN - COLW +DSPXYTOA1: ADD HL,DE + DEC B + JP P,DSPXYTOA1 + LD B,000H + ADD HL,BC + RES 3,H + LD (DSPXYADDR),HL ; Store the new address. + LD A,(HL) ; Store the new character. + LD (FLASH),A +DSPXYTOA2: POP BC + POP DE + POP HL + RET + + ; + ; Function to print a space. + ; +PRTS: LD A,020H + + ; Function to print a character to the screen. If the character is a control code it is processed as necessary + ; otherwise the character is converted from ASCII display and displayed. + ; +PRNT: DI + LD (SPISRSAVE),SP ; Share the interrupt stack for banked access as the BASIC stack goes out of scope. + LD SP,ISRSTACK ; Interrupts are disabled so we can safely use this stack. + ; +MEMSW4: IF BUILD_TZFS = 1 + PUSH AF + LD A,TZMM_MZ700_0 ; Enable access to the hardware by paging out the upper bank. + OUT (MMCFG),A + POP AF + ENDIF + ; + CALL CURSRSTR ; Restore char under cursor. + CP 00DH + JR Z,NEWLINE + CP 00AH + JR Z,NEWLINE + CP 07FH + JR Z,DELETECHR + CP BACKS + JR Z,DELETECHR + PUSH BC + LD C,A + LD B,A + CALL PRT + LD A,B + POP BC +PRNT1: CALL DSPXYTOADDR + ; +MEMSW5: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_2 ; Enable access to the hardware by paging out the upper bank. + OUT (MMCFG),A + ENDIF + ; + LD SP,(SPISRSAVE) ; Restore the BASIC stack to exit. + EI + RET + + ; + ; Function to print out the contents of HL as 4 digit Hexadecimal. + ; +PRTHL: LD A,H + CALL PRTHX + LD A,L + JR PRTHX + RET + + ; + ; Function to print out the contents of A as 2 digit Hexadecimal + ; +PRTHX: PUSH AF + RRCA + RRCA + RRCA + RRCA + CALL ASCII + CALL PRNT + POP AF + CALL ASCII + JP PRNT + +ASCII: AND 00FH + CP 00AH + JR C,NOADD + ADD A,007H +NOADD: ADD A,030H + RET + +;CLR8Z: XOR A +; LD BC,00800H +; PUSH DE +; LD D,A +;L09E8: LD (HL),D +; INC HL +; DEC BC +; LD A,B +; OR C +; JR NZ,L09E8 +; POP DE +; RET + +REV: LD HL,REVFLG + LD A,(HL) + OR A + CPL + LD (HL),A + JR Z,REV1 + LD A,(INVDSP) + JR REV2 +REV1: LD A,(NRMDSP) +REV2: JP RSTR + +.MANG: LD HL,MANG +.MANG2: LD A,(DSPXY + 1) + ADD A,L + LD L,A + LD A,(HL) + INC HL + RL (HL) + OR (HL) + RR (HL) + RRCA + EX DE,HL + LD HL,(DSPXY) + RET + +L09C7: PUSH DE + PUSH HL + LD HL,PBIAS + XOR A + RLD + LD D,A + LD E,(HL) + RRD + XOR A + RR D + RR E + LD HL,SCRN + ADD HL,DE + LD (PAGETP),HL + POP HL + POP DE + RET + +DSP: PUSH AF + PUSH BC + PUSH DE + PUSH HL + LD B,A + CALL PONT + LD (HL),B + LD HL,(DSPXY) + LD A,L +DSP01: CP COLW - 1 ; End of line. + JP NZ,CURSR + CALL .MANG + JR C,CURSR +.DSP03: EX DE,HL + LD (HL),001H + INC HL + LD (HL),000H + JP CURSR + +CURSD: LD HL,(DSPXY) + LD A,H + CP ROW - 1 + JR Z,CURS4 + INC H +CURS1: ;CALL MGP.I +CURS3: LD (DSPXY),HL + JR RSTR + +CURSU: LD HL,(DSPXY) + LD A,H + OR A + JR Z,CURS5 + DEC H +CURSU1: JR CURS3 + +CURSR: LD HL,(DSPXY) + LD A,L + CP COLW - 1 ; End of line + JR NC,CURS2 + INC L + JR CURS3 +CURS2: LD L,000H + INC H + LD A,H + CP ROW + JR C,CURS1 + LD H,ROW - 1 + LD (DSPXY),HL +CURS4: JP .SCROL + +CURSL: LD HL,(DSPXY) + LD A,L + OR A + JR Z,CURS5A + DEC L + JR CURS3 +CURS5A: LD L,COLW - 1 ; End of line + DEC H + JP P,CURSU1 + LD H,000H + LD (DSPXY),HL +CURS5: JR RSTR + +CLRS: LD HL,MANG + LD B,01BH + CALL CLER + LD HL,SCRN + PUSH HL + CALL CLR8Z + POP HL +CLRS1: LD A,(SCLDSP) +HOM0: LD HL,00000H + JP CURS3 + +RSTR: POP HL +RSTR1: POP DE + POP BC + POP AF + RET + +DEL: LD HL,(DSPXY) + LD A,H + OR L + JR Z,RSTR + LD A,L + OR A + JR NZ,DEL1 + CALL .MANG + JR C,DEL1 + CALL PONT + DEC HL + LD (HL),000H + JR CURSL +DEL1: CALL .MANG + RRCA + LD A,COLW + JR NC,L0F13 + RLCA +L0F13: SUB L + LD B,A + CALL PONT + PUSH HL + POP DE + DEC DE + SET 4,D +DEL2: RES 3,H + RES 3,D + LD A,(HL) + LD (DE),A + INC HL + INC DE + DJNZ DEL2 + DEC HL + LD (HL),000H + JP CURSL + +INST: CALL .MANG + RRCA + LD L,COLW - 1 ; End of line + LD A,L + JR NC,INST1A + INC H +INST1A: CALL PNT1 + PUSH HL + LD HL,(DSPXY) + JR NC,INST2 + LD A,(COLW*2)-1 ; 04FH +INST2: SUB L + LD B,A + POP DE + LD A,(DE) + OR A + JR NZ,RSTR + CALL PONT + LD A,(HL) + LD (HL),000H +INST1: INC HL + RES 3,H + LD E,(HL) + LD (HL),A + LD A,E + DJNZ INST1 + JR RSTR + +PONT: LD HL,(DSPXY) +PNT1: PUSH AF + PUSH BC + PUSH DE + PUSH HL + POP BC + LD DE,COLW + LD HL,SCRN - COLW +PNT2: ADD HL,DE + DEC B + JP P,PNT2 + LD B,000H + ADD HL,BC + RES 3,H + POP DE + POP BC + POP AF + RET + +CLER: XOR A + JR DINT +CLRFF: LD A,0FFH +DINT: LD (HL),A + INC HL + DJNZ DINT + RET + +ADCN: PUSH BC + PUSH HL + LD HL,ATBL ;00AB5H + LD C,A + LD B,000H + ADD HL,BC + LD A,(HL) + JR DACN3 + +DACN: PUSH BC + PUSH HL + PUSH DE + LD HL,ATBL + LD D,H + LD E,L + LD BC,00100H + CPIR + JR Z,DACN1 + LD A,0F0H +DACN2: POP DE +DACN3: POP HL + POP BC + RET + +DACN1: OR A + DEC HL + SBC HL,DE + LD A,L + JR DACN2 + + ; CTBL PAGE MODE1 +.CTBL: DW .SCROL + DW CURSD + DW CURSU + DW CURSR + DW CURSL + DW HOM0 + DW CLRS + DW DEL + DW INST + DW RSTR + DW RSTR + DW RSTR + DW REV + DW .CR + DW RSTR + DW RSTR + +; ASCII TO DISPLAY CODE TABLE +ATBL: DB 0CCH ; NUL '\0' (null character) + DB 0E0H ; SOH (start of heading) + DB 0F2H ; STX (start of text) + DB 0F3H ; ETX (end of text) + DB 0CEH ; EOT (end of transmission) + DB 0CFH ; ENQ (enquiry) + DB 0F6H ; ACK (acknowledge) + DB 0F7H ; BEL '\a' (bell) + DB 0F8H ; BS '\b' (backspace) + DB 0F9H ; HT '\t' (horizontal tab) + DB 0FAH ; LF '\n' (new line) + DB 0FBH ; VT '\v' (vertical tab) + DB 0FCH ; FF '\f' (form feed) + DB 0FDH ; CR '\r' (carriage ret) + DB 0FEH ; SO (shift out) + DB 0FFH ; SI (shift in) + DB 0E1H ; DLE (data link escape) + DB 0C1H ; DC1 (device control 1) + DB 0C2H ; DC2 (device control 2) + DB 0C3H ; DC3 (device control 3) + DB 0C4H ; DC4 (device control 4) + DB 0C5H ; NAK (negative ack.) + DB 0C6H ; SYN (synchronous idle) + DB 0E2H ; ETB (end of trans. blk) + DB 0E3H ; CAN (cancel) + DB 0E4H ; EM (end of medium) + DB 0E5H ; SUB (substitute) + DB 0E6H ; ESC (escape) + DB 0EBH ; FS (file separator) + DB 0EEH ; GS (group separator) + DB 0EFH ; RS (record separator) + DB 0F4H ; US (unit separator) + DB 000H ; SPACE + DB 061H ; ! + DB 062H ; " + DB 063H ; # + DB 064H ; $ + DB 065H ; % + DB 066H ; & + DB 067H ; ' + DB 068H ; ( + DB 069H ; ) + DB 06BH ; * + DB 06AH ; + + DB 02FH ; , + DB 02AH ; - + DB 02EH ; . + DB 02DH ; / + DB 020H ; 0 + DB 021H ; 1 + DB 022H ; 2 + DB 023H ; 3 + DB 024H ; 4 + DB 025H ; 5 + DB 026H ; 6 + DB 027H ; 7 + DB 028H ; 8 + DB 029H ; 9 + DB 04FH ; : + DB 02CH ; ; + DB 051H ; < + DB 02BH ; = + DB 057H ; > + DB 049H ; ? + DB 055H ; @ + DB 001H ; A + DB 002H ; B + DB 003H ; C + DB 004H ; D + DB 005H ; E + DB 006H ; F + DB 007H ; G + DB 008H ; H + DB 009H ; I + DB 00AH ; J + DB 00BH ; K + DB 00CH ; L + DB 00DH ; M + DB 00EH ; N + DB 00FH ; O + DB 010H ; P + DB 011H ; Q + DB 012H ; R + DB 013H ; S + DB 014H ; T + DB 015H ; U + DB 016H ; V + DB 017H ; W + DB 018H ; X + DB 019H ; Y + DB 01AH ; Z + DB 052H ; [ + DB 059H ; \ '\\' + DB 054H ; ] + DB 0BEH ; ^ + DB 03CH ; _ + DB 0C7H ; ` + DB 081H ; a + DB 082H ; b + DB 083H ; c + DB 084H ; d + DB 085H ; e + DB 086H ; f + DB 087H ; g + DB 088H ; h + DB 089H ; i + DB 08AH ; j + DB 08BH ; k + DB 08CH ; l + DB 08DH ; m + DB 08EH ; n + DB 08FH ; o + DB 090H ; p + DB 091H ; q + DB 092H ; r + DB 093H ; s + DB 094H ; t + DB 095H ; u + DB 096H ; v + DB 097H ; w + DB 098H ; x + DB 099H ; y + DB 09AH ; z + DB 0BCH ; { + DB 080H ; | + DB 040H ; } + DB 0A5H ; ~ + DB 0C0H ; DEL + DB 040H + DB 0BDH + DB 09DH + DB 0B1H + DB 0B5H + DB 0B9H + DB 0B4H + DB 09EH + DB 0B2H + DB 0B6H + DB 0BAH + DB 0BEH + DB 09FH + DB 0B3H + DB 0B7H + DB 0BBH + DB 0BFH + DB 0A3H + DB 085H + DB 0A4H + DB 0A5H + DB 0A6H + DB 094H + DB 087H + DB 088H + DB 09CH + DB 082H + DB 098H + DB 084H + DB 092H + DB 090H + DB 083H + DB 091H + DB 081H + DB 09AH + DB 097H + DB 093H + DB 095H + DB 089H + DB 0A1H + DB 0AFH + DB 08BH + DB 086H + DB 096H + DB 0A2H + DB 0ABH + DB 0AAH + DB 08AH + DB 08EH + DB 0B0H + DB 0ADH + DB 08DH + DB 0A7H + DB 0A8H + DB 0A9H + DB 08FH + DB 08CH + DB 0AEH + DB 0ACH + DB 09BH + DB 0A0H + DB 099H + DB 0BCH + DB 0B8H + DB 080H + DB 03BH + DB 03AH + DB 070H + DB 03CH + DB 071H + DB 05AH + DB 03DH + DB 043H + DB 056H + DB 03FH + DB 01EH + DB 04AH + DB 01CH + DB 05DH + DB 03EH + DB 05CH + DB 01FH + DB 05FH + DB 05EH + DB 037H + DB 07BH + DB 07FH + DB 036H + DB 07AH + DB 07EH + DB 033H + DB 04BH + DB 04CH + DB 01DH + DB 06CH + DB 05BH + DB 078H + DB 041H + DB 035H + DB 034H + DB 074H + DB 030H + DB 038H + DB 075H + DB 039H + DB 04DH + DB 06FH + DB 06EH + DB 032H + DB 077H + DB 076H + DB 072H + DB 073H + DB 047H + DB 07CH + DB 053H + DB 031H + DB 04EH + DB 06DH + DB 048H + DB 046H + DB 07DH + DB 044H + DB 01BH + DB 058H + DB 079H + DB 042H + DB 060H + DB 0FDH + DB 0CBH + DB 000H + DB 01EH + ;------------------------------------------------------------------------------- + ; END OF SCREEN FUNCTIONALITY + ;------------------------------------------------------------------------------- + + ;------------------------------------------------------------------------------- + ; ANSI TERMINAL FUNCTIONALITY + ;------------------------------------------------------------------------------- + + ;---------------------------------------- + ; + ; ANSI EMULATION + ; + ; Emulate the Ansi standard + ; N.B. Turned on when Chr + ; 27 recieved. + ; Entry - A = Char + ; Exit - None + ; Used - None + ; + ;---------------------------------------- +ANSITERM: IF INCLUDE_ANSITERM = 1 + PUSH HL + PUSH DE + PUSH BC + PUSH AF + LD C,A ; Move character into C for safe keeping + ; + LD A,(ANSIMODE) + OR A + JR NZ,ANSI2 + LD A,C + CP 27 + JP NZ,NOTANSI ; If it is Chr 27 then we haven't just + ; been turned on, so don't bother with + ; all the checking. + LD A,1 ; Turn on. + LD (ANSIMODE),A + JP AnsiMore + +ANSI2: LD A,(CHARACTERNO) ; CHARACTER number in sequence + OR A ; Is this the first character? + JP Z,AnsiFirst ; Yes, deal with this strange occurance! + + LD A,C ; Put character back in C to check + + CP ";" ; Is it a semi colon? + JP Z,AnsiSemi + + CP "0" ; Is it a number? + JR C,ANSI_NN ; If <0 then no + CP "9"+1 ; If >9 then no + JP C,AnsiNumber + +ANSI_NN: CP "?" ; Simple trap for simple problem! + JP Z,AnsiMore + + CP "@" ; Is it a letter? + JP C,ANSIEXIT ; Abandon if not letter; something wrong + +ANSIFOUND: CALL CURSRSTR ; Restore any character under the cursor. + LD HL,(NUMBERPOS) ; Get value of number buffer + LD A,(HAVELOADED) ; Did we put anything in this byte? + OR A + JR NZ,AF1 + LD (HL),255 ; Mark the fact that nothing was put in +AF1: INC HL + LD A,254 + LD (HL),A ; Mark end of sequence (for unlimited length sequences) + + ;Disable cursor as unwanted side effects such as screen flicker may occur. + LD A,(FLASHCTL) + BIT 7,A + CALL NZ,CURSOROFF + + XOR A + LD (CURSORCOUNT),A ; Restart count + LD A,0C9h + LD (CHGCURSMODE),A ; Disable flashing temp. + + LD HL,NUMBERBUF ; For the routine called. + LD A,C ; Restore number + ; + ; Now work out what happens... + ; + CP "A" ; Check for supported Ansi characters + JP Z,CUU ; Upwards + CP "B" + JP Z,CUD ; Downwards + CP "C" + JP Z,CUF ; Forward + CP "D" + JP Z,CUB ; Backward + CP "H" + JP Z,CUP ; Locate + CP "f" + JP Z,HVP ; Locate + CP "J" + JP Z,ED ; Clear screen + CP "m" + JP Z,SGR ; Set graphics renditon + CP "K" + JP Z,EL ; Clear to end of line + CP "s" + JP Z,SCP ; Save the cursor position + CP "u" + JP Z,RCP ; Restore the cursor position + +ANSIEXIT: CALL CURSORON ; If t + LD HL,NUMBERBUF ; Numbers buffer position + LD (NUMBERPOS),HL + XOR A + LD (CHARACTERNO),A ; Next time it runs, it will be the + ; first character + LD (HAVELOADED),A ; We haven't filled this byte! + LD (CHGCURSMODE),A ; Cursor allowed back again! + XOR A + LD (ANSIMODE),A + JR AnsiMore +NOTANSI: CP 000h ; Filter unprintable characters. + JR Z,AnsiMore + CALL PRNT +AnsiMore: POP AF + POP BC + POP DE + POP HL + RET + ; + ; The various routines needed to handle the filtered characters + ; +AnsiFirst: LD A,255 + LD (CHARACTERNO),A ; Next character is not first! + LD A,C ; Get character back + LD (ANSIFIRST),A ; Save first character to check later + CP "(" ; ( and [ have characters to follow + JP Z,AnsiMore ; and are legal. + CP "[" + JP Z,AnsiMore + CP 09Bh ; CSI + JP Z,AnsiF1 ; Pretend that "[" was first ;-) + JP ANSIEXIT ; = and > don't have anything to follow + ; them but are legal. + ; Others are illegal, so abandon anyway. +AnsiF1: LD A,"[" ; Put a "[" for first character + LD (ANSIFIRST),A + JP ANSIEXIT + +AnsiSemi: LD HL,(NUMBERPOS) ; Move the number pointer to the + LD A,(HAVELOADED) ; Did we put anything in this byte? + OR A + JR NZ,AS1 + LD (HL),255 ; Mark the fact that nothing was put in +AS1: INC HL ; move to next byte + LD (NUMBERPOS),HL + XOR A + LD (HAVELOADED),A ; New byte => not filled! + JP AnsiMore + +AnsiNumber: LD HL,(NUMBERPOS) ; Get address for number + LD A,(HAVELOADED) + OR A ; If value is zero + JR NZ,AN1 + LD A,C ; Get value into A + SUB "0" ; Remove ASCII offset + LD (HL),A ; Save and Exit + LD A,255 + LD (HAVELOADED),A ; Yes, we _have_ put something in! + JP AnsiMore + +AN1: LD A,(HL) ; Stored value in A; TBA in C + ADD A,A ; 2 * + LD D,A ; Save the 2* for later + ADD A,A ; 4 * + ADD A,A ; 8 * + ADD A,D ; 10 * + ADD A,C ; 10 * + new num + SUB "0" ; And remove offset from C value! + LD (HL),A ; Save and Exit. + JP AnsiMore ; Note routine will only work up to 100 + ; which should be okay for this application. + + ;-------------------------------- + ; GET NUMBER + ; + ; Gets the next number from + ; the list + ; + ; Entry - HL = address to get + ; from + ; Exit - HL = next address + ; A = value + ; IF a=255 then default value + ; If a=254 then end of sequence + ; Used - None + ;-------------------------------- +GetNumber: LD A,(HL) ; Get number + CP 254 + RET Z ; Return if end of sequence,ie still point to + ; end + INC HL ; Return pointing to next byte + RET ; Else next address and return + + ;*** ANSI UP + ; +CUU: CALL GetNumber ; Number into A + LD B,A ; Save value into B + CP 255 + JR NZ,CUUlp + LD B,1 ; Default value +CUUlp: LD A,(DSPXY+1) ; A <- Row + CP B ; Is it too far? + JR C,CUU1 + SUB B ; No, then go back that far. + JR CUU2 +CUU1: LD A,0 ; Make the choice, top line. +CUU2: LD (DSPXY+1),A ; Row <- A + JP ANSIEXIT + + ;*** ANSI DOWN + ; +CUD: LD A,(ANSIFIRST) + CP "[" + JP NZ,ANSIEXIT ; Ignore ESC(B + CALL GetNumber + LD B,A ; Save value in b + CP 255 + JR NZ,CUDlp + LD B,1 ; Default +CUDlp: LD A,(DSPXY+1) ; A <- Row + ADD A,B + CP ROW ; Too far? + JP C,CUD1 + LD A,ROW-1 ; Too far then bottom of screen +CUD1: LD (DSPXY+1),A ; Row <- A + JP ANSIEXIT + + ;*** ANSI RIGHT + ; +CUF: CALL GetNumber ; Number into A + LD B,A ; Value saved in B + CP 255 + JR NZ,CUFget + LD B,1 ; Default +CUFget: LD A,(DSPXY) ; A <- Column + ADD A,B ; Add movement. + CP 80 ; Too far? + JR C,CUF2 + LD A,79 ; Yes, right edge +CUF2: LD (DSPXY),A ; Column <- A + JP ANSIEXIT + + ;*** ANSI LEFT + ; +CUB: CALL GetNumber ; Number into A + LD B,A ; Save value in B + CP 255 + JR NZ,CUBget + LD B,1 ; Default +CUBget: LD A,(DSPXY) ; A <- Column + CP B ; Too far? + JR C,CUB1a + SUB B + JR CUB1b +CUB1a: LD A,0 +CUB1b: LD (DSPXY),A ; Column <-A + JP ANSIEXIT + + ;*** ANSI LOCATE + ; +HVP: +CUP: CALL GetNumber + CP 255 + CALL Z,DefaultLine ; Default = 1 + CP 254 ; Sequence End -> 1 + CALL Z,DefaultLine + CP ROW+1 ; Out of range then don't move + JP NC,ANSIEXIT + OR A + CALL Z,DefaultLine ; 0 means default, some strange reason + LD D,A + CALL GetNumber + CP 255 ; Default = 1 + CALL Z,DefaultColumn + CP 254 ; Sequence End -> 1 + CALL Z,DefaultColumn + CP 81 ; Out of range, then don't move + JP NC,ANSIEXIT + OR A + CALL Z,DefaultColumn ; 0 means go with default + LD E,A + EX DE,HL + DEC H ; Translate from Ansi co-ordinates to hardware + DEC L ; co-ordinates + LD (DSPXY),HL ; Set the cursor position. + JP ANSIEXIT + +DefaultColumn: +DefaultLine:LD A,1 + RET + + ;*** ANSI CLEAR SCREEN + ; +ED: CALL GetNumber + OR A + JP Z,ED1 ; Zero means first option + CP 254 ; Also default + JP Z,ED1 + CP 255 + JP Z,ED1 + CP 1 + JP Z,ED2 + CP 2 + JP NZ,ANSIEXIT + + ;*** Option 2 + ; +ED3: LD HL,0 + LD (DSPXY),HL ; Home the cursor + LD A,(JSW_FF) + OR A + JP NZ,ED_Set_LF + CALL CALCSCADDR + CALL CLRSCRN + JP ANSIEXIT + +ED_Set_LF: XOR A ; Note simply so that + LD (JSW_LF),A ; ESC[2J works the same as CTRL-L + JP ANSIEXIT + + ;*** Option 0 + ; +ED1: LD HL,(DSPXY) ; Get and save cursor position + LD A,H + OR L + JP Z,ED3 ; If we are at the top of the + ; screen and clearing to the bottom + ; then we are clearing all the screen! + PUSH HL + LD A,ROW-1 + SUB H ; ROW - Row + LD HL,0 ; Zero start + OR A ; Do we have any lines to add? + JR Z,ED1_2 ; If no bypass that addition! + LD B,A ; Number of lines to count + LD DE,80 +ED1_1: ADD HL,DE + DJNZ ED1_1 +ED1_2: EX DE,HL ; Value into DE + POP HL + LD A,80 + SUB L ; 80 - Columns + LD L,A ; Add to value before + LD H,0 + ADD HL,DE + PUSH HL ; Value saved for later + LD HL,(DSPXY) ; _that_ value again! + POP BC ; Number to blank + CALL CALCSCADDR + CALL CLRSCRN ; Now do it! + JP ANSIEXIT ; Then exit properly + + ;*** Option 1 - clear from cursor to beginning of screen + ; +ED2: LD HL,(DSPXY) ; Get and save cursor position + PUSH HL + LD A,H + LD HL,0 ; Zero start + OR A ; Do we have any lines to add? + JR Z,ED2_2 ; If no bypass that addition! + LD B,A ; Number of lines + LD DE,80 +ED2_1: ADD HL,DE + DJNZ ED2_1 +ED2_2: EX DE,HL ; Value into DE + POP HL + LD H,0 + ADD HL,DE + PUSH HL ; Value saved for later + LD HL,0 ; Find the begining! + POP BC ; Number to blank + CALL CLRSCRN ; Now do it! + JP ANSIEXIT ; Then exit properly + + ; *** ANSI CLEAR LINE + ; +EL: CALL GetNumber ; Get value + CP 0 + JP Z,EL1 ; Zero & Default are the same + CP 255 + JP Z,EL1 + CP 254 + JP Z,EL1 + CP 1 + JP Z,EL2 + CP 2 + JP NZ,ANSIEXIT ; Otherwise don't do a thing + + ;*** Option 2 - clear entire line. + ; + LD HL,(DSPXY) + LD L,0 + LD (DSPXY),HL + CALL CALCSCADDR + LD BC,80 ; 80 bytes to clear (whole line) + CALL CLRSCRN + JP ANSIEXIT + + ;*** Option 0 - Clear from Cursor to end of line. + ; +EL1: LD HL,(DSPXY) + LD A,80 ; Calculate distance to end of line + SUB L + LD C,A + LD B,0 + LD (DSPXY),HL + PUSH HL + POP DE + CALL CALCSCADDR + CALL CLRSCRN + JP ANSIEXIT + + ;*** Option 1 - clear from cursor to beginning of line. + ; +EL2: LD HL,(DSPXY) + LD C,L ; BC = distance from start of line + LD B,0 + LD L,0 + LD (DSPXY),HL + CALL CALCSCADDR + CALL CLRSCRN + JP ANSIEXIT + + ; In HL = XY Pos + ; Out = Screen address. +CALCSCADDR: PUSH AF + PUSH BC + PUSH DE + PUSH HL + LD A,H + LD B,H + LD C,L + LD HL,SCRN + OR A + JR Z,CALC3 + LD DE,80 +CALC2: ADD HL,DE + DJNZ CALC2 +CALC3: POP DE + ADD HL,BC + POP DE + POP BC + POP AF + RET + + ; HL = address + ; BC = length +CLRSCRN: DI + ; +MEMSW6: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_0 ; Enable access to the hardware by paging out the upper bank. + OUT (MMCFG),A + ENDIF + + LD (HLSAVE),HL ; 1 for later! + LD D,H + LD E,L + INC DE ; DE <- HL +1 + LD (BCSAVE),BC ; Save the value a little longer! + XOR A + LD (HL), A ; Blank this area! + LDIR ; *** just like magic *** + ; only I forgot it in 22a! + LD BC,(BCSAVE) ; Restore values + LD HL,(HLSAVE) + LD DE,2048 ; Move to attributes block + ADD HL,DE + LD D,H + LD E,L + INC DE ; DE = HL + 1 + LD A,(FONTSET) ; Save in the current values. + LD (HL),A + LDIR + +MEMSW7: IF BUILD_TZFS = 1 + LD A,TZMM_MZ700_2 ; Enable access to the hardware by paging out the upper bank. + OUT (MMCFG),A + ENDIF + ; + EI + RET + + ;*** ANSI SET GRAPHICS RENDITION + ; +SGR: CALL GetNumber + CP 254 ; 254 signifies end of sequence + JP Z,ANSIEXIT + OR A + CALL Z,AllOff + CP 255 ; Default means all off + CALL Z,AllOff + CP 1 + CALL Z,BoldOn + CP 2 + CALL Z,BoldOff + CP 4 + CALL Z,UnderOn + CP 5 + CALL Z,ItalicOn + CP 6 + CALL Z,ItalicOn + CP 7 + CALL Z,InverseOn + JP SGR ; Code is re-entrant + + ;-------------------------------- + ; + ; RESET GRAPHICS + ; + ; Entry - None + ; Exit - None + ; Used - None + ;-------------------------------- +AllOff: PUSH AF ; Save registers + LD A,0C9h ; = off + LD (BOLDMODE),A ; Turn the flags off + LD (ITALICMODE),A + LD (UNDERSCMODE),A + LD (INVMODE),A + LD A,007h ; Black background, white chars. + LD (FONTSET),A ; Reset the bit map store + POP AF ; Restore register + RET + + ;-------------------------------- + ; + ; TURN BOLD ON + ; + ; Entry - None + ; Exit - None + ; Used - None + ;-------------------------------- +BoldOn: PUSH AF ; Save register + XOR A ; 0 means on + LD (BOLDMODE),A +BOn1: LD A,(FONTSET) + SET 0,A ; turn ON indicator flag + LD (FONTSET),A + POP AF ; Restore register + RET + + ;-------------------------------- + ; + ; TURN BOLD OFF + ; + ; Entry - None + ; Exit - None + ; Used - None + ;-------------------------------- +BoldOff: PUSH AF ; Save register + PUSH BC + LD A,0C9h ; &C9 means off + LD (BOLDMODE),A +BO1: LD A,(FONTSET) + RES 0,A ; turn OFF indicator flag + LD (FONTSET),A + POP BC + POP AF ; Restore register + RET + + ;-------------------------------- + ; + ; TURN ITALICS ON + ; (replaces flashing) + ; Entry - None + ; Exit - None + ; Used - None + ;-------------------------------- +ItalicOn: PUSH AF ; Save AF + XOR A + LD (ITALICMODE),A ; 0 means on + LD A,(FONTSET) + SET 1,A ; turn ON indicator flag + LD (FONTSET),A + POP AF ; Restore register + RET + + ;-------------------------------- + ; + ; TURN UNDERLINE ON + ; + ; Entry - None + ; Exit - None + ; Used - None + ;-------------------------------- +UnderOn: PUSH AF ; Save register + XOR A ; 0 means on + LD (UNDERSCMODE),A + LD A,(FONTSET) + SET 2,A ; turn ON indicator flag + LD (FONTSET),A + POP AF ; Restore register + RET + + ;-------------------------------- + ; + ; TURN INVERSE ON + ; + ; Entry - None + ; Exit - None + ; Used - None + ;-------------------------------- +InverseOn: PUSH AF ; Save register + XOR A ; 0 means on + LD (INVMODE),A + LD A,(FONTSET) + SET 3,A ; turn ON indicator flag + LD (FONTSET),A + POP AF ; Restore AF + RET + + ;*** ANSI SAVE CURSOR POSITION + ; +SCP: LD HL,(DSPXY) ; (backup) <- (current) + LD (CURSORPSAV),HL + JP ANSIEXIT + + ;*** ANSI RESTORE CURSOR POSITION + ; +RCP: LD HL,(CURSORPSAV) ; (current) <- (backup) + LD (DSPXY),HL + JP ANSIEXIT + + + ; Control variables for the Ansi Emulator. Inline with the code as this module + ; is a build time include and the target for execution is RAM. + ; +CURSORPSAV DS 2, 0 ; Cursor save position;default 0,0 +HAVELOADED DS 1, 0 ; To show that a value has been put in for Ansi emualtor. +ANSIFIRST DS 1, 0 ; Holds first character of Ansi sequence +NUMBERBUF DS 20, 0 ; Buffer for numbers in Ansi +NUMBERPOS DW 1, NUMBERBUF ; Address within buffer +CHARACTERNO DS 1, 0 ; Byte within Ansi sequence. 0=first,255=other +CURSORCOUNT DS 1, 0 ; 1/50ths of a second since last change +FONTSET DS 1, 017H ; Ansi font setup - Blue background White Foreground as default. +JSW_FF DS 1, 0 ; Byte value to turn on/off FF routine +JSW_LF DS 1, 0 ; Byte value to turn on/off LF routine +CHARACTER DS 1, 0 ; To buffer character to be printed. +CURSORPOS DS 2, 0 ; Cursor position, default 0,0. +BOLDMODE DS 1, 0 +HIBRITEMODE DS 1, 0 ; 0 means on, &C9 means off +UNDERSCMODE DS 1, 0 +ITALICMODE DS 1, 0 +INVMODE DS 1, 0 +CHGCURSMODE DS 1, 0 +ANSIMODE DS 1, 0 ; 1 = on, 0 = off +BCSAVE DW 1, 0 ; Register save for when stack is not paged in. +DESAVE DW 1, 0 +HLSAVE DW 1, 0 +COLOUR EQU 0 + + ENDIF + ;------------------------------------------------------------------------------- + ; END OF ANSI TERMINAL FUNCTIONALITY + ;------------------------------------------------------------------------------- + + +REBOOT: DI + LD A,TZMM_TZFS + OUT (MMCFG),A + JP 0000H ; Now restart in the SA1510 monitor. + + ;------------------------------------------------------------------------------- + ; START OF STATIC LOOKUP TABLES AND CONSTANTS + ;------------------------------------------------------------------------------- + + ;-------------------------------------- + ; Test Message table + ;-------------------------------------- + +BFREE: DB " Bytes free",CR,LF,0,0 + +SIGNON: DB "Z80 BASIC Ver 4.7b",CR,LF + DB "Copyright ",40,"C",41 + DB " 1978 by Microsoft",CR,LF,0,0 + +SDAVAIL: DB "SD", NUL +FDCAVAIL: DB "FDC", NUL +NOBDOS: DB "I/O Processor failed to load BDOS, aborting!", CR, LF, NUL +SVCRESPERR: DB "I/O Response Error, time out!", CR, NUL +SVCIOERR: DB "I/O Error, time out!", CR, NUL +BADFN: DB "Filename missing!", 0, 0, 0 +FNTOOG: DB "Filename too long!", 0, 0, 0 +PHYERR: DB "SD/K64F IO error!", 0, 0, 0 +LOADERR: DB "File loading error!", 0, 0, 0 +SAVEERR: DB "File save error!", 0, 0, 0 +CREATER: DB "File create error!", 0, 0, 0 +CLOSEER: DB "File close error!", 0, 0, 0 +WRITEER: DB "File write error!", 0, 0, 0 +OPENER: DB "File open error!", 0, 0, 0 +READER: DB "File read error!", 0, 0, 0 + + ;------------------------------------------------------------------------------- + ; END OF STATIC LOOKUP TABLES AND CONSTANTS + ;------------------------------------------------------------------------------- + + ;------------------------------------------------------------------------------- + ; START OF DEBUGGING FUNCTIONALITY + ;------------------------------------------------------------------------------- + ; Debug routine to print out all registers and dump a section of memory for analysis. + ; +DEBUG: IF ENADEBUG = 1 + LD (DBGSTACKP),SP + LD SP,DBGSTACK + ; + PUSH AF + PUSH BC + PUSH DE + PUSH HL + ; + PUSH AF + PUSH HL + PUSH DE + PUSH BC + PUSH AF + LD DE, INFOMSG + CALL MONPRTSTR + POP BC + LD A,B + CALL PRTHX + LD A,C + CALL PRTHX + LD DE, INFOMSG2 + CALL MONPRTSTR + POP BC + LD A,B + CALL PRTHX + LD A,C + CALL PRTHX + LD DE, INFOMSG3 + CALL MONPRTSTR + POP DE + LD A,D + CALL PRTHX + LD A,E + CALL PRTHX + LD DE, INFOMSG4 + CALL MONPRTSTR + POP HL + LD A,H + CALL PRTHX + LD A,L + CALL PRTHX + LD DE, INFOMSG5 + CALL MONPRTSTR + LD HL,(DBGSTACKP) + LD A,H + CALL PRTHX + LD A,L + CALL PRTHX + CALL NL + + POP AF + JR C, SKIPDUMP + ; + LD HL,04000H ; WRKSPC ; Dump the startup vectors. + LD DE, 1000H + ADD HL, DE + EX DE,HL + LD HL,WRKSPC + CALL DUMPX + + LD HL,00000h ; Dump the startup vectors. + LD DE, 00A0H + ADD HL, DE + EX DE,HL + LD HL,00000h + CALL DUMPX + + LD HL,IBUFE ; Dump the data area. + LD DE, 0300H + ADD HL, DE + EX DE,HL + LD HL,IBUFE + CALL DUMPX + +SKIPDUMP: ;JR SKIPDUMP + POP HL + POP DE + POP BC + POP AF + ; + LD SP,(DBGSTACKP) + RET + + ; HL = Start + ; DE = End +DUMPX: LD A,10 +DUM1: LD (TMPCNT),A +DUM3: LD B,010h + LD C,02Fh + CALL NLPHL +DUM2: CALL SPHEX + INC HL + PUSH AF + LD A,(DSPXY) + ADD A,C + LD (DSPXY),A + POP AF + CP 020h + JR NC,L0D51 + LD A,02Eh +L0D51: CALL PRNT + LD A,(DSPXY) + INC C + SUB C + LD (DSPXY),A + DEC C + DEC C + DEC C + PUSH HL + SBC HL,DE + POP HL + JR NC,DUM7 +L0D78: DJNZ DUM2 + LD A,(TMPCNT) + DEC A + LD (TMPCNT),A + JR NZ,DUM3 +DUM4: CALL CHKKY + CP 0FFH + JR NZ,DUM4 + CALL GETKY + CP 'D' + JR NZ,DUM5 + LD A,8 + JR DUM1 +DUM5: CP 'U' + JR NZ,DUM6 + PUSH DE + LD DE,00100H + OR A + SBC HL,DE + POP DE + LD A,8 + JR DUM1 +DUM6: CP 'X' + JR Z,DUM7 + JR DUMPX +DUM7: CALL NL + RET + +NLPHL: CALL NL + CALL PRTHL + RET + + ; SPACE PRINT AND DISP ACC + ; INPUT:HL=DISP. ADR. +SPHEX: CALL PRTS ; SPACE PRINT + LD A,(HL) + CALL PRTHX ; DSP OF ACC (ASCII) + LD A,(HL) + RET + + ; Debugger messages, bit cryptic but this is due to limited space on the screen. + ; +INFOMSG: DB "AF=", NUL +INFOMSG2: DB ",BC=", 000H +INFOMSG3: DB ",DE=", 000H +INFOMSG4: DB ",HL=", 000H +INFOMSG5: DB ",SP=", 000H + + ; Seperate stack for the debugger so as not to affect anything it is reporting on. + ; +TMPCNT DS virtual 2 ; TEMPORARY COUNTER +DBGSTACKP: DS 2 + DS 128, 000H +DBGSTACK: EQU $ + + ENDIF + ;------------------------------------------------------------------------------- + ; END OF DEBUGGING FUNCTIONALITY + ;------------------------------------------------------------------------------- +CODEEND: + + ;------------------------------------------------------------------------------- + ; BASIC RELOCATION + ;------------------------------------------------------------------------------- + + ; For TZFS builds the image needs to be relocated from 0x1200 to 0x0000 on startup after switching the memory mode. +RELOCSTART: IF BUILD_TZFS = 1 + ORG $ + 1200H + + ; Swtch memory. +RELOC: LD A, TZMM_MZ700_0 ; Switch to the MZ700 memory map where the lower 4K 0000:0FFF is in block 6, we therefore preserve the Monitor for exit. + OUT (MMCFG),A + + ; Move the image down and start. + LD DE, 0000H + LD HL, 01200H + LD BC, CODEEND - CODESTART + LDIR + JP 0000H +RELOCEND: ENDIF + + + ; Variables start at the end of the code in the running image (not relocatable image). + ORG CODEEND +GVARSTART EQU $ ; Start of variables. + + ; Pad out so that the keyboard buffer is aligned on a 256 byte block boundary. + ALIGN ($ + 0100H) & 0FF00H + +KEYBUF: DS virtual KEYBUFSIZE ; Interrupt driven keyboard buffer. +KEYCOUNT: DS virtual 1 +KEYWRITE: DS virtual 2 ; Pointer into the buffer where the next character should be placed. +KEYREAD: DS virtual 2 ; Pointer into the buffer where the next character can be read. +KEYLAST: DS virtual 1 ; Last key value +KEYRPT: DS virtual 1 ; Key repeat counter + + +SPV: +IBUFE: ; TAPE BUFFER (128 BYTES) +ATRB: DS virtual 1 ; ATTRIBUTE +NAME: DS virtual 17 ; FILE NAME +SIZE: DS virtual 2 ; BYTESIZE +DTADR: DS virtual 2 ; DATA ADDRESS +EXADR: DS virtual 2 ; EXECUTION ADDRESS +COMNT: DS virtual 92 ; Comment / code area of CMT header. +SWPW: DS virtual 10 ; SWEEP WORK +KDATW: DS virtual 2 ; KEY WORK +KANAF: DS virtual 1 ; KANA FLAG (01=GRAPHIC MODE) +DSPXY: DS virtual 2 ; DISPLAY COORDINATES +MANG: DS virtual 6 ; COLUMN MANAGEMENT +MANGE: DS virtual 1 ; COLUMN MANAGEMENT END +PBIAS: DS virtual 1 ; PAGE BIAS +ROLTOP: DS virtual 1 ; ROLL TOP BIAS +MGPNT: DS virtual 1 ; COLUMN MANAG. POINTER +PAGETP: DS virtual 2 ; PAGE TOP +ROLEND: DS virtual 1 ; ROLL END + DS virtual 14 ; BIAS +FLASH: DS virtual 1 ; FLASHING DATA +SFTLK: DS virtual 1 ; SHIFT LOCK +REVFLG: DS virtual 1 ; REVERSE FLAG +FLSDT: DS virtual 1 ; CURSOR DATA +STRGF: DS virtual 1 ; STRING FLAG +DPRNT: DS virtual 1 ; TAB COUNTER +SWRK: DS virtual 1 ; KEY SOUND FLAG +TEMPW: DS virtual 1 ; TEMPO WORK +ONTYO: DS virtual 1 ; ONTYO WORK +OCTV: DS virtual 1 ; OCTAVE WORK +RATIO: DS virtual 2 ; ONPU RATIO +DSPXYADDR: DS virtual 2 ; Address of last known position. + +FLASHCTL: DS virtual 1 ; CURSOR FLASH CONTROL. BIT 0 = Cursor On/Off, BIT 1 = Cursor displayed. +TIMESEC: DS virtual 6 ; RTC 48bit TIME IN MILLISECONDS +; +TPFLAG DS virtual 1 +SECTPOS DS virtual 2 + +SPISRSAVE: DS virtual 2 + ; Stack space for the Interrupt Service Routine. + DS virtual 32 ; Max 8 stack pushes. +ISRSTACK EQU $ +STACKE: EQU $ + DS virtual 128 +STACK: EQU $ + + +WRKSPC DS virtual 3 ; 0 BASIC Work space +USR DS virtual 3 ; 3H "USR (x)" jump +OUTSUB DS virtual 1 ; 6H "OUT p,n" +OTPORT DS virtual 2 ; 7H Port (p) +DIVSUP DS virtual 1 ; 9H Division support routine +DIV1 DS virtual 4 ; 0AH <- Values +DIV2 DS virtual 4 ; 0EH <- to +DIV3 DS virtual 3 ; 12H <- be +DIV4 DS virtual 2 ; 15H <-inserted +SEED DS virtual 35 ; 17H Random number seed +LSTRND DS virtual 4 ; 3AH Last random number +INPSUB DS virtual 1 ; 3EH #INP (x)" Routine +INPORT DS virtual 2 ; 3FH PORT (x) +NULLS DS virtual 1 ; 41H Number of nulls +LWIDTH DS virtual 1 ; 42H Terminal width +COMMAN DS virtual 1 ; 43H Width for commas +NULFLG DS virtual 1 ; 44H Null after input byte flag +CTLOFG DS virtual 1 ; 45H Control "O" flag +LINESC DS virtual 2 ; 46H Lines counter +LINESN DS virtual 2 ; 48H Lines number +CHKSUM DS virtual 2 ; 4AH Array load/save check sum +NMIFLG DS virtual 1 ; 4CH Flag for NMI break routine +BRKFLG DS virtual 1 ; 4DH Break flag +RINPUT DS virtual 3 ; 4EH Input reflection +POINT DS virtual 3 ; 51H "POINT" reflection (unused) +PSET DS virtual 3 ; 54H "SET" reflection +RESET DS virtual 3 ; 57H "RESET" reflection +STRSPC DS virtual 2 ; 5AH Bottom of string space +LINEAT DS virtual 2 ; 5CH Current line number +BASTXT DS virtual 3 ; 5EH Pointer to start of program +BUFFER DS virtual 5 ; 61H Input buffer +STACKI DS virtual 69 ; 66H Initial stack +CURPOS DS virtual 1 ; 0ABH Character position on line +LCRFLG DS virtual 1 ; 0ACH Locate/Create flag +TYPE DS virtual 1 ; 0ADH Data type flag +DATFLG DS virtual 1 ; 0AEH Literal statement flag +LSTRAM DS virtual 2 ; 0AFH Last available RAM +TMSTPT DS virtual 2 ; 0B1H Temporary string pointer +TMSTPL DS virtual 12 ; 0B3H Temporary string pool +TMPSTR DS virtual 4 ; 0BFH Temporary string +STRBOT DS virtual 2 ; 0C3H Bottom of string space +CUROPR DS virtual 2 ; 0C5H Current operator in EVAL +LOOPST DS virtual 2 ; 0C7H First statement of loop +DATLIN DS virtual 2 ; 0C9H Line of current DATA item +FORFLG DS virtual 1 ; 0CBH "FOR" loop flag +LSTBIN DS virtual 1 ; 0CCH Last byte entered +READFG DS virtual 1 ; 0CDH Read/Input flag +BRKLIN DS virtual 2 ; 0CEH Line of break +NXTOPR DS virtual 2 ; 0D0H Next operator in EVAL +ERRLIN DS virtual 2 ; 0D2H Line of error +CONTAD DS virtual 2 ; 0D4H Where to CONTinue +PROGND DS virtual 2 ; 0D6H End of program +VAREND DS virtual 2 ; 0D8H End of variables +ARREND DS virtual 2 ; 0DAH End of arrays +NXTDAT DS virtual 2 ; 0DCH Next data item +FNRGNM DS virtual 2 ; 0DEH Name of FN argument +FNARG DS virtual 4 ; 0E0H FN argument value +FPREG DS virtual 3 ; 0E4H Floating point register +FPEXP DS virtual 1 ; FPREG+3 Floating point exponent +SGNRES DS virtual 1 ; 0E8H Sign of result +PBUFF DS virtual 13 ; 0E9H Number print buffer +MULVAL DS virtual 3 ; 0F6H Multiplier +PROGST DS virtual 100 ; 0F9H Start of program text area +STLOOK DS virtual 1 ; 15DH Start of memory test + +GVAREND EQU $ ; End of variables diff --git a/software/asm/asm.asm b/software/asm/asm.asm new file mode 100644 index 0000000..4ba5008 --- /dev/null +++ b/software/asm/asm.asm @@ -0,0 +1,2298 @@ +; Digital Research ASM assembler +; disassembled by Larry A. Greene +; got any comments or suggestions? +; send to greenela@clear.lakes.com + +; using command ASM TEST.ABC will assemble TEST.ASM with drive designations +; following period. A=ASM file drive, B=HEX file drive, C=SYM file drive + + ORG 0100H + +H0000 EQU 0000H ;cold re-entry to system +H0005 EQU 0005H ;BDOS +H005C EQU 005CH ;FCB +H0080 EQU 0080H ;DMA + + LD SP,H0200 ;set stack + LD HL,(H0005+1) + LD (H01CD),HL ;set end of memory = BDOS base + JP H0200 +H010C: DB ' ' ;120 byte line buffer for PRN output +H010D: DB 'C' ;if H010C is non-space then contains error code: + ;B = unknown + ;C = comma missing + ;D = not an 8 bit value for DB label expression + ;E = bad register syntax + ;L = bad mnemonic + ;N = function not supported + ;O = unknown (some form of syntax error) + ;P = duplicate label or phase error + ;R = wrong register + ;S = syntax error + ;U = unclained label + ;V = bad value +H010E: DB "OPY" +H0111: DB 'R' +H0112: DB "IGHT(C) 1978, DIGITAL RESEARCH " + DS 53H +H0184: DS 01H ;index into H010C PRN buffer +H0185: DS 01H ;char type. 4=EOL 3=literal 2=digit 1=alpha +H0186: DS 02H ;holds value of numeric expression from H1106 call +H0188: DS 01H ;index into H0189 ASM buffer +H0189: DS 01H ;64 byte ASM line buffer +H018A: DS 01H +H018B: DS 3EH +H01C9: DS 02H +H01CB: DW H20F0 ;contains end of symbol table +H01CD: DS 02H ;contains BDOS base (end of memory space) +H01CF: DS 01H ;assembly pass count 0=build symbol table 1=table done +H01D0: DS 02H ;address counter (for HEX file also) +H01D2: DS 02H ;address printed at start of line in PRN file +H01D4: DW H20F0 ;start of symbol table (fixed) +H01D6: DS 2AH ;stack space below H0200 +H0200: JP H0CE0 ;cold start +H0203: JP H0DA1 ;open ASM file +H0206: JP H0DCA ;get char from H029D ASM file buffer. + ;reads disk as needed. + JP H0E34 ;write byte in ACC reg to PRN file. all regs preserved + JP H0EAA ;write ACC reg to HEX file (direct - after processed) + JP H0EDE ;write ACC reg to console +H0212: JP H0CBC ;print string at (HL). terminates with cr +H0215: JP H0F00 ;print H010C line buffer to PRN file w/echo to console +H0218: JP H0F2F ;put error code from ACC reg into H010C flag +H021B: JP H104C ;write byte in ACC reg to HEX file in ASCII form +H021E: JP H0F39 ;close files and exit +H0221: DS 02H ;HEX file pointer (base address of line) +H0223: DS 01H ;index into line of H0224 +H0224: DS 10H ;obj code line buffer for PRN and HEX use +H0234: DS 01H ;current disk +H0235: DS 01H ;ASM file drive designation +H0236: DS 01H ;PRN file drive designation +H0237: DS 01H ;HEX file drive designation +H0238: DS 9 ;ASM filename + DB "ASM" +H0244: DS 14H +H0258: DS 01H ;PRN filename +H0259: DS 9 + DB "PRN" + DS 15H +H027A: DS 9 ;HEX filename + DB "HEX" + DS 15H +H029B: DS 02H ;index into H029D buffer +H029D: DS 400H ;buffer for ASM file read +H069D: DS 02H ;index into H069F buffer +H069F: DS 300H ;buffer for PRN file write +H099F: DS 02H ;index into H09A1 buffer +H09A1: DS 300H ;buffer for HEX file write +H0CA1: LD HL,H0234 ;select drive in ACC reg and make it the current drive + CP (HL) + RET Z + LD (HL),A + LD E,A + LD C,0EH + CALL H0005 + RET +H0CAE: INC HL + LD A,(HL) + CP 20H + JP Z,H0CB8 + SBC A,41H + RET +H0CB8: LD A,(H0234) + RET +H0CBC: LD A,(HL) ;print string at (HL). terminate w/cr + CALL H0EDE + LD A,(HL) + INC HL + CP 0DH + JP NZ,H0CBC + LD A,0AH + CALL H0EDE + RET +H0CCD: LD DE,H005C ;move 9 bytes from FCB to (HL) + LD B,09H ;error exit if '?' found +H0CD2: LD A,(DE) + CP 3FH + JP Z,H0DBB + LD (HL),A + INC HL + INC DE + DEC B + JP NZ,H0CD2 + RET +H0CE0: LD HL,H0FA0 ;cold start + CALL H0CBC ;print title + JP H0D3F +H0CE9: LD C,0FH ;open file + CALL H0005 + CP 0FFH + RET NZ + LD HL,H0FB9 + CALL H0CBC + JP H0000 +H0CFA: LD C,10H ;close file + CALL H0005 + CP 0FFH + RET NZ + LD HL,H1029 + CALL H0CBC + JP H0000 +H0D0B: LD C,13H ;delete file. (DE) = FCB + JP H0005 +H0D10: LD C,16H ;make file. (DE) = FCB + CALL H0005 ;error exit if disk full + CP 0FFH + RET NZ + LD HL,H0FD0 + CALL H0CBC + JP H0000 +H0D21: LD A,(H0235) ;select ASM file drive + CALL H0CA1 + RET +H0D28: LD A,(H0236) + CP 19H + RET Z + CP 17H + RET +H0D31: LD A,(H0236) ;select PRN file drive + CALL H0CA1 + RET +H0D38: LD A,(H0237) ;select HEX file drive + CALL H0CA1 + RET +H0D3F: LD A,(H005C) ;drive designation + CP 20H + JP Z,H0DBB ;error exit + LD C,19H + CALL H0005 ;get current disk + LD (H0234),A + LD HL,0064H ;get optional drive designations following '.' + CALL H0CAE ;after filename else use current drive + LD (H0235),A + CALL H0CAE + LD (H0237),A + CALL H0CAE + LD (H0236),A + LD HL,H0238 ;ASM filename + CALL H0CCD ;move filename + CALL H0D28 + JP Z,H0D83 + LD HL,H0259 + PUSH HL + PUSH HL + CALL H0CCD + CALL H0D31 ;select PRN file drive + POP DE + CALL H0D0B ;delete old PRN file + POP DE + CALL H0D10 ;make new PRN file +H0D83: LD A,(H0237) + CP 19H + JP Z,H0D9E + LD HL,H027A + PUSH HL + PUSH HL + CALL H0CCD + CALL H0D38 ;select HEX file drive + POP DE + CALL H0D0B ;delete old HEX file + POP DE + CALL H0D10 ;make new HEX file +H0D9E: JP H1100 ;enter assembler with HEX and PRN files open +H0DA1: LD HL,0400H ;open ASM file. force reading of first byte + LD (H029B),HL ;of ASM file by setting index to EOF + XOR A + LD (H0244),A + LD (H0258),A + LD (H0223),A + CALL H0D21 + LD DE,H0238 + CALL H0CE9 + RET +H0DBB: LD HL,H0FE3 ; 'source filename error' exit + CALL H0CBC + JP H0000 +H0DC4: LD A,D + CP H + RET NZ + LD A,E + CP L + RET +H0DCA: PUSH BC ;get char from ASM file + PUSH DE + PUSH HL + LD HL,(H029B) + LD DE,0400H + CALL H0DC4 + JP NZ,H0E19 + CALL H0D21 + LD HL,0000H + LD (H029B),HL + LD B,08H + LD HL,H029D +H0DE7: PUSH BC + PUSH HL + LD C,14H + LD DE,H0238 + CALL H0005 + POP HL + POP BC + OR A + LD C,80H + JP NZ,H0E0D + LD DE,H0080 + LD C,80H ;extra code not needed (see 3 lines previous) +H0DFE: LD A,(DE) + LD (HL),A + INC DE + INC HL + DEC C + JP NZ,H0DFE + DEC B + JP NZ,H0DE7 + JP H0E19 +H0E0D: CP 03H + JP NC,H0E2B +H0E12: LD (HL),1AH + INC HL + DEC C + JP NZ,H0E12 +H0E19: LD DE,H029D + LD HL,(H029B) + PUSH HL + INC HL + LD (H029B),HL + POP HL + ADD HL,DE + LD A,(HL) + POP HL + POP DE + POP BC + RET +H0E2B: LD HL,H0FFA ; 'source file read error' exit + CALL H0CBC + JP H0000 +H0E34: PUSH BC ;output char in ACC reg to PRN designation: + LD B,A ;Z = null, X = console, else to H069F buffer + LD A,(H0236) ;and write to disk as needed + CP 19H ; 'Z' + JP Z,H0E51 + CP 17H ; 'X' + LD A,B + JP NZ,H0E4A + CALL H0EDE ;write to console + JP H0E51 +H0E4A: PUSH DE + PUSH HL + CALL H0E53 + POP HL + POP DE +H0E51: POP BC + RET +H0E53: LD HL,(H069D) ;write byte to PRN file + EX DE,HL + LD HL,H069F + ADD HL,DE + LD (HL),A + EX DE,HL + INC HL + LD (H069D),HL + EX DE,HL + LD HL,0300H + CALL H0DC4 + RET NZ + CALL H0D31 + LD HL,0000H + LD (H069D),HL + LD HL,H069F + LD DE,H0259 + LD B,06H ;6 times 80H = 300H +H0E7A: LD A,(HL) ;write HEX file comes here + CP 1AH + RET Z + PUSH BC + PUSH DE + LD C,80H + LD DE,H0080 +H0E85: LD A,(HL) + LD (DE),A + INC HL + INC DE + DEC C + JP NZ,H0E85 + POP DE + PUSH DE + PUSH HL + LD C,15H ;write sequential + CALL H0005 + POP HL + POP DE + POP BC + OR A + JP NZ,H0EA1 + DEC B + RET Z + JP H0E7A +H0EA1: LD HL,H1011 + CALL H0CBC + JP H0F77 +H0EAA: PUSH BC ;write ACC to HEX file with disk buffering + PUSH DE + PUSH HL + CALL H0EB4 + POP HL + POP DE + POP BC + RET +H0EB4: LD HL,(H099F) + EX DE,HL + LD HL,H09A1 + ADD HL,DE + LD (HL),A + EX DE,HL + INC HL + LD (H099F),HL + EX DE,HL + LD HL,0300H + CALL H0DC4 ;compare DE and HL - buffer full? + RET NZ ;no + CALL H0D38 ;select HEX file drive + LD HL,0000H + LD (H099F),HL + LD HL,H09A1 + LD DE,H027A + LD B,06H + JP H0E7A +H0EDE: PUSH BC ;write ACC reg to console + PUSH DE + PUSH HL + LD C,02H + LD E,A + CALL H0005 + POP HL + POP DE + POP BC + RET +H0EEB: LD C,A ;write ACC reg to PRN designation. echo error + CALL H0E34 ;to console if H010C is non-space + LD A,(H010C) + CP 20H + RET Z + LD A,(H0236) + CP 17H + RET Z + LD A,C + CALL H0EDE ;echo to console + RET +H0F00: LD A,(H0184) ;print H010C line buffer to PRN file with + LD HL,H010C ;echo to console. H0184 = # of chars in line +H0F06: OR A + JP Z,H0F15 + LD B,A + LD A,(HL) + CALL H0EEB ;write byte w/echo + INC HL + LD A,B + DEC A + JP H0F06 +H0F15: LD (H0184),A ;write CR to PRN file then clear line buffer + LD A,0DH + CALL H0EEB + LD A,0AH + CALL H0EEB + LD HL,H010C + LD A,78H +H0F27: LD (HL),20H + INC HL + DEC A + JP NZ,H0F27 + RET +H0F2F: LD B,A + LD HL,H010C + LD A,(HL) + CP 20H + RET NZ + LD (HL),B + RET +H0F39: CALL H0D28 ;close files and exit + JP Z,H0F4F ;taken if no PRN file designated +H0F3F: LD HL,(H069D) + LD A,L + OR H + JP Z,H0F4F + LD A,1AH ;fill to end of buffer with ctrl-Z + CALL H0E34 + JP H0F3F +H0F4F: LD A,(H0237) + CP 19H + JP Z,H0F77 ;taken if no HEX file designated + LD A,(H0223) ;index + OR A + CALL NZ,H10B8 ;write final line to HEX file + LD HL,(H01D0) + LD (H0221),HL + CALL H10B8 ;write EOF address as data +H0F67: LD HL,(H099F) + LD A,L + OR H + JP Z,H0F77 + LD A,1AH + CALL H0EAA + JP H0F67 +H0F77: CALL H0D28 ;error in writing PRN or HEX file comes here + JP Z,H0F86 ;taken if no PRN file designation + CALL H0D31 ;select PRN file drive + LD DE,H0259 + CALL H0CFA ;close PRN file +H0F86: LD A,(H0237) ;check HEX designation + CP 19H + JP Z,H0F97 ;taken if no HEX file designation + CALL H0D38 ;select HEX file drive + LD DE,H027A + CALL H0CFA ;close HEX file +H0F97: LD HL,H103C + CALL H0CBC + JP H0000 +H0FA0: DB "CP/M ASSEMBLER - VER 2.0" + DB 0DH +H0FB9: DB "NO SOURCE FILE PRESENT" + DB 0DH +H0FD0: DB "NO DIRECTORY SPACE" + DB 0DH +H0FE3: DB "SOURCE FILE NAME ERROR" + DB 0DH +H0FFA: DB "SOURCE FILE READ ERROR" + DB 0DH +H1011: DB "OUTPUT FILE WRITE ERROR" + DB 0DH +H1029: DB "CANNOT CLOSE FILES" + DB 0DH +H103C: DB "END OF ASSEMBLY" + DB 0DH +H104C: PUSH BC ;write ACC reg to HEX file + LD B,A + LD A,(H0237) + CP 19H + LD A,B + JP Z,H1098 + PUSH DE + PUSH AF + LD HL,H0223 + LD A,(HL) + OR A + JP Z,H1084 + CP 10H + JP C,H106C + CALL H10B8 ;write complete line to HEX file. H0221 = addr + JP H1084 +H106C: LD HL,(H01D0) + EX DE,HL + LD HL,(H0221) ;if (H0221) + ACC = (H01D0) then jump to H108A + LD C,A ;else H1081 + LD B,00H + ADD HL,BC + LD A,E + CP L + JP NZ,H1081 + LD A,D + CP H + JP Z,H108A +H1081: CALL H10B8 ;write complete line to HEX file +H1084: LD HL,(H01D0) + LD (H0221),HL +H108A: LD HL,H0223 ;write ACC reg to H0224 obj buffer and + LD E,(HL) ;increment H0223 index + INC (HL) + LD D,00H + LD HL,H0224 + ADD HL,DE + POP AF + LD (HL),A + POP DE +H1098: POP BC + RET +H109A: PUSH AF ;write ACC reg to HEX file in HEX ASCII form + RRCA + RRCA + RRCA + RRCA + AND 0FH + CALL H10AF + POP AF + PUSH AF + AND 0FH + CALL H10AF + POP AF + ADD A,D + LD D,A ;keep running checksum for Intel HEX form + RET +H10AF: ADD A,90H + DAA + ADC A,40H + DAA + JP H0EAA +H10B8: LD A,3AH ;write complete line to HEX file + CALL H0EAA ;write ACC reg to HEX file + LD HL,H0223 + LD E,(HL) ;# of bytes to write + XOR A + LD D,A + LD (HL),A ;reset index to 0 + LD HL,(H0221) ;address of line in HEX file + LD A,E + CALL H109A + LD A,H ;write line address + CALL H109A + LD A,L + CALL H109A + XOR A + CALL H109A + LD A,E + OR A + JP Z,H10E8 + LD HL,H0224 +H10DF: LD A,(HL) + INC HL + CALL H109A + DEC E + JP NZ,H10DF +H10E8: XOR A + SUB D ;checksum + CALL H109A ;write checksum to HEX file + LD A,0DH + CALL H0EAA + LD A,0AH + CALL H0EAA + RET + DB 0,0,0,0,0,0,0,0 +H1100: JP H1340 ;enter assembler with PRN and HEX files open +H1103: JP H1132 ;output cr/lf to PRN file (clears line buffer) +H1106: JP H11C0 ;parse line up to non-alphanumeric char (EOL) + ;reading from ASM file as necessary. if char is + ;numeric then return value in H0186. if LF (0Ah) + ;found, will print line to PRN file with echo + ;to console on 2nd pass. +H1109: NOP ;previous char from H110A +H110A: NOP ;last char read from ASM file +H110B: NOP ;base 2,8,10 or 16 for numeric value +H110C: CALL H0206 ;get char from ASM file and store in + PUSH AF ;H010C PRN line buffer + CP 0DH + JP Z,H1130 + CP 0AH + JP Z,H1130 + LD A,(H0184) + CP 78H + JP NC,H1130 + LD E,A + LD D,00H + INC A + LD (H0184),A + LD HL,H010C + ADD HL,DE + POP AF ;restore char + LD (HL),A ;store in PRN line buffer + RET +H1130: POP AF ;restore char + RET +H1132: CALL H1149 ;print CR/LF to PRN file + LD (H110A),A + LD (H0184),A + LD A,0AH + LD (H1109),A + CALL H0215 ;print PRN line buffer + LD A,10H + LD (H0184),A ;index to label field + RET +H1149: XOR A + LD (H0188),A + LD (H110B),A + RET +H1151: LD HL,H0188 ;store char in H0189 buffer + LD A,(HL) + CP 40H + JP C,H115F + LD (HL),00H + CALL H131E +H115F: LD E,(HL) + LD D,00H + INC (HL) + INC HL + ADD HL,DE + LD A,(H110A) + LD (HL),A + RET +H116A: LD A,(HL) ;null out '$' at (HL) + CP 24H + RET NZ + XOR A + LD (HL),A + RET +H1171: LD A,(H110A) ;return z clear if '0-9' digit + SUB 30H + CP 0AH + RLA + AND 01H + RET +H117C: CALL H1171 ;return z clear if '0-9' or 'A-F' hex digit + RET NZ + LD A,(H110A) + SUB 41H + CP 06H ;A-F = 0-5. carry set if A-F + RLA ;carry to bit 0 + AND 01H ; =1 if A-F + RET +H118B: LD A,(H110A) ;return z clear if 'A-Z' alpha + SUB 41H + CP 1AH + RLA + AND 01H + RET +H1196: CALL H118B ;return z clear if 'A-Z' or '0-9' alphanumeric + RET NZ + CALL H1171 + RET +H119E: LD A,(H110A) + CP 61H + RET C + CP 7BH + RET NC + AND 5FH + LD (H110A),A + RET +H11AD: CALL H110C ;get char and store in PRN line buffer + LD (H110A),A ;save in last char + JP H132D ;go convert lower/upper conditionally + RET ;bogus +H11B7: CP 0DH + RET Z + CP 1AH + RET Z + CP 21H + RET +H11C0: XOR A ;parse line + LD (H0185),A ;clear char mode + CALL H1149 +H11C7: LD A,(H110A) ;each char loops here + CP 09H + JP Z,H11F4 + CP 3BH + JP Z,H11E1 + CP 2AH + JP NZ,H11ED + LD A,(H1109) + CP 0AH + JP NZ,H11ED +H11E1: CALL H11AD ;search ahead to EOL + CALL H11B7 + JP Z,H11FA + JP H11E1 +H11ED: OR 20H + CP 20H + JP NZ,H11FA +H11F4: CALL H11AD ;get next char + JP H11C7 ;loop for next char +H11FA: CALL H118B + JP Z,H1205 ;if not alpha + LD A,01H + JP H1239 +H1205: CALL H1171 + JP Z,H1210 ;if not digit + LD A,02H + JP H1239 +H1210: LD A,(H110A) + CP 27H ;single quote + JP NZ,H1221 + XOR A + LD (H110A),A + LD A,03H + JP H1239 +H1221: CP 0AH + JP NZ,H1237 + LD A,(H01CF) ;assembly pass count + OR A + CALL NZ,H0215 ;on 2nd pass print line to PRN file + LD HL,H010C + LD (HL),20H ;clear error char + LD A,10H + LD (H0184),A ;index to label field for PRN file +H1237: LD A,04H +H1239: LD (H0185),A +H123C: LD A,(H110A) ;last char + LD (H1109),A ;previous char + OR A + CALL NZ,H1151 ;store char in ASM buffer + CALL H11AD ;get char and store in PRN line buffer + LD A,(H0185) ;char mode + CP 04H ;EOL ? + RET Z + CP 03H ;literal? + CALL NZ,H119E ;convert lower to upper case if not in quotes + LD HL,H110A + LD A,(H0185) ;char mode + CP 01H ;alpha? + JP NZ,H126C + CALL H116A ;null out '$' from last char + JP Z,H123C ;taken if last char was '$' + CALL H1196 + RET Z ;taken if not alphanumeric + JP H123C +H126C: CP 02H + JP NZ,H1302 + CALL H116A + JP Z,H123C ;taken if '$' + CALL H117C + JP NZ,H123C ;taken if hex digit + LD A,(H110A) + CP 4FH ; 'O' octal + JP Z,H128A + CP 51H ; 'Q' octal + JP NZ,H128F +H128A: LD A,08H ;base 8 for octal + JP H1296 +H128F: CP 48H ; 'H' + JP NZ,H12A0 + LD A,10H ;base 16 hex for 'H' +H1296: LD (H110B),A + XOR A + LD (H110A),A + JP H12BB +H12A0: LD A,(H1109) + CP 42H ; 'B' binary + JP NZ,H12AD + LD A,02H ;base 2 for binary + JP H12B4 +H12AD: CP 44H ; 'D' decimal + LD A,0AH ; base 10 decimal (default) + JP NZ,H12B8 +H12B4: LD HL,H0188 ;index + DEC (HL) ;ignore trailing char +H12B8: LD (H110B),A ;set base +H12BB: LD HL,0000H + LD (H0186),HL + LD HL,H0188 + LD C,(HL) + INC HL +H12C6: LD A,(HL) + INC HL + CP 41H + JP NC,H12D2 + SUB 30H + JP H12D4 +H12D2: SUB 37H +H12D4: PUSH HL + PUSH BC + LD C,A + LD HL,H110B + CP (HL) + CALL NC,H1318 + LD B,00H + LD A,(HL) + LD HL,(H0186) + EX DE,HL + LD HL,0000H +H12E8: OR A + JP Z,H12F7 + RRA + JP NC,H12F1 + ADD HL,DE +H12F1: EX DE,HL + ADD HL,HL + EX DE,HL + JP H12E8 +H12F7: ADD HL,BC + LD (H0186),HL + POP BC + POP HL + DEC C + JP NZ,H12C6 + RET +H1302: LD A,(H110A) + CP 0DH + JP Z,H131E + CP 27H + JP NZ,H123C + CALL H11AD + CP 27H + RET NZ + JP H123C +H1318: PUSH AF ; 'V' bad value error. all regs preserved + LD A,56H + JP H1324 +H131E: PUSH AF ; 'O' error. all regs preserved + LD A,4FH + JP H1324 +H1324: PUSH BC + PUSH HL + CALL H0218 + POP HL + POP BC + POP AF + RET +H132D: PUSH AF ;convert lower to upper case if not in quotes + LD A,(H0185) ;char mode + CP 03H ;literal? + CALL NZ,H119E ;convert if not literal + POP AF + RET + DB 0,0,0,0,0,0,0,0 +H1340: JP H15A0 ;enter assembler with PRN and HEX files open +H1343: JP H145C ;clear H135B buffer +H1346: JP H149E ;using label in H0188 buffer, search for + ;duplicate label. return H01D6=0 if no duplicate + ;else H01D6 holds address of link field of dup. +H1349: JP H1498 ;ret dup label addr in HL. z-set if no dup +H134C: JP H14EB ;add symbol. see H14EB for more description +H134F: JP H1560 ;set nibble in symbol table at (H01D6) from +;ACC reg low nibble. when nibble designated by X is set then symbol has been +;assigned value. (H01D6): 00 00 X3 BDOS DW 0005 +H1352: JP H1572 ;get nibble from symbol table +H1355: JP H158D ;set value field of symbol at (H01D6) from HL +H1358: JP H1596 ;get value of symbol at (H01D6) into HL +H135B: DS 100H ;buffer table holds 16 bit values. offset into + ;table based on checksum of chars in label +H145B: DS 01H +H145C: LD HL,H135B + LD B,80H + XOR A +H1462: LD (HL),A + INC HL + LD (HL),A + INC HL + DEC B + JP NZ,H1462 + LD HL,0000H + LD (H01D6),HL + RET +H1471: LD HL,H0188 ;add all chars of label then mask bit 7 + LD B,(HL) + XOR A +H1476: INC HL + ADD A,(HL) + DEC B + JP NZ,H1476 + AND 7FH + LD (H145B),A + RET + LD B,A ;bogus code until H148E. image from addr 1566h + LD HL,(H01D6) + INC HL + INC HL + LD A,(HL) + AND 0F0H + OR B + LD (HL),A + RET +H148E: LD HL,(H01D6) ;get length of symbol table + INC HL + INC HL + LD A,(HL) + AND 0FH + INC A + RET +H1498: LD HL,(H01D6) + LD A,L + OR H + RET +H149E: CALL H1471 ;search for duplicate label. return H01D6=0 if + LD HL,H0188 ;no duplicate or pointing to link field before + LD A,(HL) ;duplicate + CP 11H + JP C,H14AC + LD (HL),10H ;16 chars max length of label +H14AC: LD HL,H145B + LD E,(HL) + LD D,00H + LD HL,H135B + ADD HL,DE + ADD HL,DE + LD E,(HL) + INC HL + LD H,(HL) + LD L,E +H14BB: LD (H01D6),HL + CALL H1498 + RET Z + CALL H148E + LD HL,H0188 + CP (HL) + JP NZ,H14E1 + LD B,A + INC HL + EX DE,HL + LD HL,(H01D6) + INC HL + INC HL + INC HL +H14D5: LD A,(DE) + CP (HL) + JP NZ,H14E1 + INC DE + INC HL + DEC B + JP NZ,H14D5 + RET +H14E1: LD HL,(H01D6) + LD E,(HL) + INC HL + LD D,(HL) + EX DE,HL + JP H14BB +H14EB: LD HL,H0188 ;add symbol from H0188 buffer to end of symbol + LD E,(HL) ;table at (H01CB) and zero value field + LD D,00H + LD HL,(H01CB) + LD (H01D6),HL + ADD HL,DE + LD DE,0005H + ADD HL,DE + EX DE,HL + LD HL,(H01CD) + LD A,E + SUB L + LD A,D + SBC A,H + EX DE,HL + JP NC,H1541 ;taken if end of symbol space + LD (H01CB),HL + LD HL,(H01D6) + EX DE,HL + LD HL,H145B + LD C,(HL) + LD B,00H + LD HL,H135B + ADD HL,BC + ADD HL,BC + LD C,(HL) + INC HL + LD B,(HL) + LD (HL),D + DEC HL + LD (HL),E + EX DE,HL + LD (HL),C + INC HL + LD (HL),B + LD DE,H0188 + LD A,(DE) + CP 11H + JP C,H152F + LD A,10H ;max length of label = 16 chars +H152F: LD B,A + DEC A + INC HL + LD (HL),A ;store length-1 +H1533: INC HL ;store label name + INC DE + LD A,(DE) + LD (HL),A + DEC B + JP NZ,H1533 + XOR A ;zero value field + INC HL + LD (HL),A + INC HL + LD (HL),A + RET +H1541: LD HL,H154A + CALL H0212 + JP H021E +H154A: DB "SYMBOL TABLE OVERFLOW" + DB 0DH +H1560: RLA + RLA + RLA + RLA + AND 0F0H + LD B,A + LD HL,(H01D6) + INC HL + INC HL + LD A,(HL) + AND 0FH + OR B + LD (HL),A + RET +H1572: LD HL,(H01D6) + INC HL + INC HL + LD A,(HL) + RRA + RRA + RRA + RRA + AND 0FH + RET +H157F: CALL H148E ;return HL pointing to value field of + LD HL,(H01D6) ;symbol at (H01D6) + LD E,A + LD D,00H + ADD HL,DE + INC HL + INC HL + INC HL + RET +H158D: PUSH HL + CALL H157F + POP DE + LD (HL),E + INC HL + LD (HL),D + RET +H1596: CALL H157F + LD E,(HL) + INC HL + LD D,(HL) + EX DE,HL + RET + DB 0,0 +H15A0: JP H1860 ;enter assembler with PRN and HEX files open + JP H1783 +H15A6: JP H1810 ;check word for match. return z-set for match + ;and regs ACC=parm1, B=parm2 +H15A9: DW H15C4 ;mnem length = 1 (as in reg designation char) + DW H15D4 ;mnem length = 2 + DW H15E6 ;mnem length = 3 + DW H1682 ;mnem length = 4 + DW H16AE ;mnem length = 5 + DW H16BD ;bogus? +H15B5: DB 10H ;# of 1 char words in H15C4 table + DB 09H ;# of 2 char words in H15D4 table + DB 34H ;# of 3 char words in H15E6 table + DB 0BH ;# of 4 char words in H1682 table + DB 03H ;# of 5 char words in H16AE table +H15BA: DW H16BD ;length = 1 + DW H16DD ;length = 2 + DW H16EF ;length = 3 + DW H1757 ;length = 4 + DW H176D ;length = 5 +H15C4: DB 0DH + +; the following tables must have at least two words in table and words must be +; in alphabetical order + + DB "()*+,-/ABCDEHLM" +H15D4: DB "DBDIDSDWEIIFINORSP" +H15E6: DB "ACIADCADDADIANAANDANICMACMCCMPCPIDAADADDCRDCXENDEQUHLTINRINXJMPL" + DB "DALXIMODMOVMVINOPNOTORAORGORIOUTPOPPSWRALRARRETRLCRRCRSTSBBSBISE" + DB "TSHLSHRSTASTCSUBSUIXORXRAXRI" +H1682: DB "CALLENDMLDAXLHLDPCHLPUSHSHLDSPHLSTAXXCHGXTHL" +H16AE: DB "ENDIFMACROTITLE" + +; the following are 2 byte parameters corresponding to each word. +; they are referenced in source comments as parm1 and parm2. +; for first pair at H16BD: parm1 = 0FH, parm2 = 0AH +; if parm1 = 10H then parm2 represents a register as follows: +; B=0 C=1 D=2 E=3 H=4 L=5 M,SP,PSW=6 + +H16BD: DB 0FH,0AH + DB 0CH,14H,0DH,1EH,00H,50H + DB 05H,46H,0EH,0AH,06H,46H,01H,50H + DB 10H,07H,10H,00H,10H,01H,10H,02H + DB 10H,03H,10H,04H,10H,05H,10H,06H +H16DD: DB 11H,01H,13H,0F3H,11H,02H,11H,03H + DB 13H,0FBH,11H,08H,21H,0DBH,0AH,28H + DB 10H,06H +H16EF: DB 1AH,0CEH,1DH,88H,1DH,80H,1AH,0C6H + DB 1DH,0A0H,09H,32H,1AH,0E6H,13H,2FH + DB 13H,3FH,1DH,0B8H,1AH,0FEH,13H,27H + DB 15H,09H,1EH,05H,1FH,0BH,11H,04H + DB 11H,07H,13H,76H,1EH,04H,1FH,03H + DB 17H,0C3H,1CH,3AH,14H,01H,02H,50H + DB 18H,40H,19H,06H,13H,00H,08H,3CH + DB 1DH,0B0H,11H,0AH,1AH,0F6H,21H,0D3H + DB 16H,0C1H,10H,06H,13H,17H,13H,1FH + DB 13H,0C9H,13H,07H,13H,0FH,20H,0C7H + DB 1DH,98H,1AH,0DEH,11H,0BH,03H,50H + DB 04H,50H,1CH,32H,13H,37H,1DH,90H + DB 1AH,0D6H,0BH,28H,1DH,0A8H,1AH,0EEH +H1757: DB 17H,0CDH,11H,06H,1BH,0AH,1CH,2AH + DB 13H,0E9H,16H,0C5H,1CH,22H,13H,0F9H + DB 1BH,02H,13H,0EBH,13H,0E3H +H176D: DB 11H,05H,11H,09H,11H,0CH +H1773: DB "NZZ NCC POPEP M " +H1783: LD E,0FFH + INC B + LD C,00H +H1788: XOR A + LD A,B + ADD A,C + RRA + CP E + JP Z,H17C4 + LD E,A + PUSH HL + PUSH DE + PUSH BC + PUSH HL + LD B,D + LD C,B + LD D,00H + LD HL,0000H +H179C: ADD HL,DE + DEC B + JP NZ,H179C + POP DE + ADD HL,DE + LD DE,H0189 +H17A6: LD A,(DE) + CP (HL) + INC DE + INC HL + JP NZ,H17B6 + DEC C + JP NZ,H17A6 + POP BC + POP DE + POP HL + LD A,E + RET +H17B6: POP BC + POP DE + POP HL + JP C,H17C0 + LD C,E + JP H1788 +H17C0: LD B,E + JP H1788 +H17C4: XOR A + INC A + RET +H17C7: LD A,(H0189) + LD BC,0C217H + CP 4AH + RET Z + LD B,0C4H + CP 43H + RET Z + LD BC,0C013H + CP 52H + RET +H17DB: LD A,(H0188) + CP 04H + JP NC,H180D + CP 03H + JP Z,H17F2 + CP 02H + JP NZ,H180D + LD HL,H018B + LD (HL),20H +H17F2: LD BC,0008H + LD DE,H1773 +H17F8: LD HL,H018A + LD A,(DE) + CP (HL) + INC DE + JP NZ,H1805 + LD A,(DE) + INC HL + CP (HL) + RET Z +H1805: INC DE + INC B + DEC C + JP NZ,H17F8 + INC C + RET +H180D: XOR A + INC A + RET +H1810: LD A,(H0188) + LD C,A + DEC A + LD E,A + LD D,00H + PUSH DE + CP 05H ;max length of mnem + JP NC,H185A + LD HL,H15B5 + ADD HL,DE + LD B,(HL) + LD HL,H15A9 + ADD HL,DE + ADD HL,DE + LD D,(HL) + INC HL + LD H,(HL) + LD L,D + LD D,C + CALL H1783 + JP NZ,H1845 ;ACC now = nth pair of whichever 2 byte table + POP DE + LD HL,H15BA + ADD HL,DE + ADD HL,DE + LD E,(HL) + INC HL + LD D,(HL) + LD L,A + LD H,00H + ADD HL,HL + ADD HL,DE + LD A,(HL) + INC HL + LD B,(HL) + RET +H1845: POP DE + CALL H17C7 + RET NZ + PUSH BC + CALL H17DB + LD A,B + POP BC + RET NZ + OR A + RLA + RLA + RLA + OR B + LD B,A + LD A,C + CP A + RET +H185A: POP DE + XOR A + INC A + RET + DB 0,0 +H1860: JP H1BA0 ;enter assembler with PRN and HEX files open +H1863: JP H1A19 ;return addr of symbol in H01C9 and (HL) reg + JP H196E +H1869: JP H1938 ;return 'USE FACTOR' value in DE reg +H186C: DS 01H ;flag 0 or FFh +H186D: DS 0AH ;buffer for parm1 values +H1877: DS 0AH ;buffer for parm2 values +H1881: DS 10H +H1891: DS 01H ;index into H186D or H1877 buffers +H1892: DS 01H ;index into H1881 buffer +H1893: EX DE,HL ;store HL reg pair in H1881 buffer and increment + LD HL,H1892 ;H1892 index by 2 + LD A,(HL) + CP 10H + JP C,H18A2 + CALL H1B85 + LD (HL),00H +H18A2: LD A,(HL) + INC (HL) + INC (HL) + LD C,A + LD B,00H + LD HL,H1881 + ADD HL,BC + LD (HL),E + INC HL + LD (HL),D + RET +H18B0: PUSH AF ;store parm1,parm2 in H186D and H1877 buffers + LD HL,H1891 ;and increment H1891 index + LD A,(HL) + CP 0AH + JP C,H18BF + LD (HL),00H + CALL H1B85 ; 'E' error +H18BF: LD E,(HL) + LD D,00H + INC (HL) + POP AF + LD HL,H186D + ADD HL,DE + LD (HL),A + LD HL,H1877 + ADD HL,DE + LD (HL),B + RET +H18CF: LD HL,H1892 ;get previous pair to HL reg from H1881 buffer + LD A,(HL) + OR A + JP NZ,H18DE + CALL H1B85 + LD HL,0000H + RET +H18DE: DEC (HL) + DEC (HL) + LD C,(HL) + LD B,00H + LD HL,H1881 + ADD HL,BC + LD C,(HL) + INC HL + LD H,(HL) + LD L,C + RET +H18EC: CALL H18CF ;get 2 pairs from H1881 buffer to HL and DE regs + EX DE,HL + CALL H18CF + RET +H18F4: LD L,A ;call subroutine from H1901 table based on + LD H,00H ;parm1 value from H186D table + ADD HL,HL + LD DE,H1901 + ADD HL,DE + LD E,(HL) + INC HL + LD H,(HL) + LD L,E + JP (HL) +H1901: DW H1989 + DW H1992 + DW H1999 + DW H199F + DW H19AB + DW H19BF + DW H19C6 + DW H19D0 + DW H19D9 + DW H19E0 + DW H19EC + DW H19F8 + DW H1B85 +H191B: CALL H18EC + LD A,D + OR A + JP NZ,H1927 + LD A,E + CP 11H + RET C +H1927: CALL H1B85 ;call 'E' error + LD A,10H + RET +H192D: XOR A + SUB L + LD L,A + LD A,00H + SBC A,H + LD H,A + RET +H1935: CALL H18EC +H1938: EX DE,HL + LD (H196B),HL + LD HL,H196D + LD (HL),11H + LD BC,0000H + PUSH BC + XOR A +H1946: LD A,E + RLA + LD E,A + LD A,D + RLA + LD D,A + DEC (HL) + POP HL + RET Z + LD A,00H + ADC A,00H + ADD HL,HL + LD B,H + ADD A,L + LD HL,(H196B) + SUB L + LD C,A + LD A,B + SBC A,H + LD B,A + PUSH BC + JP NC,H1964 + ADD HL,BC + EX (SP),HL +H1964: LD HL,H196D + CCF + JP H1946 +H196B: NOP + NOP +H196D: NOP +H196E: LD B,H + LD C,L + LD HL,0000H +H1973: XOR A + LD A,B + RRA + LD B,A + LD A,C + RRA + LD C,A + JP C,H1982 + OR B + RET Z + JP H1983 +H1982: ADD HL,DE +H1983: EX DE,HL + ADD HL,HL + EX DE,HL + JP H1973 +H1989: CALL H18EC + CALL H196E + JP H1A01 +H1992: CALL H1935 + EX DE,HL + JP H1A01 +H1999: CALL H1935 + JP H1A01 +H199F: CALL H191B +H19A2: OR A + JP Z,H1A01 + ADD HL,HL + DEC A + JP H19A2 +H19AB: CALL H191B +H19AE: OR A + JP Z,H1A01 + PUSH AF + XOR A + LD A,H + RRA + LD H,A + LD A,L + RRA + LD L,A + POP AF + DEC A + JP H19AE +H19BF: CALL H18EC +H19C2: ADD HL,DE + JP H1A01 +H19C6: CALL H18EC + EX DE,HL + CALL H192D + JP H19C2 +H19D0: CALL H18CF +H19D3: CALL H192D + JP H1A01 +H19D9: CALL H18CF + INC HL + JP H19D3 +H19E0: CALL H18EC + LD A,D + AND H + LD H,A + LD A,E + AND L + LD L,A + JP H1A01 +H19EC: CALL H18EC + LD A,D + OR H + LD H,A + LD A,E + OR L + LD L,A + JP H1A01 +H19F8: CALL H18EC + LD A,D + XOR H + LD H,A + LD A,E + XOR L + LD L,A +H1A01: JP H1893 +H1A04: LD A,(H0185) + CP 04H + RET NZ + LD A,(H0189) + CP 0DH + RET Z + CP 3BH + RET Z + CP 2CH + RET Z + CP 21H + RET +H1A19: XOR A + LD (H1891),A + LD (H1892),A + DEC A + LD (H186C),A + LD HL,0000H + LD (H01C9),HL +H1A2A: CALL H1A04 + JP NZ,H1A5D +H1A30: LD HL,H1891 + LD A,(HL) + OR A + JP Z,H1A48 + DEC (HL) + LD E,A + DEC E + LD D,00H + LD HL,H186D + ADD HL,DE + LD A,(HL) + CALL H18F4 ;call subroutine from table + JP H1A30 +H1A48: LD A,(H1892) + CP 02H + CALL NZ,H1B85 ;call 'E' error + LD A,(H010C) + CP 20H + RET NZ + LD HL,(H1881) + LD (H01C9),HL + RET +H1A5D: LD A,(H010C) + CP 20H + JP NZ,H1B7F + LD A,(H0185) ;char type + CP 03H + JP NZ,H1A89 + LD A,(H0188) + OR A + CALL Z,H1B85 + CP 03H + CALL NC,H1B85 + LD D,00H + LD HL,H0189 + LD E,(HL) + INC HL + DEC A + JP Z,H1A85 + LD D,(HL) +H1A85: EX DE,HL + JP H1B71 +H1A89: CP 02H ;char type = numeric + JP NZ,H1A94 + LD HL,(H0186) ;numeric value + JP H1B71 + +; non-alphanumeric chars encountered in label being evaluated come here to +; evaluate possible expression (math) + +H1A94: CALL H15A6 ;scan for match. if match then ACC=parm1 B=parm2 + JP NZ,H1B31 ;taken if no match + CP 10H + JP NC,H1B26 + CP 0CH + LD C,A + LD A,(H186C) + JP NZ,H1AB5 + OR A + CALL Z,H1B85 ; 'E' error + LD A,0FFH + LD (H186C),A + LD A,C + JP H1B03 +H1AB5: OR A + JP NZ,H1B0E +H1AB9: PUSH BC + LD A,(H1891) + OR A + JP Z,H1ADE + LD E,A + DEC E + LD D,00H + LD HL,H1877 + ADD HL,DE + LD A,(HL) + CP B + JP C,H1ADE + LD HL,H1891 + LD (HL),E + LD HL,H186D + ADD HL,DE + LD A,(HL) + CALL H18F4 ;call subroutine from table + POP BC + JP H1AB9 +H1ADE: POP BC + LD A,C + CP 0DH + JP NZ,H1B03 + LD HL,H1891 + LD A,(HL) + OR A + JP Z,H1AFC + DEC A + LD (HL),A + LD E,A + LD D,00H + LD HL,H186D + ADD HL,DE + LD A,(HL) + CP 0CH + JP Z,H1AFF +H1AFC: CALL H1B85 +H1AFF: XOR A + JP H1B08 +H1B03: CALL H18B0 + LD A,0FFH +H1B08: LD (H186C),A + JP H1B7F +H1B0E: LD A,C ;parm1 + CP 05H + JP Z,H1B7F + CP 06H + JP NZ,H1B1E + INC A ;f(-) + LD C,A + JP H1AB9 +H1B1E: CP 08H ;f(NOT) = 8 + CALL NZ,H1B85 + JP H1AB9 +H1B26: CP 11H + CALL Z,H1B85 + LD L,B + LD H,00H + JP H1B71 +H1B31: LD A,(H0185) + CP 04H + JP NZ,H1B50 + LD A,(H0189) + CP 24H ; '$' + JP Z,H1B4A + CALL H1B85 + LD HL,0000H + JP H1B71 +H1B4A: LD HL,(H01D2) + JP H1B71 +H1B50: CALL H1346 ;check for duplicate label + CALL H1349 ;test results + JP NZ,H1B64 ;taken if no duplicate + LD A,50H ; 'P' + CALL H0218 ;error + CALL H134C ;add symbol + JP H1B6E +H1B64: CALL H1352 ;test nibble + AND 07H + LD A,55H ; 'U' + CALL Z,H0218 ;error +H1B6E: CALL H1358 ;get symbol value into HL +H1B71: LD A,(H186C) + OR A + CALL Z,H1B85 + XOR A + LD (H186C),A + CALL H1893 +H1B7F: CALL H1106 ;f(+) + JP H1A2A +H1B85: PUSH HL ; 'E' error + LD A,45H + CALL H0218 + POP HL + RET +H1B8D: CALL H1352 + OR A + JP Z,H1DB5 + RET + DB 0,0,0,0,0,0,0,0,0,0,0 +H1BA0: XOR A ;entry to assembler with PRN and HEX files open + LD (H01CF),A ;reset pass count to 0 + CALL H1343 ;clear buffer + +; 2nd pass loops here + +H1BA7: CALL H1103 ;new line (send CR/LF to PRN file) + CALL H0203 ;open ASM file + LD HL,0000H + LD (H20EB),HL + LD (H01D0),HL + LD (H01D2),HL + LD (H20ED),HL +H1BBC: CALL H1106 ;parse word into H0189 and H010C buffers and +H1BBF: LD A,(H0185) ;set char type in H0185 + CP 02H + JP Z,H1BBC ;handle digit + CP 04H + JP NZ,H1BDD + LD A,(H0189) + CP 2AH ; '*' + JP NZ,H1F31 + CALL H2000 + JP NZ,H1F7C ; 'S' error + JP H1F52 +H1BDD: CP 01H + JP NZ,H1F7C ;not alpha + CALL H15A6 ;check word for match + JP Z,H1C30 + CALL H1346 ;check for duplicate label + CALL H1349 ;test results + JP NZ,H1BFE ;if no duplicate + CALL H134C ;add symbol to table + LD A,(H01CF) ;assembler pass# + OR A + CALL NZ,H20D7 ; 'P' error if duplicate symbol on 1st pass + JP H1C0C +H1BFE: CALL H1352 ;get symbol assignment nibble + CP 06H + JP NZ,H1C0C ;if label assigned value + CALL H20E3 ; 'N' error + JP H1F52 +H1C0C: LD HL,(H20EB) + LD A,L + OR H + CALL NZ,H20DD ; 'L' error + LD HL,(H01D6) + LD (H20EB),HL + CALL H1106 + LD A,(H0185) + CP 04H + JP NZ,H1BBF + LD A,(H0189) + CP 3AH + JP NZ,H1BBF + JP H1BBC +H1C30: CP 11H + JP NZ,H1DD7 + LD E,B + LD D,00H + DEC DE + LD HL,H1C43 + ADD HL,DE + ADD HL,DE + LD E,(HL) + INC HL + LD H,(HL) + LD L,E + JP (HL) + +;table for parm1 = 11h. parm2 referenced in () + +H1C43: DW H1C5B ;(01h) DB + DW H1CA9 ;(02h) DS + DW H1CC0 ;(03h) DW + DW H1CDE ;(04h) END + DW H1D15 ;(05h) ENDIF + DW H1D18 ;(06h) ENDM (function not supported. gives 'N' error) + DW H1D1E ;(07h) EQU + DW H1D40 ;(08h) IF + DW H1D87 ;(09h) MACRO (function not supported. gives 'N' error) + DW H1D8D ;(0Ah) ORG + DW H1DA7 ;(0Bh) SET + DW H1DCE ;(0Ch) TITLE +H1C5B: CALL H200A +H1C5E: CALL H1106 + LD A,(H0185) + CP 03H + JP NZ,H1C8C + LD A,(H0188) + DEC A + JP Z,H1C8C + LD B,A + INC B + INC B + LD HL,H0189 +H1C76: DEC B + JP Z,H1C86 + PUSH BC + LD B,(HL) + INC HL + PUSH HL + CALL H2048 + POP HL + POP BC + JP H1C76 +H1C86: CALL H1106 + JP H1C9B +H1C8C: CALL H1863 + LD HL,(H01C9) + LD A,H + OR A + CALL NZ,H20D1 ; 'D' error if DB label not 8-bit value + LD B,L + CALL H2048 +H1C9B: CALL H1FF9 + CALL H1EBA + CP 2CH + JP Z,H1C5E + JP H1F31 +H1CA9: CALL H200A ;f(DS) + CALL H20A6 + CALL H1ED1 ;get 16 bit value/address into HL + EX DE,HL + LD HL,(H01D2) + ADD HL,DE + LD (H01D2),HL + LD (H01D0),HL ;address PC counter + JP H1F31 +H1CC0: CALL H200A ;f(DW) +H1CC3: CALL H1ED1 + PUSH HL + LD B,L + CALL H2048 + POP HL + LD B,H + CALL H2048 + CALL H1FF9 + CALL H1EBA + CP 2CH + JP Z,H1CC3 + JP H1F31 +H1CDE: CALL H200A ;f(END) + CALL H20A6 ;print final PRN line addr to buffer + LD A,(H010C) + CP 20H + JP NZ,H1F31 + CALL H1ED1 ;get addr to HL of symbol following END (if any) + LD A,(H010C) ;END w/o symbol gives 'E' error (both passes) + CP 20H + JP NZ,H1CFA + LD (H20ED),HL ;value of symbol after END. possibly EOF addr? +H1CFA: LD A,20H + LD (H010C),A + CALL H1106 + LD A,(H0185) + CP 04H + JP NZ,H1F7C + LD A,(H0189) + CP 0AH + JP NZ,H1F7C + JP H1F8B +H1D15: JP H1DD1 ;f(ENDIF) +H1D18: CALL H20E3 ;f(ENDM) gives 'N' error (not supported) + JP H1DD1 +H1D1E: CALL H2000 ;f(EQU) + JP Z,H1F7C + LD HL,(H01D2) + PUSH HL + CALL H1ED1 + LD (H01D2),HL + CALL H200A + CALL H20A9 + LD HL,H0112 + LD (HL),3DH + POP HL + LD (H01D2),HL + JP H1F31 +H1D40: CALL H200A ;f(IF) + CALL H1ED1 + LD A,(H010C) + CP 20H + JP NZ,H1F31 + LD A,L + RRA + JP C,H1F31 +H1D53: CALL H1106 + LD A,(H0185) + CP 04H + JP NZ,H1D6E + LD A,(H0189) + CP 1AH + LD A,42H + CALL Z,H0218 + JP Z,H1F8B + JP H1D53 +H1D6E: CP 01H + JP NZ,H1D53 + CALL H15A6 + JP NZ,H1D53 + CP 11H + JP NZ,H1D53 + LD A,B + CP 05H + JP NZ,H1D53 + JP H1DD1 +H1D87: CALL H20E3 ;f(MACRO) gives 'N' error (not supported) + JP H1F31 +H1D8D: CALL H1ED1 ;f(ORG) + LD A,(H010C) + CP 20H + JP NZ,H1F31 + LD (H01D2),HL ;ORG address for PC counters + LD (H01D0),HL + CALL H200A + CALL H20A6 + JP H1F31 +H1DA7: CALL H2000 ;f(SET) + JP Z,H1F7C + CALL H1B8D + CP 05H + CALL NZ,H20DD +H1DB5: LD A,05H + CALL H134F + CALL H1ED1 + PUSH HL + CALL H2000 + POP HL + CALL H1355 + LD HL,0000H + LD (H20EB),HL + JP H1F31 +H1DCE: CALL H20E3 +H1DD1: CALL H1106 + JP H1F31 +H1DD7: SUB 13H ;ACC = parm1 value from H15A6 call + CP 21H ;bug here. should have been 0Fh + JP NC,H1F7C ;taken for parm1<13h or >=34h (should be >=22h) + LD E,A ;see table following. range only 13h to 21h + LD D,00H + LD HL,H1DEB + ADD HL,DE + ADD HL,DE + LD E,(HL) + INC HL + LD H,(HL) + LD L,E + JP (HL) + +;table for parm1 = 13h to 21h. parm1 value in () + +H1DEB: DW H1E09 ;(13h) DI EI CMA CMC DAA HLT NOP RAL RAR RET RLC RRC STC + ; PCHL SPHL XTHL XCHG + DW H1E12 ;(14h) LXI + DW H1E1E ;(15h) DAD + DW H1E24 ;(16h) POP PUSH + DW H1E38 ;(17h) JMP CALL + DW H1E41 ;(18h) MOV + DW H1E50 ;(19h) MVI + DW H1E60 ;(1Ah) ACI ADI ANI CPI ORI XRI SUI SBI + DW H1E69 ;(1Bh) LDAX STAX + DW H1E78 ;(1Ch) LDA STA LHLD SHLD + DW H1E81 ;(1Dh) ADC ADD ANA CMP ORA XRA SUB SBB + DW H1E88 ;(1Eh) DCR INR + DW H1E8F ;(1Fh) DCX INX + DW H1E9E ;(20h) RST + DW H1EA5 ;(21h) IN OUT +H1E09: CALL H2048 + CALL H1106 + JP H1EB1 +H1E12: CALL H1EFC ;process reg char following LXI instruction + CALL H1F17 ;check for comma + CALL H1F11 + JP H1EB1 +H1E1E: CALL H1EFC ;process reg char following DAD instruction + JP H1EB1 +H1E24: CALL H1EF2 + CP 38H + JP Z,H1E31 + AND 08H + CALL NZ,H20BD +H1E31: LD A,C + AND 30H + OR B + JP H1EAE +H1E38: CALL H2048 + CALL H1F11 + JP H1EB1 +H1E41: CALL H1EF2 ;f(MOV) + OR B + LD B,A + CALL H1F17 + CALL H1EE7 ;parse reg value + OR B + JP H1EAE +H1E50: CALL H1EF2 ;get reg mask following MVI instruction + OR B + CALL H2047 ;store opcode + CALL H1F17 ;check for comma + CALL H1F0B ;parse and store 8 bit label/value after comma + JP H1EB1 +H1E60: CALL H2048 ;store opcode in HEX file + CALL H1F0B ;parse operand + JP H1EB1 +H1E69: CALL H1EF2 + AND 28H + CALL NZ,H20BD + LD A,C + AND 10H + OR B + JP H1EAE +H1E78: CALL H2048 + CALL H1F11 + JP H1EB1 +H1E81: CALL H1EE7 + OR B + JP H1EAE +H1E88: CALL H1EF2 + OR B + JP H1EAE +H1E8F: CALL H1EF2 + AND 08H + CALL NZ,H20BD + LD A,C + AND 30H + OR B + JP H1EAE +H1E9E: CALL H1EF2 + OR B + JP H1EAE +H1EA5: CALL H2048 + CALL H1F0B + JP H1EB1 +H1EAE: CALL H2047 +H1EB1: CALL H200A ;each instruction line comes here to close + CALL H1FF9 ;update PRN file PC counter (H01D2) for next line + JP H1F31 +H1EBA: LD A,(H0185) + CP 04H + CALL NZ,H20D1 + LD A,(H0189) + CP 2CH + RET Z + CP 3BH + RET Z + CP 0DH + CALL NZ,H20D1 + RET +H1ED1: PUSH BC ;get 16 bit reg value or label address into HL reg. + CALL H1106 ;parse word + CALL H1863 ;process word + LD HL,(H01C9) ;holds value (example: C reg value = 0001) + POP BC + RET +H1EDD: CALL H1ED1 ;get 8 bit reg value or label address into ACC reg. + LD A,H + OR A + CALL NZ,H20C7 + LD A,L + RET +H1EE7: CALL H1EDD ;parse 8 bit reg char value into ACC (0 to 7 = ACC to M) + CP 08H + CALL NC,H20C7 ; 'V' error (bad register designation) + AND 07H + RET +H1EF2: CALL H1EE7 ;get 8 bit reg char value (0-7) into bits 3,4,5 of ACC + RLA + RLA + RLA + AND 38H + LD C,A + RET +H1EFC: CALL H1EF2 ;store 16 bit regs (even# B,D or H) ORA'd with B(=parm2) + AND 08H ;bit 3 set if odd# reg (ACC,C,E or L) + CALL NZ,H20BD ; 'R' error + LD A,C + AND 30H + OR B + JP H2047 +H1F0B: CALL H1EDD ;parse and store 8 bit label/address (operand) + JP H2047 +H1F11: CALL H1ED1 ;parse and store 16 bit label/address (operand) + JP H2074 +H1F17: PUSH AF ;check for comma + PUSH BC + LD A,(H0185) + CP 04H + JP NZ,H1F29 + LD A,(H0189) + CP 2CH + JP Z,H1F2E +H1F29: LD A,43H + CALL H0218 +H1F2E: POP BC + POP AF + RET +H1F31: CALL H200A + LD A,(H0185) + CP 04H + JP NZ,H1F7C + LD A,(H0189) + CP 0DH + JP NZ,H1F4A + CALL H1106 + JP H1BBC +H1F4A: CP 3BH ; ';' + JP NZ,H1F72 + CALL H200A +H1F52: CALL H1106 + LD A,(H0185) + CP 04H + JP NZ,H1F52 + LD A,(H0189) + CP 0AH + JP Z,H1BBC + CP 1AH + JP Z,H1F8B + CP 21H + JP Z,H1BBC + JP H1F52 +H1F72: CP 21H ; '!' + JP Z,H1BBC + CP 1AH + JP Z,H1F8B +H1F7C: LD A,53H + CALL H0218 + JP H1F52 +H1F84: LD A,E ;HL=DE-HL + SUB L + LD L,A + LD A,D + SBC A,H + LD H,A + RET +H1F8B: LD HL,H01CF ;assembler pass count + LD A,(HL) + INC (HL) ;increment 1st to 2nd pass + OR A + JP Z,H1BA7 ;if 2nd pass + CALL H1106 ;here after 2nd pass + CALL H20A6 + LD HL,H0111 + LD (HL),0DH + LD HL,H010D + CALL H0212 + LD HL,(H01CB) + EX DE,HL + LD HL,(H01D4) + CALL H1F84 + PUSH HL + LD HL,(H01CD) + EX DE,HL + LD HL,(H01D4) + CALL H1F84 + LD E,H + LD D,00H + POP HL + CALL H1869 + EX DE,HL + CALL H20A9 ;put HL in PRN buffer just before 'USE FACTOR' + LD HL,H0111 + LD DE,H1FD6 +H1FCB: LD A,(DE) ;put 'USE FACTOR' in PRN buffer + OR A + JP Z,H1FE4 + LD (HL),A + INC HL + INC DE + JP H1FCB +H1FD6: DB "H USE FACTOR" + DB 0DH,00H +H1FE4: LD HL,H010E + CALL H0212 + LD HL,(H20ED) + LD (H01D0),HL + JP H021E ;go close files and exit +H1FF3: LD A,D + CP H + RET NZ + LD A,E + CP L + RET +H1FF9: LD HL,(H01D0) + LD (H01D2),HL + RET +H2000: LD HL,(H20EB) ;test H20EB for 0. move to H01D6 and ret in HL + LD (H01D6),HL + CALL H1349 + RET + +; on 1st pass if H20EB non-zero then set PC counter to value of symbol operand +; at (H20EB). clear up unevaluated label, if any. on 2nd pass make sure label +; value is set and matches current PC else 'P' phase error + +H200A: CALL H2000 + RET Z + LD HL,0000H + LD (H20EB),HL + LD A,(H01CF) ;pass count + OR A + JP NZ,H2031 ;if 2nd pass + CALL H1352 ;test nibble (see H134F notes) + PUSH AF + AND 07H + CALL NZ,H20DD ; 'L' error + POP AF + OR 01H + CALL H134F ;set nibble flag + LD HL,(H01D2) + CALL H1355 ;set value of symbol to HL + RET +H2031: CALL H1352 ;test nibble + AND 07H + CALL Z,H20D7 ; 'P' error + CALL H1358 ;get symbol value + EX DE,HL + LD HL,(H01D2) + CALL H1FF3 + CALL NZ,H20D7 + RET + +;on 2nd pass store byte from ACC in hex ascii form to H010C PRN line buffer +;and HEX file. also write PC address in hex ascii if at beginning of line. + +H2047: LD B,A +H2048: LD A,(H01CF) ;store byte in B reg + OR A ;pass count + LD A,B + JP Z,H206C ;if 1st pass, only advance PC counter + PUSH BC + CALL H021B ;write byte to HEX file + LD A,(H010D) + CP 20H + LD HL,(H01D2) ;PC counter of PRN line + CALL Z,H20A9 ;print PC at start of PRN line (if no error) + LD A,(H20EF) ;PRN file line index + CP 10H ;10h = start of label field + POP BC + JP NC,H206C + LD A,B + CALL H2096 ;print byte in hex to PRN file +H206C: LD HL,(H01D0) ;advance PC counter + INC HL + LD (H01D0),HL + RET +H2074: PUSH HL ;write HL to PRN buffer and HEX file + LD B,L + CALL H2048 + POP HL + LD B,H + JP H2048 +H207E: ADD A,30H + CP 3AH + RET C + ADD A,07H + RET +H2086: CALL H207E + LD HL,H20EF + LD E,(HL) + LD D,00H + INC (HL) + LD HL,H010C + ADD HL,DE + LD (HL),A + RET +H2096: PUSH AF ;print byte to PRN buffer + RRA + RRA + RRA + RRA + AND 0FH + CALL H2086 + POP AF + AND 0FH + JP H2086 +H20A6: LD HL,(H01D2) ;print PC addr in ascii to PRN buffer +H20A9: EX DE,HL + LD HL,H20EF + PUSH HL + LD (HL),01H + LD A,D + PUSH DE + CALL H2096 + POP DE + LD A,E + CALL H2096 + POP HL + INC (HL) + RET +H20BD: PUSH AF ; 'R' error + PUSH BC + LD A,52H + CALL H0218 + POP BC + POP AF + RET +H20C7: PUSH AF ; 'V' error + PUSH HL + LD A,56H + CALL H0218 + POP HL + POP AF + RET +H20D1: PUSH AF ; 'D' error + LD A,44H + JP H20E6 +H20D7: PUSH AF ; 'P' error + LD A,50H + JP H20E6 +H20DD: PUSH AF ; 'L' error + LD A,4CH + JP H20E6 +H20E3: PUSH AF ; 'N' error + LD A,4EH +H20E6: CALL H0218 + POP AF + RET +H20EB: DS 02H ;last H01D6 value from H1346 call +H20ED: DS 02H ;EOF addr after 'END' (value of symbol) +H20EF: DS 1 ;char index into H010C PRN line buffer +H20F0: DS 1 ;label table begins here + END diff --git a/software/asm/cbios.asm b/software/asm/cbios.asm index 68a457b..046c8c4 100644 --- a/software/asm/cbios.asm +++ b/software/asm/cbios.asm @@ -922,8 +922,12 @@ TZSVC_FILE_SEC: EQU TZSVC_DIR_SEC ; Union TZSVC_TRACK_NO: DS 2 ; Storage for the virtual drive track number. TZSVC_SECTOR_NO:DS 2 ; Storage for the virtual drive sector number. TZSVC_FILE_NO: DS 1 ; File number to be opened in a file service command. +TZSVC_FILE_TYPE:DS 1 ; Type of file being accessed to differentiate between Sharp MZF files and other handled files. TZSVC_LOADADDR DS 2 ; Dynamic load address for rom/images. +TZSVC_SAVEADDR: EQU TZSVC_LOADADDR ; Union of the load address and the cpu frequency change value, the address of data to be saved. +TZSVC_CPU_FREQ: EQU TZSVC_LOADADDR ; Union of the load address and the save address value, only one can be used at a time. TZSVC_LOADSIZE DS 2 ; Size of file to be loaded. +TZSVC_SAVESIZE: EQU TZSVC_LOADSIZE ; Size of image to be saved. TZSVC_DIRNAME: DS TZSVCDIRSZ ; Service directory/file name. TZSVC_FILENAME: DS TZSVCFILESZ ; Filename to be opened/created. TZSVCWILDC: DS TZSVCWILDSZ ; Directory wildcard for file pattern matching. diff --git a/software/asm/include/BASIC_Definitions.asm b/software/asm/include/BASIC_Definitions.asm new file mode 100644 index 0000000..a8ff5b3 --- /dev/null +++ b/software/asm/include/BASIC_Definitions.asm @@ -0,0 +1,313 @@ +;-------------------------------------------------------------------------------------------------------- +;- +;- Name: BASIC_Definitions.asm +;- Created: January 2020 +;- Author(s): Philip Smart +;- Description: Sharp MZ series CPM v2.23 +;- Definitions for the Sharp MZ80A CPM v2.23 OS used in the RFS +;- +;- Credits: +;- Copyright: (c) 2019-20 Philip Smart +;- +;- History: Jan 2020 - Initial version. +; May 2020 - Advent of the new RFS PCB v2.0, quite a few changes to accommodate the +; additional and different hardware. The SPI is now onboard the PCB and +; not using the printer interface card. +; May 2020 - Cut from the RFS version of CPM for the tranZPUter SW board. +;- +;-------------------------------------------------------------------------------------------------------- +;- This source file is free software: you can redistribute it and-or modify +;- it under the terms of the GNU General Public License as published +;- by the Free Software Foundation, either version 3 of the License, or +;- (at your option) any later version. +;- +;- This source file is distributed in the hope that it will be useful, +;- but WITHOUT ANY WARRANTY; without even the implied warranty of +;- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;- GNU General Public License for more details. +;- +;- You should have received a copy of the GNU General Public License +;- along with this program. If not, see . +;-------------------------------------------------------------------------------------------------------- + +;----------------------------------------------- +; Features. +;----------------------------------------------- + +;----------------------------------------------- + +;----------------------------------------------- +; Configurable settings. +;----------------------------------------------- +MAXRDRETRY EQU 002h +MAXWRRETRY EQU 002h +BLKSIZ EQU 4096 ; CP/M allocation size +HSTSIZ EQU 512 ; host disk sector size +HSTSPT EQU 32 ; host disk sectors/trk +HSTBLK EQU HSTSIZ/128 ; CP/M sects/host buff +CPMSPT EQU HSTBLK * HSTSPT ; CP/M sectors/track +SECMSK EQU HSTBLK-1 ; sector mask +WRALL EQU 0 ; write to allocated +WRDIR EQU 1 ; write to directory +WRUAL EQU 2 ; write to unallocated +TMRTICKINTV EQU 5 ; Number of 0.010mSec ticks per interrupt, ie. resolution of RTC. +COLW: EQU 80 ; Width of the display screen (ie. columns). +ROW: EQU 25 ; Number of rows on display screen. +SCRNSZ: EQU COLW * ROW ; Total size, in bytes, of the screen display area. +SCRLW: EQU COLW / 8 ; Number of 8 byte regions in a line for hardware scroll. +MODE80C: EQU 1 + +; BIOS equates +MAXDISKS EQU 7 ; Max number of Drives supported +KEYBUFSIZE EQU 64 ; Ensure this is a power of 2, max size 256. +MAXMEM EQU 10000H - TZSVCSIZE ; Top of RAM. + +; Tape load/save modes. Used as a flag to enable common code. +TAPELOAD EQU 1 +CTAPELOAD EQU 2 +TAPESAVE EQU 3 +CTAPESAVE EQU 4 + +; Build options. Set just one to '1' the rest to '0'. +BUILD_MZ80A EQU 1 ; Build for the standard Sharp MZ80A, no lower memory. +BUILD_TZFS EQU 0 ; Build for TZFS where extended memory is available. +INCLUDE_ANSITERM EQU 1 ; Include the Ansi terminal emulation processor in the build. + +; Debugging +ENADEBUG EQU 0 ; Enable debugging logic, 1 = enable, 0 = disable + +;----------------------------------------------- +; BASIC ERROR CODE VALUES +;----------------------------------------------- +NF EQU 00H ; NEXT without FOR +SN EQU 02H ; Syntax error +RG EQU 04H ; RETURN without GOSUB +OD EQU 06H ; Out of DATA +FC EQU 08H ; Function call error +OV EQU 0AH ; Overflow +OM EQU 0CH ; Out of memory +UL EQU 0EH ; Undefined line number +BS EQU 10H ; Bad subscript +DDA EQU 12H ; Re-DIMensioned array +DZ EQU 14H ; Division by zero (/0) +ID EQU 16H ; Illegal direct +TM EQU 18H ; Type miss-match +OS EQU 1AH ; Out of string space +LS EQU 1CH ; String too long +ST EQU 1EH ; String formula too complex +CN EQU 20H ; Can't CONTinue +UF EQU 22H ; UnDEFined FN function +MO EQU 24H ; Missing operand +HX EQU 26H ; HEX error +BN EQU 28H ; BIN error + +;----------------------------------------------- +; Memory mapped ports in hardware. +;----------------------------------------------- +SCRN: EQU 0D000H +ARAM: EQU 0D800H +DSPCTL: EQU 0DFFFH ; Screen 40/80 select register (bit 7) +KEYPA: EQU 0E000h +KEYPB: EQU 0E001h +KEYPC: EQU 0E002h +KEYPF: EQU 0E003h +CSTR: EQU 0E002h +CSTPT: EQU 0E003h +CONT0: EQU 0E004h +CONT1: EQU 0E005h +CONT2: EQU 0E006h +CONTF: EQU 0E007h +SUNDG: EQU 0E008h +TEMP: EQU 0E008h +MEMSW: EQU 0E00CH +MEMSWR: EQU 0E010H +INVDSP: EQU 0E014H +NRMDSP: EQU 0E015H +SCLDSP: EQU 0E200H +SCLBASE: EQU 0E2H + +;----------------------------------------------- +; IO Registers +;----------------------------------------------- +FDC EQU 0D8h ; MB8866 IO Region 0D8h - 0DBh +FDC_CR EQU FDC + 000h ; Command Register +FDC_STR EQU FDC + 000h ; Status Register +FDC_TR EQU FDC + 001h ; Track Register +FDC_SCR EQU FDC + 002h ; Sector Register +FDC_DR EQU FDC + 003h ; Data Register +FDC_MOTOR EQU FDC + 004h ; DS[0-3] and Motor control. 4 drives DS= BIT 0 -> Bit 2 = Drive number, 2=1,1=0,0=0 DS0, 2=1,1=0,0=1 DS1 etc + ; bit 7 = 1 MOTOR ON LOW (Active) +FDC_SIDE EQU FDC + 005h ; Side select, Bit 0 when set = SIDE SELECT LOW + +;----------------------------------------------- +; Common character definitions. +;----------------------------------------------- +SCROLL EQU 001H ;Set scroll direction UP. +BELL EQU 007H +SPACE EQU 020H +TAB EQU 009H ;TAB ACROSS (8 SPACES FOR SD-BOARD) +CR EQU 00DH +LF EQU 00AH +FF EQU 00CH +CS EQU 0CH ; Clear screen +DELETE EQU 07FH +BACKS EQU 008H +SOH EQU 1 ; For XModem etc. +EOT EQU 4 +ACK EQU 6 +NAK EQU 015H +NUL EQU 000H +;NULL EQU 000H +CTRL_A EQU 001H +CTRL_B EQU 002H +CTRL_C EQU 003H +CTRL_D EQU 004H +CTRL_E EQU 005H +CTRL_F EQU 006H +CTRL_G EQU 007H +CTRL_H EQU 008H +CTRL_I EQU 009H +CTRL_J EQU 00AH +CTRL_K EQU 00BH +CTRL_L EQU 00CH +CTRL_M EQU 00DH +CTRL_N EQU 00EH +CTRL_O EQU 00FH +CTRL_P EQU 010H +CTRL_Q EQU 011H +CTRL_R EQU 012H +CTRL_S EQU 013H +CTRL_T EQU 014H +CTRL_U EQU 015H +CTRL_V EQU 016H +CTRL_W EQU 017H +CTRL_X EQU 018H +CTRL_Y EQU 019H +CTRL_Z EQU 01AH +ESC EQU 01BH +CTRL_SLASH EQU 01CH +CTRL_RB EQU 01DH +CTRL_CAPPA EQU 01EH +CTRL_UNDSCR EQU 01FH +CTRL_AT EQU 000H +NOKEY EQU 0F0H +CURSRIGHT EQU 0F1H +CURSLEFT EQU 0F2H +CURSUP EQU 0F3H +CURSDOWN EQU 0F4H +DBLZERO EQU 0F5H +INSERT EQU 0F6H +CLRKEY EQU 0F7H +HOMEKEY EQU 0F8H +BREAKKEY EQU 0FBH + + +;----------------------------------------------- +; IO ports in hardware and values. +;----------------------------------------------- +MMCFG EQU 060H ; Memory management configuration latch. +SETXMHZ EQU 062H ; Select the alternate clock frequency. +SET2MHZ EQU 064H ; Select the system 2MHz clock frequency. +CLKSELRD EQU 066H ; Read clock selected setting, 0 = 2MHz, 1 = XMHz +SVCREQ EQU 068H ; I/O Processor service request. + +;----------------------------------------------- +; tranZPUter SW Memory Management modes +;----------------------------------------------- +TZMM_ORIG EQU 000H ; Original Sharp MZ80A mode, no tranZPUter features are selected except the I/O control registers (default: 0x60-063). +TZMM_BOOT EQU 001H ; Original mode but E800-EFFF is mapped to tranZPUter RAM so TZFS can be booted. +TZMM_TZFS EQU 002H ; TZFS main memory configuration. all memory is in tranZPUter RAM, E800-FFFF is used by TZFS, SA1510 is at 0000-1000 and RAM is 1000-CFFF, 64K Block 0 selected. +TZMM_TZFS2 EQU 003H ; TZFS main memory configuration. all memory is in tranZPUter RAM, E800-EFFF is used by TZFS, SA1510 is at 0000-1000 and RAM is 1000-CFFF, 64K Block 0 selected, F000-FFFF is in 64K Block 1. +TZMM_TZFS3 EQU 004H ; TZFS main memory configuration. all memory is in tranZPUter RAM, E800-EFFF is used by TZFS, SA1510 is at 0000-1000 and RAM is 1000-CFFF, 64K Block 0 selected, F000-FFFF is in 64K Block 2. +TZMM_TZFS4 EQU 005H ; TZFS main memory configuration. all memory is in tranZPUter RAM, E800-EFFF is used by TZFS, SA1510 is at 0000-1000 and RAM is 1000-CFFF, 64K Block 0 selected, F000-FFFF is in 64K Block 3. +TZMM_CPM EQU 006H ; CPM main memory configuration, all memory on the tranZPUter board, 64K block 4 selected. Special case for F3C0:F3FF & F7C0:F7FF (floppy disk paging vectors) which resides on the mainboard. +TZMM_CPM2 EQU 007H ; CPM main memory configuration, F000-FFFF are on the tranZPUter board in block 4, 0040-CFFF and E800-EFFF are in block 5, mainboard for D000-DFFF (video), E000-E800 (Memory control) selected. + ; Special case for 0000:003F (interrupt vectors) which resides in block 4, F3C0:F3FF & F7C0:F7FF (floppy disk paging vectors) which resides on the mainboard. +TZMM_MZ700_0 EQU 00AH ; MZ700 Mode - 0000:0FFF is on the tranZPUter board in block 6, 1000:CFFF is on the tranZPUter board in block 0, D000:FFFF is on the mainboard. +TZMM_MZ700_1 EQU 00BH ; MZ700 Mode - 0000:0FFF is on the tranZPUter board in block 0, 1000:CFFF is on the tranZPUter board in block 0, D000:FFFF is on the tranZPUter in block 6. +TZMM_MZ700_2 EQU 00CH ; MZ700 Mode - 0000:0FFF is on the tranZPUter board in block 6, 1000:CFFF is on the tranZPUter board in block 0, D000:FFFF is on the tranZPUter in block 6. +TZMM_MZ700_3 EQU 00DH ; MZ700 Mode - 0000:0FFF is on the tranZPUter board in block 0, 1000:CFFF is on the tranZPUter board in block 0, D000:FFFF is inaccessible. +TZMM_MZ700_4 EQU 00EH ; MZ700 Mode - 0000:0FFF is on the tranZPUter board in block 6, 1000:CFFF is on the tranZPUter board in block 0, D000:FFFF is inaccessible. +TZMM_TZPU0 EQU 018H ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 0 is selected. +TZMM_TZPU1 EQU 019H ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 1 is selected. +TZMM_TZPU2 EQU 01AH ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 2 is selected. +TZMM_TZPU3 EQU 01BH ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 3 is selected. +TZMM_TZPU4 EQU 01CH ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 4 is selected. +TZMM_TZPU5 EQU 01DH ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 5 is selected. +TZMM_TZPU6 EQU 01EH ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 6 is selected. +TZMM_TZPU7 EQU 01FH ; Everything is in tranZPUter domain, no access to underlying Sharp mainboard unless memory management mode is switched. tranZPUter RAM 64K block 7 is selected. + +;----------------------------------------------- +; TZ File System Header (MZF) +;----------------------------------------------- +TZFS_ATRB: EQU 00000h ; Code Type, 01 = Machine Code. +TZFS_NAME: EQU 00001h ; Title/Name (17 bytes). +TZFS_SIZE: EQU 00012h ; Size of program. +TZFS_DTADR: EQU 00014h ; Load address of program. +TZFS_EXADR: EQU 00016h ; Exec address of program. +TZFS_COMNT: EQU 00018h ; Comment +TZFS_MZFLEN: EQU 128 ; Length of the MZF header. +TZFS_CMTLEN: EQU 104 ; Length of the comment field + +;----------------------------------------------- +; BIOS WORK AREA (MZ80A) +;----------------------------------------------- + ; Variables and control structure used by the I/O processor for service calls and requests. + ORG TZSVCMEM + +TZSVCMEM: EQU 0FD80H ; Start of a memory structure used to communicate with the K64F I/O processor for services such as disk access. +TZSVCSIZE: EQU 00280H ; +TZSVCDIRSZ: EQU 20 ; Size of the directory/file name. +TZSVCFILESZ: EQU 17 ; Size of a Sharp filename. +TZSVCWILDSZ: EQU 20 ; Size of the wildcard. +TZSVCSECSIZE: EQU 512 +TZSVCDIR_ENTSZ: EQU 32 ; Size of a directory entry. +TZSVCWAITIORETRIES: EQU 500 ; Wait retries for IO response. +TZSVCWAITCOUNT: EQU 65535 ; Wait retries for IO request response. +TZSVC_FTYPE_MZF: EQU 0 ; File type being handled is an MZF +TZSVC_FTYPE_CAS: EQU 1 ; File type being handled is an CASsette BASIC script. +TZSVC_FTYPE_BAS: EQU 2 ; File type being handled is an BASic script +TZSVCCMD: DS virtual 1 ; Service command. +TZSVCRESULT: DS virtual 1 ; Service command result. +TZSVCDIRSEC: DS virtual 1 ; Storage for the directory sector number. +TZSVC_FILE_SEC: EQU TZSVCDIRSEC ; Union of the file and directory sector as only one can be used at a time. +TZSVC_TRACK_NO: DS virtual 2 ; Storage for the virtual drive track number. +TZSVC_SECTOR_NO: DS virtual 2 ; Storage for the virtual drive sector number. +TZSVC_FILE_NO: DS virtual 1 ; File number to be opened in a file service command. +TZSVC_FILE_TYPE: DS virtual 1 ; Type of file being accessed to differentiate between Sharp MZF files and other handled files. +TZSVC_LOADADDR: DS virtual 2 ; Dynamic load address for rom/images. +TZSVC_SAVEADDR: EQU TZSVC_LOADADDR ; Union of the load address and the cpu frequency change value, the address of data to be saved. +TZSVC_CPU_FREQ: EQU TZSVC_LOADADDR ; Union of the load address and the save address value, only one can be used at a time. +TZSVC_LOADSIZE: DS virtual 2 ; Size of image to load. +TZSVC_SAVESIZE: EQU TZSVC_LOADSIZE ; Size of image to be saved. +TZSVC_DIRNAME: DS virtual TZSVCDIRSZ ; Service directory/file name. +TZSVC_FILENAME: DS virtual TZSVCFILESZ ; Filename to be opened/created. +TZSVCWILDC: DS virtual TZSVCWILDSZ ; Directory wildcard for file pattern matching. +TZSVCSECTOR: DS virtual TZSVCSECSIZE ; Service command sector - to store directory entries, file sector read or writes. + +TZSVC_CMD_READDIR: EQU 01H ; Service command to open a directory and return the first block of entries. +TZSVC_CMD_NEXTDIR: EQU 02H ; Service command to return the next block of an open directory. +TZSVC_CMD_READFILE: EQU 03H ; Service command to open a file and return the first block. +TZSVC_CMD_NEXTREADFILE: EQU 04H ; Service command to return the next block of an open file. +TZSVC_CMD_WRITEFILE: EQU 05H ; Service command to create a file and save the first block. +TZSVC_CMD_NEXTWRITEFILE:EQU 06H ; Service command to write the next block to the open file. +TZSVC_CMD_CLOSE: EQU 07H ; Service command to close any open file or directory. +TZSVC_CMD_LOADFILE: EQU 08H ; Service command to load a file directly into tranZPUter memory. +TZSVC_CMD_SAVEFILE: EQU 09H ; Service command to save a file directly from tranZPUter memory. +TZSVC_CMD_ERASEFILE: EQU 0aH ; Service command to erase a file on the SD card. +TZSVC_CMD_CHANGEDIR: EQU 0bH ; Service command to change the active directory on the SD card. +TZSVC_CMD_LOAD40BIOS: EQU 20H ; Service command requesting that the 40 column version of the SA1510 BIOS is loaded. +TZSVC_CMD_LOAD80BIOS: EQU 21H ; Service command requesting that the 80 column version of the SA1510 BIOS is loaded. +TZSVC_CMD_LOAD700BIOS40:EQU 22H ; Service command requesting that the MZ700 1Z-013A 40 column BIOS is loaded. +TZSVC_CMD_LOAD700BIOS80:EQU 23H ; Service command requesting that the MZ700 1Z-013A 80 column patched BIOS is loaded. +TZSVC_CMD_LOAD80BIPL: EQU 24H ; Service command requesting the MZ-80B IPL is loaded. +TZSVC_CMD_LOADBDOS: EQU 30H ; Service command to reload CPM BDOS+CCP. +TZSVC_CMD_ADDSDDRIVE: EQU 31H ; Service command to attach a CPM disk to a drive number. +TZSVC_CMD_READSDDRIVE: EQU 32H ; Service command to read an attached SD file as a CPM disk drive. +TZSVC_CMD_WRITESDDRIVE: EQU 33H ; Service command to write to a CPM disk drive which is an attached SD file. +TZSVC_CMD_CPU_BASEFREQ EQU 40H ; Service command to switch to the mainboard frequency. +TZSVC_CMD_CPU_ALTFREQ EQU 41H ; Service command to switch to the alternate frequency provided by the K64F. +TZSVC_CMD_CPU_CHGFREQ EQU 42H ; Service command to set the alternate frequency in hertz. +TZSVC_STATUS_OK: EQU 000H ; Flag to indicate the K64F processing completed successfully. +TZSVC_STATUS_REQUEST: EQU 0FEH ; Flag to indicate the Z80 has made a request to the K64F. +TZSVC_STATUS_PROCESSING:EQU 0FFH ; Flag to indicate the K64F is processing a command. diff --git a/software/asm/include/CPM_Definitions.asm b/software/asm/include/CPM_Definitions.asm index 4d20385..c74c94f 100644 --- a/software/asm/include/CPM_Definitions.asm +++ b/software/asm/include/CPM_Definitions.asm @@ -305,16 +305,21 @@ TZSVCSECSIZE: EQU 512 TZSVCDIR_ENTSZ: EQU 32 ; Size of a directory entry. TZSVCWAITIORETRIES: EQU 500 ; Wait retries for IO response. TZSVCWAITCOUNT: EQU 65535 ; Wait retries for IO request response. +TZSVC_FTYPE_MZF: EQU 0 ; File type being handled is an MZF +TZSVC_FTYPE_CAS: EQU 1 ; File type being handled is an CASsette BASIC script. +TZSVC_FTYPE_BAS: EQU 2 ; File type being handled is an BASic script TZSVC_CMD_READDIR: EQU 01H ; Service command to open a directory and return the first block of entries. TZSVC_CMD_NEXTDIR: EQU 02H ; Service command to return the next block of an open directory. TZSVC_CMD_READFILE: EQU 03H ; Service command to open a file and return the first block. -TZSVC_CMD_MEXTREADFILE: EQU 04H ; Service command to return the next block of an open file. -TZSVC_CMD_CLOSE: EQU 05H ; Service command to close any open file or directory. -TZSVC_CMD_LOADFILE: EQU 06H ; Service command to load a file directly into tranZPUter memory. -TZSVC_CMD_SAVEFILE: EQU 07H ; Service command to save a file directly from tranZPUter memory. -TZSVC_CMD_ERASEFILE: EQU 08H ; Service command to erase a file on the SD card. -TZSVC_CMD_CHANGEDIR: EQU 09H ; Service command to change the active directory on the SD card. +TZSVC_CMD_NEXTREADFILE: EQU 04H ; Service command to return the next block of an open file. +TZSVC_CMD_WRITEFILE: EQU 05H ; Service command to create a file and save the first block. +TZSVC_CMD_NEXTWRITEFILE:EQU 06H ; Service command to write the next block to the open file. +TZSVC_CMD_CLOSE: EQU 07H ; Service command to close any open file or directory. +TZSVC_CMD_LOADFILE: EQU 08H ; Service command to load a file directly into tranZPUter memory. +TZSVC_CMD_SAVEFILE: EQU 09H ; Service command to save a file directly from tranZPUter memory. +TZSVC_CMD_ERASEFILE: EQU 0aH ; Service command to erase a file on the SD card. +TZSVC_CMD_CHANGEDIR: EQU 0bH ; Service command to change the active directory on the SD card. TZSVC_CMD_LOAD40BIOS: EQU 20H ; Service command requesting that the 40 column version of the SA1510 BIOS is loaded. TZSVC_CMD_LOAD80BIOS: EQU 21H ; Service command requesting that the 80 column version of the SA1510 BIOS is loaded. TZSVC_CMD_LOAD700BIOS40:EQU 22H ; Service command requesting that the MZ700 1Z-013A 40 column BIOS is loaded. diff --git a/software/asm/include/TZFS_Definitions.asm b/software/asm/include/TZFS_Definitions.asm index 289c0f3..466bca5 100644 --- a/software/asm/include/TZFS_Definitions.asm +++ b/software/asm/include/TZFS_Definitions.asm @@ -357,6 +357,9 @@ TZSVCSECSIZE: EQU 512 TZSVCDIR_ENTSZ: EQU 32 ; Size of a directory entry. TZSVCWAITIORETRIES: EQU 5 ; Wait retries for IO response. TZSVCWAITCOUNT: EQU 65535 ; Wait retries for IO request response. +TZSVC_FTYPE_MZF: EQU 0 ; File type being handled is an MZF +TZSVC_FTYPE_CAS: EQU 1 ; File type being handled is an CASsette BASIC script. +TZSVC_FTYPE_BAS: EQU 2 ; File type being handled is an BASic script TZSVCCMD: DS virtual 1 ; Service command. TZSVCRESULT: DS virtual 1 ; Service command result. TZSVCDIRSEC: DS virtual 1 ; Storage for the directory sector number. @@ -364,9 +367,12 @@ TZSVC_FILE_SEC: EQU TZSVCDIRSEC ; Union TZSVC_TRACK_NO: DS virtual 2 ; Storage for the virtual drive track number. TZSVC_SECTOR_NO: DS virtual 2 ; Storage for the virtual drive sector number. TZSVC_FILE_NO: DS virtual 1 ; File number to be opened in a file service command. +TZSVC_FILE_TYPE: DS virtual 1 ; Type of file being accessed to differentiate between Sharp MZF files and other handled files. TZSVC_LOADADDR: DS virtual 2 ; Dynamic load address for rom/images. +TZSVC_SAVEADDR: EQU TZSVC_LOADADDR ; Union of the load address and the cpu frequency change value, the address of data to be saved. +TZSVC_CPU_FREQ: EQU TZSVC_LOADADDR ; Union of the load address and the save address value, only one can be used at a time. TZSVC_LOADSIZE: DS virtual 2 ; Size of image to load. -TZSVC_CPU_FREQ: EQU TZSVC_LOADADDR ; Union of the load address and the cpu frequency change value, only one can be used at a time. +TZSVC_SAVESIZE: EQU TZSVC_LOADSIZE ; Size of image to be saved. TZSVC_DIRNAME: DS virtual TZSVCDIRSZ ; Service directory/file name. TZSVC_FILENAME: DS virtual TZSVCFILESZ ; Filename to be opened/created. TZSVCWILDC: DS virtual TZSVCWILDSZ ; Directory wildcard for file pattern matching. @@ -375,12 +381,14 @@ TZSVCSECTOR: DS virtual TZSVCSECSIZE ; Servi TZSVC_CMD_READDIR: EQU 01H ; Service command to open a directory and return the first block of entries. TZSVC_CMD_NEXTDIR: EQU 02H ; Service command to return the next block of an open directory. TZSVC_CMD_READFILE: EQU 03H ; Service command to open a file and return the first block. -TZSVC_CMD_MEXTREADFILE: EQU 04H ; Service command to return the next block of an open file. -TZSVC_CMD_CLOSE: EQU 05H ; Service command to close any open file or directory. -TZSVC_CMD_LOADFILE: EQU 06H ; Service command to load a file directly into tranZPUter memory. -TZSVC_CMD_SAVEFILE: EQU 07H ; Service command to save a file directly from tranZPUter memory. -TZSVC_CMD_ERASEFILE: EQU 08H ; Service command to erase a file on the SD card. -TZSVC_CMD_CHANGEDIR: EQU 09H ; Service command to change the active directory on the SD card. +TZSVC_CMD_NEXTREADFILE: EQU 04H ; Service command to return the next block of an open file. +TZSVC_CMD_WRITEFILE: EQU 05H ; Service command to create a file and save the first block. +TZSVC_CMD_NEXTWRITEFILE:EQU 06H ; Service command to write the next block to the open file. +TZSVC_CMD_CLOSE: EQU 07H ; Service command to close any open file or directory. +TZSVC_CMD_LOADFILE: EQU 08H ; Service command to load a file directly into tranZPUter memory. +TZSVC_CMD_SAVEFILE: EQU 09H ; Service command to save a file directly from tranZPUter memory. +TZSVC_CMD_ERASEFILE: EQU 0aH ; Service command to erase a file on the SD card. +TZSVC_CMD_CHANGEDIR: EQU 0bH ; Service command to change the active directory on the SD card. TZSVC_CMD_LOAD40BIOS: EQU 20H ; Service command requesting that the 40 column version of the SA1510 BIOS is loaded. TZSVC_CMD_LOAD80BIOS: EQU 21H ; Service command requesting that the 80 column version of the SA1510 BIOS is loaded. TZSVC_CMD_LOAD700BIOS40:EQU 22H ; Service command requesting that the MZ700 1Z-013A 40 column BIOS is loaded. diff --git a/software/asm/nascombasic.asm b/software/asm/nascombasic.asm new file mode 100644 index 0000000..8ddbdbb --- /dev/null +++ b/software/asm/nascombasic.asm @@ -0,0 +1,4853 @@ +; NASCOM ROM BASIC Ver 4.7, (C) 1978 Microsoft +; Scanned from source published in 80-BUS NEWS from Vol 2, Issue 3 +; (May-June 1983) to Vol 3, Issue 3 (May-June 1984) +; Adapted for the freeware Zilog Macro Assembler 2.10 to produce +; the original ROM code (checksum A934H). PA + +; MONITOR EQUATES (RESTART INSTRUCTIONS) + +_ROUT EQU 0F7H ; ROUT - Output char in A +_BLNK EQU 07BDFH ; SCAL BLINK - Get input char in A +_INLN EQU 063DFH ; SCAL INLIN - Get input line +_MFLP EQU 05FDFH ; SCAL MFLP - Toggle tape drv LED +_MRET EQU 05BDFH ; SCAL MRET - Return to monitor +_READ EQU 052DFH ; SCAL READ +_RIN EQU 062DFH ; SCAL RIN - Scan for input char +_VRFY EQU 056DFH ; SCAL VERIFY +_WRIT EQU 057DFH ; SCAL WRITE + +; GENERAL EQUATES + +UARTD EQU 01H ; UART data port +UARTS EQU 02H ; UART status port +CTRLC EQU 03H ; Control "C" +CTRLG EQU 07H ; Control "G" +BKSP EQU 08H ; Back space +LF EQU 0AH ; Line feed +CS EQU 0CH ; Clear screen +CR EQU 0DH ; Carriage return +CTRLO EQU 0FH ; Control "O" +CTRLR EQU 12H ; Control "R" +CTRLS EQU 13H ; Control "S" +CTRLU EQU 15H ; Control "U" +CTRLZ EQU 1AH ; Control "Z" +ESC EQU 1BH ; Escape +TBRK EQU 1CH ; "T" monitor break +TBS EQU 1DH ; "T" monitor back space +TCS EQU 1EH ; "T" monitor clear screen +TCR EQU 1FH ; "T" monitor carriage return +DEL EQU 7FH ; Delete + +; MONITOR LOCATIONS + +MONSTT EQU 0000H ; Start of monitor +STMON EQU 000DH ; NAS-SYS initialisation +MFLP EQU 0051H ; Flip tape LED ("T") +MONTYP EQU 008DH ; Type of "T" monitor +T2DUMP EQU 03D1H ; "T2" Dump routine +T4WR EQU 0400H ; "T4" Write routine +T4READ EQU 070CH ; "T4" Read routine +VDU EQU 0800H ; NASCOM Video RAM base + +; MONITOR WORK SPACE LOCATIONS + +PORT0 EQU 0C00H ; Copy of output port 0 +ARG1 EQU 0C0CH ; Argument 1 +ARG2 EQU 0C0EH ; Argument 2 +TCUR EQU 0C18H ; "T" monitor cursor +CURSOR EQU 0C29H ; NAS-SYS Cursor +ARGN EQU 0C2BH ; Number of ARGS +TOUT EQU 0C4AH ; "T" Output reflection +TIN EQU 0C4DH ; "T" Input reflection +CIN EQU 0C75H ; NAS-SYS Input table +NMI EQU 0C7EH ; NAS-SYS NMI Jump + +; BASIC WORK SPACE LOCATIONS + +WRKSPC EQU 1000H ; BASIC Work space +USR EQU 1003H ; "USR (x)" jump +OUTSUB EQU 1006H ; "OUT p,n" +OTPORT EQU 1007H ; Port (p) +DIVSUP EQU 1009H ; Division support routine +DIV1 EQU 100AH ; <- Values +DIV2 EQU 100EH ; <- to +DIV3 EQU 1012H ; <- be +DIV4 EQU 1015H ; <-inserted +SEED EQU 1017H ; Random number seed +LSTRND EQU 103AH ; Last random number +INPSUB EQU 103EH ; #INP (x)" Routine +INPORT EQU 103FH ; PORT (x) +NULLS EQU 1041H ; Number of nulls +LWIDTH EQU 1042H ; Terminal width +COMMAN EQU 1043H ; Width for commas +NULFLG EQU 1044H ; Null after input byte flag +CTLOFG EQU 1045H ; Control "O" flag +LINESC EQU 1046H ; Lines counter +LINESN EQU 1048H ; Lines number +CHKSUM EQU 104AH ; Array load/save check sum +NMIFLG EQU 104CH ; Flag for NMI break routine +BRKFLG EQU 104DH ; Break flag +RINPUT EQU 104EH ; Input reflection +POINT EQU 1051H ; "POINT" reflection (unused) +PSET EQU 1054H ; "SET" reflection +RESET EQU 1057H ; "RESET" reflection +STRSPC EQU 105AH ; Bottom of string space +LINEAT EQU 105CH ; Current line number +BASTXT EQU 105EH ; Pointer to start of program +BUFFER EQU 1061H ; Input buffer +STACK EQU 1066H ; Initial stack +CURPOS EQU 10ABH ; Character position on line +LCRFLG EQU 10ACH ; Locate/Create flag +TYPE EQU 10ADH ; Data type flag +DATFLG EQU 10AEH ; Literal statement flag +LSTRAM EQU 10AFH ; Last available RAM +TMSTPT EQU 10B1H ; Temporary string pointer +TMSTPL EQU 10B3H ; Temporary string pool +TMPSTR EQU 10BFH ; Temporary string +STRBOT EQU 10C3H ; Bottom of string space +CUROPR EQU 10C5H ; Current operator in EVAL +LOOPST EQU 10C7H ; First statement of loop +DATLIN EQU 10C9H ; Line of current DATA item +FORFLG EQU 10CBH ; "FOR" loop flag +LSTBIN EQU 10CCH ; Last byte entered +READFG EQU 10CDH ; Read/Input flag +BRKLIN EQU 10CEH ; Line of break +NXTOPR EQU 10D0H ; Next operator in EVAL +ERRLIN EQU 10D2H ; Line of error +CONTAD EQU 10D4H ; Where to CONTinue +PROGND EQU 10D6H ; End of program +VAREND EQU 10D8H ; End of variables +ARREND EQU 10DAH ; End of arrays +NXTDAT EQU 10DCH ; Next data item +FNRGNM EQU 10DEH ; Name of FN argument +FNARG EQU 10E0H ; FN argument value +FPREG EQU 10E4H ; Floating point register +FPEXP EQU FPREG+3 ; Floating point exponent +SGNRES EQU 10E8H ; Sign of result +PBUFF EQU 10E9H ; Number print buffer +MULVAL EQU 10F6H ; Multiplier +PROGST EQU 10F9H ; Start of program text area +STLOOK EQU 115DH ; Start of memory test + +; BASIC ERROR CODE VALUES + +NF EQU 00H ; NEXT without FOR +SN EQU 02H ; Syntax error +RG EQU 04H ; RETURN without GOSUB +OD EQU 06H ; Out of DATA +FC EQU 08H ; Function call error +OV EQU 0AH ; Overflow +OM EQU 0CH ; Out of memory +UL EQU 0EH ; Undefined line number +BS EQU 10H ; Bad subscript +DD EQU 12H ; Re-DIMensioned array +DZ EQU 14H ; Division by zero (/0) +ID EQU 16H ; Illegal direct +TM EQU 18H ; Type miss-match +OS EQU 1AH ; Out of string space +LS EQU 1CH ; String too long +ST EQU 1EH ; String formula too complex +CN EQU 20H ; Can't CONTinue +UF EQU 22H ; UnDEFined FN function +MO EQU 24H ; Missing operand + + ORG 0E000H + +START: JP STARTB ; Jump for restart jump +STARTB: DI ; No interrupts + LD IX,0 ; Flag cold start + JP CSTART ; Jump to initialise + + DW DEINT ; Get integer -32768 to 32767 + DW ABPASS ; Return integer in AB + + JP LDNMI1 ; << NO REFERENCE TO HERE >> + +CSTART: LD HL,WRKSPC ; Start of workspace RAM + LD SP,HL ; Set up a temporary stack + JP INITST ; Go to initialise + +INIT: LD DE,INITAB ; Initialise workspace + LD B,INITBE-INITAB+3; Bytes to copy + LD HL,WRKSPC ; Into workspace RAM +COPY: LD A,(DE) ; Get source + LD (HL),A ; To destination + INC HL ; Next destination + INC DE ; Next source + DEC B ; Count bytes + JP NZ,COPY ; More to move + LD SP,HL ; Temporary stack + CALL CLREG ; Clear registers and stack + CALL PRNTCR ; Output CRLF + LD (BUFFER+72+1),A ; Mark end of buffer + LD (PROGST),A ; Initialise program area +MSIZE: LD HL,MEMMSG ; Point to message + CALL PRS ; Output "Memory size" + CALL PROMPT ; Get input with "?" + CALL GETCHR ; Get next character + OR A ; Set flags + JP NZ,TSTMEM ; If number - Test if RAM there + LD HL,STLOOK ; Point to start of RAM +MLOOP: INC HL ; Next byte + LD A,H ; Above address FFFF ? + OR L + JP Z,SETTOP ; Yes - 64K RAM + LD A,(HL) ; Get contents + LD B,A ; Save it + CPL ; Flip all bits + LD (HL),A ; Put it back + CP (HL) ; RAM there if same + LD (HL),B ; Restore old contents + JP Z,MLOOP ; If RAM - test next byte + JP SETTOP ; Top of RAM found + +TSTMEM: CALL ATOH ; Get high memory into DE + OR A ; Set flags on last byte + JP NZ,SNERR ; ?SN Error if bad character + EX DE,HL ; Address into HL + DEC HL ; Back one byte + LD A,11011001B ; Test byte + LD B,(HL) ; Get old contents + LD (HL),A ; Load test byte + CP (HL) ; RAM there if same + LD (HL),B ; Restore old contents + JP NZ,MSIZE ; Ask again if no RAM + +SETTOP: DEC HL ; Back one byte + LD DE,STLOOK-1 ; See if enough RAM + CALL CPDEHL ; Compare DE with HL + JP C,MSIZE ; Ask again if not enough RAM + NOP + NOP + NOP + NOP + NOP + NOP + NOP + NOP + NOP + LD DE,0-50 ; 50 Bytes string space + LD (LSTRAM),HL ; Save last available RAM + ADD HL,DE ; Allocate string space + LD (STRSPC),HL ; Save string space + CALL CLRPTR ; Clear program area + LD HL,(STRSPC) ; Get end of memory + LD DE,0-17 ; Offset for free bytes + ADD HL,DE ; Adjust HL + LD DE,PROGST ; Start of program text + LD A,L ; Get LSB + SUB E ; Adjust it + LD L,A ; Re-save + LD A,H ; Get MSB + SBC A,D ; Adjust it + LD H,A ; Re-save + PUSH HL ; Save bytes free + LD HL,SIGNON ; Sign-on message + CALL PRS ; Output string + POP HL ; Get bytes free back + CALL PRNTHL ; Output amount of free memory + LD HL,BFREE ; " Bytes free" message + CALL PRS ; Output string + +WARMST: LD SP,STACK ; Temporary stack +BRKRET: CALL CLREG ; Clear registers and stack + JP PRNTOK ; Go to get command line + +BFREE: DB " Bytes free",CR,0,0 + +SIGNON: DB "NASCOM ROM BASIC Ver 4.7 ",CR + DB "Copyright (C) 1978 by Microsoft",CR,0,0 + +MEMMSG: DB "Memory size",0 + +; FUNCTION ADDRESS TABLE + +FNCTAB: DW SGN + DW INT + DW ABS + DW USR + DW FRE + DW INP + DW POS + DW SQR + DW RND + DW LOG + DW EXP + DW COS + DW SIN + DW TAN + DW ATN + DW PEEK + DW DEEK + DW POINT + DW LEN + DW STR + DW VAL + DW ASC + DW CHR + DW LEFT + DW RIGHT + DW MID + +; RESERVED WORD LIST + +WORDS: DB "E"+80H,"ND" + DB "F"+80H,"OR" + DB "N"+80H,"EXT" + DB "D"+80H,"ATA" + DB "I"+80H,"NPUT" + DB "D"+80H,"IM" + DB "R"+80H,"EAD" + DB "L"+80H,"ET" + DB "G"+80H,"OTO" + DB "R"+80H,"UN" + DB "I"+80H,"F" + DB "R"+80H,"ESTORE" + DB "G"+80H,"OSUB" + DB "R"+80H,"ETURN" + DB "R"+80H,"EM" + DB "S"+80H,"TOP" + DB "O"+80H,"UT" + DB "O"+80H,"N" + DB "N"+80H,"ULL" + DB "W"+80H,"AIT" + DB "D"+80H,"EF" + DB "P"+80H,"OKE" + DB "D"+80H,"OKE" + DB "S"+80H,"CREEN" + DB "L"+80H,"INES" + DB "C"+80H,"LS" + DB "W"+80H,"IDTH" + DB "M"+80H,"ONITOR" + DB "S"+80H,"ET" + DB "R"+80H,"ESET" + DB "P"+80H,"RINT" + DB "C"+80H,"ONT" + DB "L"+80H,"IST" + DB "C"+80H,"LEAR" + DB "C"+80H,"LOAD" + DB "C"+80H,"SAVE" + DB "N"+80H,"EW" + DB "T"+80H,"AB(" + DB "T"+80H,"O" + DB "F"+80H,"N" + DB "S"+80H,"PC(" + DB "T"+80H,"HEN" + DB "N"+80H,"OT" + DB "S"+80H,"TEP" + + DB "+"+80H + DB "-"+80H + DB "*"+80H + DB "/"+80H + DB "^"+80H + DB "A"+80H,"ND" + DB "O"+80H,"R" + DB ">"+80H + DB "="+80H + DB "<"+80H + + DB "S"+80H,"GN" + DB "I"+80H,"NT" + DB "A"+80H,"BS" + DB "U"+80H,"SR" + DB "F"+80H,"RE" + DB "I"+80H,"NP" + DB "P"+80H,"OS" + DB "S"+80H,"QR" + DB "R"+80H,"ND" + DB "L"+80H,"OG" + DB "E"+80H,"XP" + DB "C"+80H,"OS" + DB "S"+80H,"IN" + DB "T"+80H,"AN" + DB "A"+80H,"TN" + DB "P"+80H,"EEK" + DB "D"+80H,"EEK" + DB "P"+80H,"OINT" + DB "L"+80H,"EN" + DB "S"+80H,"TR$" + DB "V"+80H,"AL" + DB "A"+80H,"SC" + DB "C"+80H,"HR$" + DB "L"+80H,"EFT$" + DB "R"+80H,"IGHT$" + DB "M"+80H,"ID$" + DB 80H ; End of list marker + +; KEYWORD ADDRESS TABLE + +WORDTB: DW PEND + DW FOR + DW NEXT + DW DATA + DW INPUT + DW DIM + DW READ + DW LET + DW GOTO + DW RUN + DW IF + DW RESTOR + DW GOSUB + DW RETURN + DW REM + DW STOP + DW POUT + DW ON + DW NULL + DW WAIT + DW DEF + DW POKE + DW DOKE + DW SCREEN + DW LINES + DW CLS + DW WIDTH + DW MONITR + DW PSET + DW RESET + DW PRINT + DW CONT + DW LIST + DW CLEAR + DW CLOAD + DW CSAVE + DW NEW + +; RESERVED WORD TOKEN VALUES + +ZEND EQU 080H ; END +ZFOR EQU 081H ; FOR +ZDATA EQU 083H ; DATA +ZGOTO EQU 088H ; GOTO +ZGOSUB EQU 08CH ; GOSUB +ZREM EQU 08EH ; REM +ZPRINT EQU 09EH ; PRINT +ZNEW EQU 0A4H ; NEW + +ZTAB EQU 0A5H ; TAB +ZTO EQU 0A6H ; TO +ZFN EQU 0A7H ; FN +ZSPC EQU 0A8H ; SPC +ZTHEN EQU 0A9H ; THEN +ZNOT EQU 0AAH ; NOT +ZSTEP EQU 0ABH ; STEP + +ZPLUS EQU 0ACH ; + +ZMINUS EQU 0ADH ; - +ZTIMES EQU 0AEH ; * +ZDIV EQU 0AFH ; / +ZOR EQU 0B2H ; OR +ZGTR EQU 0B3H ; > +ZEQUAL EQU 0B4H ; M +ZLTH EQU 0B5H ; < +ZSGN EQU 0B6H ; SGN +ZPOINT EQU 0C7H ; POINT +ZLEFT EQU 0CDH ; LEFT$ + +; ARITHMETIC PRECEDENCE TABLE + +PRITAB: DB 79H ; Precedence value + DW PADD ; FPREG = + FPREG + + DB 79H ; Precedence value + DW PSUB ; FPREG = - FPREG + + DB 7CH ; Precedence value + DW MULT ; PPREG = * FPREG + + DB 7CH ; Precedence value + DW DIV ; FPREG = / FPREG + + DB 7FH ; Precedence value + DW POWER ; FPREG = ^ FPREG + + DB 50H ; Precedence value + DW PAND ; FPREG = AND FPREG + + DB 46H ; Precedence value + DW POR ; FPREG = OR FPREG + +; BASIC ERROR CODE LIST + +ERRORS: DB "NF" ; NEXT without FOR + DB "SN" ; Syntax error + DB "RG" ; RETURN without GOSUB + DB "OD" ; Out of DATA + DB "FC" ; Illegal function call + DB "OV" ; Overflow error + DB "OM" ; Out of memory + DB "UL" ; Undefined line + DB "BS" ; Bad subscript + DB "DD" ; Re-DIMensioned array + DB "/0" ; Division by zero + DB "ID" ; Illegal direct + DB "TM" ; Type mis-match + DB "OS" ; Out of string space + DB "LS" ; String too long + DB "ST" ; String formula too complex + DB "CN" ; Can't CONTinue + DB "UF" ; Undefined FN function + DB "MO" ; Missing operand + +; INITIALISATION TABLE + +INITAB: JP WARMST ; Warm start jump + JP FCERR ; "USR (X)" jump (Set to Error) + + OUT (0),A ; "OUT p,n" skeleton + RET + + SUB 0 ; Division support routine + LD L,A + LD A,H + SBC A,0 + LD H,A + LD A,B + SBC A,0 + LD B,A + LD A,0 + RET + + DB 0,0,0 ; Random number seed + ; Table used by RND + DB 035H,04AH,0CAH,099H ;-2.65145E+07 + DB 039H,01CH,076H,098H ; 1.61291E+07 + DB 022H,095H,0B3H,098H ;-1.17691E+07 + DB 00AH,0DDH,047H,098H ; 1.30983E+07 + DB 053H,0D1H,099H,099H ;-2-01612E+07 + DB 00AH,01AH,09FH,098H ;-1.04269E+07 + DB 065H,0BCH,0CDH,098H ;-1.34831E+07 + DB 0D6H,077H,03EH,098H ; 1.24825E+07 + DB 052H,0C7H,04FH,080H ; Last random number + + IN A,(0) ; INP (x) skeleton + RET + + DB 1 ; POS (x) number (1) + DB 47 ; Terminal width (47) + DB 28 ; Width for commas (3 columns) + DB 0 ; No nulls after input bytes + DB 0 ; Output enabled (^O off) + + DW 5 ; Initial lines counter + DW 5 ; Initial lines number + DW 0 ; Array load/save check sum + + DB 0 ; Break not by NMI + DB 0 ; Break flag + + JP TTYLIN ; Input reflection (set to TTY) + JP POINTB ; POINT reflection unused + JP SETB ; SET reflection + JP RESETB ; RESET reflection + + DW STLOOK ; Temp string space + DW -2 ; Current line number (cold) + DW PROGST+1 ; Start of program text +INITBE: ; END OF INITIALISATION TABLE + +ERRMSG: DB " Error",0 +INMSG: DB " in ",0 +ZERBYT EQU $-1 ; A zero byte +OKMSG: DB "Ok",CR,0,0 +BRKMSG: DB "Break",0 + +BAKSTK: LD HL,4 ; Look for "FOR" block with + ADD HL,SP ; same index as specified +LOKFOR: LD A,(HL) ; Get block ID + INC HL ; Point to index address + CP ZFOR ; Is it a "FOR" token + RET NZ ; No - exit + LD C,(HL) ; BC = Address of "FOR" index + INC HL + LD B,(HL) + INC HL ; Point to sign of STEP + PUSH HL ; Save pointer to sign + LD L,C ; HL = address of "FOR" index + LD H,B + LD A,D ; See if an index was specified + OR E ; DE = 0 if no index specified + EX DE,HL ; Specified index into HL + JP Z,INDFND ; Skip if no index given + EX DE,HL ; Index back into DE + CALL CPDEHL ; Compare index with one given +INDFND: LD BC,16-3 ; Offset to next block + POP HL ; Restore pointer to sign + RET Z ; Return if block found + ADD HL,BC ; Point to next block + JP LOKFOR ; Keep on looking + +MOVUP: CALL ENFMEM ; See if enough memory +MOVSTR: PUSH BC ; Save end of source + EX (SP),HL ; Swap source and dest" end + POP BC ; Get end of destination +MOVLP: CALL CPDEHL ; See if list moved + LD A,(HL) ; Get byte + LD (BC),A ; Move it + RET Z ; Exit if all done + DEC BC ; Next byte to move to + DEC HL ; Next byte to move + JP MOVLP ; Loop until all bytes moved + +CHKSTK: PUSH HL ; Save code string address + LD HL,(ARREND) ; Lowest free memory + LD B,0 ; BC = Number of levels to test + ADD HL,BC ; 2 Bytes for each level + ADD HL,BC + DB 3EH ; Skip "PUSH HL" +ENFMEM: PUSH HL ; Save code string address + LD A,LOW -48 ; 48 Bytes minimum RAM + SUB L + LD L,A + LD A,HIGH -48 ; 48 Bytes minimum RAM + SBC A,H + JP C,OMERR ; Not enough - ?OM Error + LD H,A + ADD HL,SP ; Test if stack is overflowed + POP HL ; Restore code string address + RET C ; Return if enough mmory +OMERR: LD E,OM ; ?OM Error + JP ERROR + +DATSNR: LD HL,(DATLIN) ; Get line of current DATA item + LD (LINEAT),HL ; Save as current line +SNERR: LD E,SN ; ?SN Error + DB 01H ; Skip "LD E,DZ" +DZERR: LD E,DZ ; ?/0 Error + DB 01H ; Skip "LD E,NF" +NFERR: LD E,NF ; ?NF Error + DB 01H ; Skip "LD E,DD" +DDERR: LD E,DD ; ?DD Error + DB 01H ; Skip "LD E,UF" +UFERR: LD E,UF ; ?UF Error + DB 01H ; Skip "LD E,OV +OVERR: LD E,OV ; ?OV Error + DB 01H ; Skip "LD E,TM" +TMERR: LD E,TM ; ?TM Error + +ERROR: CALL CLREG ; Clear registers and stack + LD (CTLOFG),A ; Enable output (A is 0) + CALL STTLIN ; Start new line + LD HL,ERRORS ; Point to error codes + LD D,A ; D = 0 (A is 0) + LD A,"?" + CALL OUTC ; Output "?" + ADD HL,DE ; Offset to correct error code + LD A,(HL) ; First character + CALL OUTC ; Output it + CALL GETCHR ; Get next character + CALL OUTC ; Output it + LD HL,ERRMSG ; "Error" message +ERRIN: CALL PRS ; Output message + LD HL,(LINEAT) ; Get line of error + LD DE,-2 ; Cold start error if -2 + CALL CPDEHL ; See if cold start error + JP Z,CSTART ; Cold start error - Restart + LD A,H ; Was it a direct error? + AND L ; Line = -1 if direct error + INC A + CALL NZ,LINEIN ; No - output line of error + DB 3EH ; Skip "POP BC" +POPNOK: POP BC ; Drop address in input buffer + +PRNTOK: XOR A ; Output "Ok" and get command + LD (CTLOFG),A ; Enable output + CALL STTLIN ; Start new line + LD HL,OKMSG ; "Ok" message + CALL PRS ; Output "Ok" +GETCMD: LD HL,-1 ; Flag direct mode + LD (LINEAT),HL ; Save as current line + CALL GETLIN ; Get an input line + JP C,GETCMD ; Get line again if break + CALL GETCHR ; Get first character + INC A ; Test if end of line + DEC A ; Without affecting Carry + JP Z,GETCMD ; Nothing entered - Get another + PUSH AF ; Save Carry status + CALL ATOH ; Get line number into DE + PUSH DE ; Save line number + CALL CRUNCH ; Tokenise rest of line + LD B,A ; Length of tokenised line + POP DE ; Restore line number + POP AF ; Restore Carry + JP NC,EXCUTE ; No line number - Direct mode + PUSH DE ; Save line number + PUSH BC ; Save length of tokenised line + XOR A + LD (LSTBIN),A ; Clear last byte input + CALL GETCHR ; Get next character + OR A ; Set flags + PUSH AF ; And save them + CALL SRCHLN ; Search for line number in DE + JP C,LINFND ; Jump if line found + POP AF ; Get status + PUSH AF ; And re-save + JP Z,ULERR ; Nothing after number - Error + OR A ; Clear Carry +LINFND: PUSH BC ; Save address of line in prog + JP NC,INEWLN ; Line not found - Insert new + EX DE,HL ; Next line address in DE + LD HL,(PROGND) ; End of program +SFTPRG: LD A,(DE) ; Shift rest of program down + LD (BC),A + INC BC ; Next destination + INC DE ; Next source + CALL CPDEHL ; All done? + JP NZ,SFTPRG ; More to do + LD H,B ; HL - New end of program + LD L,C + LD (PROGND),HL ; Update end of program + +INEWLN: POP DE ; Get address of line, + POP AF ; Get status + JP Z,SETPTR ; No text - Set up pointers + LD HL,(PROGND) ; Get end of program + EX (SP),HL ; Get length of input line + POP BC ; End of program to BC + ADD HL,BC ; Find new end + PUSH HL ; Save new end + CALL MOVUP ; Make space for line + POP HL ; Restore new end + LD (PROGND),HL ; Update end of program pointer + EX DE,HL ; Get line to move up in HL + LD (HL),H ; Save MSB + POP DE ; Get new line number + INC HL ; Skip pointer + INC HL + LD (HL),E ; Save LSB of line number + INC HL + LD (HL),D ; Save MSB of line number + INC HL ; To first byte in line + LD DE,BUFFER ; Copy buffer to program +MOVBUF: LD A,(DE) ; Get source + LD (HL),A ; Save destinations + INC HL ; Next source + INC DE ; Next destination + OR A ; Done? + JP NZ,MOVBUF ; No - Repeat +SETPTR: CALL RUNFST ; Set line pointers + INC HL ; To LSB of pointer + EX DE,HL ; Address to DE +PTRLP: LD H,D ; Address to HL + LD L,E + LD A,(HL) ; Get LSB of pointer + INC HL ; To MSB of pointer + OR (HL) ; Compare with MSB pointer + JP Z,GETCMD ; Get command line if end + INC HL ; To LSB of line number + INC HL ; Skip line number + INC HL ; Point to first byte in line + XOR A ; Looking for 00 byte +FNDEND: CP (HL) ; Found end of line? + INC HL ; Move to next byte + JP NZ,FNDEND ; No - Keep looking + EX DE,HL ; Next line address to HL + LD (HL),E ; Save LSB of pointer + INC HL + LD (HL),D ; Save MSB of pointer + JP PTRLP ; Do next line + +SRCHLN: LD HL,(BASTXT) ; Start of program text +SRCHLP: LD B,H ; BC = Address to look at + LD C,L + LD A,(HL) ; Get address of next line + INC HL + OR (HL) ; End of program found? + DEC HL + RET Z ; Yes - Line not found + INC HL + INC HL + LD A,(HL) ; Get LSB of line number + INC HL + LD H,(HL) ; Get MSB of line number + LD L,A + CALL CPDEHL ; Compare with line in DE + LD H,B ; HL = Start of this line + LD L,C + LD A,(HL) ; Get LSB of next line address + INC HL + LD H,(HL) ; Get MSB of next line address + LD L,A ; Next line to HL + CCF + RET Z ; Lines found - Exit + CCF + RET NC ; Line not found,at line after + JP SRCHLP ; Keep looking + +NEW: RET NZ ; Return if any more on line +CLRPTR: LD HL,(BASTXT) ; Point to start of program + XOR A ; Set program area to empty + LD (HL),A ; Save LSB = 00 + INC HL + LD (HL),A ; Save MSB = 00 + INC HL + LD (PROGND),HL ; Set program end + +RUNFST: LD HL,(BASTXT) ; Clear all variables + DEC HL + +INTVAR: LD (BRKLIN),HL ; Initialise RUN variables + LD HL,(LSTRAM) ; Get end of RAM + LD (STRBOT),HL ; Clear string space + XOR A + CALL RESTOR ; Reset DATA pointers + LD HL,(PROGND) ; Get end of program + LD (VAREND),HL ; Clear variables + LD (ARREND),HL ; Clear arrays + +CLREG: POP BC ; Save return address + LD HL,(STRSPC) ; Get end of working RAN + LD SP,HL ; Set stack + LD HL,TMSTPL ; Temporary string pool + LD (TMSTPT),HL ; Reset temporary string ptr + XOR A ; A = 00 + LD L,A ; HL = 0000 + LD H,A + LD (CONTAD),HL ; No CONTinue + LD (FORFLG),A ; Clear FOR flag + LD (FNRGNM),HL ; Clear FN argument + PUSH HL ; HL = 0000 + PUSH BC ; Put back return +DOAGN: LD HL,(BRKLIN) ; Get address of code to RUN + RET ; Return to execution driver + +PROMPT: LD A,"?" ; "?" + CALL OUTC ; Output character + LD A," " ; Space + CALL OUTC ; Output character + JP RINPUT ; Get input line + +CRUNCH: XOR A ; Tokenise line @ HL to BUFFER + LD (DATFLG),A ; Reset literal flag + LD C,2+3 ; 2 byte number and 3 nulls + LD DE,BUFFER ; Start of input buffer +CRNCLP: LD A,(HL) ; Get byte + CP " " ; Is it a space? + JP Z,MOVDIR ; Yes - Copy direct + LD B,A ; Save character + CP '"' ; Is it a quote? + JP Z,CPYLIT ; Yes - Copy literal string + OR A ; Is it end of buffer? + JP Z,ENDBUF ; Yes - End buffer + LD A,(DATFLG) ; Get data type + OR A ; Literal? + LD A,(HL) ; Get byte to copy + JP NZ,MOVDIR ; Literal - Copy direct + CP "?" ; Is it "?" short for PRINT + LD A,ZPRINT ; "PRINT" token + JP Z,MOVDIR ; Yes - replace it + LD A,(HL) ; Get byte again + CP "0" ; Is it less than "0" + JP C,FNDWRD ; Yes - Look for reserved words + CP ";"+1 ; Is it "0123456789:;" ? + JP C,MOVDIR ; Yes - copy it direct +FNDWRD: PUSH DE ; Look for reserved words + LD DE,WORDS-1 ; Point to table + PUSH BC ; Save count + LD BC,RETNAD ; Where to return to + PUSH BC ; Save return address + LD B,ZEND-1 ; First token value -1 + LD A,(HL) ; Get byte + CP "a" ; Less than "a" ? + JP C,SEARCH ; Yes - search for words + CP "z"+1 ; Greater than "z" ? + JP NC,SEARCH ; Yes - search for words + AND 01011111B ; Force upper case + LD (HL),A ; Replace byte +SEARCH: LD C,(HL) ; Search for a word + EX DE,HL +GETNXT: INC HL ; Get next reserved word + OR (HL) ; Start of word? + JP P,GETNXT ; No - move on + INC B ; Increment token value + LD A, (HL) ; Get byte from table + AND 01111111B ; Strip bit 7 + RET Z ; Return if end of list + CP C ; Same character as in buffer? + JP NZ,GETNXT ; No - get next word + EX DE,HL + PUSH HL ; Save start of word + +NXTBYT: INC DE ; Look through rest of word + LD A,(DE) ; Get byte from table + OR A ; End of word ? + JP M,MATCH ; Yes - Match found + LD C,A ; Save it + LD A,B ; Get token value + CP ZGOTO ; Is it "GOTO" token ? + JP NZ,NOSPC ; No - Don't allow spaces + CALL GETCHR ; Get next character + DEC HL ; Cancel increment from GETCHR +NOSPC: INC HL ; Next byte + LD A,(HL) ; Get byte + CP "a" ; Less than "a" ? + JP C,NOCHNG ; Yes - don't change + AND 01011111B ; Make upper case +NOCHNG: CP C ; Same as in buffer ? + JP Z,NXTBYT ; Yes - keep testing + POP HL ; Get back start of word + JP SEARCH ; Look at next word + +MATCH: LD C,B ; Word found - Save token value + POP AF ; Throw away return + EX DE,HL + RET ; Return to "RETNAD" +RETNAD: EX DE,HL ; Get address in string + LD A,C ; Get token value + POP BC ; Restore buffer length + POP DE ; Get destination address +MOVDIR: INC HL ; Next source in buffer + LD (DE),A ; Put byte in buffer + INC DE ; Move up buffer + INC C ; Increment length of buffer + SUB ":" ; End of statement? + JP Z,SETLIT ; Jump if multi-statement line + CP ZDATA-3AH ; Is it DATA statement ? + JP NZ,TSTREM ; No - see if REM +SETLIT: LD (DATFLG),A ; Set literal flag +TSTREM: SUB ZREM-3AH ; Is it REM? + JP NZ,CRNCLP ; No - Leave flag + LD B,A ; Copy rest of buffer +NXTCHR: LD A,(HL) ; Get byte + OR A ; End of line ? + JP Z,ENDBUF ; Yes - Terminate buffer + CP B ; End of statement ? + JP Z,MOVDIR ; Yes - Get next one +CPYLIT: INC HL ; Move up source string + LD (DE),A ; Save in destination + INC C ; Increment length + INC DE ; Move up destination + JP NXTCHR ; Repeat + +ENDBUF: LD HL,BUFFER-1 ; Point to start of buffer + LD (DE),A ; Mark end of buffer (A = 00) + INC DE + LD (DE),A ; A = 00 + INC DE + LD (DE),A ; A = 00 + RET + +DODEL: LD A,(NULFLG) ; Get null flag status + OR A ; Is it zero? + LD A,0 ; Zero A - Leave flags + LD (NULFLG),A ; Zero null flag + JP NZ,ECHDEL ; Set - Echo it + DEC B ; Decrement length + JP Z,GETLIN ; Get line again if empty + CALL OUTC ; Output null character + DB 3EH ; Skip "DEC B" +ECHDEL: DEC B ; Count bytes in buffer + DEC HL ; Back space buffer + JP Z,OTKLN ; No buffer - Try again + LD A,(HL) ; Get deleted byte + CALL OUTC ; Echo it + JP MORINP ; Get more input + +DELCHR: DEC B ; Count bytes in buffer + DEC HL ; Back space buffer + CALL OUTC ; Output character in A + JP NZ,MORINP ; Not end - Get more +OTKLN: CALL OUTC ; Output character in A +KILIN: CALL PRNTCR ; Output CRLF + JP TTYLIN ; Get line again + +GETLIN: CALL MONTST ; Is it NAS-SYS? + JP Z,TTYLIN ; No - Character input + LD HL,(CIN) ; Point to NAS-SYS input table + LD A,(HL) ; Get input mode + CP 74H ; Is it "X" mode? + JP Z,TTYLIN ; Yes - Teletype line input + CALL INLINE ; Get a line from NAS-SYS + JP DONULL ; POS(X)=0 and do nulls + +TTYLIN: LD HL,BUFFER ; Get a line by character + LD B,1 ; Set buffer as empty + XOR A + LD (NULFLG),A ; Clear null flag +MORINP: CALL CLOTST ; Get character and test ^O + LD C,A ; Save character in C + CP DEL ; Delete character? + JP Z,DODEL ; Yes - Process it + LD A,(NULFLG) ; Get null flag + OR A ; Test null flag status + JP Z,PROCES ; Reset - Process character + LD A,0 ; Set a null + CALL OUTC ; Output null + XOR A ; Clear A + LD (NULFLG),A ; Reset null flag +PROCES: LD A,C ; Get character + CP CTRLG ; Bell? + JP Z,PUTCTL ; Yes - Save it + CP CTRLC ; Is it control "C"? + CALL Z,PRNTCR ; Yes - Output CRLF + SCF ; Flag break + RET Z ; Return if control "C" + CP CR ; Is it enter? + JP Z,ENDINP ; Yes - Terminate input + CP CTRLU ; Is it control "U"? + JP Z,KILIN ; Yes - Get another line + CP "@" ; Is it "kill line"? + JP Z,OTKLN ; Yes - Kill line + CP "_" ; Is it delete? + JP Z,DELCHR ; Yes - Delete character + CP BKSP ; Is it backspace? + JP Z,DELCHR ; Yes - Delete character + CP CTRLR ; Is it control "R"? + JP NZ,PUTBUF ; No - Put in buffer + PUSH BC ; Save buffer length + PUSH DE ; Save DE + PUSH HL ; Save buffer address + LD (HL),0 ; Mark end of buffer + CALL OUTNCR ; Output and do CRLF + LD HL,BUFFER ; Point to buffer start + CALL PRS ; Output buffer + POP HL ; Restore buffer address + POP DE ; Restore DE + POP BC ; Restore buffer length + JP MORINP ; Get another character + +PUTBUF: CP " " ; Is it a control code? + JP C,MORINP ; Yes - Ignore +PUTCTL: LD A,B ; Get number of bytes in buffer + CP 72+1 ; Test for line overflow + LD A,CTRLG ; Set a bell + JP NC,OUTNBS ; Ring bell if buffer full + LD A,C ; Get character + LD (HL),C ; Save in buffer + LD (LSTBIN),A ; Save last input byte + INC HL ; Move up buffer + INC B ; Increment length +OUTIT: CALL OUTC ; Output the character entered + JP MORINP ; Get another character + +OUTNBS: CALL OUTC ; Output bell and back over it + LD A,BKSP ; Set back space + JP OUTIT ; Output it and get more + +CPDEHL: LD A,H ; Get H + SUB D ; Compare with D + RET NZ ; Different - Exit + LD A,L ; Get L + SUB E ; Compare with E + RET ; Return status + +CHKSYN: LD A,(HL) ; Check syntax of character + EX (SP),HL ; Address of test byte + CP (HL) ; Same as in code string? + INC HL ; Return address + EX (SP),HL ; Put it back + JP Z,GETCHR ; Yes - Get next character + JP SNERR ; Different - ?SN Error + +OUTC: PUSH AF ; Save character + LD A,(CTLOFG) ; Get control "O" flag + OR A ; Is it set? + JP NZ,POPAF ; Yes - don't output + POP AF ; Restore character + PUSH BC ; Save buffer length + PUSH AF ; Save character + CP " " ; Is it a control code? + JP C,DINPOS ; Yes - Don't INC POS(X) + LD A,(LWIDTH) ; Get line width + LD B,A ; To B + LD A,(CURPOS) ; Get cursor position + INC B ; Width 255? + JP Z,INCLEN ; Yes - No width limit + DEC B ; Restore width + CP B ; At end of line? + CALL Z,PRNTCR ; Yes - output CRLF +INCLEN: INC A ; Move on one character + LD (CURPOS),A ; Save new position +DINPOS: POP AF ; Restore character + POP BC ; Restore buffer length + PUSH AF ; << This sequence >> + POP AF ; << is not needed >> + PUSH AF ; Save character + PUSH BC ; Save buffer length + LD C,A ; Character to C + CALL CONMON ; Send it + POP BC ; Restore buffer length + POP AF ; Restore character + RET + +CLOTST: CALL GETINP ; Get input character + AND 01111111B ; Strip bit 7 + CP CTRLO ; Is it control "O"? + RET NZ ; No don't flip flag + LD A,(CTLOFG) ; Get flag + CPL ; Flip it + LD (CTLOFG),A ; Put it back + XOR A ; Null character + RET + +LIST: CALL ATOH ; ASCII number to DE + RET NZ ; Return if anything extra + POP BC ; Rubbish - Not needed + CALL SRCHLN ; Search for line number in DE + PUSH BC ; Save address of line + CALL SETLIN ; Set up lines counter +LISTLP: POP HL ; Restore address of line + LD C,(HL) ; Get LSB of next line + INC HL + LD B,(HL) ; Get MSB of next line + INC HL + LD A,B ; BC = 0 (End of program)? + OR C + JP Z,PRNTOK ; Yes - Go to command mode + CALL COUNT ; Count lines + CALL TSTBRK ; Test for break key + PUSH BC ; Save address of next line + CALL PRNTCR ; Output CRLF + LD E,(HL) ; Get LSB of line number + INC HL + LD D,(HL) ; Get MSB of line number + INC HL + PUSH HL ; Save address of line start + EX DE,HL ; Line number to HL + CALL PRNTHL ; Output line number in decimal + LD A," " ; Space after line number + POP HL ; Restore start of line address +LSTLP2: CALL OUTC ; Output character in A +LSTLP3: LD A,(HL) ; Get next byte in line + OR A ; End of line? + INC HL ; To next byte in line + JP Z,LISTLP ; Yes - get next line + JP P,LSTLP2 ; No token - output it + SUB ZEND-1 ; Find and output word + LD C,A ; Token offset+1 to C + LD DE,WORDS ; Reserved word list +FNDTOK: LD A,(DE) ; Get character in list + INC DE ; Move on to next + OR A ; Is it start of word? + JP P,FNDTOK ; No - Keep looking for word + DEC C ; Count words + JP NZ,FNDTOK ; Not there - keep looking +OUTWRD: AND 01111111B ; Strip bit 7 + CALL OUTC ; Output first character + LD A,(DE) ; Get next character + INC DE ; Move on to next + OR A ; Is it end of word? + JP P,OUTWRD ; No - output the rest + JP LSTLP3 ; Next byte in line + +SETLIN: PUSH HL ; Set up LINES counter + LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Save in LINES counter + POP HL + RET + +LDNMI1: LD HL,BREAK ; Break routine + LD (NMI),HL ; NMI forces break + JP PRNTOK ; Go to command mode + + DB 0FEH ; <<< NO REFERENCE TO HERE >>> + +COUNT: PUSH HL ; Save code string address + PUSH DE + LD HL,(LINESC) ; Get LINES counter + LD DE,-1 + ADC HL,DE ; Decrement + LD (LINESC),HL ; Put it back + POP DE + POP HL ; Restore code string address + RET P ; Return if more lines to go + PUSH HL ; Save code string address + LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Reset LINES counter + LD A,(NMIFLG) ; Break by NMI? + OR A + JP NZ,ARETN ; Yes - "RETN" + CALL GETINP ; Get input character + CP CTRLC ; Is it control "C"? + JP Z,RSLNBK ; Yes - Reset LINES an break + POP HL ; Restore code string address + JP COUNT ; Keep on counting + +RSLNBK: LD HL,(LINESN) ; Get LINES number + LD (LINESC),HL ; Reset LINES counter + JP BRKRET ; Go and output "Break" + +FOR: LD A,64H ; Flag "FOR" assignment + LD (FORFLG),A ; Save "FOR" flag + CALL LET ; Set up initial index + POP BC ; Drop RETurn address + PUSH HL ; Save code string address + CALL DATA ; Get next statement address + LD (LOOPST),HL ; Save it for start of lo6p + LD HL,2 ; Offset for "FOR" block + ADD HL,SP ; Point to it +FORSLP: CALL LOKFOR ; Look for existing "FOR" block + POP DE ; Get code string address + JP NZ,FORFND ; No nesting found + ADD HL,BC ; Move into "FOR" block + PUSH DE ; Save code string address + DEC HL + LD D,(HL) ; Get MSB of loop statement + DEC HL + LD E,(HL) ; Get LSB of loop statement + INC HL + INC HL + PUSH HL ; Save block address + LD HL,(LOOPST) ; Get address of loop statement + CALL CPDEHL ; Compare the FOR loops + POP HL ; Restore block address + JP NZ,FORSLP ; Different FORs - Find another + POP DE ; Restore code string address + LD SP,HL ; Remove all nested loops + +FORFND: EX DE,HL ; Code string address to HL + LD C,8 + CALL CHKSTK ; Check for 8 levels of stack + PUSH HL ; Save code string address + LD HL,(LOOPST) ; Get first statement of loop + EX (SP),HL ; Save and restore code string + PUSH HL ; Re-save code string address + LD HL,(LINEAT) ; Get current line number + EX (SP),HL ; Save and restore code string + CALL TSTNUM ; Make sure it's a number + CALL CHKSYN ; Make sure "TO" is next + DB ZTO ; "TO" token + CALL GETNUM ; Get "TO" expression value + PUSH HL ; Save code string address + CALL BCDEFP ; Move "TO" value to BCDE + POP HL ; Restore code string address + PUSH BC ; Save "TO" value in block + PUSH DE + LD BC,8100H ; BCDE - 1 (default STEP) + LD D,C ; C=0 + LD E,D ; D=0 + LD A,(HL) ; Get next byte in code string + CP ZSTEP ; See if "STEP" is stated + LD A,1 ; Sign of step = 1 + JP NZ,SAVSTP ; No STEP given - Default to 1 + CALL GETCHR ; Jump over "STEP" token + CALL GETNUM ; Get step value + PUSH HL ; Save code string address + CALL BCDEFP ; Move STEP to BCDE + CALL TSTSGN ; Test sign of FPREG + POP HL ; Restore code string address +SAVSTP: PUSH BC ; Save the STEP value in block + PUSH DE + PUSH AF ; Save sign of STEP + INC SP ; Don't save flags + PUSH HL ; Save code string address + LD HL,(BRKLIN) ; Get address of index variable + EX (SP),HL ; Save and restore code string +PUTFID: LD B,ZFOR ; "FOR" block marker + PUSH BC ; Save it + INC SP ; Don't save C + +RUNCNT: CALL CHKBRK ; Execution driver - Test break + OR A ; Break key hit? + CALL NZ,STALL ; Yes - Pause for a key + LD (BRKLIN),HL ; Save code address for break + LD A,(HL) ; Get next byte in code string + CP ":" ; Multi statement line? + JP Z,EXCUTE ; Yes - Execute it + OR A ; End of line? + JP NZ,SNERR ; No - Syntax error + INC HL ; Point to address of next line + LD A,(HL) ; Get LSB of line pointer + INC HL + OR (HL) ; Is it zero (End of prog)? + JP Z,ENDPRG ; Yes - Terminate execution + INC HL ; Point to line number + LD E,(HL) ; Get LSB of line number + INC HL + LD D,(HL) ; Get MSB of line number + EX DE,HL ; Line number to HL + LD (LINEAT),HL ; Save as current line number + EX DE,HL ; Line number back to DE +EXCUTE: CALL GETCHR ; Get key word + LD DE,RUNCNT ; Where to RETurn to + PUSH DE ; Save for RETurn +IFJMP: RET Z ; Go to RUNCNT if end of STMT +ONJMP: SUB ZEND ; Is it a token? + JP C,LET ; No - try to assign it + CP ZNEW+1-ZEND ; END to NEW ? + JP NC,SNERR ; Not a key word - ?SN Error + RLCA ; Double it + LD C,A ; BC = Offset into table + LD B,0 + EX DE,HL ; Save code string address + LD HL,WORDTB ; Keyword address table + ADD HL,BC ; Point to routine address + LD C,(HL) ; Get LSB of routine address + INC HL + LD B,(HL) ; Get MSB of routine address + PUSH BC ; Save routine address + EX DE,HL ; Restore code string address + +GETCHR: INC HL ; Point to next character + LD A,(HL) ; Get next code string byte + CP ":" ; Z if ":" + RET NC ; NC if > "9" + CP " " + JP Z,GETCHR ; Skip over spaces + CP "0" + CCF ; NC if < "0" + INC A ; Test for zero - Leave carry + DEC A ; Z if Null + RET + +RESTOR: EX DE,HL ; Save code string address + LD HL,(BASTXT) ; Point to start of program + JP Z,RESTNL ; Just RESTORE - reset pointer + EX DE,HL ; Restore code string address + CALL ATOH ; Get line number to DE + PUSH HL ; Save code string address + CALL SRCHLN ; Search for line number in DE + LD H,B ; HL = Address of line + LD L,C + POP DE ; Restore code string address + JP NC,ULERR ; ?UL Error if not found +RESTNL: DEC HL ; Byte before DATA statement +UPDATA: LD (NXTDAT),HL ; Update DATA pointer + EX DE,HL ; Restore code string address + RET + +TSTBRK: CALL CHKBRK ; Test for interrupts + OR A + RET Z ; Return if no key pressed +STALL: CALL CLOTST ; Get input and test for ^O + CP CTRLS ; Is it control "S" + CALL Z,CLOTST ; Yes - Get another character + CP CTRLC ; Return if not control "C" +STOP: RET NZ ; Exit if anything else + DB 0F6H ; Flag "STOP" +PEND: RET NZ ; Exit if anything else + LD (BRKLIN),HL ; Save point of break + DB 21H ; Skip "OR 11111111B" +INPBRK: OR 11111111B ; Flag "Break" wanted + POP BC ; Return not needed and more +ENDPRG: LD HL,(LINEAT) ; Get current line number + PUSH AF ; Save STOP / END status + LD A,L ; Is it direct break? + AND H + INC A ; Line is -1 if direct break + JP Z,NOLIN ; Yes - No line number + LD (ERRLIN),HL ; Save line of break + LD HL,(BRKLIN) ; Get point of break + LD (CONTAD),HL ; Save point to CONTinue +NOLIN: XOR A + LD (CTLOFG),A ; Enable output + CALL STTLIN ; Start a new line + POP AF ; Restore STOP / END status + LD HL,BRKMSG ; "Break" message + JP NZ,ERRIN ; "in line" wanted? + JP PRNTOK ; Go to command mode + +CONT: LD HL,(CONTAD) ; Get CONTinue address + LD A,H ; Is it zero? + OR L + LD E,CN ; ?CN Error + JP Z,ERROR ; Yes - output "?CN Error" + EX DE,HL ; Save code string address + LD HL,(ERRLIN) ; Get line of last break + LD (LINEAT),HL ; Set up current line number + EX DE,HL ; Restore code string address + RET ; CONTinue where left off + +NULL: CALL GETINT ; Get integer 0-255 + RET NZ ; Return if bad value + LD (NULLS),A ; Set nulls number + RET + +ARRLD1: LD B,-1 ; Flag array load +ARRSV1: CALL GETCHR ; Skip "*" + LD A,B ; CLOAD* or CSAVE* + LD (BRKLIN),A ; Save it + LD A,1 ; It's an array + LD (FORFLG),A ; Flag array name + CALL GETVAR ; Get address of array name + PUSH HL ; Save code string address + LD (FORFLG),A ; Clear flag + LD H,B ; Address of array to HL + LD L,C + DEC BC ; Back space + DEC BC ; to point + DEC BC ; to the + DEC BC ; array name + LD A,(BRKLIN) ; CLOAD* or CSAVE* ? + OR A + PUSH AF ; Save CLOAD* / CSAVE* status + EX DE,HL ; Array data length + ADD HL,DE ; End of data + EX DE,HL ; To DE + LD C,(HL) ; Get dimension bytes + LD B,0 + ADD HL,BC ; 2 Bytes each dimension + ADD HL,BC + INC HL ; Over number of dimensions + PUSH HL ; Address of array data + PUSH DE ; End of array data + PUSH BC ; Number of dimensions + LD A,(BRKLIN) ; CLOAD* or CSAVE* ? + CP -1 + CALL Z,CASFF ; CLOAD* - Cassette on + LD A,(BRKLIN) ; CLOAD* or CSAVE* ? + CP -1 + CALL NZ,CASFFW ; CSAVE* - Cassette on and wait + NOP + NOP + NOP + LD HL,0 + LD (CHKSUM),HL ; Zero check sum + POP BC ; Number of dimensions + POP DE ; End of array data + POP HL ; Address of array data + LD B,11010010B ; Header byte + JP JPLDSV ; CSAVE-SNDHDR , CLOAD-GETHDR + +SNDHDR: LD A,B ; Get header byte + CALL WUART2 ; Send 2 bytes to UART + CALL WUART2 ; Send 2 bytes to UART + JP SNDARY ; Send array data + +GETHDR: LD C,4 ; 4 Bytes to check +HDRLP: CALL RUART ; Read byte from UART + CP B ; Same as header? + JP NZ,GETHDR ; No - Wait for another + DEC C ; Count bytes + JP NZ,HDRLP ; More needed +SNDARY: CALL TSTNUM ; Check it's a numerical array +ARYLP: CALL CPDEHL ; All array data done + JP Z,SUMOFF ; Yes - Do check sum + POP AF ; CLOAD* or CSAVE* ? + PUSH AF ; Re-save flags + LD A,(HL) ; Get byte + CALL P,WUART ; CSAVE* - Write byte + CALL M,RUART ; CLOAD* - Read byte + LD (HL),A ; Save byte in case of CLOAD* + CALL ACCSUM ; Accumulate check sum + INC HL ; Next byte + JP ARYLP ; Repeat + +SUMOFF: CALL DOSUM ; Do check sum + CALL CASFF ; Cassette off + POP AF ; Not needed any more + POP HL ; Restore code string address + RET + +ACCSUM: PUSH HL ; Save address in array + LD HL,(CHKSUM) ; Get check sum + LD B,0 ; BC - Value of byte + LD C,A + ADD HL,BC ; Add byte to check sum + LD (CHKSUM),HL ; Re-save check sum + POP HL ; Restore address in array + RET + +DOSUM: LD A,(BRKLIN) ; CLOAD* or CSAVE* ? + OR A + JP M,CHSUMS ; CLOAD* - Check if sums match + LD A,(CHKSUM) ; Get LSB of check sum + CALL WUART ; Write to UART + LD A,(CHKSUM+1) ; Get MSB of check sum + JP WUART ; Write to UART and return + +CHSUMS: CALL RUART ; Read LSB of check sum + PUSH AF ; Save it + CALL RUART ; Read MSB of check sum + POP BC ; LSB to B + LD E,B ; LSB to E + LD D,A ; MSB to D + LD HL,(CHKSUM) ; Get accumulated check sum + CALL CPDEHL ; Are they the same? + RET Z ; Yes - End CLOAD* + CALL CASFF ; Cassette off + JP OUTBAD ; Different - Output "Bad" + +CHKLTR: LD A,(HL) ; Get byte + CP "A" ; < "A" ? + RET C ; Carry set if not letter + CP "Z"+1 ; > "Z" ? + CCF + RET ; Carry set if not letter + +FPSINT: CALL GETCHR ; Get next character +POSINT: CALL GETNUM ; Get integer 0 to 32767 +DEPINT: CALL TSTSGN ; Test sign of FPREG + JP M,FCERR ; Negative - ?FC Error +DEINT: LD A,(FPEXP) ; Get integer value to DE + CP 80H+16 ; Exponent in range (16 bits)? + JP C,FPINT ; Yes - convert it + LD BC,9080H ; BCDE = -32768 + LD DE,0000 + PUSH HL ; Save code string address + CALL CMPNUM ; Compare FPREG with BCDE + POP HL ; Restore code string address + LD D,C ; MSB to D + RET Z ; Return if in range +FCERR: LD E,FC ; ?FC Error + JP ERROR ; Output error- + +ATOH: DEC HL ; ASCII number to DE binary +GETLN: LD DE,0 ; Get number to DE +GTLNLP: CALL GETCHR ; Get next character + RET NC ; Exit if not a digit + PUSH HL ; Save code string address + PUSH AF ; Save digit + LD HL,65529/10 ; Largest number 65529 + CALL CPDEHL ; Number in range? + JP C,SNERR ; No - ?SN Error + LD H,D ; HL = Number + LD L,E + ADD HL,DE ; Times 2 + ADD HL,HL ; Times 4 + ADD HL,DE ; Times 5 + ADD HL,HL ; Times 10 + POP AF ; Restore digit + SUB "0" ; Make it 0 to 9 + LD E,A ; DE = Value of digit + LD D,0 + ADD HL,DE ; Add to number + EX DE,HL ; Number to DE + POP HL ; Restore code string address + JP GTLNLP ; Go to next character + +CLEAR: JP Z,INTVAR ; Just "CLEAR" Keep parameters + CALL POSINT ; Get integer 0 to 32767 to DE + DEC HL ; Cancel increment + CALL GETCHR ; Get next character + PUSH HL ; Save code string address + LD HL,(LSTRAM) ; Get end of RAM + JP Z,STORED ; No value given - Use stored + POP HL ; Restore code string address + CALL CHKSYN ; Check for comma + DB "," + PUSH DE ; Save number + CALL POSINT ; Get integer 0 to 32767 + DEC HL ; Cancel increment + CALL GETCHR ; Get next character + JP NZ,SNERR ; ?SN Error if more on line + EX (SP),HL ; Save code string address + EX DE,HL ; Number to DE +STORED: LD A,L ; Get LSB of new RAM top + SUB E ; Subtract LSB of string space + LD E,A ; Save LSB + LD A,H ; Get MSB of new RAM top + SBC A,D ; Subtract MSB of string space + LD D,A ; Save MSB + JP C,OMERR ; ?OM Error if not enough mem + PUSH HL ; Save RAM top + LD HL,(PROGND) ; Get program end + LD BC,40 ; 40 Bytes minimum working RAM + ADD HL,BC ; Get lowest address + CALL CPDEHL ; Enough memory? + JP NC,OMERR ; No - ?OM Error + EX DE,HL ; RAM top to HL + LD (STRSPC),HL ; Set new string space + POP HL ; End of memory to use + LD (LSTRAM),HL ; Set new top of RAM + POP HL ; Restore code string address + JP INTVAR ; Initialise variables + +RUN: JP Z,RUNFST ; RUN from start if just RUN + CALL INTVAR ; Initialise variables + LD BC,RUNCNT ; Execution driver loop + JP RUNLIN ; RUN from line number + +GOSUB: LD C,3 ; 3 Levels of stack needed + CALL CHKSTK ; Check for 3 levels of stack + POP BC ; Get return address + PUSH HL ; Save code string for RETURN + PUSH HL ; And for GOSUB routine + LD HL,(LINEAT) ; Get current line + EX (SP),HL ; Into stack - Code string out + LD A,ZGOSUB ; "GOSUB" token + PUSH AF ; Save token + INC SP ; Don't save flags + +RUNLIN: PUSH BC ; Save return address +GOTO: CALL ATOH ; ASCII number to DE binary + CALL REM ; Get end of line + PUSH HL ; Save end of line + LD HL,(LINEAT) ; Get current line + CALL CPDEHL ; Line after current? + POP HL ; Restore end of line + INC HL ; Start of next line + CALL C,SRCHLP ; Line is after current line + CALL NC,SRCHLN ; Line is before current line + LD H,B ; Set up code string address + LD L,C + DEC HL ; Incremented after + RET C ; Line found +ULERR: LD E,UL ; ?UL Error + JP ERROR ; Output error message + +RETURN: RET NZ ; Return if not just RETURN + LD D,-1 ; Flag "GOSUB" search + CALL BAKSTK ; Look "GOSUB" block + LD SP,HL ; Kill all FORs in subroutine + CP ZGOSUB ; Test for "GOSUB" token + LD E,RG ; ?RG Error + JP NZ,ERROR ; Error if no "GOSUB" found + POP HL ; Get RETURN line number + LD (LINEAT),HL ; Save as current + INC HL ; Was it from direct statement? + LD A,H + OR L ; Return to line + JP NZ,RETLIN ; No - Return to line + LD A,(LSTBIN) ; Any INPUT in subroutine? + OR A ; If so buffer is corrupted + JP NZ,POPNOK ; Yes - Go to command mode +RETLIN: LD HL,RUNCNT ; Execution driver loop + EX (SP),HL ; Into stack - Code string out + DB 3EH ; Skip "POP HL" +NXTDTA: POP HL ; Restore code string address + +DATA: DB 01H,3AH ; ":" End of statement +REM: LD C,0 ; 00 End of statement + LD B,0 +NXTSTL: LD A,C ; Statement and byte + LD C,B + LD B,A ; Statement end byte +NXTSTT: LD A,(HL) ; Get byte + OR A ; End of line? + RET Z ; Yes - Exit + CP B ; End of statement? + RET Z ; Yes - Exit + INC HL ; Next byte + CP '"' ; Literal string? + JP Z,NXTSTL ; Yes - Look for another '"' + JP NXTSTT ; Keep looking + +LET: CALL GETVAR ; Get variable name + CALL CHKSYN ; Make sure "=" follows + DB ZEQUAL ; "=" token + PUSH DE ; Save address of variable + LD A,(TYPE) ; Get data type + PUSH AF ; Save type + CALL EVAL ; Evaluate expression + POP AF ; Restore type + EX (SP),HL ; Save code - Get var addr + LD (BRKLIN),HL ; Save address of variable + RRA ; Adjust type + CALL CHKTYP ; Check types are the same + JP Z,LETNUM ; Numeric - Move value +LETSTR: PUSH HL ; Save address of string var + LD HL,(FPREG) ; Pointer to string entry + PUSH HL ; Save it on stack + INC HL ; Skip over length + INC HL + LD E,(HL) ; LSB of string address + INC HL + LD D,(HL) ; MSB of string address + LD HL,(BASTXT) ; Point to start of program + CALL CPDEHL ; Is string before program? + JP NC,CRESTR ; Yes - Create string entry + LD HL,(STRSPC) ; Point to string space + CALL CPDEHL ; Is string literal in program? + POP DE ; Restore address of string + JP NC,MVSTPT ; Yes - Set up pointer + LD HL,TMPSTR ; Temporary string pool + CALL CPDEHL ; Is string in temporary pool? + JP NC,MVSTPT ; No - Set up pointer + DB 3EH ; Skip "POP DE" +CRESTR: POP DE ; Restore address of string + CALL BAKTMP ; Back to last tmp-str entry + EX DE,HL ; Address of string entry + CALL SAVSTR ; Save string in string area +MVSTPT: CALL BAKTMP ; Back to last tmp-str entry + POP HL ; Get string pointer + CALL DETHL4 ; Move string pointer to var + POP HL ; Restore code string address + RET + +LETNUM: PUSH HL ; Save address of variable + CALL FPTHL ; Move value to variable + POP DE ; Restore address of variable + POP HL ; Restore code string address + RET + +ON: CALL GETINT ; Get integer 0-255 + LD A,(HL) ; Get "GOTO" or "GOSUB" token + LD B,A ; Save in B + CP ZGOSUB ; "GOSUB" token? + JP Z,ONGO ; Yes - Find line number + CALL CHKSYN ; Make sure it's "GOTO" + DB ZGOTO ; "GOTO" token + DEC HL ; Cancel increment +ONGO: LD C,E ; Integer of branch value +ONGOLP: DEC C ; Count branches + LD A,B ; Get "GOTO" or "GOSUB" token + JP Z,ONJMP ; Go to that line if right one + CALL GETLN ; Get line number to DE + CP "," ; Another line number? + RET NZ ; No - Drop through + JP ONGOLP ; Yes - loop + +IF: CALL EVAL ; Evaluate expression + LD A,(HL) ; Get token + CP ZGOTO ; "GOTO" token? + JP Z,IFGO ; Yes - Get line + CALL CHKSYN ; Make sure it's "THEN" + DB ZTHEN ; "THEN" token + DEC HL ; Cancel increment +IFGO: CALL TSTNUM ; Make sure it's numeric + CALL TSTSGN ; Test state of expression + JP Z,REM ; False - Drop through + CALL GETCHR ; Get next character + JP C,GOTO ; Number - GOTO that line + JP IFJMP ; Otherwise do statement + +MRPRNT: DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character +PRINT: JP Z,PRNTCR ; CRLF if just PRINT +PRNTLP: RET Z ; End of list - Exit + CP ZTAB ; "TAB(" token? + JP Z,DOTAB ; Yes - Do TAB routine + CP ZSPC ; "SPC(" token? + JP Z,DOTAB ; Yes - Do SPC routine + PUSH HL ; Save code string address + CP "," ; Comma? + JP Z,DOCOM ; Yes - Move to next zone + CP ";" ; Semi-colon? + JP Z,NEXITM ; Do semi-colon routine + POP BC ; Code string address to BC + CALL EVAL ; Evaluate expression + PUSH HL ; Save code string address + LD A,(TYPE) ; Get variable type + OR A ; Is it a string variable? + JP NZ,PRNTST ; Yes - Output string contents + CALL NUMASC ; Convert number to text + CALL CRTST ; Create temporary string + LD (HL)," " ; Followed by a space + LD HL,(FPREG) ; Get length of output + INC (HL) ; Plus 1 for the space + LD HL,(FPREG) ; < Not needed > + LD A,(LWIDTH) ; Get width of line + LD B,A ; To B + INC B ; Width 255 (No limit)? + JP Z,PRNTNB ; Yes - Output number string + INC B ; Adjust it + LD A,(CURPOS) ; Get cursor position + ADD A,(HL) ; Add length of string + DEC A ; Adjust it + CP B ; Will output fit on this line? + CALL NC,PRNTCR ; No - CRLF first +PRNTNB: CALL PRS1 ; Output string at (HL) + XOR A ; Skip CALL by setting "Z" flag +PRNTST: CALL NZ,PRS1 ; Output string at (HL) + POP HL ; Restore code string address + JP MRPRNT ; See if more to PRINT + +STTLIN: LD A,(CURPOS) ; Make sure on new line + OR A ; Already at start? + RET Z ; Yes - Do nothing + JP PRNTCR ; Start a new line + +ENDINP: LD (HL),0 ; Mark end of buffer + LD HL,BUFFER-1 ; Point to buffer +PRNTCR: LD A,CR ; Load a CR + CALL OUTC ; Output character +DONULL: XOR A ; Set to position 0 + LD (CURPOS),A ; Store it + LD A,(NULLS) ; Get number of nulls +NULLP: DEC A ; Count them + RET Z ; Return if done + PUSH AF ; Save count + XOR A ; Load a null + CALL OUTC ; Output it + POP AF ; Restore count + JP NULLP ; Keep counting + +DOCOM: LD A,(COMMAN) ; Get comma width + LD B,A ; Save in B + LD A,(CURPOS) ; Get current position + CP B ; Within the limit? + CALL NC,PRNTCR ; No - output CRLF + JP NC,NEXITM ; Get next item +ZONELP: SUB 14 ; Next zone of 14 characters + JP NC,ZONELP ; Repeat if more zones + CPL ; Number of spaces to output + JP ASPCS ; Output them + +DOTAB: PUSH AF ; Save token + CALL FNDNUM ; Evaluate expression + CALL CHKSYN ; Make sure ")" follows + DB ")" + DEC HL ; Back space on to ")" + POP AF ; Restore token + SUB ZSPC ; Was it "SPC(" ? + PUSH HL ; Save code string address + JP Z,DOSPC ; Yes - Do "E" spaces + LD A,(CURPOS) ; Get current position +DOSPC: CPL ; Number of spaces to print to + ADD A,E ; Total number to print + JP NC,NEXITM ; TAB < Current POS(X) +ASPCS: INC A ; Output A spaces + LD B,A ; Save number to print + LD A," " ; Space +SPCLP: CALL OUTC ; Output character in A + DEC B ; Count them + JP NZ,SPCLP ; Repeat if more +NEXITM: POP HL ; Restore code string address + CALL GETCHR ; Get next character + JP PRNTLP ; More to print + +REDO: DB "?Redo from start",CR,LF,0 + +BADINP: LD A,(READFG) ; READ or INPUT? + OR A + JP NZ,DATSNR ; READ - ?SN Error + POP BC ; Throw away code string addr + LD HL,REDO ; "Redo from start" message + CALL PRS ; Output string + JP DOAGN ; Do last INPUT again + +INPUT: CALL IDTEST ; Test for illegal direct + LD A,(HL) ; Get character after "INPUT" + CP '"' ; Is there a prompt string? + LD A,0 ; Clear A and leave flags + LD (CTLOFG),A ; Enable output + JP NZ,NOPMPT ; No prompt - get input + CALL QTSTR ; Get string terminated by '"' + CALL CHKSYN ; Check for ";" after prompt + DB ";" + PUSH HL ; Save code string address + CALL PRS1 ; Output prompt string + DB 3EH ; Skip "PUSH HL" +NOPMPT: PUSH HL ; Save code string address + CALL PROMPT ; Get input with "? " prompt + POP BC ; Restore code string address + JP C,INPBRK ; Break pressed - Exit + INC HL ; Next byte + LD A,(HL) ; Get it + OR A ; End of line? + DEC HL ; Back again + PUSH BC ; Re-save code string address + JP Z,NXTDTA ; Yes - Find next DATA stmt + LD (HL),"," ; Store comma as separator + JP NXTITM ; Get next item + +READ: PUSH HL ; Save code string address + LD HL,(NXTDAT) ; Next DATA statement + DB 0F6H ; Flag "READ" +NXTITM: XOR A ; Flag "INPUT" + LD (READFG),A ; Save "READ"/"INPUT" flag + EX (SP),HL ; Get code str' , Save pointer + JP GTVLUS ; Get values + +NEDMOR: CALL CHKSYN ; Check for comma between items + DB "," +GTVLUS: CALL GETVAR ; Get variable name + EX (SP),HL ; Save code str" , Get pointer + PUSH DE ; Save variable address + LD A,(HL) ; Get next "INPUT"/"DATA" byte + CP "," ; Comma? + JP Z,ANTVLU ; Yes - Get another value + LD A,(READFG) ; Is it READ? + OR A + JP NZ,FDTLP ; Yes - Find next DATA stmt + LD A,"?" ; More INPUT needed + CALL OUTC ; Output character + CALL PROMPT ; Get INPUT with prompt + POP DE ; Variable address + POP BC ; Code string address + JP C,INPBRK ; Break pressed + INC HL ; Point to next DATA byte + LD A,(HL) ; Get byte + OR A ; Is it zero (No input) ? + DEC HL ; Back space INPUT pointer + PUSH BC ; Save code string address + JP Z,NXTDTA ; Find end of buffer + PUSH DE ; Save variable address +ANTVLU: LD A,(TYPE) ; Check data type + OR A ; Is it numeric? + JP Z,INPBIN ; Yes - Convert to binary + CALL GETCHR ; Get next character + LD D,A ; Save input character + LD B,A ; Again + CP '"' ; Start of literal sting? + JP Z,STRENT ; Yes - Create string entry + LD A,(READFG) ; "READ" or "INPUT" ? + OR A + LD D,A ; Save 00 if "INPUT" + JP Z,ITMSEP ; "INPUT" - End with 00 + LD D,":" ; "DATA" - End with 00 or ":" +ITMSEP: LD B,"," ; Item separator + DEC HL ; Back space for DTSTR +STRENT: CALL DTSTR ; Get string terminated by D + EX DE,HL ; String address to DE + LD HL,LTSTND ; Where to go after LETSTR + EX (SP),HL ; Save HL , get input pointer + PUSH DE ; Save address of string + JP LETSTR ; Assign string to variable + +INPBIN: CALL GETCHR ; Get next character + CALL ASCTFP ; Convert ASCII to FP number + EX (SP),HL ; Save input ptr, Get var addr + CALL FPTHL ; Move FPREG to variable + POP HL ; Restore input pointer +LTSTND: DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP Z,MORDT ; End of line - More needed? + CP "," ; Another value? + JP NZ,BADINP ; No - Bad input +MORDT: EX (SP),HL ; Get code string address + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP NZ,NEDMOR ; More needed - Get it + POP DE ; Restore DATA pointer + LD A,(READFG) ; "READ" or "INPUT" ? + OR A + EX DE,HL ; DATA pointer to HL + JP NZ,UPDATA ; Update DATA pointer if "READ" + PUSH DE ; Save code string address + OR (HL) ; More input given? + LD HL,EXTIG ; "?Extra ignored" message + CALL NZ,PRS ; Output string if extra given + POP HL ; Restore code string address + RET + +EXTIG: DB "?Extra ignored",CR,LF,0 + +FDTLP: CALL DATA ; Get next statement + OR A ; End of line? + JP NZ,FANDT ; No - See if DATA statement + INC HL + LD A,(HL) ; End of program? + INC HL + OR (HL) ; 00 00 Ends program + LD E,OD ; ?OD Error + JP Z,ERROR ; Yes - Out of DATA + INC HL + LD E,(HL) ; LSB of line number + INC HL + LD D,(HL) ; MSB of line number + EX DE,HL + LD (DATLIN),HL ; Set line of current DATA item + EX DE,HL +FANDT: CALL GETCHR ; Get next character + CP ZDATA ; "DATA" token + JP NZ,FDTLP ; No "DATA" - Keep looking + JP ANTVLU ; Found - Convert input + +NEXT: LD DE,0 ; In case no index given +NEXT1: CALL NZ,GETVAR ; Get index address + LD (BRKLIN),HL ; Save code string address + CALL BAKSTK ; Look for "FOR" block + JP NZ,NFERR ; No "FOR" - ?NF Error + LD SP,HL ; Clear nested loops + PUSH DE ; Save index address + LD A,(HL) ; Get sign of STEP + INC HL + PUSH AF ; Save sign of STEP + PUSH DE ; Save index address + CALL PHLTFP ; Move index value to FPREG + EX (SP),HL ; Save address of TO value + PUSH HL ; Save address of index + CALL ADDPHL ; Add STEP to index value + POP HL ; Restore address of index + CALL FPTHL ; Move value to index variable + POP HL ; Restore address of TO value + CALL LOADFP ; Move TO value to BCDE + PUSH HL ; Save address of line of FOR + CALL CMPNUM ; Compare index with TO value + POP HL ; Restore address of line num + POP BC ; Address of sign of STEP + SUB B ; Compare with expected sign + CALL LOADFP ; BC = Loop stmt,DE = Line num + JP Z,KILFOR ; Loop finished - Terminate it + EX DE,HL ; Loop statement line number + LD (LINEAT),HL ; Set loop line number + LD L,C ; Set code string to loop + LD H,B + JP PUTFID ; Put back "FOR" and continue + +KILFOR: LD SP,HL ; Remove "FOR" block + LD HL,(BRKLIN) ; Code string after "NEXT" + LD A,(HL) ; Get next byte in code string + CP "," ; More NEXTs ? + JP NZ,RUNCNT ; No - Do next statement + CALL GETCHR ; Position to index name + CALL NEXT1 ; Re-enter NEXT routine +; < will not RETurn to here , Exit to RUNCNT or Loop > + +GETNUM: CALL EVAL ; Get a numeric expression +TSTNUM: DB 0F6H ; Clear carry (numeric) +TSTSTR: SCF ; Set carry (string) +CHKTYP: LD A,(TYPE) ; Check types match + ADC A,A ; Expected + actual + OR A ; Clear carry , set parity + RET PE ; Even parity - Types match + JP TMERR ; Different types - Error + +; <<< NO REFERENCE TO HERE >>> + + CALL CHKSYN ; Make sure "=" follows + DB ZEQUAL ; "=" + JP EVAL ; Evaluate expression + +OPNPAR: CALL CHKSYN ; Make sure "(" follows + DB "(" +EVAL: DEC HL ; Evaluate expression & save + LD D,0 ; Precedence value +EVAL1: PUSH DE ; Save precedence + LD C,1 + CALL CHKSTK ; Check for 1 level of stack + CALL OPRND ; Get next expression value +EVAL2: LD (NXTOPR),HL ; Save address of next operator +EVAL3: LD HL,(NXTOPR) ; Restore address of next opr + POP BC ; Precedence value and operator + LD A,B ; Get precedence value + CP 78H ; "AND" or "OR" ? + CALL NC,TSTNUM ; No - Make sure it's a number + LD A,(HL) ; Get next operator / function + LD D,0 ; Clear Last relation +RLTLP: SUB ZGTR ; ">" Token + JP C,FOPRND ; + - * / ^ AND OR - Test it + CP ZLTH+1-ZGTR ; < = > + JP NC,FOPRND ; Function - Call it + CP ZEQUAL-ZGTR ; "=" + RLA ; <- Test for legal + XOR D ; <- combinations of < = > + CP D ; <- by combining last token + LD D,A ; <- with current one + JP C,SNERR ; Error if "<<" "==" or ">>" + LD (CUROPR),HL ; Save address of current token + CALL GETCHR ; Get next character + JP RLTLP ; Treat the two as one + +FOPRND: LD A,D ; < = > found ? + OR A + JP NZ,TSTRED ; Yes - Test for reduction + LD A,(HL) ; Get operator token + LD (CUROPR),HL ; Save operator address + SUB ZPLUS ; Operator or function? + RET C ; Neither - Exit + CP ZOR+1-ZPLUS ; Is it + - * / ^ AND OR ? + RET NC ; No - Exit + LD E,A ; Coded operator + LD A,(TYPE) ; Get data type + DEC A ; FF = numeric , 00 = string + OR E ; Combine with coded operator + LD A,E ; Get coded operator + JP Z,CONCAT ; String concatenation + RLCA ; Times 2 + ADD A,E ; Times 3 + LD E,A ; To DE (D is 0) + LD HL,PRITAB ; Precedence table + ADD HL,DE ; To the operator concerned + LD A,B ; Last operator precedence + LD D,(HL) ; Get evaluation precedence + CP D ; Compare with eval precedence + RET NC ; Exit if higher precedence + INC HL ; Point to routine address + CALL TSTNUM ; Make sure it's a number + +STKTHS: PUSH BC ; Save last precedence & token + LD BC,EVAL3 ; Where to go on prec' break + PUSH BC ; Save on stack for return + LD B,E ; Save operator + LD C,D ; Save precedence + CALL STAKFP ; Move value to stack + LD E,B ; Restore operator + LD D,C ; Restore precedence + LD C,(HL) ; Get LSB of routine address + INC HL + LD B,(HL) ; Get MSB of routine address + INC HL + PUSH BC ; Save routine address + LD HL,(CUROPR) ; Address of current operator + JP EVAL1 ; Loop until prec' break + +OPRND: XOR A ; Get operand routine + LD (TYPE),A ; Set numeric expected + CALL GETCHR ; Get next character + LD E,MO ; ?MO Error + JP Z,ERROR ; No operand - Error + JP C,ASCTFP ; Number - Get value + CALL CHKLTR ; See if a letter + JP NC,CONVAR ; Letter - Find variable + CP ZPLUS ; "+" Token ? + JP Z,OPRND ; Yes - Look for operand + CP "." ; "." ? + JP Z,ASCTFP ; Yes - Create FP number + CP ZMINUS ; "-" Token ? + JP Z,MINUS ; Yes - Do minus + CP '"' ; Literal string ? + JP Z,QTSTR ; Get string terminated by '"' + CP ZNOT ; "NOT" Token ? + JP Z,EVNOT ; Yes - Eval NOT expression + CP ZFN ; "FN" Token ? + JP Z,DOFN ; Yes - Do FN routine + SUB ZSGN ; Is it a function? + JP NC,FNOFST ; Yes - Evaluate function +EVLPAR: CALL OPNPAR ; Evaluate expression in "()" + CALL CHKSYN ; Make sure ")" follows + DB ")" + RET + +MINUS: LD D,7DH ; "-" precedence + CALL EVAL1 ; Evaluate until prec' break + LD HL,(NXTOPR) ; Get next operator address + PUSH HL ; Save next operator address + CALL INVSGN ; Negate value +RETNUM: CALL TSTNUM ; Make sure it's a number + POP HL ; Restore next operator address + RET + +CONVAR: CALL GETVAR ; Get variable address to DE +FRMEVL: PUSH HL ; Save code string address + EX DE,HL ; Variable address to HL + LD (FPREG),HL ; Save address of variable + LD A,(TYPE) ; Get type + OR A ; Numeric? + CALL Z,PHLTFP ; Yes - Move contents to FPREG + POP HL ; Restore code string address + RET + +FNOFST: LD B,0 ; Get address of function + RLCA ; Double function offset + LD C,A ; BC = Offset in function table + PUSH BC ; Save adjusted token value + CALL GETCHR ; Get next character + LD A,C ; Get adjusted token value + CP 2*(ZPOINT-ZSGN) ; Adjusted "POINT" token? + JP Z,POINTB ; Yes - Do "POINT" (not POINTB) + CP 2*(ZLEFT-ZSGN)-1; Adj' LEFT$,RIGHT$ or MID$ ? + JP C,FNVAL ; No - Do function + CALL OPNPAR ; Evaluate expression (X,... + CALL CHKSYN ; Make sure "," follows + DB "," + CALL TSTSTR ; Make sure it's a string + EX DE,HL ; Save code string address + LD HL,(FPREG) ; Get address of string + EX (SP),HL ; Save address of string + PUSH HL ; Save adjusted token value + EX DE,HL ; Restore code string address + CALL GETINT ; Get integer 0-255 + EX DE,HL ; Save code string address + EX (SP),HL ; Save integer,HL = adj' token + JP GOFUNC ; Jump to string function + +FNVAL: CALL EVLPAR ; Evaluate expression + EX (SP),HL ; HL = Adjusted token value + LD DE,RETNUM ; Return number from function + PUSH DE ; Save on stack +GOFUNC: LD BC,FNCTAB ; Function routine addresses + ADD HL,BC ; Point to right address + LD C,(HL) ; Get LSB of address + INC HL ; + LD H,(HL) ; Get MSB of address + LD L,C ; Address to HL + JP (HL) ; Jump to function + +SGNEXP: DEC D ; Dee to flag negative exponent + CP ZMINUS ; "-" token ? + RET Z ; Yes - Return + CP "-" ; "-" ASCII ? + RET Z ; Yes - Return + INC D ; Inc to flag positive exponent + CP "+" ; "+" ASCII ? + RET Z ; Yes - Return + CP ZPLUS ; "+" token ? + RET Z ; Yes - Return + DEC HL ; DEC 'cos GETCHR INCs + RET ; Return "NZ" + +POR: DB 0F6H ; Flag "OR" +PAND: XOR A ; Flag "AND" + PUSH AF ; Save "AND" / "OR" flag + CALL TSTNUM ; Make sure it's a number + CALL DEINT ; Get integer -32768 to 32767 + POP AF ; Restore "AND" / "OR" flag + EX DE,HL ; <- Get last + POP BC ; <- value + EX (SP),HL ; <- from + EX DE,HL ; <- stack + CALL FPBCDE ; Move last value to FPREG + PUSH AF ; Save "AND" / "OR" flag + CALL DEINT ; Get integer -32768 to 32767 + POP AF ; Restore "AND" / "OR" flag + POP BC ; Get value + LD A,C ; Get LSB + LD HL,ACPASS ; Address of save AC as current + JP NZ,POR1 ; Jump if OR + AND E ; "AND" LSBs + LD C,A ; Save LSB + LD A,B ; Get MBS + AND D ; "AND" MSBs + JP (HL) ; Save AC as current (ACPASS) + +POR1: OR E ; "OR" LSBs + LD C,A ; Save LSB + LD A,B ; Get MSB + OR D ; "OR" MSBs + JP (HL) ; Save AC as current (ACPASS) + +TSTRED: LD HL,CMPLOG ; Logical compare routine + LD A,(TYPE) ; Get data type + RRA ; Carry set = string + LD A,D ; Get last precedence value + RLA ; Times 2 plus carry + LD E,A ; To E + LD D,64H ; Relational precedence + LD A,B ; Get current precedence + CP D ; Compare with last + RET NC ; Eval if last was rel' or log' + JP STKTHS ; Stack this one and get next + +CMPLOG: DW CMPLG1 ; Compare two values / strings +CMPLG1: LD A,C ; Get data type + OR A + RRA + POP BC ; Get last expression to BCDE + POP DE + PUSH AF ; Save status + CALL CHKTYP ; Check that types match + LD HL,CMPRES ; Result to comparison + PUSH HL ; Save for RETurn + JP Z,CMPNUM ; Compare values if numeric + XOR A ; Compare two strings + LD (TYPE),A ; Set type to numeric + PUSH DE ; Save string name + CALL GSTRCU ; Get current string + LD A,(HL) ; Get length of string + INC HL + INC HL + LD C,(HL) ; Get LSB of address + INC HL + LD B,(HL) ; Get MSB of address + POP DE ; Restore string name + PUSH BC ; Save address of string + PUSH AF ; Save length of string + CALL GSTRDE ; Get second string + CALL LOADFP ; Get address of second string + POP AF ; Restore length of string 1 + LD D,A ; Length to D + POP HL ; Restore address of string 1 +CMPSTR: LD A,E ; Bytes of string 2 to do + OR D ; Bytes of string 1 to do + RET Z ; Exit if all bytes compared + LD A,D ; Get bytes of string 1 to do + SUB 1 + RET C ; Exit if end of string 1 + XOR A + CP E ; Bytes of string 2 to do + INC A + RET NC ; Exit if end of string 2 + DEC D ; Count bytes in string 1 + DEC E ; Count bytes in string 2 + LD A,(BC) ; Byte in string 2 + CP (HL) ; Compare to byte in string 1 + INC HL ; Move up string 1 + INC BC ; Move up string 2 + JP Z,CMPSTR ; Same - Try next bytes + CCF ; Flag difference (">" or "<") + JP FLGDIF ; "<" gives -1 , ">" gives +1 + +CMPRES: INC A ; Increment current value + ADC A,A ; Double plus carry + POP BC ; Get other value + AND B ; Combine them + ADD A,-1 ; Carry set if different + SBC A,A ; 00 - Equal , FF - Different + JP FLGREL ; Set current value & continue + +EVNOT: LD D,5AH ; Precedence value for "NOT" + CALL EVAL1 ; Eval until precedence break + CALL TSTNUM ; Make sure it's a number + CALL DEINT ; Get integer -32768 - 32767 + LD A,E ; Get LSB + CPL ; Invert LSB + LD C,A ; Save "NOT" of LSB + LD A,D ; Get MSB + CPL ; Invert MSB + CALL ACPASS ; Save AC as current + POP BC ; Clean up stack + JP EVAL3 ; Continue evaluation + +DIMRET: DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + RET Z ; End of DIM statement + CALL CHKSYN ; Make sure "," follows + DB "," +DIM: LD BC,DIMRET ; Return to "DIMRET" + PUSH BC ; Save on stack + DB 0F6H ; Flag "Create" variable +GETVAR: XOR A ; Find variable address,to DE + LD (LCRFLG),A ; Set locate / create flag + LD B,(HL) ; Get First byte of name +GTFNAM: CALL CHKLTR ; See if a letter + JP C,SNERR ; ?SN Error if not a letter + XOR A + LD C,A ; Clear second byte of name + LD (TYPE),A ; Set type to numeric + CALL GETCHR ; Get next character + JP C,SVNAM2 ; Numeric - Save in name + CALL CHKLTR ; See if a letter + JP C,CHARTY ; Not a letter - Check type +SVNAM2: LD C,A ; Save second byte of name +ENDNAM: CALL GETCHR ; Get next character + JP C,ENDNAM ; Numeric - Get another + CALL CHKLTR ; See if a letter + JP NC,ENDNAM ; Letter - Get another +CHARTY: SUB "$" ; String variable? + JP NZ,NOTSTR ; No - Numeric variable + INC A ; A = 1 (string type) + LD (TYPE),A ; Set type to string + RRCA ; A = 80H , Flag for string + ADD A,C ; 2nd byte of name has bit 7 on + LD C,A ; Resave second byte on name + CALL GETCHR ; Get next character +NOTSTR: LD A,(FORFLG) ; Array name needed ? + DEC A + JP Z,ARLDSV ; Yes - Get array name + JP P,NSCFOR ; No array with "FOR" or "FN" + LD A,(HL) ; Get byte again + SUB "(" ; Subscripted variable? + JP Z,SBSCPT ; Yes - Sort out subscript + +NSCFOR: XOR A ; Simple variable + LD (FORFLG),A ; Clear "FOR" flag + PUSH HL ; Save code string address + LD D,B ; DE = Variable name to find + LD E,C + LD HL,(FNRGNM) ; FN argument name + CALL CPDEHL ; Is it the FN argument? + LD DE,FNARG ; Point to argument value + JP Z,POPHRT ; Yes - Return FN argument value + LD HL,(VAREND) ; End of variables + EX DE,HL ; Address of end of search + LD HL,(PROGND) ; Start of variables address +FNDVAR: CALL CPDEHL ; End of variable list table? + JP Z,CFEVAL ; Yes - Called from EVAL? + LD A,C ; Get second byte of name + SUB (HL) ; Compare with name in list + INC HL ; Move on to first byte + JP NZ,FNTHR ; Different - Find another + LD A,B ; Get first byte of name + SUB (HL) ; Compare with name in list +FNTHR: INC HL ; Move on to LSB of value + JP Z,RETADR ; Found - Return address + INC HL ; <- Skip + INC HL ; <- over + INC HL ; <- F.P. + INC HL ; <- value + JP FNDVAR ; Keep looking + +CFEVAL: POP HL ; Restore code string address + EX (SP),HL ; Get return address + PUSH DE ; Save address of variable + LD DE,FRMEVL ; Return address in EVAL + CALL CPDEHL ; Called from EVAL ? + POP DE ; Restore address of variable + JP Z,RETNUL ; Yes - Return null variable + EX (SP),HL ; Put back return + PUSH HL ; Save code string address + PUSH BC ; Save variable name + LD BC,6 ; 2 byte name plus 4 byte data + LD HL,(ARREND) ; End of arrays + PUSH HL ; Save end of arrays + ADD HL,BC ; Move up 6 bytes + POP BC ; Source address in BC + PUSH HL ; Save new end address + CALL MOVUP ; Move arrays up + POP HL ; Restore new end address + LD (ARREND),HL ; Set new end address + LD H,B ; End of variables to HL + LD L,C + LD (VAREND),HL ; Set new end address + +ZEROLP: DEC HL ; Back through to zero variable + LD (HL),0 ; Zero byte in variable + CALL CPDEHL ; Done them all? + JP NZ,ZEROLP ; No - Keep on going + POP DE ; Get variable name + LD (HL),E ; Store second character + INC HL + LD (HL),D ; Store first character + INC HL +RETADR: EX DE,HL ; Address of variable in DE + POP HL ; Restore code string address + RET + +RETNUL: LD (FPEXP),A ; Set result to zero + LD HL,ZERBYT ; Also set a null string + LD (FPREG),HL ; Save for EVAL + POP HL ; Restore code string address + RET + +SBSCPT: PUSH HL ; Save code string address + LD HL,(LCRFLG) ; Locate/Create and Type + EX (SP),HL ; Save and get code string + LD D,A ; Zero number of dimensions +SCPTLP: PUSH DE ; Save number of dimensions + PUSH BC ; Save array name + CALL FPSINT ; Get subscript (0-32767) + POP BC ; Restore array name + POP AF ; Get number of dimensions + EX DE,HL + EX (SP),HL ; Save subscript value + PUSH HL ; Save LCRFLG and TYPE + EX DE,HL + INC A ; Count dimensions + LD D,A ; Save in D + LD A,(HL) ; Get next byte in code string + CP "," ; Comma (more to come)? + JP Z,SCPTLP ; Yes - More subscripts + CALL CHKSYN ; Make sure ")" follows + DB ")" + LD (NXTOPR),HL ; Save code string address + POP HL ; Get LCRFLG and TYPE + LD (LCRFLG),HL ; Restore Locate/create & type + LD E,0 ; Flag not CSAVE* or CLOAD* + PUSH DE ; Save number of dimensions (D) + DB 11H ; Skip "PUSH HL" and "PUSH AF' + +ARLDSV: PUSH HL ; Save code string address + PUSH AF ; A = 00 , Flags set = Z,N + LD HL,(VAREND) ; Start of arrays + DB 3EH ; Skip "ADD HL,DE" +FNDARY: ADD HL,DE ; Move to next array start + EX DE,HL + LD HL,(ARREND) ; End of arrays + EX DE,HL ; Current array pointer + CALL CPDEHL ; End of arrays found? + JP Z,CREARY ; Yes - Create array + LD A,(HL) ; Get second byte of name + CP C ; Compare with name given + INC HL ; Move on + JP NZ,NXTARY ; Different - Find next array + LD A,(HL) ; Get first byte of name + CP B ; Compare with name given +NXTARY: INC HL ; Move on + LD E,(HL) ; Get LSB of next array address + INC HL + LD D,(HL) ; Get MSB of next array address + INC HL + JP NZ,FNDARY ; Not found - Keep looking + LD A,(LCRFLG) ; Found Locate or Create it? + OR A + JP NZ,DDERR ; Create - ?DD Error + POP AF ; Locate - Get number of dim'ns + LD B,H ; BC Points to array dim'ns + LD C,L + JP Z,POPHRT ; Jump if array load/save + SUB (HL) ; Same number of dimensions? + JP Z,FINDEL ; Yes - Find element +BSERR: LD E,BS ; ?BS Error + JP ERROR ; Output error + +CREARY: LD DE,4 ; 4 Bytes per entry + POP AF ; Array to save or 0 dim'ns? + JP Z,FCERR ; Yes - ?FC Error + LD (HL),C ; Save second byte of name + INC HL + LD (HL),B ; Save first byte of name + INC HL + LD C,A ; Number of dimensions to C + CALL CHKSTK ; Check if enough memory + INC HL ; Point to number of dimensions + INC HL + LD (CUROPR),HL ; Save address of pointer + LD (HL),C ; Set number of dimensions + INC HL + LD A,(LCRFLG) ; Locate of Create? + RLA ; Carry set = Create + LD A,C ; Get number of dimensions +CRARLP: LD BC,10+1 ; Default dimension size 10 + JP NC,DEFSIZ ; Locate - Set default size + POP BC ; Get specified dimension size + INC BC ; Include zero element +DEFSIZ: LD (HL),C ; Save LSB of dimension size + INC HL + LD (HL),B ; Save MSB of dimension size + INC HL + PUSH AF ; Save num' of dim'ns an status + PUSH HL ; Save address of dim'n size + CALL MLDEBC ; Multiply DE by BC to find + EX DE,HL ; amount of mem needed (to DE) + POP HL ; Restore address of dimension + POP AF ; Restore number of dimensions + DEC A ; Count them + JP NZ,CRARLP ; Do next dimension if more + PUSH AF ; Save locate/create flag + LD B,D ; MSB of memory needed + LD C,E ; LSB of memory needed + EX DE,HL + ADD HL,DE ; Add bytes to array start + JP C,OMERR ; Too big - Error + CALL ENFMEM ; See if enough memory + LD (ARREND),HL ; Save new end of array + +ZERARY: DEC HL ; Back through array data + LD (HL),0 ; Set array element to zero + CALL CPDEHL ; All elements zeroed? + JP NZ,ZERARY ; No - Keep on going + INC BC ; Number of bytes + 1 + LD D,A ; A=0 + LD HL,(CUROPR) ; Get address of array + LD E,(HL) ; Number of dimensions + EX DE,HL ; To HL + ADD HL,HL ; Two bytes per dimension size + ADD HL,BC ; Add number of bytes + EX DE,HL ; Bytes needed to DE + DEC HL + DEC HL + LD (HL),E ; Save LSB of bytes needed + INC HL + LD (HL),D ; Save MSB of bytes needed + INC HL + POP AF ; Locate / Create? + JP C,ENDDIM ; A is 0 , End if create +FINDEL: LD B,A ; Find array element + LD C,A + LD A,(HL) ; Number of dimensions + INC HL + DB 16H ; Skip "POP HL" +FNDELP: POP HL ; Address of next dim' size + LD E,(HL) ; Get LSB of dim'n size + INC HL + LD D,(HL) ; Get MSB of dim'n size + INC HL + EX (SP),HL ; Save address - Get index + PUSH AF ; Save number of dim'ns + CALL CPDEHL ; Dimension too large? + JP NC,BSERR ; Yes - ?BS Error + PUSH HL ; Save index + CALL MLDEBC ; Multiply previous by size + POP DE ; Index supplied to DE + ADD HL,DE ; Add index to pointer + POP AF ; Number of dimensions + DEC A ; Count them + LD B,H ; MSB of pointer + LD C,L ; LSB of pointer + JP NZ,FNDELP ; More - Keep going + ADD HL,HL ; 4 Bytes per element + ADD HL,HL + POP BC ; Start of array + ADD HL,BC ; Point to element + EX DE,HL ; Address of element to DE +ENDDIM: LD HL,(NXTOPR) ; Got code string address + RET + +FRE: LD HL,(ARREND) ; Start of free memory + EX DE,HL ; To DE + LD HL,0 ; End of free memory + ADD HL,SP ; Current stack value + LD A,(TYPE) ; Dummy argument type + OR A + JP Z,FRENUM ; Numeric - Free variable space + CALL GSTRCU ; Current string to pool + CALL GARBGE ; Garbage collection + LD HL,(STRSPC) ; Bottom of string space in use + EX DE,HL ; To DE + LD HL,(STRBOT) ; Bottom of string space +FRENUM: LD A,L ; Get LSB of end + SUB E ; Subtract LSB of beginning + LD C,A ; Save difference if C + LD A,H ; Get MSB of end + SBC A,D ; Subtract MSB of beginning +ACPASS: LD B,C ; Return integer AC +ABPASS: LD D,B ; Return integer AB + LD E,0 + LD HL,TYPE ; Point to type + LD (HL),E ; Set type to numeric + LD B,80H+16 ; 16 bit integer + JP RETINT ; Return the integr + +POS: LD A,(CURPOS) ; Get cursor position +PASSA: LD B,A ; Put A into AB + XOR A ; Zero A + JP ABPASS ; Return integer AB + +DEF: CALL CHEKFN ; Get "FN" and name + CALL IDTEST ; Test for illegal direct + LD BC,DATA ; To get next statement + PUSH BC ; Save address for RETurn + PUSH DE ; Save address of function ptr + CALL CHKSYN ; Make sure "(" follows + DB "(" + CALL GETVAR ; Get argument variable name + PUSH HL ; Save code string address + EX DE,HL ; Argument address to HL + DEC HL + LD D,(HL) ; Get first byte of arg name + DEC HL + LD E,(HL) ; Get second byte of arg name + POP HL ; Restore code string address + CALL TSTNUM ; Make sure numeric argument + CALL CHKSYN ; Make sure ")" follows + DB ")" + CALL CHKSYN ; Make sure "=" follows + DB ZEQUAL ; "=" token + LD B,H ; Code string address to BC + LD C,L + EX (SP),HL ; Save code str , Get FN ptr + LD (HL),C ; Save LSB of FN code string + INC HL + LD (HL),B ; Save MSB of FN code string + JP SVSTAD ; Save address and do function + +DOFN: CALL CHEKFN ; Make sure FN follows + PUSH DE ; Save function pointer address + CALL EVLPAR ; Evaluate expression in "()" + CALL TSTNUM ; Make sure numeric result + EX (SP),HL ; Save code str , Get FN ptr + LD E,(HL) ; Get LSB of FN code string + INC HL + LD D,(HL) ; Get MSB of FN code string + INC HL + LD A,D ; And function DEFined? + OR E + JP Z,UFERR ; No - ?UF Error + LD A,(HL) ; Get LSB of argument address + INC HL + LD H,(HL) ; Get MSB of argument address + LD L,A ; HL = Arg variable address + PUSH HL ; Save it + LD HL,(FNRGNM) ; Get old argument name + EX (SP),HL ; ; Save old , Get new + LD (FNRGNM),HL ; Set new argument name + LD HL,(FNARG+2) ; Get LSB,NLSB of old arg value + PUSH HL ; Save it + LD HL,(FNARG) ; Get MSB,EXP of old arg value + PUSH HL ; Save it + LD HL,FNARG ; HL = Value of argument + PUSH DE ; Save FN code string address + CALL FPTHL ; Move FPREG to argument + POP HL ; Get FN code string address + CALL GETNUM ; Get value from function + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP NZ,SNERR ; Bad character in FN - Error + POP HL ; Get MSB,EXP of old arg + LD (FNARG),HL ; Restore it + POP HL ; Get LSB,NLSB of old arg + LD (FNARG+2),HL ; Restore it + POP HL ; Get name of old arg + LD (FNRGNM),HL ; Restore it + POP HL ; Restore code string address + RET + +IDTEST: PUSH HL ; Save code string address + LD HL,(LINEAT) ; Get current line number + INC HL ; -1 means direct statement + LD A,H + OR L + POP HL ; Restore code string address + RET NZ ; Return if in program + LD E,ID ; ?ID Error + JP ERROR + +CHEKFN: CALL CHKSYN ; Make sure FN follows + DB ZFN ; "FN" token + LD A,80H + LD (FORFLG),A ; Flag FN name to find + OR (HL) ; FN name has bit 7 set + LD B,A ; in first byte of name + CALL GTFNAM ; Get FN name + JP TSTNUM ; Make sure numeric function + +STR: CALL TSTNUM ; Make sure it's a number + CALL NUMASC ; Turn number into text + CALL CRTST ; Create string entry for it + CALL GSTRCU ; Current string to pool + LD BC,TOPOOL ; Save in string pool + PUSH BC ; Save address on stack + +SAVSTR: LD A,(HL) ; Get string length + INC HL + INC HL + PUSH HL ; Save pointer to string + CALL TESTR ; See if enough string space + POP HL ; Restore pointer to string + LD C,(HL) ; Get LSB of address + INC HL + LD B,(HL) ; Get MSB of address + CALL CRTMST ; Create string entry + PUSH HL ; Save pointer to MSB of addr + LD L,A ; Length of string + CALL TOSTRA ; Move to string area + POP DE ; Restore pointer to MSB + RET + +MKTMST: CALL TESTR ; See if enough string space +CRTMST: LD HL,TMPSTR ; Temporary string + PUSH HL ; Save it + LD (HL),A ; Save length of string + INC HL +SVSTAD: INC HL + LD (HL),E ; Save LSB of address + INC HL + LD (HL),D ; Save MSB of address + POP HL ; Restore pointer + RET + +CRTST: DEC HL ; DEC - INCed after +QTSTR: LD B,'"' ; Terminating quote + LD D,B ; Quote to D +DTSTR: PUSH HL ; Save start + LD C,-1 ; Set counter to -1 +QTSTLP: INC HL ; Move on + LD A,(HL) ; Get byte + INC C ; Count bytes + OR A ; End of line? + JP Z,CRTSTE ; Yes - Create string entry + CP D ; Terminator D found? + JP Z,CRTSTE ; Yes - Create string entry + CP B ; Terminator B found? + JP NZ,QTSTLP ; No - Keep looking +CRTSTE: CP '"' ; End with '"'? + CALL Z,GETCHR ; Yes - Get next character + EX (SP),HL ; Starting quote + INC HL ; First byte of string + EX DE,HL ; To DE + LD A,C ; Get length + CALL CRTMST ; Create string entry +TSTOPL: LD DE,TMPSTR ; Temporary string + LD HL,(TMSTPT) ; Temporary string pool pointer + LD (FPREG),HL ; Save address of string ptr + LD A,1 + LD (TYPE),A ; Set type to string + CALL DETHL4 ; Move string to pool + CALL CPDEHL ; Out of string pool? + LD (TMSTPT),HL ; Save new pointer + POP HL ; Restore code string address + LD A,(HL) ; Get next code byte + RET NZ ; Return if pool OK + LD E,ST ; ?ST Error + JP ERROR ; String pool overflow + +PRNUMS: INC HL ; Skip leading space +PRS: CALL CRTST ; Create string entry for it +PRS1: CALL GSTRCU ; Current string to pool + CALL LOADFP ; Move string block to BCDE + INC E ; Length + 1 +PRSLP: DEC E ; Count characters + RET Z ; End of string + LD A,(BC) ; Get byte to output + CALL OUTC ; Output character in A + CP CR ; Return? + CALL Z,DONULL ; Yes - Do nulls + INC BC ; Next byte in string + JP PRSLP ; More characters to output + +TESTR: OR A ; Test if enough room + DB 0EH ; No garbage collection done +GRBDON: POP AF ; Garbage collection done + PUSH AF ; Save status + LD HL,(STRSPC) ; Bottom of string space in use + EX DE,HL ; To DE + LD HL,(STRBOT) ; Bottom of string area + CPL ; Negate length (Top down) + LD C,A ; -Length to BC + LD B,-1 ; BC = -ve length of string + ADD HL,BC ; Add to bottom of space in use + INC HL ; Plus one for 2's complement + CALL CPDEHL ; Below string RAM area? + JP C,TESTOS ; Tidy up if not done else err + LD (STRBOT),HL ; Save new bottom of area + INC HL ; Point to first byte of string + EX DE,HL ; Address to DE +POPAF: POP AF ; Throw away status push + RET + +TESTOS: POP AF ; Garbage collect been done? + LD E,OS ; ?OS Error + JP Z,ERROR ; Yes - Not enough string apace + CP A ; Flag garbage collect done + PUSH AF ; Save status + LD BC,GRBDON ; Garbage collection done + PUSH BC ; Save for RETurn +GARBGE: LD HL,(LSTRAM) ; Get end of RAM pointer +GARBLP: LD (STRBOT),HL ; Reset string pointer + LD HL,0 + PUSH HL ; Flag no string found + LD HL,(STRSPC) ; Get bottom of string space + PUSH HL ; Save bottom of string space + LD HL,TMSTPL ; Temporary string pool +GRBLP: EX DE,HL + LD HL,(TMSTPT) ; Temporary string pool pointer + EX DE,HL + CALL CPDEHL ; Temporary string pool done? + LD BC,GRBLP ; Loop until string pool done + JP NZ,STPOOL ; No - See if in string area + LD HL,(PROGND) ; Start of simple variables +SMPVAR: EX DE,HL + LD HL,(VAREND) ; End of simple variables + EX DE,HL + CALL CPDEHL ; All simple strings done? + JP Z,ARRLP ; Yes - Do string arrays + LD A,(HL) ; Get type of variable + INC HL + INC HL + OR A ; "S" flag set if string + CALL STRADD ; See if string in string area + JP SMPVAR ; Loop until simple ones done + +GNXARY: POP BC ; Scrap address of this array +ARRLP: EX DE,HL + LD HL,(ARREND) ; End of string arrays + EX DE,HL + CALL CPDEHL ; All string arrays done? + JP Z,SCNEND ; Yes - Move string if found + CALL LOADFP ; Get array name to BCDE + LD A,E ; Get type of array + PUSH HL ; Save address of num of dim'ns + ADD HL,BC ; Start of next array + OR A ; Test type of array + JP P,GNXARY ; Numeric array - Ignore it + LD (CUROPR),HL ; Save address of next array + POP HL ; Get address of num of dim'ns + LD C,(HL) ; BC = Number of dimensions + LD B,0 + ADD HL,BC ; Two bytes per dimension size + ADD HL,BC + INC HL ; Plus one for number of dim'ns +GRBARY: EX DE,HL + LD HL,(CUROPR) ; Get address of next array + EX DE,HL + CALL CPDEHL ; Is this array finished? + JP Z,ARRLP ; Yes - Get next one + LD BC,GRBARY ; Loop until array all done +STPOOL: PUSH BC ; Save return address + OR 80H ; Flag string type +STRADD: LD A,(HL) ; Get string length + INC HL + INC HL + LD E,(HL) ; Get LSB of string address + INC HL + LD D,(HL) ; Get MSB of string address + INC HL + RET P ; Not a string - Return + OR A ; Set flags on string length + RET Z ; Null string - Return + LD B,H ; Save variable pointer + LD C,L + LD HL,(STRBOT) ; Bottom of new area + CALL CPDEHL ; String been done? + LD H,B ; Restore variable pointer + LD L,C + RET C ; String done - Ignore + POP HL ; Return address + EX (SP),HL ; Lowest available string area + CALL CPDEHL ; String within string area? + EX (SP),HL ; Lowest available string area + PUSH HL ; Re-save return address + LD H,B ; Restore variable pointer + LD L,C + RET NC ; Outside string area - Ignore + POP BC ; Get return , Throw 2 away + POP AF ; + POP AF ; + PUSH HL ; Save variable pointer + PUSH DE ; Save address of current + PUSH BC ; Put back return address + RET ; Go to it + +SCNEND: POP DE ; Addresses of strings + POP HL ; + LD A,L ; HL = 0 if no more to do + OR H + RET Z ; No more to do - Return + DEC HL + LD B,(HL) ; MSB of address of string + DEC HL + LD C,(HL) ; LSB of address of string + PUSH HL ; Save variable address + DEC HL + DEC HL + LD L,(HL) ; HL = Length of string + LD H,0 + ADD HL,BC ; Address of end of string+1 + LD D,B ; String address to DE + LD E,C + DEC HL ; Last byte in string + LD B,H ; Address to BC + LD C,L + LD HL,(STRBOT) ; Current bottom of string area + CALL MOVSTR ; Move string to new address + POP HL ; Restore variable address + LD (HL),C ; Save new LSB of address + INC HL + LD (HL),B ; Save new MSB of address + LD L,C ; Next string area+1 to HL + LD H,B + DEC HL ; Next string area address + JP GARBLP ; Look for more strings + +CONCAT: PUSH BC ; Save prec' opr & code string + PUSH HL ; + LD HL,(FPREG) ; Get first string + EX (SP),HL ; Save first string + CALL OPRND ; Get second string + EX (SP),HL ; Restore first string + CALL TSTSTR ; Make sure it's a string + LD A,(HL) ; Get length of second string + PUSH HL ; Save first string + LD HL,(FPREG) ; Get second string + PUSH HL ; Save second string + ADD A,(HL) ; Add length of second string + LD E,LS ; ?LS Error + JP C,ERROR ; String too long - Error + CALL MKTMST ; Make temporary string + POP DE ; Get second string to DE + CALL GSTRDE ; Move to string pool if needed + EX (SP),HL ; Get first string + CALL GSTRHL ; Move to string pool if needed + PUSH HL ; Save first string + LD HL,(TMPSTR+2) ; Temporary string address + EX DE,HL ; To DE + CALL SSTSA ; First string to string area + CALL SSTSA ; Second string to string area + LD HL,EVAL2 ; Return to evaluation loop + EX (SP),HL ; Save return,get code string + PUSH HL ; Save code string address + JP TSTOPL ; To temporary string to pool + +SSTSA: POP HL ; Return address + EX (SP),HL ; Get string block,save return + LD A,(HL) ; Get length of string + INC HL + INC HL + LD C,(HL) ; Get LSB of string address + INC HL + LD B,(HL) ; Get MSB of string address + LD L,A ; Length to L +TOSTRA: INC L ; INC - DECed after +TSALP: DEC L ; Count bytes moved + RET Z ; End of string - Return + LD A,(BC) ; Get source + LD (DE),A ; Save destination + INC BC ; Next source + INC DE ; Next destination + JP TSALP ; Loop until string moved + +GETSTR: CALL TSTSTR ; Make sure it's a string +GSTRCU: LD HL,(FPREG) ; Get current string +GSTRHL: EX DE,HL ; Save DE +GSTRDE: CALL BAKTMP ; Was it last tmp-str? + EX DE,HL ; Restore DE + RET NZ ; No - Return + PUSH DE ; Save string + LD D,B ; String block address to DE + LD E,C + DEC DE ; Point to length + LD C,(HL) ; Get string length + LD HL,(STRBOT) ; Current bottom of string area + CALL CPDEHL ; Last one in string area? + JP NZ,POPHL ; No - Return + LD B,A ; Clear B (A=0) + ADD HL,BC ; Remove string from str' area + LD (STRBOT),HL ; Save new bottom of str' area +POPHL: POP HL ; Restore string + RET + +BAKTMP: LD HL,(TMSTPT) ; Get temporary string pool top + DEC HL ; Back + LD B,(HL) ; Get MSB of address + DEC HL ; Back + LD C,(HL) ; Get LSB of address + DEC HL ; Back + DEC HL ; Back + CALL CPDEHL ; String last in string pool? + RET NZ ; Yes - Leave it + LD (TMSTPT),HL ; Save new string pool top + RET + +LEN: LD BC,PASSA ; To return integer A + PUSH BC ; Save address +GETLEN: CALL GETSTR ; Get string and its length + XOR A + LD D,A ; Clear D + LD (TYPE),A ; Set type to numeric + LD A,(HL) ; Get length of string + OR A ; Set status flags + RET + +ASC: LD BC,PASSA ; To return integer A + PUSH BC ; Save address +GTFLNM: CALL GETLEN ; Get length of string + JP Z,FCERR ; Null string - Error + INC HL + INC HL + LD E,(HL) ; Get LSB of address + INC HL + LD D,(HL) ; Get MSB of address + LD A,(DE) ; Get first byte of string + RET + +CHR: LD A,1 ; One character string + CALL MKTMST ; Make a temporary string + CALL MAKINT ; Make it integer A + LD HL,(TMPSTR+2) ; Get address of string + LD (HL),E ; Save character +TOPOOL: POP BC ; Clean up stack + JP TSTOPL ; Temporary string to pool + +LEFT: CALL LFRGNM ; Get number and ending ")" + XOR A ; Start at first byte in string +RIGHT1: EX (SP),HL ; Save code string,Get string + LD C,A ; Starting position in string +MID1: PUSH HL ; Save string block address + LD A,(HL) ; Get length of string + CP B ; Compare with number given + JP C,ALLFOL ; All following bytes required + LD A,B ; Get new length + DB 11H ; Skip "LD C,0" +ALLFOL: LD C,0 ; First byte of string + PUSH BC ; Save position in string + CALL TESTR ; See if enough string space + POP BC ; Get position in string + POP HL ; Restore string block address + PUSH HL ; And re-save it + INC HL + INC HL + LD B,(HL) ; Get LSB of address + INC HL + LD H,(HL) ; Get MSB of address + LD L,B ; HL = address of string + LD B,0 ; BC = starting address + ADD HL,BC ; Point to that byte + LD B,H ; BC = source string + LD C,L + CALL CRTMST ; Create a string entry + LD L,A ; Length of new string + CALL TOSTRA ; Move string to string area + POP DE ; Clear stack + CALL GSTRDE ; Move to string pool if needed + JP TSTOPL ; Temporary string to pool + +RIGHT: CALL LFRGNM ; Get number and ending ")" + POP DE ; Get string length + PUSH DE ; And re-save + LD A,(DE) ; Get length + SUB B ; Move back N bytes + JP RIGHT1 ; Go and get sub-string + +MID: EX DE,HL ; Get code string address + LD A,(HL) ; Get next byte "," or ")" + CALL MIDNUM ; Get number supplied + INC B ; Is it character zero? + DEC B + JP Z,FCERR ; Yes - Error + PUSH BC ; Save starting position + LD E,255 ; All of string + CP ")" ; Any length given? + JP Z,RSTSTR ; No - Rest of string + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETINT ; Get integer 0-255 +RSTSTR: CALL CHKSYN ; Make sure ")" follows + DB ")" + POP AF ; Restore starting position + EX (SP),HL ; Get string,8ave code string + LD BC,MID1 ; Continuation of MID$ routine + PUSH BC ; Save for return + DEC A ; Starting position-1 + CP (HL) ; Compare with length + LD B,0 ; Zero bytes length + RET NC ; Null string if start past end + LD C,A ; Save starting position-1 + LD A,(HL) ; Get length of string + SUB C ; Subtract start + CP E ; Enough string for it? + LD B,A ; Save maximum length available + RET C ; Truncate string if needed + LD B,E ; Set specified length + RET ; Go and create string + +VAL: CALL GETLEN ; Get length of string + JP Z,RESZER ; Result zero + LD E,A ; Save length + INC HL + INC HL + LD A,(HL) ; Get LSB of address + INC HL + LD H,(HL) ; Get MSB of address + LD L,A ; HL = String address + PUSH HL ; Save string address + ADD HL,DE + LD B,(HL) ; Get end of string+1 byte + LD (HL),D ; Zero it to terminate + EX (SP),HL ; Save string end,get start + PUSH BC ; Save end+1 byte + LD A,(HL) ; Get starting byte + CALL ASCTFP ; Convert ASCII string to FP + POP BC ; Restore end+1 byte + POP HL ; Restore end+1 address + LD (HL),B ; Put back original byte + RET + +LFRGNM: EX DE,HL ; Code string address to HL + CALL CHKSYN ; Make sure ")" follows + DB ")" +MIDNUM: POP BC ; Get return address + POP DE ; Get number supplied + PUSH BC ; Re-save return address + LD B,E ; Number to B + RET + +INP: CALL MAKINT ; Make it integer A + LD (INPORT),A ; Set input port + CALL INPSUB ; Get input from port + JP PASSA ; Return integer A + +POUT: CALL SETIO ; Set up port number + JP OUTSUB ; Output data and return + +WAIT: CALL SETIO ; Set up port number + PUSH AF ; Save AND mask + LD E,0 ; Assume zero if none given + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + JP Z,NOXOR ; No XOR byte given + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETINT ; Get integer 0-255 to XOR with +NOXOR: POP BC ; Restore AND mask +WAITLP: CALL INPSUB ; Get input + XOR E ; Flip selected bits + AND B ; Result non-zero? + JP Z,WAITLP ; No = keep waiting + RET + +SETIO: CALL GETINT ; Get integer 0-255 + LD (INPORT),A ; Set input port + LD (OTPORT),A ; Set output port + CALL CHKSYN ; Make sure "," follows + DB "," + JP GETINT ; Get integer 0-255 and return + +FNDNUM: CALL GETCHR ; Get next character +GETINT: CALL GETNUM ; Get a number from 0 to 255 +MAKINT: CALL DEPINT ; Make sure value 0 - 255 + LD A,D ; Get MSB of number + OR A ; Zero? + JP NZ,FCERR ; No - Error + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + LD A,E ; Get number to A + RET + +; << NO REFERENCE TO THIS SECTION OF CODE >> +; << Set up another program area (can be in ROM) >> + + LD HL,(BASTXT) ; Get start of program text + LD (PROGND),HL ; Set more variable space + LD HL,8000H ; Address of new program + LD E,(HL) ; Get LSB of new RAM end + INC HL + LD D,(HL) ; Get MSB of new RAM end + INC HL + INC HL ; Null at start of program + LD (BASTXT),HL ; New program text area 8003H + EX DE,HL ; New RAM end to HL + LD (LSTRAM),HL ; Set new RAM end + LD (STRSPC),HL ; Clear string space + LD BC,RUNCNT ; Execution driver loop + PUSH BC ; Save for return + JP RUNFST ; Clear variables and continue + +RUART: JP GUART ; Get a byte from UART + +WUART2: CALL WUART ; Send 2 Bytes to UART +WUART: PUSH AF ; Save byte + PUSH BC ; Save BC + LD C,A ; Byte to C + CALL SUART ; Send byte to UART + POP BC ; Restore BC + POP AF ; Restore byte + RET + +CSAVE: LD B,1 ; Flag "CSAVE" + CP ZTIMES ; "*" token? ("CSAVE*") + JP Z,ARRSV1 ; Yes - Array save + CALL EVAL ; Evaluate expression + PUSH HL ; Save code string address + CALL GTFLNM ; Get file name + PUSH DE ; Save file name + CALL CASFFW ; Turn on motor and wait + POP DE ; Restore file name + LD A,11010011B ; Header byte + CALL WUART ; Send byte to UART + CALL WUART2 ; Send byte twice more + LD A,(DE) ; Get file name + CALL WUART ; Send it to UART + NOP + NOP + NOP + LD HL,PROGND ; Start of program information + LD (ARG1),HL ; Save for monitor save routine + LD HL,(PROGND) ; End of program information + LD (ARG2),HL ; Save for monitor save routine + CALL SAVE ; Save program to tape + CALL ARET ; Not much there! + POP HL ; Restore code string address + RET + +CLOAD: LD A,(HL) ; Get byte after "CLOAD" + CP ZTIMES ; "*" token? ("CLOAD*") + JP Z,ARRLD1 ; Yes - Array load + CALL SMOTOR ; Start motor and get "?" + SUB ZPRINT ; "?" ("PRINT" token) Verify? + JP Z,FLGVER ; Yes - Flag "verify" + XOR A ; Flag "load" + DB 01H ; Skip "CPL" and "INC HL" +FLGVER: CPL ; Flag "verify" + INC HL ; Skip over "?" + PUSH AF ; Save verify flag + DEC HL ; DEC 'cos GETCHR INCs + CALL GETCHR ; Get next character + LD A,0 ; Any file will do + JP Z,ANYNAM ; No name given - Any will do + CALL EVAL ; Evaluate expression + CALL GTFLNM ; Get file name + LD A,(DE) ; Get first byte of name +ANYNAM: LD L,A ; Save name to find + POP AF ; Get verify flag + PUSH AF ; And re-save + OR A ; Verify of load? + LD H,A + LD (FPREG),HL ; Save nam of file to find + CALL Z,CLRPTR ; Load - Clear pointers + LD HL,(FPREG) ; Get name of program to find + EX DE,HL ; Name to DE +CLOAD1: LD B,3 ; 3 Header bytes +CLOAD2: CALL RUART ; Get a byte from UART + SUB 11010011B ; Header byte? + JP NZ,CLOAD1 ; Look for header + DEC B ; Count header bytes + JP NZ,CLOAD2 ; More to find? + CALL RUART ; Get name of file + CALL FILFND ; Display "file X found" + INC E ; Any file name given? + DEC E + JP Z,THSFIL ; No - This file will do + CP E ; Has file been found? + JP NZ,CLOAD1 ; No - Look for another +THSFIL: NOP + NOP + NOP + POP AF ; Get verify flag + OR A ; Load or verify? + JP NZ,CLOADV ; Verify program + CALL MONLD ; Use monitor to load program + LD HL,(PROGND) ; Get end of program + CALL ENFMEM ; See if enough memory + JP CLOADE ; "Ok" and set up pointers + +CLOADV: CALL MONVE ; Use monitor to verify program +CLOADE: LD HL,OKMSG ; "Ok" message + CALL PRS ; Output string + CALL ARET ; Not a lot there! + JP SETPTR ; Set up line pointers + +OUTBAD: LD HL,BAD ; "Bad" message + CALL PRS ; Output string + JP ERRIN ; In line message + +FILFND: PUSH BC ; <- Save + PUSH HL ; <- all + PUSH DE ; <- the + PUSH AF ; <- registers + LD HL,FILE ; "File" message + CALL PRS ; Output string + POP AF ; Get file name + PUSH AF ; And re-save + CALL CONMON ; Output file name to screen + LD HL,FOUND ; "Found" message + CALL PRS ; Output string + POP AF ; <- Restore + POP DE ; <- all + POP HL ; <- the + POP BC ; <- registers + RET + +FILE: DB "File ",0 +FOUND: DB " Found",CR,LF,0 +BAD: DB "Bad",0,0,0 + +PEEK: CALL DEINT ; Get memory address + LD A,(DE) ; Get byte in memory + JP PASSA ; Return integer A + +POKE: CALL GETNUM ; Get memory address + CALL DEINT ; Get integer -32768 to 3276 + PUSH DE ; Save memory address + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETINT ; Get integer 0-255 + POP DE ; Restore memory address + LD (DE),A ; Load it into memory + RET + +ROUND: LD HL,HALF ; Add 0.5 to FPREG +ADDPHL: CALL LOADFP ; Load FP at (HL) to BCDE + JP FPADD ; Add BCDE to FPREG + +SUBPHL: CALL LOADFP ; FPREG = -FPREG + number at HL + DB 21H ; Skip "POP BC" and "POP DE" +PSUB: POP BC ; Get FP number from stack + POP DE +SUBCDE: CALL INVSGN ; Negate FPREG +FPADD: LD A,B ; Get FP exponent + OR A ; Is number zero? + RET Z ; Yes - Nothing to add + LD A,(FPEXP) ; Get FPREG exponent + OR A ; Is this number zero? + JP Z,FPBCDE ; Yes - Move BCDE to FPREG + SUB B ; BCDE number larger? + JP NC,NOSWAP ; No - Don't swap them + CPL ; Two's complement + INC A ; FP exponent + EX DE,HL + CALL STAKFP ; Put FPREG on stack + EX DE,HL + CALL FPBCDE ; Move BCDE to FPREG + POP BC ; Restore number from stack + POP DE +NOSWAP: CP 24+1 ; Second number insignificant? + RET NC ; Yes - First number is result + PUSH AF ; Save number of bits to scale + CALL SIGNS ; Set MSBs & sign of result + LD H,A ; Save sign of result + POP AF ; Restore scaling factor + CALL SCALE ; Scale BCDE to same exponent + OR H ; Result to be positive? + LD HL,FPREG ; Point to FPREG + JP P,MINCDE ; No - Subtract FPREG from CDE + CALL PLUCDE ; Add FPREG to CDE + JP NC,RONDUP ; No overflow - Round it up + INC HL ; Point to exponent + INC (HL) ; Increment it + JP Z,OVERR ; Number overflowed - Error + LD L,1 ; 1 bit to shift right + CALL SHRT1 ; Shift result right + JP RONDUP ; Round it up + +MINCDE: XOR A ; Clear A and carry + SUB B ; Negate exponent + LD B,A ; Re-save exponent + LD A,(HL) ; Get LSB of FPREG + SBC A, E ; Subtract LSB of BCDE + LD E,A ; Save LSB of BCDE + INC HL + LD A,(HL) ; Get NMSB of FPREG + SBC A,D ; Subtract NMSB of BCDE + LD D,A ; Save NMSB of BCDE + INC HL + LD A,(HL) ; Get MSB of FPREG + SBC A,C ; Subtract MSB of BCDE + LD C,A ; Save MSB of BCDE +CONPOS: CALL C,COMPL ; Overflow - Make it positive + +BNORM: LD L,B ; L = Exponent + LD H,E ; H = LSB + XOR A +BNRMLP: LD B,A ; Save bit count + LD A,C ; Get MSB + OR A ; Is it zero? + JP NZ,PNORM ; No - Do it bit at a time + LD C,D ; MSB = NMSB + LD D,H ; NMSB= LSB + LD H,L ; LSB = VLSB + LD L,A ; VLSB= 0 + LD A,B ; Get exponent + SUB 8 ; Count 8 bits + CP -24-8 ; Was number zero? + JP NZ,BNRMLP ; No - Keep normalising +RESZER: XOR A ; Result is zero +SAVEXP: LD (FPEXP),A ; Save result as zero + RET + +NORMAL: DEC B ; Count bits + ADD HL,HL ; Shift HL left + LD A,D ; Get NMSB + RLA ; Shift left with last bit + LD D,A ; Save NMSB + LD A,C ; Get MSB + ADC A,A ; Shift left with last bit + LD C,A ; Save MSB +PNORM: JP P,NORMAL ; Not done - Keep going + LD A,B ; Number of bits shifted + LD E,H ; Save HL in EB + LD B,L + OR A ; Any shifting done? + JP Z,RONDUP ; No - Round it up + LD HL,FPEXP ; Point to exponent + ADD A,(HL) ; Add shifted bits + LD (HL),A ; Re-save exponent + JP NC,RESZER ; Underflow - Result is zero + RET Z ; Result is zero +RONDUP: LD A,B ; Get VLSB of number +RONDB: LD HL,FPEXP ; Point to exponent + OR A ; Any rounding? + CALL M,FPROND ; Yes - Round number up + LD B,(HL) ; B = Exponent + INC HL + LD A,(HL) ; Get sign of result + AND 10000000B ; Only bit 7 needed + XOR C ; Set correct sign + LD C,A ; Save correct sign in number + JP FPBCDE ; Move BCDE to FPREG + +FPROND: INC E ; Round LSB + RET NZ ; Return if ok + INC D ; Round NMSB + RET NZ ; Return if ok + INC C ; Round MSB + RET NZ ; Return if ok + LD C,80H ; Set normal value + INC (HL) ; Increment exponent + RET NZ ; Return if ok + JP OVERR ; Overflow error + +PLUCDE: LD A,(HL) ; Get LSB of FPREG + ADD A,E ; Add LSB of BCDE + LD E,A ; Save LSB of BCDE + INC HL + LD A,(HL) ; Get NMSB of FPREG + ADC A,D ; Add NMSB of BCDE + LD D,A ; Save NMSB of BCDE + INC HL + LD A,(HL) ; Get MSB of FPREG + ADC A,C ; Add MSB of BCDE + LD C,A ; Save MSB of BCDE + RET + +COMPL: LD HL,SGNRES ; Sign of result + LD A,(HL) ; Get sign of result + CPL ; Negate it + LD (HL),A ; Put it back + XOR A + LD L,A ; Set L to zero + SUB B ; Negate exponent,set carry + LD B,A ; Re-save exponent + LD A,L ; Load zero + SBC A,E ; Negate LSB + LD E,A ; Re-save LSB + LD A,L ; Load zero + SBC A,D ; Negate NMSB + LD D,A ; Re-save NMSB + LD A,L ; Load zero + SBC A,C ; Negate MSB + LD C,A ; Re-save MSB + RET + +SCALE: LD B,0 ; Clear underflow +SCALLP: SUB 8 ; 8 bits (a whole byte)? + JP C,SHRITE ; No - Shift right A bits + LD B,E ; <- Shift + LD E,D ; <- right + LD D,C ; <- eight + LD C,0 ; <- bits + JP SCALLP ; More bits to shift + +SHRITE: ADD A,8+1 ; Adjust count + LD L,A ; Save bits to shift +SHRLP: XOR A ; Flag for all done + DEC L ; All shifting done? + RET Z ; Yes - Return + LD A,C ; Get MSB +SHRT1: RRA ; Shift it right + LD C,A ; Re-save + LD A,D ; Get NMSB + RRA ; Shift right with last bit + LD D,A ; Re-save it + LD A,E ; Get LSB + RRA ; Shift right with last bit + LD E,A ; Re-save it + LD A,B ; Get underflow + RRA ; Shift right with last bit + LD B,A ; Re-save underflow + JP SHRLP ; More bits to do + +UNITY: DB 000H,000H,000H,081H ; 1.00000 + +LOGTAB: DB 3 ; Table used by LOG + DB 0AAH,056H,019H,080H ; 0.59898 + DB 0F1H,022H,076H,080H ; 0.96147 + DB 045H,0AAH,038H,082H ; 2.88539 + +LOG: CALL TSTSGN ; Test sign of value + OR A + JP PE,FCERR ; ?FC Error if <= zero + LD HL,FPEXP ; Point to exponent + LD A,(HL) ; Get exponent + LD BC,8035H ; BCDE = SQR(1/2) + LD DE,04F3H + SUB B ; Scale value to be < 1 + PUSH AF ; Save scale factor + LD (HL),B ; Save new exponent + PUSH DE ; Save SQR(1/2) + PUSH BC + CALL FPADD ; Add SQR(1/2) to value + POP BC ; Restore SQR(1/2) + POP DE + INC B ; Make it SQR(2) + CALL DVBCDE ; Divide by SQR(2) + LD HL,UNITY ; Point to 1. + CALL SUBPHL ; Subtract FPREG from 1 + LD HL,LOGTAB ; Coefficient table + CALL SUMSER ; Evaluate sum of series + LD BC,8080H ; BCDE = -0.5 + LD DE,0000H + CALL FPADD ; Subtract 0.5 from FPREG + POP AF ; Restore scale factor + CALL RSCALE ; Re-scale number +MULLN2: LD BC,8031H ; BCDE = Ln(2) + LD DE,7218H + DB 21H ; Skip "POP BC" and "POP DE" + +MULT: POP BC ; Get number from stack + POP DE +FPMULT: CALL TSTSGN ; Test sign of FPREG + RET Z ; Return zero if zero + LD L,0 ; Flag add exponents + CALL ADDEXP ; Add exponents + LD A,C ; Get MSB of multiplier + LD (MULVAL),A ; Save MSB of multiplier + EX DE,HL + LD (MULVAL+1),HL ; Save rest of multiplier + LD BC,0 ; Partial product (BCDE) = zero + LD D,B + LD E,B + LD HL,BNORM ; Address of normalise + PUSH HL ; Save for return + LD HL,MULT8 ; Address of 8 bit multiply + PUSH HL ; Save for NMSB,MSB + PUSH HL ; + LD HL,FPREG ; Point to number +MULT8: LD A,(HL) ; Get LSB of number + INC HL ; Point to NMSB + OR A ; Test LSB + JP Z,BYTSFT ; Zero - shift to next byte + PUSH HL ; Save address of number + LD L,8 ; 8 bits to multiply by +MUL8LP: RRA ; Shift LSB right + LD H,A ; Save LSB + LD A,C ; Get MSB + JP NC,NOMADD ; Bit was zero - Don't add + PUSH HL ; Save LSB and count + LD HL,(MULVAL+1) ; Get LSB and NMSB + ADD HL,DE ; Add NMSB and LSB + EX DE,HL ; Leave sum in DE + POP HL ; Restore MSB and count + LD A,(MULVAL) ; Get MSB of multiplier + ADC A,C ; Add MSB +NOMADD: RRA ; Shift MSB right + LD C,A ; Re-save MSB + LD A,D ; Get NMSB + RRA ; Shift NMSB right + LD D,A ; Re-save NMSB + LD A,E ; Get LSB + RRA ; Shift LSB right + LD E,A ; Re-save LSB + LD A,B ; Get VLSB + RRA ; Shift VLSB right + LD B,A ; Re-save VLSB + DEC L ; Count bits multiplied + LD A,H ; Get LSB of multiplier + JP NZ,MUL8LP ; More - Do it +POPHRT: POP HL ; Restore address of number + RET + +BYTSFT: LD B,E ; Shift partial product left + LD E,D + LD D,C + LD C,A + RET + +DIV10: CALL STAKFP ; Save FPREG on stack + LD BC,8420H ; BCDE = 10. + LD DE,0000H + CALL FPBCDE ; Move 10 to FPREG + +DIV: POP BC ; Get number from stack + POP DE +DVBCDE: CALL TSTSGN ; Test sign of FPREG + JP Z,DZERR ; Error if division by zero + LD L,-1 ; Flag subtract exponents + CALL ADDEXP ; Subtract exponents + INC (HL) ; Add 2 to exponent to adjust + INC (HL) + DEC HL ; Point to MSB + LD A,(HL) ; Get MSB of dividend + LD (DIV3),A ; Save for subtraction + DEC HL + LD A,(HL) ; Get NMSB of dividend + LD (DIV2),A ; Save for subtraction + DEC HL + LD A,(HL) ; Get MSB of dividend + LD (DIV1),A ; Save for subtraction + LD B,C ; Get MSB + EX DE,HL ; NMSB,LSB to HL + XOR A + LD C,A ; Clear MSB of quotient + LD D,A ; Clear NMSB of quotient + LD E,A ; Clear LSB of quotient + LD (DIV4),A ; Clear overflow count +DIVLP: PUSH HL ; Save divisor + PUSH BC + LD A,L ; Get LSB of number + CALL DIVSUP ; Subt' divisor from dividend + SBC A,0 ; Count for overflows + CCF + JP NC,RESDIV ; Restore divisor if borrow + LD (DIV4),A ; Re-save overflow count + POP AF ; Scrap divisor + POP AF + SCF ; Set carry to + DB 0D2H ; Skip "POP BC" and "POP HL" + +RESDIV: POP BC ; Restore divisor + POP HL + LD A,C ; Get MSB of quotient + INC A + DEC A + RRA ; Bit 0 to bit 7 + JP M,RONDB ; Done - Normalise result + RLA ; Restore carry + LD A,E ; Get LSB of quotient + RLA ; Double it + LD E,A ; Put it back + LD A,D ; Get NMSB of quotient + RLA ; Double it + LD D,A ; Put it back + LD A,C ; Get MSB of quotient + RLA ; Double it + LD C,A ; Put it back + ADD HL,HL ; Double NMSB,LSB of divisor + LD A,B ; Get MSB of divisor + RLA ; Double it + LD B,A ; Put it back + LD A,(DIV4) ; Get VLSB of quotient + RLA ; Double it + LD (DIV4),A ; Put it back + LD A,C ; Get MSB of quotient + OR D ; Merge NMSB + OR E ; Merge LSB + JP NZ,DIVLP ; Not done - Keep dividing + PUSH HL ; Save divisor + LD HL,FPEXP ; Point to exponent + DEC (HL) ; Divide by 2 + POP HL ; Restore divisor + JP NZ,DIVLP ; Ok - Keep going + JP OVERR ; Overflow error + +ADDEXP: LD A,B ; Get exponent of dividend + OR A ; Test it + JP Z,OVTST3 ; Zero - Result zero + LD A,L ; Get add/subtract flag + LD HL,FPEXP ; Point to exponent + XOR (HL) ; Add or subtract it + ADD A,B ; Add the other exponent + LD B,A ; Save new exponent + RRA ; Test exponent for overflow + XOR B + LD A,B ; Get exponent + JP P,OVTST2 ; Positive - Test for overflow + ADD A,80H ; Add excess 128 + LD (HL),A ; Save new exponent + JP Z,POPHRT ; Zero - Result zero + CALL SIGNS ; Set MSBs and sign of result + LD (HL),A ; Save new exponent + DEC HL ; Point to MSB + RET + +OVTST1: CALL TSTSGN ; Test sign of FPREG + CPL ; Invert sign + POP HL ; Clean up stack +OVTST2: OR A ; Test if new exponent zero +OVTST3: POP HL ; Clear off return address + JP P,RESZER ; Result zero + JP OVERR ; Overflow error + +MLSP10: CALL BCDEFP ; Move FPREG to BCDE + LD A,B ; Get exponent + OR A ; Is it zero? + RET Z ; Yes - Result is zero + ADD A,2 ; Multiply by 4 + JP C,OVERR ; Overflow - ?OV Error + LD B,A ; Re-save exponent + CALL FPADD ; Add BCDE to FPREG (Times 5) + LD HL,FPEXP ; Point to exponent + INC (HL) ; Double number (Times 10) + RET NZ ; Ok - Return + JP OVERR ; Overflow error + +TSTSGN: LD A,(FPEXP) ; Get sign of FPREG + OR A + RET Z ; RETurn if number is zero + LD A,(FPREG+2) ; Get MSB of FPREG + DB 0FEH ; Test sign +RETREL: CPL ; Invert sign + RLA ; Sign bit to carry +FLGDIF: SBC A,A ; Carry to all bits of A + RET NZ ; Return -1 if negative + INC A ; Bump to +1 + RET ; Positive - Return +1 + +SGN: CALL TSTSGN ; Test sign of FPREG +FLGREL: LD B,80H+8 ; 8 bit integer in exponent + LD DE,0 ; Zero NMSB and LSB +RETINT: LD HL,FPEXP ; Point to exponent + LD C,A ; CDE = MSB,NMSB and LSB + LD (HL),B ; Save exponent + LD B,0 ; CDE = integer to normalise + INC HL ; Point to sign of result + LD (HL),80H ; Set sign of result + RLA ; Carry = sign of integer + JP CONPOS ; Set sign of result + +ABS: CALL TSTSGN ; Test sign of FPREG + RET P ; Return if positive +INVSGN: LD HL,FPREG+2 ; Point to MSB + LD A,(HL) ; Get sign of mantissa + XOR 80H ; Invert sign of mantissa + LD (HL),A ; Re-save sign of mantissa + RET + +STAKFP: EX DE,HL ; Save code string address + LD HL,(FPREG) ; LSB,NLSB of FPREG + EX (SP),HL ; Stack them,get return + PUSH HL ; Re-save return + LD HL,(FPREG+2) ; MSB and exponent of FPREG + EX (SP),HL ; Stack them,get return + PUSH HL ; Re-save return + EX DE,HL ; Restore code string address + RET + +PHLTFP: CALL LOADFP ; Number at HL to BCDE +FPBCDE: EX DE,HL ; Save code string address + LD (FPREG),HL ; Save LSB,NLSB of number + LD H,B ; Exponent of number + LD L,C ; MSB of number + LD (FPREG+2),HL ; Save MSB and exponent + EX DE,HL ; Restore code string address + RET + +BCDEFP: LD HL,FPREG ; Point to FPREG +LOADFP: LD E,(HL) ; Get LSB of number + INC HL + LD D,(HL) ; Get NMSB of number + INC HL + LD C,(HL) ; Get MSB of number + INC HL + LD B,(HL) ; Get exponent of number +INCHL: INC HL ; Used for conditional "INC HL" + RET + +FPTHL: LD DE,FPREG ; Point to FPREG +DETHL4: LD B,4 ; 4 bytes to move +DETHLB: LD A,(DE) ; Get source + LD (HL),A ; Save destination + INC DE ; Next source + INC HL ; Next destination + DEC B ; Count bytes + JP NZ,DETHLB ; Loop if more + RET + +SIGNS: LD HL,FPREG+2 ; Point to MSB of FPREG + LD A,(HL) ; Get MSB + RLCA ; Old sign to carry + SCF ; Set MSBit + RRA ; Set MSBit of MSB + LD (HL),A ; Save new MSB + CCF ; Complement sign + RRA ; Old sign to carry + INC HL + INC HL + LD (HL),A ; Set sign of result + LD A,C ; Get MSB + RLCA ; Old sign to carry + SCF ; Set MSBit + RRA ; Set MSBit of MSB + LD C,A ; Save MSB + RRA + XOR (HL) ; New sign of result + RET + +CMPNUM: LD A,B ; Get exponent of number + OR A + JP Z,TSTSGN ; Zero - Test sign of FPREG + LD HL,RETREL ; Return relation routine + PUSH HL ; Save for return + CALL TSTSGN ; Test sign of FPREG + LD A,C ; Get MSB of number + RET Z ; FPREG zero - Number's MSB + LD HL,FPREG+2 ; MSB of FPREG + XOR (HL) ; Combine signs + LD A,C ; Get MSB of number + RET M ; Exit if signs different + CALL CMPFP ; Compare FP numbers + RRA ; Get carry to sign + XOR C ; Combine with MSB of number + RET + +CMPFP: INC HL ; Point to exponent + LD A,B ; Get exponent + CP (HL) ; Compare exponents + RET NZ ; Different + DEC HL ; Point to MBS + LD A,C ; Get MSB + CP (HL) ; Compare MSBs + RET NZ ; Different + DEC HL ; Point to NMSB + LD A,D ; Get NMSB + CP (HL) ; Compare NMSBs + RET NZ ; Different + DEC HL ; Point to LSB + LD A,E ; Get LSB + SUB (HL) ; Compare LSBs + RET NZ ; Different + POP HL ; Drop RETurn + POP HL ; Drop another RETurn + RET + +FPINT: LD B,A ; <- Move + LD C,A ; <- exponent + LD D,A ; <- to all + LD E,A ; <- bits + OR A ; Test exponent + RET Z ; Zero - Return zero + PUSH HL ; Save pointer to number + CALL BCDEFP ; Move FPREG to BCDE + CALL SIGNS ; Set MSBs & sign of result + XOR (HL) ; Combine with sign of FPREG + LD H,A ; Save combined signs + CALL M,DCBCDE ; Negative - Decrement BCDE + LD A,80H+24 ; 24 bits + SUB B ; Bits to shift + CALL SCALE ; Shift BCDE + LD A,H ; Get combined sign + RLA ; Sign to carry + CALL C,FPROND ; Negative - Round number up + LD B,0 ; Zero exponent + CALL C,COMPL ; If negative make positive + POP HL ; Restore pointer to number + RET + +DCBCDE: DEC DE ; Decrement BCDE + LD A,D ; Test LSBs + AND E + INC A + RET NZ ; Exit if LSBs not FFFF + DEC BC ; Decrement MSBs + RET + +INT: LD HL,FPEXP ; Point to exponent + LD A,(HL) ; Get exponent + CP 80H+24 ; Integer accuracy only? + LD A,(FPREG) ; Get LSB + RET NC ; Yes - Already integer + LD A,(HL) ; Get exponent + CALL FPINT ; F.P to integer + LD (HL),80H+24 ; Save 24 bit integer + LD A,E ; Get LSB of number + PUSH AF ; Save LSB + LD A,C ; Get MSB of number + RLA ; Sign to carry + CALL CONPOS ; Set sign of result + POP AF ; Restore LSB of number + RET + +MLDEBC: LD HL,0 ; Clear partial product + LD A,B ; Test multiplier + OR C + RET Z ; Return zero if zero + LD A,16 ; 16 bits +MLDBLP: ADD HL,HL ; Shift P.P left + JP C,BSERR ; ?BS Error if overflow + EX DE,HL + ADD HL,HL ; Shift multiplier left + EX DE,HL + JP NC,NOMLAD ; Bit was zero - No add + ADD HL,BC ; Add multiplicand + JP C,BSERR ; ?BS Error if overflow +NOMLAD: DEC A ; Count bits + JP NZ,MLDBLP ; More + RET + +ASCTFP: CP "-" ; Negative? + PUSH AF ; Save it and flags + JP Z,CNVNUM ; Yes - Convert number + CP "+" ; Positive? + JP Z,CNVNUM ; Yes - Convert number + DEC HL ; DEC 'cos GETCHR INCs +CNVNUM: CALL RESZER ; Set result to zero + LD B,A ; Digits after point counter + LD D,A ; Sign of exponent + LD E,A ; Exponent of ten + CPL + LD C,A ; Before or after point flag +MANLP: CALL GETCHR ; Get next character + JP C,ADDIG ; Digit - Add to number + CP "." + JP Z,DPOINT ; "." - Flag point + CP "E" + JP NZ,CONEXP ; Not "E" - Scale number + CALL GETCHR ; Get next character + CALL SGNEXP ; Get sign of exponent +EXPLP: CALL GETCHR ; Get next character + JP C,EDIGIT ; Digit - Add to exponent + INC D ; Is sign negative? + JP NZ,CONEXP ; No - Scale number + XOR A + SUB E ; Negate exponent + LD E,A ; And re-save it + INC C ; Flag end of number +DPOINT: INC C ; Flag point passed + JP Z,MANLP ; Zero - Get another digit +CONEXP: PUSH HL ; Save code string address + LD A,E ; Get exponent + SUB B ; Subtract digits after point +SCALMI: CALL P,SCALPL ; Positive - Multiply number + JP P,ENDCON ; Positive - All done + PUSH AF ; Save number of times to /10 + CALL DIV10 ; Divide by 10 + POP AF ; Restore count + INC A ; Count divides + +ENDCON: JP NZ,SCALMI ; More to do + POP DE ; Restore code string address + POP AF ; Restore sign of number + CALL Z,INVSGN ; Negative - Negate number + EX DE,HL ; Code string address to HL + RET + +SCALPL: RET Z ; Exit if no scaling needed +MULTEN: PUSH AF ; Save count + CALL MLSP10 ; Multiply number by 10 + POP AF ; Restore count + DEC A ; Count multiplies + RET + +ADDIG: PUSH DE ; Save sign of exponent + LD D,A ; Save digit + LD A,B ; Get digits after point + ADC A,C ; Add one if after point + LD B,A ; Re-save counter + PUSH BC ; Save point flags + PUSH HL ; Save code string address + PUSH DE ; Save digit + CALL MLSP10 ; Multiply number by 10 + POP AF ; Restore digit + SUB "0" ; Make it absolute + CALL RSCALE ; Re-scale number + POP HL ; Restore code string address + POP BC ; Restore point flags + POP DE ; Restore sign of exponent + JP MANLP ; Get another digit + +RSCALE: CALL STAKFP ; Put number on stack + CALL FLGREL ; Digit to add to FPREG +PADD: POP BC ; Restore number + POP DE + JP FPADD ; Add BCDE to FPREG and return + +EDIGIT: LD A,E ; Get digit + RLCA ; Times 2 + RLCA ; Times 4 + ADD A,E ; Times 5 + RLCA ; Times 10 + ADD A,(HL) ; Add next digit + SUB "0" ; Make it absolute + LD E,A ; Save new digit + JP EXPLP ; Look for another digit + +LINEIN: PUSH HL ; Save code string address + LD HL,INMSG ; Output " in " + CALL PRS ; Output string at HL + POP HL ; Restore code string address +PRNTHL: EX DE,HL ; Code string address to DE + XOR A + LD B,80H+24 ; 24 bits + CALL RETINT ; Return the integer + LD HL,PRNUMS ; Print number string + PUSH HL ; Save for return +NUMASC: LD HL,PBUFF ; Convert number to ASCII + PUSH HL ; Save for return + CALL TSTSGN ; Test sign of FPREG + LD (HL)," " ; Space at start + JP P,SPCFST ; Positive - Space to start + LD (HL),"-" ; "-" sign at start +SPCFST: INC HL ; First byte of number + LD (HL),"0" ; "0" if zero + JP Z,JSTZER ; Return "0" if zero + PUSH HL ; Save buffer address + CALL M,INVSGN ; Negate FPREG if negative + XOR A ; Zero A + PUSH AF ; Save it + CALL RNGTST ; Test number is in range +SIXDIG: LD BC,9143H ; BCDE - 99999.9 + LD DE,4FF8H + CALL CMPNUM ; Compare numbers + OR A + JP PO,INRNG ; > 99999.9 - Sort it out + POP AF ; Restore count + CALL MULTEN ; Multiply by ten + PUSH AF ; Re-save count + JP SIXDIG ; Test it again + +GTSIXD: CALL DIV10 ; Divide by 10 + POP AF ; Get count + INC A ; Count divides + PUSH AF ; Re-save count + CALL RNGTST ; Test number is in range +INRNG: CALL ROUND ; Add 0.5 to FPREG + INC A + CALL FPINT ; F.P to integer + CALL FPBCDE ; Move BCDE to FPREG + LD BC,0306H ; 1E+06 to 1E-03 range + POP AF ; Restore count + ADD A,C ; 6 digits before point + INC A ; Add one + JP M,MAKNUM ; Do it in "E" form if < 1E-02 + CP 6+1+1 ; More than 999999 ? + JP NC,MAKNUM ; Yes - Do it in "E" form + INC A ; Adjust for exponent + LD B,A ; Exponent of number + LD A,2 ; Make it zero after + +MAKNUM: DEC A ; Adjust for digits to do + DEC A + POP HL ; Restore buffer address + PUSH AF ; Save count + LD DE,POWERS ; Powers of ten + DEC B ; Count digits before point + JP NZ,DIGTXT ; Not zero - Do number + LD (HL),"." ; Save point + INC HL ; Move on + LD (HL),"0" ; Save zero + INC HL ; Move on +DIGTXT: DEC B ; Count digits before point + LD (HL),"." ; Save point in case + CALL Z,INCHL ; Last digit - move on + PUSH BC ; Save digits before point + PUSH HL ; Save buffer address + PUSH DE ; Save powers of ten + CALL BCDEFP ; Move FPREG to BCDE + POP HL ; Powers of ten table + LD B, "0"-1 ; ASCII "0" - 1 +TRYAGN: INC B ; Count subtractions + LD A,E ; Get LSB + SUB (HL) ; Subtract LSB + LD E,A ; Save LSB + INC HL + LD A,D ; Get NMSB + SBC A,(HL) ; Subtract NMSB + LD D,A ; Save NMSB + INC HL + LD A,C ; Get MSB + SBC A,(HL) ; Subtract MSB + LD C,A ; Save MSB + DEC HL ; Point back to start + DEC HL + JP NC,TRYAGN ; No overflow - Try again + CALL PLUCDE ; Restore number + INC HL ; Start of next number + CALL FPBCDE ; Move BCDE to FPREG + EX DE,HL ; Save point in table + POP HL ; Restore buffer address + LD (HL),B ; Save digit in buffer + INC HL ; And move on + POP BC ; Restore digit count + DEC C ; Count digits + JP NZ,DIGTXT ; More - Do them + DEC B ; Any decimal part? + JP Z,DOEBIT ; No - Do "E" bit +SUPTLZ: DEC HL ; Move back through buffer + LD A,(HL) ; Get character + CP "0" ; "0" character? + JP Z,SUPTLZ ; Yes - Look back for more + CP "." ; A decimal point? + CALL NZ,INCHL ; Move back over digit + +DOEBIT: POP AF ; Get "E" flag + JP Z,NOENED ; No "E" needed - End buffer + LD (HL),"E" ; Put "E" in buffer + INC HL ; And move on + LD (HL),"+" ; Put '+' in buffer + JP P,OUTEXP ; Positive - Output exponent + LD (HL),"-" ; Put "-" in buffer + CPL ; Negate exponent + INC A +OUTEXP: LD B,"0"-1 ; ASCII "0" - 1 +EXPTEN: INC B ; Count subtractions + SUB 10 ; Tens digit + JP NC,EXPTEN ; More to do + ADD A,"0"+10 ; Restore and make ASCII + INC HL ; Move on + LD (HL),B ; Save MSB of exponent +JSTZER: INC HL ; + LD (HL),A ; Save LSB of exponent + INC HL +NOENED: LD (HL),C ; Mark end of buffer + POP HL ; Restore code string address + RET + +RNGTST: LD BC,9474H ; BCDE = 999999. + LD DE,23F7H + CALL CMPNUM ; Compare numbers + OR A + POP HL ; Return address to HL + JP PO,GTSIXD ; Too big - Divide by ten + JP (HL) ; Otherwise return to caller + +HALF: DB 00H,00H,00H,80H ; 0.5 + +POWERS: DB 0A0H,086H,001H ; 100000 + DB 010H,027H,000H ; 10000 + DB 0E8H,003H,000H ; 1000 + DB 064H,000H,000H ; 100 + DB 00AH,000H,000H ; 10 + DB 001H,000H,000H ; 1 + +NEGAFT: LD HL,INVSGN ; Negate result + EX (SP),HL ; To be done after caller + JP (HL) ; Return to caller + +SQR: CALL STAKFP ; Put value on stack + LD HL,HALF ; Set power to 1/2 + CALL PHLTFP ; Move 1/2 to FPREG + +POWER: POP BC ; Get base + POP DE + CALL TSTSGN ; Test sign of power + LD A,B ; Get exponent of base + JP Z,EXP ; Make result 1 if zero + JP P,POWER1 ; Positive base - Ok + OR A ; Zero to negative power? + JP Z,DZERR ; Yes - ?/0 Error +POWER1: OR A ; Base zero? + JP Z,SAVEXP ; Yes - Return zero + PUSH DE ; Save base + PUSH BC + LD A,C ; Get MSB of base + OR 01111111B ; Get sign status + CALL BCDEFP ; Move power to BCDE + JP P,POWER2 ; Positive base - Ok + PUSH DE ; Save power + PUSH BC + CALL INT ; Get integer of power + POP BC ; Restore power + POP DE + PUSH AF ; MSB of base + CALL CMPNUM ; Power an integer? + POP HL ; Restore MSB of base + LD A,H ; but don't affect flags + RRA ; Exponent odd or even? +POWER2: POP HL ; Restore MSB and exponent + LD (FPREG+2),HL ; Save base in FPREG + POP HL ; LSBs of base + LD (FPREG),HL ; Save in FPREG + CALL C,NEGAFT ; Odd power - Negate result + CALL Z,INVSGN ; Negative base - Negate it + PUSH DE ; Save power + PUSH BC + CALL LOG ; Get LOG of base + POP BC ; Restore power + POP DE + CALL FPMULT ; Multiply LOG by power + +EXP: CALL STAKFP ; Put value on stack + LD BC,08138H ; BCDE = 1/Ln(2) + LD DE,0AA3BH + CALL FPMULT ; Multiply value by 1/LN(2) + LD A,(FPEXP) ; Get exponent + CP 80H+8 ; Is it in range? + JP NC,OVTST1 ; No - Test for overflow + CALL INT ; Get INT of FPREG + ADD A,80H ; For excess 128 + ADD A,2 ; Exponent > 126? + JP C,OVTST1 ; Yes - Test for overflow + PUSH AF ; Save scaling factor + LD HL,UNITY ; Point to 1. + CALL ADDPHL ; Add 1 to FPREG + CALL MULLN2 ; Multiply by LN(2) + POP AF ; Restore scaling factor + POP BC ; Restore exponent + POP DE + PUSH AF ; Save scaling factor + CALL SUBCDE ; Subtract exponent from FPREG + CALL INVSGN ; Negate result + LD HL,EXPTAB ; Coefficient table + CALL SMSER1 ; Sum the series + LD DE,0 ; Zero LSBs + POP BC ; Scaling factor + LD C,D ; Zero MSB + JP FPMULT ; Scale result to correct value + +EXPTAB: DB 8 ; Table used by EXP + DB 040H,02EH,094H,074H ; -1/7! (-1/5040) + DB 070H,04FH,02EH,077H ; 1/6! ( 1/720) + DB 06EH,002H,088H,07AH ; -1/5! (-1/120) + DB 0E6H,0A0H,02AH,07CH ; 1/4! ( 1/24) + DB 050H,0AAH,0AAH,07EH ; -1/3! (-1/6) + DB 0FFH,0FFH,07FH,07FH ; 1/2! ( 1/2) + DB 000H,000H,080H,081H ; -1/1! (-1/1) + DB 000H,000H,000H,081H ; 1/0! ( 1/1) + +SUMSER: CALL STAKFP ; Put FPREG on stack + LD DE,MULT ; Multiply by "X" + PUSH DE ; To be done after + PUSH HL ; Save address of table + CALL BCDEFP ; Move FPREG to BCDE + CALL FPMULT ; Square the value + POP HL ; Restore address of table +SMSER1: CALL STAKFP ; Put value on stack + LD A,(HL) ; Get number of coefficients + INC HL ; Point to start of table + CALL PHLTFP ; Move coefficient to FPREG + DB 06H ; Skip "POP AF" +SUMLP: POP AF ; Restore count + POP BC ; Restore number + POP DE + DEC A ; Cont coefficients + RET Z ; All done + PUSH DE ; Save number + PUSH BC + PUSH AF ; Save count + PUSH HL ; Save address in table + CALL FPMULT ; Multiply FPREG by BCDE + POP HL ; Restore address in table + CALL LOADFP ; Number at HL to BCDE + PUSH HL ; Save address in table + CALL FPADD ; Add coefficient to FPREG + POP HL ; Restore address in table + JP SUMLP ; More coefficients + +RND: CALL TSTSGN ; Test sign of FPREG + LD HL,SEED+2 ; Random number seed + JP M,RESEED ; Negative - Re-seed + LD HL,LSTRND ; Last random number + CALL PHLTFP ; Move last RND to FPREG + LD HL,SEED+2 ; Random number seed + RET Z ; Return if RND(0) + ADD A,(HL) ; Add (SEED)+2) + AND 00000111B ; 0 to 7 + LD B,0 + LD (HL),A ; Re-save seed + INC HL ; Move to coefficient table + ADD A,A ; 4 bytes + ADD A,A ; per entry + LD C,A ; BC = Offset into table + ADD HL,BC ; Point to coefficient + CALL LOADFP ; Coefficient to BCDE + CALL FPMULT ; ; Multiply FPREG by coefficient + LD A,(SEED+1) ; Get (SEED+1) + INC A ; Add 1 + AND 00000011B ; 0 to 3 + LD B,0 + CP 1 ; Is it zero? + ADC A,B ; Yes - Make it 1 + LD (SEED+1),A ; Re-save seed + LD HL,RNDTAB-4 ; Addition table + ADD A,A ; 4 bytes + ADD A,A ; per entry + LD C,A ; BC = Offset into table + ADD HL,BC ; Point to value + CALL ADDPHL ; Add value to FPREG +RND1: CALL BCDEFP ; Move FPREG to BCDE + LD A,E ; Get LSB + LD E,C ; LSB = MSB + XOR 01001111B ; Fiddle around + LD C,A ; New MSB + LD (HL),80H ; Set exponent + DEC HL ; Point to MSB + LD B,(HL) ; Get MSB + LD (HL),80H ; Make value -0.5 + LD HL,SEED ; Random number seed + INC (HL) ; Count seed + LD A,(HL) ; Get seed + SUB 171 ; Do it modulo 171 + JP NZ,RND2 ; Non-zero - Ok + LD (HL),A ; Zero seed + INC C ; Fillde about + DEC D ; with the + INC E ; number +RND2: CALL BNORM ; Normalise number + LD HL,LSTRND ; Save random number + JP FPTHL ; Move FPREG to last and return + +RESEED: LD (HL),A ; Re-seed random numbers + DEC HL + LD (HL),A + DEC HL + LD (HL),A + JP RND1 ; Return RND seed + +RNDTAB: DB 068H,0B1H,046H,068H ; Table used by RND + DB 099H,0E9H,092H,069H + DB 010H,0D1H,075H,068H + +COS: LD HL,HALFPI ; Point to PI/2 + CALL ADDPHL ; Add it to PPREG +SIN: CALL STAKFP ; Put angle on stack + LD BC,8349H ; BCDE = 2 PI + LD DE,0FDBH + CALL FPBCDE ; Move 2 PI to FPREG + POP BC ; Restore angle + POP DE + CALL DVBCDE ; Divide angle by 2 PI + CALL STAKFP ; Put it on stack + CALL INT ; Get INT of result + POP BC ; Restore number + POP DE + CALL SUBCDE ; Make it 0 <= value < 1 + LD HL,QUARTR ; Point to 0.25 + CALL SUBPHL ; Subtract value from 0.25 + CALL TSTSGN ; Test sign of value + SCF ; Flag positive + JP P,SIN1 ; Positive - Ok + CALL ROUND ; Add 0.5 to value + CALL TSTSGN ; Test sign of value + OR A ; Flag negative +SIN1: PUSH AF ; Save sign + CALL P,INVSGN ; Negate value if positive + LD HL,QUARTR ; Point to 0.25 + CALL ADDPHL ; Add 0.25 to value + POP AF ; Restore sign + CALL NC,INVSGN ; Negative - Make positive + LD HL,SINTAB ; Coefficient table + JP SUMSER ; Evaluate sum of series + +HALFPI: DB 0DBH,00FH,049H,081H ; 1.5708 (PI/2) + +QUARTR: DB 000H,000H,000H,07FH ; 0.25 + +SINTAB: DB 5 ; Table used by SIN + DB 0BAH,0D7H,01EH,086H ; 39.711 + DB 064H,026H,099H,087H ;-76.575 + DB 058H,034H,023H,087H ; 81.602 + DB 0E0H,05DH,0A5H,086H ;-41.342 + DB 0DAH,00FH,049H,083H ; 6.2832 + +TAN: CALL STAKFP ; Put angle on stack + CALL SIN ; Get SIN of angle + POP BC ; Restore angle + POP HL + CALL STAKFP ; Save SIN of angle + EX DE,HL ; BCDE = Angle + CALL FPBCDE ; Angle to FPREG + CALL COS ; Get COS of angle + JP DIV ; TAN = SIN / COS + +ATN: CALL TSTSGN ; Test sign of value + CALL M,NEGAFT ; Negate result after if -ve + CALL M,INVSGN ; Negate value if -ve + LD A,(FPEXP) ; Get exponent + CP 81H ; Number less than 1? + JP C,ATN1 ; Yes - Get arc tangnt + LD BC,8100H ; BCDE = 1 + LD D,C + LD E,C + CALL DVBCDE ; Get reciprocal of number + LD HL,SUBPHL ; Sub angle from PI/2 + PUSH HL ; Save for angle > 1 +ATN1: LD HL,ATNTAB ; Coefficient table + CALL SUMSER ; Evaluate sum of series + LD HL,HALFPI ; PI/2 - angle in case > 1 + RET ; Number > 1 - Sub from PI/2 + +ATNTAB: DB 9 ; Table used by ATN + DB 04AH,0D7H,03BH,078H ; 1/17 + DB 002H,06EH,084H,07BH ;-1/15 + DB 0FEH,0C1H,02FH,07CH ; 1/13 + DB 074H,031H,09AH,07DH ;-1/11 + DB 084H,03DH,05AH,07DH ; 1/9 + DB 0C8H,07FH,091H,07EH ;-1/7 + DB 0E4H,0BBH,04CH,07EH ; 1/5 + DB 06CH,0AAH,0AAH,07FH ;-1/3 + DB 000H,000H,000H,081H ; 1/1 + +CASFFW: CALL FLPLED ; Turn on cassette + LD B,0 ; Set 1 second delay +DELAYB: CALL DELAY ; Wait a bit + DEC B ; Count + JP NZ,DELAYB ; More delay needed + RET + +CASFF: JP FLPLED ; Flip tape LED + +ARET: RET ; A RETurn instruction + +CONMON: PUSH HL ; Output character to screen + PUSH BC ; + PUSH DE ; + PUSH AF ; + CALL MONTST ; See if NAS-SYS + JP NZ,NASOUT ; NAS-SYS - Output ASCII + POP AF ; Get character + PUSH AF ; And re-save + CP LF ; ASCII Line feed? + JP Z,IGCHR ; Yes - Ignore it + CP BKSP ; ASCII back space? + JP NZ,CONOT1 ; No - Test for CR + LD A,TBS ; NASBUG back space +CONOT1: CP CR ; ASCII CR? + JP NZ,OUTCHR ; No - Output character + LD A,TCR ; NASBUG CR + JP OUTCHR ; Output it + +NASOUT: POP AF ; Get character + PUSH AF ; And re-save +OUTCHR: CALL MONOUT ; Output it +IGCHR: POP AF ; Restore character + POP DE ; + POP BC ; + POP HL ; + RET + +GETINP: PUSH HL ; Get an input character + PUSH BC ; + PUSH DE ; + CALL MONTST ; See if NAS-SYS + JP Z,GETTIN ; "T" monitor - Get input + DW _BLNK + JP CONVIN ; Convert to ASCII + +GETTIN: CALL TIN ; "T" input a character + JP NC,GETTIN ; No input - wait +CONVIN: CP TBS ; NASBUG back space? + JP NZ,CNVIN1 ; No - Test for break + LD A,BKSP ; ASCII back space +CNVIN1: CP TBRK ; NASBUG break? + JP NZ,CNVIN2 ; No - Test for control Z + LD A,CTRLC ; Control C +CNVIN2: CP CTRLZ ; ^Z? + JP NZ,CNVIN3 ; No - Test for escape + LD A,DEL ; Delete +CNVIN3: CP ESC ; "ESC" ? + JP NZ,CNVIN4 ; No - Test for CR + LD A,CTRLC ; Control C +CNVIN4: CP TCR ; NASBUG CR? + JP NZ,CNVIN5 ; No - Return character + LD A,CR ; ASCII CR +CNVIN5: POP DE + POP BC + POP HL + RET + +CHKBRK: XOR A ; Check for break + CALL SFTENT ; Test for shift/enter + JP Z,TBRK2 ; Yes - Test for second break + LD A,(BRKFLG) ; Get break flag + OR A ; Break flag set? + JP NZ,TBRK2 ; Yes - Test for second break + XOR A ; Flag no break + RET + +TBRK2: CALL BREAK2 ; Second break? + LD A,-1 ; Flag break + RET + +GUART: IN A,(UARTS) ; Get UART status + RLA ; Any data ready? + JP NC,GUART ; No - wait until there is + IN A,(UARTD) ; Get data from UART + RET + +UARTOT: OUT (UARTD),A ; Send data to UART +URTOLP: IN A,(UARTS) ; Get status + ADD A,A ; Byte sent? + RET M ; Yes - Return + JP URTOLP ; Keep waiting + +SUART: PUSH AF ; Save A + CALL UARTOT ; Send it to UART + POP AF ; Restore A + RET + + NOP + NOP + +SFTENT: PUSH HL ; Test for Shift Enter from KBD + LD A,00000010B ; Reset KBD counter mask + LD HL,PORT0 ; Get old contents + XOR (HL) ; Toggle bit + OUT (0),A ; Reset KBD counter + XOR 00000001B ; Toggle bit + OUT (0),A ; Next row + XOR 00000010B + OUT (0),A ; Clear "clear" strobe + LD A,(HL) ; Get old value + OUT (0),A ; Original contents + ADD HL,DE ; ?? WHAT ?? + POP HL ; Restore HL + IN A,(0) ; Read in row + AND 00010010B ; Mask SHIFT and ENTER + RET + +CLS: CALL MONTST ; See if NAS-SYS + JP Z,TCLS ; "T" CLS + LD A,CS ; ASCII Clear screen + JP CONMON ; Output character + +TCLS: LD A,TCS ; NASBUG Clear screen + JP CONMON ; Output character + +DELAY: XOR A ; Delay routine +DELAY1: PUSH AF ; PUSHes and POPs delay + POP AF + PUSH AF + POP AF + DEC A ; Count delays + JP NZ,DELAY1 ; More delay + RET + +WIDTH: CALL GETINT ; Get integer 0-255 + LD A,E ; Width to A + LD (LWIDTH),A ; Set width + RET + +LINES: CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + LD (LINESC),DE ; Set lines counter + LD (LINESN),DE ; Set lines number + RET + +DEEK: CALL DEINT ; Get integer -32768 to 32767 + PUSH DE ; Save number + POP HL ; Number to HL + LD B,(HL) ; Get LSB of contents + INC HL + LD A,(HL) ; Get MSB of contents + JP ABPASS ; Return integer AB + +DOKE: CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + PUSH DE ; Save address + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + EX (SP),HL ; Save value,get address + LD (HL),E ; Save LSB of value + INC HL + LD (HL),D ; Save MSB of value + POP HL ; Restore code string address + RET + +JJUMP1: DI ; Disable interrupts + LD IX,-1 ; Flag cold start + JP CSTART ; Go and initialise + +SCREEN: CALL GETINT ; Get integer 0 to 255 + PUSH AF ; Save column + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETINT ; Get integer 0 to 255 + POP BC ; Column to B + PUSH HL ; Save code string address + PUSH BC ; Save column + CALL SCRADR ; Calculate screen address + PUSH HL ; Save screen address + CALL MONTST ; See if NAS-SYS + JP Z,TMNCUR ; "T" monitor - "T" cursor + POP HL ; Restore screen address + LD (CURSOR),HL ; Set new cursor position + POP HL ; Rstore code string address + RET + +TMNCUR: LD HL,(TCUR) ; Get address or cursor + LD (HL)," " ; Remove cursor + POP HL ; Get new cursor address + LD (TCUR),HL ; Set new cursor + LD (HL),"_" ; Put it on screen + POP HL ; Restore code string address + RET + +SCRADR: LD HL,VDU+10-65 ; SCREEN VDU address (0,0) + LD B,0 + LD C,A ; Line to BC + OR A ; Test it + JP Z,FCERR ; Zero - ?FC Error + CP 16+1 ; 16 lines + JP P,FCERR ; > 16 - ?FC Error + POP DE ; RETurn address + POP AF ; Get column + PUSH DE ; Re-save RETurn + LD D,0 + LD E,A ; Column to DE + OR A ; Test it + JP Z,FCERR ; Zero - ?FC Error + CP 48+1 ; 48 characters per line + JP P,FCERR ; > 48 - ?FC Error + ADD HL,DE ; Add column to address + LD D,0 + LD E,C ; Line to DE + LD B,64 ; 64 Bytes per line +ADD64X: ADD HL,DE ; Add line + DJNZ ADD64X ; SIXTY FOUR TIMES!!! + RET + +FLPLED: CALL MONTST ; See if NAS-SYS + JP Z,TMFLP ; "T" MFLP + DW _MFLP + RET + +TMFLP: JP MFLP ; Flip drive LED + +MONOUT: PUSH AF ; Save character + CALL MONTST ; See if NAS-SYS + JP Z,TMNOUT ; "T" output + POP AF ; Restore character + DB _ROUT ; Output it + RET + +TMNOUT: POP AF ; Restore character + JP TOUT ; "T" output + +BREAK2: LD A,(BRKFLG) ; Break flag set? + JP NZ,RETCTC ; Yes - Return ^C + CALL MONTST ; See if NAS-SYS + JP Z,TCHINP ; Get "T" character input + DW _RIN ; Scan for a character + RET + +TCHINP: JP TIN ; "T" input a character + +RETCTC: LD A,0 ; Clear Break flag + LD (BRKFLG),A + LD A,CTRLC ; Return ^C + RET + +MONTST: LD A,(MONSTT+1) ; "T" monitor or NAS-SYS? + CP 33H ; 31 00 10 / 31 33 0C + RET + +SAVE: CALL FLPLED ; Flip tape LED + CALL MONTST ; See if NAS-SYS + JP Z,TSAVE ; "T" save + DW _WRIT ; Save program + RET + +TSAVE: LD A,(MONTYP) ; "T2" or "T4" (FLAGS!!!) + JP Z,T4WR ; T4 Write + JP T2DUMP ; T2 Dump + +MONLD: CALL FLPLED ; Flip tape LED + CALL MONTST ; See if NAS-SYS + JP Z,TLOAD ; "T" load + LD A,"R" ; Set READ + LD (ARGN),A + DW _READ ; Load program + RET + +TLOAD: LD A,(MONTYP) ; "T2" or "T4" (FLAGS!!!) + JP Z,T4READ ; T4 Read + JP T2DUMP ; T2 Dump ?????????? + +MONITR: CALL MONTST ; See if NAS-SYS + JP Z,MONSTT ; Jump to zero if "T" + DW _MRET ; Return to NAS-SYS + +MONVE: CALL FLPLED ; Flip tape LED + CALL MONTST ; See if NAS-SYS + JP Z,FCERR ; Verify not available on "T" + LD A,"V" ; Set VERIFY + LD (ARGN),A + DW _VRFY ; Verify tape + RET + +INITST: LD A,0 ; Clear break flag + LD (BRKFLG),A + CALL MONTST ; See if NAS-SYS + JP Z,INIT ; "T" - No NMI vector + LD HL,BREAK ; Set NMI gives break + LD (NMI),HL + PUSH IX ; Get start up condition + POP AF ; "Z" set if cold , Else clear + OR A ; "Cold" or "Cool" start? + JP NZ,INIT ; "Cool" don't init NAS-SYS + LD B,15 ; Delay for keyboard clear + CALL DELAYB ; Allow time for key release + CALL STMON ; Initialise NAS-SYS + JP INIT ; Initialise BASIC + +BREAK: PUSH AF ; Save character + LD A,-1 + LD (BRKFLG),A ; Flag break + POP AF ; Restore character +ARETN: RETN ; Return from NMI + + NOP + +INLINE: DW _INLN ; Get an input line + PUSH DE ; Save cursor address + PUSH DE ; Cursor address to HL + POP HL + LD DE,48-1 ; Length of line-1 + ADD HL,DE ; Point to end of line +ENDLIN: LD A,(HL) ; Get end of line + CP " " ; Space? + JP NZ,LINTBF ; No - Copy to buffer + DEC E ; Back 1 character + LD A,0 ; Wasteful test on E + OR E + JP Z,LINTBF ; Start of line - Copy it + DEC HL ; Back 1 character + JP ENDLIN ; Keep looking for end + +LINTBF: PUSH DE ; Line length to BC + POP BC + INC BC ; Length +1 + LD DE,BUFFER ; Input buffer + POP HL ; Line start + PUSH BC ; Save length + LDIR ; Move line to buffer + LD A,0 + LD (DE),A ; Mark end of buffer with 00 + POP BC ; Restore buffer length + LD B,C ; Length returned in B + LD HL,BUFFER-1 ; Point to start of buffer-1 + RET + +GETXYA: CALL CHKSYN ; Make sure "(" follows + DB "(" + CALL GETNUM ; Get a number + CALL DEINT ; Get integer -32768 to 32767 + PUSH DE ; Save "X" + CALL CHKSYN ; Make sure "," follows + DB "," + CALL GETNUM ; Get a number + CALL CHKSYN ; Make sure ")" follows + DB ")" + CALL DEINT ; Get integer -32768 to 32767 + PUSH HL ; Save code string address + POP IY ; In IY + CALL XYPOS ; Address and bit mask + PUSH AF ; Save mask + CALL ADJCOL ; Adjust column + CALL SCRADR ; Get VDU address + POP AF ; Restore bit mask + LD B,11000000B ; Block graphics base + OR B ; Set bits 7 & 6 + RET + +SETB: CALL GETXYA ; Get co-ords and VDU address + PUSH AF ; Save bit mask + LD A,(HL) ; Get character from screen + CP 11000000B ; Is it a block graphic? + JP NC,SETOR ; Yes - OR new bit + POP AF ; Restore bit mask +PUTBIT: LD (HL),A ; Put character on screen +RESCSA: PUSH IY ; Restore code string address + POP HL ; From IY + RET + +SETOR: POP BC ; Restore bit mask + OR B ; Merge the bits + JP PUTBIT ; Save on screen + +RESETB: CALL GETXYA ; Get co-ords and VDU address + PUSH AF ; Save bit mask + LD A,(HL) ; Get byte from screen + CP 11000000B ; Is it a block graphic? + JP C,NORES ; No - Leave it + LD B,00111111B ; Six bits per block + AND B ; Clear bits 7 & 6 + POP BC ; Get bit mask + AND B ; Test for common bit + JP Z,RESCSA ; None - Leave it + LD A,(HL) ; Get byte from screen + AND 00111111B ; Isolate bit + XOR B ; Clear that bit + CP 11000000B ; Is it a graphic blank? + JP NZ,PUTBIT ; No - Save character + LD A," " ; Put a space there + JP PUTBIT ; Save the space + +NORES: POP BC ; Drop bit mask + JP RESCSA ; Restore code string address + +POINTB: CALL GETXYA ; Get co-ords and VDU address + LD B,(HL) ; Get character from screen + CALL TSTBIT ; Test if bit is set + JP NZ,POINT0 ; Different - Return zero + LD A,0 + LD B,1 ; Integer AB = 1 +POINTX: POP HL ; Drop return + PUSH IY ; PUSH code string address + LD DE,RETNUM ; To return a number + PUSH DE ; Save for return + JP ABPASS ; Return integer AB + +POINT0: LD B,0 ; Set zero + JP POINTX ; Return value + +XYPOS: POP BC ; Get return address + POP HL ; Get column + PUSH HL ; And re-save + PUSH BC ; Put back return address + LD A,L ; Get column + LD B,00000001B ; 2 bits per character + AND B ; Odd or even bit + PUSH AF ; Save it + PUSH DE ; Get row + POP HL ; to HL + LD DE,0 ; Zero line count + LD BC,3 ; 3 blocks per line + INC HL +DIV3LP: SBC HL,BC ; Subtract 3 + INC DE ; Count the subtractions + JP Z,DIV3EX ; Exactly - Exit + JP P,DIV3LP ; More to do + +DIV3EX: ADD HL,BC ; Restore number + POP AF ; Restore column and odd/even + OR A ; Set flags (NZ or Z) + LD A,L ; Get remainder from /3 + JP Z,NOREMD ; No remainder + ADD A,3 ; Adjust remainder +NOREMD: LD B,A ; Bit number+1 to B + LD A,00000001B ; Bit to rotate +SHFTBT: RLCA ; Shift bit left + DJNZ SHFTBT ; Count shifts + RRA ; Restore correct place + RET + +ADJCOL: POP BC ; Restore return address + POP AF ; Get bit mask + POP HL ; Get column + PUSH AF ; Re-save but mask + LD A,L ; Get column + RRA ; Divide by 2 + ADD A,1 ; Start at column 1 + AND 00111111B ; 0 to 63 + LD H,A ; Save column in H + PUSH HL ; Re-save column + PUSH BC ; Put back return + LD A,E ; Get row + RET + +SMOTOR: CALL CASFF ; Flip tape drive + LD A,(HL) ; Get byte + RET + +JPLDSV: LD A,(BRKLIN) ; CLOAD or CSAVE? + CP -1 + JP NZ,SNDHDR ; CSAVE - Send header + JP GETHDR ; CLOAD - Get header + +CRLIN1: CALL PRNTCR ; Output CRLF + JP GETLIN ; Get an input line + +CRLIN: CALL PRNTCR ; Output CRLF + JP GETLIN ; Get an input line + +TSTBIT: PUSH AF ; Save bit mask + AND B ; Get common bits + POP BC ; Restore bit mask + CP B ; Same bit set? + LD A,0 ; Return 0 in A + RET + +OUTNCR: CALL OUTC ; Output character in A + JP PRNTCR ; Output CRLF + +JJUMP: JP JJUMP1 ; "Cool" start + +ZJUMP: JP BRKRET ; Warm start + END diff --git a/software/asm/tzfs.asm b/software/asm/tzfs.asm index ba934d2..8fe522b 100644 --- a/software/asm/tzfs.asm +++ b/software/asm/tzfs.asm @@ -1684,7 +1684,9 @@ LOADSD2A: POP HL LOADSD3: LD DE,TZSVC_FILENAME LD BC,TZSVCFILESZ LDIR ; Copy in the MZF filename. -LOADSD3A: LD A,TZSVC_CMD_LOADFILE +LOADSD3A: LD A,TZSVC_FTYPE_MZF ; Set to MZF type files. + LD (TZSVC_FILE_TYPE),A + LD A,TZSVC_CMD_LOADFILE LD (TZSVCCMD), A ; Load up the command into the service record. CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. OR A @@ -1765,7 +1767,9 @@ ERASESD1: POP HL LD DE,TZSVC_FILENAME LD BC,TZSVCFILESZ LDIR ; Copy in the MZF filename. -ERASESD2: LD A,TZSVC_CMD_ERASEFILE +ERASESD2: LD A,TZSVC_FTYPE_MZF ; Set to MZF type files. + LD (TZSVC_FILE_TYPE),A + LD A,TZSVC_CMD_ERASEFILE LD (TZSVCCMD), A ; Load up the command into the service record. CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. OR A @@ -1815,7 +1819,9 @@ SAVESD1: LD (SDCOPY),A ; Save the file by making a service call to the I/O processor, it will allocate a filename on the SD, read the tranZPUter memory directly based on the values in the ; service record. -SAVESD2: LD A,TZSVC_CMD_SAVEFILE +SAVESD2: LD A,TZSVC_FTYPE_MZF ; Set to MZF type files. + LD (TZSVC_FILE_TYPE),A + LD A,TZSVC_CMD_SAVEFILE LD (TZSVCCMD), A ; Load up the command into the service record. CALL SVC_CMD ; And make communications wit the I/O processor, returning with the required record. OR A diff --git a/software/roms/CPM223.BIN b/software/roms/CPM223.BIN index bee9a83..e2f272f 100644 Binary files a/software/roms/CPM223.BIN and b/software/roms/CPM223.BIN differ diff --git a/software/roms/tzfs.rom b/software/roms/tzfs.rom index f7fbb4d..48a3572 100644 Binary files a/software/roms/tzfs.rom and b/software/roms/tzfs.rom differ diff --git a/software/src/tools/Makefile b/software/src/tools/Makefile index 61804b6..ec1456a 100644 --- a/software/src/tools/Makefile +++ b/software/src/tools/Makefile @@ -52,6 +52,9 @@ COMMON_OBJ = $(patsubst $(COMMON_DIR)/%.c,$(BUILD_DIR)/%.o,$(COMMON_SRC)) FLASHMMCFG_PRJ = flashmmcfg FLASHMMCFG_SRC = flashmmcfg.c FLASHMMCFG_OBJ = $(COMMON_OBJ) $(patsubst %.c,$(BUILD_DIR)/%.o,$(FLASHMMCFG_SRC)) +NASCONV_PRJ = nasconv +NASCONV_SRC = nasconv.c +NASCONV_OBJ = $(COMMON_OBJ) $(patsubst %.c,$(BUILD_DIR)/%.o,$(NASCONV_SRC)) # Commandline options for each tool. OPTS = @@ -66,15 +69,17 @@ ASFLAGS = -I. -I$(COMMON_DIR) -I$(INCLUDE_DIR) -I$(STARTUP_DIR) # # Our target. -all: clean $(BUILD_DIR) $(FLASHMMCFG_PRJ) +all: clean $(BUILD_DIR) $(FLASHMMCFG_PRJ) $(NASCONV_PRJ) install: all cp $(FLASHMMCFG_PRJ) $(INSTALLDIR) + cp $(NASCONV_PRJ) $(INSTALLDIR) clean: - rm -f $(BUILD_DIR)/*.o *.hex *.lss *.elf *.map *.lst *.srec *~ */*.o *.bin *.srec *.dmp *.vhd *.rpt $(FLASHMMCFG_PRJ) + rm -f $(BUILD_DIR)/*.o *.hex *.lss *.elf *.map *.lst *.srec *~ */*.o *.bin *.srec *.dmp *.vhd *.rpt $(FLASHMMCFG_PRJ) $(NASCONV_PRJ) $(FLASHMMCFG_PRJ): $(FLASHMMCFG_PRJ).elf $(FLASHMMCFG_PRJ).dmp $(FLASHMMCFG_PRJ).lss +$(NASCONV_PRJ): $(NASCONV_PRJ).elf $(NASCONV_PRJ).dmp $(NASCONV_PRJ).lss # Convert ELF binary to bin file. %.bin: %.elf @@ -97,10 +102,18 @@ $(FLASHMMCFG_PRJ): $(FLASHMMCFG_OBJ) $(CC) $(LFLAGS) $(FLASHMMCFG_OBJ) -o $@ $(LIBS) chmod +x $@ +$(NASCONV_PRJ): $(NASCONV_OBJ) + $(CC) $(LFLAGS) $(NASCONV_OBJ) -o $@ $(LIBS) + chmod +x $@ + # Link - this produces an ELF binary. $(FLASHMMCFG_PRJ).elf: $(FLASHMMCFG_OBJ) $(LD) $(LFLAGS) -o $@ $+ $(LIBS) +# Link - this produces an ELF binary. +$(NASCONV_PRJ).elf: $(NASCONV_OBJ) + $(LD) $(LFLAGS) -o $@ $+ $(LIBS) + $(BUILD_DIR)/%.o: %.c Makefile $(CC) $(CFLAGS) $(OFLAGS) -o $@ -c $< diff --git a/software/src/tools/nasconv.c b/software/src/tools/nasconv.c new file mode 100644 index 0000000..c5080c1 --- /dev/null +++ b/software/src/tools/nasconv.c @@ -0,0 +1,308 @@ +///////////////////////////////////////////////////////////////////////////////////////////////////////// +// +// Name: nasconv.c +// Created: June 2020 +// Author(s): Philip Smart +// Description: Tool to extract a linear image from a NASCOM cassette format image. The NASCOM +// is formatted with tape sequencing data which is not needed. +// +// Credits: +// Copyright: (c) 2020 Philip Smart +// +// History: March 2020 - Initial program written. +// +// Notes: +// +///////////////////////////////////////////////////////////////////////////////////////////////////////// +// This source file is free software: you can redistribute it and#or modify +// it under the terms of the GNU General Public License as published +// by the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// This source file is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with this program. If not, see . +///////////////////////////////////////////////////////////////////////////////////////////////////////// + +#include +#include +#include +#include +#include +#include + +#define VERSION "1.0" + + +// Simple help screen to remmber how this utility works!! +// +void usage(void) +{ + printf("NASCONV v%s\n", VERSION); + printf("\nRequired:-\n"); + printf(" -i | --image Image file to be converted.\n"); + printf(" -o | --output Target destination file for converted data.\n"); + printf("\nOptions:-\n"); + + printf(" -l | --loadaddr MZ80A basic start address. NASCOM address is used to set correct MZ80A address.\n"); + printf(" -n | --nasaddr Original NASCOM basic start address.\n"); + printf(" -h | --help This help test.\n"); + printf(" -v | --verbose Output more messages.\n"); + + printf("\nExamples:\n"); + printf(" nasconv --image 3dnc.cas --output 3dnc.bas --nasaddr 0x10fa --loadaddr 0x4341 Convert the file 3dnc.cas from NASCOM cassette format.\n"); +} + +// Method to convert a little endian <-> big endian 32bit unsigned. +// +uint32_t swap_endian(uint32_t value) +{ + uint32_t b[4]; + b[0] = ((value & 0x000000ff) << 24u); + b[1] = ((value & 0x0000ff00) << 8u); + b[2] = ((value & 0x00ff0000) >> 8u); + b[3] = ((value & 0xff000000) >> 24u); + + return(b[0] | b[1] | b[2] | b[3]); +} + + +// Main program, to be split up into methods at a later date!! Just quick write. +// +int main(int argc, char *argv[]) +{ + + int opt; + int option_index = 0; + int help_flag = 0; + int verbose_flag = 0; + uint8_t zeroCount = 0; + uint8_t ffCount = 0; + uint8_t readCount = 0; + uint8_t hdrCount = 0; + uint8_t hdr[5]; + uint8_t cassette[65536]; + uint16_t loadAddr = 0x4341; + uint16_t nasAddr = 0x10fa; + uint32_t casPos = 0; + uint32_t casIdx = 0; + char imageFile[1024]; + char outputFile[1024]; + FILE *fpImage; + FILE *fpOutput; + + // Initialise other variables. + // + imageFile[0] = 0x00; + outputFile[0] = 0x00; + + // Modes of operation. + static struct option long_options[] = + { + {"help", no_argument, 0, 'h'}, + {"image", required_argument, 0, 'i'}, + {"output", required_argument, 0, 'o'}, + {"loadaddr", required_argument, 0, 'l'}, + {"nasaddr", required_argument, 0, 'n'}, + {"verbose", no_argument, 0, 'v'}, + {0, 0, 0, 0} + }; + + // Parse the command line options. + // + while((opt = getopt_long(argc, argv, ":hvi:o:l:n:", long_options, &option_index)) != -1) + { + switch(opt) + { + case 'h': + help_flag = 1; + break; + + case 'i': + strcpy(imageFile, optarg); + break; + + case 'o': + strcpy(outputFile, optarg); + break; + + case '1': + loadAddr = atoi(optarg); + break; + + case 'n': + nasAddr = atoi(optarg); + break; + + case 'v': + verbose_flag = 1; + break; + + case ':': + printf("Option %s needs a value\n", argv[optind-1]); + break; + case '?': + printf("Unknown option: %s, ignoring!\n", argv[optind-1]); + break; + } + } + + // Validate the input. + if(help_flag == 1) + { + usage(); + exit(0); + } + if(strlen(imageFile) == 0 ) + { + printf("Image file not specified.\n"); + exit(10); + } + if(strlen(outputFile) == 0 ) + { + printf("Output file not specified.\n"); + exit(10); + } + + // Open the NASCOM CASSETTE image file. + fpImage = fopen(imageFile, "r"); + if(fpImage == NULL) + { + printf("Couldnt open the image file:%s.\n", imageFile); + exit(30); + } + + // Create a new file to output the extracted data. + fpOutput = fopen(outputFile, "w"); + if(fpOutput == NULL) + { + printf("Couldnt create the output file:%s.\n", outputFile); + exit(31); + } + + // First get the image into memory removing the outer tape block wrappers. + // + fseek(fpImage, 0, 0); + uint32_t addr = 0; + do { + int c = fgetc(fpImage); + + // If we are in a data block, just store into memory for later manipulation. + if(ffCount >= 4 && hdrCount >= 5) + { + if(verbose_flag) + printf("%02x ", c); + cassette[casPos++] = c; + readCount++; + + // Header[2] contains the block size, normally 256 bytes but can be less on the last block. + if(readCount == hdr[2]) + { + zeroCount = 0; + ffCount = 0; + hdrCount = 0; + } + } else + { + // A block header starts with one or more zeros followed by 4x0xFF then a 5 byte description block. + if(c == 0x00 && ffCount == 0) + { + zeroCount++; + } else + if(zeroCount > 0 && ffCount < 4 && c == 0xff) + { + ffCount++; + } else + if(ffCount >= 4 && hdrCount < 5) + { + hdr[hdrCount] = c; + hdrCount++; + if(hdrCount == 5) + { + readCount = 0; + } + if(verbose_flag) + printf("ADDR:%04x, HDR[0..4]=%02x,%02x,%02x,%02x,%02x\n", addr, hdr[0], hdr[1], hdr[2], hdr[3], hdr[4]); + } else + { + zeroCount = 0; + ffCount = 0; + hdrCount = 0; + } + } + addr++; + } while(!feof(fpImage)); + + // Find the start of the basic program, a block starting 0x80 0x00 0x00 0x00 + // + //for(casIdx = 0; casIdx < casPos; casIdx++) + // { + // if(cassette[casIdx] == 0x80 && cassette[casIdx+1] == 0x00 && cassette[casIdx+2] == 0x00 && cassette[casIdx+3] == 0x000) + // break; + // } + // The above code only worked on some files, others are not really decipherable given I dont have the NASCOM tape details, but further analysis shows + // all the files start at the common vector 0x132 or 0x24 after removal of tape run in header, so will run with this! + casIdx = 0x24 - 4; // Adjust so the below code works as intended. + + if(verbose_flag) + { + printf("\n"); for(uint16_t idx=0; idx < casPos; idx++) { printf("%02x ", cassette[idx]); }; printf("\n"); + } + + // If the start block couldnt be found then we cant process this file. + if(casIdx < casPos) + { + // Update the pointers to the correct load address in the MZ80A basic. + // The cassette image contains the load addresses of each line, these addresses are NASCOM addresses so need updating. + // + uint16_t lastAddr = nasAddr; + for(uint16_t idx = casIdx+4; idx< casPos;) + { + uint16_t origAddr = *(uint16_t *)&cassette[idx]; + + // End of program the next address will be zero so exit. + if(idx > casIdx+4 && origAddr == 0x0000) + break; + + // Update the address to the new value for the MZ80A version of Microsoft Basic. + *(uint16_t *)&cassette[idx] = (origAddr - nasAddr) + loadAddr; + //printf("OrigAddr = %04x, lastAddr = %04x, next = %04x\n", origAddr, lastAddr, (origAddr - nasAddr) + loadAddr); + + // Scan for tokens in the program code and update. + // Skip the line number and just work within the actual tokenised data. + // + for(uint16_t idx2 = idx+4; idx2 < idx + (origAddr - lastAddr); idx2++) + { + if(cassette[idx2] > 0xA4 && cassette[idx2] < 0xcf) + { + //printf("Updating:%04x,%02x\n", idx, cassette[idx2]); + if(cassette[idx2] > 0xe4) + printf("EXCEED:%04x,%02x\n", idx2, cassette[idx2]); + cassette[idx2] = cassette[idx2] + (0xC0 - 0xA5); + } + } + idx += origAddr - lastAddr; + lastAddr = origAddr; + } + + // Write out the data to finish. + for(uint32_t idx=casIdx+4; idx < casPos; idx++) + { + fputc(cassette[idx], fpOutput); + } + } + else + { + printf("Tape data not valid:%s, update logic to cater for this file or use a correct data file.\n", outputFile); + } + + // Close files to finish. + fclose(fpImage); + fclose(fpOutput); + if(verbose_flag) + printf("Image file updated.\n"); +} diff --git a/software/tools/assemble_roms.sh b/software/tools/assemble_roms.sh index 6464eef..a903e7c 100755 --- a/software/tools/assemble_roms.sh +++ b/software/tools/assemble_roms.sh @@ -34,7 +34,7 @@ JARDIR=${ROOTDIR}/software/tools ASM=glass-0.5.jar BUILDROMLIST="MZ80AFI monitor_SA1510 monitor_80c_SA1510 monitor_1Z-013A monitor_80c_1Z-013A MZ80B_IPL" #BUILDMZFLIST="hi-ramcheck sharpmz-test" -BUILDMZFLIST="sharpmz-test" +BUILDMZFLIST="BASIC sharpmz-test" ASMDIR=${ROOTDIR}/software/asm ASMTMPDIR=${ROOTDIR}/software/tmp INCDIR=${ROOTDIR}/software/asm/include @@ -61,7 +61,7 @@ do cp ${ASMTMPDIR}/${f}.obj ${ROMDIR}/${f}.rom else echo "Copy ${ASMDIR}/${f}.obj to ${MZFDIR}/${f}.mzf" - cp ${ASMTMPDIR}/${f}.obj ${MZFDIR}/${f}.mzf + cp ${ASMTMPDIR}/${f}.obj ${MZFDIR}/${f}.MZF fi fi done diff --git a/software/tools/nasconv b/software/tools/nasconv new file mode 100755 index 0000000..ac9b7dc Binary files /dev/null and b/software/tools/nasconv differ