├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── cdp1802.v ├── go ├── ram.v ├── sim_main.cpp ├── software ├── CF1802.hex ├── anstests0.10 │ ├── alltest.fr │ ├── core.fr │ ├── coreexttest.fth │ ├── coreplustest.fth │ ├── doubletest.fth │ ├── exceptiontest.fth │ ├── filetest.fth │ ├── memorytest.fth │ ├── runtests.fth │ ├── searchordertest.fth │ ├── stringtest.fth │ ├── tester.fr │ └── toolstest.fth ├── blink.hex ├── intel2hex.py └── intelhex.py └── testbench.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.pyc 2 | unused 3 | obj_dir 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, James Bowman 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of verilog1802 nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | $(SUBDIRS): 3 | $(MAKE) -C $@ 4 | 5 | all: obj_dir/Vtestbench $(SUBDIRS) 6 | 7 | VERILOGS=testbench.v cdp1802.v ram.v 8 | 9 | obj_dir/Vtestbench: $(VERILOGS) sim_main.cpp Makefile 10 | verilator -Wall --cc --trace $(VERILOGS) --top-module testbench --l2-name v --exe sim_main.cpp 11 | $(MAKE) -C obj_dir OPT_FAST="-O2" -f Vtestbench.mk Vtestbench 12 | 13 | .PHONY: all 14 | 15 | clean: 16 | rm -rf obj_dir 17 | rm -f log 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | verilog1802 2 | =========== 3 | 4 | The RCA 1802 in Verilog. 5 | 6 | If you have 7 | [Verilator](http://www.veripool.org/wiki/verilator) 8 | installed then you should be able to build the simulator, 9 | and even run 10 | [CamelForth 1802](http://www.camelforth.com/page.php?9) 11 | interactively: 12 | 13 | $ make 14 | ... 15 | $ obj_dir/Vtestbench software/CF1802.hex 16 | RCA1802 CamelForth v1.3 18 Oct 2014 17 | 1 2 + . 18 | 3 19 | ok WORDS 20 | .SYMBOL TRACE ROLL CS-ROLL PICK CS-PICK 2R@ 2R> 2>R RESTORE-INPUT 21 | SAVE-INPUT [THEN] [IF] [ELSE] REFILL SOURCE-ID ENDCASE ENDOF OF CASE 22 | AHEAD BEGINLOOP ?DO 0> 0<> UNUSED MARKER FORGET (FORGET) CONVERT 23 | CREATE1 [COMPILE] 1. 2CONSTANT 2VARIABLE TO FINDWORD VALUE :NONAME 24 | ? DUMP .ADDR .BYTE .R U.R S.RJ ERASE BLANK SEARCH COMPARE -TRAILING \ 25 | SLITERAL CCSTR C" (C") .( PARSE COLD .S WORDS ENVIRONMENT? DEPTH MOVE 26 | WITHIN LEAVE +LOOP LOOP ENDLOOP DO L> >L REPEAT WHILE AGAIN UNTIL 27 | BEGIN ELSE THEN IF COMPILE POSTPONE ['] ; : IMMEDIATE REVEAL HIDE ] 28 | [ RECURSE DOES> (DOES>) CREATE (CREATE) ( [CHAR] CHAR ' ABORT" 29 | ?ABORT ABORT QUIT EVALUATE INTERPRET DICTERR ?NUMBER >NUMBER ?SIGN 30 | DIGIT? LITERAL FIND (FIND) NFA>CFA NFA>LFA WORD >COUNTED /STRING 31 | SOURCE C, , ALLOT HERE HEX DECIMAL . U. SIGN #> #S # >DIGIT <# HOLD 32 | UD* UD/MOD ." S" (S") TYPE ACCEPT UMAX UMIN SPACES SPACE CR COUNT 33 | 2OVER 2SWAP 2DUP 2DROP 2! 2@ MIN MAX */ */MOD MOD / /MOD * FM/MOD 34 | SM/REM M* DABS ?DNEGATE DNEGATE ABS ?NEGATE S>D #INIT UINIT R0 L0 35 | PAD S0 LP HP LATEST 'SOURCE DP STATE BASE >IN U0 TIB #TIB TIBSIZE 36 | BL !DEST ,DEST ,BRANCH ,EXIT COMPILE, >BODY CHARS CHAR+ CELLS CELL+ 37 | CELL ALIGNED ALIGN S= SCAN SKIP CMOVE> CMOVE FILL UM/MOD UM* UNLOOP J 38 | I (+loop) (loop) (do) ?BRANCH BRANCH U> U< > < <> = 0< 1 TRUE FALSE 39 | 0 -1 0= +! RSHIFT LSHIFT 2/ 2* >< 1- 1+ NEGATE INVERT XOR OR AND - 40 | M+ + C@ @ C! ! RP! RP@ SP! SP@ R@ R> >R TUCK NIP ROT OVER SWAP DROP 41 | DUP ?DUP BYE KEY EMIT ALIAS USER CONSTANT VARIABLE EXECUTE EXIT 42 | ok 43 | 44 | -------------------------------------------------------------------------------- /cdp1802.v: -------------------------------------------------------------------------------- 1 | `default_nettype none 2 | /* verilator lint_off UNOPTFLAT */ 3 | 4 | module cdp1802 ( 5 | input clock, 6 | input resetq, 7 | 8 | output reg Q, // external pin Q 9 | input [3:0] EF, // external flags EF1 to EF4 10 | 11 | input [7:0] io_din, // IO data in 12 | output [7:0] io_dout, // IO data out 13 | output [2:0] io_n, // IO control lines: N2,N1,N0 14 | output io_inp, // IO input signal 15 | output io_out, // IO output signal 16 | 17 | output unsupported,// unsupported instruction signal 18 | 19 | output ram_rd, // RAM read enable 20 | output ram_wr, // RAM write enable 21 | output [15:0] ram_a, // RAM address 22 | input [7:0] ram_q, // RAM read data 23 | output [7:0] ram_d // RAM write data 24 | ); 25 | 26 | // ---------- execution states ------------------------- 27 | reg [2:0] state, state_n; 28 | 29 | localparam RESET = 3'd0; // hardware reset asserted 30 | localparam FETCH = 3'd1; // fetching opcode from PC 31 | localparam EXECUTE = 3'd2; // main exection state 32 | localparam EXECUTE2 = 3'd3; // second execute, if memory was read 33 | localparam BRANCH2 = 3'd4; // long branch, collect new PC hi-byte 34 | localparam BRANCH3 = 3'd5; // short branch, new PC lo-byte 35 | localparam SKIP = 3'd6; // for untaken branch 36 | 37 | // ---------- registers -------------------------------- 38 | reg [3:0] P, X; 39 | 40 | reg [15:0] R[0:15]; // 16x16 register file 41 | wire [3:0] Ra; // which register to work on this clock 42 | wire [15:0] Rrd = R[Ra]; // read out the selected register 43 | reg [15:0] Rwd; // write-back value for the register 44 | 45 | reg [7:0] D; // data register (accumulator) 46 | reg DF; // data flag (ALU carry) 47 | reg [7:0] B; // used for hi-byte of long branch 48 | reg [7:0] ram_q_; // registered copy of ram_q, for multi-cycle ops 49 | wire [3:0] I, N; // the current instruction 50 | 51 | // ---------- RAM hookups ------------------------------ 52 | assign ram_d = (I == 4'h6) ? io_din : D; 53 | assign ram_a = Rrd; // RAM address always one of the 16-bit regs 54 | 55 | // ---------- conditional branch ----------------------- 56 | reg sense; 57 | always @* 58 | casez ({I, N}) 59 | {4'h3, 4'b?000}, {4'hc, 4'b??00}: sense = 1; 60 | {4'h3, 4'b?001}, {4'hc, 4'b??01}: sense = Q; 61 | {4'h3, 4'b?010}, {4'hc, 4'b??10}: sense = (D == 8'h00); 62 | {4'h3, 4'b?011}, {4'hc, 4'b??11}: sense = DF; 63 | {4'h3, 4'b?1??}: sense = EF[N[1:0]]; 64 | default: sense = 1'bx; 65 | endcase 66 | wire take = sense ^ N[3]; 67 | 68 | // ---------- fetch/execute ---------------------------- 69 | always @* 70 | case (state) 71 | FETCH: state_n = EXECUTE; 72 | EXECUTE: 73 | case (I) 74 | 4'h3: state_n = take ? BRANCH3 : FETCH; 75 | 4'hc: state_n = take ? BRANCH2 : SKIP; 76 | default: state_n = ram_rd ? EXECUTE2 : FETCH; 77 | endcase 78 | BRANCH2: state_n = BRANCH3; 79 | default: state_n = FETCH; 80 | endcase 81 | assign {I, N} = (state == EXECUTE) ? ram_q : ram_q_; 82 | 83 | // ---------- decode and execute ----------------------- 84 | wire [3:0] P_n = ((I == 4'hD)) ? N : P; // SEP 85 | wire [3:0] X_n = ((I == 4'hE)) ? N : X; // SEX 86 | wire Q_n = (({I, N} == 8'h7a) | ({I, N} == 8'h7b)) ? N[0] : Q; // REQ, SEQ 87 | 88 | reg [5:0] action; // reg. address; RAM rd; RAM wr 89 | assign {Ra, ram_rd, ram_wr} = action; 90 | 91 | localparam MEM___ = 2'b00; // no memory access 92 | localparam MEM_RD = 2'b10; // memory read strobe 93 | localparam MEM_WR = 2'b01; // memory write strobe 94 | 95 | always @* 96 | case (state) 97 | FETCH, BRANCH2, SKIP: {action, Rwd} = {P, MEM_RD, Rrd + 16'd1}; 98 | EXECUTE, EXECUTE2: 99 | casez ({I, N}) 100 | /* LDN */ 8'h0?: {action, Rwd} = {N, MEM_RD, Rrd}; 101 | /* INC */ 8'h1?: {action, Rwd} = {N, MEM___, Rrd + 16'd1}; 102 | /* DEC */ 8'h2?: {action, Rwd} = {N, MEM___, Rrd - 16'd1}; 103 | /* LDA */ 8'h4?: {action, Rwd} = {N, MEM_RD, Rrd + 16'd1}; 104 | /* STR */ 8'h5?: {action, Rwd} = {N, MEM_WR, Rrd}; 105 | /* SEP */ 8'hd?, 106 | /* SEX */ 8'he?, 107 | /* GLO */ 8'h8?, 108 | /* GHI */ 8'h9?: {action, Rwd} = {N, MEM___, Rrd}; 109 | /* PLO */ 8'ha?: {action, Rwd} = {N, MEM___, Rrd[15:8], D}; 110 | /* PHI */ 8'hb?: {action, Rwd} = {N, MEM___, D, Rrd[7:0]}; 111 | 112 | /* STXD */ 8'h73: {action, Rwd} = {X, MEM_WR, Rrd - 16'd1}; 113 | /* LDXA */ 8'h72, 114 | /* OUT */ {4'h6, 4'b0???}: {action, Rwd} = {X, MEM_RD, Rrd + 16'd1}; 115 | /* INP */ {4'h6, 4'b1???}: {action, Rwd} = {X, MEM_WR, Rrd}; 116 | 117 | /* immediate and branch instructions must fetch from R[P] */ 118 | 8'h7c, 8'h7d, 8'h7f, 8'hf8, 8'hf9, 8'hfa, 8'hfb, 8'hfc, 8'hfd, 8'hff, 119 | 8'h3?, 8'hc?: {action, Rwd} = {P, MEM_RD, Rrd + 16'd1}; 120 | 121 | default: {action, Rwd} = {X, MEM_RD, Rrd}; 122 | endcase 123 | BRANCH3: {action, Rwd} = {P, MEM___, (I == 4'hc) ? B : Rrd[15:8], ram_q}; 124 | default: {action, Rwd} = {X, MEM___, Rrd}; 125 | endcase 126 | 127 | wire [8:0] carry = (I[3]) ? 9'd0 : {8'd0, DF}; // 0 or 1 for ADC 128 | wire [8:0] borrow = (I[3]) ? 9'd0 : ~{9{DF}}; // -1 or 0 for SDB and SMB 129 | reg [8:0] DFD_n; 130 | always @* 131 | casez ({I, N}) 132 | /* LDXA */ 8'h72, 133 | /* LDX */ 8'hf0, 134 | /* LDI */ 8'hf8, 135 | /* LDA */ 8'h4?, 136 | /* LDN */ 8'h0?: DFD_n = {DF, ram_q}; 137 | /* GLO */ 8'h8?: DFD_n = {DF, Rrd[7:0]}; 138 | /* GHI */ 8'h9?: DFD_n = {DF, Rrd[15:8]}; 139 | /* INP */ 8'b0110_1???: DFD_n = {DF, io_din}; 140 | /* OR */ 8'b1111_?001: DFD_n = {DF, D | ram_q}; 141 | /* AND */ 8'b1111_?010: DFD_n = {DF, D & ram_q}; 142 | /* XOR */ 8'b1111_?011: DFD_n = {DF, D ^ ram_q}; 143 | /* ADD */ 8'b?111_?100: DFD_n = {1'b0, D} + {1'b0, ram_q} + carry; 144 | /* SD */ 8'b?111_?101: DFD_n = ({1'b1, ram_q} - {1'b0, D}) + borrow; 145 | /* SM */ 8'b?111_?111: DFD_n = ({1'b1, D} - {1'b0, ram_q}) + borrow; 146 | /* SHR */ 8'b?111_0110: DFD_n = {D[0], carry[0], D[7:1]}; 147 | /* SHL */ 8'b?111_1110: DFD_n = {D, carry[0]}; 148 | default: DFD_n = {DF, D}; 149 | endcase 150 | 151 | assign io_n = N[2:0]; 152 | assign io_out = (I == 4'h6) & ~N[3] & (state == EXECUTE2) & (N[2:0] != 3'b000); 153 | assign io_inp = (I == 4'h6) & N[3] & (state == EXECUTE) & (N[2:0] != 3'b000); 154 | assign io_dout = ram_q; 155 | assign unsupported = {I, N} == 8'h70; 156 | 157 | // ---------- cycle commit ----------------------------- 158 | always @(negedge resetq or posedge clock) 159 | if (!resetq) begin 160 | {ram_q_, Q, P, X} <= 0; 161 | {DF, D} <= 9'd0; 162 | R[0] <= 16'd0; 163 | state <= RESET; 164 | end else begin 165 | state <= state_n; 166 | if (state == EXECUTE) 167 | {ram_q_, Q, P, X} <= {ram_q, Q_n, P_n, X_n}; 168 | if (state != EXECUTE2) 169 | R[Ra] <= Rwd; 170 | if (((state == EXECUTE) & !ram_rd) || (state == EXECUTE2)) 171 | {DF, D} <= DFD_n; 172 | if (state == BRANCH2) 173 | B <= ram_q; 174 | end 175 | 176 | endmodule 177 | -------------------------------------------------------------------------------- /go: -------------------------------------------------------------------------------- 1 | set -e 2 | # python prepare.py ; exit 3 | make 4 | # obj_dir/Vtestbench software/CF1802.hex 5 | ANS=software/anstests0.10 6 | echo BYE | cat $ANS/tester.fr $ANS/core.fr - >0 7 | time obj_dir/Vtestbench software/CF1802.hex < 0 8 | # time echo BYE | cat $ANS/tester.fr $ANS/core.fr - | obj_dir/Vtestbench software/CF1802.hex 9 | grep RESULT log || true 10 | # ./1802sim CF1802 ; exit 11 | # ./1802sim CF1802 < _1 12 | # qdiff /data/xlog /data/1 13 | -------------------------------------------------------------------------------- /ram.v: -------------------------------------------------------------------------------- 1 | `default_nettype none 2 | 3 | module ram( 4 | input clk, 5 | /* verilator lint_off UNUSED */ 6 | input [15:0] a, 7 | /* verilator lint_on UNUSED */ 8 | input [7:0] d, 9 | input we, 10 | input re, 11 | output reg [7:0] q); 12 | reg [7:0] store[0:32767] /* verilator public_flat */; 13 | 14 | always @(posedge clk) 15 | if (we) begin 16 | store[a[14:0]] <= d; 17 | end else if (re) 18 | q <= store[a[14:0]]; 19 | endmodule 20 | -------------------------------------------------------------------------------- /sim_main.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "Vtestbench.h" 3 | #include "verilated_vcd_c.h" 4 | // This include and the top->rootp syntax are proper for Verilator >= 4.210 5 | #include "Vtestbench___024root.h" 6 | 7 | int main(int argc, char **argv) 8 | { 9 | Verilated::commandArgs(argc, argv); 10 | Vtestbench* top = new Vtestbench; 11 | 12 | // Verilated::traceEverOn(true); 13 | // VerilatedVcdC* tfp = new VerilatedVcdC; 14 | // top->trace (tfp, 99); 15 | // tfp->open ("simx.vcd"); 16 | 17 | if (argc != 2) { 18 | fprintf(stderr, "usage: sim \n"); 19 | exit(1); 20 | } 21 | 22 | FILE *hex = fopen(argv[1], "r"); 23 | int i; 24 | for (i = 0; i < 32768; i++) { 25 | unsigned int v; 26 | if (fscanf(hex, "%x\n", &v) != 1) { 27 | fprintf(stderr, "invalid hex value at line %d\n", i + 1); 28 | exit(1); 29 | } 30 | top->rootp->v__DOT___ram__DOT__store[i] = v; 31 | } 32 | 33 | FILE *log = fopen("log", "w"); 34 | int t = 0; 35 | for (i = 0; !top->unsupported; i++) { 36 | top->clock = 1; 37 | top->eval(); 38 | // tfp->dump(t); 39 | t += 20; 40 | 41 | top->clock = 0; 42 | top->eval(); 43 | // tfp->dump(t); 44 | t += 20; 45 | if (top->io_out && (top->io_n == 1)) { 46 | putchar(top->io_dout); 47 | putc(top->io_dout, log); 48 | } 49 | if (top->io_inp && (top->io_n == 2)) { 50 | top->io_din = getchar(); 51 | } 52 | } 53 | printf("Simulation ended after %d cycles\n", i); 54 | delete top; 55 | // tfp->close(); 56 | fclose(log); 57 | 58 | exit(0); 59 | } 60 | -------------------------------------------------------------------------------- /software/anstests0.10/alltest.fr: -------------------------------------------------------------------------------- 1 | \ From: John Hayes S1I 2 | \ Subject: tester.fr 3 | \ Date: Mon, 27 Nov 95 13:10:09 PST 4 | 5 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7 | \ VERSION 1.1 8 | 9 | \ 22/1/09 The words { and } have been changed to T{ and }T respectively to 10 | \ agree with the Forth 200X file ttester.fs. This avoids clashes with 11 | \ locals using { ... } and the FSL use of } 12 | 13 | HEX 14 | 15 | \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 16 | \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 17 | VARIABLE VERBOSE 18 | FALSE VERBOSE ! 19 | \ TRUE VERBOSE ! 20 | 21 | : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 22 | DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; 23 | 24 | : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 25 | \ THE LINE THAT HAD THE ERROR. 26 | TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR 27 | EMPTY-STACK \ THROW AWAY EVERY THING ELSE 28 | \ QUIT \ *** Uncomment this line to QUIT on an error 29 | ; 30 | 31 | VARIABLE ACTUAL-DEPTH \ STACK RECORD 32 | CREATE ACTUAL-RESULTS 20 CELLS ALLOT 33 | 34 | : T{ \ ( -- ) SYNTACTIC SUGAR. 35 | ; 36 | 37 | : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 38 | DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 39 | ?DUP IF \ IF THERE IS SOMETHING ON STACK 40 | 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 41 | THEN ; 42 | 43 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 44 | \ (ACTUAL) CONTENTS. 45 | DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 46 | DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 47 | 0 DO \ FOR EACH STACK ITEM 48 | ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 49 | <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 50 | LOOP 51 | THEN 52 | ELSE \ DEPTH MISMATCH 53 | S" WRONG NUMBER OF RESULTS: " ERROR 54 | THEN ; 55 | 56 | : TESTING \ ( -- ) TALKING COMMENT. 57 | SOURCE VERBOSE @ 58 | IF DUP >R TYPE CR R> >IN ! 59 | ELSE >IN ! DROP [CHAR] * EMIT 60 | THEN ; 61 | 62 | \ From: John Hayes S1I 63 | \ Subject: core.fr 64 | \ Date: Mon, 27 Nov 95 13:10 65 | 66 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 67 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 68 | \ VERSION 1.2 69 | \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. 70 | \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE 71 | \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND 72 | \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. 73 | \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... 74 | \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... 75 | 76 | CR 77 | TESTING CORE WORDS 78 | HEX 79 | 80 | \ ------------------------------------------------------------------------ 81 | TESTING BASIC ASSUMPTIONS 82 | 83 | T{ -> }T \ START WITH CLEAN SLATE 84 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 85 | T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T 86 | T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) 87 | T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 88 | T{ -1 BITSSET? -> 0 0 }T 89 | 90 | \ ------------------------------------------------------------------------ 91 | TESTING BOOLEANS: INVERT AND OR XOR 92 | 93 | T{ 0 0 AND -> 0 }T 94 | T{ 0 1 AND -> 0 }T 95 | T{ 1 0 AND -> 0 }T 96 | T{ 1 1 AND -> 1 }T 97 | 98 | T{ 0 INVERT 1 AND -> 1 }T 99 | T{ 1 INVERT 1 AND -> 0 }T 100 | 101 | 0 CONSTANT 0S 102 | 0 INVERT CONSTANT 1S 103 | 104 | T{ 0S INVERT -> 1S }T 105 | T{ 1S INVERT -> 0S }T 106 | 107 | T{ 0S 0S AND -> 0S }T 108 | T{ 0S 1S AND -> 0S }T 109 | T{ 1S 0S AND -> 0S }T 110 | T{ 1S 1S AND -> 1S }T 111 | 112 | T{ 0S 0S OR -> 0S }T 113 | T{ 0S 1S OR -> 1S }T 114 | T{ 1S 0S OR -> 1S }T 115 | T{ 1S 1S OR -> 1S }T 116 | 117 | T{ 0S 0S XOR -> 0S }T 118 | T{ 0S 1S XOR -> 1S }T 119 | T{ 1S 0S XOR -> 1S }T 120 | T{ 1S 1S XOR -> 0S }T 121 | 122 | \ ------------------------------------------------------------------------ 123 | TESTING 2* 2/ LSHIFT RSHIFT 124 | 125 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 126 | 1S 1 RSHIFT INVERT CONSTANT MSB 127 | T{ MSB BITSSET? -> 0 0 }T 128 | 129 | T{ 0S 2* -> 0S }T 130 | T{ 1 2* -> 2 }T 131 | T{ 4000 2* -> 8000 }T 132 | T{ 1S 2* 1 XOR -> 1S }T 133 | T{ MSB 2* -> 0S }T 134 | 135 | T{ 0S 2/ -> 0S }T 136 | T{ 1 2/ -> 0 }T 137 | T{ 4000 2/ -> 2000 }T 138 | T{ 1S 2/ -> 1S }T \ MSB PROPOGATED 139 | T{ 1S 1 XOR 2/ -> 1S }T 140 | T{ MSB 2/ MSB AND -> MSB }T 141 | 142 | T{ 1 0 LSHIFT -> 1 }T 143 | T{ 1 1 LSHIFT -> 2 }T 144 | T{ 1 2 LSHIFT -> 4 }T 145 | T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT 146 | T{ 1S 1 LSHIFT 1 XOR -> 1S }T 147 | T{ MSB 1 LSHIFT -> 0 }T 148 | 149 | T{ 1 0 RSHIFT -> 1 }T 150 | T{ 1 1 RSHIFT -> 0 }T 151 | T{ 2 1 RSHIFT -> 1 }T 152 | T{ 4 2 RSHIFT -> 1 }T 153 | T{ 8000 F RSHIFT -> 1 }T \ BIGGEST 154 | T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS 155 | T{ MSB 1 RSHIFT 2* -> MSB }T 156 | 157 | \ ------------------------------------------------------------------------ 158 | TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 159 | 0 INVERT CONSTANT MAX-UINT 160 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT 161 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 162 | 0 INVERT 1 RSHIFT CONSTANT MID-UINT 163 | 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 164 | 165 | 0S CONSTANT 166 | 1S CONSTANT 167 | 168 | T{ 0 0= -> }T 169 | T{ 1 0= -> }T 170 | T{ 2 0= -> }T 171 | T{ -1 0= -> }T 172 | T{ MAX-UINT 0= -> }T 173 | T{ MIN-INT 0= -> }T 174 | T{ MAX-INT 0= -> }T 175 | 176 | T{ 0 0 = -> }T 177 | T{ 1 1 = -> }T 178 | T{ -1 -1 = -> }T 179 | T{ 1 0 = -> }T 180 | T{ -1 0 = -> }T 181 | T{ 0 1 = -> }T 182 | T{ 0 -1 = -> }T 183 | 184 | T{ 0 0< -> }T 185 | T{ -1 0< -> }T 186 | T{ MIN-INT 0< -> }T 187 | T{ 1 0< -> }T 188 | T{ MAX-INT 0< -> }T 189 | 190 | T{ 0 1 < -> }T 191 | T{ 1 2 < -> }T 192 | T{ -1 0 < -> }T 193 | T{ -1 1 < -> }T 194 | T{ MIN-INT 0 < -> }T 195 | T{ MIN-INT MAX-INT < -> }T 196 | T{ 0 MAX-INT < -> }T 197 | T{ 0 0 < -> }T 198 | T{ 1 1 < -> }T 199 | T{ 1 0 < -> }T 200 | T{ 2 1 < -> }T 201 | T{ 0 -1 < -> }T 202 | T{ 1 -1 < -> }T 203 | T{ 0 MIN-INT < -> }T 204 | T{ MAX-INT MIN-INT < -> }T 205 | T{ MAX-INT 0 < -> }T 206 | 207 | T{ 0 1 > -> }T 208 | T{ 1 2 > -> }T 209 | T{ -1 0 > -> }T 210 | T{ -1 1 > -> }T 211 | T{ MIN-INT 0 > -> }T 212 | T{ MIN-INT MAX-INT > -> }T 213 | T{ 0 MAX-INT > -> }T 214 | T{ 0 0 > -> }T 215 | T{ 1 1 > -> }T 216 | T{ 1 0 > -> }T 217 | T{ 2 1 > -> }T 218 | T{ 0 -1 > -> }T 219 | T{ 1 -1 > -> }T 220 | T{ 0 MIN-INT > -> }T 221 | T{ MAX-INT MIN-INT > -> }T 222 | T{ MAX-INT 0 > -> }T 223 | 224 | T{ 0 1 U< -> }T 225 | T{ 1 2 U< -> }T 226 | T{ 0 MID-UINT U< -> }T 227 | T{ 0 MAX-UINT U< -> }T 228 | T{ MID-UINT MAX-UINT U< -> }T 229 | T{ 0 0 U< -> }T 230 | T{ 1 1 U< -> }T 231 | T{ 1 0 U< -> }T 232 | T{ 2 1 U< -> }T 233 | T{ MID-UINT 0 U< -> }T 234 | T{ MAX-UINT 0 U< -> }T 235 | T{ MAX-UINT MID-UINT U< -> }T 236 | 237 | T{ 0 1 MIN -> 0 }T 238 | T{ 1 2 MIN -> 1 }T 239 | T{ -1 0 MIN -> -1 }T 240 | T{ -1 1 MIN -> -1 }T 241 | T{ MIN-INT 0 MIN -> MIN-INT }T 242 | T{ MIN-INT MAX-INT MIN -> MIN-INT }T 243 | T{ 0 MAX-INT MIN -> 0 }T 244 | T{ 0 0 MIN -> 0 }T 245 | T{ 1 1 MIN -> 1 }T 246 | T{ 1 0 MIN -> 0 }T 247 | T{ 2 1 MIN -> 1 }T 248 | T{ 0 -1 MIN -> -1 }T 249 | T{ 1 -1 MIN -> -1 }T 250 | T{ 0 MIN-INT MIN -> MIN-INT }T 251 | T{ MAX-INT MIN-INT MIN -> MIN-INT }T 252 | T{ MAX-INT 0 MIN -> 0 }T 253 | 254 | T{ 0 1 MAX -> 1 }T 255 | T{ 1 2 MAX -> 2 }T 256 | T{ -1 0 MAX -> 0 }T 257 | T{ -1 1 MAX -> 1 }T 258 | T{ MIN-INT 0 MAX -> 0 }T 259 | T{ MIN-INT MAX-INT MAX -> MAX-INT }T 260 | T{ 0 MAX-INT MAX -> MAX-INT }T 261 | T{ 0 0 MAX -> 0 }T 262 | T{ 1 1 MAX -> 1 }T 263 | T{ 1 0 MAX -> 1 }T 264 | T{ 2 1 MAX -> 2 }T 265 | T{ 0 -1 MAX -> 0 }T 266 | T{ 1 -1 MAX -> 1 }T 267 | T{ 0 MIN-INT MAX -> 0 }T 268 | T{ MAX-INT MIN-INT MAX -> MAX-INT }T 269 | T{ MAX-INT 0 MAX -> MAX-INT }T 270 | 271 | \ ------------------------------------------------------------------------ 272 | TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP 273 | 274 | T{ 1 2 2DROP -> }T 275 | T{ 1 2 2DUP -> 1 2 1 2 }T 276 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 277 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 278 | T{ 0 ?DUP -> 0 }T 279 | T{ 1 ?DUP -> 1 1 }T 280 | T{ -1 ?DUP -> -1 -1 }T 281 | T{ DEPTH -> 0 }T 282 | T{ 0 DEPTH -> 0 1 }T 283 | T{ 0 1 DEPTH -> 0 1 2 }T 284 | T{ 0 DROP -> }T 285 | T{ 1 2 DROP -> 1 }T 286 | T{ 1 DUP -> 1 1 }T 287 | T{ 1 2 OVER -> 1 2 1 }T 288 | T{ 1 2 3 ROT -> 2 3 1 }T 289 | T{ 1 2 SWAP -> 2 1 }T 290 | 291 | \ ------------------------------------------------------------------------ 292 | TESTING >R R> R@ 293 | 294 | T{ : GR1 >R R> ; -> }T 295 | T{ : GR2 >R R@ R> DROP ; -> }T 296 | T{ 123 GR1 -> 123 }T 297 | T{ 123 GR2 -> 123 }T 298 | T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) 299 | 300 | \ ------------------------------------------------------------------------ 301 | TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE 302 | 303 | T{ 0 5 + -> 5 }T 304 | T{ 5 0 + -> 5 }T 305 | T{ 0 -5 + -> -5 }T 306 | T{ -5 0 + -> -5 }T 307 | T{ 1 2 + -> 3 }T 308 | T{ 1 -2 + -> -1 }T 309 | T{ -1 2 + -> 1 }T 310 | T{ -1 -2 + -> -3 }T 311 | T{ -1 1 + -> 0 }T 312 | T{ MID-UINT 1 + -> MID-UINT+1 }T 313 | 314 | T{ 0 5 - -> -5 }T 315 | T{ 5 0 - -> 5 }T 316 | T{ 0 -5 - -> 5 }T 317 | T{ -5 0 - -> -5 }T 318 | T{ 1 2 - -> -1 }T 319 | T{ 1 -2 - -> 3 }T 320 | T{ -1 2 - -> -3 }T 321 | T{ -1 -2 - -> 1 }T 322 | T{ 0 1 - -> -1 }T 323 | T{ MID-UINT+1 1 - -> MID-UINT }T 324 | 325 | T{ 0 1+ -> 1 }T 326 | T{ -1 1+ -> 0 }T 327 | T{ 1 1+ -> 2 }T 328 | T{ MID-UINT 1+ -> MID-UINT+1 }T 329 | 330 | T{ 2 1- -> 1 }T 331 | T{ 1 1- -> 0 }T 332 | T{ 0 1- -> -1 }T 333 | T{ MID-UINT+1 1- -> MID-UINT }T 334 | 335 | T{ 0 NEGATE -> 0 }T 336 | T{ 1 NEGATE -> -1 }T 337 | T{ -1 NEGATE -> 1 }T 338 | T{ 2 NEGATE -> -2 }T 339 | T{ -2 NEGATE -> 2 }T 340 | 341 | T{ 0 ABS -> 0 }T 342 | T{ 1 ABS -> 1 }T 343 | T{ -1 ABS -> 1 }T 344 | T{ MIN-INT ABS -> MID-UINT+1 }T 345 | 346 | \ ------------------------------------------------------------------------ 347 | TESTING MULTIPLY: S>D * M* UM* 348 | 349 | T{ 0 S>D -> 0 0 }T 350 | T{ 1 S>D -> 1 0 }T 351 | T{ 2 S>D -> 2 0 }T 352 | T{ -1 S>D -> -1 -1 }T 353 | T{ -2 S>D -> -2 -1 }T 354 | T{ MIN-INT S>D -> MIN-INT -1 }T 355 | T{ MAX-INT S>D -> MAX-INT 0 }T 356 | 357 | T{ 0 0 M* -> 0 S>D }T 358 | T{ 0 1 M* -> 0 S>D }T 359 | T{ 1 0 M* -> 0 S>D }T 360 | T{ 1 2 M* -> 2 S>D }T 361 | T{ 2 1 M* -> 2 S>D }T 362 | T{ 3 3 M* -> 9 S>D }T 363 | T{ -3 3 M* -> -9 S>D }T 364 | T{ 3 -3 M* -> -9 S>D }T 365 | T{ -3 -3 M* -> 9 S>D }T 366 | T{ 0 MIN-INT M* -> 0 S>D }T 367 | T{ 1 MIN-INT M* -> MIN-INT S>D }T 368 | T{ 2 MIN-INT M* -> 0 1S }T 369 | T{ 0 MAX-INT M* -> 0 S>D }T 370 | T{ 1 MAX-INT M* -> MAX-INT S>D }T 371 | T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T 372 | T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T 373 | T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T 374 | T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T 375 | 376 | T{ 0 0 * -> 0 }T \ TEST IDENTITIES 377 | T{ 0 1 * -> 0 }T 378 | T{ 1 0 * -> 0 }T 379 | T{ 1 2 * -> 2 }T 380 | T{ 2 1 * -> 2 }T 381 | T{ 3 3 * -> 9 }T 382 | T{ -3 3 * -> -9 }T 383 | T{ 3 -3 * -> -9 }T 384 | T{ -3 -3 * -> 9 }T 385 | 386 | T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T 387 | T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T 388 | T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T 389 | 390 | T{ 0 0 UM* -> 0 0 }T 391 | T{ 0 1 UM* -> 0 0 }T 392 | T{ 1 0 UM* -> 0 0 }T 393 | T{ 1 2 UM* -> 2 0 }T 394 | T{ 2 1 UM* -> 2 0 }T 395 | T{ 3 3 UM* -> 9 0 }T 396 | 397 | T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T 398 | T{ MID-UINT+1 2 UM* -> 0 1 }T 399 | T{ MID-UINT+1 4 UM* -> 0 2 }T 400 | T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T 401 | T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T 402 | 403 | \ ------------------------------------------------------------------------ 404 | TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD 405 | 406 | T{ 0 S>D 1 FM/MOD -> 0 0 }T 407 | T{ 1 S>D 1 FM/MOD -> 0 1 }T 408 | T{ 2 S>D 1 FM/MOD -> 0 2 }T 409 | T{ -1 S>D 1 FM/MOD -> 0 -1 }T 410 | T{ -2 S>D 1 FM/MOD -> 0 -2 }T 411 | T{ 0 S>D -1 FM/MOD -> 0 0 }T 412 | T{ 1 S>D -1 FM/MOD -> 0 -1 }T 413 | T{ 2 S>D -1 FM/MOD -> 0 -2 }T 414 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 415 | T{ -2 S>D -1 FM/MOD -> 0 2 }T 416 | T{ 2 S>D 2 FM/MOD -> 0 1 }T 417 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 418 | T{ -2 S>D -2 FM/MOD -> 0 1 }T 419 | T{ 7 S>D 3 FM/MOD -> 1 2 }T 420 | T{ 7 S>D -3 FM/MOD -> -2 -3 }T 421 | T{ -7 S>D 3 FM/MOD -> 2 -3 }T 422 | T{ -7 S>D -3 FM/MOD -> -1 2 }T 423 | T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T 424 | T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T 425 | T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T 426 | T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T 427 | T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T 428 | T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T 429 | T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T 430 | T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T 431 | T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T 432 | T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T 433 | T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T 434 | T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T 435 | T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T 436 | T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T 437 | T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T 438 | T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T 439 | T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T 440 | 441 | T{ 0 S>D 1 SM/REM -> 0 0 }T 442 | T{ 1 S>D 1 SM/REM -> 0 1 }T 443 | T{ 2 S>D 1 SM/REM -> 0 2 }T 444 | T{ -1 S>D 1 SM/REM -> 0 -1 }T 445 | T{ -2 S>D 1 SM/REM -> 0 -2 }T 446 | T{ 0 S>D -1 SM/REM -> 0 0 }T 447 | T{ 1 S>D -1 SM/REM -> 0 -1 }T 448 | T{ 2 S>D -1 SM/REM -> 0 -2 }T 449 | T{ -1 S>D -1 SM/REM -> 0 1 }T 450 | T{ -2 S>D -1 SM/REM -> 0 2 }T 451 | T{ 2 S>D 2 SM/REM -> 0 1 }T 452 | T{ -1 S>D -1 SM/REM -> 0 1 }T 453 | T{ -2 S>D -2 SM/REM -> 0 1 }T 454 | T{ 7 S>D 3 SM/REM -> 1 2 }T 455 | T{ 7 S>D -3 SM/REM -> 1 -2 }T 456 | T{ -7 S>D 3 SM/REM -> -1 -2 }T 457 | T{ -7 S>D -3 SM/REM -> -1 2 }T 458 | T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T 459 | T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T 460 | T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T 461 | T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T 462 | T{ 1S 1 4 SM/REM -> 3 MAX-INT }T 463 | T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T 464 | T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T 465 | T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T 466 | T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T 467 | T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T 468 | T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T 469 | T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T 470 | T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T 471 | 472 | T{ 0 0 1 UM/MOD -> 0 0 }T 473 | T{ 1 0 1 UM/MOD -> 0 1 }T 474 | T{ 1 0 2 UM/MOD -> 1 0 }T 475 | T{ 3 0 2 UM/MOD -> 1 1 }T 476 | T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T 477 | T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T 478 | T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T 479 | 480 | : IFFLOORED 481 | [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; 482 | 483 | : IFSYM 484 | [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; 485 | 486 | \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. 487 | \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. 488 | 489 | IFFLOORED : T/MOD >R S>D R> FM/MOD ; 490 | IFFLOORED : T/ T/MOD SWAP DROP ; 491 | IFFLOORED : TMOD T/MOD DROP ; 492 | IFFLOORED : T*/MOD >R M* R> FM/MOD ; 493 | IFFLOORED : T*/ T*/MOD SWAP DROP ; 494 | IFSYM : T/MOD >R S>D R> SM/REM ; 495 | IFSYM : T/ T/MOD SWAP DROP ; 496 | IFSYM : TMOD T/MOD DROP ; 497 | IFSYM : T*/MOD >R M* R> SM/REM ; 498 | IFSYM : T*/ T*/MOD SWAP DROP ; 499 | 500 | T{ 0 1 /MOD -> 0 1 T/MOD }T 501 | T{ 1 1 /MOD -> 1 1 T/MOD }T 502 | T{ 2 1 /MOD -> 2 1 T/MOD }T 503 | T{ -1 1 /MOD -> -1 1 T/MOD }T 504 | T{ -2 1 /MOD -> -2 1 T/MOD }T 505 | T{ 0 -1 /MOD -> 0 -1 T/MOD }T 506 | T{ 1 -1 /MOD -> 1 -1 T/MOD }T 507 | T{ 2 -1 /MOD -> 2 -1 T/MOD }T 508 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 509 | T{ -2 -1 /MOD -> -2 -1 T/MOD }T 510 | T{ 2 2 /MOD -> 2 2 T/MOD }T 511 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 512 | T{ -2 -2 /MOD -> -2 -2 T/MOD }T 513 | T{ 7 3 /MOD -> 7 3 T/MOD }T 514 | T{ 7 -3 /MOD -> 7 -3 T/MOD }T 515 | T{ -7 3 /MOD -> -7 3 T/MOD }T 516 | T{ -7 -3 /MOD -> -7 -3 T/MOD }T 517 | T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T 518 | T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T 519 | T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T 520 | T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T 521 | 522 | T{ 0 1 / -> 0 1 T/ }T 523 | T{ 1 1 / -> 1 1 T/ }T 524 | T{ 2 1 / -> 2 1 T/ }T 525 | T{ -1 1 / -> -1 1 T/ }T 526 | T{ -2 1 / -> -2 1 T/ }T 527 | T{ 0 -1 / -> 0 -1 T/ }T 528 | T{ 1 -1 / -> 1 -1 T/ }T 529 | T{ 2 -1 / -> 2 -1 T/ }T 530 | T{ -1 -1 / -> -1 -1 T/ }T 531 | T{ -2 -1 / -> -2 -1 T/ }T 532 | T{ 2 2 / -> 2 2 T/ }T 533 | T{ -1 -1 / -> -1 -1 T/ }T 534 | T{ -2 -2 / -> -2 -2 T/ }T 535 | T{ 7 3 / -> 7 3 T/ }T 536 | T{ 7 -3 / -> 7 -3 T/ }T 537 | T{ -7 3 / -> -7 3 T/ }T 538 | T{ -7 -3 / -> -7 -3 T/ }T 539 | T{ MAX-INT 1 / -> MAX-INT 1 T/ }T 540 | T{ MIN-INT 1 / -> MIN-INT 1 T/ }T 541 | T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T 542 | T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T 543 | 544 | T{ 0 1 MOD -> 0 1 TMOD }T 545 | T{ 1 1 MOD -> 1 1 TMOD }T 546 | T{ 2 1 MOD -> 2 1 TMOD }T 547 | T{ -1 1 MOD -> -1 1 TMOD }T 548 | T{ -2 1 MOD -> -2 1 TMOD }T 549 | T{ 0 -1 MOD -> 0 -1 TMOD }T 550 | T{ 1 -1 MOD -> 1 -1 TMOD }T 551 | T{ 2 -1 MOD -> 2 -1 TMOD }T 552 | T{ -1 -1 MOD -> -1 -1 TMOD }T 553 | T{ -2 -1 MOD -> -2 -1 TMOD }T 554 | T{ 2 2 MOD -> 2 2 TMOD }T 555 | T{ -1 -1 MOD -> -1 -1 TMOD }T 556 | T{ -2 -2 MOD -> -2 -2 TMOD }T 557 | T{ 7 3 MOD -> 7 3 TMOD }T 558 | T{ 7 -3 MOD -> 7 -3 TMOD }T 559 | T{ -7 3 MOD -> -7 3 TMOD }T 560 | T{ -7 -3 MOD -> -7 -3 TMOD }T 561 | T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T 562 | T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T 563 | T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T 564 | T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T 565 | 566 | T{ 0 2 1 */ -> 0 2 1 T*/ }T 567 | T{ 1 2 1 */ -> 1 2 1 T*/ }T 568 | T{ 2 2 1 */ -> 2 2 1 T*/ }T 569 | T{ -1 2 1 */ -> -1 2 1 T*/ }T 570 | T{ -2 2 1 */ -> -2 2 1 T*/ }T 571 | T{ 0 2 -1 */ -> 0 2 -1 T*/ }T 572 | T{ 1 2 -1 */ -> 1 2 -1 T*/ }T 573 | T{ 2 2 -1 */ -> 2 2 -1 T*/ }T 574 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 575 | T{ -2 2 -1 */ -> -2 2 -1 T*/ }T 576 | T{ 2 2 2 */ -> 2 2 2 T*/ }T 577 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 578 | T{ -2 2 -2 */ -> -2 2 -2 T*/ }T 579 | T{ 7 2 3 */ -> 7 2 3 T*/ }T 580 | T{ 7 2 -3 */ -> 7 2 -3 T*/ }T 581 | T{ -7 2 3 */ -> -7 2 3 T*/ }T 582 | T{ -7 2 -3 */ -> -7 2 -3 T*/ }T 583 | T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T 584 | T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T 585 | 586 | T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T 587 | T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T 588 | T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T 589 | T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T 590 | T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T 591 | T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T 592 | T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T 593 | T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T 594 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 595 | T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T 596 | T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T 597 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 598 | T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T 599 | T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T 600 | T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T 601 | T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T 602 | T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T 603 | T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T 604 | T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T 605 | 606 | \ ------------------------------------------------------------------------ 607 | TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT 608 | 609 | HERE 1 ALLOT 610 | HERE 611 | CONSTANT 2NDA 612 | CONSTANT 1STA 613 | T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT 614 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 615 | ( MISSING TEST: NEGATIVE ALLOT ) 616 | 617 | HERE 1 , 618 | HERE 2 , 619 | CONSTANT 2ND 620 | CONSTANT 1ST 621 | T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT 622 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 623 | T{ 1ST 1 CELLS + -> 2ND }T 624 | T{ 1ST @ 2ND @ -> 1 2 }T 625 | T{ 5 1ST ! -> }T 626 | T{ 1ST @ 2ND @ -> 5 2 }T 627 | T{ 6 2ND ! -> }T 628 | T{ 1ST @ 2ND @ -> 5 6 }T 629 | T{ 1ST 2@ -> 6 5 }T 630 | T{ 2 1 1ST 2! -> }T 631 | T{ 1ST 2@ -> 2 1 }T 632 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 633 | 634 | HERE 1 C, 635 | HERE 2 C, 636 | CONSTANT 2NDC 637 | CONSTANT 1STC 638 | T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT 639 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 640 | T{ 1STC 1 CHARS + -> 2NDC }T 641 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 642 | T{ 3 1STC C! -> }T 643 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 644 | T{ 4 2NDC C! -> }T 645 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 646 | 647 | ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT 648 | CONSTANT A-ADDR CONSTANT UA-ADDR 649 | T{ UA-ADDR ALIGNED -> A-ADDR }T 650 | T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T 651 | T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T 652 | T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T 653 | T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T 654 | T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T 655 | T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T 656 | T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T 657 | 658 | : BITS ( X -- U ) 659 | 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; 660 | ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) 661 | T{ 1 CHARS 1 < -> }T 662 | T{ 1 CHARS 1 CELLS > -> }T 663 | ( TBD: HOW TO FIND NUMBER OF BITS? ) 664 | 665 | ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) 666 | T{ 1 CELLS 1 < -> }T 667 | T{ 1 CELLS 1 CHARS MOD -> 0 }T 668 | T{ 1S BITS 10 < -> }T 669 | 670 | T{ 0 1ST ! -> }T 671 | T{ 1 1ST +! -> }T 672 | T{ 1ST @ -> 1 }T 673 | T{ -1 1ST +! 1ST @ -> 0 }T 674 | 675 | \ ------------------------------------------------------------------------ 676 | TESTING CHAR [CHAR] [ ] BL S" 677 | 678 | T{ BL -> 20 }T 679 | T{ CHAR X -> 58 }T 680 | T{ CHAR HELLO -> 48 }T 681 | T{ : GC1 [CHAR] X ; -> }T 682 | T{ : GC2 [CHAR] HELLO ; -> }T 683 | T{ GC1 -> 58 }T 684 | T{ GC2 -> 48 }T 685 | T{ : GC3 [ GC1 ] LITERAL ; -> }T 686 | T{ GC3 -> 58 }T 687 | T{ : GC4 S" XY" ; -> }T 688 | T{ GC4 SWAP DROP -> 2 }T 689 | T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T 690 | 691 | \ ------------------------------------------------------------------------ 692 | TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE 693 | 694 | T{ : GT1 123 ; -> }T 695 | T{ ' GT1 EXECUTE -> 123 }T 696 | T{ : GT2 ['] GT1 ; IMMEDIATE -> }T 697 | T{ GT2 EXECUTE -> 123 }T 698 | HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING 699 | HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING 700 | T{ GT1STRING FIND -> ' GT1 -1 }T 701 | T{ GT2STRING FIND -> ' GT2 1 }T 702 | ( HOW TO SEARCH FOR NON-EXISTENT WORD? ) 703 | T{ : GT3 GT2 LITERAL ; -> }T 704 | T{ GT3 -> ' GT1 }T 705 | T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T 706 | 707 | T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T 708 | T{ : GT5 GT4 ; -> }T 709 | T{ GT5 -> 123 }T 710 | T{ : GT6 345 ; IMMEDIATE -> }T 711 | T{ : GT7 POSTPONE GT6 ; -> }T 712 | T{ GT7 -> 345 }T 713 | 714 | T{ : GT8 STATE @ ; IMMEDIATE -> }T 715 | T{ GT8 -> 0 }T 716 | T{ : GT9 GT8 LITERAL ; -> }T 717 | T{ GT9 0= -> }T 718 | 719 | \ ------------------------------------------------------------------------ 720 | TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE 721 | 722 | T{ : GI1 IF 123 THEN ; -> }T 723 | T{ : GI2 IF 123 ELSE 234 THEN ; -> }T 724 | T{ 0 GI1 -> }T 725 | T{ 1 GI1 -> 123 }T 726 | T{ -1 GI1 -> 123 }T 727 | T{ 0 GI2 -> 234 }T 728 | T{ 1 GI2 -> 123 }T 729 | T{ -1 GI1 -> 123 }T 730 | 731 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 732 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 733 | T{ 4 GI3 -> 4 5 }T 734 | T{ 5 GI3 -> 5 }T 735 | T{ 6 GI3 -> 6 }T 736 | 737 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 738 | T{ 3 GI4 -> 3 4 5 6 }T 739 | T{ 5 GI4 -> 5 6 }T 740 | T{ 6 GI4 -> 6 7 }T 741 | 742 | T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T 743 | T{ 1 GI5 -> 1 345 }T 744 | T{ 2 GI5 -> 2 345 }T 745 | T{ 3 GI5 -> 3 4 5 123 }T 746 | T{ 4 GI5 -> 4 5 123 }T 747 | T{ 5 GI5 -> 5 123 }T 748 | 749 | T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T 750 | T{ 0 GI6 -> 0 }T 751 | T{ 1 GI6 -> 0 1 }T 752 | T{ 2 GI6 -> 0 1 2 }T 753 | T{ 3 GI6 -> 0 1 2 3 }T 754 | T{ 4 GI6 -> 0 1 2 3 4 }T 755 | 756 | \ ------------------------------------------------------------------------ 757 | TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT 758 | 759 | T{ : GD1 DO I LOOP ; -> }T 760 | T{ 4 1 GD1 -> 1 2 3 }T 761 | T{ 2 -1 GD1 -> -1 0 1 }T 762 | T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T 763 | 764 | T{ : GD2 DO I -1 +LOOP ; -> }T 765 | T{ 1 4 GD2 -> 4 3 2 1 }T 766 | T{ -1 2 GD2 -> 2 1 0 -1 }T 767 | T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T 768 | 769 | T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T 770 | T{ 4 1 GD3 -> 1 2 3 }T 771 | T{ 2 -1 GD3 -> -1 0 1 }T 772 | T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T 773 | 774 | T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T 775 | T{ 1 4 GD4 -> 4 3 2 1 }T 776 | T{ -1 2 GD4 -> 2 1 0 -1 }T 777 | T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T 778 | 779 | T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T 780 | T{ 1 GD5 -> 123 }T 781 | T{ 5 GD5 -> 123 }T 782 | T{ 6 GD5 -> 234 }T 783 | 784 | T{ : GD6 ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T ) 785 | 0 SWAP 0 DO 786 | I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP 787 | LOOP ; -> }T 788 | T{ 1 GD6 -> 1 }T 789 | T{ 2 GD6 -> 3 }T 790 | T{ 3 GD6 -> 4 1 2 }T 791 | 792 | \ ------------------------------------------------------------------------ 793 | TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY 794 | 795 | T{ 123 CONSTANT X123 -> }T 796 | T{ X123 -> 123 }T 797 | T{ : EQU CONSTANT ; -> }T 798 | T{ X123 EQU Y123 -> }T 799 | T{ Y123 -> 123 }T 800 | 801 | T{ VARIABLE V1 -> }T 802 | T{ 123 V1 ! -> }T 803 | T{ V1 @ -> 123 }T 804 | 805 | T{ : NOP : POSTPONE ; ; -> }T 806 | T{ NOP NOP1 NOP NOP2 -> }T 807 | T{ NOP1 -> }T 808 | T{ NOP2 -> }T 809 | 810 | T{ : DOES1 DOES> @ 1 + ; -> }T 811 | T{ : DOES2 DOES> @ 2 + ; -> }T 812 | T{ CREATE CR1 -> }T 813 | T{ CR1 -> HERE }T 814 | T{ ' CR1 >BODY -> HERE }T 815 | T{ 1 , -> }T 816 | T{ CR1 @ -> 1 }T 817 | T{ DOES1 -> }T 818 | T{ CR1 -> 2 }T 819 | T{ DOES2 -> }T 820 | T{ CR1 -> 3 }T 821 | 822 | T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T 823 | T{ WEIRD: W1 -> }T 824 | T{ ' W1 >BODY -> HERE }T 825 | T{ W1 -> HERE 1 + }T 826 | T{ W1 -> HERE 2 + }T 827 | 828 | \ ------------------------------------------------------------------------ 829 | TESTING EVALUATE 830 | 831 | : GE1 S" 123" ; IMMEDIATE 832 | : GE2 S" 123 1+" ; IMMEDIATE 833 | : GE3 S" : GE4 345 ;" ; 834 | : GE5 EVALUATE ; IMMEDIATE 835 | 836 | T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) 837 | T{ GE2 EVALUATE -> 124 }T 838 | T{ GE3 EVALUATE -> }T 839 | T{ GE4 -> 345 }T 840 | 841 | T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) 842 | T{ GE6 -> 123 }T 843 | T{ : GE7 GE2 GE5 ; -> }T 844 | T{ GE7 -> 124 }T 845 | 846 | \ ------------------------------------------------------------------------ 847 | TESTING SOURCE >IN WORD 848 | 849 | : GS1 S" SOURCE" 2DUP EVALUATE 850 | >R SWAP >R = R> R> = ; 851 | T{ GS1 -> }T 852 | 853 | VARIABLE SCANS 854 | : RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; 855 | 856 | T{ 2 SCANS ! 857 | 345 RESCAN? 858 | -> 345 345 }T 859 | 860 | : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; 861 | T{ GS2 -> 123 123 123 123 123 }T 862 | 863 | : GS3 WORD COUNT SWAP C@ ; 864 | T{ BL GS3 HELLO -> 5 CHAR H }T 865 | T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T 866 | T{ BL GS3 867 | DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING 868 | 869 | : GS4 SOURCE >IN ! DROP ; 870 | T{ GS4 123 456 871 | -> }T 872 | 873 | \ ------------------------------------------------------------------------ 874 | TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL 875 | 876 | : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. 877 | >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH 878 | R> ?DUP IF \ IF NON-EMPTY STRINGS 879 | 0 DO 880 | OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN 881 | SWAP CHAR+ SWAP CHAR+ 882 | LOOP 883 | THEN 884 | 2DROP \ IF WE GET HERE, STRINGS MATCH 885 | ELSE 886 | R> DROP 2DROP \ LENGTHS MISMATCH 887 | THEN ; 888 | 889 | : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; 890 | T{ GP1 -> }T 891 | 892 | : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; 893 | T{ GP2 -> }T 894 | 895 | : GP3 <# 1 0 # # #> S" 01" S= ; 896 | T{ GP3 -> }T 897 | 898 | : GP4 <# 1 0 #S #> S" 1" S= ; 899 | T{ GP4 -> }T 900 | 901 | 24 CONSTANT MAX-BASE \ BASE 2 .. 36 902 | : COUNT-BITS 903 | 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; 904 | COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD 905 | 906 | : GP5 907 | BASE @ 908 | MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE 909 | I BASE ! \ TBD: ASSUMES BASE WORKS 910 | I 0 <# #S #> S" 10" S= AND 911 | LOOP 912 | SWAP BASE ! ; 913 | T{ GP5 -> }T 914 | 915 | : GP6 916 | BASE @ >R 2 BASE ! 917 | MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY 918 | R> BASE ! \ S: C-ADDR U 919 | DUP #BITS-UD = SWAP 920 | 0 DO \ S: C-ADDR FLAG 921 | OVER C@ [CHAR] 1 = AND \ ALL ONES 922 | >R CHAR+ R> 923 | LOOP SWAP DROP ; 924 | T{ GP6 -> }T 925 | 926 | : GP7 927 | BASE @ >R MAX-BASE BASE ! 928 | 929 | A 0 DO 930 | I 0 <# #S #> 931 | 1 = SWAP C@ I 30 + = AND AND 932 | LOOP 933 | MAX-BASE A DO 934 | I 0 <# #S #> 935 | 1 = SWAP C@ 41 I A - + = AND AND 936 | LOOP 937 | R> BASE ! ; 938 | 939 | T{ GP7 -> }T 940 | 941 | \ >NUMBER TESTS 942 | CREATE GN-BUF 0 C, 943 | : GN-STRING GN-BUF 1 ; 944 | : GN-CONSUMED GN-BUF CHAR+ 0 ; 945 | : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; 946 | 947 | T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T 948 | T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T 949 | T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T 950 | T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE 951 | T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T 952 | T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T 953 | 954 | : >NUMBER-BASED 955 | BASE @ >R BASE ! >NUMBER R> BASE ! ; 956 | 957 | T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T 958 | T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T 959 | T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T 960 | T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T 961 | T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T 962 | T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T 963 | 964 | : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. 965 | BASE @ >R BASE ! 966 | <# #S #> 967 | 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY 968 | R> BASE ! ; 969 | T{ 0 0 2 GN1 -> 0 0 0 }T 970 | T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T 971 | T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T 972 | T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T 973 | T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T 974 | T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T 975 | 976 | : GN2 \ ( -- 16 10 ) 977 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 978 | T{ GN2 -> 10 A }T 979 | 980 | \ ------------------------------------------------------------------------ 981 | TESTING FILL MOVE 982 | 983 | CREATE FBUF 00 C, 00 C, 00 C, 984 | CREATE SBUF 12 C, 34 C, 56 C, 985 | : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; 986 | 987 | T{ FBUF 0 20 FILL -> }T 988 | T{ SEEBUF -> 00 00 00 }T 989 | 990 | T{ FBUF 1 20 FILL -> }T 991 | T{ SEEBUF -> 20 00 00 }T 992 | 993 | T{ FBUF 3 20 FILL -> }T 994 | T{ SEEBUF -> 20 20 20 }T 995 | 996 | T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE 997 | T{ SEEBUF -> 20 20 20 }T 998 | 999 | T{ SBUF FBUF 0 CHARS MOVE -> }T 1000 | T{ SEEBUF -> 20 20 20 }T 1001 | 1002 | T{ SBUF FBUF 1 CHARS MOVE -> }T 1003 | T{ SEEBUF -> 12 20 20 }T 1004 | 1005 | T{ SBUF FBUF 3 CHARS MOVE -> }T 1006 | T{ SEEBUF -> 12 34 56 }T 1007 | 1008 | T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T 1009 | T{ SEEBUF -> 12 12 34 }T 1010 | 1011 | T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T 1012 | T{ SEEBUF -> 12 34 34 }T 1013 | 1014 | \ ------------------------------------------------------------------------ 1015 | TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. 1016 | 1017 | : OUTPUT-TEST 1018 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 1019 | 41 BL DO I EMIT LOOP CR 1020 | 61 41 DO I EMIT LOOP CR 1021 | 7F 61 DO I EMIT LOOP CR 1022 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 1023 | 9 1+ 0 DO I . LOOP CR 1024 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 1025 | [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR 1026 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 1027 | [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR 1028 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 1029 | 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR 1030 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 1031 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 1032 | ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR 1033 | ." SIGNED: " MIN-INT . MAX-INT . CR 1034 | ." UNSIGNED: " 0 U. MAX-UINT U. CR 1035 | ; 1036 | 1037 | T{ OUTPUT-TEST -> }T 1038 | 1039 | 1040 | \ ------------------------------------------------------------------------ 1041 | TESTING INPUT: ACCEPT 1042 | 1043 | CREATE ABUF 80 CHARS ALLOT 1044 | 1045 | : ACCEPT-TEST 1046 | CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR 1047 | ABUF 80 ACCEPT 1048 | CR ." RECEIVED: " [CHAR] " EMIT 1049 | ABUF SWAP TYPE [CHAR] " EMIT CR 1050 | ; 1051 | 1052 | T{ ACCEPT-TEST -> }T 1053 | 1054 | \ ------------------------------------------------------------------------ 1055 | TESTING DICTIONARY SEARCH RULES 1056 | 1057 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 1058 | 1059 | T{ GDX -> 123 234 }T 1060 | 1061 | CR .( End of Core word set tests) CR 1062 | 1063 | BYE 1064 | -------------------------------------------------------------------------------- /software/anstests0.10/core.fr: -------------------------------------------------------------------------------- 1 | \ From: John Hayes S1I 2 | \ Subject: core.fr 3 | \ Date: Mon, 27 Nov 95 13:10 4 | 5 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7 | \ VERSION 1.2 8 | \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. 9 | \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE 10 | \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND 11 | \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. 12 | \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... 13 | \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... 14 | 15 | CR 16 | TESTING CORE WORDS 17 | HEX 18 | 19 | \ ------------------------------------------------------------------------ 20 | TESTING BASIC ASSUMPTIONS 21 | 22 | T{ -> }T \ START WITH CLEAN SLATE 23 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 24 | T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T 25 | T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) 26 | T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 27 | T{ -1 BITSSET? -> 0 0 }T 28 | 29 | \ ------------------------------------------------------------------------ 30 | TESTING BOOLEANS: INVERT AND OR XOR 31 | 32 | T{ 0 0 AND -> 0 }T 33 | T{ 0 1 AND -> 0 }T 34 | T{ 1 0 AND -> 0 }T 35 | T{ 1 1 AND -> 1 }T 36 | 37 | T{ 0 INVERT 1 AND -> 1 }T 38 | T{ 1 INVERT 1 AND -> 0 }T 39 | 40 | 0 CONSTANT 0S 41 | 0 INVERT CONSTANT 1S 42 | 43 | T{ 0S INVERT -> 1S }T 44 | T{ 1S INVERT -> 0S }T 45 | 46 | T{ 0S 0S AND -> 0S }T 47 | T{ 0S 1S AND -> 0S }T 48 | T{ 1S 0S AND -> 0S }T 49 | T{ 1S 1S AND -> 1S }T 50 | 51 | T{ 0S 0S OR -> 0S }T 52 | T{ 0S 1S OR -> 1S }T 53 | T{ 1S 0S OR -> 1S }T 54 | T{ 1S 1S OR -> 1S }T 55 | 56 | T{ 0S 0S XOR -> 0S }T 57 | T{ 0S 1S XOR -> 1S }T 58 | T{ 1S 0S XOR -> 1S }T 59 | T{ 1S 1S XOR -> 0S }T 60 | 61 | \ ------------------------------------------------------------------------ 62 | TESTING 2* 2/ LSHIFT RSHIFT 63 | 64 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 65 | 1S 1 RSHIFT INVERT CONSTANT MSB 66 | T{ MSB BITSSET? -> 0 0 }T 67 | 68 | T{ 0S 2* -> 0S }T 69 | T{ 1 2* -> 2 }T 70 | T{ 4000 2* -> 8000 }T 71 | T{ 1S 2* 1 XOR -> 1S }T 72 | T{ MSB 2* -> 0S }T 73 | 74 | T{ 0S 2/ -> 0S }T 75 | T{ 1 2/ -> 0 }T 76 | T{ 4000 2/ -> 2000 }T 77 | T{ 1S 2/ -> 1S }T \ MSB PROPOGATED 78 | T{ 1S 1 XOR 2/ -> 1S }T 79 | T{ MSB 2/ MSB AND -> MSB }T 80 | 81 | T{ 1 0 LSHIFT -> 1 }T 82 | T{ 1 1 LSHIFT -> 2 }T 83 | T{ 1 2 LSHIFT -> 4 }T 84 | T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT 85 | T{ 1S 1 LSHIFT 1 XOR -> 1S }T 86 | T{ MSB 1 LSHIFT -> 0 }T 87 | 88 | T{ 1 0 RSHIFT -> 1 }T 89 | T{ 1 1 RSHIFT -> 0 }T 90 | T{ 2 1 RSHIFT -> 1 }T 91 | T{ 4 2 RSHIFT -> 1 }T 92 | T{ 8000 F RSHIFT -> 1 }T \ BIGGEST 93 | T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS 94 | T{ MSB 1 RSHIFT 2* -> MSB }T 95 | 96 | \ ------------------------------------------------------------------------ 97 | TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 98 | 0 INVERT CONSTANT MAX-UINT 99 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT 100 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 101 | 0 INVERT 1 RSHIFT CONSTANT MID-UINT 102 | 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 103 | 104 | 0S CONSTANT 105 | 1S CONSTANT 106 | 107 | T{ 0 0= -> }T 108 | T{ 1 0= -> }T 109 | T{ 2 0= -> }T 110 | T{ -1 0= -> }T 111 | T{ MAX-UINT 0= -> }T 112 | T{ MIN-INT 0= -> }T 113 | T{ MAX-INT 0= -> }T 114 | 115 | T{ 0 0 = -> }T 116 | T{ 1 1 = -> }T 117 | T{ -1 -1 = -> }T 118 | T{ 1 0 = -> }T 119 | T{ -1 0 = -> }T 120 | T{ 0 1 = -> }T 121 | T{ 0 -1 = -> }T 122 | 123 | T{ 0 0< -> }T 124 | T{ -1 0< -> }T 125 | T{ MIN-INT 0< -> }T 126 | T{ 1 0< -> }T 127 | T{ MAX-INT 0< -> }T 128 | 129 | T{ 0 1 < -> }T 130 | T{ 1 2 < -> }T 131 | T{ -1 0 < -> }T 132 | T{ -1 1 < -> }T 133 | T{ MIN-INT 0 < -> }T 134 | T{ MIN-INT MAX-INT < -> }T 135 | T{ 0 MAX-INT < -> }T 136 | T{ 0 0 < -> }T 137 | T{ 1 1 < -> }T 138 | T{ 1 0 < -> }T 139 | T{ 2 1 < -> }T 140 | T{ 0 -1 < -> }T 141 | T{ 1 -1 < -> }T 142 | T{ 0 MIN-INT < -> }T 143 | T{ MAX-INT MIN-INT < -> }T 144 | T{ MAX-INT 0 < -> }T 145 | 146 | T{ 0 1 > -> }T 147 | T{ 1 2 > -> }T 148 | T{ -1 0 > -> }T 149 | T{ -1 1 > -> }T 150 | T{ MIN-INT 0 > -> }T 151 | T{ MIN-INT MAX-INT > -> }T 152 | T{ 0 MAX-INT > -> }T 153 | T{ 0 0 > -> }T 154 | T{ 1 1 > -> }T 155 | T{ 1 0 > -> }T 156 | T{ 2 1 > -> }T 157 | T{ 0 -1 > -> }T 158 | T{ 1 -1 > -> }T 159 | T{ 0 MIN-INT > -> }T 160 | T{ MAX-INT MIN-INT > -> }T 161 | T{ MAX-INT 0 > -> }T 162 | 163 | T{ 0 1 U< -> }T 164 | T{ 1 2 U< -> }T 165 | T{ 0 MID-UINT U< -> }T 166 | T{ 0 MAX-UINT U< -> }T 167 | T{ MID-UINT MAX-UINT U< -> }T 168 | T{ 0 0 U< -> }T 169 | T{ 1 1 U< -> }T 170 | T{ 1 0 U< -> }T 171 | T{ 2 1 U< -> }T 172 | T{ MID-UINT 0 U< -> }T 173 | T{ MAX-UINT 0 U< -> }T 174 | T{ MAX-UINT MID-UINT U< -> }T 175 | 176 | T{ 0 1 MIN -> 0 }T 177 | T{ 1 2 MIN -> 1 }T 178 | T{ -1 0 MIN -> -1 }T 179 | T{ -1 1 MIN -> -1 }T 180 | T{ MIN-INT 0 MIN -> MIN-INT }T 181 | T{ MIN-INT MAX-INT MIN -> MIN-INT }T 182 | T{ 0 MAX-INT MIN -> 0 }T 183 | T{ 0 0 MIN -> 0 }T 184 | T{ 1 1 MIN -> 1 }T 185 | T{ 1 0 MIN -> 0 }T 186 | T{ 2 1 MIN -> 1 }T 187 | T{ 0 -1 MIN -> -1 }T 188 | T{ 1 -1 MIN -> -1 }T 189 | T{ 0 MIN-INT MIN -> MIN-INT }T 190 | T{ MAX-INT MIN-INT MIN -> MIN-INT }T 191 | T{ MAX-INT 0 MIN -> 0 }T 192 | 193 | T{ 0 1 MAX -> 1 }T 194 | T{ 1 2 MAX -> 2 }T 195 | T{ -1 0 MAX -> 0 }T 196 | T{ -1 1 MAX -> 1 }T 197 | T{ MIN-INT 0 MAX -> 0 }T 198 | T{ MIN-INT MAX-INT MAX -> MAX-INT }T 199 | T{ 0 MAX-INT MAX -> MAX-INT }T 200 | T{ 0 0 MAX -> 0 }T 201 | T{ 1 1 MAX -> 1 }T 202 | T{ 1 0 MAX -> 1 }T 203 | T{ 2 1 MAX -> 2 }T 204 | T{ 0 -1 MAX -> 0 }T 205 | T{ 1 -1 MAX -> 1 }T 206 | T{ 0 MIN-INT MAX -> 0 }T 207 | T{ MAX-INT MIN-INT MAX -> MAX-INT }T 208 | T{ MAX-INT 0 MAX -> MAX-INT }T 209 | 210 | \ ------------------------------------------------------------------------ 211 | TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP 212 | 213 | T{ 1 2 2DROP -> }T 214 | T{ 1 2 2DUP -> 1 2 1 2 }T 215 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 216 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 217 | T{ 0 ?DUP -> 0 }T 218 | T{ 1 ?DUP -> 1 1 }T 219 | T{ -1 ?DUP -> -1 -1 }T 220 | T{ DEPTH -> 0 }T 221 | T{ 0 DEPTH -> 0 1 }T 222 | T{ 0 1 DEPTH -> 0 1 2 }T 223 | T{ 0 DROP -> }T 224 | T{ 1 2 DROP -> 1 }T 225 | T{ 1 DUP -> 1 1 }T 226 | T{ 1 2 OVER -> 1 2 1 }T 227 | T{ 1 2 3 ROT -> 2 3 1 }T 228 | T{ 1 2 SWAP -> 2 1 }T 229 | 230 | \ ------------------------------------------------------------------------ 231 | TESTING >R R> R@ 232 | 233 | T{ : GR1 >R R> ; -> }T 234 | T{ : GR2 >R R@ R> DROP ; -> }T 235 | T{ 123 GR1 -> 123 }T 236 | T{ 123 GR2 -> 123 }T 237 | T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) 238 | 239 | \ ------------------------------------------------------------------------ 240 | TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE 241 | 242 | T{ 0 5 + -> 5 }T 243 | T{ 5 0 + -> 5 }T 244 | T{ 0 -5 + -> -5 }T 245 | T{ -5 0 + -> -5 }T 246 | T{ 1 2 + -> 3 }T 247 | T{ 1 -2 + -> -1 }T 248 | T{ -1 2 + -> 1 }T 249 | T{ -1 -2 + -> -3 }T 250 | T{ -1 1 + -> 0 }T 251 | T{ MID-UINT 1 + -> MID-UINT+1 }T 252 | 253 | T{ 0 5 - -> -5 }T 254 | T{ 5 0 - -> 5 }T 255 | T{ 0 -5 - -> 5 }T 256 | T{ -5 0 - -> -5 }T 257 | T{ 1 2 - -> -1 }T 258 | T{ 1 -2 - -> 3 }T 259 | T{ -1 2 - -> -3 }T 260 | T{ -1 -2 - -> 1 }T 261 | T{ 0 1 - -> -1 }T 262 | T{ MID-UINT+1 1 - -> MID-UINT }T 263 | 264 | T{ 0 1+ -> 1 }T 265 | T{ -1 1+ -> 0 }T 266 | T{ 1 1+ -> 2 }T 267 | T{ MID-UINT 1+ -> MID-UINT+1 }T 268 | 269 | T{ 2 1- -> 1 }T 270 | T{ 1 1- -> 0 }T 271 | T{ 0 1- -> -1 }T 272 | T{ MID-UINT+1 1- -> MID-UINT }T 273 | 274 | T{ 0 NEGATE -> 0 }T 275 | T{ 1 NEGATE -> -1 }T 276 | T{ -1 NEGATE -> 1 }T 277 | T{ 2 NEGATE -> -2 }T 278 | T{ -2 NEGATE -> 2 }T 279 | 280 | T{ 0 ABS -> 0 }T 281 | T{ 1 ABS -> 1 }T 282 | T{ -1 ABS -> 1 }T 283 | T{ MIN-INT ABS -> MID-UINT+1 }T 284 | 285 | \ ------------------------------------------------------------------------ 286 | TESTING MULTIPLY: S>D * M* UM* 287 | 288 | T{ 0 S>D -> 0 0 }T 289 | T{ 1 S>D -> 1 0 }T 290 | T{ 2 S>D -> 2 0 }T 291 | T{ -1 S>D -> -1 -1 }T 292 | T{ -2 S>D -> -2 -1 }T 293 | T{ MIN-INT S>D -> MIN-INT -1 }T 294 | T{ MAX-INT S>D -> MAX-INT 0 }T 295 | 296 | T{ 0 0 M* -> 0 S>D }T 297 | T{ 0 1 M* -> 0 S>D }T 298 | T{ 1 0 M* -> 0 S>D }T 299 | T{ 1 2 M* -> 2 S>D }T 300 | T{ 2 1 M* -> 2 S>D }T 301 | T{ 3 3 M* -> 9 S>D }T 302 | T{ -3 3 M* -> -9 S>D }T 303 | T{ 3 -3 M* -> -9 S>D }T 304 | T{ -3 -3 M* -> 9 S>D }T 305 | T{ 0 MIN-INT M* -> 0 S>D }T 306 | T{ 1 MIN-INT M* -> MIN-INT S>D }T 307 | T{ 2 MIN-INT M* -> 0 1S }T 308 | T{ 0 MAX-INT M* -> 0 S>D }T 309 | T{ 1 MAX-INT M* -> MAX-INT S>D }T 310 | T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T 311 | T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T 312 | T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T 313 | T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T 314 | 315 | T{ 0 0 * -> 0 }T \ TEST IDENTITIES 316 | T{ 0 1 * -> 0 }T 317 | T{ 1 0 * -> 0 }T 318 | T{ 1 2 * -> 2 }T 319 | T{ 2 1 * -> 2 }T 320 | T{ 3 3 * -> 9 }T 321 | T{ -3 3 * -> -9 }T 322 | T{ 3 -3 * -> -9 }T 323 | T{ -3 -3 * -> 9 }T 324 | 325 | T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T 326 | T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T 327 | T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T 328 | 329 | T{ 0 0 UM* -> 0 0 }T 330 | T{ 0 1 UM* -> 0 0 }T 331 | T{ 1 0 UM* -> 0 0 }T 332 | T{ 1 2 UM* -> 2 0 }T 333 | T{ 2 1 UM* -> 2 0 }T 334 | T{ 3 3 UM* -> 9 0 }T 335 | 336 | T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T 337 | T{ MID-UINT+1 2 UM* -> 0 1 }T 338 | T{ MID-UINT+1 4 UM* -> 0 2 }T 339 | T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T 340 | T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T 341 | 342 | \ ------------------------------------------------------------------------ 343 | TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD 344 | 345 | T{ 0 S>D 1 FM/MOD -> 0 0 }T 346 | T{ 1 S>D 1 FM/MOD -> 0 1 }T 347 | T{ 2 S>D 1 FM/MOD -> 0 2 }T 348 | T{ -1 S>D 1 FM/MOD -> 0 -1 }T 349 | T{ -2 S>D 1 FM/MOD -> 0 -2 }T 350 | T{ 0 S>D -1 FM/MOD -> 0 0 }T 351 | T{ 1 S>D -1 FM/MOD -> 0 -1 }T 352 | T{ 2 S>D -1 FM/MOD -> 0 -2 }T 353 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 354 | T{ -2 S>D -1 FM/MOD -> 0 2 }T 355 | T{ 2 S>D 2 FM/MOD -> 0 1 }T 356 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 357 | T{ -2 S>D -2 FM/MOD -> 0 1 }T 358 | T{ 7 S>D 3 FM/MOD -> 1 2 }T 359 | T{ 7 S>D -3 FM/MOD -> -2 -3 }T 360 | T{ -7 S>D 3 FM/MOD -> 2 -3 }T 361 | T{ -7 S>D -3 FM/MOD -> -1 2 }T 362 | T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T 363 | T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T 364 | T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T 365 | T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T 366 | T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T 367 | T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T 368 | T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T 369 | T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T 370 | T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T 371 | T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T 372 | T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T 373 | T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T 374 | T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T 375 | T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T 376 | T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T 377 | T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T 378 | T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T 379 | 380 | T{ 0 S>D 1 SM/REM -> 0 0 }T 381 | T{ 1 S>D 1 SM/REM -> 0 1 }T 382 | T{ 2 S>D 1 SM/REM -> 0 2 }T 383 | T{ -1 S>D 1 SM/REM -> 0 -1 }T 384 | T{ -2 S>D 1 SM/REM -> 0 -2 }T 385 | T{ 0 S>D -1 SM/REM -> 0 0 }T 386 | T{ 1 S>D -1 SM/REM -> 0 -1 }T 387 | T{ 2 S>D -1 SM/REM -> 0 -2 }T 388 | T{ -1 S>D -1 SM/REM -> 0 1 }T 389 | T{ -2 S>D -1 SM/REM -> 0 2 }T 390 | T{ 2 S>D 2 SM/REM -> 0 1 }T 391 | T{ -1 S>D -1 SM/REM -> 0 1 }T 392 | T{ -2 S>D -2 SM/REM -> 0 1 }T 393 | T{ 7 S>D 3 SM/REM -> 1 2 }T 394 | T{ 7 S>D -3 SM/REM -> 1 -2 }T 395 | T{ -7 S>D 3 SM/REM -> -1 -2 }T 396 | T{ -7 S>D -3 SM/REM -> -1 2 }T 397 | T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T 398 | T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T 399 | T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T 400 | T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T 401 | T{ 1S 1 4 SM/REM -> 3 MAX-INT }T 402 | T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T 403 | T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T 404 | T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T 405 | T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T 406 | T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T 407 | T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T 408 | T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T 409 | T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T 410 | 411 | T{ 0 0 1 UM/MOD -> 0 0 }T 412 | T{ 1 0 1 UM/MOD -> 0 1 }T 413 | T{ 1 0 2 UM/MOD -> 1 0 }T 414 | T{ 3 0 2 UM/MOD -> 1 1 }T 415 | T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T 416 | T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T 417 | T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T 418 | 419 | : IFFLOORED 420 | [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; 421 | 422 | : IFSYM 423 | [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; 424 | 425 | \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. 426 | \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. 427 | 428 | IFFLOORED : T/MOD >R S>D R> FM/MOD ; 429 | IFFLOORED : T/ T/MOD SWAP DROP ; 430 | IFFLOORED : TMOD T/MOD DROP ; 431 | IFFLOORED : T*/MOD >R M* R> FM/MOD ; 432 | IFFLOORED : T*/ T*/MOD SWAP DROP ; 433 | IFSYM : T/MOD >R S>D R> SM/REM ; 434 | IFSYM : T/ T/MOD SWAP DROP ; 435 | IFSYM : TMOD T/MOD DROP ; 436 | IFSYM : T*/MOD >R M* R> SM/REM ; 437 | IFSYM : T*/ T*/MOD SWAP DROP ; 438 | 439 | T{ 0 1 /MOD -> 0 1 T/MOD }T 440 | T{ 1 1 /MOD -> 1 1 T/MOD }T 441 | T{ 2 1 /MOD -> 2 1 T/MOD }T 442 | T{ -1 1 /MOD -> -1 1 T/MOD }T 443 | T{ -2 1 /MOD -> -2 1 T/MOD }T 444 | T{ 0 -1 /MOD -> 0 -1 T/MOD }T 445 | T{ 1 -1 /MOD -> 1 -1 T/MOD }T 446 | T{ 2 -1 /MOD -> 2 -1 T/MOD }T 447 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 448 | T{ -2 -1 /MOD -> -2 -1 T/MOD }T 449 | T{ 2 2 /MOD -> 2 2 T/MOD }T 450 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 451 | T{ -2 -2 /MOD -> -2 -2 T/MOD }T 452 | T{ 7 3 /MOD -> 7 3 T/MOD }T 453 | T{ 7 -3 /MOD -> 7 -3 T/MOD }T 454 | T{ -7 3 /MOD -> -7 3 T/MOD }T 455 | T{ -7 -3 /MOD -> -7 -3 T/MOD }T 456 | T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T 457 | T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T 458 | T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T 459 | T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T 460 | 461 | T{ 0 1 / -> 0 1 T/ }T 462 | T{ 1 1 / -> 1 1 T/ }T 463 | T{ 2 1 / -> 2 1 T/ }T 464 | T{ -1 1 / -> -1 1 T/ }T 465 | T{ -2 1 / -> -2 1 T/ }T 466 | T{ 0 -1 / -> 0 -1 T/ }T 467 | T{ 1 -1 / -> 1 -1 T/ }T 468 | T{ 2 -1 / -> 2 -1 T/ }T 469 | T{ -1 -1 / -> -1 -1 T/ }T 470 | T{ -2 -1 / -> -2 -1 T/ }T 471 | T{ 2 2 / -> 2 2 T/ }T 472 | T{ -1 -1 / -> -1 -1 T/ }T 473 | T{ -2 -2 / -> -2 -2 T/ }T 474 | T{ 7 3 / -> 7 3 T/ }T 475 | T{ 7 -3 / -> 7 -3 T/ }T 476 | T{ -7 3 / -> -7 3 T/ }T 477 | T{ -7 -3 / -> -7 -3 T/ }T 478 | T{ MAX-INT 1 / -> MAX-INT 1 T/ }T 479 | T{ MIN-INT 1 / -> MIN-INT 1 T/ }T 480 | T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T 481 | T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T 482 | 483 | T{ 0 1 MOD -> 0 1 TMOD }T 484 | T{ 1 1 MOD -> 1 1 TMOD }T 485 | T{ 2 1 MOD -> 2 1 TMOD }T 486 | T{ -1 1 MOD -> -1 1 TMOD }T 487 | T{ -2 1 MOD -> -2 1 TMOD }T 488 | T{ 0 -1 MOD -> 0 -1 TMOD }T 489 | T{ 1 -1 MOD -> 1 -1 TMOD }T 490 | T{ 2 -1 MOD -> 2 -1 TMOD }T 491 | T{ -1 -1 MOD -> -1 -1 TMOD }T 492 | T{ -2 -1 MOD -> -2 -1 TMOD }T 493 | T{ 2 2 MOD -> 2 2 TMOD }T 494 | T{ -1 -1 MOD -> -1 -1 TMOD }T 495 | T{ -2 -2 MOD -> -2 -2 TMOD }T 496 | T{ 7 3 MOD -> 7 3 TMOD }T 497 | T{ 7 -3 MOD -> 7 -3 TMOD }T 498 | T{ -7 3 MOD -> -7 3 TMOD }T 499 | T{ -7 -3 MOD -> -7 -3 TMOD }T 500 | T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T 501 | T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T 502 | T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T 503 | T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T 504 | 505 | T{ 0 2 1 */ -> 0 2 1 T*/ }T 506 | T{ 1 2 1 */ -> 1 2 1 T*/ }T 507 | T{ 2 2 1 */ -> 2 2 1 T*/ }T 508 | T{ -1 2 1 */ -> -1 2 1 T*/ }T 509 | T{ -2 2 1 */ -> -2 2 1 T*/ }T 510 | T{ 0 2 -1 */ -> 0 2 -1 T*/ }T 511 | T{ 1 2 -1 */ -> 1 2 -1 T*/ }T 512 | T{ 2 2 -1 */ -> 2 2 -1 T*/ }T 513 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 514 | T{ -2 2 -1 */ -> -2 2 -1 T*/ }T 515 | T{ 2 2 2 */ -> 2 2 2 T*/ }T 516 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 517 | T{ -2 2 -2 */ -> -2 2 -2 T*/ }T 518 | T{ 7 2 3 */ -> 7 2 3 T*/ }T 519 | T{ 7 2 -3 */ -> 7 2 -3 T*/ }T 520 | T{ -7 2 3 */ -> -7 2 3 T*/ }T 521 | T{ -7 2 -3 */ -> -7 2 -3 T*/ }T 522 | T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T 523 | T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T 524 | 525 | T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T 526 | T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T 527 | T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T 528 | T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T 529 | T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T 530 | T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T 531 | T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T 532 | T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T 533 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 534 | T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T 535 | T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T 536 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 537 | T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T 538 | T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T 539 | T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T 540 | T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T 541 | T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T 542 | T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T 543 | T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T 544 | 545 | \ ------------------------------------------------------------------------ 546 | TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT 547 | 548 | HERE 1 ALLOT 549 | HERE 550 | CONSTANT 2NDA 551 | CONSTANT 1STA 552 | T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT 553 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 554 | ( MISSING TEST: NEGATIVE ALLOT ) 555 | 556 | HERE 1 , 557 | HERE 2 , 558 | CONSTANT 2ND 559 | CONSTANT 1ST 560 | T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT 561 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 562 | T{ 1ST 1 CELLS + -> 2ND }T 563 | T{ 1ST @ 2ND @ -> 1 2 }T 564 | T{ 5 1ST ! -> }T 565 | T{ 1ST @ 2ND @ -> 5 2 }T 566 | T{ 6 2ND ! -> }T 567 | T{ 1ST @ 2ND @ -> 5 6 }T 568 | T{ 1ST 2@ -> 6 5 }T 569 | T{ 2 1 1ST 2! -> }T 570 | T{ 1ST 2@ -> 2 1 }T 571 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 572 | 573 | HERE 1 C, 574 | HERE 2 C, 575 | CONSTANT 2NDC 576 | CONSTANT 1STC 577 | T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT 578 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 579 | T{ 1STC 1 CHARS + -> 2NDC }T 580 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 581 | T{ 3 1STC C! -> }T 582 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 583 | T{ 4 2NDC C! -> }T 584 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 585 | 586 | ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT 587 | CONSTANT A-ADDR CONSTANT UA-ADDR 588 | T{ UA-ADDR ALIGNED -> A-ADDR }T 589 | T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T 590 | T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T 591 | T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T 592 | T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T 593 | T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T 594 | T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T 595 | T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T 596 | 597 | : BITS ( X -- U ) 598 | 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; 599 | ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) 600 | T{ 1 CHARS 1 < -> }T 601 | T{ 1 CHARS 1 CELLS > -> }T 602 | ( TBD: HOW TO FIND NUMBER OF BITS? ) 603 | 604 | ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) 605 | T{ 1 CELLS 1 < -> }T 606 | T{ 1 CELLS 1 CHARS MOD -> 0 }T 607 | T{ 1S BITS 10 < -> }T 608 | 609 | T{ 0 1ST ! -> }T 610 | T{ 1 1ST +! -> }T 611 | T{ 1ST @ -> 1 }T 612 | T{ -1 1ST +! 1ST @ -> 0 }T 613 | 614 | \ ------------------------------------------------------------------------ 615 | TESTING CHAR [CHAR] [ ] BL S" 616 | 617 | T{ BL -> 20 }T 618 | T{ CHAR X -> 58 }T 619 | T{ CHAR HELLO -> 48 }T 620 | T{ : GC1 [CHAR] X ; -> }T 621 | T{ : GC2 [CHAR] HELLO ; -> }T 622 | T{ GC1 -> 58 }T 623 | T{ GC2 -> 48 }T 624 | T{ : GC3 [ GC1 ] LITERAL ; -> }T 625 | T{ GC3 -> 58 }T 626 | T{ : GC4 S" XY" ; -> }T 627 | T{ GC4 SWAP DROP -> 2 }T 628 | T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T 629 | 630 | \ ------------------------------------------------------------------------ 631 | TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE 632 | 633 | T{ : GT1 123 ; -> }T 634 | T{ ' GT1 EXECUTE -> 123 }T 635 | T{ : GT2 ['] GT1 ; IMMEDIATE -> }T 636 | T{ GT2 EXECUTE -> 123 }T 637 | HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING 638 | HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING 639 | T{ GT1STRING FIND -> ' GT1 -1 }T 640 | T{ GT2STRING FIND -> ' GT2 1 }T 641 | ( HOW TO SEARCH FOR NON-EXISTENT WORD? ) 642 | T{ : GT3 GT2 LITERAL ; -> }T 643 | T{ GT3 -> ' GT1 }T 644 | T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T 645 | 646 | T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T 647 | T{ : GT5 GT4 ; -> }T 648 | T{ GT5 -> 123 }T 649 | T{ : GT6 345 ; IMMEDIATE -> }T 650 | T{ : GT7 POSTPONE GT6 ; -> }T 651 | T{ GT7 -> 345 }T 652 | 653 | T{ : GT8 STATE @ ; IMMEDIATE -> }T 654 | T{ GT8 -> 0 }T 655 | T{ : GT9 GT8 LITERAL ; -> }T 656 | T{ GT9 0= -> }T 657 | 658 | \ ------------------------------------------------------------------------ 659 | TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE 660 | 661 | T{ : GI1 IF 123 THEN ; -> }T 662 | T{ : GI2 IF 123 ELSE 234 THEN ; -> }T 663 | T{ 0 GI1 -> }T 664 | T{ 1 GI1 -> 123 }T 665 | T{ -1 GI1 -> 123 }T 666 | T{ 0 GI2 -> 234 }T 667 | T{ 1 GI2 -> 123 }T 668 | T{ -1 GI1 -> 123 }T 669 | 670 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 671 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 672 | T{ 4 GI3 -> 4 5 }T 673 | T{ 5 GI3 -> 5 }T 674 | T{ 6 GI3 -> 6 }T 675 | 676 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 677 | T{ 3 GI4 -> 3 4 5 6 }T 678 | T{ 5 GI4 -> 5 6 }T 679 | T{ 6 GI4 -> 6 7 }T 680 | 681 | T{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T 682 | T{ 1 GI5 -> 1 345 }T 683 | T{ 2 GI5 -> 2 345 }T 684 | T{ 3 GI5 -> 3 4 5 123 }T 685 | T{ 4 GI5 -> 4 5 123 }T 686 | T{ 5 GI5 -> 5 123 }T 687 | 688 | T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T 689 | T{ 0 GI6 -> 0 }T 690 | T{ 1 GI6 -> 0 1 }T 691 | T{ 2 GI6 -> 0 1 2 }T 692 | T{ 3 GI6 -> 0 1 2 3 }T 693 | T{ 4 GI6 -> 0 1 2 3 4 }T 694 | 695 | \ ------------------------------------------------------------------------ 696 | TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT 697 | 698 | T{ : GD1 DO I LOOP ; -> }T 699 | T{ 4 1 GD1 -> 1 2 3 }T 700 | T{ 2 -1 GD1 -> -1 0 1 }T 701 | T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T 702 | 703 | T{ : GD2 DO I -1 +LOOP ; -> }T 704 | T{ 1 4 GD2 -> 4 3 2 1 }T 705 | T{ -1 2 GD2 -> 2 1 0 -1 }T 706 | T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T 707 | 708 | T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T 709 | T{ 4 1 GD3 -> 1 2 3 }T 710 | T{ 2 -1 GD3 -> -1 0 1 }T 711 | T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T 712 | 713 | T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T 714 | T{ 1 4 GD4 -> 4 3 2 1 }T 715 | T{ -1 2 GD4 -> 2 1 0 -1 }T 716 | T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T 717 | 718 | T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T 719 | T{ 1 GD5 -> 123 }T 720 | T{ 5 GD5 -> 123 }T 721 | T{ 6 GD5 -> 234 }T 722 | 723 | T{ : GD6 ( PAT: T{0 0}T,T{0 0}TT{1 0}TT{1 1}T,T{0 0}TT{1 0}TT{1 1}TT{2 0}TT{2 1}TT{2 2}T ) 724 | 0 SWAP 0 DO 725 | I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP 726 | LOOP ; -> }T 727 | T{ 1 GD6 -> 1 }T 728 | T{ 2 GD6 -> 3 }T 729 | T{ 3 GD6 -> 4 1 2 }T 730 | 731 | \ ------------------------------------------------------------------------ 732 | TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY 733 | 734 | T{ 123 CONSTANT X123 -> }T 735 | T{ X123 -> 123 }T 736 | T{ : EQU CONSTANT ; -> }T 737 | T{ X123 EQU Y123 -> }T 738 | T{ Y123 -> 123 }T 739 | 740 | T{ VARIABLE V1 -> }T 741 | T{ 123 V1 ! -> }T 742 | T{ V1 @ -> 123 }T 743 | 744 | T{ : NOP : POSTPONE ; ; -> }T 745 | T{ NOP NOP1 NOP NOP2 -> }T 746 | T{ NOP1 -> }T 747 | T{ NOP2 -> }T 748 | 749 | T{ : DOES1 DOES> @ 1 + ; -> }T 750 | T{ : DOES2 DOES> @ 2 + ; -> }T 751 | T{ CREATE CR1 -> }T 752 | T{ CR1 -> HERE }T 753 | T{ ' CR1 >BODY -> HERE }T 754 | T{ 1 , -> }T 755 | T{ CR1 @ -> 1 }T 756 | T{ DOES1 -> }T 757 | T{ CR1 -> 2 }T 758 | T{ DOES2 -> }T 759 | T{ CR1 -> 3 }T 760 | 761 | T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T 762 | T{ WEIRD: W1 -> }T 763 | T{ ' W1 >BODY -> HERE }T 764 | T{ W1 -> HERE 1 + }T 765 | T{ W1 -> HERE 2 + }T 766 | 767 | \ ------------------------------------------------------------------------ 768 | TESTING EVALUATE 769 | 770 | : GE1 S" 123" ; IMMEDIATE 771 | : GE2 S" 123 1+" ; IMMEDIATE 772 | : GE3 S" : GE4 345 ;" ; 773 | : GE5 EVALUATE ; IMMEDIATE 774 | 775 | T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) 776 | T{ GE2 EVALUATE -> 124 }T 777 | T{ GE3 EVALUATE -> }T 778 | T{ GE4 -> 345 }T 779 | 780 | T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) 781 | T{ GE6 -> 123 }T 782 | T{ : GE7 GE2 GE5 ; -> }T 783 | T{ GE7 -> 124 }T 784 | 785 | \ ------------------------------------------------------------------------ 786 | TESTING SOURCE >IN WORD 787 | 788 | : GS1 S" SOURCE" 2DUP EVALUATE 789 | >R SWAP >R = R> R> = ; 790 | T{ GS1 -> }T 791 | 792 | VARIABLE SCANS 793 | : RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; 794 | 795 | T{ 2 SCANS ! 796 | 345 RESCAN? 797 | -> 345 345 }T 798 | 799 | : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; 800 | T{ GS2 -> 123 123 123 123 123 }T 801 | 802 | : GS3 WORD COUNT SWAP C@ ; 803 | T{ BL GS3 HELLO -> 5 CHAR H }T 804 | T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T 805 | T{ BL GS3 806 | DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING 807 | 808 | : GS4 SOURCE >IN ! DROP ; 809 | T{ GS4 123 456 810 | -> }T 811 | 812 | \ ------------------------------------------------------------------------ 813 | TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL 814 | 815 | : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. 816 | >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH 817 | R> ?DUP IF \ IF NON-EMPTY STRINGS 818 | 0 DO 819 | OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN 820 | SWAP CHAR+ SWAP CHAR+ 821 | LOOP 822 | THEN 823 | 2DROP \ IF WE GET HERE, STRINGS MATCH 824 | ELSE 825 | R> DROP 2DROP \ LENGTHS MISMATCH 826 | THEN ; 827 | 828 | : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; 829 | T{ GP1 -> }T 830 | 831 | : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; 832 | T{ GP2 -> }T 833 | 834 | : GP3 <# 1 0 # # #> S" 01" S= ; 835 | T{ GP3 -> }T 836 | 837 | : GP4 <# 1 0 #S #> S" 1" S= ; 838 | T{ GP4 -> }T 839 | 840 | 24 CONSTANT MAX-BASE \ BASE 2 .. 36 841 | : COUNT-BITS 842 | 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; 843 | COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD 844 | 845 | : GP5 846 | BASE @ 847 | MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE 848 | I BASE ! \ TBD: ASSUMES BASE WORKS 849 | I 0 <# #S #> S" 10" S= AND 850 | LOOP 851 | SWAP BASE ! ; 852 | T{ GP5 -> }T 853 | 854 | : GP6 855 | BASE @ >R 2 BASE ! 856 | MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY 857 | R> BASE ! \ S: C-ADDR U 858 | DUP #BITS-UD = SWAP 859 | 0 DO \ S: C-ADDR FLAG 860 | OVER C@ [CHAR] 1 = AND \ ALL ONES 861 | >R CHAR+ R> 862 | LOOP SWAP DROP ; 863 | T{ GP6 -> }T 864 | 865 | : GP7 866 | BASE @ >R MAX-BASE BASE ! 867 | 868 | A 0 DO 869 | I 0 <# #S #> 870 | 1 = SWAP C@ I 30 + = AND AND 871 | LOOP 872 | MAX-BASE A DO 873 | I 0 <# #S #> 874 | 1 = SWAP C@ 41 I A - + = AND AND 875 | LOOP 876 | R> BASE ! ; 877 | 878 | T{ GP7 -> }T 879 | 880 | \ >NUMBER TESTS 881 | CREATE GN-BUF 0 C, 882 | : GN-STRING GN-BUF 1 ; 883 | : GN-CONSUMED GN-BUF CHAR+ 0 ; 884 | : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; 885 | 886 | T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T 887 | T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T 888 | T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T 889 | T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE 890 | T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T 891 | T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T 892 | 893 | : >NUMBER-BASED 894 | BASE @ >R BASE ! >NUMBER R> BASE ! ; 895 | 896 | T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T 897 | T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T 898 | T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T 899 | T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T 900 | T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T 901 | T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T 902 | 903 | : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. 904 | BASE @ >R BASE ! 905 | <# #S #> 906 | 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY 907 | R> BASE ! ; 908 | T{ 0 0 2 GN1 -> 0 0 0 }T 909 | T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T 910 | T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T 911 | T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T 912 | T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T 913 | T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T 914 | 915 | : GN2 \ ( -- 16 10 ) 916 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 917 | T{ GN2 -> 10 A }T 918 | 919 | \ ------------------------------------------------------------------------ 920 | TESTING FILL MOVE 921 | 922 | CREATE FBUF 00 C, 00 C, 00 C, 923 | CREATE SBUF 12 C, 34 C, 56 C, 924 | : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; 925 | 926 | T{ FBUF 0 20 FILL -> }T 927 | T{ SEEBUF -> 00 00 00 }T 928 | 929 | T{ FBUF 1 20 FILL -> }T 930 | T{ SEEBUF -> 20 00 00 }T 931 | 932 | T{ FBUF 3 20 FILL -> }T 933 | T{ SEEBUF -> 20 20 20 }T 934 | 935 | T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE 936 | T{ SEEBUF -> 20 20 20 }T 937 | 938 | T{ SBUF FBUF 0 CHARS MOVE -> }T 939 | T{ SEEBUF -> 20 20 20 }T 940 | 941 | T{ SBUF FBUF 1 CHARS MOVE -> }T 942 | T{ SEEBUF -> 12 20 20 }T 943 | 944 | T{ SBUF FBUF 3 CHARS MOVE -> }T 945 | T{ SEEBUF -> 12 34 56 }T 946 | 947 | T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T 948 | T{ SEEBUF -> 12 12 34 }T 949 | 950 | T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T 951 | T{ SEEBUF -> 12 34 34 }T 952 | 953 | \ ------------------------------------------------------------------------ 954 | TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. 955 | 956 | : OUTPUT-TEST 957 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 958 | 41 BL DO I EMIT LOOP CR 959 | 61 41 DO I EMIT LOOP CR 960 | 7F 61 DO I EMIT LOOP CR 961 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 962 | 9 1+ 0 DO I . LOOP CR 963 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 964 | [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR 965 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 966 | [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR 967 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 968 | 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR 969 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 970 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 971 | ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR 972 | ." SIGNED: " MIN-INT . MAX-INT . CR 973 | ." UNSIGNED: " 0 U. MAX-UINT U. CR 974 | ; 975 | 976 | T{ OUTPUT-TEST -> }T 977 | 978 | 979 | \ ------------------------------------------------------------------------ 980 | TESTING INPUT: ACCEPT 981 | 982 | CREATE ABUF 80 CHARS ALLOT 983 | 984 | : ACCEPT-TEST 985 | CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR 986 | ABUF 80 ACCEPT 987 | CR ." RECEIVED: " [CHAR] " EMIT 988 | ABUF SWAP TYPE [CHAR] " EMIT CR 989 | ; 990 | 991 | T{ ACCEPT-TEST -> }T 992 | 993 | \ ------------------------------------------------------------------------ 994 | TESTING DICTIONARY SEARCH RULES 995 | 996 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 997 | 998 | T{ GDX -> 123 234 }T 999 | 1000 | CR .( End of Core word set tests) CR 1001 | 1002 | 1003 | -------------------------------------------------------------------------------- /software/anstests0.10/coreexttest.fth: -------------------------------------------------------------------------------- 1 | \ To test some of the ANS Forth Core Extension word set 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ----------------------------------------------------------------------------- 14 | \ Version 0.10 1 August 2014 15 | \ Added tests contributed by James Bowman for: 16 | \ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> 17 | \ HEX WITHIN UNUSED AGAIN MARKER 18 | \ Added tests for: 19 | \ .R U.R ERASE PAD REFILL SOURCE-ID 20 | \ Removed ABORT from NeverExecuted to enable Win32 21 | \ to continue after failure of RESTORE-INPUT. 22 | \ Removed max-intx which is no longer used. 23 | \ 0.7 6 June 2012 Extra CASE test added 24 | \ 0.6 1 April 2012 Tests placed in the public domain. 25 | \ SAVE-INPUT & RESTORE-INPUT tests, position 26 | \ of T{ moved so that tests work with ttester.fs 27 | \ CONVERT test deleted - obsolete word removed from Forth 200X 28 | \ IMMEDIATE VALUEs tested 29 | \ RECURSE with :NONAME tested 30 | \ PARSE and .( tested 31 | \ Parsing behaviour of C" added 32 | \ 0.5 14 September 2011 Removed the double [ELSE] from the 33 | \ initial SAVE-INPUT & RESTORE-INPUT test 34 | \ 0.4 30 November 2009 max-int replaced with max-intx to 35 | \ avoid redefinition warnings. 36 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 37 | \ CONVERT test now independent of cell size 38 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 39 | \ Tests qd3 to qd6 by Reinhold Straub 40 | \ 0.1 Oct 2006 First version released 41 | \ ----------------------------------------------------------------------------- 42 | \ The tests are based on John Hayes test program for the core word set 43 | 44 | \ Words tested in this file are: 45 | \ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE 46 | \ ENDCASE ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL 47 | \ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED 48 | \ VALUE WITHIN [COMPILE] 49 | 50 | \ Words not tested or partially tested: 51 | \ \ because it has been extensively used already and is, hence, unnecessary 52 | \ REFILL and SOURCE-ID from the user input device which are not possible 53 | \ when testing from a file such as this one 54 | \ UNUSED as the value returned is system dependent 55 | \ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been 56 | \ removed from the Forth 200X standard 57 | 58 | \ Results from words that output to the user output device have to visually 59 | \ checked for correctness. These are .R U.R .( 60 | 61 | \ ----------------------------------------------------------------------------- 62 | \ Assumptions: 63 | \ - tester.fr (or ttester.fs) and core-fr have been included prior to this 64 | \ file 65 | \ ----------------------------------------------------------------------------- 66 | TESTING Core Extension words 67 | 68 | DECIMAL 69 | 70 | TESTING TRUE FALSE 71 | 72 | T{ TRUE -> 0 INVERT }T 73 | T{ FALSE -> 0 }T 74 | 75 | \ ----------------------------------------------------------------------------- 76 | TESTING <> U> (contributed by James Bowman) 77 | 78 | T{ 0 0 <> -> }T 79 | T{ 1 1 <> -> }T 80 | T{ -1 -1 <> -> }T 81 | T{ 1 0 <> -> }T 82 | T{ -1 0 <> -> }T 83 | T{ 0 1 <> -> }T 84 | T{ 0 -1 <> -> }T 85 | 86 | T{ 0 1 U> -> }T 87 | T{ 1 2 U> -> }T 88 | T{ 0 MID-UINT U> -> }T 89 | T{ 0 MAX-UINT U> -> }T 90 | T{ MID-UINT MAX-UINT U> -> }T 91 | T{ 0 0 U> -> }T 92 | T{ 1 1 U> -> }T 93 | T{ 1 0 U> -> }T 94 | T{ 2 1 U> -> }T 95 | T{ MID-UINT 0 U> -> }T 96 | T{ MAX-UINT 0 U> -> }T 97 | T{ MAX-UINT MID-UINT U> -> }T 98 | 99 | \ ----------------------------------------------------------------------------- 100 | TESTING 0<> 0> (contributed by James Bowman) 101 | 102 | T{ 0 0<> -> }T 103 | T{ 1 0<> -> }T 104 | T{ 2 0<> -> }T 105 | T{ -1 0<> -> }T 106 | T{ MAX-UINT 0<> -> }T 107 | T{ MIN-INT 0<> -> }T 108 | T{ MAX-INT 0<> -> }T 109 | 110 | T{ 0 0> -> }T 111 | T{ -1 0> -> }T 112 | T{ MIN-INT 0> -> }T 113 | T{ 1 0> -> }T 114 | T{ MAX-INT 0> -> }T 115 | 116 | \ ----------------------------------------------------------------------------- 117 | TESTING NIP TUCK ROLL PICK (contributed by James Bowman) 118 | 119 | T{ 1 2 NIP -> 2 }T 120 | T{ 1 2 3 NIP -> 1 3 }T 121 | 122 | T{ 1 2 TUCK -> 2 1 2 }T 123 | T{ 1 2 3 TUCK -> 1 3 2 3 }T 124 | 125 | T{ : ro5 100 200 300 400 500 ; -> }T 126 | T{ ro5 3 ROLL -> 100 300 400 500 200 }T 127 | T{ ro5 2 ROLL -> ro5 ROT }T 128 | T{ ro5 1 ROLL -> ro5 SWAP }T 129 | T{ ro5 0 ROLL -> ro5 }T 130 | 131 | T{ ro5 2 PICK -> 100 200 300 400 500 300 }T 132 | T{ ro5 1 PICK -> ro5 OVER }T 133 | T{ ro5 0 PICK -> ro5 DUP }T 134 | 135 | \ ----------------------------------------------------------------------------- 136 | TESTING 2>R 2R@ 2R> (contributed by James Bowman) 137 | 138 | T{ : rr0 2>R 100 R> R> ; -> }T 139 | T{ 300 400 rr0 -> 100 400 300 }T 140 | T{ 200 300 400 rr0 -> 200 100 400 300 }T 141 | 142 | T{ : rr1 2>R 100 2R@ R> R> ; -> }T 143 | T{ 300 400 rr1 -> 100 300 400 400 300 }T 144 | T{ 200 300 400 rr1 -> 200 100 300 400 400 300 }T 145 | 146 | T{ : rr2 2>R 100 2R> ; -> }T 147 | T{ 300 400 rr2 -> 100 300 400 }T 148 | T{ 200 300 400 rr2 -> 200 100 300 400 }T 149 | 150 | \ ----------------------------------------------------------------------------- 151 | TESTING HEX (contributed by James Bowman) 152 | 153 | T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T 154 | 155 | \ ----------------------------------------------------------------------------- 156 | TESTING WITHIN (contributed by James Bowman) 157 | 158 | T{ 0 0 0 WITHIN -> }T 159 | T{ 0 0 MID-UINT WITHIN -> }T 160 | T{ 0 0 MID-UINT+1 WITHIN -> }T 161 | T{ 0 0 MAX-UINT WITHIN -> }T 162 | T{ 0 MID-UINT 0 WITHIN -> }T 163 | T{ 0 MID-UINT MID-UINT WITHIN -> }T 164 | T{ 0 MID-UINT MID-UINT+1 WITHIN -> }T 165 | T{ 0 MID-UINT MAX-UINT WITHIN -> }T 166 | T{ 0 MID-UINT+1 0 WITHIN -> }T 167 | T{ 0 MID-UINT+1 MID-UINT WITHIN -> }T 168 | T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> }T 169 | T{ 0 MID-UINT+1 MAX-UINT WITHIN -> }T 170 | T{ 0 MAX-UINT 0 WITHIN -> }T 171 | T{ 0 MAX-UINT MID-UINT WITHIN -> }T 172 | T{ 0 MAX-UINT MID-UINT+1 WITHIN -> }T 173 | T{ 0 MAX-UINT MAX-UINT WITHIN -> }T 174 | T{ MID-UINT 0 0 WITHIN -> }T 175 | T{ MID-UINT 0 MID-UINT WITHIN -> }T 176 | T{ MID-UINT 0 MID-UINT+1 WITHIN -> }T 177 | T{ MID-UINT 0 MAX-UINT WITHIN -> }T 178 | T{ MID-UINT MID-UINT 0 WITHIN -> }T 179 | T{ MID-UINT MID-UINT MID-UINT WITHIN -> }T 180 | T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> }T 181 | T{ MID-UINT MID-UINT MAX-UINT WITHIN -> }T 182 | T{ MID-UINT MID-UINT+1 0 WITHIN -> }T 183 | T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> }T 184 | T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> }T 185 | T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> }T 186 | T{ MID-UINT MAX-UINT 0 WITHIN -> }T 187 | T{ MID-UINT MAX-UINT MID-UINT WITHIN -> }T 188 | T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> }T 189 | T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> }T 190 | T{ MID-UINT+1 0 0 WITHIN -> }T 191 | T{ MID-UINT+1 0 MID-UINT WITHIN -> }T 192 | T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> }T 193 | T{ MID-UINT+1 0 MAX-UINT WITHIN -> }T 194 | T{ MID-UINT+1 MID-UINT 0 WITHIN -> }T 195 | T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> }T 196 | T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> }T 197 | T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> }T 198 | T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> }T 199 | T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> }T 200 | T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> }T 201 | T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> }T 202 | T{ MID-UINT+1 MAX-UINT 0 WITHIN -> }T 203 | T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> }T 204 | T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> }T 205 | T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> }T 206 | T{ MAX-UINT 0 0 WITHIN -> }T 207 | T{ MAX-UINT 0 MID-UINT WITHIN -> }T 208 | T{ MAX-UINT 0 MID-UINT+1 WITHIN -> }T 209 | T{ MAX-UINT 0 MAX-UINT WITHIN -> }T 210 | T{ MAX-UINT MID-UINT 0 WITHIN -> }T 211 | T{ MAX-UINT MID-UINT MID-UINT WITHIN -> }T 212 | T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> }T 213 | T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> }T 214 | T{ MAX-UINT MID-UINT+1 0 WITHIN -> }T 215 | T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> }T 216 | T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> }T 217 | T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> }T 218 | T{ MAX-UINT MAX-UINT 0 WITHIN -> }T 219 | T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> }T 220 | T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> }T 221 | T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> }T 222 | 223 | T{ MIN-INT MIN-INT MIN-INT WITHIN -> }T 224 | T{ MIN-INT MIN-INT 0 WITHIN -> }T 225 | T{ MIN-INT MIN-INT 1 WITHIN -> }T 226 | T{ MIN-INT MIN-INT MAX-INT WITHIN -> }T 227 | T{ MIN-INT 0 MIN-INT WITHIN -> }T 228 | T{ MIN-INT 0 0 WITHIN -> }T 229 | T{ MIN-INT 0 1 WITHIN -> }T 230 | T{ MIN-INT 0 MAX-INT WITHIN -> }T 231 | T{ MIN-INT 1 MIN-INT WITHIN -> }T 232 | T{ MIN-INT 1 0 WITHIN -> }T 233 | T{ MIN-INT 1 1 WITHIN -> }T 234 | T{ MIN-INT 1 MAX-INT WITHIN -> }T 235 | T{ MIN-INT MAX-INT MIN-INT WITHIN -> }T 236 | T{ MIN-INT MAX-INT 0 WITHIN -> }T 237 | T{ MIN-INT MAX-INT 1 WITHIN -> }T 238 | T{ MIN-INT MAX-INT MAX-INT WITHIN -> }T 239 | T{ 0 MIN-INT MIN-INT WITHIN -> }T 240 | T{ 0 MIN-INT 0 WITHIN -> }T 241 | T{ 0 MIN-INT 1 WITHIN -> }T 242 | T{ 0 MIN-INT MAX-INT WITHIN -> }T 243 | T{ 0 0 MIN-INT WITHIN -> }T 244 | T{ 0 0 0 WITHIN -> }T 245 | T{ 0 0 1 WITHIN -> }T 246 | T{ 0 0 MAX-INT WITHIN -> }T 247 | T{ 0 1 MIN-INT WITHIN -> }T 248 | T{ 0 1 0 WITHIN -> }T 249 | T{ 0 1 1 WITHIN -> }T 250 | T{ 0 1 MAX-INT WITHIN -> }T 251 | T{ 0 MAX-INT MIN-INT WITHIN -> }T 252 | T{ 0 MAX-INT 0 WITHIN -> }T 253 | T{ 0 MAX-INT 1 WITHIN -> }T 254 | T{ 0 MAX-INT MAX-INT WITHIN -> }T 255 | T{ 1 MIN-INT MIN-INT WITHIN -> }T 256 | T{ 1 MIN-INT 0 WITHIN -> }T 257 | T{ 1 MIN-INT 1 WITHIN -> }T 258 | T{ 1 MIN-INT MAX-INT WITHIN -> }T 259 | T{ 1 0 MIN-INT WITHIN -> }T 260 | T{ 1 0 0 WITHIN -> }T 261 | T{ 1 0 1 WITHIN -> }T 262 | T{ 1 0 MAX-INT WITHIN -> }T 263 | T{ 1 1 MIN-INT WITHIN -> }T 264 | T{ 1 1 0 WITHIN -> }T 265 | T{ 1 1 1 WITHIN -> }T 266 | T{ 1 1 MAX-INT WITHIN -> }T 267 | T{ 1 MAX-INT MIN-INT WITHIN -> }T 268 | T{ 1 MAX-INT 0 WITHIN -> }T 269 | T{ 1 MAX-INT 1 WITHIN -> }T 270 | T{ 1 MAX-INT MAX-INT WITHIN -> }T 271 | T{ MAX-INT MIN-INT MIN-INT WITHIN -> }T 272 | T{ MAX-INT MIN-INT 0 WITHIN -> }T 273 | T{ MAX-INT MIN-INT 1 WITHIN -> }T 274 | T{ MAX-INT MIN-INT MAX-INT WITHIN -> }T 275 | T{ MAX-INT 0 MIN-INT WITHIN -> }T 276 | T{ MAX-INT 0 0 WITHIN -> }T 277 | T{ MAX-INT 0 1 WITHIN -> }T 278 | T{ MAX-INT 0 MAX-INT WITHIN -> }T 279 | T{ MAX-INT 1 MIN-INT WITHIN -> }T 280 | T{ MAX-INT 1 0 WITHIN -> }T 281 | T{ MAX-INT 1 1 WITHIN -> }T 282 | T{ MAX-INT 1 MAX-INT WITHIN -> }T 283 | T{ MAX-INT MAX-INT MIN-INT WITHIN -> }T 284 | T{ MAX-INT MAX-INT 0 WITHIN -> }T 285 | T{ MAX-INT MAX-INT 1 WITHIN -> }T 286 | T{ MAX-INT MAX-INT MAX-INT WITHIN -> }T 287 | 288 | \ ----------------------------------------------------------------------------- 289 | TESTING UNUSED (contributed by James Bowman) 290 | 291 | T{ UNUSED DROP -> }T 292 | 293 | \ ----------------------------------------------------------------------------- 294 | TESTING AGAIN (contributed by James Bowman) 295 | 296 | T{ : ag0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T 297 | T{ ag0 -> 707 }T 298 | 299 | \ ----------------------------------------------------------------------------- 300 | TESTING MARKER (contributed by James Bowman) 301 | 302 | T{ : ma? BL WORD FIND NIP 0<> ; -> }T 303 | T{ MARKER ma0 -> }T 304 | T{ : ma1 111 ; -> }T 305 | T{ MARKER ma2 -> }T 306 | T{ : ma1 222 ; -> }T 307 | T{ ma? ma0 ma? ma1 ma? ma2 -> }T 308 | T{ ma1 ma2 ma1 -> 222 111 }T 309 | T{ ma? ma0 ma? ma1 ma? ma2 -> }T 310 | T{ ma0 -> }T 311 | T{ ma? ma0 ma? ma1 ma? ma2 -> }T 312 | 313 | \ ----------------------------------------------------------------------------- 314 | TESTING ?DO 315 | 316 | : qd ?DO I LOOP ; 317 | T{ 789 789 qd -> }T 318 | T{ -9876 -9876 qd -> }T 319 | T{ 5 0 qd -> 0 1 2 3 4 }T 320 | 321 | : qd1 ?DO I 10 +LOOP ; 322 | T{ 50 1 qd1 -> 1 11 21 31 41 }T 323 | T{ 50 0 qd1 -> 0 10 20 30 40 }T 324 | 325 | : qd2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; 326 | T{ 5 -1 qd2 -> -1 0 1 2 3 }T 327 | 328 | : qd3 ?DO I 1 +LOOP ; 329 | T{ 4 4 qd3 -> }T 330 | T{ 4 1 qd3 -> 1 2 3 }T 331 | T{ 2 -1 qd3 -> -1 0 1 }T 332 | 333 | : qd4 ?DO I -1 +LOOP ; 334 | T{ 4 4 qd4 -> }T 335 | T{ 1 4 qd4 -> 4 3 2 1 }T 336 | T{ -1 2 qd4 -> 2 1 0 -1 }T 337 | 338 | : qd5 ?DO I -10 +LOOP ; 339 | T{ 1 50 qd5 -> 50 40 30 20 10 }T 340 | T{ 0 50 qd5 -> 50 40 30 20 10 0 }T 341 | T{ -25 10 qd5 -> 10 0 -10 -20 }T 342 | 343 | VARIABLE iters 344 | VARIABLE incrmnt 345 | 346 | : qd6 ( limit start increment -- ) 347 | incrmnt ! 348 | 0 iters ! 349 | ?DO 350 | 1 iters +! 351 | I 352 | iters @ 6 = IF LEAVE THEN 353 | incrmnt @ 354 | +LOOP iters @ 355 | ; 356 | 357 | T{ 4 4 -1 qd6 -> 0 }T 358 | T{ 1 4 -1 qd6 -> 4 3 2 1 4 }T 359 | T{ 4 1 -1 qd6 -> 1 0 -1 -2 -3 -4 6 }T 360 | T{ 4 1 0 qd6 -> 1 1 1 1 1 1 6 }T 361 | T{ 0 0 0 qd6 -> 0 }T 362 | T{ 1 4 0 qd6 -> 4 4 4 4 4 4 6 }T 363 | T{ 1 4 1 qd6 -> 4 5 6 7 8 9 6 }T 364 | T{ 4 1 1 qd6 -> 1 2 3 3 }T 365 | T{ 4 4 1 qd6 -> 0 }T 366 | T{ 2 -1 -1 qd6 -> -1 -2 -3 -4 -5 -6 6 }T 367 | T{ -1 2 -1 qd6 -> 2 1 0 -1 4 }T 368 | T{ 2 -1 0 qd6 -> -1 -1 -1 -1 -1 -1 6 }T 369 | T{ -1 2 0 qd6 -> 2 2 2 2 2 2 6 }T 370 | T{ -1 2 1 qd6 -> 2 3 4 5 6 7 6 }T 371 | T{ 2 -1 1 qd6 -> -1 0 1 3 }T 372 | 373 | \ ----------------------------------------------------------------------------- 374 | TESTING VALUE TO 375 | 376 | T{ 111 VALUE val1 -999 VALUE val2 -> }T 377 | T{ val1 -> 111 }T 378 | T{ val2 -> -999 }T 379 | T{ 222 TO val1 -> }T 380 | T{ val1 -> 222 }T 381 | T{ : vd1 val1 ; -> }T 382 | T{ vd1 -> 222 }T 383 | T{ : vd2 TO val2 ; -> }T 384 | T{ val2 -> -999 }T 385 | T{ -333 vd2 -> }T 386 | T{ val2 -> -333 }T 387 | T{ val1 -> 222 }T 388 | T{ 123 VALUE val3 IMMEDIATE val3 -> 123 }T 389 | T{ : vd3 val3 LITERAL ; vd3 -> 123 }T 390 | 391 | \ ----------------------------------------------------------------------------- 392 | TESTING CASE OF ENDOF ENDCASE 393 | 394 | : cs1 CASE 1 OF 111 ENDOF 395 | 2 OF 222 ENDOF 396 | 3 OF 333 ENDOF 397 | >R 999 R> 398 | ENDCASE 399 | ; 400 | 401 | T{ 1 cs1 -> 111 }T 402 | T{ 2 cs1 -> 222 }T 403 | T{ 3 cs1 -> 333 }T 404 | T{ 4 cs1 -> 999 }T 405 | 406 | \ Nested CASE's 407 | 408 | : cs2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF 409 | 2 OF 200 ENDOF 410 | >R -300 R> 411 | ENDCASE 412 | ENDOF 413 | -2 OF CASE R@ 1 OF -99 ENDOF 414 | >R -199 R> 415 | ENDCASE 416 | ENDOF 417 | >R 299 R> 418 | ENDCASE R> DROP 419 | ; 420 | 421 | T{ -1 1 cs2 -> 100 }T 422 | T{ -1 2 cs2 -> 200 }T 423 | T{ -1 3 cs2 -> -300 }T 424 | T{ -2 1 cs2 -> -99 }T 425 | T{ -2 2 cs2 -> -199 }T 426 | T{ 0 2 cs2 -> 299 }T 427 | 428 | \ Boolean short circuiting using CASE 429 | 430 | : cs3 ( n1 -- n2 ) 431 | CASE 1- FALSE OF 11 ENDOF 432 | 1- FALSE OF 22 ENDOF 433 | 1- FALSE OF 33 ENDOF 434 | 44 SWAP 435 | ENDCASE 436 | ; 437 | 438 | T{ 1 cs3 -> 11 }T 439 | T{ 2 cs3 -> 22 }T 440 | T{ 3 cs3 -> 33 }T 441 | T{ 9 cs3 -> 44 }T 442 | 443 | \ ----------------------------------------------------------------------------- 444 | TESTING :NONAME RECURSE 445 | 446 | VARIABLE nn1 447 | VARIABLE nn2 448 | :NONAME 1234 ; nn1 ! 449 | :NONAME 9876 ; nn2 ! 450 | T{ nn1 @ EXECUTE -> 1234 }T 451 | T{ nn2 @ EXECUTE -> 9876 }T 452 | 453 | T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; 454 | CONSTANT rn1 -> }T 455 | T{ 0 rn1 EXECUTE -> 0 }T 456 | T{ 4 rn1 EXECUTE -> 0 1 2 3 4 }T 457 | 458 | :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition 459 | 1- DUP 460 | CASE 0 OF EXIT ENDOF 461 | 1 OF 11 SWAP RECURSE ENDOF 462 | 2 OF 22 SWAP RECURSE ENDOF 463 | 3 OF 33 SWAP RECURSE ENDOF 464 | DROP ABS RECURSE EXIT 465 | ENDCASE 466 | ; CONSTANT rn2 467 | 468 | T{ 1 rn2 EXECUTE -> 0 }T 469 | T{ 2 rn2 EXECUTE -> 11 0 }T 470 | T{ 4 rn2 EXECUTE -> 33 22 11 0 }T 471 | T{ 25 rn2 EXECUTE -> 33 22 11 0 }T 472 | 473 | \ ----------------------------------------------------------------------------- 474 | TESTING C" 475 | 476 | T{ : cq1 C" 123" ; -> }T 477 | T{ cq1 COUNT EVALUATE -> 123 }T 478 | T{ : cq2 C" " ; -> }T 479 | T{ cq2 COUNT EVALUATE -> }T 480 | T{ : cq3 C" 2345"COUNT EVALUATE ; cq3 -> 2345 }T 481 | 482 | \ ----------------------------------------------------------------------------- 483 | TESTING COMPILE, [COMPILE] 484 | 485 | :NONAME DUP + ; CONSTANT dup+ 486 | T{ : q dup+ COMPILE, ; -> }T 487 | T{ : as1 [ q ] ; -> }T 488 | T{ 123 as1 -> 246 }T 489 | 490 | T{ : [c1] [COMPILE] DUP ; IMMEDIATE -> }T 491 | T{ 123 [c1] -> 123 123 }T \ With default compilation semantics 492 | T{ : [c2] [COMPILE] [c1] ; -> }T 493 | T{ 234 [c2] -> 234 234 }T \ With an immediate word 494 | T{ : [cif] [COMPILE] IF ; IMMEDIATE -> }T 495 | T{ : [c3] [cif] 111 ELSE 222 THEN ; -> }T \ With special compilation semantics 496 | T{ -1 [c3] -> 111 }T 497 | T{ 0 [c3] -> 222 }T 498 | 499 | \ ----------------------------------------------------------------------------- 500 | \ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source 501 | 502 | TESTING SAVE-INPUT and RESTORE-INPUT with a file source 503 | 504 | VARIABLE siv -1 siv ! 505 | 506 | : NeverExecuted 507 | CR ." This should never be executed" CR 508 | ; 509 | 510 | T{ 11111 SAVE-INPUT 511 | 512 | siv @ 513 | 514 | [IF] 515 | 0 siv ! 516 | RESTORE-INPUT 517 | NeverExecuted 518 | 33333 519 | [ELSE] 520 | 521 | TESTING the -[ELSE]- part is executed 522 | 22222 523 | 524 | [THEN] 525 | 526 | -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT 527 | 528 | TESTING SAVE-INPUT and RESTORE-INPUT with a string source 529 | 530 | VARIABLE si_inc 0 si_inc ! 531 | 532 | : si1 533 | si_inc @ >IN +! 534 | 15 si_inc ! 535 | ; 536 | 537 | : s$ S" SAVE-INPUT si1 RESTORE-INPUT 12345" ; 538 | 539 | T{ s$ EVALUATE si_inc @ -> 0 2345 15 }T 540 | 541 | TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file 542 | 543 | : read_a_line 544 | REFILL 0= 545 | ABORT" REFILL failed" 546 | ; 547 | 548 | 0 si_inc ! 549 | 550 | 2VARIABLE 2res -1. 2res 2! 551 | 552 | : si2 553 | read_a_line 554 | read_a_line 555 | SAVE-INPUT 556 | read_a_line 557 | read_a_line 558 | s$ EVALUATE 2res 2! 559 | RESTORE-INPUT 560 | ; 561 | 562 | \ WARNING: do not delete or insert lines of text after si2 is called 563 | \ otherwise the next test will fail 564 | 565 | T{ si2 566 | 33333 \ This line should be ignored 567 | 2res 2@ 44444 \ RESTORE-INPUT should return to this line 568 | 569 | 55555 570 | TESTING the nested results 571 | -> 0 0 2345 44444 55555 }T 572 | 573 | \ End of warning 574 | 575 | \ ----------------------------------------------------------------------------- 576 | TESTING .( 577 | 578 | CR CR .( Output from .() 579 | T{ CR .( You should see -9876: ) -9876 . -> }T 580 | T{ CR .( and again: ).( -9876)CR -> }T 581 | 582 | CR CR .( On the next 2 lines you should see First then Second messages:) 583 | T{ : dotp CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate 584 | [ CR ] .( First message via .( ) ; dotp -> }T 585 | CR CR 586 | T{ : imm? bl word find nip ; imm? .( -> 1 }T 587 | 588 | \ ----------------------------------------------------------------------------- 589 | TESTING .R and U.R - has to handle different cell sizes 590 | 591 | \ Create some large integers 592 | MAX-INT 73 79 */ CONSTANT li1 593 | MIN-INT 71 73 */ CONSTANT li2 594 | 595 | li1 0 <# #S #> NIP CONSTANT lenli1 596 | 597 | : (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation 598 | TUCK + >R 599 | li1 OVER SPACES . CR R@ li1 SWAP .R CR 600 | li2 OVER SPACES . CR R@ 1+ li2 SWAP .R CR 601 | li1 OVER SPACES U. CR R@ li1 SWAP U.R CR 602 | li2 SWAP SPACES U. CR R> li2 SWAP U.R CR 603 | ; 604 | 605 | : .R&U.R ( -- ) 606 | CR ." You should see lines duplicated:" CR 607 | ." indented by 0 spaces" CR 0 0 (.R&U.R) CR 608 | ." indented by 0 spaces" CR lenli1 0 (.R&U.R) CR \ Just fits required width 609 | ." indented by 5 spaces" CR lenli1 5 (.R&U.R) CR 610 | ; 611 | 612 | CR CR .( Output from .R and U.R) 613 | T{ .R&U.R -> }T 614 | 615 | \ ----------------------------------------------------------------------------- 616 | TESTING PAD ERASE 617 | \ Must handle different size characters i.e. 1 CHARS >= 1 618 | 619 | 84 CONSTANT chars/pad \ Minimum size of PAD in chars 620 | chars/pad CHARS CONSTANT aus/pad 621 | : checkpad ( caddr u ch -- f ) \ f = TRUE if u chars = ch 622 | SWAP 0 623 | ?DO 624 | OVER I CHARS + C@ OVER <> 625 | IF 2DROP UNLOOP FALSE EXIT THEN 626 | LOOP 627 | 2DROP TRUE 628 | ; 629 | 630 | T{ PAD DROP -> }T 631 | T{ 0 INVERT PAD C! -> }T 632 | T{ PAD C@ CONSTANT maxchar -> }T 633 | T{ PAD chars/pad 2DUP maxchar FILL maxchar checkpad -> TRUE }T 634 | T{ PAD chars/pad 2DUP CHARS ERASE 0 checkpad -> TRUE }T 635 | T{ PAD chars/pad 2DUP maxchar FILL PAD 0 ERASE maxchar checkpad -> TRUE }T 636 | T{ PAD 43 CHARS + 9 CHARS ERASE -> }T 637 | T{ PAD 43 maxchar checkpad -> TRUE }T 638 | T{ PAD 43 CHARS + 9 0 checkpad -> TRUE }T 639 | T{ PAD 52 CHARS + chars/pad 52 - maxchar checkpad -> TRUE }T 640 | 641 | \ Check that use of WORD and pictured numeric output do not corrupt PAD 642 | \ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively 643 | \ where n is number of bits per cell 644 | 645 | PAD chars/pad ERASE 646 | 2 BASE ! 647 | MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP 648 | DECIMAL 649 | BL WORD 12345678123456781234567812345678 DROP 650 | T{ PAD chars/pad 0 checkpad -> TRUE }T 651 | 652 | \ ----------------------------------------------------------------------------- 653 | TESTING PARSE 654 | 655 | T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T 656 | T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T 657 | : pa1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; 658 | T{ pa1 3456 659 | DUP ROT ROT EVALUATE -> 4 3456 }T 660 | T{ CHAR a PARSE a SWAP DROP -> 0 }T 661 | T{ CHAR z PARSE 662 | SWAP DROP -> 0 }T 663 | T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T 664 | 665 | \ ----------------------------------------------------------------------------- 666 | TESTING REFILL SOURCE-ID 667 | \ REFILL and SOURCE-ID from the user input device can't be tested from a file, 668 | \ can only be tested from a string via EVALUATE 669 | 670 | T{ : rf1 S" REFILL" EVALUATE ; rf1 -> FALSE }T 671 | T{ : sid1 S" SOURCE-ID" EVALUATE ; sid1 -> -1 }T 672 | 673 | \ ----------------------------------------------------------------------------- 674 | 675 | CR .( End of Core Extension word tests) CR 676 | 677 | 678 | -------------------------------------------------------------------------------- /software/anstests0.10/coreplustest.fth: -------------------------------------------------------------------------------- 1 | \ Additional tests on the the ANS Forth Core word set 2 | 3 | \ This program was written by Gerry Jackson in 2007, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.10 3 August 2014 Test IMMEDIATE doesn't toggle an immediate flag 15 | \ 0.3 1 April 2012 Tests placed in the public domain. 16 | \ Testing multiple ELSE's. 17 | \ Further tests on DO +LOOPs. 18 | \ Ackermann function added to test RECURSE. 19 | \ >IN manipulation in interpreter mode 20 | \ Immediate CONSTANTs, VARIABLEs and CREATEd words tests. 21 | \ :NONAME with RECURSE moved to core extension tests. 22 | \ Parsing behaviour of S" ." and ( tested 23 | \ 0.2 6 March 2009 { and } replaced with T{ and }T 24 | \ Added extra RECURSE tests 25 | \ 0.1 20 April 2007 Created 26 | \ ------------------------------------------------------------------------------ 27 | \ The tests are based on John Hayes test program for the core word set 28 | \ 29 | \ This file provides some more tests on Core words where the original Hayes 30 | \ tests are thought to be incomplete 31 | \ 32 | \ Words tested in this file are: 33 | \ DO +LOOP RECURSE ELSE >IN IMMEDIATE 34 | \ ------------------------------------------------------------------------------ 35 | \ Assumptions and dependencies: 36 | \ - tester.fr or ttester.fs has been loaded prior to this file 37 | \ - core.fr has been loaded so that constants MAX-INT, MIN-INT and 38 | \ MAX-UINT are defined 39 | \ ------------------------------------------------------------------------------ 40 | 41 | DECIMAL 42 | 43 | TESTING DO +LOOP with run-time increment, negative increment, infinite loop 44 | \ Contributed by Reinhold Straub 45 | 46 | VARIABLE iterations 47 | VARIABLE increment 48 | : gd7 ( limit start increment -- ) 49 | increment ! 50 | 0 iterations ! 51 | DO 52 | 1 iterations +! 53 | I 54 | iterations @ 6 = IF LEAVE THEN 55 | increment @ 56 | +LOOP iterations @ 57 | ; 58 | 59 | T{ 4 4 -1 gd7 -> 4 1 }T 60 | T{ 1 4 -1 gd7 -> 4 3 2 1 4 }T 61 | T{ 4 1 -1 gd7 -> 1 0 -1 -2 -3 -4 6 }T 62 | T{ 4 1 0 gd7 -> 1 1 1 1 1 1 6 }T 63 | T{ 0 0 0 gd7 -> 0 0 0 0 0 0 6 }T 64 | T{ 1 4 0 gd7 -> 4 4 4 4 4 4 6 }T 65 | T{ 1 4 1 gd7 -> 4 5 6 7 8 9 6 }T 66 | T{ 4 1 1 gd7 -> 1 2 3 3 }T 67 | T{ 4 4 1 gd7 -> 4 5 6 7 8 9 6 }T 68 | T{ 2 -1 -1 gd7 -> -1 -2 -3 -4 -5 -6 6 }T 69 | T{ -1 2 -1 gd7 -> 2 1 0 -1 4 }T 70 | T{ 2 -1 0 gd7 -> -1 -1 -1 -1 -1 -1 6 }T 71 | T{ -1 2 0 gd7 -> 2 2 2 2 2 2 6 }T 72 | T{ -1 2 1 gd7 -> 2 3 4 5 6 7 6 }T 73 | T{ 2 -1 1 gd7 -> -1 0 1 3 }T 74 | T{ -20 30 -10 gd7 -> 30 20 10 0 -10 -20 6 }T 75 | T{ -20 31 -10 gd7 -> 31 21 11 1 -9 -19 6 }T 76 | T{ -20 29 -10 gd7 -> 29 19 9 -1 -11 5 }T 77 | 78 | \ ------------------------------------------------------------------------------ 79 | TESTING DO +LOOP with large and small increments 80 | 81 | \ Contributed by Andrew Haley 82 | 83 | MAX-UINT 8 RSHIFT 1+ CONSTANT ustep 84 | ustep NEGATE CONSTANT -ustep 85 | MAX-INT 7 RSHIFT 1+ CONSTANT step 86 | step NEGATE CONSTANT -step 87 | 88 | VARIABLE bump 89 | 90 | T{ : gd8 bump ! DO 1+ bump @ +LOOP ; -> }T 91 | 92 | T{ 0 MAX-UINT 0 ustep gd8 -> 256 }T 93 | T{ 0 0 MAX-UINT -ustep gd8 -> 256 }T 94 | 95 | T{ 0 MAX-INT MIN-INT step gd8 -> 256 }T 96 | T{ 0 MIN-INT MAX-INT -step gd8 -> 256 }T 97 | 98 | \ Two's complement arithmetic, wraps around modulo wordsize 99 | \ Only tested if the Forth system does wrap around, use of conditional 100 | \ compilation deliberately avoided 101 | 102 | MAX-INT 1+ MIN-INT = CONSTANT +wrap? 103 | MIN-INT 1- MAX-INT = CONSTANT -wrap? 104 | MAX-UINT 1+ 0= CONSTANT +uwrap? 105 | 0 1- MAX-UINT = CONSTANT -uwrap? 106 | 107 | : gd9 ( n limit start step f result -- ) 108 | >R IF gd8 ELSE 2DROP 2DROP R@ THEN -> R> }T 109 | ; 110 | 111 | T{ 0 0 0 ustep +uwrap? 256 gd9 112 | T{ 0 0 0 -ustep -uwrap? 1 gd9 113 | T{ 0 MIN-INT MAX-INT step +wrap? 1 gd9 114 | T{ 0 MAX-INT MIN-INT -step -wrap? 1 gd9 115 | 116 | \ ------------------------------------------------------------------------------ 117 | TESTING DO +LOOP with maximum and minimum increments 118 | 119 | : (-mi) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; 120 | (-mi) CONSTANT -max-int 121 | 122 | T{ 0 1 0 MAX-INT gd8 -> 1 }T 123 | T{ 0 -max-int NEGATE -max-int OVER gd8 -> 2 }T 124 | 125 | T{ 0 MAX-INT 0 MAX-INT gd8 -> 1 }T 126 | T{ 0 MAX-INT 1 MAX-INT gd8 -> 1 }T 127 | T{ 0 MAX-INT -1 MAX-INT gd8 -> 2 }T 128 | T{ 0 MAX-INT dup 1- MAX-INT gd8 -> 1 }T 129 | 130 | T{ 0 MIN-INT 1+ 0 MIN-INT gd8 -> 1 }T 131 | T{ 0 MIN-INT 1+ -1 MIN-INT gd8 -> 1 }T 132 | T{ 0 MIN-INT 1+ 1 MIN-INT gd8 -> 2 }T 133 | T{ 0 MIN-INT 1+ DUP MIN-INT gd8 -> 1 }T 134 | 135 | \ ------------------------------------------------------------------------------ 136 | TESTING multiple RECURSEs in one colon definition 137 | 138 | : ack ( m n -- u ) \ Ackermann function, from Rosetta Code 139 | OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 140 | SWAP 1- SWAP ( -- m-1 n ) 141 | DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) 142 | 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) 143 | ; 144 | 145 | T{ 0 0 ack -> 1 }T 146 | T{ 3 0 ack -> 5 }T 147 | T{ 2 4 ack -> 11 }T 148 | 149 | \ ------------------------------------------------------------------------------ 150 | TESTING multiple ELSE's in an IF statement 151 | \ Discussed on comp.lang.forth and accepted as valid ANS Forth 152 | 153 | : melse IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; 154 | T{ 0 melse -> 2 4 }T 155 | T{ -1 melse -> 1 3 5 }T 156 | 157 | \ ------------------------------------------------------------------------------ 158 | TESTING manipulation of >IN in interpreter mode 159 | 160 | T{ 123456 depth over 9 < 35 and + 3 + >in ! -> 123456 23456 3456 456 56 6 }T 161 | T{ 14145 8115 ?dup 0= 34 and >in +! tuck mod 14 >in ! GCD calculation -> 15 }T 162 | 163 | \ ------------------------------------------------------------------------------ 164 | TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] 165 | 166 | T{ 123 CONSTANT iw1 IMMEDIATE iw1 -> 123 }T 167 | T{ : iw2 iw1 LITERAL ; iw2 -> 123 }T 168 | T{ VARIABLE iw3 IMMEDIATE 234 iw3 ! iw3 @ -> 234 }T 169 | T{ : iw4 iw3 [ @ ] LITERAL ; iw4 -> 234 }T 170 | T{ :noname [ 345 ] iw3 [ ! ] ; DROP iw3 @ -> 345 }T 171 | T{ CREATE iw5 456 , IMMEDIATE -> }T 172 | T{ :noname iw5 [ @ iw3 ! ] ; DROP iw3 @ -> 456 }T 173 | T{ : iw6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T 174 | T{ 111 iw6 iw7 iw7 -> 112 }T 175 | T{ : iw8 iw7 LITERAL 1+ ; iw8 -> 113 }T 176 | T{ : iw9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T 177 | : find-iw bl word find nip ; ( -- 0 | 1 | -1 ) 178 | T{ 222 iw9 iw10 find-iw iw10 -> -1 }T \ iw10 is not immediate 179 | T{ iw10 find-iw iw10 -> 224 1 }T \ iw10 becomes immediate 180 | 181 | \ ------------------------------------------------------------------------------ 182 | TESTING that IMMEDIATE doesn't toggle a flag 183 | 184 | VARIABLE it1 0 it1 ! 185 | : it2 1234 it1 ! ; IMMEDIATE IMMEDIATE 186 | T{ : it3 it2 ; it1 @ -> 1234 }T 187 | 188 | \ ------------------------------------------------------------------------------ 189 | TESTING parsing behaviour of S" ." and ( 190 | \ which should parse to just beyond the terminating character no space needed 191 | 192 | T{ S" A string"2DROP -> }T 193 | T{ ( A comment)1234 -> 1234 }T 194 | T{ : pb1 cr ." You should see 2345: "." 2345"( A comment) CR ; pb1 -> }T 195 | 196 | \ ------------------------------------------------------------------------------ 197 | 198 | CR .( End of additional Core tests) CR 199 | -------------------------------------------------------------------------------- /software/anstests0.10/doubletest.fth: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth Double-Number word set and double number extensions 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | \ ------------------------------------------------------------------------------ 13 | \ Version 0.6 1 April 2012 Tests placed in the public domain. 14 | \ Immediate 2CONSTANTs and 2VARIABLEs tested 15 | \ 0.5 20 November 2009 Various constants renamed to avoid 16 | \ redefinition warnings. and replaced 17 | \ with TRUE and FALSE 18 | \ 0.4 6 March 2009 { and } replaced with T{ and }T 19 | \ Tests rewritten to be independent of word size and 20 | \ tests re-ordered 21 | \ 0.3 20 April 2007 ANS Forth words changed to upper case 22 | \ 0.2 30 Oct 2006 Updated following GForth test to include 23 | \ various constants from core.fr 24 | \ 0.1 Oct 2006 First version released 25 | \ ------------------------------------------------------------------------------ 26 | \ The tests are based on John Hayes test program for the core word set 27 | 28 | \ Words tested in this file are: 29 | \ 2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/ 30 | \ D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU< 31 | \ Also tests the interpreter and compiler reading a double number 32 | \ ------------------------------------------------------------------------------ 33 | \ Assumptions and dependencies: 34 | \ - tester.fr or ttester.fs has been included prior to this file 35 | \ - core words and core extension words have been tested 36 | \ ------------------------------------------------------------------------------ 37 | \ Constant definitions 38 | 39 | DECIMAL 40 | 0 INVERT CONSTANT 1sd 41 | 1sd 1 RSHIFT CONSTANT max-intd \ 01...1 42 | max-intd INVERT CONSTANT min-intd \ 10...0 43 | max-intd 2/ CONSTANT hi-int \ 001...1 44 | min-intd 2/ CONSTANT lo-int \ 110...1 45 | 46 | \ ------------------------------------------------------------------------------ 47 | TESTING interpreter and compiler reading a double number 48 | 49 | T{ 1. -> 1 0 }T 50 | T{ -2. -> -2 -1 }T 51 | T{ : rdl1 3. ; rdl1 -> 3 0 }T 52 | T{ : rdl2 -4. ; rdl2 -> -4 -1 }T 53 | 54 | \ ------------------------------------------------------------------------------ 55 | TESTING 2CONSTANT 56 | 57 | T{ 1 2 2CONSTANT 2c1 -> }T 58 | T{ 2c1 -> 1 2 }T 59 | T{ : cd1 2c1 ; -> }T 60 | T{ cd1 -> 1 2 }T 61 | T{ : cd2 2CONSTANT ; -> }T 62 | T{ -1 -2 cd2 2c2 -> }T 63 | T{ 2c2 -> -1 -2 }T 64 | T{ 4 5 2CONSTANT 2c3 IMMEDIATE 2c3 -> 4 5 }T 65 | T{ : cd6 2c3 2LITERAL ; cd6 -> 4 5 }T 66 | 67 | \ ------------------------------------------------------------------------------ 68 | \ Some 2CONSTANTs for the following tests 69 | 70 | 1sd max-intd 2CONSTANT max-2int \ 01...1 71 | 0 min-intd 2CONSTANT min-2int \ 10...0 72 | max-2int 2/ 2CONSTANT hi-2int \ 001...1 73 | min-2int 2/ 2CONSTANT lo-2int \ 110...0 74 | 75 | \ ------------------------------------------------------------------------------ 76 | TESTING DNEGATE 77 | 78 | T{ 0. DNEGATE -> 0. }T 79 | T{ 1. DNEGATE -> -1. }T 80 | T{ -1. DNEGATE -> 1. }T 81 | T{ max-2int DNEGATE -> min-2int SWAP 1+ SWAP }T 82 | T{ min-2int SWAP 1+ SWAP DNEGATE -> max-2int }T 83 | 84 | \ ------------------------------------------------------------------------------ 85 | TESTING D+ with small integers 86 | 87 | T{ 0. 5. D+ -> 5. }T 88 | T{ -5. 0. D+ -> -5. }T 89 | T{ 1. 2. D+ -> 3. }T 90 | T{ 1. -2. D+ -> -1. }T 91 | T{ -1. 2. D+ -> 1. }T 92 | T{ -1. -2. D+ -> -3. }T 93 | T{ -1. 1. D+ -> 0. }T 94 | 95 | TESTING D+ with mid range integers 96 | 97 | T{ 0 0 0 5 D+ -> 0 5 }T 98 | T{ -1 5 0 0 D+ -> -1 5 }T 99 | T{ 0 0 0 -5 D+ -> 0 -5 }T 100 | T{ 0 -5 -1 0 D+ -> -1 -5 }T 101 | T{ 0 1 0 2 D+ -> 0 3 }T 102 | T{ -1 1 0 -2 D+ -> -1 -1 }T 103 | T{ 0 -1 0 2 D+ -> 0 1 }T 104 | T{ 0 -1 -1 -2 D+ -> -1 -3 }T 105 | T{ -1 -1 0 1 D+ -> -1 0 }T 106 | T{ min-intd 0 2DUP D+ -> 0 1 }T 107 | T{ min-intd S>D min-intd 0 D+ -> 0 0 }T 108 | 109 | TESTING D+ with large double integers 110 | 111 | T{ hi-2int 1. D+ -> 0 hi-int 1+ }T 112 | T{ hi-2int 2DUP D+ -> 1sd 1- max-intd }T 113 | T{ max-2int min-2int D+ -> -1. }T 114 | T{ max-2int lo-2int D+ -> hi-2int }T 115 | T{ hi-2int min-2int D+ 1. D+ -> lo-2int }T 116 | T{ lo-2int 2DUP D+ -> min-2int }T 117 | 118 | \ ------------------------------------------------------------------------------ 119 | TESTING D- with small integers 120 | 121 | T{ 0. 5. D- -> -5. }T 122 | T{ 5. 0. D- -> 5. }T 123 | T{ 0. -5. D- -> 5. }T 124 | T{ 1. 2. D- -> -1. }T 125 | T{ 1. -2. D- -> 3. }T 126 | T{ -1. 2. D- -> -3. }T 127 | T{ -1. -2. D- -> 1. }T 128 | T{ -1. -1. D- -> 0. }T 129 | 130 | TESTING D- with mid-range integers 131 | 132 | T{ 0 0 0 5 D- -> 0 -5 }T 133 | T{ -1 5 0 0 D- -> -1 5 }T 134 | T{ 0 0 -1 -5 D- -> 1 4 }T 135 | T{ 0 -5 0 0 D- -> 0 -5 }T 136 | T{ -1 1 0 2 D- -> -1 -1 }T 137 | T{ 0 1 -1 -2 D- -> 1 2 }T 138 | T{ 0 -1 0 2 D- -> 0 -3 }T 139 | T{ 0 -1 0 -2 D- -> 0 1 }T 140 | T{ 0 0 0 1 D- -> 0 -1 }T 141 | T{ min-intd 0 2DUP D- -> 0. }T 142 | T{ min-intd S>D max-intd 0 D- -> 1 1sd }T 143 | 144 | TESTING D- with large integers 145 | 146 | T{ max-2int max-2int D- -> 0. }T 147 | T{ min-2int min-2int D- -> 0. }T 148 | T{ max-2int hi-2int D- -> lo-2int DNEGATE }T 149 | T{ hi-2int lo-2int D- -> max-2int }T 150 | T{ lo-2int hi-2int D- -> min-2int 1. D+ }T 151 | T{ min-2int min-2int D- -> 0. }T 152 | T{ min-2int lo-2int D- -> lo-2int }T 153 | 154 | \ ------------------------------------------------------------------------------ 155 | TESTING D0< D0= 156 | 157 | T{ 0. D0< -> FALSE }T 158 | T{ 1. D0< -> FALSE }T 159 | T{ min-intd 0 D0< -> FALSE }T 160 | T{ 0 max-intd D0< -> FALSE }T 161 | T{ max-2int D0< -> FALSE }T 162 | T{ -1. D0< -> TRUE }T 163 | T{ min-2int D0< -> TRUE }T 164 | 165 | T{ 1. D0= -> FALSE }T 166 | T{ min-intd 0 D0= -> FALSE }T 167 | T{ max-2int D0= -> FALSE }T 168 | T{ -1 max-intd D0= -> FALSE }T 169 | T{ 0. D0= -> TRUE }T 170 | T{ -1. D0= -> FALSE }T 171 | T{ 0 min-intd D0= -> FALSE }T 172 | 173 | \ ------------------------------------------------------------------------------ 174 | TESTING D2* D2/ 175 | 176 | T{ 0. D2* -> 0. D2* }T 177 | T{ min-intd 0 D2* -> 0 1 }T 178 | T{ hi-2int D2* -> max-2int 1. D- }T 179 | T{ lo-2int D2* -> min-2int }T 180 | 181 | T{ 0. D2/ -> 0. }T 182 | T{ 1. D2/ -> 0. }T 183 | T{ 0 1 D2/ -> min-intd 0 }T 184 | T{ max-2int D2/ -> hi-2int }T 185 | T{ -1. D2/ -> -1. }T 186 | T{ min-2int D2/ -> lo-2int }T 187 | 188 | \ ------------------------------------------------------------------------------ 189 | TESTING D< D= 190 | 191 | T{ 0. 1. D< -> TRUE }T 192 | T{ 0. 0. D< -> FALSE }T 193 | T{ 1. 0. D< -> FALSE }T 194 | T{ -1. 1. D< -> TRUE }T 195 | T{ -1. 0. D< -> TRUE }T 196 | T{ -2. -1. D< -> TRUE }T 197 | T{ -1. -2. D< -> FALSE }T 198 | T{ -1. max-2int D< -> TRUE }T 199 | T{ min-2int max-2int D< -> TRUE }T 200 | T{ max-2int -1. D< -> FALSE }T 201 | T{ max-2int min-2int D< -> FALSE }T 202 | T{ max-2int 2DUP -1. D+ D< -> FALSE }T 203 | T{ min-2int 2DUP 1. D+ D< -> TRUE }T 204 | 205 | T{ -1. -1. D= -> TRUE }T 206 | T{ -1. 0. D= -> FALSE }T 207 | T{ -1. 1. D= -> FALSE }T 208 | T{ 0. -1. D= -> FALSE }T 209 | T{ 0. 0. D= -> TRUE }T 210 | T{ 0. 1. D= -> FALSE }T 211 | T{ 1. -1. D= -> FALSE }T 212 | T{ 1. 0. D= -> FALSE }T 213 | T{ 1. 1. D= -> TRUE }T 214 | 215 | T{ 0 -1 0 -1 D= -> TRUE }T 216 | T{ 0 -1 0 0 D= -> FALSE }T 217 | T{ 0 -1 0 1 D= -> FALSE }T 218 | T{ 0 0 0 -1 D= -> FALSE }T 219 | T{ 0 0 0 0 D= -> TRUE }T 220 | T{ 0 0 0 1 D= -> FALSE }T 221 | T{ 0 1 0 -1 D= -> FALSE }T 222 | T{ 0 1 0 0 D= -> FALSE }T 223 | T{ 0 1 0 1 D= -> TRUE }T 224 | 225 | T{ max-2int min-2int D= -> FALSE }T 226 | T{ max-2int 0. D= -> FALSE }T 227 | T{ max-2int max-2int D= -> TRUE }T 228 | T{ max-2int hi-2int D= -> FALSE }T 229 | T{ max-2int min-2int D= -> FALSE }T 230 | T{ min-2int min-2int D= -> TRUE }T 231 | T{ min-2int lo-2int D= -> FALSE }T 232 | T{ min-2int max-2int D= -> FALSE }T 233 | 234 | \ ------------------------------------------------------------------------------ 235 | TESTING 2LITERAL 2VARIABLE 236 | 237 | T{ : cd3 [ max-2int ] 2LITERAL ; -> }T 238 | T{ cd3 -> max-2int }T 239 | T{ 2VARIABLE 2v1 -> }T 240 | T{ 0. 2v1 2! -> }T 241 | T{ 2v1 2@ -> 0. }T 242 | T{ -1 -2 2v1 2! -> }T 243 | T{ 2v1 2@ -> -1 -2 }T 244 | T{ : cd4 2VARIABLE ; -> }T 245 | T{ cd4 2v2 -> }T 246 | T{ : cd5 2v2 2! ; -> }T 247 | T{ -2 -1 cd5 -> }T 248 | T{ 2v2 2@ -> -2 -1 }T 249 | T{ 2VARIABLE 2v3 IMMEDIATE 5 6 2v3 2! -> }T 250 | T{ 2v3 2@ -> 5 6 }T 251 | T{ : cd7 2v3 [ 2@ ] 2LITERAL ; cd7 -> 5 6 }T 252 | T{ : cd8 [ 6 7 ] 2v3 [ 2! ] ; 2v3 2@ -> 6 7 }T 253 | 254 | \ ------------------------------------------------------------------------------ 255 | TESTING DMAX DMIN 256 | 257 | T{ 1. 2. DMAX -> 2. }T 258 | T{ 1. 0. DMAX -> 1. }T 259 | T{ 1. -1. DMAX -> 1. }T 260 | T{ 1. 1. DMAX -> 1. }T 261 | T{ 0. 1. DMAX -> 1. }T 262 | T{ 0. -1. DMAX -> 0. }T 263 | T{ -1. 1. DMAX -> 1. }T 264 | T{ -1. -2. DMAX -> -1. }T 265 | 266 | T{ max-2int hi-2int DMAX -> max-2int }T 267 | T{ max-2int min-2int DMAX -> max-2int }T 268 | T{ min-2int max-2int DMAX -> max-2int }T 269 | T{ min-2int lo-2int DMAX -> lo-2int }T 270 | 271 | T{ max-2int 1. DMAX -> max-2int }T 272 | T{ max-2int -1. DMAX -> max-2int }T 273 | T{ min-2int 1. DMAX -> 1. }T 274 | T{ min-2int -1. DMAX -> -1. }T 275 | 276 | 277 | T{ 1. 2. DMIN -> 1. }T 278 | T{ 1. 0. DMIN -> 0. }T 279 | T{ 1. -1. DMIN -> -1. }T 280 | T{ 1. 1. DMIN -> 1. }T 281 | T{ 0. 1. DMIN -> 0. }T 282 | T{ 0. -1. DMIN -> -1. }T 283 | T{ -1. 1. DMIN -> -1. }T 284 | T{ -1. -2. DMIN -> -2. }T 285 | 286 | T{ max-2int hi-2int DMIN -> hi-2int }T 287 | T{ max-2int min-2int DMIN -> min-2int }T 288 | T{ min-2int max-2int DMIN -> min-2int }T 289 | T{ min-2int lo-2int DMIN -> min-2int }T 290 | 291 | T{ max-2int 1. DMIN -> 1. }T 292 | T{ max-2int -1. DMIN -> -1. }T 293 | T{ min-2int 1. DMIN -> min-2int }T 294 | T{ min-2int -1. DMIN -> min-2int }T 295 | 296 | \ ------------------------------------------------------------------------------ 297 | TESTING D>S DABS 298 | 299 | T{ 1234 0 D>S -> 1234 }T 300 | T{ -1234 -1 D>S -> -1234 }T 301 | T{ max-intd 0 D>S -> max-intd }T 302 | T{ min-intd -1 D>S -> min-intd }T 303 | 304 | T{ 1. DABS -> 1. }T 305 | T{ -1. DABS -> 1. }T 306 | T{ max-2int DABS -> max-2int }T 307 | T{ min-2int 1. D+ DABS -> max-2int }T 308 | 309 | \ ------------------------------------------------------------------------------ 310 | TESTING M+ M*/ 311 | 312 | T{ hi-2int 1 M+ -> hi-2int 1. D+ }T 313 | T{ max-2int -1 M+ -> max-2int -1. D+ }T 314 | T{ min-2int 1 M+ -> min-2int 1. D+ }T 315 | T{ lo-2int -1 M+ -> lo-2int -1. D+ }T 316 | 317 | \ To correct the result if the division is floored, only used when 318 | \ necessary i.e. negative quotient and remainder <> 0 319 | 320 | : ?floored [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ; 321 | 322 | T{ 5. 7 11 M*/ -> 3. }T 323 | T{ 5. -7 11 M*/ -> -3. ?floored }T \ floored -4. 324 | T{ -5. 7 11 M*/ -> -3. ?floored }T \ floored -4. 325 | T{ -5. -7 11 M*/ -> 3. }T 326 | T{ max-2int 8 16 M*/ -> hi-2int }T 327 | T{ max-2int -8 16 M*/ -> hi-2int DNEGATE ?floored }T \ floored subtract 1 328 | T{ min-2int 8 16 M*/ -> lo-2int }T 329 | T{ min-2int -8 16 M*/ -> lo-2int DNEGATE }T 330 | T{ max-2int max-intd max-intd M*/ -> max-2int }T 331 | T{ max-2int max-intd 2/ max-intd M*/ -> max-intd 1- hi-2int NIP }T 332 | T{ min-2int lo-2int NIP DUP NEGATE M*/ -> min-2int }T 333 | T{ min-2int lo-2int NIP 1- max-intd M*/ -> min-intd 3 + hi-2int NIP 2 + }T 334 | T{ max-2int lo-2int NIP DUP NEGATE M*/ -> max-2int DNEGATE }T 335 | T{ min-2int max-intd DUP M*/ -> min-2int }T 336 | 337 | \ ------------------------------------------------------------------------------ 338 | TESTING D. D.R 339 | 340 | \ Create some large double numbers 341 | max-2int 71 73 M*/ 2CONSTANT dbl1 342 | min-2int 73 79 M*/ 2CONSTANT dbl2 343 | 344 | : d>ascii ( d -- caddr u ) 345 | DUP >R <# DABS #S R> SIGN #> ( -- caddr1 u ) 346 | HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R> 347 | ; 348 | 349 | dbl1 d>ascii 2CONSTANT "dbl1" 350 | dbl2 d>ascii 2CONSTANT "dbl2" 351 | 352 | : DoubleOutput 353 | CR ." You should see lines duplicated:" CR 354 | 5 SPACES "dbl1" TYPE CR 355 | 5 SPACES dbl1 D. CR 356 | 8 SPACES "dbl1" DUP >R TYPE CR 357 | 5 SPACES dbl1 R> 3 + D.R CR 358 | 5 SPACES "dbl2" TYPE CR 359 | 5 SPACES dbl2 D. CR 360 | 10 SPACES "dbl2" DUP >R TYPE CR 361 | 5 SPACES dbl2 R> 5 + D.R CR 362 | ; 363 | 364 | T{ DoubleOutput -> }T 365 | 366 | \ ------------------------------------------------------------------------------ 367 | TESTING 2ROT DU< (Double Number extension words) 368 | 369 | T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T 370 | T{ max-2int min-2int 1. 2ROT -> min-2int 1. max-2int }T 371 | 372 | T{ 1. 1. DU< -> FALSE }T 373 | T{ 1. -1. DU< -> TRUE }T 374 | T{ -1. 1. DU< -> FALSE }T 375 | T{ -1. -2. DU< -> FALSE }T 376 | 377 | T{ max-2int hi-2int DU< -> FALSE }T 378 | T{ hi-2int max-2int DU< -> TRUE }T 379 | T{ max-2int min-2int DU< -> TRUE }T 380 | T{ min-2int max-2int DU< -> FALSE }T 381 | T{ min-2int lo-2int DU< -> TRUE }T 382 | 383 | \ ------------------------------------------------------------------------------ 384 | 385 | CR .( End of Double-Number word tests) CR 386 | 387 | -------------------------------------------------------------------------------- /software/anstests0.10/exceptiontest.fth: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth Exception word set and extension words 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.4 1 April 2012 Tests placed in the public domain. 15 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 16 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 17 | \ 0.1 Oct 2006 First version released 18 | 19 | \ ------------------------------------------------------------------------------ 20 | \ The tests are based on John Hayes test program for the core word set 21 | \ 22 | \ Words tested in this file are: 23 | \ CATCH THROW ABORT ABORT" 24 | \ 25 | \ ------------------------------------------------------------------------------ 26 | \ Assumptions and dependencies: 27 | \ - the forth system under test throws an exception with throw 28 | \ code -13 for a word not found by the text interpreter. The 29 | \ undefined word used is $$qweqweqwert$$, if this happens to be 30 | \ a valid word in your system change the definition of t7 below 31 | \ - tester.fr or ttester.fs has been loaded prior to this file 32 | \ - CASE, OF, ENDOF and ENDCASE from the core extension wordset 33 | \ are present and work correctly 34 | \ ------------------------------------------------------------------------------ 35 | TESTING CATCH THROW 36 | 37 | DECIMAL 38 | 39 | : t1 9 ; 40 | : c1 1 2 3 ['] t1 CATCH ; 41 | T{ c1 -> 1 2 3 9 0 }T \ No THROW executed 42 | 43 | : t2 8 0 THROW ; 44 | : c2 1 2 ['] t2 CATCH ; 45 | T{ c2 -> 1 2 8 0 }T \ 0 THROW does nothing 46 | 47 | : t3 7 8 9 99 THROW ; 48 | : c3 1 2 ['] t3 CATCH ; 49 | T{ c3 -> 1 2 99 }T \ Restores stack to CATCH depth 50 | 51 | : t4 1- DUP 0> IF RECURSE ELSE 999 THROW -222 THEN ; 52 | : c4 3 4 5 10 ['] t4 CATCH -111 ; 53 | T{ c4 -> 3 4 5 0 999 -111 }T \ Test return stack unwinding 54 | 55 | : t5 2DROP 2DROP 9999 THROW ; 56 | : c5 1 2 3 4 ['] t5 CATCH \ Test depth restored correctly 57 | DEPTH >R DROP 2DROP 2DROP R> ; \ after stack has been emptied 58 | T{ c5 -> 5 }T 59 | 60 | \ ------------------------------------------------------------------------------ 61 | TESTING ABORT ABORT" 62 | 63 | -1 CONSTANT exc_abort 64 | -2 CONSTANT exc_abort" 65 | -13 CONSTANT exc_undef 66 | : t6 ABORT ; 67 | 68 | \ The 77 in t10 is necessary for the second ABORT" test as the data stack 69 | \ is restored to a depth of 2 when THROW is executed. The 77 ensures the top 70 | \ of stack value is known for the results check 71 | 72 | : t10 77 SWAP ABORT" This should not be displayed" ; 73 | : c6 CATCH 74 | CASE exc_abort OF 11 ENDOF 75 | exc_abort" OF 12 ENDOF 76 | exc_undef OF 13 ENDOF 77 | ENDCASE 78 | ; 79 | 80 | T{ 1 2 ' t6 c6 -> 1 2 11 }T \ Test that ABORT is caught 81 | T{ 3 0 ' t10 c6 -> 3 77 }T \ ABORT" does nothing 82 | T{ 4 5 ' t10 c6 -> 4 77 12 }T \ ABORT" caught, no message 83 | 84 | \ ------------------------------------------------------------------------------ 85 | TESTING a system generated exception 86 | 87 | : t7 S" 333 $$qweqweqwert$$ 334" EVALUATE 335 ; 88 | : t8 S" 222 t7 223" EVALUATE 224 ; 89 | : t9 S" 111 112 t8 113" EVALUATE 114 ; 90 | 91 | T{ 6 7 ' t9 c6 3 -> 6 7 13 3 }T \ Test unlinking of sources 92 | 93 | \ ------------------------------------------------------------------------------ 94 | 95 | CR .( End of Exception word tests) CR 96 | 97 | -------------------------------------------------------------------------------- /software/anstests0.10/filetest.fth: -------------------------------------------------------------------------------- 1 | \ To test the ANS File Access word set and extension words 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.5 1 April 2012 Tests placed in the public domain. 15 | \ 0.4 22 March 2009 { and } replaced with T{ and }T 16 | \ 0.3 20 April 2007 ANS Forth words changed to upper case. 17 | \ Removed directory test from the filenames. 18 | \ 0.2 30 Oct 2006 updated following GForth tests to remove 19 | \ system dependency on file size, to allow for file 20 | \ buffering and to allow for PAD moving around. 21 | \ 0.1 Oct 2006 First version released. 22 | 23 | \ ------------------------------------------------------------------------------ 24 | \ The tests are based on John Hayes test program for the core word set 25 | \ and requires those files to have been loaded 26 | 27 | \ Words tested in this file are: 28 | \ ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE 29 | \ OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE 30 | \ S" SOURCE-ID W/O WRITE-FILE WRITE-LINE 31 | \ FILE-STATUS FLUSH-FILE RENAME-FILE 32 | 33 | \ Words not tested: 34 | \ REFILL INCLUDED INCLUDE-FILE (as these will likely have been 35 | \ tested in the execution of the test files) 36 | \ ------------------------------------------------------------------------------ 37 | \ Assumptions, dependencies and notes: 38 | \ - tester.fr or ttester.fs has been loaded prior to this file 39 | \ - These tests create files in the current directory, if all goes 40 | \ well these will be deleted. If something fails they may not be 41 | \ deleted. If this is a problem ensure you set a suitable 42 | \ directory before running this test. There is no ANS standard 43 | \ way of doing this. Also be aware of the file names used below 44 | \ which are: fatest1.txt, fatest2.txt and fatest3.txt 45 | \ - TRUE and FALSE are present from the Core extension word set 46 | \ ------------------------------------------------------------------------------ 47 | 48 | TESTING File Access word set 49 | 50 | DECIMAL 51 | 52 | \ ------------------------------------------------------------------------------ 53 | TESTING CREATE-FILE CLOSE-FILE 54 | 55 | : fn1 S" fatest1.txt" ; 56 | VARIABLE fid1 57 | 58 | T{ fn1 R/W CREATE-FILE SWAP fid1 ! -> 0 }T 59 | T{ fid1 @ CLOSE-FILE -> 0 }T 60 | 61 | \ ------------------------------------------------------------------------------ 62 | TESTING OPEN-FILE W/O WRITE-LINE 63 | 64 | : line1 S" Line 1" ; 65 | 66 | T{ fn1 W/O OPEN-FILE SWAP fid1 ! -> 0 }T 67 | T{ line1 fid1 @ WRITE-LINE -> 0 }T 68 | T{ fid1 @ CLOSE-FILE -> 0 }T 69 | 70 | \ ------------------------------------------------------------------------------ 71 | TESTING R/O FILE-POSITION (simple) READ-LINE 72 | 73 | 200 CONSTANT bsize 74 | CREATE buf bsize ALLOT 75 | VARIABLE #chars 76 | 77 | T{ fn1 R/O OPEN-FILE SWAP fid1 ! -> 0 }T 78 | T{ fid1 @ FILE-POSITION -> 0. 0 }T 79 | T{ buf 100 fid1 @ READ-LINE ROT DUP #chars ! -> TRUE 0 line1 SWAP DROP }T 80 | T{ buf #chars @ line1 COMPARE -> 0 }T 81 | T{ fid1 @ CLOSE-FILE -> 0 }T 82 | 83 | \ ------------------------------------------------------------------------------ 84 | TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S" 85 | 86 | : line2 S" Line 2 blah blah blah" ; 87 | : rl1 buf 100 fid1 @ READ-LINE ; 88 | 2VARIABLE fp 89 | 90 | T{ fn1 R/W OPEN-FILE SWAP fid1 ! -> 0 }T 91 | T{ fid1 @ FILE-SIZE DROP fid1 @ REPOSITION-FILE -> 0 }T 92 | T{ fid1 @ FILE-SIZE -> fid1 @ FILE-POSITION }T 93 | T{ line2 fid1 @ WRITE-FILE -> 0 }T 94 | T{ 10. fid1 @ REPOSITION-FILE -> 0 }T 95 | T{ fid1 @ FILE-POSITION -> 10. 0 }T 96 | T{ 0. fid1 @ REPOSITION-FILE -> 0 }T 97 | T{ rl1 -> line1 SWAP DROP TRUE 0 }T 98 | T{ rl1 ROT DUP #chars ! -> TRUE 0 line2 SWAP DROP }T 99 | T{ buf #chars @ line2 COMPARE -> 0 }T 100 | T{ rl1 -> 0 FALSE 0 }T 101 | T{ fid1 @ FILE-POSITION ROT ROT fp 2! -> 0 }T 102 | T{ fp 2@ fid1 @ FILE-SIZE DROP D= -> TRUE }T 103 | T{ S" " fid1 @ WRITE-LINE -> 0 }T 104 | T{ S" " fid1 @ WRITE-LINE -> 0 }T 105 | T{ fp 2@ fid1 @ REPOSITION-FILE -> 0 }T 106 | T{ rl1 -> 0 TRUE 0 }T 107 | T{ rl1 -> 0 TRUE 0 }T 108 | T{ rl1 -> 0 FALSE 0 }T 109 | T{ fid1 @ CLOSE-FILE -> 0 }T 110 | 111 | \ ------------------------------------------------------------------------------ 112 | TESTING BIN READ-FILE FILE-SIZE 113 | 114 | : cbuf buf bsize 0 FILL ; 115 | : fn2 S" fatest2.txt" ; 116 | VARIABLE fid2 117 | : setpad PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ; 118 | 119 | setpad \ If anything else is defined setpad must be called again 120 | \ as pad may move 121 | 122 | T{ fn2 R/W BIN CREATE-FILE SWAP fid2 ! -> 0 }T 123 | T{ PAD 50 fid2 @ WRITE-FILE fid2 @ FLUSH-FILE -> 0 0 }T 124 | T{ fid2 @ FILE-SIZE -> 50. 0 }T 125 | T{ 0. fid2 @ REPOSITION-FILE -> 0 }T 126 | T{ cbuf buf 29 fid2 @ READ-FILE -> 29 0 }T 127 | T{ PAD 29 buf 29 COMPARE -> 0 }T 128 | T{ PAD 30 buf 30 COMPARE -> 1 }T 129 | T{ cbuf buf 29 fid2 @ READ-FILE -> 21 0 }T 130 | T{ PAD 29 + 21 buf 21 COMPARE -> 0 }T 131 | T{ fid2 @ FILE-SIZE DROP fid2 @ FILE-POSITION DROP D= -> TRUE }T 132 | T{ buf 10 fid2 @ READ-FILE -> 0 0 }T 133 | T{ fid2 @ CLOSE-FILE -> 0 }T 134 | 135 | \ ------------------------------------------------------------------------------ 136 | TESTING RESIZE-FILE 137 | 138 | T{ fn2 R/W BIN OPEN-FILE SWAP fid2 ! -> 0 }T 139 | T{ 37. fid2 @ RESIZE-FILE -> 0 }T 140 | T{ fid2 @ FILE-SIZE -> 37. 0 }T 141 | T{ 0. fid2 @ REPOSITION-FILE -> 0 }T 142 | T{ cbuf buf 100 fid2 @ READ-FILE -> 37 0 }T 143 | T{ PAD 37 buf 37 COMPARE -> 0 }T 144 | T{ PAD 38 buf 38 COMPARE -> 1 }T 145 | T{ 500. fid2 @ RESIZE-FILE -> 0 }T 146 | T{ fid2 @ FILE-SIZE -> 500. 0 }T 147 | T{ 0. fid2 @ REPOSITION-FILE -> 0 }T 148 | T{ cbuf buf 100 fid2 @ READ-FILE -> 100 0 }T 149 | T{ PAD 37 buf 37 COMPARE -> 0 }T 150 | T{ fid2 @ CLOSE-FILE -> 0 }T 151 | 152 | \ ------------------------------------------------------------------------------ 153 | TESTING DELETE-FILE 154 | 155 | T{ fn2 DELETE-FILE -> 0 }T 156 | T{ fn2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T 157 | T{ fn2 DELETE-FILE 0= -> FALSE }T 158 | 159 | \ ------------------------------------------------------------------------------ 160 | TESTING multi-line ( comments 161 | 162 | T{ ( 1 2 3 163 | 4 5 6 164 | 7 8 9 ) 11 22 33 -> 11 22 33 }T 165 | 166 | \ ------------------------------------------------------------------------------ 167 | TESTING SOURCE-ID (can only test it does not return 0 or -1) 168 | 169 | T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T 170 | 171 | \ ------------------------------------------------------------------------------ 172 | TESTING RENAME-FILE FILE-STATUS FLUSH-FILE 173 | 174 | : fn3 S" fatest3.txt" ; 175 | : >end fid1 @ FILE-SIZE DROP fid1 @ REPOSITION-FILE ; 176 | 177 | 178 | T{ fn3 DELETE-FILE DROP -> }T 179 | T{ fn1 fn3 RENAME-FILE 0= -> TRUE }T 180 | T{ fn1 FILE-STATUS SWAP DROP 0= -> FALSE }T 181 | T{ fn3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined 182 | T{ fn3 R/W OPEN-FILE SWAP fid1 ! -> 0 }T 183 | T{ >end -> 0 }T 184 | T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T 185 | T{ fid1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail 186 | T{ fid1 @ CLOSE-FILE -> 0 }T 187 | 188 | \ Tidy the test folder 189 | T{ fn3 DELETE-FILE DROP -> }T 190 | 191 | \ ------------------------------------------------------------------------------ 192 | 193 | CR .( End of File-Access word tests) CR 194 | -------------------------------------------------------------------------------- /software/anstests0.10/memorytest.fth: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth Memory-Allocation word set 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.7 1 April 2012 Tests placed in the public domain. 15 | \ 0.6 30 January 2011 CHECKMEM modified to work with ttester.fs 16 | \ 0.5 30 November 2009 replaced with FALSE 17 | \ 0.4 9 March 2009 Aligned test improved and data space pointer tested 18 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 19 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 20 | \ 0.1 October 2006 First version released 21 | 22 | \ ------------------------------------------------------------------------------ 23 | \ The tests are based on John Hayes test program for the core word set 24 | \ and requires those files to have been loaded 25 | 26 | \ Words tested in this file are: 27 | \ ALLOCATE FREE RESIZE 28 | \ 29 | \ ------------------------------------------------------------------------------ 30 | \ Assumptions and dependencies: 31 | \ - that 'addr -1 ALLOCATE' and 'addr -1 RESIZE' will return an error 32 | \ - tester.fr or ttester.fs has been loaded prior to this file 33 | \ - testing FREE failing is not done as it is likely to crash the 34 | \ system 35 | \ ------------------------------------------------------------------------------ 36 | 37 | TESTING Memory-Allocation word set 38 | 39 | DECIMAL 40 | 41 | \ ------------------------------------------------------------------------------ 42 | TESTING ALLOCATE FREE RESIZE 43 | 44 | VARIABLE addr1 45 | VARIABLE datsp 46 | 47 | HERE datsp ! 48 | T{ 100 ALLOCATE SWAP addr1 ! -> 0 }T 49 | T{ addr1 @ ALIGNED -> addr1 @ }T \ Test address is aligned 50 | T{ HERE -> datsp @ }T \ Check data space pointer is unchanged 51 | T{ addr1 @ FREE -> 0 }T 52 | 53 | T{ 99 ALLOCATE SWAP addr1 ! -> 0 }T 54 | T{ addr1 @ ALIGNED -> addr1 @ }T 55 | T{ addr1 @ FREE -> 0 }T 56 | 57 | T{ 50 ALLOCATE SWAP addr1 ! -> 0 }T 58 | 59 | : writemem 0 DO I 1+ OVER C! 1+ LOOP DROP ; ( ad n -- ) 60 | 61 | \ checkmem is defined this way to maintain compatibility with both 62 | \ tester.fr and ttester.fs which differ in their definitions of T{ 63 | 64 | : checkmem ( ad n --- ) 65 | 0 66 | DO 67 | >R 68 | T{ R@ C@ -> R> I 1+ SWAP >R }T 69 | R> 1+ 70 | LOOP 71 | DROP 72 | ; 73 | 74 | addr1 @ 50 writemem addr1 @ 50 checkmem 75 | 76 | T{ addr1 @ 28 RESIZE SWAP addr1 ! -> 0 }T 77 | addr1 @ 28 checkmem 78 | 79 | T{ addr1 @ 200 RESIZE SWAP addr1 ! -> 0 }T 80 | addr1 @ 28 checkmem 81 | 82 | \ ------------------------------------------------------------------------------ 83 | TESTING failure of RESIZE and ALLOCATE (unlikely to be enough memory) 84 | 85 | T{ addr1 @ -1 RESIZE 0= -> addr1 @ FALSE }T 86 | 87 | T{ addr1 @ FREE -> 0 }T 88 | 89 | T{ -1 ALLOCATE SWAP DROP 0= -> FALSE }T \ Memory allocate failed 90 | 91 | \ ------------------------------------------------------------------------------ 92 | 93 | CR .( End of Memory-Allocation word tests) CR 94 | -------------------------------------------------------------------------------- /software/anstests0.10/runtests.fth: -------------------------------------------------------------------------------- 1 | \ ANS Forth tests - run all tests 2 | 3 | \ Adjust the file paths as appropriate to your system 4 | \ Select the appropriate test harness, either the simple tester.fr 5 | \ or the more complex tester.fs 6 | 7 | CR .( Running ANS Forth test programs, version 0.10) CR 8 | 9 | S" tester.fr" INCLUDED 10 | \ S" ttester.fs" INCLUDED 11 | S" core.fr" INCLUDED 12 | S" coreplustest.fth" INCLUDED 13 | S" coreexttest.fth" INCLUDED 14 | S" doubletest.fth" INCLUDED 15 | S" exceptiontest.fth" INCLUDED 16 | S" filetest.fth" INCLUDED 17 | S" memorytest.fth" INCLUDED 18 | S" toolstest.fth" INCLUDED 19 | S" searchordertest.fth" INCLUDED 20 | S" stringtest.fth" INCLUDED 21 | 22 | CR CR .( Forth tests completed ) CR CR 23 | 24 | 25 | -------------------------------------------------------------------------------- /software/anstests0.10/searchordertest.fth: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth search-order word set and search order extensions 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.10 3 August 2014 Name changes to remove redefinition messages 15 | \ "list" changed to "wordlist" in message for ORDER tests 16 | \ 0.5 1 April 2012 Tests placed in the public domain. 17 | \ 0.4 6 March 2009 { and } replaced with T{ and }T 18 | \ 0.3 20 April 2007 ANS Forth words changed to upper case 19 | \ 0.2 30 Oct 2006 updated following GForth tests to get 20 | \ initial search order into a known state 21 | \ 0.1 Oct 2006 First version released 22 | 23 | \ ------------------------------------------------------------------------------ 24 | \ The tests are based on John Hayes test program for the core word set 25 | \ and requires those files to have been loaded 26 | 27 | \ Words tested in this file are: 28 | \ FORTH-WORDLIST GET-ORDER SET-ORDER ALSO ONLY FORTH GET-CURRENT 29 | \ SET-CURRENT DEFINITIONS PREVIOUS SEARCH-WORDLIST WORDLIST FIND 30 | \ Words not fully tested: 31 | \ ORDER only tests that it executes, display is implementation 32 | \ dependent and should be visually inspected 33 | 34 | \ ------------------------------------------------------------------------------ 35 | \ Assumptions and dependencies: 36 | \ - tester.fr or ttester.fs has been loaded prior to this file 37 | \ - that ONLY FORTH DEFINITIONS will work at the start of the file 38 | \ to ensure the search order is in a known state 39 | \ ------------------------------------------------------------------------------ 40 | 41 | ONLY FORTH DEFINITIONS 42 | 43 | TESTING Search-order word set 44 | 45 | DECIMAL 46 | 47 | VARIABLE wid1 VARIABLE wid2 48 | 49 | : save-orderlist ( widn ... wid1 n -> ) DUP , 0 ?DO , LOOP ; 50 | 51 | \ ------------------------------------------------------------------------------ 52 | TESTING FORTH-WORDLIST GET-ORDER SET-ORDER 53 | 54 | T{ FORTH-WORDLIST wid1 ! -> }T 55 | 56 | CREATE order-list 57 | 58 | T{ GET-ORDER save-orderlist -> }T 59 | 60 | : get-orderlist ( -- widn ... wid1 n ) 61 | order-list DUP @ CELLS ( -- ad n ) 62 | OVER + ( -- ad ad' ) 63 | ?DO I @ -1 CELLS +LOOP ( -- ) 64 | ; 65 | 66 | T{ GET-ORDER OVER -> GET-ORDER wid1 @ }T \ Forth wordlist at top 67 | T{ GET-ORDER SET-ORDER -> }T \ Effectively noop 68 | T{ GET-ORDER -> get-orderlist }T \ Check nothing changed 69 | T{ get-orderlist DROP get-orderlist 2* SET-ORDER -> }T 70 | T{ GET-ORDER -> get-orderlist DROP get-orderlist 2* }T 71 | T{ get-orderlist SET-ORDER GET-ORDER -> get-orderlist }T 72 | 73 | \ ------------------------------------------------------------------------------ 74 | TESTING ALSO ONLY FORTH 75 | 76 | T{ ALSO GET-ORDER -> get-orderlist OVER SWAP 1+ }T 77 | T{ ONLY FORTH GET-ORDER -> get-orderlist }T \ See assumptions above 78 | 79 | \ ------------------------------------------------------------------------------ 80 | TESTING GET-CURRENT SET-CURRENT WORDLIST (simple) 81 | 82 | T{ GET-CURRENT -> wid1 @ }T \ See assumptions above 83 | T{ WORDLIST wid2 ! -> }T 84 | T{ wid2 @ SET-CURRENT -> }T 85 | T{ GET-CURRENT -> wid2 @ }T 86 | T{ wid1 @ SET-CURRENT -> }T 87 | 88 | \ ------------------------------------------------------------------------------ 89 | TESTING minimum search order list contains FORTH-WORDLIST and SET-ORDER 90 | 91 | : so1 SET-ORDER ; \ In case it is unavailable in the forth wordlist 92 | 93 | T{ ONLY FORTH-WORDLIST 1 SET-ORDER get-orderlist so1 -> }T 94 | T{ GET-ORDER -> get-orderlist }T 95 | 96 | \ ------------------------------------------------------------------------------ 97 | TESTING GET-ORDER SET-ORDER with 0 and -1 number of wids argument 98 | 99 | : so2a GET-ORDER get-orderlist SET-ORDER ; \ To recover search order 100 | : so2 0 SET-ORDER so2a ; 101 | 102 | T{ so2 -> 0 }T \ 0 set-order leaves an empty search order 103 | 104 | : so3 -1 SET-ORDER so2a ; 105 | : so4 ONLY so2a ; 106 | 107 | T{ so3 -> so4 }T \ -1 SET-ORDER = ONLY 108 | 109 | \ ------------------------------------------------------------------------------ 110 | TESTING DEFINITIONS PREVIOUS 111 | 112 | T{ ONLY FORTH DEFINITIONS -> }T 113 | T{ GET-CURRENT -> FORTH-WORDLIST }T 114 | T{ GET-ORDER wid2 @ SWAP 1+ SET-ORDER DEFINITIONS GET-CURRENT -> wid2 @ }T 115 | T{ GET-ORDER -> get-orderlist wid2 @ SWAP 1+ }T 116 | T{ PREVIOUS GET-ORDER -> get-orderlist }T 117 | T{ DEFINITIONS GET-CURRENT -> FORTH-WORDLIST }T 118 | 119 | \ ------------------------------------------------------------------------------ 120 | TESTING SEARCH-WORDLIST WORDLIST FIND 121 | 122 | ONLY FORTH DEFINITIONS 123 | VARIABLE xt ' DUP xt ! 124 | VARIABLE xti ' .( xti ! \ Immediate word 125 | 126 | T{ S" DUP" wid1 @ SEARCH-WORDLIST -> xt @ -1 }T 127 | T{ S" .(" wid1 @ SEARCH-WORDLIST -> xti @ 1 }T 128 | T{ S" DUP" wid2 @ SEARCH-WORDLIST -> 0 }T 129 | 130 | : c"dup" C" DUP" ; 131 | : c".(" C" .(" ; 132 | : c"x" C" unknown word" ; 133 | 134 | T{ c"dup" FIND -> xt @ -1 }T 135 | T{ c".(" FIND -> xti @ 1 }T 136 | T{ c"x" FIND -> c"x" 0 }T 137 | 138 | \ ------------------------------------------------------------------------------ 139 | TESTING new definitions are put into the correct wordlist 140 | 141 | : alsowid2 ALSO GET-ORDER wid2 @ ROT DROP SWAP SET-ORDER ; 142 | alsowid2 143 | : w2 1234 ; 144 | DEFINITIONS 145 | : w2 -9876 ; IMMEDIATE 146 | 147 | ONLY FORTH 148 | T{ w2 -> 1234 }T 149 | DEFINITIONS 150 | T{ w2 -> 1234 }T 151 | alsowid2 152 | T{ w2 -> -9876 }T 153 | DEFINITIONS 154 | T{ w2 -> -9876 }T 155 | 156 | ONLY FORTH DEFINITIONS 157 | 158 | : so5 DUP IF SWAP EXECUTE THEN ; 159 | 160 | T{ S" w2" wid1 @ SEARCH-WORDLIST so5 -> -1 1234 }T 161 | T{ S" w2" wid2 @ SEARCH-WORDLIST so5 -> 1 -9876 }T 162 | 163 | : c"w2" C" w2" ; 164 | T{ alsowid2 c"w2" FIND so5 -> 1 -9876 }T 165 | T{ PREVIOUS c"w2" FIND so5 -> -1 1234 }T 166 | 167 | \ ------------------------------------------------------------------------------ 168 | TESTING ORDER \ Should display search order and compilation wordlist 169 | 170 | CR .( ONLY FORTH DEFINITIONS search order and compilation wordlist) CR 171 | T{ ONLY FORTH DEFINITIONS ORDER -> }T 172 | 173 | CR .( Plus another unnamed wordlist at the head of the search order) CR 174 | T{ alsowid2 DEFINITIONS ORDER -> }T 175 | 176 | \ ------------------------------------------------------------------------------ 177 | 178 | CR .( End of Search Order word tests) CR 179 | 180 | ONLY FORTH DEFINITIONS \ Leave search order in the standard state 181 | -------------------------------------------------------------------------------- /software/anstests0.10/stringtest.fth: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth String word set 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.6 1 April 2012 Tests placed in the public domain. 15 | \ 0.5 29 April 2010 Added tests for SEARCH and COMPARE with 16 | \ all strings zero length (suggested by Krishna Myneni). 17 | \ SLITERAL test amended in line with comp.lang.forth 18 | \ discussion 19 | \ 0.4 30 November 2009 and replaced with TRUE 20 | \ and FALSE 21 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 22 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 23 | \ 0.1 Oct 2006 First version released 24 | 25 | \ ------------------------------------------------------------------------------ 26 | \ The tests are based on John Hayes test program for the core word set 27 | \ and requires those files to have been loaded 28 | 29 | \ Words tested in this file are: 30 | \ -TRAILING /STRING BLANK CMOVE CMOVE> COMPARE SEARCH SLITERAL 31 | \ 32 | \ ------------------------------------------------------------------------------ 33 | \ Assumptions and dependencies: 34 | \ - tester.fr or ttester.fs has been loaded prior to this file 35 | \ - COMPARE is case sensitive 36 | \ ------------------------------------------------------------------------------ 37 | 38 | TESTING String word set 39 | 40 | DECIMAL 41 | 42 | T{ : s1 S" abcdefghijklmnopqrstuvwxyz" ; -> }T 43 | T{ : s2 S" abc" ; -> }T 44 | T{ : s3 S" jklmn" ; -> }T 45 | T{ : s4 S" z" ; -> }T 46 | T{ : s5 S" mnoq" ; -> }T 47 | T{ : s6 S" 12345" ; -> }T 48 | T{ : s7 S" " ; -> }T 49 | T{ : s8 S" abc " ; -> }T 50 | T{ : s9 S" " ; -> }T 51 | T{ : s10 S" a " ; -> }T 52 | 53 | \ ------------------------------------------------------------------------------ 54 | TESTING -TRAILING 55 | 56 | T{ s1 -TRAILING -> s1 }T 57 | T{ s8 -TRAILING -> s8 2 - }T 58 | T{ s7 -TRAILING -> s7 }T 59 | T{ s9 -TRAILING -> s9 DROP 0 }T 60 | T{ s10 -TRAILING -> s10 1- }T 61 | 62 | \ ------------------------------------------------------------------------------ 63 | TESTING /STRING 64 | 65 | T{ s1 5 /STRING -> s1 SWAP 5 + SWAP 5 - }T 66 | T{ s1 10 /STRING -4 /STRING -> s1 6 /STRING }T 67 | T{ s1 0 /STRING -> s1 }T 68 | 69 | \ ------------------------------------------------------------------------------ 70 | TESTING SEARCH 71 | 72 | T{ s1 s2 SEARCH -> s1 TRUE }T 73 | T{ s1 s3 SEARCH -> s1 9 /STRING TRUE }T 74 | T{ s1 s4 SEARCH -> s1 25 /STRING TRUE }T 75 | T{ s1 s5 SEARCH -> s1 FALSE }T 76 | T{ s1 s6 SEARCH -> s1 FALSE }T 77 | T{ s1 s7 SEARCH -> s1 TRUE }T 78 | T{ s7 PAD 0 SEARCH -> s7 TRUE }T 79 | 80 | \ ------------------------------------------------------------------------------ 81 | TESTING COMPARE 82 | 83 | T{ s1 s1 COMPARE -> 0 }T 84 | T{ s1 PAD SWAP CMOVE -> }T 85 | T{ s1 PAD OVER COMPARE -> 0 }T 86 | T{ s1 PAD 6 COMPARE -> 1 }T 87 | T{ PAD 10 s1 COMPARE -> -1 }T 88 | T{ s1 PAD 0 COMPARE -> 1 }T 89 | T{ PAD 0 s1 COMPARE -> -1 }T 90 | T{ s1 s6 COMPARE -> 1 }T 91 | T{ s6 s1 COMPARE -> -1 }T 92 | T{ s7 PAD 0 COMPARE -> 0 }T 93 | 94 | : "abdde" S" abdde" ; 95 | : "abbde" S" abbde" ; 96 | : "abcdf" S" abcdf" ; 97 | : "abcdee" S" abcdee" ; 98 | 99 | T{ s1 "abdde" COMPARE -> -1 }T 100 | T{ s1 "abbde" COMPARE -> 1 }T 101 | T{ s1 "abcdf" COMPARE -> -1 }T 102 | T{ s1 "abcdee" COMPARE -> 1 }T 103 | 104 | : s11 S" 0abc" ; 105 | : s12 S" 0aBc" ; 106 | 107 | T{ s11 s12 COMPARE -> 1 }T 108 | T{ s12 s11 COMPARE -> -1 }T 109 | 110 | \ ------------------------------------------------------------------------------ 111 | TESTING CMOVE and CMOVE> 112 | 113 | PAD 30 CHARS 0 FILL 114 | T{ s1 PAD SWAP CMOVE -> }T 115 | T{ s1 PAD s1 SWAP DROP COMPARE -> 0 }T 116 | T{ s6 PAD 10 CHARS + SWAP CMOVE -> }T 117 | T{ S" abcdefghij12345pqrstuvwxyz" PAD s1 SWAP DROP COMPARE -> 0 }T 118 | T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE -> }T 119 | T{ S" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T 120 | T{ PAD PAD 3 CHARS + 7 CMOVE -> }T 121 | T{ S" apqapqapqa12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T 122 | T{ PAD PAD CHAR+ 10 CMOVE -> }T 123 | T{ S" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T 124 | T{ s7 PAD 14 CHARS + SWAP CMOVE -> }T 125 | T{ S" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T 126 | 127 | PAD 30 CHARS 0 FILL 128 | 129 | T{ s1 PAD SWAP CMOVE> -> }T 130 | T{ s1 PAD s1 SWAP DROP COMPARE -> 0 }T 131 | T{ s6 PAD 10 CHARS + SWAP CMOVE> -> }T 132 | T{ S" abcdefghij12345pqrstuvwxyz" PAD s1 SWAP DROP COMPARE -> 0 }T 133 | T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE> -> }T 134 | T{ S" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T 135 | T{ PAD 13 CHARS + PAD 10 CHARS + 7 CMOVE> -> }T 136 | T{ S" apqrstuhijtrstrstrstuvwxyz" PAD 26 COMPARE -> 0 }T 137 | T{ PAD 12 CHARS + PAD 11 CHARS + 10 CMOVE> -> }T 138 | T{ S" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T 139 | T{ s7 PAD 14 CHARS + SWAP CMOVE> -> }T 140 | T{ S" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T 141 | 142 | \ ------------------------------------------------------------------------------ 143 | TESTING BLANK 144 | 145 | : s13 S" aaaaa a" ; \ Don't move this down or might corrupt PAD 146 | 147 | T{ PAD 25 CHAR a FILL -> }T 148 | T{ PAD 5 CHARS + 6 BLANK -> }T 149 | T{ PAD 12 s13 COMPARE -> 0 }T 150 | 151 | \ ------------------------------------------------------------------------------ 152 | TESTING SLITERAL 153 | 154 | T{ HERE DUP s1 DUP ALLOT ROT SWAP CMOVE s1 SWAP DROP 2CONSTANT s1a -> }T 155 | T{ : s14 [ s1a ] SLITERAL ; -> }T 156 | T{ s1a s14 COMPARE -> 0 }T 157 | T{ s1a DROP s14 DROP = -> FALSE }T 158 | 159 | \ ------------------------------------------------------------------------------ 160 | 161 | CR .( End of String word tests) CR 162 | -------------------------------------------------------------------------------- /software/anstests0.10/tester.fr: -------------------------------------------------------------------------------- 1 | \ From: John Hayes S1I 2 | \ Subject: tester.fr 3 | \ Date: Mon, 27 Nov 95 13:10:09 PST 4 | 5 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7 | \ VERSION 1.1 8 | 9 | \ 22/1/09 The words { and } have been changed to T{ and }T respectively to 10 | \ agree with the Forth 200X file ttester.fs. This avoids clashes with 11 | \ locals using { ... } and the FSL use of } 12 | 13 | HEX 14 | 15 | \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 16 | \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 17 | VARIABLE VERBOSE 18 | FALSE VERBOSE ! 19 | \ TRUE VERBOSE ! 20 | 21 | : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 22 | DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; 23 | 24 | : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 25 | \ THE LINE THAT HAD THE ERROR. 26 | TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR 27 | EMPTY-STACK \ THROW AWAY EVERY THING ELSE 28 | \ QUIT \ *** Uncomment this line to QUIT on an error 29 | ; 30 | 31 | VARIABLE ACTUAL-DEPTH \ STACK RECORD 32 | CREATE ACTUAL-RESULTS 20 CELLS ALLOT 33 | 34 | : T{ \ ( -- ) SYNTACTIC SUGAR. 35 | ; 36 | 37 | : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 38 | DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 39 | ?DUP IF \ IF THERE IS SOMETHING ON STACK 40 | 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 41 | THEN ; 42 | 43 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 44 | \ (ACTUAL) CONTENTS. 45 | DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 46 | DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 47 | 0 DO \ FOR EACH STACK ITEM 48 | ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 49 | <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 50 | LOOP 51 | THEN 52 | ELSE \ DEPTH MISMATCH 53 | S" WRONG NUMBER OF RESULTS: " ERROR 54 | THEN ; 55 | 56 | : TESTING \ ( -- ) TALKING COMMENT. 57 | SOURCE VERBOSE @ 58 | IF DUP >R TYPE CR R> >IN ! 59 | ELSE >IN ! DROP [CHAR] * EMIT 60 | THEN ; 61 | 62 | -------------------------------------------------------------------------------- /software/anstests0.10/toolstest.fth: -------------------------------------------------------------------------------- 1 | \ To test some of the ANS Forth Programming Tools and extension wordset 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.6 1 April 2012 Tests placed in the public domain. 15 | \ Further tests on [IF] [ELSE] [THEN] 16 | \ 0.5 30 November 2009 and replaced with TRUE and FALSE 17 | \ 0.4 6 March 2009 ENDIF changed to THEN. {...} changed to T{...}T 18 | \ 0.3 20 April 2007 ANS Forth words changed to upper case 19 | \ 0.2 30 Oct 2006 updated following GForth test to avoid 20 | \ changing stack depth during a colon definition 21 | \ 0.1 Oct 2006 First version released 22 | 23 | \ ------------------------------------------------------------------------------ 24 | \ The tests are based on John Hayes test program 25 | 26 | \ Words tested in this file are: 27 | \ AHEAD [IF] [ELSE] [THEN] CS-PICK CS-ROLL 28 | \ 29 | 30 | \ Words not tested: 31 | \ .S ? DUMP SEE WORDS 32 | \ ;CODE ASSEMBLER BYE CODE EDITOR FORGET STATE 33 | \ ------------------------------------------------------------------------------ 34 | \ Assumptions and dependencies: 35 | \ - tester.fr or ttester.fs has been loaded prior to this file 36 | \ ------------------------------------------------------------------------------ 37 | 38 | DECIMAL 39 | 40 | \ ------------------------------------------------------------------------------ 41 | TESTING AHEAD 42 | 43 | T{ : pt1 AHEAD 1111 2222 THEN 3333 ; -> }T 44 | T{ pt1 -> 3333 }T 45 | 46 | \ ------------------------------------------------------------------------------ 47 | TESTING [IF] [ELSE] [THEN] 48 | 49 | T{ TRUE [IF] 111 [ELSE] 222 [THEN] -> 111 }T 50 | T{ FALSE [IF] 111 [ELSE] 222 [THEN] -> 222 }T 51 | 52 | T{ TRUE [IF] 1 \ Code spread over more than 1 line 53 | 2 54 | [ELSE] 55 | 3 56 | 4 57 | [THEN] -> 1 2 }T 58 | T{ FALSE [IF] 59 | 1 2 60 | [ELSE] 61 | 3 4 62 | [THEN] -> 3 4 }T 63 | 64 | T{ TRUE [IF] 1 TRUE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 1 2 }T 65 | T{ FALSE [IF] 1 TRUE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 4 }T 66 | T{ TRUE [IF] 1 FALSE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 1 3 }T 67 | T{ FALSE [IF] 1 FALSE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 4 }T 68 | 69 | \ ------------------------------------------------------------------------------ 70 | TESTING immediacy of [IF] [ELSE] [THEN] 71 | 72 | T{ : pt2 [ 0 ] [IF] 1111 [ELSE] 2222 [THEN] ; pt2 -> 2222 }T 73 | T{ : pt3 [ -1 ] [IF] 3333 [ELSE] 4444 [THEN] ; pt3 -> 3333 }T 74 | : pt9 bl WORD FIND ; 75 | T{ pt9 [IF] NIP -> 1 }T 76 | T{ pt9 [ELSE] NIP -> 1 }T 77 | T{ pt9 [THEN] NIP -> 1 }T 78 | 79 | \ ----------------------------------------------------------------------------- 80 | TESTING [IF] and [ELSE] carry out a text scan by parsing and discarding words 81 | \ so that an [ELSE] or [THEN] in a comment or string is recognised 82 | 83 | : pt10 REFILL DROP REFILL DROP ; 84 | 85 | T{ 0 [IF] \ Words ignored up to [ELSE] 2 86 | [THEN] -> 2 }T 87 | T{ -1 [IF] 2 [ELSE] 3 s" [THEN] 4 pt10 ignored to end of line" 88 | [THEN] \ Precaution in case [THEN] in string isn't recognised 89 | -> 2 4 }T 90 | 91 | \ ------------------------------------------------------------------------------ 92 | TESTING CS-PICK and CS-ROLL 93 | 94 | \ Test pt5 based on example in ANS document p 176. 95 | 96 | : ?repeat 97 | 0 CS-PICK POSTPONE UNTIL 98 | ; IMMEDIATE 99 | 100 | VARIABLE pt4 101 | 102 | T{ : pt5 ( n1 -- ) 103 | pt4 ! 104 | BEGIN 105 | -1 pt4 +! 106 | pt4 @ 4 > 0= ?repeat \ Back to BEGIN if false 107 | 111 108 | pt4 @ 3 > 0= ?repeat 109 | 222 110 | pt4 @ 2 > 0= ?repeat 111 | 333 112 | pt4 @ 1 = 113 | UNTIL 114 | ; -> }T 115 | 116 | T{ 6 pt5 -> 111 111 222 111 222 333 111 222 333 }T 117 | 118 | 119 | T{ : ?DONE POSTPONE IF 1 CS-ROLL ; IMMEDIATE -> }T \ Same as WHILE 120 | T{ : pt6 121 | >R 122 | BEGIN 123 | R@ 124 | ?DONE 125 | R@ 126 | R> 1- >R 127 | REPEAT 128 | R> DROP 129 | ; -> }T 130 | 131 | T{ 5 pt6 -> 5 4 3 2 1 }T 132 | 133 | : mix_up 2 CS-ROLL ; IMMEDIATE \ cs-rot 134 | 135 | : pt7 ( f3 f2 f1 -- ? ) 136 | IF 1111 ROT ROT ( -- 1111 f3 f2 ) ( cs: -- orig1 ) 137 | IF 2222 SWAP ( -- 1111 2222 f3 ) ( cs: -- orig1 orig2 ) 138 | IF ( cs: -- orig1 orig2 orig3 ) 139 | 3333 mix_up ( -- 1111 2222 3333 ) ( cs: -- orig2 orig3 orig1 ) 140 | THEN ( cs: -- orig2 orig3 ) 141 | 4444 \ Hence failure of first IF comes here and falls through 142 | THEN ( cs: -- orig2 ) 143 | 5555 \ Failure of 3rd IF comes here 144 | THEN ( cs: -- ) 145 | 6666 \ Failure of 2nd IF comes here 146 | ; 147 | 148 | T{ -1 -1 -1 pt7 -> 1111 2222 3333 4444 5555 6666 }T 149 | T{ 0 -1 -1 pt7 -> 1111 2222 5555 6666 }T 150 | T{ 0 0 -1 pt7 -> 1111 0 6666 }T 151 | T{ 0 0 0 pt7 -> 0 0 4444 5555 6666 }T 152 | 153 | : [1cs-roll] 1 CS-ROLL ; IMMEDIATE 154 | 155 | T{ : pt8 156 | >R 157 | AHEAD 111 158 | BEGIN 222 159 | [1cs-roll] 160 | THEN 161 | 333 162 | R> 1- >R 163 | R@ 0< 164 | UNTIL 165 | R> DROP 166 | ; -> }T 167 | 168 | T{ 1 pt8 -> 333 222 333 }T 169 | 170 | \ ------------------------------------------------------------------------------ 171 | 172 | CR .( End of Programming Tools word tests) CR 173 | -------------------------------------------------------------------------------- /software/intel2hex.py: -------------------------------------------------------------------------------- 1 | import sys 2 | from intelhex import IntelHex 3 | 4 | i = IntelHex(sys.argv[1]) 5 | i.readfile() 6 | bin = i.tobinstr().ljust(32768, chr(0)) 7 | open(sys.argv[2], "w").write("".join(["%02x\n" % ord(c) for c in bin])) 8 | -------------------------------------------------------------------------------- /software/intelhex.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | 3 | # Copyright (c) 2005-2007, Alexander Belchenko 4 | # All rights reserved. 5 | # 6 | # Redistribution and use in source and binary forms, 7 | # with or without modification, are permitted provided 8 | # that the following conditions are met: 9 | # 10 | # * Redistributions of source code must retain 11 | # the above copyright notice, this list of conditions 12 | # and the following disclaimer. 13 | # * Redistributions in binary form must reproduce 14 | # the above copyright notice, this list of conditions 15 | # and the following disclaimer in the documentation 16 | # and/or other materials provided with the distribution. 17 | # * Neither the name of the 18 | # nor the names of its contributors may be used to endorse 19 | # or promote products derived from this software 20 | # without specific prior written permission. 21 | # 22 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 24 | # BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY 25 | # AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 26 | # IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE 27 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 28 | # OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 29 | # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 30 | # OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 31 | # AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 32 | # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 33 | # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 34 | # EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | 36 | '''Intel HEX file format reader and converter. 37 | 38 | This script also may be used as hex2bin convertor utility. 39 | 40 | @author Alexander Belchenko (bialix AT ukr net) 41 | @version 0.8.6 42 | @date 2007/04/26 43 | ''' 44 | 45 | 46 | __docformat__ = "javadoc" 47 | 48 | 49 | from array import array 50 | from binascii import hexlify, unhexlify 51 | 52 | 53 | class IntelHex: 54 | ''' Intel HEX file reader. ''' 55 | 56 | def __init__(self, fname): 57 | ''' Constructor. 58 | @param fname file name of HEX file or file object. 59 | ''' 60 | #public members 61 | self.Error = None 62 | self.AddrOverlap = None 63 | self.padding = 0x0FF 64 | # Start Address 65 | self.start_addr = None 66 | 67 | # private members 68 | self._fname = fname 69 | self._buf = {} 70 | self._readed = False 71 | self._eof = False 72 | self._offset = 0 73 | 74 | def readfile(self): 75 | ''' Read file into internal buffer. 76 | @return True if successful. 77 | ''' 78 | if self._readed: 79 | return True 80 | 81 | if not hasattr(self._fname, "read"): 82 | f = file(self._fname, "rU") 83 | fclose = f.close 84 | else: 85 | f = self._fname 86 | fclose = None 87 | 88 | self._offset = 0 89 | self._eof = False 90 | 91 | result = True 92 | 93 | for s in f: 94 | if not self.decode_record(s): 95 | result = False 96 | break 97 | 98 | if self._eof: 99 | break 100 | 101 | if fclose: 102 | fclose() 103 | 104 | self._readed = result 105 | return result 106 | 107 | def decode_record(self, s): 108 | ''' Decode one record of HEX file. 109 | @param s line with HEX record. 110 | @return True if line decode OK, or this is not HEX line. 111 | False if this is invalid HEX line or checksum error. 112 | ''' 113 | s = s.rstrip('\r\n') 114 | if not s: 115 | return True # empty line 116 | 117 | if s[0] == ':': 118 | try: 119 | bin = array('B', unhexlify(s[1:])) 120 | except TypeError: 121 | # this might be raised by unhexlify when odd hexascii digits 122 | self.Error = "Odd hexascii digits" 123 | return False 124 | length = len(bin) 125 | if length < 5: 126 | self.Error = "Too short line" 127 | return False 128 | else: 129 | return True # first char must be ':' 130 | 131 | record_length = bin[0] 132 | 133 | if length != (5 + record_length): 134 | self.Error = "Invalid line length" 135 | return False 136 | 137 | addr = bin[1]*256 + bin[2] 138 | 139 | record_type = bin[3] 140 | if not (0 <= record_type <= 5): 141 | self.Error = "Invalid type of record: %d" % record_type 142 | return False 143 | 144 | crc = sum(bin) 145 | crc &= 0x0FF 146 | if crc != 0: 147 | self.Error = "Invalid crc" 148 | return False 149 | 150 | if record_type == 0: 151 | # data record 152 | addr += self._offset 153 | for i in xrange(4, 4+record_length): 154 | if not self._buf.get(addr, None) is None: 155 | self.AddrOverlap = addr 156 | self._buf[addr] = bin[i] 157 | addr += 1 # FIXME: addr should be wrapped on 64K boundary 158 | 159 | elif record_type == 1: 160 | # end of file record 161 | if record_length != 0: 162 | self.Error = "Bad End-of-File Record" 163 | return False 164 | self._eof = True 165 | 166 | elif record_type == 2: 167 | # Extended 8086 Segment Record 168 | if record_length != 2 or addr != 0: 169 | self.Error = "Bad Extended 8086 Segment Record" 170 | return False 171 | self._offset = (bin[4]*256 + bin[5]) * 16 172 | 173 | elif record_type == 4: 174 | # Extended Linear Address Record 175 | if record_length != 2 or addr != 0: 176 | self.Error = "Bad Extended Linear Address Record" 177 | return False 178 | self._offset = (bin[4]*256 + bin[5]) * 65536 179 | 180 | elif record_type == 3: 181 | # Start Segment Address Record 182 | if record_length != 4 or addr != 0: 183 | self.Error = "Bad Start Segment Address Record" 184 | return False 185 | if self.start_addr: 186 | self.Error = "Start Address Record appears twice" 187 | return False 188 | self.start_addr = {'CS': bin[4]*256 + bin[5], 189 | 'IP': bin[6]*256 + bin[7], 190 | } 191 | 192 | elif record_type == 5: 193 | # Start Linear Address Record 194 | if record_length != 4 or addr != 0: 195 | self.Error = "Bad Start Linear Address Record" 196 | return False 197 | if self.start_addr: 198 | self.Error = "Start Address Record appears twice" 199 | return False 200 | self.start_addr = {'EIP': (bin[4]*16777216 + 201 | bin[5]*65536 + 202 | bin[6]*256 + 203 | bin[7]), 204 | } 205 | 206 | return True 207 | 208 | def _get_start_end(self, start=None, end=None): 209 | """Return default values for start and end if they are None 210 | """ 211 | if start is None: 212 | start = min(self._buf.keys()) 213 | if end is None: 214 | end = max(self._buf.keys()) 215 | if start > end: 216 | start, end = end, start 217 | return start, end 218 | 219 | def tobinarray(self, start=None, end=None, pad=None): 220 | ''' Convert to binary form. 221 | @param start start address of output bytes. 222 | @param end end address of output bytes. 223 | @param pad fill empty spaces with this value 224 | (if None used self.padding). 225 | @return array of unsigned char data. 226 | ''' 227 | if pad is None: 228 | pad = self.padding 229 | 230 | bin = array('B') 231 | 232 | if self._buf == {}: 233 | return bin 234 | 235 | start, end = self._get_start_end(start, end) 236 | 237 | for i in xrange(start, end+1): 238 | bin.append(self._buf.get(i, pad)) 239 | 240 | return bin 241 | 242 | def tobinstr(self, start=None, end=None, pad=0xFF): 243 | ''' Convert to binary form. 244 | @param start start address of output bytes. 245 | @param end end address of output bytes. 246 | @param pad fill empty spaces with this value 247 | (if None used self.padding). 248 | @return string of binary data. 249 | ''' 250 | return self.tobinarray(start, end, pad).tostring() 251 | 252 | def tobinfile(self, fobj, start=None, end=None, pad=0xFF): 253 | '''Convert to binary and write to file. 254 | 255 | @param fobj file name or file object for writing output bytes. 256 | @param start start address of output bytes. 257 | @param end end address of output bytes. 258 | @param pad fill empty spaces with this value 259 | (if None used self.padding). 260 | ''' 261 | if not hasattr(fobj, "write"): 262 | fobj = file(fobj, "wb") 263 | fclose = fobj.close 264 | else: 265 | fclose = None 266 | 267 | fobj.write(self.tobinstr(start, end, pad)) 268 | 269 | if fclose: 270 | fclose() 271 | 272 | def minaddr(self): 273 | ''' Get minimal address of HEX content. ''' 274 | aa = self._buf.keys() 275 | if aa == []: 276 | return 0 277 | else: 278 | return min(aa) 279 | 280 | def maxaddr(self): 281 | ''' Get maximal address of HEX content. ''' 282 | aa = self._buf.keys() 283 | if aa == []: 284 | return 0 285 | else: 286 | return max(aa) 287 | 288 | def __getitem__(self, addr): 289 | ''' Get byte from address. 290 | @param addr address of byte. 291 | @return byte if address exists in HEX file, or self.padding 292 | if no data found. 293 | ''' 294 | return self._buf.get(addr, self.padding) 295 | 296 | def __setitem__(self, addr, byte): 297 | self._buf[addr] = byte 298 | 299 | def writefile(self, f, write_start_addr=True): 300 | """Write data to file f in HEX format. 301 | 302 | @param f filename or file-like object for writing 303 | @param write_start_addr enable or disable writing start address 304 | record to file (enabled by default). 305 | If there is no start address nothing 306 | will be written. 307 | 308 | @return True if successful. 309 | """ 310 | fwrite = getattr(f, "write", None) 311 | if fwrite: 312 | fobj = f 313 | fclose = None 314 | else: 315 | fobj = file(f, 'w') 316 | fwrite = fobj.write 317 | fclose = fobj.close 318 | 319 | # start address record if any 320 | if self.start_addr and write_start_addr: 321 | keys = self.start_addr.keys() 322 | keys.sort() 323 | bin = array('B', '\0'*9) 324 | if keys == ['CS','IP']: 325 | # Start Segment Address Record 326 | bin[0] = 4 # reclen 327 | bin[1] = 0 # offset msb 328 | bin[2] = 0 # offset lsb 329 | bin[3] = 3 # rectyp 330 | cs = self.start_addr['CS'] 331 | bin[4] = (cs >> 8) & 0x0FF 332 | bin[5] = cs & 0x0FF 333 | ip = self.start_addr['IP'] 334 | bin[6] = (ip >> 8) & 0x0FF 335 | bin[7] = ip & 0x0FF 336 | bin[8] = (-sum(bin)) & 0x0FF # chksum 337 | fwrite(':') 338 | fwrite(hexlify(bin.tostring()).upper()) 339 | fwrite('\n') 340 | elif keys == ['EIP']: 341 | # Start Linear Address Record 342 | bin[0] = 4 # reclen 343 | bin[1] = 0 # offset msb 344 | bin[2] = 0 # offset lsb 345 | bin[3] = 5 # rectyp 346 | eip = self.start_addr['EIP'] 347 | bin[4] = (eip >> 24) & 0x0FF 348 | bin[5] = (eip >> 16) & 0x0FF 349 | bin[6] = (eip >> 8) & 0x0FF 350 | bin[7] = eip & 0x0FF 351 | bin[8] = (-sum(bin)) & 0x0FF # chksum 352 | fwrite(':') 353 | fwrite(hexlify(bin.tostring()).upper()) 354 | fwrite('\n') 355 | else: 356 | self.Error = ('Invalid start address value: %r' 357 | % self.start_addr) 358 | return False 359 | 360 | # data 361 | minaddr = IntelHex.minaddr(self) 362 | maxaddr = IntelHex.maxaddr(self) 363 | if maxaddr > 65535: 364 | offset = (minaddr/65536)*65536 365 | else: 366 | offset = None 367 | 368 | while True: 369 | if offset != None: 370 | # emit 32-bit offset record 371 | high_ofs = offset / 65536 372 | offset_record = ":02000004%04X" % high_ofs 373 | bytes = divmod(high_ofs, 256) 374 | csum = 2 + 4 + bytes[0] + bytes[1] 375 | csum = (-csum) & 0x0FF 376 | offset_record += "%02X\n" % csum 377 | 378 | ofs = offset 379 | if (ofs + 65536) > maxaddr: 380 | rng = xrange(maxaddr - ofs + 1) 381 | else: 382 | rng = xrange(65536) 383 | else: 384 | ofs = 0 385 | offset_record = '' 386 | rng = xrange(maxaddr + 1) 387 | 388 | csum = 0 389 | k = 0 390 | record = "" 391 | for addr in rng: 392 | byte = self._buf.get(ofs+addr, None) 393 | if byte != None: 394 | if k == 0: 395 | # optionally offset record 396 | fobj.write(offset_record) 397 | offset_record = '' 398 | # start data record 399 | record += "%04X00" % addr 400 | bytes = divmod(addr, 256) 401 | csum = bytes[0] + bytes[1] 402 | 403 | k += 1 404 | # continue data in record 405 | record += "%02X" % byte 406 | csum += byte 407 | 408 | # check for length of record 409 | if k < 16: 410 | continue 411 | 412 | if k != 0: 413 | # close record 414 | csum += k 415 | csum = (-csum) & 0x0FF 416 | record += "%02X" % csum 417 | fobj.write(":%02X%s\n" % (k, record)) 418 | # cleanup 419 | csum = 0 420 | k = 0 421 | record = "" 422 | else: 423 | if k != 0: 424 | # close record 425 | csum += k 426 | csum = (-csum) & 0x0FF 427 | record += "%02X" % csum 428 | fobj.write(":%02X%s\n" % (k, record)) 429 | 430 | # advance offset 431 | if offset is None: 432 | break 433 | 434 | offset += 65536 435 | if offset > maxaddr: 436 | break 437 | 438 | # end-of-file record 439 | fobj.write(":00000001FF\n") 440 | if fclose: 441 | fclose() 442 | 443 | return True 444 | #/IntelHex 445 | 446 | 447 | class IntelHex16bit(IntelHex): 448 | """Access to data as 16-bit words.""" 449 | 450 | def __init__(self, source): 451 | """Construct class from HEX file 452 | or from instance of ordinary IntelHex class. 453 | 454 | @param source file name of HEX file or file object 455 | or instance of ordinary IntelHex class 456 | """ 457 | if isinstance(source, IntelHex): 458 | # from ihex8 459 | self.Error = source.Error 460 | self.AddrOverlap = source.AddrOverlap 461 | self.padding = source.padding 462 | 463 | # private members 464 | self._fname = source._fname 465 | self._buf = source._buf 466 | self._readed = source._readed 467 | self._eof = source._eof 468 | self._offset = source._offset 469 | else: 470 | IntelHex.__init__(self, source) 471 | 472 | if self.padding == 0x0FF: 473 | self.padding = 0x0FFFF 474 | 475 | def __getitem__(self, addr16): 476 | """Get 16-bit word from address. 477 | Raise error if found only one byte from pair. 478 | 479 | @param addr16 address of word (addr8 = 2 * addr16). 480 | @return word if bytes exists in HEX file, or self.padding 481 | if no data found. 482 | """ 483 | addr1 = addr16 * 2 484 | addr2 = addr1 + 1 485 | byte1 = self._buf.get(addr1, None) 486 | byte2 = self._buf.get(addr2, None) 487 | 488 | if byte1 != None and byte2 != None: 489 | return byte1 | (byte2 << 8) # low endian 490 | 491 | if byte1 == None and byte2 == None: 492 | return self.padding 493 | 494 | raise Exception, 'Bad access in 16-bit mode (not enough data)' 495 | 496 | def __setitem__(self, addr16, word): 497 | addr_byte = addr16 * 2 498 | bytes = divmod(word, 256) 499 | self._buf[addr_byte] = bytes[1] 500 | self._buf[addr_byte+1] = bytes[0] 501 | 502 | def minaddr(self): 503 | '''Get minimal address of HEX content in 16-bit mode.''' 504 | aa = self._buf.keys() 505 | if aa == []: 506 | return 0 507 | else: 508 | return min(aa)/2 509 | 510 | def maxaddr(self): 511 | '''Get maximal address of HEX content in 16-bit mode.''' 512 | aa = self._buf.keys() 513 | if aa == []: 514 | return 0 515 | else: 516 | return max(aa)/2 517 | 518 | #/class IntelHex16bit 519 | 520 | 521 | def hex2bin(fin, fout, start=None, end=None, size=None, pad=0xFF): 522 | """Hex-to-Bin convertor engine. 523 | @return 0 if all OK 524 | 525 | @param fin input hex file (filename or file-like object) 526 | @param fout output bin file (filename or file-like object) 527 | @param start start of address range (optional) 528 | @param end end of address range (optional) 529 | @param size size of resulting file (in bytes) (optional) 530 | @param pad padding byte (optional) 531 | """ 532 | h = IntelHex(fin) 533 | if not h.readfile(): 534 | print "Bad HEX file" 535 | return 1 536 | 537 | # start, end, size 538 | if size != None and size != 0: 539 | if end == None: 540 | if start == None: 541 | start = h.minaddr() 542 | end = start + size - 1 543 | else: 544 | if (end+1) >= size: 545 | start = end + 1 - size 546 | else: 547 | start = 0 548 | 549 | try: 550 | h.tobinfile(fout, start, end, pad) 551 | except IOError: 552 | print "Could not write to file: %s" % fout 553 | return 1 554 | 555 | return 0 556 | #/def hex2bin 557 | 558 | 559 | if __name__ == '__main__': 560 | import getopt 561 | import os 562 | import sys 563 | 564 | usage = '''Hex2Bin python converting utility. 565 | Usage: 566 | python intelhex.py [options] file.hex [out.bin] 567 | 568 | Arguments: 569 | file.hex name of hex file to processing. 570 | out.bin name of output file. 571 | If omitted then output write to file.bin. 572 | 573 | Options: 574 | -h, --help this help message. 575 | -p, --pad=FF pad byte for empty spaces (ascii hex value). 576 | -r, --range=START:END specify address range for writing output 577 | (ascii hex value). 578 | Range can be in form 'START:' or ':END'. 579 | -l, --length=NNNN, 580 | -s, --size=NNNN size of output (decimal value). 581 | ''' 582 | 583 | pad = 0xFF 584 | start = None 585 | end = None 586 | size = None 587 | 588 | try: 589 | opts, args = getopt.getopt(sys.argv[1:], "hp:r:l:s:", 590 | ["help", "pad=", "range=", 591 | "length=", "size="]) 592 | 593 | for o, a in opts: 594 | if o in ("-h", "--help"): 595 | print usage 596 | sys.exit(0) 597 | elif o in ("-p", "--pad"): 598 | try: 599 | pad = int(a, 16) & 0x0FF 600 | except: 601 | raise getopt.GetoptError, 'Bad pad value' 602 | elif o in ("-r", "--range"): 603 | try: 604 | l = a.split(":") 605 | if l[0] != '': 606 | start = int(l[0], 16) 607 | if l[1] != '': 608 | end = int(l[1], 16) 609 | except: 610 | raise getopt.GetoptError, 'Bad range value(s)' 611 | elif o in ("-l", "--lenght", "-s", "--size"): 612 | try: 613 | size = int(a, 10) 614 | except: 615 | raise getopt.GetoptError, 'Bad size value' 616 | 617 | if start != None and end != None and size != None: 618 | raise getopt.GetoptError, 'Cannot specify START:END and SIZE simultaneously' 619 | 620 | if not args: 621 | raise getopt.GetoptError, 'Hex file is not specified' 622 | 623 | if len(args) > 2: 624 | raise getopt.GetoptError, 'Too many arguments' 625 | 626 | except getopt.GetoptError, msg: 627 | print msg 628 | print usage 629 | sys.exit(2) 630 | 631 | fin = args[0] 632 | if len(args) == 1: 633 | import os.path 634 | name, ext = os.path.splitext(fin) 635 | fout = name + ".bin" 636 | else: 637 | fout = args[1] 638 | 639 | if not os.path.isfile(fin): 640 | print "File not found" 641 | sys.exit(1) 642 | 643 | sys.exit(hex2bin(fin, fout, start, end, size, pad)) 644 | -------------------------------------------------------------------------------- /testbench.v: -------------------------------------------------------------------------------- 1 | /* verilator lint_off UNUSED */ 2 | 3 | module testbench ( 4 | input clock, 5 | output [7:0] cc, 6 | output unsupported, 7 | input [7:0] io_din, 8 | output io_inp, 9 | output io_out, 10 | output [7:0] io_dout, 11 | output [2:0] io_n 12 | ); 13 | 14 | reg [7:0] count; 15 | always @(posedge clock) 16 | count <= count + 1; 17 | assign cc = count; 18 | 19 | wire ram_rd, ram_wr; 20 | wire [7:0] ram_q, ram_d; 21 | wire [15:0] ram_a; 22 | 23 | ram _ram ( 24 | .clk(clock), 25 | .re(ram_rd), 26 | .we(ram_wr), 27 | .d(ram_d), 28 | .a(ram_a), 29 | .q(ram_q)); 30 | 31 | /* verilator lint_off UNUSED */ 32 | wire Q; 33 | cdp1802 cdp1802 ( 34 | .clock(clock), 35 | .resetq(1'b1), 36 | .Q(Q), 37 | .EF(4'b0000), 38 | 39 | .io_n(io_n), 40 | .io_inp(io_inp), 41 | .io_out(io_out), 42 | 43 | .ram_rd(ram_rd), 44 | .ram_wr(ram_wr), 45 | .ram_q(ram_q), 46 | .ram_d(ram_d), 47 | .ram_a(ram_a), 48 | 49 | .io_din(io_din), 50 | .io_dout(io_dout), 51 | 52 | .unsupported(unsupported) 53 | ); 54 | 55 | endmodule 56 | --------------------------------------------------------------------------------