• R/O
  • HTTP
  • SSH
  • HTTPS

bif-6809: コミット

ソースコード及び仕様書など
Source and documentation


コミットメタ情報

リビジョンd64a55552376a2a3c4cba3ebc575982ef7e4a15c (tree)
日時2019-05-02 19:44:38
作者Joel Matthew Rees <joel.rees@gmai...>
コミッターJoel Matthew Rees

ログメッセージ

The sieve example programs in testsource run, such as they are.

変更サマリ

差分

--- a/testsource/rs_sieve_bif.fs
+++ b/testsource/rs_sieve_bif.fs
@@ -70,5 +70,7 @@ SHOWPRIMES
7070
7171 COUNTPRIMES
7272
73-
73+( 8192: 6 SECONDS TO FIND PRIMES )
74+( 3 SECONDS TO COUNT )
75+( XROAR NORMAL )
7476
--- a/testsource/sievefig.bif6809
+++ b/testsource/sievefig.bif6809
@@ -39,34 +39,33 @@ MAXSIEVE 1 - 2 /
3939 0 VARIABLE SIEVE
4040 ( OLD FORTHS DON'T PROVIDE A )
4141 ( DEFAULT BEHAVIOR FOR CREATE )
42-( GFORTH WILL LEAVE )
42+( NEW FORTHS WILL LEAVE )
4343 ( THE ZERO THERE. )
4444 ( OLD FORTHS NEED )
4545 ( AN INITIAL VALUE. )
4646
47- HERE SIEVE -
4847 ( OLD FORTHS DON'T PROVIDE )
4948 ( A CELL WIDTH. )
50- CONSTANT CELLWIDTH
51-( TO SHOW HOW IT CAN BE DONE. )
49+ HERE SIEVE - DUP ( CELLWIDTH )
5250
53-CELLWIDTH MAXSIEVE SWAP - ALLOT
5451 ( ALLOCATE THE REST )
5552 ( OF THE BYTE ARRAY. )
53+ MAXSIEVE SWAP - ALLOT
54+
55+( NOW DEFINE THE CONSTANT: )
56+ CONSTANT CELLWIDTH
5657
5758 : NOT-PRIME! ( ADR N -- )
58-+ 0 SWAP ! ;
59++ 0 SWAP C! ;
5960
6061 : IS-PRIME? ( ADR N -- F )
61-+ @ ;
62++ C@ ;
6263 -->
6364
6465
6566 : SIEVE-INIT ( ADR -- )
66-0 OVER C!
67-( 0 IS NOT PRIME. )
68-0 OVER 1+ C!
69-( 1 IS NOT PRIME. )
67+DUP 0 NOT-PRIME!
68+DUP 1 NOT-PRIME!
7069 ( SET FLAGS TO TRUE )
7170 ( FOR 2 TO FINALPASS. )
7271 2+ MAXSIEVE 2- -1 FILL
@@ -94,14 +93,15 @@ LOOP ;
9493
9594
9695
96+
97+
9798 : COUNT-PRIMES ( ADR -- )
98-." COUNT: " .
9999 0 SWAP
100100 MAXSIEVE 0 DO
101101 DUP I IS-PRIME? IF
102102 SWAP 1+ SWAP
103103 ENDIF
104-LOOP DROP CR
104+LOOP DROP
105105 ;
106106
107107
@@ -119,7 +119,7 @@ DROP ;
119119 : PRINT-PRIMES ( ADR -- )
120120 MAXSIEVE 0 DO
121121 DUP I IS-PRIME?
122- IF . ENDIF
122+ IF I . ENDIF
123123 LOOP
124124 DROP CR ;
125125 -->
@@ -133,10 +133,15 @@ BIF DEFINITIONS
133133 [ SIEVE-LOCAL ]
134134 SIEVE SIEVE-INIT
135135 SIEVE FIND-PRIMES
136-SIEVE PRINT-PRIMES
137-SIEVE COUNT-PRIMES ;
136+SIEVE PRINT-PRIMES CR
137+." COUNT: "
138+SIEVE COUNT-PRIMES . CR ;
138139
139140
140141 SIEVEMAIN
141142
142143
144+( 8192: 8 SECONDS TO FIND )
145+( 3 TO COUNT )
146+( XROAR, NORMAL CLOCK )
147+
--- a/testsource/sievegforth.bif6809
+++ b/testsource/sievegforth.bif6809
@@ -14,7 +14,7 @@
1414 ( SHALL RETAIN THIS COPYRIGHT )
1515 ( AND PERMISSION NOTICE. )
1616
17-256 CONSTANT MAXSIEVE
17+256 CONSTANT MAXSIEVE
1818 MAXSIEVE 1- 2 /
1919 CONSTANT FINALPASS
2020
@@ -22,13 +22,13 @@ MAXSIEVE 1- 2 /
2222 ( ENOUGH DIGITS )
2323 ( TO DISPLAY MAXSIEVE )
2424
25-CREATE SIEVE MAXSIEVE ALLOT
26-
27- -->
28-
29-
25+( BIF AND FIG HAVE NO DEFAULT )
26+( BEHAVIOR FOR CREATE-D WORDS )
27+0 VARIABLE SIEVE
28+ MAXSIEVE 2- ALLOT
3029
3130
31+-->
3232
3333 : SIEVEMAIN ( -- )
3434 0 SIEVE C!
@@ -44,20 +44,20 @@ FINALPASS 2 DO
4444 ( CLEAR FLAGS AT MULTIPLES. )
4545 DUP I + C@ IF
4646 ( DON'T BOTHER IF NOT PRIME. )
47- MAXSIEVE I DUP + ?DO
47+ MAXSIEVE I DUP + DO
4848 ( START AT FIRST MULTIPLE )
4949 ( -- DOUBLE. )
5050 0 OVER I + C!
5151 ( CLEAR AT THIS MULTIPLE. )
5252 J +LOOP
5353 ( SIEVE STILL ON STACK. )
54- THEN
54+ ENDIF
5555 LOOP ( SIEVE STILL ON STACK. )
5656 MAXSIEVE 0 DO
5757 I DISPWIDTH .R ." : IS "
5858 DUP I + C@ 0= IF
5959 ." NOT "
60- THEN
60+ ENDIF
6161 ." PRIME." CR
6262 LOOP DROP ;
6363 -->
@@ -65,4 +65,6 @@ LOOP DROP ;
6565
6666 SIEVEMAIN
6767
68-
68+( 8 SECONDS )
69+( FROM CALL TO SIEVEMAIN )
70+( ON XROAR. )
--- a/testsource/sieveplay.dsk
+++ b/testsource/sieveplay.dsk
@@ -1 +1 @@
1-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) ERATOSTHENES FROM ROSETTA 44) MY FIG COMPATIBLE SIEVE 50 A GFORTH COMPATIBLE SIEVE 54 ROSETTA SIEVE FIXED? 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 ( FROM ROSETTA CODE ) ( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth ) : PRIME? ( N -- ? ) HERE + C@ 0= ; : COMPOSITE! ( N -- ) HERE + 1 SWAP C! ; : 2DUP OVER OVER ; : SHOWPRIMES ." PRIMES: " 2 DO I PRIME? IF I . ENDIF LOOP ; : COUNTPRIMES ." PRIME COUNT: " 0 SWAP 2 DO I PRIME? IF 1+ ENDIF LOOP . ; --> : SIEVE ( N -- ) HERE OVER ERASE 2 BEGIN 2DUP DUP * > WHILE DUP PRIME? IF 2DUP DUP * DO I COMPOSITE! DUP +LOOP ENDIF 1+ REPEAT DROP ; --> ( SIEVE DEFINED. ) ( EDIT SIEVE COUNT TO DO MORE ) ( SIEVE IS KEPT IN THE ) ( FREE RAM AREA, ) ( WITH THE EXPECT-ED ) ( CONSEQUENCES. ) ( MAY MISBEHAVE ) ( IF RUN TWICE IN A ROW ) ( WITHOUT REPEAL-ING BACK. ) ( OKAY UP TO AT LEAST 8192. ) 100 SIEVE DUP SHOWPRIMES COUNTPRIMES ( ARCHETYPICAL IMPLEMENTATION ) ( OF THE SIEVE OF ERATOSTHENES )( IN FORTH -- FIG, BIF-C -- ) ( USING A LITTLE MORE ) ( OF THE FORTH AND BIF IDIOMS. )( COPYRIGHT 2015, 2019, ( JOEL MATTHEW REES ) ( BY JOEL MATTHEW REES, ) ( AMAGASAKI, JAPAN, 2015 ) ( ALL RIGHTS RESERVED. ) ( PERMISSION GRANTED BY THE ) ( AUTHOR TO USE THIS CODE ) ( FOR ANY PURPOSE, ) ( ON CONDITION THAT ) ( SUBSTANTIAL USE ) ( SHALL RETAIN THIS COPYRIGHT ) ( AND PERMISSION NOTICE. ) ( PERL-ESQUE, TOO. ) VOCABULARY SIEVE-LOCAL ( MAKE A LOCAL SYMBOL TABLE. ) SIEVE-LOCAL DEFINITIONS ( SWITCH TO THE ) ( LOCAL VOCABULARY. ) 256 CONSTANT MAXSIEVE MAXSIEVE 1 - 2 / CONSTANT FINALPASS --> 5 CONSTANT DISPWIDTH ( ENOUGH DIGITS ) ( TO DISPLAY MAXSIEVE ) 0 VARIABLE SIEVE ( OLD FORTHS DON'T PROVIDE A ) ( DEFAULT BEHAVIOR FOR CREATE ) ( GFORTH WILL LEAVE ) ( THE ZERO THERE. ) ( OLD FORTHS NEED ) ( AN INITIAL VALUE. ) HERE SIEVE - ( OLD FORTHS DON'T PROVIDE ) ( A CELL WIDTH. ) CONSTANT CELLWIDTH ( TO SHOW HOW IT CAN BE DONE. ) CELLWIDTH MAXSIEVE SWAP - ALLOT ( ALLOCATE THE REST ) ( OF THE BYTE ARRAY. ) : NOT-PRIME! ( ADR N -- ) + 0 SWAP ! ; : IS-PRIME? ( ADR N -- F ) + @ ; --> : SIEVE-INIT ( ADR -- ) 0 OVER C! ( 0 IS NOT PRIME. ) 0 OVER 1+ C! ( 1 IS NOT PRIME. ) ( SET FLAGS TO TRUE ) ( FOR 2 TO FINALPASS. ) 2+ MAXSIEVE 2- -1 FILL ; : PRIME-PASS ( ADR PRIME -- ) ( DOUBLE IS FIRST MULTIPLE ) MAXSIEVE OVER DUP + DO OVER I NOT-PRIME! DUP +LOOP ( NEXT MULTIPLE ) DROP ; : FIND-PRIMES ( ADR -- ) FINALPASS 2 DO DUP I IS-PRIME? IF I PRIME-PASS ENDIF LOOP ; --> : COUNT-PRIMES ( ADR -- ) ." COUNT: " . 0 SWAP MAXSIEVE 0 DO DUP I IS-PRIME? IF SWAP 1+ SWAP ENDIF LOOP DROP CR ; : PRINT-ALL ( ADR -- ) MAXSIEVE 0 DO I DISPWIDTH .R ." : IS " DUP I IS-PRIME? 0= IF ." NOT " ENDIF ." PRIME." CR LOOP DROP ; : PRINT-PRIMES ( ADR -- ) MAXSIEVE 0 DO DUP I IS-PRIME? IF . ENDIF LOOP DROP CR ; --> BIF DEFINITIONS : SIEVEMAIN ( -- ) [ SIEVE-LOCAL ] SIEVE SIEVE-INIT SIEVE FIND-PRIMES SIEVE PRINT-PRIMES SIEVE COUNT-PRIMES ; SIEVEMAIN ( ARCHETYPICAL IMPLEMENTATION ) ( OF THE SIEVE OF ERATOSTHENES )( IN FORTH -- BIF-6809 -- ) ( COPYRIGHT 2015, 2019, ) ( JOEL MATTHEW REES ) ( WRITTEN BY JOEL MATHEW REES, )( AMAGASAKI, JAPAN, 2015, 2019 )( ALL RIGHTS RESERVED. ) ( PERMISSION GRANTED BY THE ) ( AUTHOR TO USE THIS CODE ) ( FOR ANY PURPOSE, ) ( ON CONDITION THAT ) ( SUBSTANTIAL USE ) ( SHALL RETAIN THIS COPYRIGHT ) ( AND PERMISSION NOTICE. ) 256 CONSTANT MAXSIEVE MAXSIEVE 1- 2 / CONSTANT FINALPASS 5 CONSTANT DISPWIDTH ( ENOUGH DIGITS ) ( TO DISPLAY MAXSIEVE ) CREATE SIEVE MAXSIEVE ALLOT --> : SIEVEMAIN ( -- ) 0 SIEVE C! ( 0 IS NOT PRIME. ) 0 SIEVE 1+ C! ( 1 IS NOT PRIME. ) SIEVE MAXSIEVE 2 DO ( SET FLAGS TO TRUE ) ( FOR 2 TO FINALPASS. ) -1 OVER I + C! LOOP ( SIEVE PTR STILL ON STACK. ) FINALPASS 2 DO ( CLEAR FLAGS AT MULTIPLES. ) DUP I + C@ IF ( DON'T BOTHER IF NOT PRIME. ) MAXSIEVE I DUP + ?DO ( START AT FIRST MULTIPLE ) ( -- DOUBLE. ) 0 OVER I + C! ( CLEAR AT THIS MULTIPLE. ) J +LOOP ( SIEVE STILL ON STACK. ) THEN LOOP ( SIEVE STILL ON STACK. ) MAXSIEVE 0 DO I DISPWIDTH .R ." : IS " DUP I + C@ 0= IF ." NOT " THEN ." PRIME." CR LOOP DROP ; --> SIEVEMAIN ( FROM ROSETTA CODE ) ( MODIFIED TO GIVE ROOM ) ( FOR OTHER WORDS THAT ) ( USE THE HERE REGION ) ( WITHOUT ALLOCATION. ) ( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth ) ( USE BOTTOM TO MOVE ) ( OUT OF EXPECT BUFFER ) : BOTTOM HERE 256 + ; : PRIME? ( N -- ? ) BOTTOM + C@ 0= ; : COMPOSITE! ( N -- ) BOTTOM + 1 SWAP C! ; : 2DUP OVER OVER ; : SHOWPRIMES ." PRIMES: " 2 DO I PRIME? IF I . ENDIF LOOP ; --> : COUNTPRIMES ." PRIME COUNT: " 0 SWAP 2 DO I PRIME? IF 1+ ENDIF LOOP . ; : SIEVE ( N -- ) BOTTOM OVER ERASE 2 BEGIN 2DUP DUP * > WHILE DUP PRIME? IF 2DUP DUP * DO I COMPOSITE! DUP +LOOP ENDIF 1+ REPEAT DROP ; --> ( SIEVE DEFINED. ) ( EDIT SIEVE COUNT TO DO MORE ) ( SIEVE IS KEPT IN THE ) ( FREE RAM AREA, ) ( MOVED DOWN BY BOTTOM ) ( TO AVOID EXPECT-ED CONFLICT ) ( BUT IT DOESN'T WORK. ) ( SHOULD BE OKAY BEYOND 8192 ) 100 SIEVE DUP SHOWPRIMES COUNTPRIMES
\ No newline at end of file
1+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) ERATOSTHENES FROM ROSETTA 44) MY FIG COMPATIBLE SIEVE 50 A GFORTH COMPATIBLE SIEVE 54 ROSETTA SIEVE FIXED? 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 ( FROM ROSETTA CODE ) ( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth ) : PRIME? ( N -- ? ) HERE + C@ 0= ; : COMPOSITE! ( N -- ) HERE + 1 SWAP C! ; : 2DUP OVER OVER ; : SHOWPRIMES ." PRIMES: " 2 DO I PRIME? IF I . ENDIF LOOP ; : COUNTPRIMES ." PRIME COUNT: " 0 SWAP 2 DO I PRIME? IF 1+ ENDIF LOOP . ; --> : SIEVE ( N -- ) HERE OVER ERASE 2 BEGIN 2DUP DUP * > WHILE DUP PRIME? IF 2DUP DUP * DO I COMPOSITE! DUP +LOOP ENDIF 1+ REPEAT DROP ; --> ( SIEVE DEFINED. ) ( EDIT SIEVE COUNT TO DO MORE ) ( SIEVE IS KEPT IN THE ) ( FREE RAM AREA, ) ( WITH THE EXPECT-ED ) ( CONSEQUENCES. ) ( MAY MISBEHAVE ) ( IF RUN TWICE IN A ROW ) ( WITHOUT REPEAL-ING BACK. ) ( OKAY UP TO AT LEAST 8192. ) 100 SIEVE DUP SHOWPRIMES COUNTPRIMES ( 8192: 6 SECONDS TO FIND PRIMES ) ( 3 SECONDS TO COUNT ) ( XROAR NORMAL ) ( ARCHETYPICAL IMPLEMENTATION ) ( OF THE SIEVE OF ERATOSTHENES )( IN FORTH -- BIF, FIG -- ) ( USING A LITTLE MORE ) ( OF THE FORTH AND BIF IDIOMS. )( COPYRIGHT 2015, 2019, ( JOEL MATTHEW REES ) ( BY JOEL MATTHEW REES, ) ( AMAGASAKI, JAPAN, 2015 ) ( ALL RIGHTS RESERVED. ) ( PERMISSION GRANTED BY THE ) ( AUTHOR TO USE THIS CODE ) ( FOR ANY PURPOSE, ) ( ON CONDITION THAT ) ( SUBSTANTIAL USE ) ( SHALL RETAIN THIS COPYRIGHT ) ( AND PERMISSION NOTICE. ) ( PERL-ESQUE, TOO. ) VOCABULARY SIEVE-LOCAL ( MAKE A LOCAL SYMBOL TABLE. ) SIEVE-LOCAL DEFINITIONS ( SWITCH TO THE ) ( LOCAL VOCABULARY. ) 256 CONSTANT MAXSIEVE MAXSIEVE 1 - 2 / CONSTANT FINALPASS --> 5 CONSTANT DISPWIDTH ( ENOUGH DIGITS ) ( TO DISPLAY MAXSIEVE ) 0 VARIABLE SIEVE ( OLD FORTHS DON'T PROVIDE A ) ( DEFAULT BEHAVIOR FOR CREATE ) ( NEW FORTHS WILL LEAVE ) ( THE ZERO THERE. ) ( OLD FORTHS NEED ) ( AN INITIAL VALUE. ) ( OLD FORTHS DON'T PROVIDE ) ( A CELL WIDTH. ) HERE SIEVE - DUP ( CELLWIDTH ) ( ALLOCATE THE REST ) ( OF THE BYTE ARRAY. ) MAXSIEVE SWAP - ALLOT ( NOW DEFINE THE CONSTANT: ) CONSTANT CELLWIDTH : NOT-PRIME! ( ADR N -- ) + 0 SWAP C! ; : IS-PRIME? ( ADR N -- F ) + C@ ; --> : SIEVE-INIT ( ADR -- ) DUP 0 NOT-PRIME! DUP 1 NOT-PRIME! ( SET FLAGS TO TRUE ) ( FOR 2 TO FINALPASS. ) 2+ MAXSIEVE 2- -1 FILL ; : PRIME-PASS ( ADR PRIME -- ) ( DOUBLE IS FIRST MULTIPLE ) MAXSIEVE OVER DUP + DO OVER I NOT-PRIME! DUP +LOOP ( NEXT MULTIPLE ) DROP ; : FIND-PRIMES ( ADR -- ) FINALPASS 2 DO DUP I IS-PRIME? IF I PRIME-PASS ENDIF LOOP ; --> : COUNT-PRIMES ( ADR -- ) 0 SWAP MAXSIEVE 0 DO DUP I IS-PRIME? IF SWAP 1+ SWAP ENDIF LOOP DROP ; : PRINT-ALL ( ADR -- ) MAXSIEVE 0 DO I DISPWIDTH .R ." : IS " DUP I IS-PRIME? 0= IF ." NOT " ENDIF ." PRIME." CR LOOP DROP ; : PRINT-PRIMES ( ADR -- ) MAXSIEVE 0 DO DUP I IS-PRIME? IF I . ENDIF LOOP DROP CR ; --> BIF DEFINITIONS : SIEVEMAIN ( -- ) [ SIEVE-LOCAL ] SIEVE SIEVE-INIT SIEVE FIND-PRIMES SIEVE PRINT-PRIMES CR ." COUNT: " SIEVE COUNT-PRIMES . CR ; SIEVEMAIN ( 8192: 8 SECONDS TO FIND ) ( 3 TO COUNT ) ( XROAR, NORMAL CLOCK ) ( ARCHETYPICAL IMPLEMENTATION ) ( OF THE SIEVE OF ERATOSTHENES )( IN FORTH -- BIF-6809 -- ) ( COPYRIGHT 2015, 2019, ) ( JOEL MATTHEW REES ) ( WRITTEN BY JOEL MATHEW REES, )( AMAGASAKI, JAPAN, 2015, 2019 )( ALL RIGHTS RESERVED. ) ( PERMISSION GRANTED BY THE ) ( AUTHOR TO USE THIS CODE ) ( FOR ANY PURPOSE, ) ( ON CONDITION THAT ) ( SUBSTANTIAL USE ) ( SHALL RETAIN THIS COPYRIGHT ) ( AND PERMISSION NOTICE. ) 256 CONSTANT MAXSIEVE MAXSIEVE 1- 2 / CONSTANT FINALPASS 5 CONSTANT DISPWIDTH ( ENOUGH DIGITS ) ( TO DISPLAY MAXSIEVE ) ( BIF AND FIG HAVE NO DEFAULT ) ( BEHAVIOR FOR CREATE-D WORDS ) 0 VARIABLE SIEVE MAXSIEVE 2- ALLOT --> : SIEVEMAIN ( -- ) 0 SIEVE C! ( 0 IS NOT PRIME. ) 0 SIEVE 1+ C! ( 1 IS NOT PRIME. ) SIEVE MAXSIEVE 2 DO ( SET FLAGS TO TRUE ) ( FOR 2 TO FINALPASS. ) -1 OVER I + C! LOOP ( SIEVE PTR STILL ON STACK. ) FINALPASS 2 DO ( CLEAR FLAGS AT MULTIPLES. ) DUP I + C@ IF ( DON'T BOTHER IF NOT PRIME. ) MAXSIEVE I DUP + DO ( START AT FIRST MULTIPLE ) ( -- DOUBLE. ) 0 OVER I + C! ( CLEAR AT THIS MULTIPLE. ) J +LOOP ( SIEVE STILL ON STACK. ) ENDIF LOOP ( SIEVE STILL ON STACK. ) MAXSIEVE 0 DO I DISPWIDTH .R ." : IS " DUP I + C@ 0= IF ." NOT " ENDIF ." PRIME." CR LOOP DROP ; --> SIEVEMAIN ( 8 SECONDS ) ( FROM CALL TO SIEVEMAIN ) ( ON XROAR. ) ( FROM ROSETTA CODE ) ( MODIFIED TO GIVE ROOM ) ( FOR OTHER WORDS THAT ) ( USE THE HERE REGION ) ( WITHOUT ALLOCATION. ) ( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth ) ( USE BOTTOM TO MOVE ) ( OUT OF EXPECT BUFFER ) : BOTTOM HERE 256 + ; : PRIME? ( N -- ? ) BOTTOM + C@ 0= ; : COMPOSITE! ( N -- ) BOTTOM + 1 SWAP C! ; : 2DUP OVER OVER ; : SHOWPRIMES ." PRIMES: " 2 DO I PRIME? IF I . ENDIF LOOP ; --> : COUNTPRIMES ." PRIME COUNT: " 0 SWAP 2 DO I PRIME? IF 1+ ENDIF LOOP . ; : SIEVE ( N -- ) BOTTOM OVER ERASE 2 BEGIN 2DUP DUP * > WHILE DUP PRIME? IF 2DUP DUP * DO I COMPOSITE! DUP +LOOP ENDIF 1+ REPEAT DROP ; --> ( SIEVE DEFINED. ) ( EDIT SIEVE COUNT TO DO MORE ) ( SIEVE IS KEPT IN THE ) ( FREE RAM AREA, ) ( MOVED DOWN BY BOTTOM ) ( TO AVOID EXPECT-ED CONFLICT ) ( BUT IT DOESN'T WORK. ) ( SHOULD BE OKAY BEYOND 8192 ) 100 SIEVE DUP SHOWPRIMES COUNTPRIMES
\ No newline at end of file
旧リポジトリブラウザで表示