Programmer 7500

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

/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / ASMUTL / CHEAPASM.ZIP / CHASM.BAS (.txt) next >

Wrap

GW-BASIC | 1987-01-11 | 35.0 KB | 1,170 lines

10000 '*********************************** 10010 '* PROGRAM CHASM Version 1.9 * 10020 '* * 10030 '* CHeap ASseMbler for the IBM PC. * 10040 '* * 10050 '* Begun 6/15/82 by Dave Whitman * 10060 '*********************************** 10070 ' 10080 'main program 10090 GOSUB 50000 'initialize 10100 'wipe out transient code 10110 CHAIN MERGE "chasm.ovl",10120,ALL,DELETE 50000-51570 10120 GOSUB 19950 'set up sym table 10130 GOSUB 10170 'pass 1: build sym table 10140 GOSUB 10380 'pass 2: generate obj code & listing 10150 GOSUB 19490 'clean up 10160 SYSTEM 10170 '******************************************* 10180 '* SUBROUTINE PASSONE * 10190 '* Adds user-defined symbols to sym table. * 10200 '******************************************* 10210 ' 10220 PASS = 1 10230 LOCTR = 256 '0-255 reserved for p.s. prefix 10240 LINENUM = 0 10250 WHILE NOT EOF(1) 10260 'get source line, initialize 10270 GOSUB 10620 'getline 10280 'parse it 10290 GOSUB 10730 'parse 10300 'if label, enter in sym table 10310 IF LABEL$ <> "" THEN GOSUB 11640 'newentry 10320 'if op, decode, & update loctr 10330 IF OP$ <> "" THEN GOSUB 12480 'update_loctr 10340 'progress report 10350 GOSUB 19850 10360 WEND 10370 RETURN 10380 '********************************* 10390 '* SUBROUTINE PASSTWO * 10400 '* Generates obj code & listing. * 10410 '********************************* 10420 ' 10430 GOSUB 19370 'pass2_init 10440 ' 10450 WHILE NOT EOF(1) 10460 'get source line, initialize 10470 GOSUB 10620 'getline 10480 'parse line 10490 GOSUB 10730 'parse 10500 'phase error? 10510 IF LABEL$ <> "" THEN GOSUB 11910 'check_phase 10520 'if op, update loctr, generate obj. code 10530 IF OP$ <> "" THEN GOSUB 12480 'update_loctr 10540 'output obj. code & listing line 10550 GOSUB 19020 'output 10560 'progess report 10570 GOSUB 19850 10580 WEND 10590 'wipe out msg 10600 X = POS(0): Y = CSRLIN: LOCATE 25,1: PRINT TAB(79): LOCATE Y,X 10610 RETURN 10620 '******************************************** 10630 '* SUBROUTINE GETLINE * 10640 '* Gets line of source code for processing. * 10650 '* and initializes for new iteration. * 10660 '******************************************** 10670 ' 10680 LINE INPUT#1, INPLINE$ 10690 LINENUM = LINENUM + 1 10700 NEEDOFFSET = NONE: DSFLAG = FALSE 10710 OBJLEN = 0 10720 RETURN 10730 '***************************************************** 10740 '* SUBROUTINE PARSE * 10750 '* Parses input line for any label, op, or operands. * 10760 '***************************************************** 10770 ' 10780 LINEPTR = 1: LINEPTR2 = 1 10790 LABEL$ = "": OP$ = "": SOURCE$ = "": DEST$ = "" 10800 ' 10810 'set endptr to end of code 10820 ENDPTR = INSTR(INPLINE$,";") - 1 'just before comment 10830 IF ENDPTR = -1 THEN ENDPTR = LEN(INPLINE$) 'no comment, set to eol 10840 ' 10850 'no code? (return) 10860 IF ENDPTR = 0 THEN 11120 10870 ' 10880 'convert to all caps 10890 GOSUB 11140 10900 ' 10910 'label (if any) 10920 IF LEFT$(INPLINE$,1) = " " THEN 10960 10930 GOSUB 11280 'getfield 10940 LABEL$ = FLD$ 10950 ' 10960 'op-code 10970 GOSUB 11280 'getfield 10980 IF NOT FOUND THEN 11120 10990 OP$ = FLD$ 11000 'save ptr to start of operands 11010 OPDPTR = LINEPTR 11020 ' 11030 'destination operand (if any) 11040 GOSUB 11280 'getfield 11050 IF NOT FOUND THEN 11120 11060 DEST$ = FLD$ 11070 ' 11080 'source operand (if any) 11090 GOSUB 11280 'getfield 11100 IF NOT FOUND THEN 11120 11110 SOURCE$ = FLD$ 11120 RETURN 11130 ' 11140 'internal subroutine caps 11150 'Scans inpline$ up to comment field, 11160 'converting l.c. chars. to u.c.. Skips over strings. 11170 FOR I = 1 TO ENDPTR 11180 C$ = MID$(INPLINE$,I,1) 11190 'skip strings 11200 IF C$ <> "'" THEN 11240 11210 STRGEND = INSTR(I+1,INPLINE$,C$) 11220 IF STRGEND > 0 THEN I = STRGEND: GOTO 11250 11230 'convert 11240 IF ASC(C$) => 97 AND ASC(C$) <= 122 THEN C$ = CHR$(ASC(C$) - 32): MID$(INPLINE$,I,1) = C$ 11250 NEXT I 11260 RETURN 11270 '*********************************************************** 11280 '* SUBROUTINE GETFIELD * 11290 '* Starting at lineptr, trys to return next field in FLD$. * 11300 '* Sets found if sucessful. Moves lineptr past field. * 11310 '*********************************************************** 11320 ' 11330 'find next non-delimiter or run off end 11340 WHILE LINEPTR <= ENDPTR 11350 IF INSTR(" ,",MID$(INPLINE$,LINEPTR,1)) = 0 THEN 11380 11360 LINEPTR = LINEPTR + 1 11370 WEND 11380 'if past end, not found 11390 IF LINEPTR <= ENDPTR THEN 11420 11400 FOUND = FALSE 11410 RETURN 11420 ' 11430 'strings terminated by ' 11440 IF MID$(INPLINE$,LINEPTR,1) <> "'" THEN 11500 11450 STRGEND = INSTR(LINEPTR+1,INPLINE$,"'") 11460 IF STRGEND = 0 THEN 11500 11470 LINEPTR2 = STRGEND + 1 11480 GOTO 11570 11490 ' 11500 'otherwise, find next delimter or go 1 past end 11510 LINEPTR2 = LINEPTR 11520 WHILE LINEPTR2 <= ENDPTR 11530 IF INSTR(" ,",MID$(INPLINE$,LINEPTR2,1)) > 0 THEN 11570 11540 LINEPTR2 = LINEPTR2 + 1 11550 WEND 11560 ' 11570 'copy field 11580 FLD$ = MID$(INPLINE$,LINEPTR,LINEPTR2-LINEPTR) 11590 ' 11600 'move lineptr past field, set found & return 11610 LINEPTR = LINEPTR2 11620 FOUND = TRUE 11630 RETURN 11640 '********************************************** 11650 '* SUBROUTINE NEWENTRY * 11660 '* Adds new symbol to sym table with default * 11670 '* attributes. (may be changed by pseudo-ops) * 11680 '********************************************** 11690 ' 11700 'already in table? (error) 11710 TARGET$ = LABEL$ 11720 GOSUB 12030 'operand_lookup 11730 IF NOT FOUND THEN 11780 11740 ERRS = ERRS + 1 11750 PRINT#2,"****Error: Duplicate definition of ";LABEL$;" in ";LINENUM 11760 RETURN 11770 ' 11780 'table full? (error) 11790 IF NUMSYM < MAXSYM THEN 11840 11800 ERRS = ERRS + 1 11810 PRINT#2, "****Error: Too many user symbols in "; LINENUM 11820 RETURN 11830 ' 11840 'else make new entry 11850 NUMSYM = NUMSYM + 1 11860 SYM$(NUMSYM) = LABEL$ 11870 VAL1(NUMSYM) = LOCTR 11880 SYMTYPE(NUMSYM) = NEAR 11890 ' 11900 RETURN 11910 '********************************* 11920 '* SUBROUTINE CHECK_PHASE * 11930 '* Label value same both passes? * 11940 '********************************* 11950 IF OP$ = "EQU" THEN 12020 11960 TARGET$ = LABEL$ 11970 GOSUB 12030 'operand_lookup 11980 ' 11990 IF (SYMTYPE(TABLEPTR) AND (NEAR OR MEM)) = FALSE THEN 12020 12000 IF VAL1(TABLEPTR) = LOCTR THEN 12020 12010 ERRS = ERRS + 1: PRINT#2, "****Phase Error" 12020 RETURN 12030 '************************************************* 12040 '* SUBROUTINE OPERAND_LOOKUP * 12050 '* Trys to find TARGET$ in sym table. If there, * 12060 '* sets FOUND true, & TABLEPTR to its'position. * 12070 '************************************************* 12080 'scan table for symbol 12090 FOR TABLEPTR = 1 TO NUMSYM 12100 IF SYM$(TABLEPTR) = TARGET$ THEN 12160 'found 12110 NEXT TABLEPTR 12120 ' 12130 'failure exit point 12140 FOUND = FALSE 12150 RETURN 12160 'sucess exit point 12170 FOUND = TRUE 12180 RETURN 12190 '********************************************************* 12200 '* SUBROUTINE LOOKUP_OP * 12210 '* Given op-code in op$, & operand types in dtype & * 12220 '* stype, trys to find op in opcode table. If sucessful, * 12230 '* sets found true, & opptr to its' position. * 12240 '********************************************************* 12250 'binary search for good starting pt. 12260 MOVE = NUMOP: ST = MOVE/2 12270 WHILE MOVE >= 2 12280 MOVE = MOVE/2 12290 IF OP$ > OPCODE$(ST) THEN ST = ST + MOVE ELSE ST = ST - MOVE 12300 IF ST < 1 THEN ST = 1 12310 IF ST > NUMOP THEN ST = NUMOP 12320 WEND 12330 ' 12340 'scan for entry matching all 3 fields 12350 FOR OPPTR = ST TO NUMOP 12360 IF OPCODE$(OPPTR) > OP$ THEN 12420 'failed 12370 IF OPCODE$(OPPTR) <> OP$ THEN 12410 12380 IF (SRCTYPE(OPPTR) AND STYPE) = FALSE THEN 12410 12390 IF (DSTTYPE(OPPTR) AND DTYPE) = FALSE THEN 12410 12400 GOTO 12450 'found! 12410 NEXT OPPTR 12420 'failure exit 12430 FOUND = FALSE 12440 RETURN 12450 'successful exit 12460 FOUND = TRUE 12470 RETURN 12480 '*************************************** 12490 '* SUBROUTINE UPDATE_LOCTR * 12500 '* Decodes operation & advances loctr. * 12510 '* On pass 2, generates obj. code. * 12520 '*************************************** 12530 ' 12540 'set operand types & values 12550 'destination operand 12560 TARGET$ = DEST$: GOSUB 12860 'type_operand 12570 DTYPE = TARGTYPE 12580 DVAL1 = TARGVAL1 12590 DVAL2 = TARGVAL2 12600 'source operand 12610 'special case: RET op 12620 IF OP$ = "RET" THEN STYPE = PROCTYPE(STKTOP): GOTO 12690 12630 'normal source 12640 TARGET$ = SOURCE$: GOSUB 12860 'type_operand 12650 STYPE = TARGTYPE 12660 SVAL1 = TARGVAL1 12670 SVAL2 = TARGVAL2 12680 ' 12690 'find op in op table (not there: error) 12700 TARGET$ = OP$ 12710 GOSUB 12190 'lookup_op 12720 IF FOUND THEN 12810 12730 IF PASS = 1 THEN RETURN 12740 ERRS = ERRS + 1: PRINT#2,"****Syntax Error: ";OP$;DTYPE;STYPE 12750 IF ((ACUM8 OR ACUM16 OR REG8 OR REG16 OR SEG OR CS) AND (DTYPE OR STYPE)) THEN 12800 12760 IF (STYPE AND (NONE OR IMMED8 OR IMMED16)) = FALSE THEN 12800 12770 IF INSTR("BW",RIGHT$(OP$,1)) <> 0 THEN 12800 12780 DIAG = DIAG + 1 12790 PRINT#2,"****Diagnostic: Specify word or byte operation" 12800 RETURN 12810 FLAG = OFLAG(OPPTR) 12820 ' 12830 'branch for mach ops & pseudo-ops to update loctr 12840 IF FLAG AND MACHOP THEN GOSUB 15160 ELSE GOSUB 15970 12850 RETURN 12860 '********************************************************* 12870 '* SUBROUTINE TYPE_OPERAND * 12880 '* Sets TARGTYPE to reflect TARGET$'s type. Sets * 12890 '* TARGVAL1 to its' value. If the operand is a register, * 12900 '* sets TARVAL2 to its' val2. If an offset appears, * 12910 '* NEEDOFFSET gets the its' type, and OFFSET its' value. * 12920 '********************************************************* 12930 ' 12940 'any operand? 12950 IF LEN(TARGET$) > 0 THEN 12980 12960 TARGTYPE = NONE 12970 RETURN 12980 'in sym table? 12990 GOSUB 12030 'operand_lookup 13000 IF NOT FOUND THEN 13050 13010 TARGTYPE = SYMTYPE(TABLEPTR) 13020 TARGVAL1 = VAL1(TABLEPTR) 13030 IF TABLEPTR <= PREDEF THEN TARGVAL2 = VAL2(TABLEPTR) 13040 RETURN 13050 'number? 13060 GOSUB 13440 'test_number 13070 IF NOT FOUND THEN 13110 13080 TARGTYPE = NUMTYPE 13090 TARGVAL1 = NUMVAL 13100 RETURN 13110 'direct mem. ref.? 13120 GOSUB 13820 'memref 13130 IF NOT FOUND THEN 13170 13140 TARGTYPE = MEM 13150 TARGVAL1 = MEMADDR 13160 RETURN 13170 'offset off register? 13180 GOSUB 14180 'parse_disp_off_reg 13190 IF NOT FOUND THEN 13240 13200 TARGTYPE = MEMREG 13210 TARGVAL1 = REGVAL 13220 RETURN 13230 'offset? 13240 GOSUB 14750 'offset 13250 IF NOT FOUND THEN 13290 13260 TARGTYPE = OFFSETYPE 13270 TARGVAL1 = OFFSETVAL 13280 RETURN 13290 'charactor? 13300 GOSUB 15050 13310 IF NOT FOUND THEN 13350 13320 TARGTYPE = IMMED8 OR IMMED16 13330 TARGVAL1 = CHARVAL 13340 RETURN 13350 'string? 13360 IF LEFT$(TARGET$,1) <> "'" THEN 13400 13370 TARGTYPE = STRING 13380 RETURN 13390 ' 13400 'not found? assume near label or mem ref. (error on pass 2) 13410 IF PASS = 2 THEN PRINT#2,"****Error: Undefined symbol ";TARGET$: ERRS = ERRS + 1 13420 TARGTYPE = NEAR OR MEM 13430 RETURN 13440 '******************************************* 13450 '* SUBROUTINE TEST_NUMBER * 13460 '* Trys to interpret TARGET$ as a number. * 13470 '* If sucessful, sets FOUND true, NUMVAL * 13480 '* to its' value and NUMTYPE to its' type. * 13490 '******************************************* 13500 ' 13510 FOUND = FALSE 13520 TN$ = TARGET$ 'working copy 13530 ' 13540 'hex number? 13550 IF RIGHT$(TN$,1) <> "H" THEN 13690 13560 'lop off H 13570 TN$ = LEFT$(TN$,LEN(TN$)-1) 13580 'scan for non-hex digits (exit) 13590 I = 1 13600 FOR I = 1 TO LEN(TN$) 13610 C$ = MID$(TN$,I,1) 13620 IF INSTR("0123456789ABCDEF",C$) = 0 THEN RETURN 13630 NEXT I 13640 'get value 13650 NUMVAL = VAL("&H" + TN$) 13660 'set type, return 13670 GOTO 13780 13680 ' 13690 'decimal number? 13700 'scan for non-dec digits (exit) 13710 FOR I = 1 TO LEN(TN$) 13720 C$ = MID$(TN$,I,1) 13730 IF INSTR("0123456789-+",C$) = 0 THEN RETURN 13740 NEXT I 13750 'get value 13760 NUMVAL = VAL(TN$) 13770 ' 13780 'sucess exit 13790 FOUND = TRUE 13800 IF LEN(HEX$(NUMVAL)) < 3 THEN NUMTYPE = IMMED16 OR IMMED8 ELSE NUMTYPE = IMMED16 13810 RETURN 13820 '******************************************** 13830 '* SUBROUTINE MEMREF * 13840 '* Trys to interpret target$ as a direct * 13850 '* mem ref. If sucessful, sets FOUND true, * 13860 '* & MEMADDR to the address referanced. * 13870 '******************************************** 13880 ' 13890 MR$ = TARGET$ 'save copy 13900 ' 13910 'brackets? 13920 IF LEFT$(MR$,1) <> "[" OR RIGHT$(MR$,1) <> "]" THEN RETURN 13930 ' 13940 'strip off brackets 13950 TARGET$ = MID$(MR$,2,LEN(MR$)-2) 13960 'try to interpret as addr. 13970 'might be number 13980 GOSUB 13440 'test_number 13990 IF NOT FOUND THEN 14030 14000 MEMADDR = NUMVAL 14010 GOTO 14150 'exit 14020 ' 14030 'or might be symbol 14040 GOSUB 12030 'operand_lookup 14050 IF NOT FOUND THEN 14100 14060 IF (SYMTYPE(TABLEPTR) AND IMMED16) = FALSE THEN 14100 14070 MEMADDR = VAL1(TABLEPTR) 14080 GOTO 14150 'exit 14090 ' 14100 'failure exit 14110 FOUND = FALSE 14120 TARGET$ = MR$ 14130 RETURN 14140 ' 14150 'sucessful exit 14160 TARGET$ = MR$ 14170 RETURN 14180 '***************************************************** 14190 '* SUBROUTINE PARSE_DISP_OFF_REG * 14200 '* Trys to parse TARGET$ as an offset off a register * 14210 '* If sucessful, sets FOUND true, sets NEEDOFFSET * 14220 '* to the offset's type, and OFFSET to it's value . * 14230 '***************************************************** 14240 ' 14250 PDOR$ = TARGET$ 'save copy 14260 ' 14270 'special case 14280 IF TARGET$ = "[BP]" THEN REGVAL = 6: NEEDOFFSET = IMMED8: OFFSET = 0: GOTO 14670 14290 ' 14300 'parse reg spec. 14310 'set ptr to candidate 14320 PTR = INSTR(TARGET$,"[") 14330 IF PTR <= 1 THEN 14710 'no disp, exit 14340 'isolate candidate 14350 REG$ = RIGHT$(PDOR$,LEN(PDOR$)-PTR+1) 14360 'valid reg. spec? 14370 IF REG$ = "[BP]" THEN REGVAL = 6: GOTO 14440 14380 TARGET$ = REG$ 14390 GOSUB 12030 'operand_lookup 14400 IF NOT FOUND OR SYMTYPE(TABLEPTR) <> MEMREG THEN 14710 14410 'save reg value 14420 REGVAL = VAL1(TABLEPTR) 14430 ' 14440 'now parse disp. 14450 'isolate candidate 14460 DISP$ = LEFT$(PDOR$,PTR-1) 14470 'valid disp? 14480 TARGET$ = DISP$ 14490 'might be symbol 14500 GOSUB 12030 'operand_lookup 14510 IF NOT FOUND THEN 14560 'not sym 14520 IF (SYMTYPE(TABLEPTR) AND (IMMED16 OR IMMED8)) = FALSE THEN 14560 14530 NEEDOFFSET = SYMTYPE(TABLEPTR) 14540 OFFSET = VAL1(TABLEPTR) 14550 GOTO 14670 14560 'or number 14570 GOSUB 13440 'test_number 14580 IF NOT FOUND THEN 14620 14590 NEEDOFFSET = NUMTYPE 14600 OFFSET = NUMVAL 14610 GOTO 14670 14620 'or offset 14630 GOSUB 14750 'offset 14640 IF NOT FOUND THEN 14710 14650 NEEDOFFSET = OFFSETYPE 14660 OFFSET = OFFSETVAL 14670 'sucess exit 14680 TARGET$ = PDOR$ 14690 FOUND = TRUE 14700 RETURN 14710 'failure exit 14720 TARGET$ = PDOR$ 14730 FOUND = FALSE 14740 RETURN 14750 '*************************************************** 14760 '* SUBROUTINE OFFSET * 14770 '* Trys to interpret TARGET$ as an offset operand. * 14780 '* If sucessful, set FOUND, set OFFSETYPE * 14790 '* immed16, and TARGVAL1 to the label's offset. * 14800 '*************************************************** 14810 ' 14820 OS$ = TARGET$ 14830 ' 14840 IF LEFT$(OS$,7) <> "OFFSET(" THEN FOUND = FALSE: RETURN 14850 IF PASS = 1 THEN 15010 14860 ' 14870 'isolate label 14880 TARGET$ = MID$(TARGET$,8,LEN(TARGET$)-8) 14890 ' 14900 'look it up 14910 GOSUB 12030 'operand_lookup 14920 ' 14930 IF FOUND AND (SYMTYPE(TABLEPTR) AND (MEM OR NEAR)) THEN 14990 14940 ERRS = ERRS + 1 14950 PRINT#2, "****Error: Illegal or undefined argument for Offset" 14960 OFFSETVAL = 0 14970 GOTO 15010 14980 ' 14990 OFFSETVAL = VAL1(TABLEPTR) 15000 ' 15010 FOUND = TRUE 15020 OFFSETYPE = IMMED16 15030 TARGET$ = OS$ 15040 RETURN 15050 '*************************************** 15060 '* SUBROUTINE CHAR * 15070 '* Trys to interpret TARGET$ as a char * 15080 '*************************************** 15090 FOUND = FALSE 15100 IF LEN(TARGET$) <> 3 THEN RETURN 15110 IF LEFT$(TARGET$,1) <> "'" THEN RETURN 15120 IF RIGHT$(TARGET$,1) <> "'" THEN RETURN 15130 FOUND = TRUE 15140 CHARVAL = ASC(MID$(TARGET$,2,1)) 15150 RETURN 15160 '************************************* 15170 '* SUBROUTINE MACHOP * 15180 '* Updates loctr based on op length. * 15190 '* On pass 2, generates obj. code. * 15200 '************************************* 15210 ' 15220 GOSUB 15800 'op_type 15230 ' 15240 'opcode 15250 LOCTR = LOCTR + 1 15260 IF PASS = 2 THEN GOSUB 16060 'build_opcode 15270 ' 15280 '2nd op byte? 15290 IF (OPVAL(OPPTR) <> &HD5) AND (OPVAL(OPPTR) <> &HD4) THEN 15330 15300 LOCTR = LOCTR + 1 15310 IF PASS = 2 THEN OBJLEN = OBJLEN + 1: OBJ(OBJLEN) = &HA 15320 ' 15330 'room for m. byte disp. (must go here, modebyte modifys offset) 15340 IF NEEDOFFSET = NONE THEN 15370 15350 IF (NEEDOFFSET AND IMMED8) THEN LOCTR = LOCTR + 1 ELSE LOCTR = LOCTR + 2 15360 ' 15370 'if direct addr. mode byte, leave room for address 15380 IF (FLAG AND (NEEDMODEBYTE OR NEEDEXT)) = FALSE THEN 15410 15390 IF (DTYPE OR STYPE) AND MEM THEN LOCTR = LOCTR + 2 15400 ' 15410 'extension byte? 15420 IF (FLAG AND NEEDEXT) = FALSE THEN 15460 15430 LOCTR = LOCTR + 1 15440 IF PASS = 2 THEN GOSUB 16320 'build_ext 15450 ' 15460 'mode byte? 15470 IF (FLAG AND NEEDMODEBYTE) = FALSE THEN 15510 15480 LOCTR = LOCTR + 1 15490 IF PASS = 2 THEN GOSUB 16460 'build_modebyte 15500 ' 15510 '8 bit disp.? 15520 IF (FLAG AND NEEDISP8) = FALSE THEN 15560 15530 LOCTR = LOCTR + 1 15540 IF PASS = 2 THEN GOSUB 16990 'build_disp8 15550 ' 15560 '16 bit disp.? 15570 IF (FLAG AND NEEDISP16) = FALSE THEN 15610 15580 LOCTR = LOCTR + 2 15590 IF PASS = 2 THEN GOSUB 17210 'build_disp16 15600 ' 15610 'immediate byte? 15620 IF (FLAG AND NEEDIMMED8) = FALSE THEN 15650 15630 LOCTR = LOCTR + 1 15640 IF PASS = 2 THEN GOSUB 17570 15650 IF WORD OR ((FLAG AND NEEDIMMED) = FALSE) THEN 15690 15660 LOCTR = LOCTR + 1 15670 IF PASS = 2 THEN GOSUB 17570 'build_immed8 15680 ' 15690 'immediate word(s)? 15700 IF NOT(WORD) OR ((FLAG AND NEEDIMMED) = FALSE) THEN 15740 15710 IF DTYPE = IMMED16 THEN LOCTR = LOCTR + 4 ELSE LOCTR = LOCTR + 2 15720 IF PASS = 2 THEN GOSUB 17430 'build_immed16 15730 ' 15740 'mem. addr.? 15750 IF (FLAG AND NEEDMEM) = FALSE THEN 15790 15760 LOCTR = LOCTR + 2 15770 IF PASS = 2 THEN GOSUB 17730 'mem_addr 15780 ' 15790 RETURN 15800 '************************************ 15810 '* SUBROUTINE OP_TYPE * 15820 '* Decides between word & byte ops. * 15830 '************************************ 15840 ' 15850 IF (DTYPE OR STYPE) AND (REG16 OR ACUM16 OR SEG OR CS) THEN 15900 15860 IF (DTYPE OR STYPE) AND (REG8 OR ACUM8) THEN 15940 15870 ' 15880 IF RIGHT$(OP$,1) = "B" THEN 15940 15890 ' 15900 'word 15910 WORD = TRUE 15920 RETURN 15930 ' 15940 'byte 15950 WORD = FALSE 15960 RETURN 15970 '********************************************** 15980 '* SUBROUTINE PSEUDO-OP * 15990 '* Branches to routines to handle each pseudo * 16000 '* op using the value field as an index. * 16010 '********************************************** 16020 ' 16030 ON OPVAL(OPPTR) GOSUB 17860, 18050, 18130, 18510, 18740, 18890 16040 ' EQU ORG DB DS PROC ENDP 16050 RETURN 16060 '********************************************************** 16070 '* SUBROUTINE BUILD_OPCODE * 16080 '* Builds opcode, stores it in obj. Increments objlength. * 16090 '********************************************************** 16100 ' 16110 OBJLEN = OBJLEN + 1 16120 OBJ(OBJLEN) = OPVAL(OPPTR) 16130 ' 16140 'add reg. field if requested 16150 IF (FLAG AND ADDREG) = FALSE THEN 16230 16160 'segment reg. 16170 IF DTYPE AND (SEG OR CS) THEN R = DVAL2: GOTO 16210 16180 'normal reg. 16190 IF (FLAG AND DIRECTION) THEN R = SVAL2/8 ELSE R = DVAL2/8 16200 ' 16210 OBJ(OBJLEN) = OBJ(OBJLEN) + R 16220 ' 16230 'auto word bit? 16240 IF (FLAG AND AUTOW) = FALSE THEN 16270 16250 IF WORD THEN OBJ(OBJLEN) = OBJ(OBJLEN) + 1 16260 ' 16270 'auto count bit? 16280 IF (FLAG AND AUTOC) = FALSE THEN 16310 16290 IF STYPE AND CL THEN OBJ(OBJLEN) = OBJ(OBJLEN) + 2 16300 ' 16310 RETURN 16320 '************************************************** 16330 '* SUBROUTINE BUILD_EXTENSION_BYTE * 16340 '* Builds an opcode extension byte. The ext. val * 16350 '* is extracted from bits 3-5 of the flag word. * 16360 '************************************************** 16370 ' 16380 'get ext. 16390 MASK = &H38 16400 EXT = FLAG AND MASK 16410 ' 16420 'define proper operand as ext. & build mode byte 16430 IF FLAG AND DIRECTION THEN DVAL2 = EXT ELSE SVAL2 = EXT 16440 GOSUB 16460 'build_modebyte 16450 RETURN 16460 '*************************************************************** 16470 '* SUBROUTINE BUILD_MODE_BYTE * 16480 '* Given direction flag, memreg values in dval1 and sval1 and * 16490 '* reg values in dval2 and sval2, builds an addressing mode * 16500 '* byte. If necessary, also builds displacement byte(s). * 16510 '*************************************************************** 16520 ' 16530 OBJLEN = OBJLEN + 1 16540 ' 16550 'special case: direct mem. addressing? 16560 IF ((DTYPE OR STYPE) AND MEM) = FALSE THEN 16630 16570 IF DTYPE = MEM THEN M = SVAL2 ELSE M = DVAL2 16580 OBJ(OBJLEN) = 6 + M 16590 GOSUB 17730 'build_mem_addr 16600 RETURN 16610 ' 16620 'normal mode byte 16630 'operands in normal or reverse order? 16640 IF FLAG AND DIRECTION THEN M = SVAL1 + DVAL2 ELSE M = DVAL1 + SVAL2 16650 ' 16660 OBJ(OBJLEN) = M 16670 ' 16680 'offset byte(s)? 16690 ' 16700 IF NEEDOFFSET = NONE THEN 16880 16710 ' 16720 '8 bit disp. 16730 IF OFFSET > 127 OR OFFSET < -128 THEN 16810 16740 OBJ(OBJLEN) = OBJ(OBJLEN) + 64 'set mod field 16750 'crunch neg. offset to 8 bits 16760 IF OFFSET < 0 THEN OFFSET = OFFSET AND &HFF 16770 OBJLEN = OBJLEN + 1 16780 OBJ(OBJLEN) = OFFSET 16790 RETURN 16800 ' 16810 '16 bit disp. 16820 OBJ(OBJLEN) = OBJ(OBJLEN) + 128 'set mod field 16830 OBJLEN = OBJLEN + 2 16840 'convert to hi/low form 16850 NUMLOW = OFFSET: GOSUB 16890 'hi/low 16860 OBJ(OBJLEN-1) = NUMLOW 16870 OBJ(OBJLEN) = NUMHIGH 16880 RETURN 16890 '************************************************ 16900 '* SUBROUTINE HI/LOW * 16910 '* Splits 16 bit number in numlow, into two * 16920 '* byte-sized componants in numhigh and numlow. * 16930 '************************************************ 16940 H$ = HEX$(NUMLOW) 16950 H$ = STRING$(4-LEN(H$),"0") + H$ 16960 NUMLOW = VAL("&H" + RIGHT$(H$,2)) 16970 NUMHIGH = VAL("&H" + LEFT$(H$,2)) 16980 RETURN 16990 '********************************************* 17000 '* SUBROUTINE BUILD_DISP8 * 17010 '* Calculates the disp. from the present * 17020 '* loc to the loc given as an operand. * 17030 '* Prints error message if disp. exceeds 127.* 17040 '********************************************* 17050 ' 17060 'calculate disp. 17070 D = DVAL1 - LOCTR 17080 ' 17090 'check size 17100 IF ABS(D) < 128 THEN 17140 17110 D = 0 17120 IF PASS = 2 THEN PRINT#2,"****Error: Too far for short jump": ERRS = ERRS + 1 17130 ' 17140 'if neg. crunch to 8 bits 17150 IF D < 0 THEN D = D AND &HFF 17160 ' 17170 'build obj. code 17180 OBJLEN = OBJLEN + 1 17190 OBJ(OBJLEN) = D 17200 RETURN 17210 '******************************************** 17220 '* SUBROUTINE BUILD_DISP16 * 17230 '* Builds 16 bit displacement. Prints error * 17240 '* msg. for negative disps not on CALL ops. * 17250 '******************************************** 17260 ' 17270 'calculate disp. 17280 D = DVAL1 - LOCTR 17290 ' 17300 IF OP$ = "JMP" AND D<=128 THEN PRINT#2, "****Diagnostic: Could use JMPS" : DIAG = DIAG + 1 17310 ' 17320 'legal? 17330 IF D >= 0 OR OP$ = "CALL" THEN 17370 17340 D = 0 17350 IF PASS = 2 THEN PRINT#2,"****Error: Illegal reverse long jump": ERRS = ERRS + 1 17360 ' 17370 'build obj. code 17380 NUMLOW = D: GOSUB 16890 'hi/low 17390 OBJLEN = OBJLEN + 2 17400 OBJ(OBJLEN-1) = NUMLOW 17410 OBJ(OBJLEN) = NUMHIGH 17420 RETURN 17430 '************************************ 17440 '* SUBROUTINE BUILD_IMMED16 * 17450 '* Builds word(s) of immediate data * 17460 '************************************ 17470 ' 17480 IF DTYPE AND IMMED16 THEN IVAL = DVAL1: GOSUB 17510 17490 IF STYPE AND IMMED16 THEN IVAL = SVAL1: GOSUB 17510 17500 RETURN 17510 'internal subroutine immed16 17520 NUMLOW = IVAL: GOSUB 16890 'hi/low 17530 OBJLEN = OBJLEN + 2 17540 OBJ(OBJLEN-1) = NUMLOW 17550 OBJ(OBJLEN) = NUMHIGH 17560 RETURN 17570 '********************************** 17580 '* SUBROUTINE BUILD_IMMED8 * 17590 '* Builds byte of immediate data. * 17600 '********************************** 17610 ' 17620 IF DTYPE AND IMMED8 THEN IVAL = DVAL1: GOSUB 17650 17630 IF STYPE AND IMMED8 THEN IVAL = SVAL1: GOSUB 17650 17640 RETURN 17650 'int. sub. immed8 17660 IF IVAL <= 255 AND IVAL >= 0 THEN 17700 17670 IVAL = 0 17680 IF PASS = 2 THEN ERRS = ERRS + 1: PRINT#2,"****Error: Data too long" 17690 ' 17700 OBJLEN = OBJLEN + 1 17710 OBJ(OBJLEN) = IVAL 17720 RETURN 17730 '********************************* 17740 '* SUBROUTINE MEMREF * 17750 '* Builds a memory address word. * 17760 '********************************* 17770 ' 17780 'get addr. in hi/low form 17790 IF DTYPE = MEM THEN NUMLOW = DVAL1 ELSE NUMLOW = SVAL1 17800 GOSUB 16890 17810 'build word 17820 OBJLEN = OBJLEN + 2 17830 OBJ(OBJLEN-1) = NUMLOW 17840 OBJ(OBJLEN) = NUMHIGH 17850 RETURN 17860 '*************************** 17870 '* SUBROUTINE EQU * 17880 '* Handles equ pseudo-op. * 17890 '*************************** 17900 ' 17910 IF (LABEL$ <> "") THEN 17950 17920 IF PASS = 2 THEN ERRS = ERRS+1: PRINT#2,"****Error: EQU without symbol" 17930 RETURN 17940 ' 17950 IF PASS = 2 THEN 18040 17960 ' 17970 IF DTYPE <> (NEAR OR MEM) THEN 18020 'pass 1 default if not found 17980 ERRS = ERRS + 1 17990 PRINT#2, "****Error: EQU with forward referance in ";LINENUM 18000 RETURN 18010 ' 18020 VAL1(NUMSYM) = DVAL1 18030 SYMTYPE(NUMSYM) = DTYPE 18040 RETURN 18050 '************************** 18060 '* SUBROUTINE ORG * 18070 '* Handles org pseudo-op. * 18080 '************************** 18090 ' 18100 'set loctr to new value 18110 LOCTR = DVAL1 18120 RETURN 18130 '************************* 18140 '* SUBROUTINE DB * 18150 '* Handles db pseudo-op. * 18160 '************************* 18170 ' 18180 'label? set type to mem 18190 IF LABEL$ <> "" THEN SYMTYPE(NUMSYM) = MEM 18200 ' 18210 'scan operand area, building obj. code 18220 LINEPTR = OPDPTR: LINEPTR2 = OPDPTR 18230 WHILE LINEPTR < ENDPTR 18240 'get operand 18250 GOSUB 11270 'get_field 18260 IF NOT FOUND THEN 18380 'exit 18270 'branch for byte value or string 18280 TARGET$ = FLD$: GOSUB 13440 'test_number 18290 IF NOT FOUND OR (NUMTYPE AND IMMED8) = FALSE THEN 18320 18300 GOSUB 18400 'build_byte 18310 GOTO 18370 18320 IF LEFT$(FLD$,1) <> "'" THEN 18350 18330 GOSUB 18440 'build_stg 18340 GOTO 18370 18350 'if not byte or string, error on pass 2 18360 IF PASS = 2 THEN PRINT#2,"****Error: unrecognized operand ";FLD$: ERRS = ERRS + 1 18370 WEND 18380 LOCTR = LOCTR + OBJLEN 18390 RETURN 18400 'subroutine build_byte 18410 OBJLEN = OBJLEN + 1 18420 OBJ(OBJLEN) = NUMVAL 18430 RETURN 18440 'subroutine build_stg 18450 FLD$ = MID$(FLD$,2,LEN(FLD$)-2) 'strip off 's 18460 FOR I = 1 TO LEN(FLD$) 18470 OBJLEN = OBJLEN + 1 18480 OBJ(OBJLEN) = ASC(MID$(FLD$,I,1)) 18490 NEXT I 18500 RETURN 18510 '************************* 18520 '* SUBROUTINE DS * 18530 '* Handles ds pseudo-op. * 18540 '************************* 18550 ' 18560 DSFLAG = TRUE 'signal this is a ds 18570 ' 18580 'label? set type to mem 18590 IF LABEL$ <> "" THEN SYMTYPE(NUMSYM) = MEM 18600 ' 18610 'set output code 18620 IF STYPE AND IMMED8 THEN DSVAL = SVAL1 ELSE DSVAL = 0 18630 ' 18640 'on pass 2, generate obj. code directly 18650 IF PASS = 1 THEN 18700 18660 FOR I = 1 TO DVAL1 18670 LSET BYTE$ = CHR$(DSVAL): PUT #3 18680 NEXT I 18690 ' 18700 'advance loctr 18710 LOCTR = LOCTR + DVAL1 18720 ' 18730 RETURN 18740 '*************************** 18750 '* SUBROUTINE PROC * 18760 '* Handles proc pseudo-op. * 18770 '*************************** 18780 ' 18790 IF STKTOP < MAXSTK THEN 18850 18800 IF PASS = 1 THEN 18830 18810 ERRS = ERRS + 1 18820 PRINT#2, "****Error: Procedures nested too deeply" 18830 RETURN 18840 ' 18850 'push new proc type for returns 18860 STKTOP = STKTOP + 1 18870 PROCTYPE(STKTOP) = DTYPE 18880 RETURN 18890 '******************** 18900 '* SUBROUTINE ENDP * 18910 '* Pops proc stack. * 18920 '******************** 18930 ' 18940 IF STKTOP > 0 THEN 19000 18950 IF PASS = 1 THEN 18980 18960 ERRS = ERRS + 1 18970 PRINT#2, "****Error: ENDP without PROC" 18980 RETURN 18990 ' 19000 STKTOP = STKTOP - 1 19010 RETURN 19020 '************************************ 19030 '* SUBROUTINE OUTPUT * 19040 '* Outputs obj code & listing line, * 19050 '* given code in obj(objlength). * 19060 '************************************ 19070 ' 19080 IF DSFLAG THEN H$ = HEX$(LOCTR-DVAL1) ELSE H$ = HEX$(LOCTR-OBJLEN) 19090 H$ = STRING$(4-LEN(H$),"0") + H$ 19100 PRINT#2, TAB(1) H$; 19110 'first 6 bytes 19120 I = 1 19130 PRINT#2, TAB(6) 19140 WHILE I <= 6 19150 IF I > OBJLEN THEN 19220 19160 LSET BYTE$ = CHR$(OBJ(I)): PUT #3 19170 H$ = HEX$(OBJ(I)): IF LEN(H$) = 1 THEN H$ = "0" + H$ 19180 PRINT#2, H$; 19190 I = I + 1 19200 WEND 19210 ' 19220 'source (truncate if necessary) 19230 PRINT#2, TAB(19) 19240 PRINT#2, USING "####"; LINENUM; 19250 PRINT#2, SPACE$(2) LEFT$(INPLINE$, LWIDTH-26) 19260 ' 19270 'rest of obj. code 19280 WHILE I <= OBJLEN 19290 IF I MOD 6 = 1 THEN PRINT#2, TAB(6) 19300 LSET BYTE$ = CHR$(OBJ(I)): PUT #3 19310 H$ = HEX$(OBJ(I)): IF LEN(H$) = 1 THEN H$ = "0" + H$ 19320 PRINT#2, H$; 19330 I = I + 1 19340 WEND 19350 IF OBJLEN > 6 THEN PRINT#2, 19360 RETURN 19370 '*************************** 19380 '* SUBROUTINE PASSTWO_INIT * 19390 '*************************** 19400 ' 19410 'reset input file 19420 CLOSE #1: OPEN SC$ FOR INPUT AS #1 19430 ' 19440 PASS = 2 19450 LOCTR = 256 19460 LINENUM = 0 19470 ' 19480 RETURN 19490 '************************ 19500 '* SUBROUTINE FINALPROC * 19510 '* Cleanup * 19520 '************************ 19530 ' 19540 IF STKTOP > 0 THEN ERRS = ERRS + 1: PRINT#2,"****Error: missing ENDP" 19550 ' 19560 PRINT#2,: PRINT#2,: PRINT#2, ERRS; "Error(s) detected" 19570 PRINT#2, DIAG; "Diagnostic(s) offered" 19580 'dump sym table 19590 GOSUB 19690 19600 'return printer to normal 19610 IF L$ = "lpt1:" THEN PRINT#2, PMODEOFF$ 19620 'hang onto screen listing 19630 IF L$ <> "scrn:" THEN 19680 19640 PRINT: BEEP: COLOR 0,7 19650 PRINT TAB(30) "Hit any key to exit" TAB(79); 19660 C$ = INKEY$: IF C$ = "" THEN 19660 19670 COLOR 7,0 19680 RETURN 19690 '***************************** 19700 '* SUBROUTINE DUMP_SYM_TABLE * 19710 '***************************** 19720 ' 19730 PRINT#2,: PRINT#2, "SYMBOL TABLE DUMP:" 19740 I = PREDEF + 1 19750 F$ = "\ \!\ \\ \" 'format 19760 PERLINE = LWIDTH \ LEN(F$) 19770 WHILE I <= NUMSYM 19780 H$ = HEX$(VAL1(I)): H$ = STRING$(4-LEN(H$),"0") + H$ 19790 PRINT#2, USING F$; SYM$(I); " "; H$; " "; 19800 I = I + 1 19810 IF (I-PREDEF) MOD PERLINE = 1 THEN PRINT#2, 19820 WEND 19830 PRINT#2, 19840 RETURN 19850 '************************************* 19860 '* SUBROUTINE PROGESS REPORT * 19870 '* Maintains reassuring msg. on scrn * 19880 '************************************* 19890 ' 19900 X = POS(0): Y = CSRLIN: LOCATE 25,1: COLOR 0,7 19910 IF PASS = 1 THEN PRINT "First"; ELSE PRINT "Second"; 19920 PRINT " pass in progress. Lines processed = "; LINENUM; 19930 PRINT TAB(79);: COLOR 7,0: LOCATE Y,X 19940 RETURN 19950 '**************************************** 19960 '* SUBROUTINE SET_UP_SYMBOL_TABLE * 19970 '* Sets up sym table, & opens obj. file * 19980 '**************************************** 19990 ' 20000 INPUT#3, PREDEF, MAXSYM: LINE INPUT#3, C$: LINE INPUT#3, C$ 20010 DIM SYM$(MAXSYM), VAL1(MAXSYM), VAL2(PREDEF), SYMTYPE(MAXSYM) 20020 ' 20030 FOR I = 1 TO PREDEF '# of pre-defined syms 20040 INPUT#3, SYM$(I), VAL1(I), VAL2(I), SYMTYPE(I) 20050 NEXT I 20060 NUMSYM = PREDEF 20070 ' 20080 CLOSE #3 20090 OPEN O$ AS #3 LEN=1: FIELD #3,1 AS BYTE$ 20100 RETURN 50000 '********************************** 50010 '* SUBROUTINE INIT * 50020 '* Initializes all but sym table. * 50030 '********************************** 50040 ' 50050 DEFINT A-Z 50060 ERRS = 0: DIAG = 0 50070 ' 50080 'title page 50090 GOSUB 50190 50100 'define constants 50110 GOSUB 50450 50120 'open files 50130 GOSUB 50660 50140 'op table 50150 GOSUB 51190 50160 'listing header 50170 GOSUB 51350 50180 RETURN 50190 '************************************************* 50200 '* SUBROUTINE TITLE * 50210 '* Prints title page, & waits for user response. * 50220 '************************************************* 50230 ' 50240 SCREEN 0,0,0: WIDTH 80: KEY OFF: CLS: LOCATE 24,1,0 50250 PRINT TAB(12)"KEY";STRING$(56,"THEN");"CLOSE 50260 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50270 PRINT TAB(12)"OPEN"TAB(32)"CHASM version 1.9"TAB(69)"OPEN 50280 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50290 PRINT TAB(12)"OPEN"TAB(25)"Cheap Assembler for the IBM PC"TAB(69)"OPEN 50300 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50310 PRINT TAB(12)"OPEN If you have used this program and found it of OPEN 50320 PRINT TAB(12)"OPEN value, your $20 contribution will be appreciated. OPEN 50330 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50340 PRINT TAB(12)"OPEN"TAB(29)"David Whitman"TAB(69)"OPEN 50350 PRINT TAB(12)"OPEN"TAB(29)"Dept. of Chemistry"TAB(69)"OPEN 50360 PRINT TAB(12)"OPEN"TAB(29)"Dartmouth College"TAB(69)"OPEN 50370 PRINT TAB(12)"OPEN"TAB(29)"Hanover, NH 03755"TAB(69)"OPEN 50380 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50390 PRINT TAB(12)"OPEN You are encouraged to copy and share this program. OPEN 50400 PRINT TAB(12)"OPEN"TAB(69)"OPEN 50410 PRINT TAB(12) "SCREEN";STRING$(56,"THEN");"LOAD":PRINT 50420 PRINT TAB(27) "Hit any key to continue...":PRINT:PRINT 50430 I$ = INKEY$: IF I$ = "" THEN 50430 50440 CLS: RETURN 50450 '**************************** 50460 '* SUBROUTINE SET_CONSTANTS * 50470 '**************************** 50480 'general 50490 TRUE = -1: FALSE = 0 50500 ' 50510 'flag values 50520 'bits 3-5 reserved for ext. values 50530 MACHOP = 1: AUTOW = 4: ADDREG = 64: NEEDEXT = 128 50540 NEEDISP8 = 256: NEEDISP16 = 512: NEEDMODEBYTE = 1024: NEEDIMMED8 = 2048 50550 NEEDIMMED = 4096: DIRECTION = 8192: NEEDMEM = 16384: AUTOC = &H8000 50560 ' 50570 'operand types 50580 ACUM8 = 1: ACUM16 = 2: REG8 = 4: REG16 = 8: MEMREG = 16: CS = 32 50590 SEG = 64: MEM = 128: IMMED8 = 256: IMMED16 = 512: NONE = 1024 50600 STRING = 2048: NEAR = 4096: FAR = 8192: CL = 16384 50610 ' 50620 'arrays 50630 MAXOBJ = 50: DIM OBJ(MAXOBJ) 50640 MAXSTK = 10: DIM PROCTYPE(MAXSTK): STKTOP = 0 50650 RETURN 50660 '***************************************************** 50670 '* SUBROUTINE OPEN_FILES * 50680 '* Prompts user for i/o filenames, then opens files. * 50690 '***************************************************** 50700 ' 50710 ON ERROR GOTO 51000 50720 ' 50730 'input file 50740 LOCATE 1,1: INPUT"Source code file name? [.asm] ", S$ 50750 IF S$ = "" THEN BEEP: GOTO 50740 50760 'if no extension, add default 50770 IF INSTR(S$,".") = 0 THEN SC$ = S$ + ".asm" ELSE SC$ = S$: S$ = LEFT$(S$,INSTR(S$,".")-1) 50780 OPEN SC$ FOR INPUT AS #1 50790 LOCATE 3,1 50800 INPUT"Direct listing to Printer (P), Screen (S), or Disk (D)?",L$ 50810 IF L$ = "" THEN BEEP: GOTO 50790 50820 IF INSTR("PpSsDd",L$) = 0 THEN BEEP: GOTO 50790 'invalid response 50830 IF L$ = "P" OR L$ = "p" THEN L$ = "lpt1:" : GOTO 50890 'printer? 50840 IF L$ = "S" OR L$ = "s" THEN L$ = "scrn:" : GOTO 50890 'screen? 50850 LOCATE 3,1: PRINT SPACE$(79);: LOCATE 3,1 50860 PRINT"Name for listing file? [";S$;".lst] "; 50870 INPUT "",L$ 50880 IF L$ = "" THEN L$ = S$ + ".lst" 'default to source name 50890 OPEN L$ FOR OUTPUT AS #2 50900 PRINT#2, 'test listing device 50910 'object file 50920 LOCATE 5,1: PRINT "Name for object file? [";S$;".com] "; 50930 INPUT "",O$ 50940 'default to source file name.com 50950 IF O$ = "" THEN O$ = S$ + ".com" 50960 'will open after symtable setup 50970 ON ERROR GOTO 0 'kill error trapping 50980 PRINT: PRINT: PRINT 50990 RETURN 51000 '**************** 51010 '*Error Handler * 51020 '**************** 51030 ' 51040 IF ERR <> 53 THEN 51120 51050 COLOR 0,7: BEEP 51060 PRINT SC$; " not found. Press Esc to exit, anything else to continue."; 51070 SC$ = INKEY$: IF SC$ = "" THEN 51070 51080 IF SC$ = CHR$(27) THEN SYSTEM 51090 LOCATE ,1: COLOR 7,0: PRINT SPACE$(79); 51100 LOCATE 1,31: PRINT SPACE$(48); : LOCATE ,1: RESUME 50740 51110 ' 51120 IF ERR <> 27 THEN 51180 51130 CLOSE #2: COLOR 0,7: BEEP 51140 PRINT"Printer not available. Press any key to continue."; 51150 L$ = INKEY$ : IF L$ = "" THEN 51150 51160 LOCATE ,1: COLOR 7,0: PRINT SPACE$(79); 51170 LOCATE 3,56: PRINT SPACE$(23);: LOCATE ,1: RESUME 50800 51180 ON ERROR GOTO 0 51190 '*********************** 51200 '* SUBROUTINE OP_TABLE * 51210 '*********************** 51220 ' 51230 OPEN "chasm.dat" FOR INPUT AS #3 51240 'note: c$ used to skip data comments 51250 ' 51260 INPUT#3, NUMOP: LINE INPUT#3,C$: LINE INPUT#3, C$ 51270 DIM OPCODE$(NUMOP), OPVAL(NUMOP), SRCTYPE(NUMOP) 51280 DIM DSTTYPE(NUMOP), OFLAG(NUMOP) 51290 ' 51300 FOR I = 1 TO NUMOP 51310 INPUT#3, OPCODE$(I),OPVAL(I),DSTTYPE(I),SRCTYPE(I),OFLAG(I) 51320 LINE INPUT#3, C$ 51330 NEXT I 51340 RETURN 51350 '************************* 51360 '* SUBROUTINE HEADER * 51370 '* Prints listing header.* 51380 '************************* 51390 ' 51400 LWIDTH = 79 'default width 51410 ' 51420 'title & date 51430 D$ = LEFT$(DATE$,2) + "/" + MID$(DATE$,4,2) + "/" + RIGHT$(DATE$,2) 51440 PRINT#2, SC$ TAB(LWIDTH-LEN(D$)) D$:PRINT#2,:PRINT#2, 51450 ' 51460 'printer set up? 51470 IF L$ <> "lpt1:" THEN 51540 51480 'for NEC 8023 printer, remove quotes for auto condensed mode 51490 'similar code may be substituted for other printers. 51500 ' LWIDTH = 131: WIDTH #2, LWIDTH + 1 51510 ' PRINT#2, CHR$(27) + "Q" 'pmodeon 51520 ' PMODEOFF$ = CHR$(27) + "N" 51530 ' 51540 'column headings 51550 PRINT#2,"LOC"TAB(6)"OBJ"TAB(19)"LINE"TAB(25)"SOURCE":PRINT#2, 51560 ' 51570 RETURN