Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / rascal.arc / TEST.BAS < prev next >

Wrap

BASIC Source File | 1985-08-03 | 17.4 KB | 554 lines

10 'CHARS.RAS 8-03-85 2:27p 464 lines 12 GOSUB 70 20 GOSUB 4170 30 END 40 'CHARS.RAS: Display all the PC's screen characters, modified from 50 ' Peter Norton's book. 60 'Rascal Program Debugger, version 1.00 (C) Copyright 1983 Marty Franz 70 'PROCEDURE DEBUG.SETUP 80 'Set up stack of procedure names 90 DB.NPROCS = 10 100 DIM DB.LABEL$(DB.NPROCS),DB.LINE(DB.NPROCS) 110 'Set up cursor and output variables 120 DB.STATUS.LINE = 25 130 DB.CUROFF = 0 : DB.CURON = 1 140 DB.BLINK = 5 : DB.CURCNT = DB.BLINK 150 DB.CURSOR$ = CHR$(&H5F) 160 DB.BKSP$ = CHR$(8) 170 DB.RET$ = CHR$(13) 180 DB.TLBOX$ = CHR$(&HC9) : DB.TRBOX$ = CHR$(&HBB) 190 DB.BLBOX$ = CHR$(&HC8) : DB.BRBOX$ = CHR$(&HBC) 200 DB.TOP$ = CHR$(&HCD) : DB.SIDE$ = CHR$(&HBA) 210 DB.MASK$ = "\ \" 220 'String for proofing labels input as breakpoints 230 DB.LABCHRS$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789." 240 'Establish error and key trapping (F10 stops debugger) 250 ON ERROR GOTO 370 260 ON KEY(10) GOSUB 410 270 KEY OFF 280 KEY (10) ON 290 DB.LEVEL = 0 'No procedures entered yet 300 DB.BPOINT = 0 'No breakpoints in effect 310 DB.CMDSTOP = 0 'No command keyboard stops 320 GOSUB 440 330 GOSUB 2340 340 GOSUB 2290 350 GOSUB 1110 360 RETURN 370 'Error routine for BASIC errors 'DB.BASIC.ERROR| 380 GOSUB 610 390 GOSUB 1110 400 RESUME 410 'PROCEDURE DEBUG.KEYBD.STOP 'Entered when F10 pressed 420 DB.CMDSTOP = 1 430 RETURN 440 'PROCEDURE DEBUG.HELLO 'Tell user available functions 450 CLS 460 PRINT "Rascal Program Debugger active..." 470 PRINT 480 PRINT "You can enter the debugger by:" 490 PRINT 500 PRINT " 1. Pressing F10 during program execution," 510 PRINT " 2. Setting a procedure breakpoint with the B command," 520 PRINT " 3. Your program causing a BASIC error." 530 PRINT 540 PRINT "In the debugger, you can type:" 550 PRINT 560 PRINT " X to exit into BASIC (type CONT to go back)," 570 PRINT " D to list the Rascal procedures called," 580 PRINT " B to set a procedure breakpoint," 590 PRINT " G to resume your program's execution" 600 RETURN 610 'PROCEDURE DEBUG.BASIC.ERROR 'Process BASIC errors 620 COLOR 15,0 630 LOCATE DB.STATUS.LINE,1,CUROFF 640 PRINT USING "##### ";ERL; 650 DB.ERROR = ERR 660 IF NOT(DB.ERROR > 77) THEN 680 670 DB.ERROR = 77 680 GOSUB 720 690 LOCATE ,,CURON 700 COLOR 7,0 710 RETURN 720 'PROCEDURE DEBUG.ERROR.MSG 'Decode BASIC error msg 730 RESTORE 2400 740 READ DB.ERR.KEY,DB.ERROR.MSG$ 750 IF NOT(DB.ERR.KEY = DB.ERROR) THEN 770 760 GOTO 780 770 IF NOT(DB.ERR.KEY = 77) THEN 740 780 PRINT USING DB.MASK$;DB.ERROR.MSG$ 790 RETURN 800 'PROCEDURE DEBUG.PROC 'Handle procedure call 810 GOSUB 2340 820 DB.LEVEL = DB.LEVEL + 1 830 DB.LABEL$(DB.LEVEL) = DEBUG.LABEL$ 840 DB.LINE(DB.LEVEL) = DEBUG.LINE 850 GOSUB 1000 860 IF NOT(DB.BPOINT = 1 AND DB.BPLABEL$ = DEBUG.LABEL$) THEN 880 870 DB.CMDSTOP = 1 880 IF NOT(DB.CMDSTOP = 1) THEN 920 890 GOSUB 2240 900 GOSUB 1110 910 DB.CMDSTOP = 0 920 GOSUB 2370 930 RETURN 940 'PROCEDURE DEBUG.ENDP 'Handle procedure exit 950 GOSUB 2340 960 DB.LEVEL = DB.LEVEL - 1 970 GOSUB 1000 980 GOSUB 2370 990 RETURN 1000 'PROCEDURE DEBUG.TRACE.MSG 'Display procedure and line 1010 COLOR 15,0 1020 LOCATE DB.STATUS.LINE,1,CUROFF 1030 IF NOT(DB.LEVEL > 0) THEN 1070 1040 PRINT USING "##### ";DB.LINE(DB.LEVEL); 1050 PRINT USING DB.MASK$;DB.LABEL$(DB.LEVEL); 1060 GOTO 1080 1070 PRINT USING DB.MASK$;"Exit"; 1080 LOCATE ,,CURON 1090 COLOR 7,0 1100 RETURN 1110 'PROCEDURE DEBUG.CMD 'Get and process commands 1120 DB.DONE = 0 1130 GOSUB 1180 1140 GOSUB 1250 1150 IF NOT(DB.DONE = 1) THEN 1130 1160 GOSUB 2240 1170 RETURN 1180 'PROCEDURE DEBUG.GET.CMD 'Get and proof debugger command 1190 GOSUB 2240 1200 PRINT "debug: "; 1210 GOSUB 1900 1220 DB.ISKEY = INSTR("BDGX",DB.KEY$) 1230 IF NOT(DB.ISKEY > 0) THEN 1210 1240 RETURN 1250 'PROCEDURE DEBUG.DO.CMD 'Call procedure for each command 1260 IF NOT(DB.KEY$ = "G") THEN 1290 1270 DB.DONE = 1 1280 GOTO 1390 1290 IF NOT(DB.KEY$ = "X") THEN 1320 1300 GOSUB 1400 1310 GOTO 1390 1320 IF NOT(DB.KEY$ = "B") THEN 1350 1330 GOSUB 1460 1340 GOTO 1390 1350 IF NOT(DB.KEY$ = "D") THEN 1380 1360 GOSUB 1560 1370 GOTO 1390 1380 BEEP 1390 RETURN 1400 'PROCEDURE DEBUG.DO.STOP 'Handle exit to BASIC 1410 PRINT "exit to BASIC"; 1420 GOSUB 2370 1430 PRINT : PRINT "Type CONT to go back to debugger..." 1440 STOP 1450 RETURN 1460 'PROCEDURE DEBUG.DO.BPOINT 'Set breakpoint 1470 GOSUB 2240 1480 PRINT "breakpoint: "; 1490 GOSUB 1740 1500 DB.BPLABEL$ = DB.INPUT$ 1510 IF NOT(LEN(DB.BPLABEL$) > 0) THEN 1540 1520 DB.BPOINT = 1 1530 GOTO 1550 1540 DB.BPOINT = 0 1550 RETURN 1560 'PROCEDURE DEBUG.DO.DUMP 'Dump stack of procedure calls 1570 PRINT "dump procedure stack"; 1580 LOCATE 1,38 1590 PRINT DB.TLBOX$; 1600 FOR DB.I = 1 TO 40 : PRINT DB.TOP$; : NEXT DB.I 1610 PRINT DB.TRBOX$ 1620 FOR DB.I = DB.LEVEL TO 1 STEP -1 1630 LOCATE ,38 1640 PRINT DB.SIDE$;" "; 1650 PRINT USING "##### ";DB.LINE(DB.I); 1660 PRINT USING DB.MASK$;DB.LABEL$(DB.I); 1670 PRINT " ";DB.SIDE$ 1680 NEXT DB.I 1690 LOCATE ,38 1700 PRINT DB.BLBOX$; 1710 FOR DB.I = 1 TO 40 : PRINT DB.TOP$; : NEXT DB.I 1720 PRINT DB.BRBOX$; 1730 RETURN 1740 'PROCEDURE DEBUG.GET.STRING 'Get label name for breakpoint 1750 DB.INPUT$ = "" 1760 DB.START.COL = POS(0) 1770 GOSUB 1900 1780 IF NOT(DB.KEY$ = DB.RET$) THEN 1810 1790 GOTO 1890 1800 GOTO 1880 1810 IF NOT(DB.KEY$ = DB.BKSP$) THEN 1840 1820 GOSUB 2040 1830 GOTO 1880 1840 IF NOT(INSTR(DB.LABCHRS$,DB.KEY$) > 0) THEN 1870 1850 GOSUB 1970 1860 GOTO 1880 1870 BEEP 1880 IF NOT(1 = 0) THEN 1770 1890 RETURN 1900 'PROCEDURE DEBUG.GET.KEY 'Get uppercase key from keyboard 1910 GOSUB 2130 1920 DB.KEY$ = INKEY$ 1930 IF NOT(LEN(DB.KEY$) > 0) THEN 1910 1940 IF NOT(ASC(DB.KEY$) > 96 AND ASC(DB.KEY$) < 123) THEN 1960 1950 DB.KEY$ = CHR$(ASC(DB.KEY$) - 32) 1960 RETURN 1970 'PROCEDURE DEBUG.INS.CHAR 'Add char to end of breakpoint label 1980 IF NOT(POS(0) < 79) THEN 2020 1990 PRINT DB.KEY$; 2000 DB.INPUT$ = DB.INPUT$ + DB.KEY$ 2010 GOTO 2030 2020 BEEP 2030 RETURN 2040 'PROCEDURE DEBUG.DEL.CHAR 'Handle backspace key in input 2050 DB.CUR.COL = POS(0) 2060 IF NOT(DB.CUR.COL > DB.START.COL) THEN 2110 2070 DB.INPUT$ = LEFT$(DB.INPUT$,LEN(DB.INPUT$)-1) 2080 PRINT " "; 2090 LOCATE ,DB.CUR.COL-1 2100 GOTO 2120 2110 BEEP 2120 RETURN 2130 'PROCEDURE DEBUG.CURSOR 'Simulate BASIC cursor 2140 IF NOT(DB.CURCNT = DB.BLINK) THEN 2200 2150 IF NOT(DB.CURCHAR$ = DB.CURSOR$) THEN 2180 2160 DB.CURCHAR$ = " " 2170 GOTO 2190 2180 DB.CURCHAR$ = DB.CURSOR$ 2190 DB.CURCNT = 0 2200 PRINT DB.CURCHAR$; 2210 DB.CURCNT = DB.CURCNT + 1 2220 LOCATE ,POS(0)-1 2230 RETURN 2240 'PROCEDURE DEBUG.CLR.CMD 'Clear command area of status line 2250 LOCATE DB.STATUS.LINE,40,CUROFF 2260 PRINT SPACE$(40); 2270 LOCATE DB.STATUS.LINE,40,CURON 2280 RETURN 2290 'PROCEDURE DEBUG.CLR.MSG 'Clear message area of status line 2300 LOCATE DB.STATUS.LINE,1,CUROFF 2310 PRINT SPACE$(40); 2320 LOCATE DB.STATUS.LINE,1,CURON 2330 RETURN 2340 'PROCEDURE DEBUG.PUSH.CURSOR 'Save program's cursor 2350 DB.ROW = CSRLIN : DB.COL = POS(0) 2360 RETURN 2370 'PROCEDURE DEBUG.POP.CURSOR 'Restore program's cursor 2380 LOCATE DB.ROW,DB.COL 2390 RETURN 2400 'Table of BASIC error messages 'DB.ERROR.MSGS| 2410 DATA 1,"NEXT without FOR" 2420 DATA 2,"Syntax error" 2430 DATA 3,"RETURN without GOSUB" 2440 DATA 4,"Out of data" 2450 DATA 5,"Illegal function call" 2460 DATA 6,"Overflow" 2470 DATA 7,"Out of memory" 2480 DATA 8,"Undefined line number" 2490 DATA 9,"Subscript out of range" 2500 DATA 10,"Duplicate definition" 2510 DATA 11,"Division by zero" 2520 DATA 12,"Illegal direct" 2530 DATA 13,"Type mismatch" 2540 DATA 14,"Out of string space" 2550 DATA 15,"String too long" 2560 DATA 16,"String formula too complex" 2570 DATA 17,"Can't continue" 2580 DATA 18,"Undefined user function" 2590 DATA 19,"No RESUME" 2600 DATA 20,"RESUME without error" 2610 DATA 22,"Missing operand" 2620 DATA 23,"Line buffer overflow" 2630 DATA 24,"Device timeout" 2640 DATA 25,"Device fault" 2650 DATA 26,"FOR without NEXT" 2660 DATA 27,"Out of paper" 2670 DATA 29,"WHILE without WEND" 2680 DATA 30,"WEND without WHILE" 2690 DATA 50,"FIELD overflow" 2700 DATA 51,"Internal error" 2710 DATA 52,"Bad file number" 2720 DATA 53,"File not found" 2730 DATA 54,"Bad file mode" 2740 DATA 55,"File already open" 2750 DATA 57,"Device I/O error" 2760 DATA 58,"File already exists" 2770 DATA 61,"Disk full" 2780 DATA 62,"Input past end" 2790 DATA 63,"Bad record number" 2800 DATA 64,"Bad file name" 2810 DATA 66,"Direct statement in file" 2820 DATA 67,"Too many files" 2830 DATA 68,"Device unavailable" 2840 DATA 69,"Communication buffer overflow" 2850 DATA 70,"Disk Write Protect" 2860 DATA 71,"Disk not ready" 2870 DATA 72,"Disk media error" 2880 DATA 73,"Advanced feature" 2890 DATA 74,"Rename across disks" 2900 DATA 75,"Path/file access error" 2910 DATA 76,"Path not found" 2920 DATA 77,"Unprintable error" 2930 'INPUT.INC: Some input routines that make life easier 2940 ' (C) Copyright 1983 Marty Franz 2950 'PROCEDURE INITIALIZE.INPUT 'Initialize cursor and proof string 2951 DEBUG.LINE = 2950 : DEBUG.LABEL$ = "INITIALIZE.INPUT" 2952 GOSUB 800 2960 IN.CHAR$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890 " 2970 IN.BLINK = 5 : IN.CURCNT = IN.BLINK 2971 DEBUG.LINE = 2980 2972 GOSUB 940 2980 RETURN 2990 'PROCEDURE GET.YES.OR.NO 'Get a yes or no answer from user 2991 DEBUG.LINE = 2990 : DEBUG.LABEL$ = "GET.YES.OR.NO" 2992 GOSUB 800 3000 'ANSWER contains either YES (1) or NO (0) on exit. 3010 IN.GOTIT = 0 : YES = 1 : NO = 0 3020 GOSUB 3280 3030 IF NOT(IN.KEY$ = "Y") THEN 3070 3040 IN.GOTIT = 1 3050 ANSWER = YES 3060 GOTO 3100 3070 IF NOT(IN.KEY$ = "N") THEN 3100 3080 IN.GOTIT = 1 3090 ANSWER = NO 3100 IF NOT(IN.GOTIT = 1) THEN 3020 3101 DEBUG.LINE = 3110 3102 GOSUB 940 3110 RETURN 3120 'PROCEDURE GET.STRING 'Get label name for breakpoint 3121 DEBUG.LINE = 3120 : DEBUG.LABEL$ = "GET.STRING" 3122 GOSUB 800 3130 IN.INPUT$ = "" 3140 IN.START.COL = POS(0) 3150 GOSUB 3280 3160 IF NOT(IN.KEY$ = CHR$(13)) THEN 3190 3170 GOTO 3270 3180 GOTO 3260 3190 IF NOT(IN.KEY$ = CHR$(8)) THEN 3220 3200 GOSUB 3390 3210 GOTO 3260 3220 IF NOT(INSTR(IN.CHARS$,IN.KEY$) > 0) THEN 3250 3230 GOSUB 3350 3240 GOTO 3260 3250 BEEP 3260 IF NOT(1 = 0) THEN 3150 3261 DEBUG.LINE = 3270 3262 GOSUB 940 3270 RETURN 3280 'PROCEDURE IN.GET.KEY 'Get uppercase key from keyboard 3281 DEBUG.LINE = 3280 : DEBUG.LABEL$ = "IN.GET.KEY" 3282 GOSUB 800 3290 GOSUB 3480 3300 IN.KEY$ = INKEY$ 3310 IF NOT(LEN(IN.KEY$) > 0) THEN 3290 3320 IF NOT(ASC(IN.KEY$) > 96 AND ASC(IN.KEY$) < 123) THEN 3340 3330 IN.KEY$ = CHR$(ASC(IN.KEY$) - 32) 3331 DEBUG.LINE = 3340 3332 GOSUB 940 3340 RETURN 3350 'PROCEDURE IN.INS.CHAR 'Add char to end of input string 3351 DEBUG.LINE = 3350 : DEBUG.LABEL$ = "IN.INS.CHAR" 3352 GOSUB 800 3360 PRINT IN.KEY$; 3370 IN.INPUT$ = IN.INPUT$ + IN.KEY$ 3371 DEBUG.LINE = 3380 3372 GOSUB 940 3380 RETURN 3390 'PROCEDURE IN.DEL.CHAR 'Handle backspace key in input 3391 DEBUG.LINE = 3390 : DEBUG.LABEL$ = "IN.DEL.CHAR" 3392 GOSUB 800 3400 IN.CUR.COL = POS(0) 3410 IF NOT(IN.CUR.COL > IN.START.COL) THEN 3460 3420 IN.INPUT$ = LEFT$(IN.INPUT$,LEN(IN.INPUT$)-1) 3430 PRINT " "; 3440 LOCATE ,IN.CUR.COL-1 3450 GOTO 3470 3460 BEEP 3461 DEBUG.LINE = 3470 3462 GOSUB 940 3470 RETURN 3480 'PROCEDURE IN.CURSOR 'Simulate BASIC cursor 3481 DEBUG.LINE = 3480 : DEBUG.LABEL$ = "IN.CURSOR" 3482 GOSUB 800 3490 IF NOT(IN.CURCNT = IN.BLINK) THEN 3550 3500 IF NOT(IN.CURCHAR$ = CHR$(&H5F)) THEN 3530 3510 IN.CURCHAR$ = " " 3520 GOTO 3540 3530 IN.CURCHAR$ = CHR$(&H5F) 3540 IN.CURCNT = 0 3550 PRINT IN.CURCHAR$; 3560 IN.CURCNT = IN.CURCNT + 1 3570 LOCATE ,POS(0)-1 3571 DEBUG.LINE = 3580 3572 GOSUB 940 3580 RETURN 3590 ' SCREEN.INC: a set of sample screen formatting routines 3600 ' (C) Copyright 1983 Marty Franz 3610 'PROCEDURE INITIALIZE.SCREEN 'Initialize all the screen variables 3611 DEBUG.LINE = 3610 : DEBUG.LABEL$ = "INITIALIZE.SCREEN" 3612 GOSUB 800 3620 BORDER$ = STRING$(80,&HC4) 3630 LINE.MASK$ = SPACE$(79) 3640 MSG.MASK$ = SPACE$(20) 3641 DEBUG.LINE = 3650 3642 GOSUB 940 3650 RETURN 3660 'PROCEDURE CLEAR.SCREEN 'Clear the screen, set keys off 3661 DEBUG.LINE = 3660 : DEBUG.LABEL$ = "CLEAR.SCREEN" 3662 GOSUB 800 3670 KEY OFF : CLS : WIDTH 80 3671 DEBUG.LINE = 3680 3672 GOSUB 940 3680 RETURN 3690 'PROCEDURE SET.TITLES 'Redisplay all the titles 3691 DEBUG.LINE = 3690 : DEBUG.LABEL$ = "SET.TITLES" 3692 GOSUB 800 3700 GOSUB 3660 3710 LOCATE 1,1 : PRINT L.TITLE$; 3720 LOCATE 1,80-LEN(R.TITLE$)+1 : PRINT R.TITLE$; 3730 LOCATE 3,1 : PRINT BORDER$ 3731 DEBUG.LINE = 3740 3732 GOSUB 940 3740 RETURN 3750 'PROCEDURE SET.FUNCTION.MSG 'Update the function message 3751 DEBUG.LINE = 3750 : DEBUG.LABEL$ = "SET.FUNCTION.MSG" 3752 GOSUB 800 3760 LOCATE 2,1 3770 PRINT LEFT$(FUNC.MSG$+MSG.MASK$,20); 3771 DEBUG.LINE = 3780 3772 GOSUB 940 3780 RETURN 3790 'PROCEDURE SET.ACTION.MSG 'Update the action message 3791 DEBUG.LINE = 3790 : DEBUG.LABEL$ = "SET.ACTION.MSG" 3792 GOSUB 800 3800 LOCATE 2,61 3810 PRINT RIGHT$(MSG.MASK$+ACT.MSG$,20); 3811 DEBUG.LINE = 3820 3812 GOSUB 940 3820 RETURN 3830 'PROCEDURE CLEAR.AREA 'Clear lines 4 thru 23 3831 DEBUG.LINE = 3830 : DEBUG.LABEL$ = "CLEAR.AREA" 3832 GOSUB 800 3840 LOCATE 4,1 3850 FOR CLRA.I = 4 TO 23 3860 PRINT LINE.MASK$ 3870 NEXT CLRA.I 3871 DEBUG.LINE = 3880 3872 GOSUB 940 3880 RETURN 3890 'PROCEDURE SET.LINE.24 'Put a message on line 24 3891 DEBUG.LINE = 3890 : DEBUG.LABEL$ = "SET.LINE.24" 3892 GOSUB 800 3900 LOCATE 24,1 3910 PRINT LINE.24.MSG$; 3911 DEBUG.LINE = 3920 3912 GOSUB 940 3920 RETURN 3930 'PROCEDURE CLEAR.LINE.24 'Clear the 24th line of the screen 3931 DEBUG.LINE = 3930 : DEBUG.LABEL$ = "CLEAR.LINE.24" 3932 GOSUB 800 3940 LINE.24.MSG$ = LINE.MASK$ 3950 GOSUB 3890 3951 DEBUG.LINE = 3960 3952 GOSUB 940 3960 RETURN 3970 'PROCEDURE DRAW.BOX 'Draw a box 3971 DEBUG.LINE = 3970 : DEBUG.LABEL$ = "DRAW.BOX" 3972 GOSUB 800 3980 LOCATE BOX.ROW,BOX.COL 3990 PRINT CHR$(&HDA);STRING$(BOX.LEN-2,&HC4);CHR$(&HBF) 4000 LOCATE ,BOX.COL 4010 FOR BOX.I=1 TO BOX.HT-2 4020 PRINT CHR$(&HB3);SPACE$(BOX.LEN-2);CHR$(&HB3) 4030 LOCATE ,BOX.COL 4040 NEXT BOX.I 4050 PRINT CHR$(&HC0);STRING$(BOX.LEN-2,&HC4);CHR$(&HD9) 4051 DEBUG.LINE = 4060 4052 GOSUB 940 4060 RETURN 4070 'PROCEDURE DRAW.FRAME 'Draw a frame (double lines) 4071 DEBUG.LINE = 4070 : DEBUG.LABEL$ = "DRAW.FRAME" 4072 GOSUB 800 4080 LOCATE FRAME.ROW,FRAME.COL 4090 PRINT CHR$(&HC9);STRING$(FRAME.LEN-2,&HCD);CHR$(&HBB) 4100 LOCATE ,FRAME.COL 4110 FOR FRAME.I = 1 TO FRAME.HT-2 4120 PRINT CHR$(&HBA);SPACE$(FRAME.LEN-2);CHR$(&HBA) 4130 LOCATE ,FRAME.COL 4140 NEXT FRAME.I 4150 PRINT CHR$(&HC8);STRING$(FRAME.LEN-2,&HCD);CHR$(&HBC) 4151 DEBUG.LINE = 4160 4152 GOSUB 940 4160 RETURN 4170 'PROCEDURE MAIN 4171 DEBUG.LINE = 4170 : DEBUG.LABEL$ = "MAIN" 4172 GOSUB 800 4180 GOSUB 3610 4190 GOSUB 2950 4200 L.TITLE$ = "CHARS - Display the IBM PC Character Set" 4210 R.TITLE$ = "Rascal version 1.05" 4220 GOSUB 3690 4230 FUNC.MSG$ = "Rascal Example #1" 4240 GOSUB 3750 4250 GOSUB 4320 4260 GOSUB 3690 4270 GOSUB 3750 4280 GOSUB 4420 4290 GOSUB 4510 4300 GOSUB 4580 4301 DEBUG.LINE = 4310 4302 GOSUB 940 4310 RETURN 4320 'PROCEDURE GET.DISPLAY.TYPE 4321 DEBUG.LINE = 4320 : DEBUG.LABEL$ = "GET.DISPLAY.TYPE" 4322 GOSUB 800 4330 LOCATE 5,1 : PRINT "Is this a color-graphics display? "; 4340 GOSUB 2990 4350 IF NOT(ANSWER = YES) THEN 4380 4360 SEGVAL! = &HB800 'Color segment 4370 GOTO 4390 4380 SEGVAL! = &HB000 'Monochrome segment 4390 DEF SEG = SEGVAL! 4400 PRINT 4401 DEBUG.LINE = 4410 4402 GOSUB 940 4410 RETURN 4420 'PROCEDURE BORDERS 4421 DEBUG.LINE = 4420 : DEBUG.LABEL$ = "BORDERS" 4422 GOSUB 800 4430 FOR HEX.DIGIT% = 0 TO 15 4440 LOCATE 6,HEX.DIGIT% * 3 + 14 4450 PRINT HEX$(HEX.DIGIT%) 4460 LOCATE HEX.DIGIT%+8,8 4470 PRINT HEX$(HEX.DIGIT%) 4480 NEXT HEX.DIGIT% 4490 LOCATE ,,0 4491 DEBUG.LINE = 4500 4492 GOSUB 940 4500 RETURN 4510 'PROCEDURE BUILD.DISPLAY.ARRAY 4511 DEBUG.LINE = 4510 : DEBUG.LABEL$ = "BUILD.DISPLAY.ARRAY" 4512 GOSUB 800 4520 FOR ROW% = 0 TO 15 4530 FOR COL% = 0 TO 15 4540 POKE (ROW%+7)*160+COL%*6+26, COL%+ROW%*16 4550 NEXT COL% 4560 NEXT ROW% 4561 DEBUG.LINE = 4570 4562 GOSUB 940 4570 RETURN 4580 'PROCEDURE FINISH 4581 DEBUG.LINE = 4580 : DEBUG.LABEL$ = "FINISH" 4582 GOSUB 800 4590 LINE.24.MSG$ = "Press any key to return to DOS..." 4600 GOSUB 3890 4610 GOSUB 3280 4620 GOSUB 3660 4630 SYSTEM 4631 DEBUG.LINE = 4640 4632 GOSUB 940 4640 RETURN