--- /dev/null
+0) Index to BIF HI-LEVEL disk 2) Title page, Copr. notice 3) MONITOR CALL TO DEBUG 4) ERROR MESSAGES 6) HIGH LEVEL TOOLS & UTILITIES 7) LIST, INDEX, TRIAD 8) HIGH LEVEL DISK & SCREEN 11) FORWARD REFERENCING 12) PERIPHERAL UTILITIES 13) SLIST 15) DUMP DEFINITION BY NAME 16) ASSEMBLER 32) DOUBLES IN ASSEMBLER 40) HLL COMPILER 64) PAIR ASSOCIATION EXAMPLE 66) A TRY AT DIVIDE BY CONSTANT 100) SARDIS DMC STUFF 144) HOOCH COMPILER REMAINS BIF EDITOR, UTILITIES, ASSEMBLER, AND EXAMPLES VERSION 1.0 COPYRIGHT 1989 JOEL MATTHEW REES THESE ALGORITHMS ARE EXPRESSED IN THREE LANGUAGES: BIF, BIF ASSEMBLER FOR THE MOTOROLA M6809 MICROPROCESSOR, AND HEXADECIMAL MACHINE CODE FORTHE M6809. THE TEXT IS ORGANIZED FOR EDITING ON A 32-COLUMN TERMINAL,SUCH AS IS FOUND ON A RADIO SHACK COLOR COMPUTER 2. THESE ALGORITHMS AND THEIR TEXT ARE INTENDED FOR NO PURPOSEOTHER THAN EXPERIMENTATION, AND NO CLAIMS OR WARRANTIES ARE MADECONCERNING THEIR USEFULNESS IN ANY PARTICULAR APPLICATION. PUBLISHED 1989 JOEL MATTHEW REES SOUTH SALT LAKE CITY, UTAH ( CALL TO MONITOR, IF SWI IS BREAKPOINT JMR-88OCT?? ) CREATE MON HEX 3F C, 6EB1 , SMUDGE HERE 1- FENCE ! ;S ( ERROR MESSAGES ) DATA STACK UNDERFLOW DICTIONARY FULL ADDRESS RESOLUTION ERROR HIDES DEFINITION IN NULL VECTOR WRITTEN DISC RANGE? DATA STACK OVERFLOW DISC ERROR! CAN'T EXECUTE A NULL! CONTROL STACK UNDERFLOW CONTROL STACK OVERFLOW ARRAY REFERENCE OUT OF BOUNDS ARRAY DIMENSION NOT VALID NO PROCEDURE TO ENTER ( WAS REGISTER ) COMPILATION ONLY, USE IN DEF EXECUTION ONLY CONDITIONALS NOT PAIRED DEFINITION INCOMPLETE IN PROTECTED DICTIONARY USE ONLY WHEN LOADING OFF CURRENT EDITING SCREEN DECLARE VOCABULARY DEFINITION NOT IN VOCABULARY IN FORWARD BLOCK ALLOCATION LIST CORRUPTED: LOST CAN'T REDEFINE nul! NOT FORWARD REFERENCE ( WAS IMMEDIATE ) ( MORE ERROR MESSAGES ) HAS INCORRECT ADDRESS MODE HAS INCORRECT INDEX MODE OPERAND NOT REGISTER HAS ILLEGAL IMMEDIATE PC OFFSET MUST BE ABSOLUTE ACCUMULATOR OFFSET REQUIRED ILLEGAL MEMORY INDIRECTION ILLEGAL INDEX BASE ILLEGAL TARGET SPECIFIED CAN'T STACK ON SELF DUPLICATE IN LIST REGISTER NOT STACK EMPTY REGISTER LIST IMMEDIATE OPERAND REQUIRED REQUIRES CONDITION COMPILE-TIME STACK UNDERFLOW COMPILE-TIME STACK OVERFLOW ( UTILITIES DUMP QLIST QINDEX ) ( L/SCR ULIST JMR-88NOV16) BIF DEFINITIONS HEX ( UTILITIES IS NOW IN KERNEL ) UTILITIES DEFINITIONS : BYTE-DUMP -DUP IF 0 DO DUP I + C@ 4 .R LOOP ENDIF DROP ; ( BASE > 6) BIF DEFINITIONS : DUMP -DUP IF OVER + SWAP DO I 0 6 D.R I 4 [ UTILITIES ] BYTE-DUMP [ BIF ] 3A EMIT I 4 TYPE CR ?TERMINAL 0< IF KEY 0< IF LEAVE ENDIF ENDIF 4 +LOOP ENDIF ; : QLIST BLOCK [ EDITOR ] QDUMP [ BIF ] 500 88 ! ( CENTER ) ; : QINDEX 1+ SWAP DO I QLIST ." SCREEN=" I 4 /MOD . 3A EMIT . ." BLOCK=" I . KEY 0< IF LEAVE ENDIF LOOP ; UTILITIES DEFINITIONS : L/SCR B/BUF B/SCR C/L */ ; : ULIST ( SCREEN N, FLAG BRK ) DUP SCR ! ." SCR # " . 0 ( F ) L/SCR 0 DO CR I 3 .R SPACE I SCR @ .LINE ?TERMINAL 0< IF ( BREAK? ) KEY 0< IF 1- LEAVE ENDIF ENDIF LOOP CR ; --> ( LIST INDEX TRIAD ) ( JMR-88NOV16 ) BIF DEFINITIONS : LIST ( WIDE OUTPUT ) DECIMAL CR UTILITIES ULIST BIF DROP ; : INDEX ( PRINT COMMENT LINES ) 0C EMIT ( FORM FEED ) CR 1+ SWAP DO CR I 3 .R SPACE 0 I .LINE C/L 49 < IF 1 I .LINE ENDIF ?TERMINAL 0< IF KEY 0< IF LEAVE ENDIF ENDIF LOOP ; : TRIAD ( LIST MULTIPLE ) >PRT 0C EMIT ( FORM FEED ) [ DECIMAL ] UTILITIES L/SCR BIF 22 > IF 2 ELSE 3 ENDIF >R R / R * DUP R> + SWAP DO I UTILITIES ULIST BIF 0< IF LEAVE ENDIF UTILITIES L/SCR BIF DUP 32 = SWAP 22 = OR NOT IF CR CR ENDIF LOOP >VID ; HEX -->( HOME CLS QSAVE SAVE-BUFFERS QCAN ) ( JMR-88DEC10 ) UTILITIES DEFINITIONS HEX : HOME 400 88 ! ; : MID 500 88 ! ; BIF DEFINITIONS : CLS 400 200 60 FILL UTILITIES HOME BIF ; UTILITIES DEFINITIONS : CAN-UP ( CANCEL UPDATE IN BUF) DUP @ 7FFF AND OVER ! ; : W-BUF ( WRITE BUF AT ADR ) DUP 2+ OVER @ 7FFF AND 0 R/W CAN-UP ; : SAVE-BUF ( IF UPDATED ) DUP @ 0< IF W-BUF ENDIF ; BIF DEFINITIONS : QSAVE PREV @ ( SAVE PREVIOUS ) UTILITIES SAVE-BUF BIF DROP ; : SAVE-BUFFERS PREV @ BEGIN UTILITIES SAVE-BUF BIF +BUF NOT UNTIL DROP ; : QCAN PREV @ ( CAN UP OF PREV ) UTILITIES CAN-UP BIF DROP ; --> ( CANCEL-UPDATES RE-QUICK .PREV .BUFFERS QPREV JMR-88DEC10 ) : CANCEL-UPDATES PREV @ BEGIN UTILITIES CAN-UP BIF +BUF NOT UNTIL DROP ; : RE-QUICK ( QUICK OLD PREVIOUS) PREV @ DUP @ 7FFF AND 0 ROT ! [ EDITOR ] QUICK BIF ; UTILITIES DEFINITIONS : .BUF ( QLIST BUFFER, . BLOCK ) DUP @ DUP 7FFF AND DUP QLIST MID ." BLOCK=" . 0< IF ." UPDATED" ENDIF CR ; BIF DEFINITIONS : .BUFFERS PREV @ ( .BUF, PAUSE) BEGIN UTILITIES .BUF BIF +BUF DROP KEY 0< ( BREAK? ) UNTIL DROP ; : .PREV PREV @ UTILITIES .BUF BIF DROP ; : EDIT DUP UTILITIES MID BIF ." BLOCK=" . CR [ EDITOR ] QUICK BIF PREV @ @ 0< IF ." UPDATED" ENDIF ; : QPREV PREV @ @ 7FFF AND EDIT ; -->( QOPY COPY QBACK BACK-UP ) ( JMR-88DEC11 ) : QOPY SWAP BLOCK SWAP BLOCK B/BUF 2/ MOVE UPDATE ; : COPY 2* 2* ( SCREEN ) SWAP 2* 2* DUP 4 + SWAP DO I OVER QOPY 1+ LOOP DROP ; : QBACK 1+ SWAP DO I QLIST I BLOCK DUP [ EDITOR ] QDUMP ." BLOCK " I . ." TO " 0 DRIVE-OFFSET @ I + DUP . KEY 59 = IF 0 R/W ( YES? ) ELSE DROP DROP ENDIF LOOP ; : EEDIT ( ERASE AND EDIT BLOCK ) DUP BLOCK 2- UTILITIES .BUF 2+ MID BIF ." BLOCK=" OVER . ." CLEAR?" CR KEY 59 = IF ( YES? ) B/BUF BLANKS UPDATE ELSE DROP ( DON'T CLEAR ) ENDIF EDIT ; --> ( RES-ERROR FORWARD :RESOLVE :RESOLVE ;RES JMR-16MAY89 ) UTILITIES DEFINITIONS HEX : RES-ERROR ( ADR RESOLUTION ) 3 ERROR ; BIF DEFINITIONS UTILITIES : FORWARD ( REFERENCE HEADER ) CREATE 7E C, ( JMP EXTENDED ) IP, [ ' RES-ERROR CFA , ] ( INIT TO RES-ERROR ) SMUDGE FOREWARD @ 0= IF ( EARLIEST? ) LATEST FOREWARD ! ENDIF ; ASSEMBLER DEFINITIONS UTILITIES : :RESOLVE ( :ASM FORWARD REFS ) ?EXEC !CSP [COMPILE] ' DUP CFA DUP 1+ SWAP C@ 7E - ( JMP) OVER @ ' RES-ERROR CFA - OR 1D ?ERROR ( HEADER? ) HERE SWAP ! ( LINK IT ) FOREWARD @ = IF ( END FORWD? ) 0 FOREWARD ! ENDIF ; IMMEDIATE BIF DEFINITIONS ASSEMBLER : :RES ( RESOLVE : FORWARDS ) [COMPILE] :RESOLVE [ BIF ] ( ASSEMBLE JMP <XCOL, COMPILE) IP, [ LATEST CFA @ , ] ] ; : ;RES [COMPILE] ; SMUDGE ; IMMEDIATE ( PL PTEST ) ( JMR-89AUG25 ) BIF DEFINITIONS DECIMAL : PL 79 0 DO I 33 + EMIT LOOP ; : PT ( PL UNTIL KEY PRESS ) BEGIN PL ?TERMINAL UNTIL ; : PTEST >PRT PT >VID ; ;S ( SLIST ) ( JMR-16OCT90 ) ROOT @ UTILITIES : SLIST ( LIST SCREENS TO PRT ) >PRT 1+ SWAP DO I ULIST 0< IF LEAVE ENDIF LOOP >VID ; ROOT ! ;S ( DISK ACCESS WORDS JMR-900228) HEX : CM! FF48 C! ; : ST@ FF48 C@ ; : TR! FF49 C! ; : TR@ FF49 C@ ; : SE! FF4A C! ; : SE@ FF4A C@ ; : DA! FF4B C! ; : DA@ FF4B C@ ; : DR FF40 ! ; : DWAIT BEGIN ST@ DUP 1 AND WHILE DROP REPEAT ; : 1I DR 40 CM! DWAIT 0 DR . ; : 1O DR 60 CM! DWAIT 0 DR . ; : IN 0 DO DUP 1I LOOP DROP ; : OUT 0 DO DUP 1O LOOP DROP ; : ?ADR 0 FF42 C! 0 FF46 C! 28 OR DR ( MOTOR ON, DBL DNS) C4 FF4C C! DWAIT . FF44 @ DROP 0 FF42 C! 0 FF46 C! FF4E ? FF4E ? FF4E ? ; ;S ( NAMES ) ( JMR-89MAY16 ) BIF DEFINITIONS HEX : NAME ( CFA TO NAME ) 2+ NFA ID. ; : NAMES ( DUMP BY NAME ) -DUP IF 2* OVER + SWAP ( 0? ) DO I 0 6 D.R ( ADR ) I @ DUP 0 5 D.R ( NUMERIC) 3A EMIT NAME CR ?TERMINAL 0< IF KEY 0< IF LEAVE ENDIF ENDIF 2 +LOOP ENDIF ; ;S ( ^asm-util DREG REGISTERS # DPREG DPR SETDP JMR-88DEC19 ) ASSEMBLER DEFINITIONS HEX VOCABULARY ^asm-util ( HIDDEN ) ^asm-util DEFINITIONS : DREG ( REGISTER OPERANDS ) 0FF0F AND 5245 DCONSTANT ; ASSEMBLER DEFINITIONS ^asm-util ( INDEX IN HI BYTE ) 8B00 DREG D 8608 DREG A 8509 DREG B 8C05 DREG PC 4003 DREG U 6004 DREG S 2002 DREG Y 0001 DREG X EF0A DREG CC EF0B DREG DP ( ALL OPERANDS ARE DBL INTS ) ( ABSOLUTE IS 0 OR -1 HI WORD ) ( DIRECT IS ABSOLUTE IN DPAGE ) 494D CONSTANT # ( HI WORD ) ^asm-util DEFINITIONS ( ASSEMBLY TIME DIRECT PAGE ) 42 USER DPREG ( EMULATOR ) ( INIT DPREG ) UTILITIES DP@ ASSEMBLER ^asm-util DPREG ! ASSEMBLER DEFINITIONS ( ACCESS DPREG ) : DPR [ ^asm-util ] DPREG BIF @ ; : SETDP 0FF00 AND [ ^asm-util ] DPREG BIF ! ; --> ( OFF, ABS, V, PCOFF PCR, ) ( JMR-89JAN2 ) ^asm-util DEFINITIONS : OFF, ( SET IX b0, COMPILE 2 ) OVER DUP 80 < SWAP -81 > AND IF C, C, ( SHORT ) ELSE 1 OR C, , ( LONG ) ENDIF ; : OP, ( COMPILE BYTE OR WORD ) DUP 0FF00 AND IF , ELSE C, ENDIF ; : ABS, >R ( COMPILE ABS ADR OP ) OVER 0FF00 AND DPR = IF R> DROP OP, C, ( DIR PAGE) ELSE R> OR OP, , ( EXT ) ENDIF ; : PCOFF ( ABSOLUTE TO PC REL ) HERE + 1+ - ( CALC OFFSET ) DUP 7F > OVER -80 < OR IF 1- 0 ( WORD OFF ) ELSE -1 ( BYTE OFF ) ENDIF ; : ?ABS ( TRUE IF ABSOLUTE ) DUP NOT 0= = ; ( USE T/F VAL) : PCR, ( COMPILE A PC REL INDEX) >R ?ABS NOT 25 ?ERROR 1 PCOFF IF R> C, C, ( BYTE ) ELSE R> 1 OR C, , ENDIF ; --> ( AUTO MASK, REG, IXOFF, EI, ) ( JMR-89JAN2 ) ASSEMBLER DEFINITIONS 4155.0082 DCONSTANT -) ( AUTO ) 4155.0081 DCONSTANT )++ ( REG ) 4155.0080 DCONSTANT )+ ( MODE ) 4155.0083 DCONSTANT --) ( CONS) ^asm-util DEFINITIONS : MASK, OR C, ; ( FOR POSTBYTE) : REG, ( REG OFF TO POST-BYTE ) SWAP DUP D DROP = OVER A DROP = OR OVER B DROP = OR NOT 26 ?ERROR SWAB OR C, ; ( REG, USES DUAL CODED REGS ) : IXOFF, ( REGISTER + CONSTANT ) OVER IF OVER ( NON-ZERO? ) DUP 0F > SWAP -10 < OR OVER 10 AND OR ( []? ) IF 88 OR OFF, ( EXTERNAL ) ELSE ( OFFSET IN POST-BYTE) SWAP 1F AND OR C, ENDIF ELSE 84 OR C, DROP ( 0 OFF ) ENDIF ; : EI, ( EXTENDED INDIRECT ) SWAP ?ABS NOT 27 ?ERROR C, , ; --> ( IX, , INDIRECT ) ( JMR-89JAN4 ) : IX, ( COMPILE AN INDEX MODE ) DUP 9F = IF EI, ELSE DUP 8F AND 8C = IF PCR, ELSE SWAP DUP 4155 = IF DROP MASK, ( AUTO ) ELSE DUP 5245 = IF DROP REG, ELSE ?ABS NOT 22 ?ERROR IXOFF, ENDIF ENDIF ENDIF ENDIF ; ASSEMBLER DEFINITIONS : , ( CONVERT TO INDEX ) 5245 = ( REGISTER? ) OVER 00FF AND DUP 0 > SWAP 6 < AND ( X Y U S PC ? ) AND NOT 28 ?ERROR SWAB 4958 ; : ) ( CONVERT TO INDIRECT ) DUP 5245 = ( REGISTER? ) IF ( ASSEMBLER ) , ELSE DUP [ ^asm-util ] ?ABS [ ASSEMBLER ] IF 4958.009F ELSE ( INDEX? ) DUP 4958 = NOT 27 ?ERROR ENDIF ENDIF ( SET BIT 4 ) SWAP 10 OR SWAP ; --> ( ACCM UNARY REG ) ( JMR-89JAN5 ) ^asm-util DEFINITIONS HEX : ACCM ( ENCODE ACCUMULATOR ) SWAP DUP 0FE AND ( A OR B? ) 8 = NOT 29 ?ERROR 1 AND ( MASK B IN? ) IF OR ELSE DROP ENDIF ; : UNARY ( OP-CODE COMPILER ) <BUILDS 0F AND C, ( OP-CODE ) DOES> C@ ( OP-CODE ) OVER 5245 = ( REGISTER? ) IF DUP 0E = 29 ?ERROR ( JMP?) 40 OR ROT 10 ACCM C, DROP ELSE OVER 4958 = ( INDEX? ) IF 60 OR C, DROP IX, ELSE SWAP ?ABS NOT 21 ?ERROR 70 ( EXT BITS ) ABS, ENDIF ENDIF ; : REG ( ENCODE TARGET REG ) DUP C@ 8D = IF C@ 1 ( JSR ) ELSE SWAP 5245 - 29 ?ERROR OVER DUP A DROP = SWAP B DROP = OR IF C@ SWAP 40 ACCM 0 ( BYTE) ELSE SWAP 00FF AND ( REG? ) OVER 1+ C@ ( CT? ) OVER > NOT 29 ?ERROR ( RANGE ) 2* + 2+ @ -1 ( WORD REG ) ENDIF ENDIF ; --> ( #, BINARY REG-REG ) ( JMR-89JAN12 ) : #, ( COMPILE AN IMMEDIATE ) SWAP DUP 0F AND 5 - ( BIT OK) OVER 5 AND 5 = ( ST OR JSR? ) AND 24 ?ERROR OP, IF BIF , [ ^asm-util ] ( WORD) ELSE C, ENDIF ; ( BYTE ) : BINARY ( OP-CODE COMPILER ) <BUILDS 8F AND C, ( A/B OP ) 05 AND DUP C, -DUP IF ( OP CT) 0 DO 11CF AND BIF , ( DXYUS) [ ^asm-util ] LOOP ENDIF DOES> REG ROT ( SOURCE ) DUP 4958 = IF ( INDEX ? ) DROP DROP 20 OR OP, IX, ELSE DUP 494D = ( IMMEDIATE? ) IF DROP #, ELSE ?ABS NOT 21 ?ERROR DROP 10 OR 20 ABS, ENDIF ENDIF ; : REG-REG ( OP-CODE COMPILER ) <BUILDS C, ( OP-CODE ) DOES> C@ C, ( OP-CODE ) 5245 = ROT 5245 = AND NOT 23 ?ERROR ( 2 REGS? ) 0F AND SWAP SWAN 0F0 AND OR C, ; --> ( REG-BITS PACK MOVEM ) ( JMR-89JAN12 ) 0 0B 1 1ARRAY REG-BITS ( PACK ) 0 REG-BITS ( INITIALIZE ) 06 OVER C! 1+ 10 OVER C! 1+ 20 OVER C! 1+ 40 OVER C! 1+ 40 OVER C! 1+ 80 OVER C! 1+ -1 OVER ! 2+ ( UNDEFINED ) 02 OVER C! 1+ 04 OVER C! 1+ 01 OVER C! 1+ 08 SWAP C! ( STABILIZE PACK: UNDEF=ALL ) : PACK >R 0 ( PSH/PUL LIST ) BEGIN OVER 5245 = WHILE SWAP DROP SWAP ( REG ) DUP R = 2A ?ERROR ( SELF? ) 0FF AND REG-BITS C@ ( BIT ) OVER OVER AND 2B ?ERROR OR REPEAT ( ^ IS DUPLICATE?) R> DROP ; : MOVEM ( OP-CODE COMPILER ) <BUILDS 0FD AND C, DOES> ( OP) C@ >R ( OP ) 5245 = OVER 1+ 0FE AND 4 = AND ( S OR U?) NOT 2C ?ERROR R> OVER U DROP = ( SELECT S/U) IF 2 OR ENDIF C, PACK DUP 0= 2D ?ERROR C, ; --> ( BR DCOND CC-IMM IMPLY ) ( JMR-89JAN13 ) ASSEMBLER DEFINITIONS : BR ( COMPILE CONDITIONAL BR ) 434F - 2F ?ERROR ( CONDITION?) [ ^asm-util ] SWAP ( ADR? ) ?ABS NOT 21 ?ERROR SWAP 1 PCOFF IF ( SHORT ) SWAP DUP 0< IF 0FF AND ( BSR ) ELSE 0F AND 20 OR ENDIF C, C, ( BOTH BYTES ) ELSE SWAP DUP 01000 AND IF SWAB 017 AND ( BSR/BRA ) ELSE 0F AND 1020 OR SWAP 1- SWAP ENDIF OP, BIF , ENDIF ; ASSEMBLER ^asm-util DEFINITIONS : DCOND ( CONDITIONAL OPERANDS) 434F DCONSTANT ; : CC-IMM ( OP-CODE COMPILER ) <BUILDS C, ( OP-CODE ) DOES> C@ C, ( OP-CODE ) 494D - 2E ?ERROR ( IMMEDIATE?) C, ; : IMPLY ( OP-CODE COMPILER ) <BUILDS BIF , ( OP-CODE ) DOES> @ OP, ; --> ( MNEMONICS ) ( JMR-89JAN13 ) ASSEMBLER DEFINITIONS ^asm-util 10CE 0CE 108E 8E 0CC 5 86 BINARY LD 10CF 0CF 108F 8F 0CD 5 87 BINARY ST 118C 1183 108C 8C 1083 5 81 BINARY CMP 35 MOVEM PUL 34 MOVEM PSH 46 UNARY ROR 49 UNARY ROL 39 IMPLY RTS 3B IMPLY RTI 0 82 BINARY SBC 978D DCOND SR 1F REG-REG TFR 4D UNARY TST 83 1 80 BINARY SUB 103F IMPLY SWI2 113F IMPLY SWI3 3F IMPLY SWI 13 IMPLY SYNC 0 84 BINARY AND 0 89 BINARY ADC 48 UNARY ASL 47 UNARY ASR 0C3 1 8B BINARY ADD 3A IMPLY ABX 5 DCOND CS 43 UNARY COM 4F UNARY CLR 1600 DCOND AL 0 85 BINARY BIT 4A UNARY DEC 19 IMPLY DAA 2 DCOND HI 0B DCOND MI 7 DCOND EQ 0C DCOND GE 1E REG-REG EXG 4C UNARY INC 0 8D BINARY JSR 4E UNARY JMP 0 88 BINARY EOR 0E DCOND GT 4 DCOND HS 12 IMPLY NOP 3 DCOND LS 0A DCOND PL --> ( MORE MNEMONICS ) ( JMR-89JAN13 ) 44 UNARY LSR 48 UNARY LSL 0D DCOND LT 6 DCOND NE 3D IMPLY MUL 40 UNARY NEG 0 8A BINARY OR 1A CC-IMM ORCC 1 DCOND NV 1D IMPLY SEX 1C CC-IMM ANDCC 3C CC-IMM CWAI 8 DCOND VC 9 DCOND VS 4 DCOND CCLR ( LO LE FOLLOW ) ^asm-util DEFINITIONS 1 4 1 1ARRAY EA-IX ( TRANSLATE) 1 EA-IX ( INITIALIZE ) 0 OVER C! 1+ 1 OVER C! 1+ 3 OVER C! 1+ 2 SWAP C! ASSEMBLER DEFINITIONS : LEA ( OP-CODE ASSEMBLER ) 5245 - 23 ?ERROR ( REGISTER?) 0F BIF AND [ ^asm-util ] EA-IX C@ 30 BIF OR C, 4958 - 21 ?ERROR ( INDEX? ) [ ^asm-util ] IX, ; 0F DCOND LE 5 DCOND LO --> ( [CD] & ! ^ NEXT ) ( JMR-89JAN17 ) ASSEMBLER DEFINITIONS BIF HEX : [CD] ( CFA OF DEF ) -IFIND DROP DUP 0= 0 ?ERROR CFA 0 [COMPILE] DLITERAL ; IMMEDIATE CREATE & [CD] AND JMP SMUDGE CREATE ! [CD] OR JMP SMUDGE CREATE ^ [CD] XOR JMP SMUDGE ASSEMBLER : NEXT )++ Y ) JMP ; --> ( INVERTCC LIF IF ) ( JMR-89FEB3 ) ^asm-util DEFINITIONS HEX CREATE INVERTCC ( CONDITIONS ) 0. U , X LD 434F # X CMP HERE DUP 2+ 0 NE BR ( CC? ) 2. U , D LD ( BSR? ) HERE DUP 2+ 0 MI BR A CLR 1 # B EOR ( TOGGLE CC ) HERE 4 + 0 NE BR ( ALWAYS? ) AL DROP SWAB # A LD 2. U , D ST NEXT ( FILL BR) 1+ HERE OVER 1+ - SWAP C! 1+ HERE OVER 1+ - SWAP C! 2F # D LD D U PSH ( TO ERROR) [CD] ERROR JMP SMUDGE ASSEMBLER DEFINITIONS : LIF ( MARK AND ASM LONG BR ) [ ^asm-util ] INVERTCC [ ASSEMBLER ] >R >R HERE 4146 ( MARK ) [ UTILITIES ] [CD] RES-ERROR [ ASSEMBLER ] R> R> BR ; : IF ( MARK AND ASM SHORT BR ) [ ^asm-util ] INVERTCC [ ASSEMBLER ] >R >R HERE 4146 ( MARK ) OVER 2+ 0 R> R> BR ; --> ( FILL-IN ) ( JMR-89FEB7 ) ^asm-util DEFINITIONS CREATE FILL-IN ( BR OFFSETS ) UTILITIES DP@ 0 X LD DP DP@ @ - ASSEMBLER 0 X , D LD 0. U , D SUB D U PSH ( OFFS) 2. U , X LD 0. X , D LD ( BR) 16 # A CMP ( ALWAYS? ) HERE DUP 2+ 0 EQ BR 0FE # A AND 0F0 # B AND 1020 # D CMP ( LONG? ) HERE DUP 2+ 0 EQ BR ( SHORT BRANCH ) 0F0 # A AND 20 # A CMP ( BR?) UTILITIES [CD] RES-ERROR ASSEMBLER NE BR 0. U , D LD 7E # D ADD A TST UTILITIES [CD] RES-ERROR ASSEMBLER NE BR ( TOO FAR? ) 80 # B SUB 1. X , B ST ( OFFSET ) HERE 4. U , U LEA NEXT ROT 1+ HERE OVER 1+ - SWAP C! 0. U , D LD ( LONG BR ALWAYS) 3 # D SUB 1. X , D ST DUP 0 AL BR SWAP 1+ HERE OVER 1+ - SWAP C! 0. U , D LD ( LONG BR COND ) 4 # D SUB 2. X , D ST 0 AL BR SMUDGE --> ( ELSE LELSE ENDIF ) ( JMR-89FEB6 ) ASSEMBLER DEFINITIONS HEX ^asm-util : ELSE ( SHORT BRANCH, RESOLVE) 4146 ?PAIRS >R NV IF R> FILL-IN ; : LELSE ( LONG BRANCH, RESOLVE) 4146 ?PAIRS >R NV LIF R> FILL-IN ; : ENDIF 4146 ?PAIRS FILL-IN ; : BEGIN HERE 4142 ; : UNTIL ( COND BR TO BEGIN ) >R >R 4142 ?PAIRS 0 R> R> INVERTCC BR ; : WHILE ( COND BR PAST REPEAT ) ROT 4142 ?PAIRS IF DROP 4157 ; : REPEAT ( LOOP, RESOLVE WHILE) 4157 ?PAIRS SWAP 0 AL BR FILL-IN ; : LWHILE ( LONG WHILE ) ROT 4142 ?PAIRS LIF DROP 4157 ; --> ( :ASM ;ASM ) ( JMR-89MAR28 ) ASSEMBLER DEFINITIONS HEX : :ASM CREATE !CSP ; : ;ASM ?CSP SMUDGE ; : I-CODE ( SHIFT TO HI-LEVEL ) [ ' :ASM CFA @ ] LITERAL [ BIF ] , ( ASMBL JMP <XCOL ) DROOT @ ROOT ! ] ; ( COMPILE) ASSEMBLER : MACHINE ( SHIFT TO LO-LEVEL ) COMPILE (MACHINE) ( IN DEF ) [COMPILE] [ ( NOW INTERPRET ) [COMPILE] ASSEMBLER ; IMMEDIATE ;S ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ( D! D@ ) ( JMR-89FEB16 ) BIF DEFINITIONS ASSEMBLER :ASM D! ( STORE DBL ) X U PUL D U PUL 0. X , D ST D U PUL 2. X , D ST NEXT ;ASM :ASM D@ ( FETCH DBL ) X U PUL 0. X , D LD 2. X , X LD D X U PSH NEXT ;ASM :ASM DOVER ( DOUBLE OVER DOUBLE) 4. U , D LD 6. U , X LD D X U PSH NEXT ;ASM :ASM DSWAP ( SWAP DOUBLES ) 4. U , D LD 0. U , X LD 4. U , X ST 0. U , D ST 6. U , D LD 2. U , X LD 6. U , X ST 2. U , D ST NEXT ;ASM ;S ( [& ,& ]& ) ( JMR-93MAR20 ) BIF DEFINITIONS HEX : [& ( START ARRAY INDEX LIST ) 0 0 4152 ; : ,& ( ACCUMULATE INDEX LIST ) ROT 4152 - 35 ?ERROR ( SPAN?) OVER - DUP F000 AND 33 ?ERROR 1+ SWAP >R ( SAVE LO ) DUP ROT * R> + ( NEW RELOC ) ROT 1+ DUP 7 > 34 ?ERROR SWAP 4152 ; : ]& ( COMPLETE THE ARRAY DEF ) DUP 1- FF00 AND 33 ?ERROR <BUILDS >R ,& DROP ( AR FLAG) R * ( NEW REL ) R> SWAP >R SWAP DUP , ( STORE COUNT ) 0 DO DUP , * LOOP ( SIZES ) DUP , ( ARR SZ ) R> , ( REL ) ALLOT ?STACK DOES> 0 ( SUM ) SWAP DUP 2+ SWAP @ ( COUNT ) 2* OVER + DUP >R ( SAVE END ) SWAP DO ( SUM OF PRODUCTS ) SWAP I @ * + 2 +LOOP R 2+ @ ( RELOCATE ) - DUP 0< OVER R @ < 0= ( BOUNDS? ) OR 0C ?ERROR R> 4 + + ; ( ^ LABEL LOCVOC ) ( JMR-93MAR21 ) BIF DEFINITIONS DECIMAL : ^ ( EXPONENT WITH ?ERROR ) -DUP 0= IF DROP 1 ( N 0 ^ ) ELSE OVER DUP 0= ( 0 N ^ ) SWAP 1 = OR ( 1 N ^ ) OVER 1 = OR ( N 1 ^ ) IF DROP ELSE 1 SWAP 0 DO OVER M* 54 ?ERROR LOOP SWAP DROP ENDIF ENDIF ; : LABEL ( --- ) ( BUILD GOTO ) <BUILDS IMMEDIATE COMPILE-ONLY 0 , DOES> DUP @ IF COMPILE BRANCH @ HERE - 2- , ELSE HERE SWAP ! ENDIF ; : LOCVOC VOCABULARY IMMEDIATE ; : GETNUMBER ( ADR N --- ) 1- OVER 1+ SWAP EXPECT BL ENCLOSE OVER + 0 SWAP C! NUMBER DROP ; : $ DUP . ; ( CS431 TESTPARAMS FACTORIAL ) ( JMR-93MAR24 ) DECIMAL 33 LOAD ( ARRAYS ) DECIMAL 34 LOAD ( ^ LABEL ) BIF DEFINITIONS LOCVOC CS431 CS431 DEFINITIONS DECIMAL 6805 VARIABLE X 6800 VARIABLE Y LOCVOC PARAMSLOCAL PARAMSLOCAL DEFINITIONS 0 VARIABLE A 0 VARIABLE B 0 VARIABLE C 0 VARIABLE X 0 2 2 1ARRAY D CS431 DEFINITIONS PARAMSLOCAL : TESTPARAMS ( N ADR --- ) 1 A ! 2 B ! 3 C ! 4 X ! 4 0 D ! 5 1 D ! 6 2 D ! SWAP ." BY-VAL WAS" . DUP @ 0 D @ * 2 D @ C @ / - 1 D @ A @ * B @ * + SWAP OVER 0 D @ / B @ * 2 D @ * OVER ! ." BY-VAL PARAMETER=" SWAP . ." BY-ADR PARAMETER=" @ . ." LOCAL X=" X @ . ; CS431 : FACTORIAL ( ADR --- ) [ SMUDGE ] ( RECURSIVE ) DUP @ 12 > IF ." TOO BIG " ELSE ." FACTOR" DUP ? DUP @ 2 > IF DUP @ 1- SP@ FACTORIAL OVER @ * OVER ! ENDIF ENDIF ." N!=" ? ; SMUDGE -->( CS431 RECORDS ) ( JMR-93MAR24 ) CS431 DEFINITIONS LOCVOC RECLOC RECLOC DEFINITIONS LOCVOC US US DEFINITIONS 0 VARIABLE ME 0 VARIABLE YOU 0 2 2 1ARRAY THEM RECLOC DEFINITIONS 0 VARIABLE X CS431 DEFINITIONS RECLOC : TESTRECORDS ( --- ) 1 X ! US 3 ME ! 6 YOU ! 2 0 THEM ! 4 1 THEM ! 6 2 THEM ! 2 THEM @ 10 * YOU @ / 1 THEM @ - 0 THEM @ + ME ! ." BEFORE CALL, US.ME=" ME ? ." US.THEM[2]=" 2 THEM ? ME @ 2 THEM TESTPARAMS ." AFTER CALL, LOCAL X=" X ? ." GLOBAL X=" CS431 X ? RECLOC US ." US.ME=" ME ? ." US.THEM[2]=" 2 THEM ? ; CS431 DEFINITIONS --> ( CS431 MAIN ) ( JMR-93MAR24 ) CS431 DEFINITIONS DECIMAL LOCVOC MAINLOC MAINLOC DEFINITIONS LABEL LOOPTO 0 VARIABLE A 0 VARIABLE B 0 VARIABLE C 0 VARIABLE D 0 VARIABLE E 0 VARIABLE F 0 VARIABLE G 0 VARIABLE I 0 VARIABLE J 0 VARIABLE K 0 VARIABLE X 0 VARIABLE CHOICE 0 VARIABLE RESULT [& -1 1 ,& 5 7 ,& 10 11 2 ]& ARRAY 0 79 1 1ARRAY STR 0 VARIABLE AA 0 VARIABLE BB 0 VARIABLE CC 0 VARIABLE DRES CS431 DEFINITIONS MAINLOC ( MIGHT AS WELL START HERE! ) : MAIN ( --- ) ( WE HOPE ) LOOPTO ." CHOICE (1 - 9): " 0 STR 80 GETNUMBER DUP CHOICE ! 0= IF ." I BE DONE!" QUIT ELSE CHOICE @ 1 = IF 1 A ! 2 B ! 3 C ! 4 D ! 5 E ! 6 F ! 7 G ! A @ B @ * $ C @ D @ * $ F @ B @ / $ D @ B @ / $ G @ 100 * $ --> ( CS431 CONTINUE MAIN ) E @ E @ * E @ * $ 23 C @ - $ B @ G @ B @ - * C @ * $ C @ A @ B @ D @ * + * E @ / $ A @ B @ + C @ + G @ F @ - D @ - * $ E @ F @ + G @ + A @ B @ + / $ G @ MINUS G @ - $ A @ MINUS B @ MINUS * G @ MINUS + $ F @ D @ * MINUS B @ C @ * MINUS / $ + + + + + + + + - + - + + RESULT ! ." RESULT=" RESULT ? ELSE CHOICE @ 2 = IF 2 AA ! 3 BB ! 4 CC ! AA @ AA @ ^ AA @ BB @ ^ + AA @ ^ AA @ CC @ ^ / DRES ! DRES @ RESULT ! ." RESULT=" RESULT ? ELSE CHOICE @ 3 = IF 2 -1 DO BIF I MAINLOC I ! 8 5 DO BIF I MAINLOC J ! 12 10 DO BIF I MAINLOC K ! ." ARRAY AT" I ? J ? K ? --> ( CS431 MAIN CONTINUED ) 0 STR 80 GETNUMBER I @ J @ K @ ARRAY ! LOOP LOOP LOOP 0 RESULT ! 2 -1 DO BIF I MAINLOC I ! 8 5 DO BIF I MAINLOC J ! 12 10 DO BIF I MAINLOC K ! I @ J @ K @ ARRAY @ RESULT +! LOOP LOOP LOOP ." RESULT=" RESULT ? ELSE CHOICE @ 4 = IF 21 0 DO BIF I MAINLOC I ! I @ 0= IF ." ZERO" ELSE I @ 10 < IF ." I=" I ? ELSE I @ 10 = IF 16 I ! R> DROP 16 >R ELSE ." NEAT-O" ENDIF ENDIF ENDIF 2 +LOOP ELSE CHOICE @ 5 = IF 2 A ! 4 B ! 0 X ! ." A BEFORE CALL=" A ? ." B BEFORE CALL=" B ? --> ( CS431 MAIN CONTINUED ) A @ B TESTPARAMS ." AFTER A=" A ? ." AFTER B=" B ? ." GLOBAL X=" CS431 X ? ." MAIN X=" MAINLOC X ? ELSE CHOICE @ 6 = IF 0 STR 80 GETNUMBER SP@ FACTORIAL ." ^:" 0 D. ELSE CHOICE @ 7 = IF TESTRECORDS ELSE CHOICE @ 8 = IF ." NO CASE " ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF CHOICE @ 9 < IF LOOPTO ENDIF ." THE WRONG END TO PRINT" ; ;S
\ No newline at end of file
OSDN Git Service
