├── .gitignore ├── SIM2000 ├── run ├── hexin.c ├── decode.c ├── output.c ├── appforth.bin ├── bin2hex.exe ├── sim2000.csm ├── sim2000.dsw ├── sim2000.exe ├── sim2000.ide ├── Makefile ├── hexin.h ├── host.h ├── testhex.c ├── execute.h ├── output.h ├── main.h ├── tdecode.c ├── texec.c ├── readme.1st └── decode.h ├── RTX2000 ├── myterm.com ├── term.4th ├── term.com ├── term.exe ├── unload.com ├── bin2hex.exe ├── progcard.pdf ├── rtx2000.bin ├── rtx2001a.bin ├── rtx2010.bin ├── TESTS │ ├── globals.h │ ├── ops.cap │ ├── term.exe │ ├── save.4th │ ├── 2010.4th │ ├── fib.c │ ├── ship.bat │ ├── ilist.4th │ ├── install.bat │ ├── fib.asm │ ├── skifib │ ├── bperm.c │ ├── xsieve.c │ ├── sieve.c │ ├── perm.c │ ├── bbubble.c │ ├── bintmm.c │ ├── xperm.c │ ├── bqueen.c │ ├── bquick.c │ ├── sieve.a.4th │ ├── example.4th │ ├── bubble.c │ ├── sieve.e.4th │ ├── matmul.c │ ├── sieve.c.4th │ ├── xbubble.c │ ├── quick.c │ ├── sieve.b.4th │ ├── perm.e.4th │ ├── xquick.c │ ├── fib.4th │ ├── xmatmul.c │ ├── perm.a.4th │ ├── perm.c.4th │ ├── perm.b.4th │ ├── matmul.a.4th │ ├── matmul.e.4th │ ├── queens.c │ ├── xqueens.c │ ├── btowers.c │ ├── bubble.e.4th │ ├── matmul.c.4th │ ├── bubble.a.4th │ ├── matmul.b.4th │ ├── queens.a.4th │ ├── towers.c │ ├── xtowers.c │ ├── bubble.c.4th │ ├── quick.a.4th │ ├── bubble.b.4th │ ├── quick.e.4th │ ├── towers.e.4th │ ├── queens.e.4th │ ├── towers.a.4th │ ├── queens.b.4th │ ├── ctest.4th │ ├── queens.c.4th │ ├── quick.b.4th │ ├── quick.c.4th │ ├── sieve.d.4th │ ├── towers.c.4th │ ├── towers.b.4th │ ├── slowtigr.4th │ ├── bperm.s │ └── tigre.4th ├── read.me ├── files.txt ├── COMVERS │ ├── fib.hnd │ ├── fib.rtx │ ├── sieve.ces │ ├── perm.ces │ ├── matmul.ces │ ├── queens.ces │ ├── bubble.ces │ ├── quick.ces │ ├── towers.ces │ ├── sieve.rtx │ └── sieve.ins └── math.txt └── README.txt /.gitignore: -------------------------------------------------------------------------------- 1 | gmon.out 2 | SIM2000/sim2000 -------------------------------------------------------------------------------- /SIM2000/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ./sim2000 appforth.hex 4 | -------------------------------------------------------------------------------- /SIM2000/hexin.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/hexin.c -------------------------------------------------------------------------------- /RTX2000/myterm.com: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/myterm.com -------------------------------------------------------------------------------- /RTX2000/term.4th: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/term.4th -------------------------------------------------------------------------------- /RTX2000/term.com: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/term.com -------------------------------------------------------------------------------- /RTX2000/term.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/term.exe -------------------------------------------------------------------------------- /RTX2000/unload.com: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/unload.com -------------------------------------------------------------------------------- /SIM2000/decode.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/decode.c -------------------------------------------------------------------------------- /SIM2000/output.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/output.c -------------------------------------------------------------------------------- /RTX2000/bin2hex.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/bin2hex.exe -------------------------------------------------------------------------------- /RTX2000/progcard.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/progcard.pdf -------------------------------------------------------------------------------- /RTX2000/rtx2000.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/rtx2000.bin -------------------------------------------------------------------------------- /RTX2000/rtx2001a.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/rtx2001a.bin -------------------------------------------------------------------------------- /RTX2000/rtx2010.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/rtx2010.bin -------------------------------------------------------------------------------- /SIM2000/appforth.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/appforth.bin -------------------------------------------------------------------------------- /SIM2000/bin2hex.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/bin2hex.exe -------------------------------------------------------------------------------- /SIM2000/sim2000.csm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/sim2000.csm -------------------------------------------------------------------------------- /SIM2000/sim2000.dsw: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/sim2000.dsw -------------------------------------------------------------------------------- /SIM2000/sim2000.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/sim2000.exe -------------------------------------------------------------------------------- /SIM2000/sim2000.ide: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/SIM2000/sim2000.ide -------------------------------------------------------------------------------- /RTX2000/TESTS/globals.h: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/TESTS/globals.h -------------------------------------------------------------------------------- /RTX2000/TESTS/ops.cap: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/TESTS/ops.cap -------------------------------------------------------------------------------- /RTX2000/TESTS/term.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/rtx2000_simulator/HEAD/RTX2000/TESTS/term.exe -------------------------------------------------------------------------------- /RTX2000/TESTS/save.4th: -------------------------------------------------------------------------------- 1 | DECIMAL 2 | 3 | : SAVE-IMAGE ( a # SAVE filename) 4 | BL WORD COUNT CREATE-FILE ( handle) >R 5 | BEGIN ( a #) 6 | DUP 1024 > WHILE 7 | OVER 1024 R@ WRITE-FILE DROP 8 | SWAP 1024 + SWAP 1024 - 9 | REPEAT 10 | R@ WRITE-FILE DROP 11 | R> CLOSE-FILE ; 12 | 13 | 14 | -------------------------------------------------------------------------------- /RTX2000/read.me: -------------------------------------------------------------------------------- 1 | RTX 2000 Programmer's Reference Card 2 | 3 | PROGCARD.PRN contains a laserjet printable single page instruction set 4 | reference for the RTX 2000. It will print on any HP Laserjet II compatible 5 | printer. Use the DOS command 6 | 7 | COPY PROGCARD.PRN/B PRN 8 | 9 | to print it. 10 | 11 | -------------------------------------------------------------------------------- /SIM2000/Makefile: -------------------------------------------------------------------------------- 1 | 2 | FILES=decode.c execute.c hexin.c host.c output.c state.c 3 | 4 | main: 5 | gcc ${FILES} main.c -o sim2000 6 | 7 | tdecode: 8 | gcc ${FILES} tdecode.c 9 | 10 | testhex: 11 | gcc ${FILES} testhex.c 12 | 13 | texec: 14 | gcc ${FILES} texec.c 15 | 16 | 17 | .PHONY: clean 18 | 19 | clean:: 20 | rm -f sim2000 21 | -------------------------------------------------------------------------------- /SIM2000/hexin.h: -------------------------------------------------------------------------------- 1 | /* HEXIN.H -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | #ifndef HEXIN_H 6 | #define HEXIN_H 7 | 8 | #include 9 | 10 | #define DEBUG_HEX 0 /* when 1, prints data read from .HEX file */ 11 | 12 | extern void hex_input(FILE *in_file); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /SIM2000/host.h: -------------------------------------------------------------------------------- 1 | /* HOST.H -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | #ifndef HOST_H 6 | #define HOST_H 7 | 8 | extern int host_read(); 9 | extern void host_write(int data); 10 | 11 | extern int hostmode; /* when true, in process of talking to the host */ 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /SIM2000/testhex.c: -------------------------------------------------------------------------------- 1 | /* TESTHEX.C -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | #include "hexin.h" 6 | int which_chip ; 7 | 8 | void error(char *s) 9 | { 10 | fprintf(/*stderr*/stdout,"\nERROR: %s ",s); 11 | } 12 | 13 | main() 14 | { 15 | printf("\nloading .HEX file..."); 16 | hex_input(stdin); 17 | printf("done\n"); 18 | } 19 | -------------------------------------------------------------------------------- /RTX2000/TESTS/2010.4th: -------------------------------------------------------------------------------- 1 | \ COPYRIGHT 1990 HARRIS CORPORATION ALL RIGHTS RESERVED 2 | \ Rick VanNorman Mon 04-23-1990 15:34:23 3 | 4 | \ 2010 OPCODES 5 | 6 | BE12 UCODE MXR@ B00E UCODE DSLL 7 | BE92 UCODE MXR! B012 UCODE SMACS 8 | B00C UCODE CLEARACC B092 UCODE SMACA 9 | B017 UCODE MULACS 10 | B015 UCODE MULACM 11 | B014 UCODE MULSUB 12 | B013 UCODE MULM 13 | B016 UCODE MULACU 14 | B011 UCODE RSACC 15 | B008 UCODE 0=2010 16 | B00F UCODE NORM 17 | B00A UCODE DSRL 18 | B009 UCODE DSRA 19 | 20 | -------------------------------------------------------------------------------- /RTX2000/TESTS/fib.c: -------------------------------------------------------------------------------- 1 | /* fib.c */ 2 | /* Phil Koopman Jr. */ 3 | 4 | #include 5 | /* #include */ 6 | 7 | static int fib(n) 8 | int n; 9 | { int result ; 10 | if ( n < 3 ) 11 | { return(1) ; } 12 | result = fib(n-1) + fib(n-2) ; 13 | return(result); 14 | } 15 | 16 | 17 | void main() 18 | { int input; 19 | input = 2 ; 20 | while (input > 0 ) 21 | { 22 | printf("\nFibonacci. Input?"); 23 | scanf("%d",&input); 24 | printf(" = %d",fib(input)); 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /RTX2000/files.txt: -------------------------------------------------------------------------------- 1 | 2 | Volume in drive A has no label 3 | Directory of A:\ 4 | 5 | TERM 4 11998 10-10-90 4:30p 6 | TERM EXE 32494 10-10-90 4:31p 7 | FILES DOC 507 10-10-90 4:56p 8 | GLOSSARY DOC 129903 6-07-90 9:54a 9 | APPFORTH 4 57863 10-10-90 4:40p 10 | RTX2000 BIN 16384 10-10-90 4:39p 11 | RTX2001A BIN 16384 10-10-90 4:40p 12 | RTX2010 BIN 16384 10-10-90 4:40p 13 | README 1ST 7833 10-10-90 4:41p 14 | 9 File(s) 69632 bytes free 15 | -------------------------------------------------------------------------------- /RTX2000/TESTS/ship.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | goto start 3 | 4 | This file builds the shippable disk for APPFORTH on drive a: from the 5 | directory RTX2000 on the current drive. 6 | 7 | Rick VanNorman Tue 05-01-1990 8 | 9 | :start 10 | cd \rtx2000 11 | del *.bak 12 | cd \ 13 | del rtx2000.zip 14 | pkzip -rP rtx2000 rtx2000\*.* 15 | 16 | a: 17 | echo y | del *.* 18 | c: 19 | 20 | @echo on 21 | 22 | copy rtx2000.zip a: 23 | copy rtx2000\install.bat a: 24 | copy c:\bin\pkunzip.exe a: 25 | copy c:\bin\ticker.com a: 26 | 27 | @echo . 28 | @echo Ship completed. 29 | 30 | 31 | -------------------------------------------------------------------------------- /RTX2000/TESTS/ilist.4th: -------------------------------------------------------------------------------- 1 | 2 | \ Generate a disassembly of all instructions 3 | 4 | EMPTY 5 | 6 | : xy " dos xy ilist.4" evaluate ; 7 | 8 | \ Constants for 2010 AppForth, from disassembling the word UN 9 | : UN-ONE $1345 , ; IMMEDIATE 10 | : LOCATION $0E71 , ; IMMEDIATE 11 | 12 | : dis-asm ( n -- ) \ uses address $9000 13 | LOCATION @ ! 14 | UN-ONE 15 | ; 16 | 17 | : .DIS-ASM ( n -- ) 18 | DUP S>D <# # # # # #> TYPE ." " DIS-ASM CR 19 | 13 for -1 FOR NEXT next ; 20 | 21 | : MAKE-LIST 22 | HEX cr cr 23 | $9000 LOCATION ! 24 | 0 .DIS-ASM 25 | $FFFF $7FFF DO I .DIS-ASM LOOP 26 | $FFFF .DIS-ASM 27 | BYE ; 28 | 29 | .( type in: MAKE-LIST) 30 | -------------------------------------------------------------------------------- /SIM2000/execute.h: -------------------------------------------------------------------------------- 1 | /* EXECUTE.H -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | #define NUMBER_OF_ROUTINES 128 6 | /* Note: you *MUST* change the initialization statement for the array 7 | * if NUMBER_OF_ROUTINES is changed !!!!! */ 8 | extern void (*dispatch_vector[NUMBER_OF_ROUTINES]) (); 9 | 10 | extern void execute(int instruction); 11 | extern void execute_2(int instruction); 12 | 13 | void init_dispatch(); /* initialize the function dispatch vector */ 14 | 15 | #define EXIT (IR & 0x0020) 16 | #define TEST_EXIT { if (EXIT) do_exit(); } 17 | extern void do_exit(); 18 | -------------------------------------------------------------------------------- /RTX2000/TESTS/install.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | goto start 3 | 4 | Batch file to install appforth on a pc 5 | Rick VanNorman Tue 05-01-1990 6 | 7 | This installs from A: to C: -- change the drive constant if you wish 8 | 9 | :start 10 | 11 | echo A directory rtx2000 will be created in the root of drive C 12 | echo and rtx2000 will be uncompressed from a .ZIP file into this 13 | echo directory. If you wish to install it on a drive other 14 | echo than C: please edit the INSTALL.BAT file appropriately. 15 | 16 | a:ticker Any key to continue, control-c to abort 17 | 18 | c: 19 | cd \ 20 | a:pkunzip -d -o a:rtx2000 21 | cd rtx2000 22 | 23 | echo Installation complete -- type TERM to enter the terminal environment 24 | 25 | 26 | -------------------------------------------------------------------------------- /SIM2000/output.h: -------------------------------------------------------------------------------- 1 | /* OUTPUT.H -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | /* print a disassembled instruction to a designated output */ 6 | /* inputs: *outf = output file (e.g., stdout) 7 | * opr = decoded instruction token 8 | * instruction = 16-bit instruction value 9 | * address = address of instruction (for branch computations 10 | */ 11 | 12 | #ifndef OUTPUT_H 13 | #define OUTPUT_H 14 | 15 | #include 16 | 17 | #include "decode.h" 18 | 19 | void print_instruction(FILE *outf, machine_op opr, 20 | int instruction, int page, int address); 21 | 22 | #endif 23 | -------------------------------------------------------------------------------- /RTX2000/TESTS/fib.asm: -------------------------------------------------------------------------------- 1 | 2 | DOSSEG 3 | .MODEL small 4 | .STACK 100h 5 | .DATA 6 | msga DB 'START$' 7 | msgb DB 'STOP$' 8 | msgc DB ' answer = -13111 $' 9 | .CODE 10 | 11 | mov ax, @data 12 | mov ds,ax 13 | mov ah,9 14 | mov dx,OFFSET msga 15 | int 21h 16 | 17 | mov bx,35 18 | call fib 19 | 20 | mov ax, @data 21 | mov ds,ax 22 | mov ah,9 23 | mov dx,OFFSET msgb 24 | 25 | cmp bx,-13111 26 | jne lab1 27 | mov dx,OFFSET msgc 28 | lab1: 29 | int 21h 30 | 31 | mov ah,4ch 32 | int 21h 33 | 34 | fib: 35 | cmp bx,3 36 | jge lab2 37 | mov bx,1 38 | ret 39 | lab2: 40 | push bx 41 | sub bx,1 42 | call fib 43 | pop ax 44 | xchg ax,bx 45 | push ax 46 | sub bx,2 47 | call fib 48 | pop ax 49 | add bx,ax 50 | ret 51 | 52 | END 53 | -------------------------------------------------------------------------------- /SIM2000/main.h: -------------------------------------------------------------------------------- 1 | /* MAIN.H -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | #ifndef MAIN_H 6 | #define MAIN_H 7 | 8 | extern void error(char *s); 9 | extern void error_1(char *s, int n); 10 | extern void warning(char *s); 11 | extern void warning_3(char *s, int page, int offset); 12 | 13 | extern int which_chip; 14 | #define RTX2000 1 15 | #define RTX2001A 2 16 | #define RTX2010 3 17 | 18 | #define FALSE 0 19 | #define TRUE 1 20 | 21 | // #ifdef TURBOC 22 | #define LONG long 23 | // #else 24 | // #define LONG int /* 32-bit systems */ 25 | // #endif 26 | 27 | #ifdef TURBOC 28 | #define _MASKED_ /* nop */ 29 | #else 30 | #define _MASKED_ & 0xFFFF /* mask to 16 bits */ 31 | #endif 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /SIM2000/tdecode.c: -------------------------------------------------------------------------------- 1 | /* TDECODE.C -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | /* test code file for instruction cracking */ 6 | 7 | #include "output.h" 8 | #include "main.h" 9 | 10 | int which_chip ; 11 | 12 | void error(char *s) 13 | { 14 | fprintf(/*stderr*/stdout,"\nERROR: %s ",s); 15 | } 16 | 17 | void main() 18 | { 19 | unsigned int i; 20 | int j; 21 | 22 | which_chip = RTX2001A; 23 | for (i = 0x7FFF; i <= 0xFFFE; i++) 24 | { j = i; 25 | printf("%05X ",j); 26 | print_instruction(stdout, decode(j), j, 0, 0x9000); 27 | printf("\n"); 28 | } 29 | j = 0xFFFF; 30 | printf("%05X ",j); 31 | print_instruction(stdout, decode(j), j, 0, 0x9000); 32 | printf("\n"); 33 | } 34 | -------------------------------------------------------------------------------- /RTX2000/TESTS/skifib: -------------------------------------------------------------------------------- 1 | ((S ((S ((S (K IF)) ((S <) (K 3)))) (K 1))) 2 | ((S ((S (K +)) ((S (K CYCLE)) ((S -) (K 1))))) 3 | ((S (K CYCLE)) ((S -) (K 2))))). 4 | 5 | fib x = 1 ; x < 3 6 | = fib(x-1) (x-2) 7 | 8 | this is fib(x), where: n fib(n) 9 | 1 1 10 | 2 1 11 | 3 2 12 | 4 3 13 | 5 5 ... 14 | 15 | ***** this is SKIFIB right out of the compiler 16 | ((S((S((S(K IF))((S((S(K <))I))(K 3))))(K 1))) 17 | ((S((S(K +))((S(K CYCLE))((S((S (K -))I))(K 1))))) 18 | ((S(K CYCLE))((S((S(K -))I))(K 2))))). 19 | 20 | ***** this is SKIFIB with Turner Set optimizations 1 and 2 applied 21 | ((S ((S 22 | ((S (K IF)) ((S <) (K 3))))(K 1))) 23 | ((S((S(K +))((S(K CYCLE))((S -) (K 1))))) 24 | ((S(K CYCLE))((S -) (K 2))))). 25 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bperm.c: -------------------------------------------------------------------------------- 1 | /******************** PERM ************************/ 2 | 3 | #define PERMRANGE 10 4 | 5 | int permarray [PERMRANGE+1]; 6 | int pctr; 7 | 8 | void swap (a, b) 9 | int *a; 10 | int *b; 11 | { 12 | int t; 13 | t = *a; *a = *b; *b = t; 14 | } 15 | 16 | void initialize () { 17 | int i; 18 | for (i=1; i<=7; i++) { 19 | permarray [i] = i - 1; 20 | } 21 | } 22 | 23 | void permute (n) 24 | int n; 25 | { 26 | int k; 27 | 28 | pctr = pctr + 1; 29 | if (n != 1) { 30 | permute (n-1); 31 | for (k=n-1; k>=1; k--) { 32 | swap (&permarray[n], &permarray[k]); 33 | permute (n-1); 34 | swap (&permarray[n], &permarray[k]); 35 | } 36 | } 37 | } 38 | 39 | void main () { 40 | int i; 41 | 42 | pctr = 0; 43 | for (i=1; i<=5; i++) { 44 | initialize (); 45 | permute (7); 46 | } 47 | } 48 | 49 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xsieve.c: -------------------------------------------------------------------------------- 1 | /* Eratosthenes Sieve Prime Number Program in C from Byte January 1983 */ 2 | /* Hand-optimized for best C performance by Phil Koopman */ 3 | 4 | #include 5 | 6 | #define true 1 7 | #define false 0 8 | #define size 8190 9 | 10 | char flags [size+1]; 11 | 12 | static void do_error() { 13 | puts(" Error in Sieve.\n"); } 14 | 15 | void main() 16 | { 17 | int count, iter, j, k, prime; 18 | char *i; 19 | for(iter = 1; iter < 350 ; iter++) 20 | { 21 | count = 0 ; /* prime counter */ 22 | for (i = &flags[0]; i <= &flags[size]; i++) /* set all flags true */ 23 | *i = true ; 24 | for (j = 0; j <= size; j++) 25 | { 26 | if (flags[j]) /* found a prime */ 27 | { 28 | prime = j + j + 3 ; 29 | for (k = j+prime; k<=size; k+= prime) 30 | { flags[k] = false; } 31 | count++; 32 | } 33 | } 34 | if (count != 1899) do_error(); 35 | } 36 | } 37 | 38 | -------------------------------------------------------------------------------- /RTX2000/TESTS/sieve.c: -------------------------------------------------------------------------------- 1 | /* Eratosthenes Siee Prime Number Program in C from Byte January 1983 */ 2 | 3 | #include 4 | 5 | #define true 1 6 | #define false 0 7 | #define size 8190 8 | 9 | char flags [size+1]; 10 | 11 | static void do_error() { 12 | printf(" Error in Sieve.\n"); } 13 | 14 | void main() 15 | { 16 | int prime, count, iter; 17 | register i,k; 18 | /* getchar(); */ 19 | for(iter = 1; iter < 350 ; iter++) 20 | { 21 | /* putchar ('I'); */ 22 | count = 0 ; /* prime counter */ 23 | for (i = 0; i <= size; i++) /* set all flags true */ 24 | flags[i] = true ; 25 | for (i = 0; i <= size; i++) 26 | { 27 | if (flags[i]) /* found a prime */ 28 | { 29 | prime = i + i + 3 ; 30 | for (k = i+prime; k<=size; k+= prime) 31 | flags[k] = false; 32 | count++; 33 | } 34 | } 35 | } 36 | /* printf(" %d primes found\n",count); */ 37 | if (count != 1899) do_error(); 38 | } 39 | 40 | -------------------------------------------------------------------------------- /SIM2000/texec.c: -------------------------------------------------------------------------------- 1 | /* TEXEC.C -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | /* test code file for instruction execution */ 6 | 7 | #include "main.h" 8 | #include "execute.h" 9 | #include "decode.h" 10 | #include "state.h" 11 | #include 12 | 13 | int which_chip ; 14 | 15 | void error(char *s) 16 | { 17 | printf("\nERROR: %s ",s); 18 | } 19 | 20 | void trace(int instruction, int address) 21 | { 22 | execute(instruction); 23 | printf("%X insn=%X ",address,instruction); 24 | print_instruction(stdout, decode(instruction), instruction, CPR, PC); 25 | display_ds(); 26 | printf("\n"); 27 | } 28 | 29 | void main() 30 | { 31 | init_dispatch(); 32 | PC = 0x9000; 33 | CPR = 0; 34 | DPR = 0; 35 | display_ds(); printf("\n"); 36 | trace(0xBE43, PC++); /* lit 3 */ 37 | trace(0xBE45, PC++); /* lit 5 */ 38 | trace(0xBE47, PC++); /* lit 7 */ 39 | trace(0xa840, PC++); /* + */ 40 | trace(0xaC40, PC++); /* - */ 41 | printf("\n%ld clocks\n",clocks); 42 | 43 | } 44 | -------------------------------------------------------------------------------- /RTX2000/TESTS/perm.c: -------------------------------------------------------------------------------- 1 | 2 | /* perm.c */ 3 | /* from Stanford benchmark suite */ 4 | /* modified for reasonable 16-bit operation */ 5 | 6 | #include 7 | /* #include "stdlib.h" */ 8 | 9 | /* Perm */ 10 | #define permrange 10 11 | 12 | /* Perm */ 13 | int permarray[permrange+1]; 14 | int pctr; 15 | 16 | static void do_error() { 17 | printf(" Error in Perm.\n"); } 18 | 19 | /* Permutation program, heavily recursive, written by Denny Brown. */ 20 | 21 | static void Swap_el ( a,b ) 22 | int *a, *b; 23 | { 24 | int t; 25 | t = *a; *a = *b; *b = t; 26 | }; 27 | 28 | static void Initialize () 29 | { 30 | int i; 31 | for ( i = 1; i <= 7; i++ ) { 32 | permarray[i]=i-1; 33 | }; 34 | }; 35 | 36 | static void Permute (n) 37 | int n; 38 | { /* permute */ 39 | int k; 40 | pctr = pctr + 1; 41 | if ( n!=1 ) { 42 | Permute(n-1); 43 | for ( k = n-1; k >= 1; k-- ) { 44 | Swap_el(&permarray[n],&permarray[k]); 45 | Permute(n-1); 46 | Swap_el(&permarray[n],&permarray[k]); 47 | }; 48 | }; 49 | } /* permute */; 50 | 51 | void main () { /* Perm */ 52 | int i; 53 | for ( i = 1; i <= 250 ; i++ ) { 54 | pctr = 0; 55 | Initialize(); 56 | Permute(7); 57 | if ( pctr != 8660 ) do_error(); 58 | }; 59 | } /* Perm */; 60 | 61 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bbubble.c: -------------------------------------------------------------------------------- 1 | /******************** BUBBLE ********************/ 2 | #define SRTELEMENTS 500 3 | 4 | int sortlist[SRTELEMENTS+1], biggest, littlest, top; 5 | int seed; 6 | 7 | void initrand () { 8 | seed = 9219; 9 | } 10 | 11 | int rand () { 12 | seed = (seed * 1309 + 13849) & 65535; 13 | return (seed); 14 | } 15 | 16 | 17 | void binitarr () { 18 | int i, temp; 19 | 20 | initrand (); 21 | biggest = 0; littlest = 0; 22 | for (i=1; i<= SRTELEMENTS; i++) { 23 | temp = rand (); 24 | sortlist[i] = temp - (temp / 10000) * 10000 - 5000; 25 | if (sortlist[i] > biggest) { 26 | biggest = sortlist[i]; 27 | }else { 28 | if (sortlist[i] < littlest) { 29 | littlest = sortlist[i]; 30 | } 31 | } 32 | } 33 | } 34 | 35 | void main () { 36 | int i, j; 37 | 38 | binitarr (); 39 | top = SRTELEMENTS; 40 | 41 | while (top > 1) { 42 | i = 1; 43 | while (i < top) { 44 | if (sortlist[i] > sortlist[i+1]) { 45 | j = sortlist[i]; 46 | sortlist[i] = sortlist[i+1]; 47 | sortlist[i+1] = j; 48 | } 49 | i = i + 1; 50 | } 51 | top = top - 1; 52 | } 53 | 54 | } 55 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bintmm.c: -------------------------------------------------------------------------------- 1 | /******************** INTMM ******************/ 2 | 3 | #define ROWSIZE 40 4 | 5 | int ima [ROWSIZE+1][ROWSIZE+1], imb [ROWSIZE+1][ROWSIZE+1]; 6 | int imr [ROWSIZE+1][ROWSIZE+1]; 7 | int seed; 8 | 9 | void initrand () { 10 | seed = 74755; 11 | } 12 | 13 | int rand () { 14 | seed = (seed * 1309 + 13849) & 65535; 15 | return (seed); 16 | } 17 | 18 | 19 | void initmatrix (m) 20 | int m[ROWSIZE+1][ROWSIZE+1]; 21 | { 22 | int temp, i, j; 23 | 24 | for (i=1; i<=ROWSIZE; i++) { 25 | for (j=1; j<=ROWSIZE; j++) { 26 | temp = rand (); 27 | m[i][j] = temp - (temp/120)*120 - 60; 28 | } 29 | } 30 | } 31 | 32 | /* computes the inner product of a X b */ 33 | void innerproduct (results, a, b, row, column) 34 | int *results, a[ROWSIZE+1][ROWSIZE+1], b[ROWSIZE+1][ROWSIZE+1], row, column; 35 | { 36 | int i; 37 | *results = 0; 38 | for (i=1; i<= ROWSIZE; i++) { 39 | *results = *results + a[row][i] * b[i][column]; 40 | } 41 | } 42 | 43 | 44 | void main () { 45 | int i, j; 46 | 47 | initrand (); 48 | initmatrix (ima); 49 | initmatrix (imb); 50 | for (i=1; i<=ROWSIZE; i++) { 51 | for (j=1; j<=ROWSIZE; j++) { 52 | innerproduct (&imr[i][j], ima, imb, i, j); 53 | } 54 | } 55 | } 56 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xperm.c: -------------------------------------------------------------------------------- 1 | /* perm.c */ 2 | /* from Stanford benchmark suite */ 3 | /* modified for reasonable 16-bit operation */ 4 | /* Hand-optimized for best C performance by Phil Koopman */ 5 | 6 | #include 7 | 8 | /* Perm */ 9 | #define permrange 10 10 | 11 | /* Perm */ 12 | int permarray[permrange+1]; 13 | int pctr; 14 | 15 | static void do_error() { 16 | puts(" Error in Perm.\n"); } 17 | 18 | /* Permutation program, heavily recursive, written by Denny Brown. */ 19 | 20 | static void Swap_el ( a,b ) 21 | int *a, *b; 22 | { 23 | int t; 24 | t = *a; *a = *b; *b = t; 25 | }; 26 | 27 | static void Initialize () 28 | { 29 | int i; 30 | for ( i = 1; i <= 7; i++ ) { 31 | permarray[i]=i-1; 32 | }; 33 | }; 34 | 35 | static void Permute (n) 36 | int n; 37 | { /* permute */ 38 | int *k, *n_addr; 39 | pctr = pctr + 1; 40 | if ( n!=1 ) { 41 | Permute(n-1); 42 | n_addr = &permarray[n]; 43 | for ( k = n_addr-1 ; k >= &permarray[1]; k-- ) { 44 | Swap_el(n_addr,k); 45 | Permute(n-1); 46 | Swap_el(n_addr,k); 47 | }; 48 | }; 49 | } /* permute */; 50 | 51 | void main () { /* Perm */ 52 | int i; 53 | for ( i = 1; i <= 250 ; i++ ) { 54 | pctr = 0; 55 | Initialize(); 56 | Permute(7); 57 | if ( pctr != 8660 ) do_error(); 58 | }; 59 | } /* Perm */; 60 | 61 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bqueen.c: -------------------------------------------------------------------------------- 1 | /******************** QUEEN ******************/ 2 | 3 | #define FALSE 0 4 | #define TRUE 1 5 | 6 | void try (i, q, a, b, c, x) 7 | int i, *q, a[], b[], c[], x[]; 8 | { 9 | int j = 0; 10 | 11 | *q = FALSE; 12 | while ((! *q) && (j != 8)) { 13 | j += 1; 14 | *q = FALSE; 15 | 16 | if (b[j] && a[j+i] && c[j-i+7]) { 17 | x[i] = j; 18 | b[j] = FALSE; 19 | a[j+i] = FALSE; 20 | c[j-i+7] = FALSE; 21 | 22 | if (i < 8) { 23 | try (i+1, q, a, b, c, x); 24 | } 25 | else { 26 | *q = TRUE; 27 | } 28 | 29 | if (! *q) { 30 | b[j] = TRUE; 31 | a[j+i] = TRUE; 32 | c[j-i+7] = TRUE; 33 | } 34 | } 35 | } 36 | } 37 | 38 | void doit () { 39 | int i, q; 40 | int a[9], b[17], c[15], x[9]; 41 | 42 | i = 0 - 7; 43 | while (i <= 16) { 44 | if ((i >= 1) && (i <= 8)) { 45 | a[i] = TRUE; 46 | } 47 | if (i >= 2) { 48 | b[i] = TRUE; 49 | } 50 | if (i <= 7) { 51 | c[i+7] = TRUE; 52 | } 53 | i += 1; 54 | } 55 | try (1, &q, b, a, c, x); 56 | 57 | } 58 | 59 | void main () { 60 | int i; 61 | 62 | for (i=1; i <= 50; i++) { 63 | doit (); 64 | } 65 | 66 | } 67 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bquick.c: -------------------------------------------------------------------------------- 1 | /******************** QUICK ********************/ 2 | 3 | #define SORTELEMENTS 5000 4 | 5 | int sortlist[SORTELEMENTS+1], biggest, littlest, top; 6 | int seed; 7 | 8 | void initrand () { 9 | seed = 9219; 10 | } 11 | 12 | int rand () { 13 | seed = (seed * 1309 + 13849) & 65535; 14 | return (seed); 15 | } 16 | 17 | 18 | void initarr () 19 | { 20 | int i, temp; 21 | 22 | initrand (); 23 | biggest = 0; 24 | littlest = 0; 25 | for (i=1; i <= SORTELEMENTS; i++) { 26 | temp = rand (); 27 | sortlist[i] = temp - (temp / 10000) * 10000 - 5000; 28 | if (sortlist[i] > biggest) { 29 | biggest = sortlist[i]; 30 | } else { 31 | if (sortlist[i] < littlest) { 32 | littlest = sortlist[i]; 33 | } 34 | } 35 | } 36 | } 37 | 38 | void quicksort (a, l, r) 39 | int a[], l, r; 40 | { 41 | int i, j, x, w; 42 | 43 | i = l; j = r; 44 | x = a[(l+r) / 2]; 45 | do { 46 | while (a[i] < x) { 47 | i = i + 1; 48 | } 49 | while (x < a[j]) { 50 | j = j - 1; 51 | } 52 | if (i <= j) { 53 | w = a[i]; 54 | a[i] = a[j]; 55 | a[j] = w; 56 | i = i + 1; j = j - 1; 57 | } 58 | } while (i <= j); 59 | if (l < j) { 60 | quicksort (a, l, j); 61 | } 62 | if (i < r) { 63 | quicksort (a, i, r); 64 | } 65 | } 66 | 67 | void main () 68 | { 69 | initarr (); 70 | quicksort (sortlist, 1, SORTELEMENTS); 71 | } 72 | -------------------------------------------------------------------------------- /RTX2000/TESTS/sieve.a.4th: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Siee Prime Number Program in C from Byte January 1983 */ 2 | \ CESYS output modified for AppForth 3 | 4 | EMPTY 5 | : XY " DOS XY sieve.a.4th " EVALUATE ; 6 | 7 | load gnutool.4th 8 | 9 | VARIABLE flags 8192 CELL- ALLOT 10 | 11 | DECIMAL 12 | 13 | : do_error ." Error in Sieve." CR ; 14 | 15 | : main ( FUNC ) ( 3 top> empty ) 16 | 64 REG-ADDR $FFC0 AND UBR! 17 | 18 | $1 2 u! 19 | [ 41 ] LABEL 20 | $15e 2 u@ 21 | dup . 22 | > 23 | 1 and 24 | [ 42 ] branchz 25 | 26 | $0 1 u! 27 | $0 3 u! 28 | 29 | [ 44 ] LABEL 30 | 3 u@ $1ffe <= 31 | 1 and 32 | [ 45 ] branchz 33 | $1 flags 3 u@ + c! 34 | 35 | [ 46 ] LABEL 36 | 3 u@ $1 + 3 u! 37 | [ 44 ] branch 38 | 39 | [ 45 ] LABEL 40 | $0 3 u! 41 | 42 | [ 47 ] LABEL 43 | 44 | 3 u@ $1ffe <= 45 | 1 and 46 | [ 48 ] branchz 47 | 48 | flags 3 u@ + c@ c>i 49 | [ 50 ] branchz 50 | 51 | 3 u@ 3 u@ + $3 + 0 u! 52 | 3 u@ 0 u@ + 4 u! 53 | 54 | [ 51 ] LABEL 55 | 4 u@ $1ffe <= 56 | 1 and 57 | [ 52 ] branchz 58 | 59 | $0 flags 4 u@ + c! 60 | 61 | [ 53 ] LABEL 62 | 4 u@ 0 u@ + 4 u! 63 | [ 51 ] branch 64 | 65 | [ 52 ] LABEL 66 | 1 u@ $1 + 1 u! 67 | 68 | [ 50 ] LABEL 69 | [ 49 ] LABEL 70 | 3 u@ $1 + 3 u! 71 | [ 47 ] branch 72 | 73 | [ 48 ] LABEL 74 | [ 43 ] LABEL 75 | 2 u@ $1 + 2 u! 76 | [ 41 ] branch 77 | 78 | [ 42 ] LABEL 79 | 1 u@ 80 | $76b 81 | <> 82 | 1 and 83 | [ 54 ] branchz 84 | 64 FP+! 85 | do_error 86 | -64 FP+! 87 | [ 54 ] LABEL 88 | ; 89 | 90 | .( max ) $15e . cr 91 | -------------------------------------------------------------------------------- /RTX2000/TESTS/example.4th: -------------------------------------------------------------------------------- 1 | 2 | \ RTX 2000 Forth code for software FIFO interrupt service routine 3 | 4 | : xy " dos xy example.4" evaluate ; 5 | 6 | \ Define U< to be a macro 7 | : U< " - cU2/ not 0< " evaluate ; immediate 8 | 9 | CREATE FIFO_START 1000 ALLOT 10 | HERE 4 - CONSTANT FIFO_END 11 | 12 | VARIABLE FIFO_HEAD FIFO_START FIFO_HEAD ! 13 | VARIABLE FIFO_TAIL FIFO_START FIFO_TAIL ! 14 | 15 | : Int_Service \ 2 clocks for interrupt 16 | ( \ ) 12 G@ ( -- input ) \ 1 clock 17 | FIFO_HEAD @ ( -- input ptr ) \ 4 clocks 18 | 2 !+ ( -- ptr' ) \ 2 clocks 19 | FIFO_END OVER U< ( -- ptr' wrap? ) \ 5 clocks 20 | IF \ 1 clock 21 | DROP FIFO_START \ 3 clocks 22 | THEN 23 | DUP FIFO_TAIL @ = ( -- ptr' no_overrun? ) \ 8 clocks 24 | IF \ 1 clock 25 | ABORT" FIFO overrun" 26 | THEN 27 | FIFO_HEAD ! EXIT ( -- ) \ 4 clocks 28 | ; 29 | 30 | \ total time: 31 clocks 31 | 32 | 33 | variable test_val 0 test_val ! 34 | : test 35 | test_val @ DUP . int_service 36 | ." FIFO_HEAD = " FIFO_HEAD @ U. 37 | ." FIFO_START = " FIFO_START U. 38 | ." FIFO_END = " FIFO_END U. 39 | 1 test_val +! ; 40 | 41 | : tests for test cr next ; 42 | 43 | 44 | 45 | \ Wait loop for I/O status bit 46 | \ Waits for bit 3 of I/O port 12 to be set 47 | 48 | : WAIT 49 | 8 ( -- mask value ) 50 | BEGIN 51 | 12 G@ 52 | OVER AND 53 | UNTIL 54 | DROP ; 55 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bubble.c: -------------------------------------------------------------------------------- 1 | 2 | /* bubble.c */ 3 | /* from Stanford benchmark suite */ 4 | /* modified for reasonable 16-bit operation */ 5 | 6 | #include 7 | /* #include "stdlib.h" */ 8 | 9 | /* Bubble, Quick */ 10 | #define sortelements 5000 11 | #define srtelements 500 12 | 13 | #define false 0 14 | #define true 1 15 | 16 | /* Bubble, Quick */ 17 | int sortlist[sortelements+1], 18 | biggest, littlest, top; 19 | 20 | static void do_error() 21 | { printf ( "Error3 in Bubble.\n"); } 22 | 23 | 24 | int seed ; 25 | 26 | static void Initrand () 27 | { 28 | seed = 9219; 29 | }; 30 | 31 | static int Rand () 32 | { 33 | seed = (seed * 1309 + 13849) ; 34 | return( seed ); 35 | }; 36 | 37 | /* Sorts an array using bubblesort */ 38 | 39 | static void bInitarr() 40 | { 41 | int i, temp; 42 | Initrand(); 43 | biggest = 0; littlest = 0; 44 | for ( i = 1; i <= srtelements; i++ ) 45 | { 46 | temp = Rand(); 47 | sortlist[i] = temp - 32767 ; 48 | if ( sortlist[i] > biggest ) biggest = sortlist[i]; 49 | else if ( sortlist[i] < littlest ) littlest = sortlist[i]; 50 | }; 51 | }; 52 | 53 | void main() 54 | { 55 | int i, j, iter; 56 | 57 | for (iter = 1 ; iter < 30 ; iter++ ) 58 | { 59 | bInitarr(); 60 | top=srtelements; 61 | while ( top>1 ) { 62 | 63 | i=1; 64 | while ( i sortlist[i+1] ) { 67 | j = sortlist[i]; 68 | sortlist[i] = sortlist[i+1]; 69 | sortlist[i+1] = j; 70 | }; 71 | i=i+1; 72 | }; 73 | 74 | top=top-1; 75 | }; 76 | if ( (sortlist[1] != littlest) || (sortlist[srtelements] != biggest) ) 77 | do_error(); 78 | } 79 | }; 80 | -------------------------------------------------------------------------------- /RTX2000/TESTS/sieve.e.4th: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Sieve Prime Number Program in C from Byte January 1983 */ 2 | \ Improved source code assembler based on GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY sieve.e.4th" EVALUATE ; 6 | 7 | load gnutool.4th 8 | 9 | VARIABLE myflags 8192 CELL- ALLOT 10 | : flags " [ myflags ] literal " evaluate ; immediate 11 | 12 | DECIMAL 13 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 14 | 15 | : do_error 16 | ." Error in Sieve." CR 17 | ; 18 | 19 | 64 FRAME_SIZE ! 20 | : main 21 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 22 | 23 | 1 ( LIT) ( 6 top> empty ) 24 | [ 0020 ADD_INDEX ] >R ( 137 top> #65 ) 25 | 26 | ( TYPE 1 LOOP BEGIN) ( 7 top> empty ) 27 | 28 | BEGIN 29 | 0 2 U! \ Count is in user # 2 30 | 31 | 1 flags ( -- 1 flags ) 32 | 33 | 8190 FOR ( -- 1 addr ) 34 | [ $F8C1 , ] ( DDUP_C!_1+ ) ( -- 1 addr' ) 35 | NEXT ( -- 1 addr' ) 36 | DROP DROP ( -- ) 37 | 38 | 0 >R 39 | 40 | BEGIN 41 | flags I + C@ 42 | IF I 2* 3 + ( -- j ) 43 | DUP I + ( -- j k ) 44 | DUP 8191 u< 45 | IF ( -- j k ) 46 | BEGIN 47 | 0 OVER flags + C! ( -- j k ) 48 | OVER_+ ( -- j k ) 49 | DUP 8190 U> ( -- j k flag ) 50 | UNTIL 51 | THEN ( -- j k ) 52 | DROP DROP 53 | 1 2 U@ + 2 U! ( increment count ) 54 | THEN 55 | R> 1 + DUP_>R 56 | 8190 U> 57 | UNTIL 58 | R>DROP 59 | 60 | 2 U@ 1899 - 61 | IF 62 | do_error 63 | THEN 64 | 65 | R> 1 + DUP_>R 66 | 349 U> 67 | UNTIL 68 | R>DROP 69 | ; 70 | 71 | .( max 349) cr 72 | -------------------------------------------------------------------------------- /RTX2000/TESTS/matmul.c: -------------------------------------------------------------------------------- 1 | 2 | /* matmul.c */ 3 | /* from Stanford benchmark suite */ 4 | /* modified for reasonable 16-bit operation */ 5 | 6 | #include 7 | /* #include */ 8 | 9 | #define true -1 10 | #define false 0 11 | 12 | /* Intmm, Mm */ 13 | #define ROWSIZE 40 14 | 15 | /* Intmm, Mm */ 16 | int ima[ROWSIZE+1][ROWSIZE+1], 17 | imb[ROWSIZE+1][ROWSIZE+1], 18 | imr[ROWSIZE+1][ROWSIZE+1]; 19 | 20 | int seed ; 21 | 22 | static void Initrand () 23 | { 24 | seed = 9219; 25 | }; 26 | 27 | static int Rand () 28 | { 29 | seed = (seed * 1309 + 13849) ; 30 | return( seed ); 31 | }; 32 | 33 | /* Multiplies two integer matrices. */ 34 | 35 | static void Initmatrix ( m ) int m[ROWSIZE+1][ROWSIZE+1]; 36 | { 37 | int temp, i, j; 38 | for ( i = 1; i <= ROWSIZE; i++ ) 39 | for ( j = 1; j <= ROWSIZE; j++ ) 40 | { temp = Rand(); 41 | m[i][j] = temp - (temp/120)*120 - 60; 42 | }; 43 | }; 44 | 45 | static void Innerproduct( result,a,b, row,column) 46 | int *result, 47 | a[ROWSIZE+1][ROWSIZE+1], 48 | b[ROWSIZE+1][ROWSIZE+1], 49 | row,column; 50 | /* computes the inner product of A[row,*] and B[*,column] */ 51 | { 52 | int i; 53 | *result = 0; 54 | for(i = 1; i <= ROWSIZE; i++ )*result = *result+a[row][i]*b[i][column]; 55 | }; 56 | 57 | void main () 58 | { 59 | int i, j, iter; 60 | for (iter = 1 ; iter < 25; iter++ ) 61 | { 62 | Initrand(); 63 | Initmatrix (ima); 64 | Initmatrix (imb); 65 | for ( i = 1; i <= ROWSIZE; i++ ) 66 | for ( j = 1; j <= ROWSIZE; j++ ) Innerproduct(&imr[i][j],ima,imb,i,j); 67 | } 68 | }; 69 | 70 | -------------------------------------------------------------------------------- /SIM2000/readme.1st: -------------------------------------------------------------------------------- 1 | 2 | 10/24/97 3 | 4 | I pulled this RTX 2000 simulator from an ancient floppy disk. 5 | It was written for my personal use while I was at Harris, and 6 | is not a commercial product by any stretch of the imagination. 7 | I figure that Harris is long past caring about this, so I'm 8 | giving it to people who need help using the RTX 2000 as an 9 | after-the-fact technical support exercise. However, this is 10 | still copyrighted by Harris Semiconductor and should be treated 11 | accordingly. 12 | 13 | To run, just execute sim.bat, which will execute the simulator 14 | while loading an image of Rick VanNorman's AppForth. What you 15 | get is an RTX 2000 simulation running a Forth compiler. The 16 | source code is all there for both the simulator and AppForth 17 | (and probably some spare code that isn't used). I recompiled 18 | it with Borland Turbo C++ 4.0 and it worked, so it should be 19 | complete (it got a heap of compiler warnings, but it did 20 | compile -- I suppose I've learned a lot more about C programming 21 | since I wrote the original code :-) ) 22 | Beyond that, you're on your own. 23 | 24 | Notes: 25 | 26 | - This is hacked-together C code. I think it is complete except 27 | for single-step functions not working (I never got to them). 28 | 29 | - Harris Semiconductor does not officially endorse the release of 30 | this simulator -- so don't hassle them if there is a problem 31 | with it (you use it at your own risk and expense). Similarly, 32 | I offer no warrantees express or implied. 33 | 34 | - If you have questions about the code -- you're on your own. 35 | I don't have time to support this, even if I *did* remember 36 | what I did all those years ago. 37 | 38 | Cheers, 39 | 40 | Phil Koopman 41 | koopman@cmu.edu 42 | -------------------------------------------------------------------------------- /RTX2000/TESTS/sieve.c.4th: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Siee Prime Number Program in C from Byte January 1983 */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY sieve.c.4th " EVALUATE ; 6 | 7 | load gnutool.4th 8 | 9 | VARIABLE flags 8192 CELL- ALLOT 10 | 11 | DECIMAL 12 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 13 | 14 | : do_error 15 | ." Error in Sieve." CR 16 | ; 17 | 18 | : main 19 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 20 | 21 | 0 22 | 23 | 1 24 | [ 0019 ADD_INDEX ] >R 25 | 26 | [ 0019 ] LABEL 27 | 28 | DROP 0 29 | 30 | 0 31 | [ 009 ADD_INDEX ] >R 32 | 33 | [ 009 ] LABEL 34 | 35 | 1 36 | flags 37 | [ 009 ] INDEX + 38 | C! 39 | R> 40 | 1 41 | + 42 | DUP_>R 43 | 8190 44 | U> 45 | [ 009 ] BRANCHZ 46 | [ 009 DROP_INDEX ] R>DROP 47 | [ 0023 ] LABEL 48 | 49 | 0 50 | [ 0018 ADD_INDEX ] >R 51 | 52 | [ 0018 ] LABEL 53 | 54 | flags 55 | [ 0018 ] INDEX + 56 | C@ 57 | [ 0012 ] BRANCHZ 58 | 59 | [ 0018 ] INDEX 60 | 2* 61 | 3 62 | + 63 | [ 0018 ] INDEX 64 | OVER_+ 65 | 66 | 8190 67 | 1_PICK > 68 | [ 0021 ] BRANCHZ 69 | 70 | [ 0017 ] LABEL 71 | 72 | 0 73 | flags 74 | 2_PICK + 75 | C! 76 | 77 | OVER_+ 78 | 0_PICK 79 | 8190 80 | > 81 | [ 0017 ] BRANCHZ 82 | 83 | [ 0021 ] LABEL 84 | 85 | DROP DROP 86 | 1 + 87 | 88 | [ 0012 ] LABEL 89 | R> 90 | 1 91 | + 92 | DUP_>R 93 | 8190 94 | U> 95 | [ 0018 ] BRANCHZ 96 | [ 0018 DROP_INDEX ] R>DROP 97 | 98 | [ 0022 ] LABEL 99 | R> 100 | 1 101 | + 102 | DUP_>R 103 | dup . 349 104 | U> 105 | [ 0019 ] BRANCHZ 106 | [ 0019 DROP_INDEX ] R>DROP 107 | 108 | [ 0024 ] LABEL 109 | 110 | 1899 111 | - 112 | [ 0020 ] BRANCHZ 113 | do_error 114 | EXIT [ 0020 ] LABEL 115 | ; 116 | 117 | .( max 349) cr 118 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xbubble.c: -------------------------------------------------------------------------------- 1 | /* bubble.c */ 2 | /* from Stanford benchmark suite */ 3 | /* modified for reasonable 16-bit operation */ 4 | /* Hand-optimized for best C performance by Phil Koopman */ 5 | 6 | #include 7 | 8 | /* Bubble, Quick */ 9 | #define sortelements 5000 10 | #define srtelements 500 11 | 12 | #define false 0 13 | #define true 1 14 | 15 | /* Bubble, Quick */ 16 | int sortlist[sortelements+1], 17 | biggest, littlest; 18 | 19 | static void do_error() 20 | { puts ( "Error3 in Bubble.\n"); } 21 | 22 | int seed ; 23 | 24 | static void Initrand () 25 | { 26 | seed = 9219; 27 | }; 28 | 29 | static int Rand () 30 | { 31 | seed = (seed * 1309 + 13849) ; 32 | return( seed ); 33 | }; 34 | 35 | /* Sorts an array using bubblesort */ 36 | 37 | static void bInitarr() 38 | { 39 | int temp, list; 40 | int *i; 41 | Initrand(); 42 | biggest = 0; littlest = 0; 43 | for ( i = &sortlist[1]; i <= &sortlist[srtelements]; i++ ) 44 | { 45 | temp = Rand(); 46 | list = temp - 32767 ; 47 | *i = list; 48 | if ( list > biggest ) biggest = list; 49 | else if ( list < littlest ) littlest = list; 50 | }; 51 | }; 52 | 53 | int main() 54 | { 55 | int j, iter; 56 | int *i, *top; 57 | 58 | for (iter = 1 ; iter < 30 ; iter++ ) 59 | { 60 | /* printf("\niter = %d ",iter); */ 61 | bInitarr(); 62 | top = &sortlist[srtelements]; 63 | while ( top > &sortlist[1] ) { 64 | 65 | i=&sortlist[1]; 66 | while ( i < top ) { 67 | 68 | if ( *i > *(i+1) ) { 69 | j = *i; 70 | *i = *(i+1); 71 | *(i+1) = j; 72 | }; 73 | i=i+1; 74 | }; 75 | 76 | top=top-1; 77 | }; 78 | if ( (sortlist[1] != littlest) || (sortlist[srtelements] != biggest) ) 79 | do_error(); 80 | } 81 | return(0); 82 | }; 83 | -------------------------------------------------------------------------------- /RTX2000/TESTS/quick.c: -------------------------------------------------------------------------------- 1 | 2 | /* quick.c */ 3 | /* from Stanford benchmark suite */ 4 | /* modified for reasonable 16-bit operation */ 5 | 6 | #include 7 | /* #include */ 8 | 9 | /* Bubble, Quick */ 10 | #define sortelements 5000 11 | 12 | /* Bubble, Quick */ 13 | int sortlist[sortelements+1], 14 | biggest, littlest, top; 15 | 16 | static void do_error() 17 | { printf ( " Error in Quick.\n"); } 18 | 19 | int seed ; 20 | 21 | static void Initrand () 22 | { 23 | seed = 9219; 24 | }; 25 | 26 | static int Rand () 27 | { 28 | seed = (seed * 1309 + 13849) ; 29 | return( seed ); 30 | }; 31 | 32 | /* Sorts an array using quicksort */ 33 | 34 | static void Initarr() 35 | { 36 | int i, temp; 37 | Initrand(); 38 | biggest = 0; littlest = 0; 39 | for ( i = 1; i <= sortelements; i++ ) 40 | { 41 | temp = Rand(); 42 | sortlist[i] = temp - 32668 ; 43 | if ( sortlist[i] > biggest ) biggest = sortlist[i]; 44 | else if ( sortlist[i] < littlest ) littlest = sortlist[i]; 45 | }; 46 | }; 47 | 48 | static void Quicksort( a,l,r) int a[], l, r; 49 | /* quicksort the array A from start to finish */ 50 | { 51 | int i,j,x,w; 52 | 53 | i=l; j=r; 54 | x=a[(l+r) / 2]; 55 | do { 56 | while ( a[i]R 23 | 24 | [ 0019 ] LABEL 25 | 26 | 0 27 | 2 U! 28 | 29 | 0 30 | [ 009 ADD_INDEX ] >R 31 | 32 | [ 009 ] LABEL 33 | 34 | 1 35 | flags 36 | [ 009 ] INDEX + 37 | C! 38 | R> 39 | 1 40 | + 41 | DUP_>R 42 | 8190 43 | U> 44 | [ 009 ] BRANCHZ 45 | [ 009 DROP_INDEX ] R>DROP 46 | [ 0023 ] LABEL 47 | 48 | 0 49 | [ 0018 ADD_INDEX ] >R 50 | 51 | [ 0018 ] LABEL 52 | 53 | flags 54 | [ 0018 ] INDEX + 55 | C@ 56 | [ 0012 ] BRANCHZ 57 | 58 | [ 0018 ] INDEX 59 | 2* 60 | 3 61 | + 62 | [ 0018 ] INDEX 63 | OVER_+ 64 | [ 3 ] DUP_U! 65 | 66 | SWAP 67 | 4 U! 68 | 8190 69 | <= 70 | [ 0021 ] BRANCHZ 71 | 72 | [ 0017 ] LABEL 73 | 74 | 0 75 | flags 76 | 3 U@ + 77 | C! 78 | 3 U@ 79 | 4 U@ + 80 | [ 3 ] DUP_U! 81 | 8190 82 | > 83 | [ 0017 ] BRANCHZ 84 | 85 | [ 0021 ] LABEL 86 | 87 | 1 88 | 2 U@ + 2 U! 89 | 90 | [ 0012 ] LABEL 91 | R> 92 | 1 93 | + 94 | DUP_>R 95 | 8190 96 | U> 97 | [ 0018 ] BRANCHZ 98 | [ 0018 DROP_INDEX ] R>DROP 99 | 100 | [ 0022 ] LABEL 101 | R> 102 | 1 103 | + 104 | DUP_>R 105 | dup . 106 | 349 107 | U> 108 | [ 0019 ] BRANCHZ 109 | [ 0019 DROP_INDEX ] R>DROP 110 | 111 | [ 0024 ] LABEL 112 | 113 | 2 U@ 114 | 1899 115 | - 116 | [ 0020 ] BRANCHZ 117 | -64 FP+! 118 | do_error 119 | 64 FP+! 120 | EXIT [ 0020 ] LABEL 121 | ; 122 | 123 | .( max 349) cr 124 | -------------------------------------------------------------------------------- /RTX2000/TESTS/perm.e.4th: -------------------------------------------------------------------------------- 1 | \ /* perm.c */ 2 | \ Improved source code assembler based on GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY perm.e.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE permarray 24 CELL- ALLOT 11 | VARIABLE pctr 4 CELL- ALLOT 12 | 13 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 14 | 15 | : do_error 16 | ." Error in Perm." cr 17 | ; 18 | 19 | : Swap_el ( ^a ^b -- ) \ swap a & b 20 | ( DUP @ SWAP ) [ $E140 , ] ( -- ^a b ^b ) 21 | >R ( -- ^a b ) 22 | OVER @ ( -- ^a b a ) 23 | R> ( -- ^a b a ^b ) 24 | ! ( -- ^a b ) 25 | SWAP ! ; 26 | 27 | : Initialize ( -- ) 28 | 6 FOR 29 | I 30 | I 1 + 2* [ permarray ] SYMBOL_+ ! 31 | NEXT 32 | ; 33 | 34 | 64 FRAME_SIZE ! 35 | : Permute ( n -- ) 36 | 1 pctr +! 37 | [ 2 ] DUP_U! 1 - 38 | IF 39 | 2 U@ 1 - 40 | -64 FP+! RECURSE 64 FP+! 41 | 2 U@ 2* [ permarray ] SYMBOL_+ 42 | [ 3 ] DUP_U! 2 - 43 | [ permarray 2 + ] LITERAL 44 | OVER 45 | U> 46 | IF ( -- k ) 47 | drop exit 48 | ELSE ( -- k ) 49 | BEGIN ( -- k ) 50 | [ 4 ] DUP_u! 3 U@ Swap_el ( -- k ) 51 | 2 U@ 1 - 52 | -64 FP+! RECURSE 64 FP+! 53 | 4 U@ ( -- k ) 54 | 3 U@ OVER Swap_el ( -- k ) 55 | 2 - DUP [ permarray 2 + ] LITERAL U< 56 | UNTIL ( -- k ) 57 | DROP EXIT 58 | THEN 59 | THEN 60 | ; 61 | 62 | 64 FRAME_SIZE ! 63 | : main 64 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 65 | 1 >R 66 | BEGIN 67 | 0 pctr ! 68 | Initialize 69 | 7 -64 FP+! Permute 64 FP+! 70 | pctr @ 8660 - 71 | IF do_error THEN 72 | R> 1 + DUP_>R 73 | 250 U> 74 | UNTIL 75 | R>DROP 76 | ; 77 | 78 | .( max 250) cr 79 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xquick.c: -------------------------------------------------------------------------------- 1 | /* quick.c */ 2 | /* from Stanford benchmark suite */ 3 | /* modified for reasonable 16-bit operation */ 4 | /* Hand-optimized for best C performance by Phil Koopman */ 5 | 6 | #include 7 | 8 | /* Bubble, Quick */ 9 | #define sortelements 5000 10 | 11 | /* Bubble, Quick */ 12 | int sortlist[sortelements+1], 13 | biggest, littlest, top; 14 | 15 | static void do_error() 16 | { puts ( " Error in Quick.\n"); } 17 | 18 | int seed ; 19 | 20 | static void Initrand () 21 | { 22 | seed = 9219; 23 | }; 24 | 25 | static int Rand () 26 | { 27 | seed = (seed * 1309 + 13849) ; 28 | return( seed ); 29 | }; 30 | 31 | /* Sorts an array using quicksort */ 32 | 33 | static void Initarr() 34 | { 35 | int *i, temp; 36 | Initrand(); 37 | biggest = 0; littlest = 0; 38 | for ( i = &sortlist[1]; i <= &sortlist[sortelements]; i++ ) 39 | { 40 | temp = Rand(); 41 | temp = temp - 32668 ; 42 | *i = temp; 43 | if ( temp > biggest ) biggest = temp; 44 | else if ( temp < littlest ) littlest = temp; 45 | }; 46 | }; 47 | 48 | static void Quicksort( a,l,r) int a[], *l, *r; 49 | /* quicksort the array A from start to finish */ 50 | { 51 | int *i,*j,x,w; 52 | 53 | i=l; j=r; 54 | x= *(int *)( ( ((int)l >>1) + ((int)r >>1) ) & 0xFFFE ) ; 55 | do { 56 | while ( *i empty ) 20 | ( #4 dummy reload ) ( 4 top> empty ) 21 | DUP 2 U! ( 9 top> #64 ) 22 | 2 ( LIT) ( 9 top> #64x ) 23 | <= ( 10 top> #66x #64x ) 24 | [ 003 ] BRANCHZ ( 10 top> #0x ) 25 | 1 ( LIT) ( 13 top> empty ) 26 | DUP 3 U! ( 17 top> #2 ) 27 | [ 001 ] BRANCH ( 15 top> #2 ) 28 | [ 003 ] LABEL ( 17 top> empty ) 29 | ( -16 SP+! ) ( 20 top> empty ) 30 | 2 U@ ( 21 top> empty ) 31 | 1 ( LIT) ( 21 top> #64x ) 32 | - ( 21 top> #0x #64x ) 33 | ( #4 CALL ARG ) ( 24 top> #4 ) 34 | -64 FP+! ( Link) ( 32 top> empty ) 35 | recurse \ fib ( CALL) ( 24 top> empty ) 36 | 64 FP+! ( Link) ( 32 top> empty ) 37 | 5 U! ( 32 top> #68 ) 38 | 2 U@ ( 29 top> #68 ) 39 | 2 ( LIT) ( 29 top> #64x #68 ) 40 | - ( 29 top> #0x #64x #68 ) 41 | -64 FP+! ( Link) ( 32 top> empty ) 42 | recurse \ fib ( CALL) ( 32 top> empty ) 43 | 64 FP+! ( Unlink) ( 32 top> #2x ) 44 | 5 U@ + ( 37 top> #70d ) 45 | ( 16 SP+! ) ( 39 top> #2 ) 46 | DUP 3 U! ( 45 top> #2 ) 47 | [ 001 ] LABEL ( 45 top> empty ) 48 | ; ( END ) ( 45 top> empty ) 49 | 50 | 51 | : 3_OVER_SWAP- $B443 , ; IMMEDIATE 52 | : 1_OVER_SWAP- $B441 , ; IMMEDIATE 53 | : DROP_1_EXIT $BEE1 , ; IMMEDIATE 54 | 55 | \ Pure Forth version of fib 56 | 57 | : fib ( n -- n ) 58 | 3_OVER_SWAP- 0< 59 | IF DROP_1_EXIT THEN 60 | 1_OVER_SWAP- RECURSE 61 | SWAP 2 - RECURSE 62 | + ; 63 | 64 | : FIBS FOR 30 FIB DROP NEXT ; 65 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/fib.hnd: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | EMPTY 6 | : XY " DOS XY fib.RTX" EVALUATE ; 7 | 8 | DECIMAL 9 | load gnutool.4th 10 | 11 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 12 | 13 | \ gcc_compiled.: 14 | 15 | 16 | ( RTX 2000 code generation) 17 | 18 | 19 | : cfib ( FUNC ) ( 3 top> empty ) 20 | ( #4 dummy reload ) ( 4 top> empty ) 21 | DUP 2 U! ( 9 top> #64 ) 22 | 2 ( LIT) ( 9 top> #64x ) 23 | <= ( 10 top> #66x #64x ) 24 | [ 003 ] BRANCHZ ( 10 top> #0x ) 25 | 1 ( LIT) ( 13 top> empty ) 26 | DUP 3 U! ( 17 top> #2 ) 27 | [ 001 ] BRANCH ( 15 top> #2 ) 28 | [ 003 ] LABEL ( 17 top> empty ) 29 | ( -16 SP+! ) ( 20 top> empty ) 30 | 2 U@ ( 21 top> empty ) 31 | 1 ( LIT) ( 21 top> #64x ) 32 | - ( 21 top> #0x #64x ) 33 | ( #4 CALL ARG ) ( 24 top> #4 ) 34 | -64 FP+! ( Link) ( 32 top> empty ) 35 | recurse \ fib ( CALL) ( 24 top> empty ) 36 | 64 FP+! ( Link) ( 32 top> empty ) 37 | 5 U! ( 32 top> #68 ) 38 | 2 U@ ( 29 top> #68 ) 39 | 2 ( LIT) ( 29 top> #64x #68 ) 40 | - ( 29 top> #0x #64x #68 ) 41 | -64 FP+! ( Link) ( 32 top> empty ) 42 | recurse \ fib ( CALL) ( 32 top> empty ) 43 | 64 FP+! ( Unlink) ( 32 top> #2x ) 44 | 5 U@ + ( 37 top> #70d ) 45 | ( 16 SP+! ) ( 39 top> #2 ) 46 | DUP 3 U! ( 45 top> #2 ) 47 | [ 001 ] LABEL ( 45 top> empty ) 48 | ; ( END ) ( 45 top> empty ) 49 | 50 | 51 | : 3_OVER_SWAP- $B443 , ; IMMEDIATE 52 | : 1_OVER_SWAP- $B441 , ; IMMEDIATE 53 | : DROP_1_EXIT $BEE1 , ; IMMEDIATE 54 | 55 | \ Pure Forth version of fib 56 | 57 | : fib ( n -- n ) 58 | 3_OVER_SWAP- 0< 59 | IF DROP_1_EXIT THEN 60 | 1_OVER_SWAP- RECURSE 61 | SWAP 2 - RECURSE 62 | + ; 63 | 64 | : FIBS FOR 30 FIB DROP NEXT ; 65 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/fib.rtx: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | EMPTY 6 | : XY " DOS XY fib.RTX" EVALUATE ; 7 | 8 | DECIMAL 9 | load gnutool.4th 10 | 11 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 12 | 13 | \ gcc_compiled.: 14 | 15 | 16 | ( RTX 2000 code generation) 17 | 18 | 19 | : cfib ( FUNC ) ( 3 top> empty ) 20 | ( #4 dummy reload ) ( 4 top> empty ) 21 | DUP 2 U! ( 9 top> #64 ) 22 | 2 ( LIT) ( 9 top> #64x ) 23 | <= ( 10 top> #66x #64x ) 24 | [ 003 ] BRANCHZ ( 10 top> #0x ) 25 | 1 ( LIT) ( 13 top> empty ) 26 | DUP 3 U! ( 17 top> #2 ) 27 | [ 001 ] BRANCH ( 15 top> #2 ) 28 | [ 003 ] LABEL ( 17 top> empty ) 29 | ( -16 SP+! ) ( 20 top> empty ) 30 | 2 U@ ( 21 top> empty ) 31 | 1 ( LIT) ( 21 top> #64x ) 32 | - ( 21 top> #0x #64x ) 33 | ( #4 CALL ARG ) ( 24 top> #4 ) 34 | -64 FP+! ( Link) ( 32 top> empty ) 35 | recurse \ fib ( CALL) ( 24 top> empty ) 36 | 64 FP+! ( Link) ( 32 top> empty ) 37 | 5 U! ( 32 top> #68 ) 38 | 2 U@ ( 29 top> #68 ) 39 | 2 ( LIT) ( 29 top> #64x #68 ) 40 | - ( 29 top> #0x #64x #68 ) 41 | -64 FP+! ( Link) ( 32 top> empty ) 42 | recurse \ fib ( CALL) ( 32 top> empty ) 43 | 64 FP+! ( Unlink) ( 32 top> #2x ) 44 | 5 U@ + ( 37 top> #70d ) 45 | ( 16 SP+! ) ( 39 top> #2 ) 46 | DUP 3 U! ( 45 top> #2 ) 47 | [ 001 ] LABEL ( 45 top> empty ) 48 | ; ( END ) ( 45 top> empty ) 49 | 50 | 51 | : 3_OVER_SWAP- $B443 , ; IMMEDIATE 52 | : 1_OVER_SWAP- $B441 , ; IMMEDIATE 53 | : DROP_1_EXIT $BEE1 , ; IMMEDIATE 54 | 55 | \ Pure Forth version of fib 56 | 57 | : fib ( n -- n ) 58 | 3_OVER_SWAP- 0< 59 | IF DROP_1_EXIT THEN 60 | 1_OVER_SWAP- RECURSE 61 | SWAP 2 - RECURSE 62 | + ; 63 | 64 | : FIBS FOR 30 FIB DROP NEXT ; 65 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/sieve.ces: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Siee Prime Number Program in C from Byte January 1983 */ 2 | \ CESYS output modified for AppForth 3 | 4 | EMPTY 5 | : XY " DOS XY sieve.ces " EVALUATE ; 6 | 7 | load gnutool.4th 8 | 9 | \ char flags [size+1]; 10 | VARIABLE flags 8192 CELL- ALLOT 11 | \ #define true 1 12 | \ #define false 0 13 | \ #define size 8190 14 | 15 | DECIMAL 16 | 17 | \ static void do_error() { 18 | : do_error ( FUNC ) ( 3 top> empty ) 19 | \ printf(" Error in Sieve.\n"); } 20 | ." Error in Sieve." CR 21 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 22 | 23 | 24 | \ void main() 25 | : main ( FUNC ) ( 3 top> empty ) 26 | \ { 27 | \ int prime, count, iter; 28 | \ register i,k; 29 | 64 REG-ADDR $FFC0 AND UBR! 30 | 31 | $1 2 u! 32 | [ 41 ] LABEL 33 | $15e 2 u@ 34 | > 35 | 1 and 36 | [ 42 ] branchz 37 | 38 | $0 1 u! 39 | $0 3 u! 40 | 41 | [ 44 ] LABEL 42 | 3 u@ $1ffe <= 43 | 1 and 44 | [ 45 ] branchz 45 | $1 flags 3 u@ + c! 46 | 47 | [ 46 ] LABEL 48 | 3 u@ $1 + 3 u! 49 | [ 44 ] branch 50 | 51 | [ 45 ] LABEL 52 | $0 3 u! 53 | 54 | [ 47 ] LABEL 55 | 56 | 3 u@ $1ffe <= 57 | 1 and 58 | [ 48 ] branchz 59 | 60 | flags 3 u@ + c@ c>i 61 | [ 50 ] branchz 62 | 63 | 3 u@ 3 u@ + $3 + 0 u! 64 | 3 u@ 0 u@ + 4 u! 65 | 66 | [ 51 ] LABEL 67 | 4 u@ $1ffe <= 68 | 1 and 69 | [ 52 ] branchz 70 | 71 | $0 flags 4 u@ + c! 72 | 73 | [ 53 ] LABEL 74 | 4 u@ 0 u@ + 4 u! 75 | [ 51 ] branch 76 | 77 | [ 52 ] LABEL 78 | 1 u@ $1 + 1 u! 79 | 80 | [ 50 ] LABEL 81 | [ 49 ] LABEL 82 | 3 u@ $1 + 3 u! 83 | [ 47 ] branch 84 | 85 | [ 48 ] LABEL 86 | [ 43 ] LABEL 87 | 2 u@ $1 + 2 u! 88 | [ 41 ] branch 89 | 90 | [ 42 ] LABEL 91 | 1 u@ 92 | $76b 93 | <> 94 | 1 and 95 | [ 54 ] branchz 96 | 64 FP+! 97 | do_error 98 | -64 FP+! 99 | [ 54 ] LABEL 100 | ; 101 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xmatmul.c: -------------------------------------------------------------------------------- 1 | /* matmul.c */ 2 | /* from Stanford benchmark suite */ 3 | /* modified for reasonable 16-bit operation */ 4 | /* Hand-optimized for best C performance by Phil Koopman */ 5 | 6 | #include 7 | 8 | #define true -1 9 | #define false 0 10 | 11 | /* Intmm, Mm */ 12 | #define ROWSIZE 40 13 | 14 | /* Intmm, Mm */ 15 | int ima[ROWSIZE+1][ROWSIZE+1], 16 | imb[ROWSIZE+1][ROWSIZE+1], 17 | imr[ROWSIZE+1][ROWSIZE+1]; 18 | 19 | int seed ; 20 | 21 | static void Initrand () 22 | { 23 | seed = 9219; 24 | }; 25 | 26 | static int Rand () 27 | { 28 | seed = (seed * 1309 + 13849) ; 29 | return( seed ); 30 | }; 31 | 32 | /* Multiplies two integer matrices. */ 33 | 34 | static void Initmatrix ( m ) int m[ROWSIZE+1][ROWSIZE+1]; 35 | { 36 | int temp, i, j; 37 | int *mat; 38 | for ( i = 1; i <= ROWSIZE; i++ ) 39 | { mat = m[i]; 40 | for ( j = 1; j <= ROWSIZE; j++ ) 41 | { temp = Rand(); 42 | mat[j] = temp - (temp/120)*120 - 60; 43 | }; 44 | } 45 | }; 46 | 47 | static void Innerproduct( result,a,b, row,column) 48 | int *result, 49 | a[ROWSIZE+1][ROWSIZE+1], 50 | b[ROWSIZE+1][ROWSIZE+1], 51 | row,column; 52 | /* computes the inner product of A[row,*] and B[*,column] */ 53 | { 54 | int i, acc; 55 | int *a_addr; 56 | a_addr = a[row]; 57 | acc = 0; 58 | for(i = 1; i <= ROWSIZE; i++ ) 59 | { acc = acc + a_addr[i] * b[i][column]; } 60 | *result = acc; 61 | }; 62 | 63 | void main () 64 | { 65 | int i, j, iter; 66 | int *mat; 67 | for (iter = 1 ; iter < 25 ; iter++ ) 68 | { 69 | Initrand(); 70 | Initmatrix (ima); 71 | Initmatrix (imb); 72 | for ( i = 1; i <= ROWSIZE; i++ ) 73 | { mat = imr[i]; 74 | for ( j = 1; j <= ROWSIZE; j++ ) 75 | { Innerproduct(&mat[j],ima,imb,i,j); } 76 | } 77 | } 78 | }; 79 | 80 | -------------------------------------------------------------------------------- /RTX2000/TESTS/perm.a.4th: -------------------------------------------------------------------------------- 1 | \ /* perm.c */ 2 | \ CESYS compiled 3 | 4 | EMPTY 5 | : XY " DOS XY perm.4a" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE permarray 24 CELL- ALLOT 11 | VARIABLE pctr 4 CELL- ALLOT 12 | 13 | 100 REG-ADDR $FFC0 AND UBR! 14 | 15 | : do_error ." Error in Perm." cr ; 16 | 17 | : Swap_el 18 | 0 u! 1 u! 0 u@ @ 2 u! 1 u@ @ 0 u@ ! 2 u@ 1 u@ ! ; 19 | 20 | : Initialize 21 | $1 0 u! 22 | 23 | [ 42 ] label 24 | 0 u@ $7 <= 1 and 25 | [ 43 ] branchz 26 | 27 | 0 u@ $ffff + permarray 28 | 0 u@ 2* + ! 29 | 30 | [ 44 ] label 31 | 0 u@ $1 + 0 u! 32 | [ 42 ] branch 33 | 34 | [ 43 ] label 35 | ; 36 | 37 | : Permute 38 | >r pctr @ $1 + pctr ! r@ $1 <> 1 and 39 | 40 | [ 46 ] branchz 41 | 42 | r@ $ffff + 43 | 17 g@ 64 + 17 g! 44 | RECURSE 17 g@ 64 - 17 g! 45 | r@ $ffff + 1 u! 46 | 47 | [ 47 ] label 48 | $1 1 u@ <= 1 and 49 | [ 48 ] branchz 50 | 51 | permarray 1 u@ 2* + 52 | permarray r@ 2* + 53 | 17 g@ 64 + 17 g! 54 | Swap_el 55 | 17 g@ 64 - 17 g! 56 | r@ $ffff + 57 | 17 g@ 64 + 17 g! 58 | RECURSE 17 g@ 64 - 17 g! 59 | permarray 1 u@ 2* + 60 | permarray r@ 2* + 61 | 17 g@ 64 + 17 g! 62 | Swap_el 63 | 17 g@ 64 - 17 g! 64 | 65 | [ 49 ] label 66 | 1 u@ $1 - 1 u! 67 | [ 47 ] branch 68 | 69 | [ 48 ] label 70 | [ 46 ] label 71 | r> drop ; 72 | 73 | : main 74 | 100 REG-ADDR $FFC0 AND UBR! 75 | $1 0 u! 76 | 77 | [ 51 ] label 78 | 0 u@ 79 | dup . 80 | $fa <= 1 and 81 | [ 52 ] branchz 82 | 83 | $0 pctr ! 84 | 17 g@ 64 + 17 g! 85 | Initialize 86 | 17 g@ 64 - 17 g! 87 | $7 88 | 17 g@ 64 + 17 g! 89 | Permute 90 | 17 g@ 64 - 17 g! 91 | pctr @ $21d4 92 | <> 1 and 93 | [ 54 ] branchz 94 | 95 | 17 g@ 64 + 17 g! 96 | do_error 97 | 17 g@ 64 - 17 g! 98 | 99 | [ 54 ] label 100 | [ 53 ] label 101 | 0 u@ $1 + 0 u! 102 | [ 51 ] branch 103 | 104 | [ 52 ] label 105 | ; 106 | 107 | .( max ) $fa . cr 108 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | RTX2000 Simulator 2 | 3 | Build and run on Ubuntu: 4 | cd SIM2000 5 | make 6 | ./run 7 | 8 | 9 | It appears this simulator contains support for the RTX2000, RTX2001A, and RTX2010. 10 | To set the chip type set the which_chip variable in main.c before building. 11 | 12 | 13 | This program has been ported to GNU/Linux. Files originally from: 14 | http://users.ece.cmu.edu/~koopman/forth/RTX2000_SIMULATOR.ZIP 15 | http://users.ece.cmu.edu/~koopman/forth/RTX2000_APPFORTH.ZIP 16 | 17 | 18 | ======= The text from SIM2000/readme.1st follows ============= 19 | 20 | 10/24/97 21 | 22 | I pulled this RTX 2000 simulator from an ancient floppy disk. 23 | It was written for my personal use while I was at Harris, and 24 | is not a commercial product by any stretch of the imagination. 25 | I figure that Harris is long past caring about this, so I'm 26 | giving it to people who need help using the RTX 2000 as an 27 | after-the-fact technical support exercise. However, this is 28 | still copyrighted by Harris Semiconductor and should be treated 29 | accordingly. 30 | 31 | To run, just execute sim.bat, which will execute the simulator 32 | while loading an image of Rick VanNorman's AppForth. What you 33 | get is an RTX 2000 simulation running a Forth compiler. The 34 | source code is all there for both the simulator and AppForth 35 | (and probably some spare code that isn't used). I recompiled 36 | it with Borland Turbo C++ 4.0 and it worked, so it should be 37 | complete (it got a heap of compiler warnings, but it did 38 | compile -- I suppose I've learned a lot more about C programming 39 | since I wrote the original code :-) ) 40 | Beyond that, you're on your own. 41 | 42 | Notes: 43 | 44 | - This is hacked-together C code. I think it is complete except 45 | for single-step functions not working (I never got to them). 46 | 47 | - Harris Semiconductor does not officially endorse the release of 48 | this simulator -- so don't hassle them if there is a problem 49 | with it (you use it at your own risk and expense). Similarly, 50 | I offer no warrantees express or implied. 51 | 52 | - If you have questions about the code -- you're on your own. 53 | I don't have time to support this, even if I *did* remember 54 | what I did all those years ago. 55 | 56 | Cheers, 57 | 58 | Phil Koopman 59 | koopman@cmu.edu 60 | -------------------------------------------------------------------------------- /RTX2000/TESTS/perm.c.4th: -------------------------------------------------------------------------------- 1 | \ /* perm.c */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY perm.c.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE permarray 24 CELL- ALLOT 11 | VARIABLE pctr 4 CELL- ALLOT 12 | 13 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 14 | 15 | : do_error 16 | ." Error in Perm." cr 17 | ; 18 | 19 | : Swap_el 20 | 21 | 1_pick 22 | @ 23 | 1_pick 24 | @ 25 | 3_pick 26 | ! 27 | SWAP ! 28 | DROP 29 | ; 30 | 31 | : Initialize 32 | 33 | 1 34 | [ 007 ADD_INDEX ] >R 35 | 36 | [ 007 ] LABEL 37 | 38 | [ 007 ] INDEX 39 | 2* 40 | [ permarray ] SYMBOL_+ 41 | [ 007 ] INDEX 42 | 1 43 | - 44 | SWAP ! 45 | R> 46 | 1 47 | + 48 | DUP_>R 49 | 7 50 | U> 51 | [ 007 ] BRANCHZ 52 | [ 007 DROP_INDEX ] R>DROP 53 | EXIT [ 008 ] LABEL 54 | ; 55 | 56 | : Permute 57 | 58 | 1 59 | pctr 60 | +! 61 | 62 | [ 2 ] DUP_U! 63 | 1 64 | - 65 | [ 0010 ] BRANCHZ 66 | 67 | 2 U@ 68 | 1 69 | - 70 | 71 | -64 FP+! 72 | recurse 64 FP+! 73 | 74 | 2 U@ 75 | 1 76 | - 77 | 0_pick 78 | 0> 79 | [ 0015 ] BRANCHZ 80 | 81 | 2 U@ 82 | 2* 83 | 4 U! 84 | 85 | [ 0014 ] LABEL 86 | 87 | 0_pick 88 | 2* 89 | 4 U@ 90 | [ permarray ] SYMBOL_+ 91 | SWAP 92 | [ permarray ] SYMBOL_+ 93 | 94 | Swap_el 95 | 96 | 3 U! 97 | 2 U@ 98 | 1 99 | - 100 | 101 | -64 FP+! 102 | recurse 64 FP+! 103 | 104 | 3 U@ 0_pick 105 | 2* 106 | 4 U@ 107 | [ permarray ] SYMBOL_+ 108 | SWAP 109 | [ permarray ] SYMBOL_+ 110 | 111 | Swap_el 112 | 113 | -1 + 114 | 0_pick 115 | 0> 116 | [ 0014 ] BRANCHNZ 117 | 118 | DROP 119 | [ 0015 ] LABEL 120 | EXIT [ 0010 ] LABEL 121 | ; 122 | 123 | : main 124 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 125 | 126 | 1 127 | [ 0021 ADD_INDEX ] >R 128 | 129 | [ 0021 ] LABEL 130 | 131 | 0 132 | pctr 133 | ! 134 | 135 | Initialize 136 | 137 | 7 138 | 139 | -64 FP+! 140 | Permute 141 | 64 FP+! 142 | 143 | pctr 144 | @ 145 | 8660 146 | - 147 | [ 0019 ] BRANCHZ 148 | -64 FP+! 149 | do_error 150 | 64 FP+! 151 | 152 | [ 0019 ] LABEL 153 | R> 154 | 1 155 | + 156 | DUP_>R 157 | dup . 250 158 | U> 159 | [ 0021 ] BRANCHZ 160 | [ 0021 DROP_INDEX ] R>DROP 161 | 162 | EXIT [ 0022 ] LABEL 163 | ; 164 | 165 | .( max 250) cr 166 | -------------------------------------------------------------------------------- /RTX2000/TESTS/perm.b.4th: -------------------------------------------------------------------------------- 1 | \ /* perm.c */ 2 | \ GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY perm.b.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE permarray 24 CELL- ALLOT 11 | VARIABLE pctr 4 CELL- ALLOT 12 | 13 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 14 | 15 | : do_error 16 | ." Error in Perm." cr 17 | ; 18 | 19 | : Swap_el 20 | 21 | OVER 22 | @ 23 | 2 U! 24 | DUP 25 | @ 26 | ROT 27 | ! 28 | [ 2 ] U@_SWAP 29 | ! 30 | ; 31 | 32 | : Initialize 33 | 34 | 1 35 | [ 007 ADD_INDEX ] >R 36 | 37 | [ 007 ] LABEL 38 | 39 | [ 007 ] INDEX 40 | 2* 41 | [ permarray ] SYMBOL_+ 42 | [ 007 ] INDEX 43 | 1 44 | - 45 | SWAP ! 46 | R> 47 | 1 48 | + 49 | DUP_>R 50 | 7 51 | U> 52 | [ 007 ] BRANCHZ 53 | [ 007 DROP_INDEX ] R>DROP 54 | EXIT [ 008 ] LABEL 55 | ; 56 | 57 | : Permute 58 | 59 | 1 60 | pctr 61 | +! 62 | 63 | [ 2 ] DUP_U! 64 | 1 65 | - 66 | [ 0010 ] BRANCHZ 67 | 68 | 2 U@ 69 | 1 70 | - 71 | 72 | -64 FP+! 73 | recurse 64 FP+! 74 | 75 | 2 U@ 76 | 1 77 | - 78 | [ 3 ] DUP_U! 79 | 0> 80 | [ 0015 ] BRANCHZ 81 | 2 U@ 82 | 2* 83 | 4 U! 84 | 85 | [ 0014 ] LABEL 86 | 87 | 3 U@ 88 | 2* 89 | 4 U@ 90 | [ permarray ] SYMBOL_+ 91 | SWAP 92 | [ permarray ] SYMBOL_+ 93 | 94 | -64 FP+! 95 | Swap_el 96 | 64 FP+! 97 | 98 | 2 U@ 99 | 1 100 | - 101 | 102 | -64 FP+! 103 | recurse 64 FP+! 104 | 105 | 3 U@ 106 | 2* 107 | 4 U@ 108 | [ permarray ] SYMBOL_+ 109 | SWAP 110 | [ permarray ] SYMBOL_+ 111 | 112 | -64 FP+! 113 | Swap_el 114 | 64 FP+! 115 | 116 | -1 117 | 3 U@ + 3 U! 118 | 3 U@ 119 | 0> 120 | [ 0014 ] BRANCHNZ 121 | 122 | [ 0015 ] LABEL 123 | EXIT [ 0010 ] LABEL 124 | ; 125 | 126 | : main 127 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 128 | 129 | 1 130 | [ 0021 ADD_INDEX ] >R 131 | 132 | [ 0021 ] LABEL 133 | 134 | 0 135 | pctr 136 | ! 137 | 138 | -64 FP+! 139 | Initialize 140 | 64 FP+! 141 | 142 | 7 143 | 144 | -64 FP+! 145 | Permute 146 | 64 FP+! 147 | 148 | pctr 149 | @ 150 | 8660 151 | - 152 | [ 0019 ] BRANCHZ 153 | -64 FP+! 154 | do_error 155 | 64 FP+! 156 | 157 | [ 0019 ] LABEL 158 | R> 159 | 1 160 | + 161 | DUP_>R 162 | dup . 163 | 250 164 | U> 165 | [ 0021 ] BRANCHZ 166 | [ 0021 DROP_INDEX ] R>DROP 167 | 168 | EXIT [ 0022 ] LABEL 169 | ; 170 | 171 | .( max 250) cr 172 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/perm.ces: -------------------------------------------------------------------------------- 1 | \ /* perm.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | \ CESYS compiled 6 | 7 | EMPTY 8 | : XY " DOS XY perm.ces" EVALUATE ; 9 | 10 | DECIMAL 11 | load gnutool.4th 12 | 13 | \ int permarray[permrange+1]; 14 | \ int pctr; 15 | VARIABLE permarray 24 CELL- ALLOT 16 | VARIABLE pctr 4 CELL- ALLOT 17 | 18 | \ #define permrange 10 19 | 20 | 21 | 100 REG-ADDR $FFC0 AND UBR! 22 | 23 | \ static void do_error() { 24 | : do_error ( FUNC ) ( 3 top> empty ) 25 | \ printf(" Error in Perm.\n"); } 26 | ." Error in Perm." cr 27 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 28 | 29 | : Swap_el 30 | 0 u! 1 u! 0 u@ @ 2 u! 1 u@ @ 0 u@ ! 2 u@ 1 u@ ! ; 31 | 32 | : Initialize 33 | $1 0 u! 34 | 35 | [ 42 ] label 36 | 0 u@ $7 <= 1 and 37 | [ 43 ] branchz 38 | 39 | 0 u@ $ffff + permarray 40 | 0 u@ 2* + ! 41 | 42 | [ 44 ] label 43 | 0 u@ $1 + 0 u! 44 | [ 42 ] branch 45 | 46 | [ 43 ] label 47 | ; 48 | 49 | : Permute 50 | >r pctr @ $1 + pctr ! r@ $1 <> 1 and 51 | 52 | [ 46 ] branchz 53 | 54 | r@ $ffff + 55 | 17 g@ 64 + 17 g! 56 | RECURSE \ Permute 57 | 17 g@ 64 - 17 g! 58 | r@ $ffff + 1 u! 59 | 60 | [ 47 ] label 61 | $1 1 u@ <= 1 and 62 | [ 48 ] branchz 63 | 64 | permarray 1 u@ 2* + 65 | permarray r@ 2* + 66 | 17 g@ 64 + 17 g! 67 | Swap_el 68 | 17 g@ 64 - 17 g! 69 | r@ $ffff + 70 | 17 g@ 64 + 17 g! 71 | RECURSE \ Permute 72 | 17 g@ 64 - 17 g! 73 | permarray 1 u@ 2* + 74 | permarray r@ 2* + 75 | 17 g@ 64 + 17 g! 76 | Swap_el 77 | 17 g@ 64 - 17 g! 78 | 79 | [ 49 ] label 80 | 1 u@ $1 - 1 u! 81 | [ 47 ] branch 82 | 83 | [ 48 ] label 84 | [ 46 ] label 85 | r> drop ; 86 | 87 | : main 88 | 100 REG-ADDR $FFC0 AND UBR! 89 | $1 0 u! 90 | 91 | [ 51 ] label 92 | 0 u@ 93 | dup . 94 | $fa <= 1 and 95 | [ 52 ] branchz 96 | 97 | $0 pctr ! 98 | 17 g@ 64 + 17 g! 99 | Initialize 100 | 17 g@ 64 - 17 g! 101 | $7 102 | 17 g@ 64 + 17 g! 103 | Permute 104 | 17 g@ 64 - 17 g! 105 | pctr @ $21d4 106 | <> 1 and 107 | [ 54 ] branchz 108 | 109 | 17 g@ 64 + 17 g! 110 | do_error 111 | 17 g@ 64 - 17 g! 112 | 113 | [ 54 ] label 114 | [ 53 ] label 115 | 0 u@ $1 + 0 u! 116 | [ 51 ] branch 117 | 118 | [ 52 ] label 119 | ; 120 | -------------------------------------------------------------------------------- /RTX2000/TESTS/matmul.a.4th: -------------------------------------------------------------------------------- 1 | \ /* matmul.c */ 2 | \ CESYS compiled code 3 | 4 | EMPTY 5 | 6 | : XY " DOS XY matmul.a.4th" EVALUATE ; 7 | 8 | DECIMAL 9 | 10 | load gnutool.4th 11 | 100 REG-ADDR $FFC0 AND UBR! 12 | 13 | VARIABLE seed 4 CELL- ALLOT 14 | VARIABLE imr 3364 CELL- ALLOT 15 | VARIABLE imb 3364 CELL- ALLOT 16 | VARIABLE ima 3364 CELL- ALLOT 17 | 18 | : Initrand 19 | $2403 seed ! ; 20 | 21 | : Rand 22 | seed @ $51d * $3619 + seed ! 23 | seed @ ; 24 | 25 | : Initmatrix 26 | >r $1 2 u! 27 | 28 | [ 41 ] label 29 | 2 u@ $28 <= 1 and 30 | [ 42 ] branchz 31 | 32 | $1 3 u! 33 | 34 | [ 44 ] label 35 | 3 u@ $28 <= 1 and 36 | [ 45 ] branchz 37 | 38 | 17 g@ 64 + 17 g! 39 | Rand 40 | 17 g@ 64 - 17 g! 41 | 1 u! 42 | 1 u@ 1 u@ $78 / $78 * - 43 | $ffc4 + r@ 2 u@ $52 * + 44 | 3 u@ 2* + ! 45 | 46 | [ 46 ] label 47 | 3 u@ $1 + 3 u! 48 | [ 44 ] branch 49 | 50 | [ 45 ] label 51 | [ 43 ] label 52 | 2 u@ $1 + 2 u! 53 | [ 41 ] branch 54 | 55 | [ 42 ] label 56 | r> drop ; 57 | 58 | 59 | : Innerproduct 60 | 0 u! 1 u! 2 u! 3 u! 4 u! 61 | $0 0 u@ ! $1 5 u! 62 | [ 48 ] label 63 | 5 u@ $28 <= 1 and 64 | [ 49 ] branchz 65 | 66 | 0 u@ @ 1 u@ 3 u@ $52 * + 67 | 5 u@ 2* + @ 2 u@ 5 u@ $52 * + 4 u@ 68 | 2* + @ * + 0 u@ ! 69 | 70 | [ 50 ] label 71 | 5 u@ $1 + 5 u! 72 | [ 48 ] branch 73 | 74 | [ 49 ] label 75 | ; 76 | 77 | : main 78 | 100 REG-ADDR $FFC0 AND UBR! 79 | $1 2 u! 80 | 81 | [ 52 ] label 82 | $19 2 u@ 83 | dup . 84 | > 1 and 85 | [ 53 ] branchz 86 | 87 | 17 g@ 64 + 17 g! 88 | Initrand 89 | 17 g@ 64 - 17 g! 90 | 91 | ima 92 | 17 g@ 64 + 17 g! 93 | Initmatrix 94 | 17 g@ 64 - 17 g! 95 | 96 | imb 97 | 17 g@ 64 + 17 g! 98 | Initmatrix 99 | 17 g@ 64 - 17 g! 100 | $1 0 u! 101 | 102 | [ 55 ] label 103 | 0 u@ $28 <= 1 and 104 | [ 56 ] branchz 105 | 106 | $1 1 u! 107 | [ 58 ] label 108 | 1 u@ $28 <= 1 and 109 | [ 59 ] branchz 110 | 111 | 1 u@ 0 u@ imb 112 | ima imr 0 u@ $52 * + 1 u@ 2* + 113 | 17 g@ 64 + 17 g! 114 | Innerproduct 115 | 17 g@ 64 - 17 g! 116 | 117 | [ 60 ] label 118 | 1 u@ $1 + 1 u! 119 | [ 58 ] branch 120 | 121 | [ 59 ] label 122 | [ 57 ] label 123 | 0 u@ $1 + 0 u! 124 | [ 55 ] branch 125 | 126 | [ 56 ] label 127 | [ 54 ] label 128 | 2 u@ $1 + 2 u! 129 | [ 52 ] branch 130 | 131 | [ 53 ] label 132 | ; 133 | 134 | .( max ) $19 . cr 135 | -------------------------------------------------------------------------------- /RTX2000/TESTS/matmul.e.4th: -------------------------------------------------------------------------------- 1 | \ /* matmul.c */ 2 | \ Improved source code assembler based on GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY matmul.e.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | 9 | load gnutool.4th 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE seed 4 CELL- ALLOT 13 | VARIABLE imr 3364 CELL- ALLOT 14 | VARIABLE imb 3364 CELL- ALLOT 15 | VARIABLE ima 3364 CELL- ALLOT 16 | 17 | 18 | : Initrand ( -- ) 19 | 9219 seed ! ; 20 | 21 | : Rand ( -- n) 22 | seed @ 1309 * 13849 + seed TUCK_! ; 23 | 24 | : Initmatrix 25 | 84 + 26 | 39 FOR 27 | 39 FOR ( -- ^mat[j] ) 28 | Rand ( -- ^mat[j] temp ) 29 | DUP 120 / 120 * ( -- ^mat[j] temp x ) 30 | - 60 - ( -- ^mat[j] x ) 31 | SWAP ( -- x ^mat[j] ) 32 | !+2 ( -- ^mat[j] ) 33 | NEXT ( -- ^mat[j] ) 34 | 2 + 35 | NEXT 36 | DROP 37 | ; 38 | 39 | : Innerproduct ( ^result a b row col -- ) 40 | >R ( -- ^result a b row ) 41 | SWAP >R ( -- ^result a row ) 42 | 82 * + 80 + ( -- ^result ^a ) 43 | R> R> 2* + 3280 + SWAP ( -- ^result ^b ^a ) 44 | 45 | 0 ( -- ^result ^b ^a acc ) 46 | 39 FOR ( -- ^result ^b ^a acc ) 47 | >R ( -- ^result ^b ^a ) 48 | OVER @ ( -- ^result ^b ^a b ) 49 | OVER @ ( -- ^result ^b ^a b a ) 50 | * ( -- ^result ^b ^a prod ) 51 | >R ( -- ^result ^b ^a ) 52 | SWAP -82 + SWAP ( -- ^result ^b ^a ) 53 | 2 - ( -- ^result ^b ^a ) 54 | R> R> + ( -- ^result ^b ^a acc ) 55 | NEXT ( -- ^result ^b ^a acc ) 56 | NIP NIP ( -- ^result acc ) 57 | SWAP ! ( -- ) 58 | ; 59 | 60 | 64 FRAME_SIZE ! 61 | : main 62 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 63 | 1 >R 64 | 65 | BEGIN 66 | Initrand 67 | ima Initmatrix 68 | imb Initmatrix 69 | 70 | 1 >R 71 | 72 | BEGIN 73 | I 82 * [ imr ] SYMBOL_+ 3 U! 74 | 1 2 U! 75 | BEGIN 76 | 2 U@ 2* 77 | 3 U@ + 78 | ima 79 | imb 80 | I 81 | 2 U@ 82 | Innerproduct 83 | 2 U@ 1 + [ 2 ] dup_U! 84 | 40 u> 85 | UNTIL 86 | R> 1 + DUP_>R 87 | 40 U> 88 | UNTIL 89 | R>DROP 90 | R> 1 + DUP_>R 91 | 24 U> 92 | UNTIL 93 | R>DROP 94 | ; 95 | 96 | .( max 24) cr 97 | -------------------------------------------------------------------------------- /RTX2000/TESTS/queens.c: -------------------------------------------------------------------------------- 1 | 2 | /* queens.c */ 3 | /* from Stanford benchmark suite */ 4 | /* modified for reasonable 16-bit operation */ 5 | 6 | #include 7 | /* #include "stdlib.h" */ 8 | 9 | #define true -1 10 | #define false 0 11 | 12 | static void do_error() 13 | { printf (" Error in Queens.\n"); } 14 | 15 | int tries ; 16 | 17 | /* The eight queens problem, solved 50 times. */ 18 | /* 19 | type 20 | doubleboard = 2..16; 21 | doublenorm = -7..7; 22 | boardrange = 1..8; 23 | aarray = array [boardrange] of boolean; 24 | barray = array [doubleboard] of boolean; 25 | carray = array [doublenorm] of boolean; 26 | xarray = array [boardrange] of boardrange; 27 | */ 28 | 29 | static void Try(i, q, a, b, c, x) int i, *q, a[], b[], c[], x[]; 30 | { 31 | int j; 32 | tries += 1 ; 33 | j = 0; 34 | *q = false; 35 | while ( (! *q) && (j != 8) ) 36 | { j = j + 1; 37 | *q = false; 38 | if ( b[j] && a[i+j] && c[i-j+7] ) 39 | { 40 | x[i] = j; 41 | b[j] = false; 42 | a[i+j] = false; 43 | c[i-j+7] = false; 44 | if ( i < 8 ) 45 | { 46 | Try(i+1,q,a,b,c,x); 47 | if ( ! *q ) 48 | { b[j] = true; 49 | a[i+j] = true; 50 | c[i-j+7] = true; 51 | } 52 | } 53 | else { *q = true; 54 | } 55 | } 56 | } 57 | }; 58 | 59 | static void Doit () 60 | { 61 | int i,q; 62 | int a[9], b[17], c[15], x[9]; 63 | i = 0 - 7; 64 | while ( i <= 16 ) 65 | { if ( (i >= 1) && (i <= 8) ) a[i] = true; 66 | if ( i >= 2 ) b[i] = true; 67 | if ( i <= 7 ) c[i+7] = true; 68 | i = i + 1; 69 | }; 70 | 71 | Try(1, &q, b, a, c, x); 72 | if ( ! q ) 73 | { do_error(); 74 | tries += 1000 ; 75 | } 76 | }; 77 | 78 | void main () 79 | { 80 | int i; 81 | for ( i = 1; i <= 2500; i++ ) 82 | { 83 | tries = 0 ; 84 | Doit(); 85 | if (tries != 113 ) do_error(); 86 | } 87 | }; 88 | 89 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xqueens.c: -------------------------------------------------------------------------------- 1 | /* queens.c */ 2 | /* from Stanford benchmark suite */ 3 | /* modified for reasonable 16-bit operation */ 4 | /* Hand-optimized for best C performance by Phil Koopman */ 5 | /* net result: no changes made */ 6 | 7 | #include 8 | 9 | #define true -1 10 | #define false 0 11 | 12 | static void do_error() 13 | { puts (" Error in Queens.\n"); } 14 | 15 | int tries ; 16 | 17 | /* The eight queens problem, solved 50 times. */ 18 | /* 19 | type 20 | doubleboard = 2..16; 21 | doublenorm = -7..7; 22 | boardrange = 1..8; 23 | aarray = array [boardrange] of boolean; 24 | barray = array [doubleboard] of boolean; 25 | carray = array [doublenorm] of boolean; 26 | xarray = array [boardrange] of boardrange; 27 | */ 28 | 29 | static void Try(i, q, a, b, c, x) int i, *q, a[], b[], c[], x[]; 30 | { 31 | int j; 32 | tries += 1 ; 33 | j = 0; 34 | *q = false; 35 | while ( (! *q) && (j != 8) ) 36 | { j = j + 1; 37 | *q = false; 38 | if ( b[j] && a[i+j] && c[i-j+7] ) 39 | { 40 | x[i] = j; 41 | b[j] = false; 42 | a[i+j] = false; 43 | c[i-j+7] = false; 44 | if ( i < 8 ) 45 | { 46 | Try(i+1,q,a,b,c,x); 47 | if ( ! *q ) 48 | { b[j] = true; 49 | a[i+j] = true; 50 | c[i-j+7] = true; 51 | } 52 | } 53 | else { *q = true; 54 | } 55 | } 56 | } 57 | }; 58 | 59 | static void Doit () 60 | { 61 | int i,q; 62 | int a[9], b[17], c[15], x[9]; 63 | i = 0 - 7; 64 | while ( i <= 16 ) 65 | { if ( (i >= 1) && (i <= 8) ) a[i] = true; 66 | if ( i >= 2 ) b[i] = true; 67 | if ( i <= 7 ) c[i+7] = true; 68 | i = i + 1; 69 | }; 70 | 71 | Try(1, &q, b, a, c, x); 72 | if ( ! q ) 73 | { do_error(); 74 | tries += 1000 ; 75 | } 76 | }; 77 | 78 | void main () 79 | { 80 | int i; 81 | for ( i = 1; i <= 2500; i++ ) 82 | { 83 | tries = 0 ; 84 | Doit(); 85 | if (tries != 113 ) do_error(); 86 | } 87 | }; 88 | 89 | -------------------------------------------------------------------------------- /RTX2000/TESTS/btowers.c: -------------------------------------------------------------------------------- 1 | /******************** TOWERS ********************/ 2 | 3 | #define FALSE 0 4 | #define TRUE 1 5 | #define MAXCELLS 18 6 | #define STACKRANGE 3 7 | 8 | int stack [STACKRANGE+1]; 9 | struct element { 10 | int discsize; 11 | int next; 12 | } cellspace [MAXCELLS+1]; 13 | int freelist, movesdone; 14 | 15 | void error (emsg) 16 | char *emsg; 17 | { 18 | } 19 | 20 | void makenull (s) 21 | int s; 22 | { 23 | stack[s] = 0; 24 | } 25 | 26 | int getelement() { 27 | int temp; 28 | 29 | if (freelist > 0) { 30 | temp = freelist; 31 | freelist = cellspace[freelist].next; 32 | } else 33 | error ("Out of space "); 34 | return (temp); 35 | } 36 | 37 | void push (i, s) 38 | int i, s; 39 | { 40 | int errorfound, localel; 41 | 42 | errorfound = FALSE; 43 | if (stack[s] > 0) { 44 | if (cellspace[stack[s]].discsize <= i) { 45 | errorfound = TRUE; 46 | error ("Disc size error "); 47 | } 48 | } 49 | if (! errorfound) { 50 | localel = getelement (); 51 | cellspace[localel].next = stack[s]; 52 | stack[s] = localel; 53 | cellspace[localel].discsize = i; 54 | } 55 | } 56 | 57 | void init (s, n) 58 | int s, n; 59 | { 60 | int discctr; 61 | 62 | makenull (s); 63 | for (discctr=n; discctr >= 1; discctr--) { 64 | push (discctr, s); 65 | } 66 | } 67 | 68 | int pop (s) 69 | int s; 70 | { 71 | int temp, temp1; 72 | 73 | if (stack[s] > 0) { 74 | temp1 = cellspace[stack[s]].discsize; 75 | temp = cellspace[stack[s]].next; 76 | cellspace[stack[s]].next = freelist; 77 | freelist = stack[s]; 78 | stack[s] = temp; 79 | return (temp1); 80 | } else 81 | error ("Nothing to pop "); 82 | } 83 | 84 | void move (s1, s2) 85 | int s1, s2; 86 | { 87 | push (pop (s1), s2); 88 | movesdone = movesdone + 1; 89 | } 90 | 91 | void tower (i, j, k) 92 | int i, j, k; 93 | { 94 | int other; 95 | 96 | if (k == 1) { 97 | move (i, j); 98 | }else { 99 | other = 6 - i - j; 100 | tower (i, other, k-1); 101 | move (i, j); 102 | tower (other, j, k-1); 103 | } 104 | } 105 | 106 | void main () { 107 | int i; 108 | 109 | for (i=1; i<= MAXCELLS; i++) { 110 | cellspace[i].next = i-1; 111 | } 112 | freelist = MAXCELLS; 113 | init (1, 14); 114 | makenull (2); 115 | makenull (3); 116 | movesdone = 0; 117 | tower (1, 2, 14); 118 | } 119 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bubble.e.4th: -------------------------------------------------------------------------------- 1 | \ /* bubble.c */ 2 | \ Improved source code assembler based on GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY bubble.e.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | 11 | VARIABLE seed 4 CELL- ALLOT 12 | 13 | VARIABLE top 4 CELL- ALLOT 14 | 15 | VARIABLE littlest 4 CELL- ALLOT 16 | 17 | VARIABLE biggest 4 CELL- ALLOT 18 | 19 | VARIABLE sortlist 10004 CELL- ALLOT 20 | 21 | : .DATA 22 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 23 | 24 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 25 | 26 | : do_error 27 | ." Error3 in Bubble." CR 28 | ; 29 | 30 | : Initrand ( --) 31 | 9219 seed ! ; 32 | 33 | : Rand ( -- n) 34 | seed @ 1309 * 13849 + seed TUCK_! ; 35 | 36 | 37 | : bInitarr ( --) 38 | Initrand 39 | 0 biggest ! 40 | 0 littlest ! 41 | [ sortlist 2 + ] LITERAL ( -- i ) 42 | 43 | 999 FOR 44 | Rand ( -- i temp ) 45 | 32767 - ( -- i list ) 46 | OVER ( OVER SWAP ! ) [ $E080 , ] ( -- i list ) 47 | DUP biggest @ > 48 | IF ( -- i list ) 49 | biggest ! ( -- i ) 50 | ELSE ( -- i list ) 51 | DUP littlest @ < 52 | IF ( -- i list ) 53 | littlest ! ( -- i ) 54 | ELSE ( -- i list ) 55 | DROP ( -- i ) 56 | THEN ( -- i ) 57 | THEN ( -- i ) 58 | 2 + ( -- i ) 59 | NEXT ( -- i ) 60 | DROP 61 | ; 62 | 63 | 64 FRAME_SIZE ! 64 | : main ( --) 65 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 66 | 1 2 U! 67 | [ sortlist 2 + ] LITERAL 3 U! 68 | 69 | BEGIN 70 | bInitarr 71 | [ sortlist 1000 + ] LITERAL ( -- top ) 72 | BEGIN ( -- top ) 73 | DUP 3 U@ U> 74 | WHILE 75 | [ sortlist 2 + ] LITERAL ( -- top i ) 76 | BEGIN ( -- top i ) 77 | OVER OVER U> 78 | WHILE ( -- top i ) 79 | DUP @+2 ( -- top i *i i+2) 80 | @ ( -- top i *i *i+2 ) 81 | > 82 | IF ( exchange *i with *[i+2] ) ( -- top i ) 83 | @+2 @-2 !+2 !-2 ( -- top i ) 84 | THEN ( -- top i ) 85 | 2 + ( -- top i+2 ) 86 | REPEAT ( -- top i ) 87 | DROP ( -- top ) 88 | 2 - ( -- top ) 89 | REPEAT ( -- top ) 90 | DROP 91 | [ sortlist 2 + ] LITERAL @ littlest @ - 92 | [ sortlist 1000 + ] LITERAL @ biggest @ - 93 | OR IF 94 | do_error 95 | THEN 96 | 97 | 2 U@ 1 + [ 2 ] DUP_U! 98 | 29 > 99 | UNTIL 100 | ; 101 | 102 | .( max 29) cr 103 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/matmul.ces: -------------------------------------------------------------------------------- 1 | \ /* matmul.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | \ CESYS compiled code 6 | 7 | EMPTY 8 | 9 | : XY " DOS XY matmul.ces" EVALUATE ; 10 | 11 | DECIMAL 12 | 13 | load gnutool.4th 14 | 100 REG-ADDR $FFC0 AND UBR! 15 | 16 | \ int seed ; 17 | 18 | VARIABLE seed 4 CELL- ALLOT 19 | 20 | \ #define ROWSIZE 40 21 | \ 22 | \ /* Intmm, Mm */ 23 | \ int ima[ROWSIZE+1][ROWSIZE+1], 24 | \ imb[ROWSIZE+1][ROWSIZE+1], 25 | \ imr[ROWSIZE+1][ROWSIZE+1]; 26 | 27 | VARIABLE imr 3364 CELL- ALLOT 28 | 29 | VARIABLE imb 3364 CELL- ALLOT 30 | 31 | VARIABLE ima 3364 CELL- ALLOT 32 | 33 | 34 | : Initrand 35 | $2403 seed ! ; 36 | 37 | : Rand 38 | seed @ $51d * $3619 + seed ! 39 | seed @ ; 40 | 41 | : Initmatrix 42 | >r $1 2 u! 43 | 44 | [ 41 ] label 45 | 2 u@ $28 <= 1 and 46 | [ 42 ] branchz 47 | 48 | $1 3 u! 49 | 50 | [ 44 ] label 51 | 3 u@ $28 <= 1 and 52 | [ 45 ] branchz 53 | 54 | 17 g@ 64 + 17 g! 55 | Rand 56 | 17 g@ 64 - 17 g! 57 | 1 u! 58 | 1 u@ 1 u@ $78 / $78 * - 59 | $ffc4 + r@ 2 u@ $52 * + 60 | 3 u@ 2* + ! 61 | 62 | [ 46 ] label 63 | 3 u@ $1 + 3 u! 64 | [ 44 ] branch 65 | 66 | [ 45 ] label 67 | [ 43 ] label 68 | 2 u@ $1 + 2 u! 69 | [ 41 ] branch 70 | 71 | [ 42 ] label 72 | r> drop ; 73 | 74 | 75 | : Innerproduct 76 | 0 u! 1 u! 2 u! 3 u! 4 u! 77 | $0 0 u@ ! $1 5 u! 78 | [ 48 ] label 79 | 5 u@ $28 <= 1 and 80 | [ 49 ] branchz 81 | 82 | 0 u@ @ 1 u@ 3 u@ $52 * + 83 | 5 u@ 2* + @ 2 u@ 5 u@ $52 * + 4 u@ 84 | 2* + @ * + 0 u@ ! 85 | 86 | [ 50 ] label 87 | 5 u@ $1 + 5 u! 88 | [ 48 ] branch 89 | 90 | [ 49 ] label 91 | ; 92 | 93 | : main 94 | 100 REG-ADDR $FFC0 AND UBR! 95 | $1 2 u! 96 | 97 | [ 52 ] label 98 | $19 2 u@ 99 | dup . 100 | > 1 and 101 | [ 53 ] branchz 102 | 103 | 17 g@ 64 + 17 g! 104 | Initrand 105 | 17 g@ 64 - 17 g! 106 | 107 | ima 108 | 17 g@ 64 + 17 g! 109 | Initmatrix 110 | 17 g@ 64 - 17 g! 111 | 112 | imb 113 | 17 g@ 64 + 17 g! 114 | Initmatrix 115 | 17 g@ 64 - 17 g! 116 | $1 0 u! 117 | 118 | [ 55 ] label 119 | 0 u@ $28 <= 1 and 120 | [ 56 ] branchz 121 | 122 | $1 1 u! 123 | [ 58 ] label 124 | 1 u@ $28 <= 1 and 125 | [ 59 ] branchz 126 | 127 | 1 u@ 0 u@ imb 128 | ima imr 0 u@ $52 * + 1 u@ 2* + 129 | 17 g@ 64 + 17 g! 130 | Innerproduct 131 | 17 g@ 64 - 17 g! 132 | 133 | [ 60 ] label 134 | 1 u@ $1 + 1 u! 135 | [ 58 ] branch 136 | 137 | [ 59 ] label 138 | [ 57 ] label 139 | 0 u@ $1 + 0 u! 140 | [ 55 ] branch 141 | 142 | [ 56 ] label 143 | [ 54 ] label 144 | 2 u@ $1 + 2 u! 145 | [ 52 ] branch 146 | 147 | [ 53 ] label 148 | ; 149 | -------------------------------------------------------------------------------- /RTX2000/TESTS/matmul.c.4th: -------------------------------------------------------------------------------- 1 | \ /* matmul.c */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY matmul.c.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | 9 | load gnutool.4th 10 | 11 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 12 | 13 | VARIABLE seed 4 CELL- ALLOT 14 | VARIABLE imr 3364 CELL- ALLOT 15 | VARIABLE imb 3364 CELL- ALLOT 16 | VARIABLE ima 3364 CELL- ALLOT 17 | 18 | : Initrand 19 | 9219 20 | seed 21 | ! 22 | ; 23 | 24 | : Rand 25 | seed 26 | @ 27 | 1309 28 | * 29 | 13849 30 | + 31 | seed 32 | TUCK_! 33 | ; 34 | 35 | : Initmatrix 36 | 37 | 1 38 | 39 | [ 0011 ] LABEL 40 | 41 | 1 42 | OVER 43 | 82 44 | * 45 | 3_pick + 46 | SWAP 47 | 48 | [ 0010 ] LABEL 49 | Rand 50 | 51 | OVER 52 | 2* 53 | 3_pick + 54 | OVER 55 | 120 56 | / 57 | 120 58 | * 59 | ROT 60 | SWAP- 61 | 60 62 | - 63 | SWAP ! 64 | 1 65 | + 66 | 0_pick 67 | 40 68 | > 69 | [ 0010 ] BRANCHZ 70 | 71 | DROP DROP 72 | 73 | [ 0012 ] LABEL 74 | 1 75 | + 76 | 0_pick 77 | 40 78 | > 79 | [ 0011 ] BRANCHZ 80 | 81 | DROP DROP 82 | EXIT [ 0013 ] LABEL 83 | ; 84 | 85 | : Innerproduct 86 | \ /* computes the inner product of A[row,*] and B[*,column] */ 87 | 88 | 2 U@ 89 | 90 | 0 91 | 5_pick 92 | ! 93 | 1 94 | 95 | 2_PICK 96 | 82 97 | * 98 | 5_pick + 99 | 2_pick 100 | 2* 101 | 102 | [ 0018 ] LABEL 103 | 2_pick 104 | 2* 105 | 2_pick + 106 | 3_pick 107 | 82 108 | * 109 | 7_pick + 110 | 2_pick + 111 | @_SWAP 112 | @_SWAP 113 | * 114 | 8_pick +! 115 | 1 116 | 3_pick 117 | + 118 | 0_PICK 119 | 4_PUT 120 | 40 121 | > 122 | [ 0018 ] BRANCHZ 123 | 124 | DROP 125 | DROP 126 | DROP 127 | DROP 128 | DROP 129 | DROP 130 | DROP 131 | DROP 132 | 133 | EXIT [ 0019 ] LABEL 134 | ; 135 | 136 | : main 137 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 138 | 139 | 1 140 | [ 0032 ADD_INDEX ] >R 141 | 142 | [ 0032 ] LABEL 143 | 144 | Initrand 145 | 146 | ima 147 | 148 | Initmatrix 149 | 150 | imb 151 | 152 | Initmatrix 153 | 154 | 1 155 | [ 0031 ADD_INDEX ] >R 156 | 157 | [ 0031 ] LABEL 158 | 159 | 1 160 | 2 U! 161 | [ 0031 ] INDEX 162 | 82 163 | * 164 | 3 U! 165 | 166 | [ 0030 ] LABEL 167 | 2 U@ 168 | DUP 2* 169 | [ imr ] SYMBOL_+ 170 | SWAP 171 | [ 2 ] MEM_ARG! 172 | 3 U@ + 173 | ima 174 | imb 175 | [ 0031 ] INDEX 176 | 177 | -64 FP+! 178 | Innerproduct 179 | 64 FP+! 180 | 2 U@ 181 | 1 182 | + 183 | [ 2 ] DUP_U! 184 | 40 185 | > 186 | [ 0030 ] BRANCHZ 187 | 188 | [ 0033 ] LABEL 189 | R> 190 | 1 191 | + 192 | DUP_>R 193 | 40 194 | U> 195 | [ 0031 ] BRANCHZ 196 | [ 0031 DROP_INDEX ] R>DROP 197 | [ 0034 ] LABEL 198 | R> 199 | 1 200 | + 201 | DUP_>R 202 | dup . 24 203 | U> 204 | [ 0032 ] BRANCHZ 205 | [ 0032 DROP_INDEX ] R>DROP 206 | 207 | EXIT [ 0035 ] LABEL 208 | ; 209 | 210 | .( max 24) cr 211 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bubble.a.4th: -------------------------------------------------------------------------------- 1 | \ /* bubble.c */ 2 | \ CESYS C generated code 3 | 4 | EMPTY 5 | : XY " DOS XY bubble.a.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE seed 4 CELL- ALLOT 11 | VARIABLE top 4 CELL- ALLOT 12 | VARIABLE littlest 4 CELL- ALLOT 13 | VARIABLE biggest 4 CELL- ALLOT 14 | VARIABLE sortlist 10004 CELL- ALLOT 15 | 16 | : .DATA 17 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 18 | 19 | 100 REG-ADDR $FFC0 AND UBR! 20 | 21 | : do_error ( FUNC ) ( 3 top> empty ) 22 | ." Error3 in Bubble." CR 23 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 24 | 25 | : initrand 26 | $2403 seed ! ; 27 | 28 | : rand 29 | seed @ 30 | $51d 31 | * 32 | $3619 + 33 | seed ! 34 | seed @ 35 | ; 36 | 37 | : bInitarr 38 | 17 g@ 64 + 17 g! 39 | initrand 40 | 17 g@ 64 - 17 g! 41 | $0 biggest ! 42 | $0 littlest ! 43 | $1 0 u! 44 | 45 | 46 | [ 43 ] label 47 | 48 | 0 u@ $1f4 <= 49 | 1 and 50 | [ 44 ] branchz 51 | 52 | 17 g@ 64 + 17 g! 53 | rand 54 | 17 g@ 64 - 17 g! 55 | 1 u! 56 | 1 u@ $8001 + 57 | sortlist 0 u@ 2* + ! 58 | sortlist 0 u@ 2* + @ 59 | biggest @ > 60 | 1 and 61 | [ 46 ] branchz 62 | 63 | sortlist 0 u@ 2* + @ 64 | biggest ! 65 | [ 47 ] branch 66 | 67 | [ 46 ] label 68 | littlest @ 69 | sortlist 0 u@ 2* + @ 70 | > 1 and 71 | [ 48 ] branchz 72 | sortlist 0 u@ 2* + @ 73 | littlest ! 74 | 75 | [ 48 ] label 76 | 77 | [ 47 ] label 78 | 79 | [ 45 ] label 80 | 0 u@ $1 + 0 u! 81 | [ 43 ] branch 82 | 83 | [ 44 ] label 84 | ; 85 | 86 | : main 87 | 88 | 100 REG-ADDR $FFC0 AND UBR! $1 2 u! 89 | 90 | [ 50 ] label 91 | $1e 92 | 2 u@ 93 | dup . 94 | > 1 and 95 | [ 51 ] branchz 96 | 17 g@ 64 + 17 g! 97 | bInitarr 98 | 17 g@ 64 - 17 g! 99 | $1f4 top ! 100 | 101 | [ 53 ] label 102 | top @ $1 > 1 and 103 | [ 54 ] branchz 104 | $1 0 u! 105 | 106 | [ 55 ] label 107 | top @ 0 u@ > 1 and 108 | [ 56 ] branchz 109 | sortlist 0 u@ 2* + @ 110 | sortlist 0 u@ $1 + 2* + @ 111 | > 1 and 112 | [ 57 ] branchz 113 | sortlist 0 u@ 2* + @ 1 u! 114 | sortlist 0 u@ $1 + 2* + @ 115 | sortlist 0 u@ 2* + ! 116 | 1 u@ sortlist 0 u@ $1 + 2* + ! 117 | 118 | [ 57 ] label 119 | 0 u@ $1 + 0 u! 120 | [ 55 ] branch 121 | 122 | [ 56 ] label 123 | top @ $ffff + top ! 124 | [ 53 ] branch 125 | 126 | [ 54 ] label 127 | [ sortlist 2 + ] literal @ 128 | littlest @ 129 | <> 1 and dup 130 | [ 60 ] branchz 131 | [ 59 ] branch 132 | 133 | [ 60 ] label 134 | drop [ sortlist 1000 + ] literal @ biggest @ 135 | <> 1 and 136 | [ 59 ] label 137 | [ 58 ] branchz 138 | 17 g@ 64 + 17 g! 139 | do_error 140 | 17 g@ 64 - 17 g! 141 | 142 | [ 58 ] label 143 | 144 | [ 52 ] label 145 | 2 u@ $1 + 2 u! 146 | [ 50 ] branch 147 | 148 | [ 51 ] label 149 | ; 150 | 151 | .( max ) $1e . cr 152 | -------------------------------------------------------------------------------- /RTX2000/TESTS/matmul.b.4th: -------------------------------------------------------------------------------- 1 | \ /* matmul.c */ 2 | \ GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY matmul.b.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | 9 | load gnutool.4th 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE seed 4 CELL- ALLOT 13 | VARIABLE imr 3364 CELL- ALLOT 14 | VARIABLE imb 3364 CELL- ALLOT 15 | VARIABLE ima 3364 CELL- ALLOT 16 | 17 | : Initrand 18 | 9219 19 | seed 20 | ! 21 | ; 22 | 23 | : Rand 24 | seed 25 | @ 26 | 1309 27 | * 28 | 13849 29 | + 30 | seed 31 | TUCK_! 32 | ; 33 | 34 | : Initmatrix 35 | 36 | 1 37 | 2 U! 38 | 3 U! 39 | 40 | [ 0011 ] LABEL 41 | 42 | 1 43 | 4 U! 44 | 2 U@ 45 | 82 46 | * 47 | 3 U@ + 48 | 5 U! 49 | 50 | [ 0010 ] LABEL 51 | -64 FP+! 52 | Rand 53 | 64 FP+! 54 | 55 | 4 U@ 56 | 2* 57 | 5 U@ + 58 | OVER 59 | 120 60 | / 61 | 120 62 | * 63 | ROT 64 | SWAP- 65 | 60 66 | - 67 | SWAP ! 68 | 4 U@ 69 | 1 70 | + 71 | [ 4 ] DUP_U! 72 | 40 73 | > 74 | [ 0010 ] BRANCHZ 75 | 76 | [ 0012 ] LABEL 77 | 2 U@ 78 | 1 79 | + 80 | [ 2 ] DUP_U! 81 | 40 82 | > 83 | [ 0011 ] BRANCHZ 84 | 85 | EXIT [ 0013 ] LABEL 86 | ; 87 | 88 | : Innerproduct 89 | 90 | 2 U@ 91 | 2 U! 92 | 3 U! 93 | 4 U! 94 | 95 | 0 96 | 2_PICK 97 | ! 98 | 1 99 | 5 U! 100 | 6 U! 101 | 7 U! 102 | 103 | 5 U@ 104 | 40 105 | <= 106 | [ 0019 ] BRANCHZ 107 | 3 U@ 108 | 82 109 | * 110 | 6 U@ + 111 | 2 U@ 112 | 2* 113 | 8 U! 114 | 9 U! 115 | 116 | [ 0018 ] LABEL 117 | 5 U@ 118 | 2* 119 | 9 U@ + 120 | 5 U@ 121 | 82 122 | * 123 | 4 U@ + 124 | 8 U@ + 125 | @_SWAP 126 | @_SWAP 127 | * 128 | 7 U@ 129 | @ + 130 | 7 U@ ! 131 | 5 U@ 132 | 1 133 | + 134 | [ 5 ] DUP_U! 135 | 40 136 | > 137 | [ 0018 ] BRANCHZ 138 | 139 | EXIT [ 0019 ] LABEL 140 | ; 141 | 142 | : main 143 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 144 | 145 | 1 146 | [ 0032 ADD_INDEX ] >R 147 | 148 | [ 0032 ] LABEL 149 | 150 | -64 FP+! 151 | Initrand 152 | 64 FP+! 153 | 154 | ima 155 | 156 | -64 FP+! 157 | Initmatrix 158 | 64 FP+! 159 | 160 | imb 161 | 162 | -64 FP+! 163 | Initmatrix 164 | 64 FP+! 165 | 166 | 1 167 | [ 0031 ADD_INDEX ] >R 168 | 169 | [ 0031 ] LABEL 170 | 171 | 1 172 | 2 U! 173 | [ 0031 ] INDEX 174 | 82 175 | * 176 | 3 U! 177 | 178 | [ 0030 ] LABEL 179 | 2 U@ 180 | 2* 181 | [ imr ] SYMBOL_+ 182 | 2 U@ 183 | [ 2 ] MEM_ARG! 184 | 3 U@ + 185 | ima 186 | imb 187 | [ 0031 ] INDEX 188 | 189 | -64 FP+! 190 | Innerproduct 191 | 64 FP+! 192 | 2 U@ 193 | 1 194 | + 195 | [ 2 ] DUP_U! 196 | 40 197 | > 198 | [ 0030 ] BRANCHZ 199 | 200 | [ 0033 ] LABEL 201 | R> 202 | 1 203 | + 204 | DUP_>R 205 | 40 206 | U> 207 | [ 0031 ] BRANCHZ 208 | [ 0031 DROP_INDEX ] R>DROP 209 | [ 0034 ] LABEL 210 | R> 211 | 1 212 | + 213 | DUP_>R 214 | dup . 215 | 24 216 | U> 217 | [ 0032 ] BRANCHZ 218 | [ 0032 DROP_INDEX ] R>DROP 219 | 220 | EXIT [ 0035 ] LABEL 221 | ; 222 | 223 | .( max 24) cr 224 | -------------------------------------------------------------------------------- /RTX2000/TESTS/queens.a.4th: -------------------------------------------------------------------------------- 1 | \ /* queens.c */ 2 | \ CESYS compiled version 3 | 4 | EMPTY 5 | : XY " DOS XY queens.a.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE tries 4 CELL- ALLOT 11 | 12 | 100 REG-ADDR $FFC0 AND UBR! 13 | 14 | : do_error ." Error in Queens." cr ; 15 | 16 | : Try 17 | 0 u! 1 u! 2 u! 3 u! 4 u! 5 u! 18 | tries @ $1 + tries ! 19 | $0 6 u! 20 | $0 1 u@ ! 21 | 22 | [ 41 ] label 23 | 1 u@ @ 0= 1 and 24 | dup [ 43 ] branchz 25 | drop 26 | 27 | 6 u@ $8 <> 1 and 28 | [ 43 ] label 29 | [ 42 ] branchz 30 | 31 | 6 u@ $1 + 6 u! 32 | $0 1 u@ ! 33 | 3 u@ 6 u@ 2* + @ dup 34 | [ 45 ] branchz 35 | drop 36 | 37 | 2 u@ 0 u@ 6 u@ + 2* + @ 38 | 39 | [ 45 ] label 40 | dup 41 | [ 46 ] branchz 42 | drop 43 | 4 u@ 0 u@ 6 u@ - $7 + 2* + @ 44 | 45 | [ 46 ] label 46 | [ 44 ] branchz 47 | 6 u@ 5 u@ 0 u@ 2* + ! 48 | $0 3 u@ 6 u@ 2* + ! 49 | $0 2 u@ 0 u@ 6 u@ + 2* + ! 50 | $0 4 u@ 0 u@ 6 u@ - 51 | $7 + 2* + ! $8 0 u@ 52 | > 1 and 53 | [ 47 ] branchz 54 | 55 | 5 u@ 4 u@ 3 u@ 2 u@ 1 u@ 0 u@ $1 + 56 | 17 g@ 64 + 17 g! 57 | RECURSE 17 g@ 64 - 17 g! 58 | 1 u@ @ 0= 1 and 59 | [ 48 ] branchz 60 | 61 | $ffff 3 u@ 6 u@ 2* + ! 62 | $ffff 2 u@ 0 u@ 6 u@ + 2* + ! 63 | $ffff 4 u@ 0 u@ 6 u@ - $7 + 2* + ! 64 | 65 | [ 48 ] label 66 | [ 49 ] branch 67 | 68 | [ 47 ] label 69 | $ffff 1 u@ ! 70 | 71 | [ 49 ] label 72 | [ 44 ] label 73 | [ 41 ] branch 74 | 75 | [ 42 ] label ; 76 | 77 | 78 | : Doit 79 | $fff9 0 u! 80 | 81 | [ 51 ] label 82 | 0 u@ $10 <= 1 and 83 | [ 52 ] branchz 84 | 85 | $1 0 u@ <= 1 and dup 86 | [ 54 ] branchz 87 | drop 88 | 89 | 0 u@ $8 <= 1 and 90 | [ 54 ] label 91 | [ 53 ] branchz 92 | 93 | $ffff 4 17 g@ + 0 u@ 2* + ! 94 | 95 | [ 53 ] label 96 | $2 0 u@ <= 1 and 97 | [ 55 ] branchz 98 | 99 | $ffff 22 17 g@ + 0 u@ 2* + ! 100 | 101 | [ 55 ] label 102 | 0 u@ $7 <= 1 and 103 | [ 56 ] branchz 104 | 105 | $ffff 56 17 g@ + 0 u@ $7 + 2* + ! 106 | 107 | [ 56 ] label 108 | 0 u@ $1 + 0 u! 109 | [ 51 ] branch 110 | 111 | [ 52 ] label 112 | 86 17 g@ + 113 | 56 17 g@ + 114 | 4 17 g@ + 115 | 22 17 g@ + 116 | 2 17 g@ + 117 | $1 118 | 17 g@ 128 + 17 g! 119 | Try 120 | 17 g@ 128 - 17 g! 121 | 1 u@ 0= 1 and 122 | [ 57 ] branchz 123 | 124 | 17 g@ 128 + 17 g! 125 | do_error 126 | 17 g@ 128 - 17 g! 127 | tries @ $3e8 + tries ! 128 | 129 | [ 57 ] label ; 130 | 131 | : main 132 | 100 REG-ADDR $FFC0 AND UBR! $1 0 u! 133 | 134 | [ 59 ] label 135 | 0 u@ 136 | dup . 137 | $9c4 <= 1 and 138 | [ 60 ] branchz 139 | 140 | $0 tries ! 141 | 17 g@ 64 + 17 g! 142 | Doit 143 | 17 g@ 64 - 17 g! 144 | tries @ $71 <> 1 and 145 | [ 62 ] branchz 146 | 147 | 17 g@ 64 + 17 g! 148 | do_error 149 | 17 g@ 64 - 17 g! 150 | 151 | [ 62 ] label 152 | [ 61 ] label 153 | 0 u@ $1 + 0 u! 154 | [ 59 ] branch 155 | 156 | [ 60 ] label ; 157 | 158 | .( max ) $9c4 . cr 159 | -------------------------------------------------------------------------------- /RTX2000/TESTS/towers.c: -------------------------------------------------------------------------------- 1 | 2 | /* towers.c */ 3 | /* from Stanford benchmark suite */ 4 | /* modified for reasonable 16-bit operation */ 5 | 6 | #include 7 | /* #include */ 8 | /* Towers */ 9 | #define maxcells 18 10 | 11 | #define stackrange 3 12 | /* cellcursor = 0..maxcells; */ 13 | struct element { 14 | int discsize; 15 | int next; 16 | }; 17 | #define true 1 18 | #define false 0 19 | 20 | /* Towers */ 21 | int stack[stackrange+1]; 22 | struct element cellspace[maxcells+1]; 23 | int freelist, movesdone; 24 | 25 | /* Program to Solve the Towers of Hanoi */ 26 | 27 | static void do_error() 28 | { printf (" Error in Towers.\n"); } 29 | 30 | static void Error (emsg) char *emsg; 31 | { 32 | printf(" Error in Towers: %s\n",emsg); 33 | }; 34 | 35 | static void Makenull (s) 36 | { 37 | stack[s]=0; 38 | }; 39 | 40 | static int Getelement () 41 | { 42 | int temp; 43 | if ( freelist>0 ) 44 | { 45 | temp = freelist; 46 | freelist = cellspace[freelist].next; 47 | } 48 | else 49 | Error("out of space "); 50 | return (temp); 51 | }; 52 | 53 | static void Push(i,s) int i, s; 54 | { 55 | int errorfound, localel; 56 | errorfound=false; 57 | if ( stack[s] > 0 ) 58 | if ( cellspace[stack[s]].discsize<=i ) 59 | { 60 | errorfound=true; 61 | Error("disc size error"); 62 | }; 63 | if ( ! errorfound ) 64 | { 65 | localel=Getelement(); 66 | cellspace[localel].next=stack[s]; 67 | stack[s]=localel; 68 | cellspace[localel].discsize=i; 69 | } 70 | }; 71 | 72 | static void Init (s,n) int s, n; 73 | { 74 | int discctr; 75 | Makenull(s); 76 | for ( discctr = n; discctr >= 1; discctr-- ) 77 | Push(discctr,s); 78 | }; 79 | 80 | static int Pop (s) int s; 81 | { 82 | int temp, temp1; 83 | if ( stack[s] > 0 ) 84 | { 85 | temp1 = cellspace[stack[s]].discsize; 86 | temp = cellspace[stack[s]].next; 87 | cellspace[stack[s]].next=freelist; 88 | freelist=stack[s]; 89 | stack[s]=temp; 90 | return (temp1); 91 | } 92 | else 93 | Error("nothing to pop "); 94 | }; 95 | 96 | static void Move (s1,s2) int s1, s2; 97 | { 98 | /* printf("Move %d -> %d\n",s1,s2); */ 99 | Push(Pop(s1),s2); 100 | movesdone=movesdone+1; 101 | }; 102 | 103 | static void tower(i,j,k) int i,j,k; 104 | { 105 | int other; 106 | if ( k==1 ) 107 | Move(i,j); 108 | else 109 | { 110 | other=6-i-j; 111 | tower(i,other,k-1); 112 | Move(i,j); 113 | tower(other,j,k-1); 114 | } 115 | }; 116 | 117 | 118 | void main () { /* Towers */ 119 | int i, iter; 120 | for (iter = 0 ; iter < 35 ; iter++ ) 121 | { 122 | for ( i=1; i <= maxcells; i++ ) 123 | cellspace[i].next=i-1; 124 | freelist=maxcells; 125 | Init(1,14); 126 | Makenull(2); 127 | Makenull(3); 128 | movesdone=0; 129 | tower(1,2,14); 130 | if ( movesdone != 16383 ) 131 | do_error(); 132 | } 133 | }; /* Towers */ 134 | -------------------------------------------------------------------------------- /RTX2000/TESTS/xtowers.c: -------------------------------------------------------------------------------- 1 | /* towers.c */ 2 | /* from Stanford benchmark suite */ 3 | /* modified for reasonable 16-bit operation */ 4 | /* Hand-optimized for best C performance by Phil Koopman */ 5 | 6 | #include 7 | 8 | /* Towers */ 9 | #define maxcells 18 10 | 11 | #define stackrange 3 12 | /* cellcursor = 0..maxcells; */ 13 | struct element { 14 | int discsize; 15 | int next; 16 | }; 17 | #define true 1 18 | #define false 0 19 | 20 | /* Towers */ 21 | int stack[stackrange+1]; 22 | struct element cellspace[maxcells+1]; 23 | int freelist, movesdone; 24 | 25 | /* Program to Solve the Towers of Hanoi */ 26 | 27 | static void do_error() 28 | { puts (" Error in Towers.\n"); } 29 | 30 | static void Error (emsg) char *emsg; 31 | { 32 | printf(" Error in Towers: %s\n",emsg); 33 | }; 34 | 35 | void Makenull (int *s) 36 | { 37 | *s=0; 38 | }; 39 | 40 | int Getelement () 41 | { 42 | int temp; 43 | if ( freelist>0 ) 44 | { 45 | temp = freelist; 46 | freelist = cellspace[freelist].next; 47 | return(temp); 48 | } 49 | else 50 | Error("out of space "); 51 | return (temp); 52 | }; 53 | 54 | static void Push(i,s) int i, *s; 55 | { 56 | int errorfound, localel; 57 | int s_val; 58 | errorfound=false; 59 | 60 | s_val = *s; 61 | if ( s_val > 0 ) 62 | if ( cellspace[s_val].discsize<=i ) 63 | { 64 | errorfound=true; 65 | Error("disc size error"); 66 | }; 67 | if ( ! errorfound ) 68 | { 69 | localel=Getelement(); 70 | cellspace[localel].next=s_val; 71 | *s=localel; 72 | cellspace[localel].discsize=i; 73 | } 74 | }; 75 | 76 | static void Init (s,n) int *s, n; 77 | { 78 | int discctr; 79 | Makenull(s); 80 | for ( discctr = n; discctr >= 1; discctr-- ) 81 | Push(discctr,s); 82 | }; 83 | 84 | static int Pop (s) int *s; 85 | { 86 | int temp, temp1; 87 | if ( *s > 0 ) 88 | { 89 | temp1 = cellspace[*s].discsize; 90 | temp = cellspace[*s].next; 91 | cellspace[*s].next=freelist; 92 | freelist=*s; 93 | *s=temp; 94 | return (temp1); 95 | } 96 | else 97 | { Error("nothing to pop "); 98 | return(0); 99 | } 100 | }; 101 | 102 | static void Move (s1,s2) int *s1, *s2; 103 | { 104 | /* printf("Move %d -> %d\n",s1,s2); */ 105 | Push(Pop(s1),s2); 106 | movesdone=movesdone+1; 107 | }; 108 | 109 | static void tower(i,j,k) int i,j,k; 110 | { 111 | int other; 112 | if ( k==1 ) 113 | Move(&stack[i],&stack[j]); 114 | else 115 | { 116 | other=6-i-j; 117 | tower(i,other,k-1); 118 | Move(&stack[i],&stack[j]); 119 | tower(other,j,k-1); 120 | } 121 | }; 122 | 123 | 124 | void main () { /* Towers */ 125 | int i, iter; 126 | for (iter = 0 ; iter < 35 ; iter++ ) 127 | { 128 | for ( i=1; i <= maxcells; i++ ) 129 | cellspace[i].next=i-1; 130 | freelist=maxcells; 131 | Init(&stack[1],14); 132 | Makenull(&stack[2]); 133 | Makenull(&stack[3]); 134 | movesdone=0; 135 | tower(1,2,14); 136 | if ( movesdone != 16383 ) 137 | do_error(); 138 | } 139 | }; /* Towers */ 140 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bubble.c.4th: -------------------------------------------------------------------------------- 1 | \ /* bubble.c */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY bubble.c.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE seed 4 CELL- ALLOT 11 | VARIABLE top 4 CELL- ALLOT 12 | VARIABLE littlest 4 CELL- ALLOT 13 | VARIABLE biggest 4 CELL- ALLOT 14 | VARIABLE sortlist 10004 CELL- ALLOT 15 | 16 | : .DATA 17 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 18 | 19 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 20 | 21 | : do_error 22 | ." Error3 in Bubble." CR 23 | ; 24 | 25 | : Initrand 26 | 9219 27 | seed 28 | ! 29 | ; 30 | 31 | : Rand 32 | seed 33 | @ 34 | 1309 35 | * 36 | 13849 37 | + 38 | seed 39 | TUCK_! 40 | ; 41 | 42 | : bInitarr 43 | 44 | Initrand 45 | 46 | 0 47 | biggest 48 | ! 49 | 0 50 | littlest 51 | ! 52 | 53 | 1 54 | [ 0011 ADD_INDEX ] >R 55 | 56 | [ 0011 ] LABEL 57 | 58 | Rand 59 | 60 | 32767 61 | - 62 | 63 | [ 0011 ] INDEX 64 | 2* 65 | [ sortlist ] SYMBOL_+ 66 | 67 | ! 68 | 69 | [ 0011 ] INDEX 70 | 2* 71 | [ sortlist ] SYMBOL_+ 72 | @ 73 | biggest 74 | @ 75 | > 76 | [ 008 ] BRANCHZ 77 | [ 0011 ] INDEX 2* 78 | [ sortlist ] SYMBOL_+ 79 | @ 80 | biggest 81 | ! 82 | [ 007 ] BRANCH 83 | 84 | [ 008 ] LABEL 85 | [ 0011 ] INDEX 86 | 2* 87 | [ sortlist ] SYMBOL_+ 88 | @ 89 | littlest 90 | @ 91 | < 92 | [ 107 ] BRANCHZ 93 | [ 0011 ] INDEX 94 | 2* 95 | [ sortlist ] SYMBOL_+ 96 | @ 97 | littlest 98 | ! 99 | [ 007 ] LABEL 100 | [ 107 ] LABEL 101 | 102 | R> 103 | 1 104 | + 105 | DUP_>R 106 | 500 107 | U> 108 | [ 0011 ] BRANCHZ 109 | [ 0011 DROP_INDEX ] R>DROP 110 | 111 | EXIT [ 0012 ] LABEL 112 | ; 113 | 114 | : main 115 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 116 | 117 | 1 118 | 2 U! 119 | 120 | [ 121 | sortlist 122 | 2 123 | + 124 | ] LITERAL 125 | 3 U! 126 | 127 | [ 0026 ] LABEL 128 | 129 | bInitarr 130 | 131 | 500 132 | top 133 | TUCK_! 134 | 135 | 1 136 | > 137 | [ 0028 ] BRANCHZ 138 | 139 | [ 0023 ] LABEL 140 | 141 | 1 142 | 143 | top 144 | @ 145 | 1_PICK 146 | > 147 | [ 0027 ] BRANCHZ 148 | 149 | [ 0022 ] LABEL 150 | 151 | 0_PICK 152 | 2* 153 | [ sortlist ] SYMBOL_+ 154 | 1_PICK 155 | 2* 156 | 3 U@ + 157 | @_SWAP 158 | @_SWAP 159 | > 160 | [ 0021 ] BRANCHZ 161 | 162 | 0_PICK 163 | 2* 164 | [ sortlist ] SYMBOL_+ 165 | @ 166 | 167 | 1_PICK 168 | 2* 169 | [ sortlist ] SYMBOL_+ 170 | 2_PICK 171 | 2* 172 | 3 U@ + 173 | @_SWAP 174 | ! 175 | 176 | 1_PICK 177 | 2* 178 | 3 U@ + 179 | ! 180 | 181 | [ 0021 ] LABEL 182 | 1 183 | + 184 | top 185 | @ 186 | 1_PICK 187 | <= 188 | [ 0022 ] BRANCHZ 189 | 190 | DROP 191 | 192 | [ 0027 ] LABEL 193 | 194 | top 195 | @ -1 + 0_PICK top ! 196 | 1 197 | <= 198 | [ 0023 ] BRANCHZ 199 | 200 | [ 0028 ] LABEL 201 | 202 | 3 U@ 203 | @ 204 | littlest 205 | @ 206 | - 207 | [ 0025 ] BRANCHNZ 208 | [ 209 | sortlist 210 | 1000 211 | + 212 | ] LITERAL 213 | @ 214 | biggest 215 | @ 216 | - 217 | [ 0016 ] BRANCHZ 218 | [ 0025 ] LABEL 219 | do_error 220 | 221 | [ 0016 ] LABEL 222 | 2 U@ 223 | 1 224 | + 225 | [ 2 ] DUP_U! 226 | dup . 29 227 | > 228 | [ 0026 ] BRANCHZ 229 | 230 | EXIT [ 0029 ] LABEL 231 | ; 232 | 233 | .( max 29) cr 234 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/queens.ces: -------------------------------------------------------------------------------- 1 | 2 | \ /* queens.c */ 3 | \ /* from Stanford benchmark suite */ 4 | \ /* modified for reasonable 16-bit operation */ 5 | 6 | \ CESYS compiled version 7 | 8 | EMPTY 9 | : XY " DOS XY queens.ces" EVALUATE ; 10 | 11 | DECIMAL 12 | load gnutool.4th 13 | 14 | \ #define true -1 15 | \ #define false 0 16 | 17 | \ int tries ; 18 | VARIABLE tries 4 CELL- ALLOT 19 | 20 | 100 REG-ADDR $FFC0 AND UBR! 21 | 22 | \ static void do_error() { 23 | 64 frame_size ! 24 | : do_error ( FUNC ) ( 3 top> empty ) 25 | \ { printf (" Error in Queens.\n"); } 26 | ." Error in Queens." cr ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 27 | 28 | : Try 29 | 0 u! 1 u! 2 u! 3 u! 4 u! 5 u! 30 | tries @ $1 + tries ! 31 | $0 6 u! 32 | $0 1 u@ ! 33 | 34 | [ 41 ] label 35 | 1 u@ @ 0= 1 and 36 | dup [ 43 ] branchz 37 | drop 38 | 39 | 6 u@ $8 <> 1 and 40 | [ 43 ] label 41 | [ 42 ] branchz 42 | 43 | 6 u@ $1 + 6 u! 44 | $0 1 u@ ! 45 | 3 u@ 6 u@ 2* + @ dup 46 | [ 45 ] branchz 47 | drop 48 | 49 | 2 u@ 0 u@ 6 u@ + 2* + @ 50 | 51 | [ 45 ] label 52 | dup 53 | [ 46 ] branchz 54 | drop 55 | 4 u@ 0 u@ 6 u@ - $7 + 2* + @ 56 | 57 | [ 46 ] label 58 | [ 44 ] branchz 59 | 6 u@ 5 u@ 0 u@ 2* + ! 60 | $0 3 u@ 6 u@ 2* + ! 61 | $0 2 u@ 0 u@ 6 u@ + 2* + ! 62 | $0 4 u@ 0 u@ 6 u@ - 63 | $7 + 2* + ! $8 0 u@ 64 | > 1 and 65 | [ 47 ] branchz 66 | 67 | 5 u@ 4 u@ 3 u@ 2 u@ 1 u@ 0 u@ $1 + 68 | 17 g@ 64 + 17 g! 69 | RECURSE \ Try 70 | 17 g@ 64 - 17 g! 71 | 1 u@ @ 0= 1 and 72 | [ 48 ] branchz 73 | 74 | $ffff 3 u@ 6 u@ 2* + ! 75 | $ffff 2 u@ 0 u@ 6 u@ + 2* + ! 76 | $ffff 4 u@ 0 u@ 6 u@ - $7 + 2* + ! 77 | 78 | [ 48 ] label 79 | [ 49 ] branch 80 | 81 | [ 47 ] label 82 | $ffff 1 u@ ! 83 | 84 | [ 49 ] label 85 | [ 44 ] label 86 | [ 41 ] branch 87 | 88 | [ 42 ] label ; 89 | 90 | 91 | : Doit 92 | $fff9 0 u! 93 | 94 | [ 51 ] label 95 | 0 u@ $10 <= 1 and 96 | [ 52 ] branchz 97 | 98 | $1 0 u@ <= 1 and dup 99 | [ 54 ] branchz 100 | drop 101 | 102 | 0 u@ $8 <= 1 and 103 | [ 54 ] label 104 | [ 53 ] branchz 105 | 106 | $ffff 4 17 g@ + 0 u@ 2* + ! 107 | 108 | [ 53 ] label 109 | $2 0 u@ <= 1 and 110 | [ 55 ] branchz 111 | 112 | $ffff 22 17 g@ + 0 u@ 2* + ! 113 | 114 | [ 55 ] label 115 | 0 u@ $7 <= 1 and 116 | [ 56 ] branchz 117 | 118 | $ffff 56 17 g@ + 0 u@ $7 + 2* + ! 119 | 120 | [ 56 ] label 121 | 0 u@ $1 + 0 u! 122 | [ 51 ] branch 123 | 124 | [ 52 ] label 125 | 86 17 g@ + 126 | 56 17 g@ + 127 | 4 17 g@ + 128 | 22 17 g@ + 129 | 2 17 g@ + 130 | $1 131 | 17 g@ 128 + 17 g! 132 | Try 133 | 17 g@ 128 - 17 g! 134 | 1 u@ 0= 1 and 135 | [ 57 ] branchz 136 | 137 | 17 g@ 128 + 17 g! 138 | do_error 139 | 17 g@ 128 - 17 g! 140 | tries @ $3e8 + tries ! 141 | 142 | [ 57 ] label ; 143 | 144 | : main 145 | 100 REG-ADDR $FFC0 AND UBR! $1 0 u! 146 | 147 | [ 59 ] label 148 | 0 u@ 149 | dup . 150 | $9c4 <= 1 and 151 | [ 60 ] branchz 152 | 153 | $0 tries ! 154 | 17 g@ 64 + 17 g! 155 | Doit 156 | 17 g@ 64 - 17 g! 157 | tries @ $71 <> 1 and 158 | [ 62 ] branchz 159 | 160 | 17 g@ 64 + 17 g! 161 | do_error 162 | 17 g@ 64 - 17 g! 163 | 164 | [ 62 ] label 165 | [ 61 ] label 166 | 0 u@ $1 + 0 u! 167 | [ 59 ] branch 168 | 169 | [ 60 ] label ; 170 | -------------------------------------------------------------------------------- /RTX2000/TESTS/quick.a.4th: -------------------------------------------------------------------------------- 1 | \ /* quick.c */ 2 | \ CESYS C version 3 | 4 | EMPTY 5 | : XY " DOS XY quick.a.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | 100 REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE seed 4 CELL- ALLOT 13 | VARIABLE top 4 CELL- ALLOT 14 | VARIABLE littlest 4 CELL- ALLOT 15 | VARIABLE biggest 4 CELL- ALLOT 16 | VARIABLE sortlist 10004 CELL- ALLOT 17 | 18 | : .DATA 19 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 20 | 21 | : do_error ." Error in Quick." cr ; 22 | 23 | 24 | : Initrand 25 | $2403 seed ! ; 26 | 27 | : Rand 28 | seed @ $51d * $3619 + seed ! 29 | seed @ ; 30 | 31 | : Initarr 32 | 17 g@ 64 + 17 g! 33 | Initrand 34 | 17 g@ 64 - 17 g! 35 | $0 biggest ! 36 | $0 littlest ! 37 | $1 0 u! 38 | 39 | [ 43 ] label 40 | 0 u@ $1388 <= 1 and 41 | [ 44 ] branchz 42 | 43 | 17 g@ 64 + 17 g! 44 | Rand 45 | 17 g@ 64 - 17 g! 46 | 1 u! 47 | 1 u@ $8064 + sortlist 0 u@ 2* + ! 48 | sortlist 0 u@ 2* + @ biggest @ > 1 and 49 | [ 46 ] branchz 50 | 51 | sortlist 0 u@ 2* + @ biggest ! 52 | [ 47 ] branch 53 | 54 | [ 46 ] label 55 | littlest @ sortlist 0 u@ 2* + @ > 1 and 56 | [ 48 ] branchz 57 | 58 | sortlist 0 u@ 2* + @ littlest ! 59 | 60 | [ 48 ] label 61 | [ 47 ] label 62 | [ 45 ] label 63 | 0 u@ $1 + 0 u! 64 | [ 43 ] branch 65 | 66 | [ 44 ] label 67 | ; 68 | 69 | : Quicksort 70 | 0 u! 1 u! 2 u! 71 | 1 u@ 3 u! 2 u@ 4 u! 72 | 0 u@ 1 u@ 2 u@ + $2 / 2* + @ 5 u! 73 | 74 | [ 50 ] label 75 | [ 53 ] label 76 | 77 | 5 u@ 0 u@ 3 u@ 2* + @ > 1 and 78 | [ 54 ] branchz 79 | 80 | 3 u@ $1 + 3 u! 81 | [ 53 ] branch 82 | 83 | [ 54 ] label 84 | [ 55 ] label 85 | 0 u@ 4 u@ 2* + @ 5 u@ > 1 and 86 | [ 56 ] branchz 87 | 88 | 4 u@ $ffff + 4 u! 89 | [ 55 ] branch 90 | 91 | [ 56 ] label 92 | 3 u@ 4 u@ <= 1 and 93 | [ 57 ] branchz 94 | 95 | 0 u@ 3 u@ 2* + @ 6 u! 96 | 0 u@ 4 u@ 2* + @ 0 u@ 3 u@ 2* + ! 97 | 6 u@ 0 u@ 4 u@ 2* + ! 98 | 3 u@ $1 + 3 u! 99 | 4 u@ $ffff + 4 u! 100 | 101 | [ 57 ] label 102 | [ 52 ] label 103 | 3 u@ 4 u@ <= 1 and 104 | [ 58 ] branchz 105 | 106 | [ 50 ] branch 107 | 108 | [ 58 ] label 109 | [ 51 ] label 110 | 4 u@ 1 u@ > 1 and 111 | [ 59 ] branchz 112 | 113 | 4 u@ 1 u@ 0 u@ 114 | 17 g@ 64 + 17 g! 115 | RECURSE 17 g@ 64 - 17 g! 116 | 117 | [ 59 ] label 118 | 2 u@ 3 u@ > 1 and 119 | [ 60 ] branchz 120 | 121 | 2 u@ 3 u@ 0 u@ 122 | 17 g@ 64 + 17 g! 123 | RECURSE 17 g@ 64 - 17 g! 124 | 125 | [ 60 ] label 126 | ; 127 | 128 | : main 129 | 100 REG-ADDR $FFC0 AND UBR! $0 0 u! 130 | 131 | [ 62 ] label 132 | $32 0 u@ 133 | dup . 134 | > 1 and 135 | [ 63 ] branchz 136 | 137 | 17 g@ 64 + 17 g! 138 | Initarr 139 | 17 g@ 64 - 17 g! 140 | 141 | $1388 $1 sortlist 142 | 17 g@ 64 + 17 g! 143 | Quicksort 144 | 17 g@ 64 - 17 g! 145 | 146 | [ sortlist 2 + ] literal @ littlest @ <> 1 and dup 147 | [ 67 ] branchz 148 | 149 | [ 66 ] branch 150 | 151 | [ 67 ] label 152 | drop 153 | [ sortlist 10000 + ] literal @ biggest @ <> 1 and 154 | 155 | [ 66 ] label 156 | [ 65 ] branchz 157 | 158 | 17 g@ 64 + 17 g! 159 | do_error 160 | 17 g@ 64 - 17 g! 161 | 162 | [ 65 ] label 163 | [ 64 ] label 164 | 165 | 0 u@ $1 + 0 u! 166 | [ 62 ] branch 167 | 168 | [ 63 ] label ; 169 | 170 | .( max ) $32 . cr 171 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/bubble.ces: -------------------------------------------------------------------------------- 1 | \ /* bubble.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | \ CESYS C generated code 6 | 7 | EMPTY 8 | : XY " DOS XY bubble.ces" EVALUATE ; 9 | 10 | DECIMAL 11 | load gnutool.4th 12 | 13 | \ int seed ; 14 | 15 | VARIABLE seed 4 CELL- ALLOT 16 | 17 | \ int sortlist[sortelements+1], 18 | \ biggest, littlest, top; 19 | VARIABLE top 4 CELL- ALLOT 20 | 21 | VARIABLE littlest 4 CELL- ALLOT 22 | 23 | VARIABLE biggest 4 CELL- ALLOT 24 | 25 | VARIABLE sortlist 10004 CELL- ALLOT 26 | 27 | : .DATA 28 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 29 | 30 | 100 REG-ADDR $FFC0 AND UBR! 31 | 32 | \ #define sortelements 5000 33 | \ #define srtelements 500 34 | \ #define false 0 35 | \ #define true 1 36 | 37 | \ static void do_error() 38 | \ { printf ( "Error3 in Bubble.\n"); } 39 | : do_error ( FUNC ) ( 3 top> empty ) 40 | ." Error3 in Bubble." CR 41 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 42 | 43 | 44 | : initrand 45 | $2403 seed ! ; 46 | 47 | : rand 48 | seed @ 49 | $51d 50 | * 51 | $3619 + 52 | seed ! 53 | seed @ 54 | ; 55 | 56 | : bInitarr 57 | 17 g@ 64 + 17 g! 58 | initrand 59 | 17 g@ 64 - 17 g! 60 | $0 biggest ! 61 | $0 littlest ! 62 | $1 0 u! 63 | 64 | 65 | [ 43 ] label 66 | 67 | 0 u@ $1f4 <= 68 | 1 and 69 | [ 44 ] branchz 70 | 71 | 17 g@ 64 + 17 g! 72 | rand 73 | 17 g@ 64 - 17 g! 74 | 1 u! 75 | 1 u@ $8001 + 76 | sortlist 0 u@ 2* + ! 77 | sortlist 0 u@ 2* + @ 78 | biggest @ > 79 | 1 and 80 | [ 46 ] branchz 81 | 82 | sortlist 0 u@ 2* + @ 83 | biggest ! 84 | [ 47 ] branch 85 | 86 | [ 46 ] label 87 | littlest @ 88 | sortlist 0 u@ 2* + @ 89 | > 1 and 90 | [ 48 ] branchz 91 | sortlist 0 u@ 2* + @ 92 | littlest ! 93 | 94 | [ 48 ] label 95 | 96 | [ 47 ] label 97 | 98 | [ 45 ] label 99 | 0 u@ $1 + 0 u! 100 | [ 43 ] branch 101 | 102 | [ 44 ] label 103 | ; 104 | 105 | : main 106 | 107 | 100 REG-ADDR $FFC0 AND UBR! $1 2 u! 108 | 109 | [ 50 ] label 110 | $1e 111 | 2 u@ 112 | dup . 113 | > 1 and 114 | [ 51 ] branchz 115 | 17 g@ 64 + 17 g! 116 | bInitarr 117 | 17 g@ 64 - 17 g! 118 | $1f4 top ! 119 | 120 | [ 53 ] label 121 | top @ $1 > 1 and 122 | [ 54 ] branchz 123 | $1 0 u! 124 | 125 | [ 55 ] label 126 | top @ 0 u@ > 1 and 127 | [ 56 ] branchz 128 | sortlist 0 u@ 2* + @ 129 | sortlist 0 u@ $1 + 2* + @ 130 | > 1 and 131 | [ 57 ] branchz 132 | sortlist 0 u@ 2* + @ 1 u! 133 | sortlist 0 u@ $1 + 2* + @ 134 | sortlist 0 u@ 2* + ! 135 | 1 u@ sortlist 0 u@ $1 + 2* + ! 136 | 137 | [ 57 ] label 138 | 0 u@ $1 + 0 u! 139 | [ 55 ] branch 140 | 141 | [ 56 ] label 142 | top @ $ffff + top ! 143 | [ 53 ] branch 144 | 145 | [ 54 ] label 146 | [ sortlist 2 + ] literal @ 147 | littlest @ 148 | <> 1 and dup 149 | [ 60 ] branchz 150 | [ 59 ] branch 151 | 152 | [ 60 ] label 153 | drop [ sortlist 1000 + ] literal @ biggest @ 154 | <> 1 and 155 | [ 59 ] label 156 | [ 58 ] branchz 157 | 17 g@ 64 + 17 g! 158 | do_error 159 | 17 g@ 64 - 17 g! 160 | 161 | [ 58 ] label 162 | 163 | [ 52 ] label 164 | 2 u@ $1 + 2 u! 165 | [ 50 ] branch 166 | 167 | [ 51 ] label 168 | ; 169 | 170 | -------------------------------------------------------------------------------- /SIM2000/decode.h: -------------------------------------------------------------------------------- 1 | /* DECODE.H -- RTX 2000 Instruction Set Simulator */ 2 | /* (C) Copyright 1990 Harris Semiconductor, all rights reserved */ 3 | /* By: Phil Koopman Jr. 9/x/90 */ 4 | 5 | /* This file contains the enum definition for result of 6 | * instruction cracking operations, and prototypes for 7 | * the decoding subroutine. 8 | */ 9 | 10 | #ifndef DECODE_H 11 | #define DECODE_H 12 | 13 | #define NIL 0 14 | 15 | typedef enum machine_op 16 | { 17 | OP_CALL, 18 | OP_0BRANCH, 19 | OP_ALU, 20 | OP_ASIC_STREAM_MAC, 21 | OP_BRANCH, 22 | OP_BS_ONE_TICK, 23 | OP_BS_TICK, 24 | OP_BUSLASH_TICK, 25 | OP_BUSTAR_TICK, 26 | OP_BUSTAR_TICK_TICK, 27 | OP_CLEAR_ACC, 28 | OP_CLEAR_SOFTINT, 29 | OP_C_TICK, 30 | OP_DDUP_ALU, 31 | OP_DDUP_STORE, 32 | OP_DDUP_STORE_WITH_ALU, 33 | OP_DEC_RX, 34 | OP_DROP, 35 | OP_DROP_DUP, 36 | OP_DROP_LIT, 37 | OP_DROP_SHORT_LIT, 38 | OP_DSLL, 39 | OP_DSRA, 40 | OP_DSRL, 41 | OP_DUP, 42 | OP_DUP_FETCH_SWAP, 43 | OP_DUP_GSTORE, 44 | OP_DUP_USTORE, 45 | OP_FETCH, 46 | OP_FETCH_LIT, 47 | OP_FETCH_OVER_ALU, 48 | OP_FETCH_SWAP, 49 | OP_FETCH_SWAP_ALU, 50 | OP_FETCH_WITH_ALU, 51 | OP_GFETCH, 52 | OP_GFETCH_DROP, 53 | OP_GFETCH_OVER_ALU, 54 | OP_GFETCH_SWAP_ALU, 55 | OP_GSTORE, 56 | OP_INC_RX, 57 | OP_LIT, 58 | OP_LIT_OVER_ALU, 59 | OP_LIT_SWAP, 60 | OP_LIT_SWAP_ALU, 61 | OP_MAC, 62 | OP_MIXED_MAC, 63 | OP_MIXED_MULT, 64 | OP_MULT, 65 | OP_MULT_SUB, 66 | OP_NEXT, 67 | OP_NIP, 68 | OP_NIP_DUP, 69 | OP_NIP_DUP_FETCH_SWAP, 70 | OP_NIP_FETCH_LIT, 71 | OP_NIP_FETCH_WITH_ALU, 72 | OP_NORMALIZE, 73 | OP_OVER, 74 | OP_QDUP_0BRANCH, 75 | OP_RDR, 76 | OP_RESERVED, 77 | OP_RESERVED_STEP_MATH, 78 | OP_RTR, 79 | OP_R_TICK, 80 | OP_SELECT_CPR, 81 | OP_SELECT_DPR, 82 | OP_SET_SOFTINT, 83 | OP_SHIFT, 84 | OP_SHIFT_MAC_RIGHT, 85 | OP_SHORT_LIT, 86 | OP_SHORT_LIT_OVER_ALU, 87 | OP_SHORT_LIT_SWAP_ALU, 88 | OP_STAR_TICK, 89 | OP_STAR_TICK_TICK, 90 | OP_STORE, 91 | OP_STORE_LIT, 92 | OP_STREAM_MAC, 93 | OP_SWAP, 94 | OP_S_ONE_TICK, 95 | OP_S_TICK, 96 | OP_S_TICK_TICK, 97 | OP_TUCK_ALU, 98 | OP_TUCK_STORE, 99 | OP_TUCK_STORE_WITH_ALU, 100 | OP_TWO_STAR_TICK, 101 | OP_UFETCH, 102 | OP_UFETCH_OVER_ALU, 103 | OP_UFETCH_SWAP, 104 | OP_UFETCH_SWAP_ALU, 105 | OP_UMAC, 106 | OP_UMULT, 107 | OP_UNDER_ALU, 108 | OP_UNDER_STORE, 109 | OP_UNDER_STORE_LIT, 110 | OP_USLASH_ONE_TICK, 111 | OP_USLASH_ONE_TICK_TICK, 112 | OP_USLASH_TICK, 113 | OP_USLASH_TICK_TICK, 114 | OP_USTAR_TICK, 115 | OP_USTAR_TICK_TICK, 116 | OP_USTORE, 117 | OP_ZERO_EQUAL, 118 | DUMMY_LAST /* put here as a bounds check for initialization */ 119 | } machine_op ; 120 | 121 | /* Driver for instruction operation cracking. 122 | * Input: 16-bit RTX instruction 123 | * Output: enum for operation to be performed (exclusive of alu/shift op). 124 | */ 125 | extern machine_op decode(register int instruction); 126 | 127 | /* Compute branch target address 128 | * Input: instruction = 16-bit RTX instruction 129 | * address = 16-bit RTX address 130 | * Output: 16-bit RTX branch target address 131 | */ 132 | extern int target_addr(int instruction, int address); 133 | 134 | #endif 135 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bubble.b.4th: -------------------------------------------------------------------------------- 1 | \ /* bubble.c */ 2 | \ GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY bubble.b.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | 11 | VARIABLE seed 4 CELL- ALLOT 12 | 13 | VARIABLE top 4 CELL- ALLOT 14 | 15 | VARIABLE littlest 4 CELL- ALLOT 16 | 17 | VARIABLE biggest 4 CELL- ALLOT 18 | 19 | VARIABLE sortlist 10004 CELL- ALLOT 20 | 21 | : .DATA 22 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 23 | 24 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 25 | 26 | : do_error 27 | ." Error3 in Bubble." CR 28 | ; 29 | 30 | : Initrand 31 | 9219 32 | seed 33 | ! 34 | ; 35 | 36 | : Rand 37 | seed 38 | @ 39 | 1309 40 | * 41 | 13849 42 | + 43 | seed 44 | TUCK_! 45 | ; 46 | 47 | : bInitarr 48 | 49 | -64 FP+! 50 | Initrand 51 | 64 FP+! 52 | 53 | 0 54 | biggest 55 | ! 56 | 0 57 | littlest 58 | ! 59 | 60 | 1 61 | [ 0011 ADD_INDEX ] >R 62 | 63 | [ 0011 ] LABEL 64 | 65 | -64 FP+! 66 | Rand 67 | 64 FP+! 68 | 69 | [ 0011 ] INDEX 70 | 2* 71 | [ sortlist ] SYMBOL_+ 72 | SWAP 73 | 32767 74 | - 75 | SWAP ! 76 | 77 | [ 0011 ] INDEX 78 | 2* 79 | [ sortlist ] SYMBOL_+ 80 | @ 81 | biggest 82 | @ 83 | > 84 | [ 008 ] BRANCHZ 85 | [ 0011 ] INDEX 86 | 2* 87 | [ sortlist ] SYMBOL_+ 88 | @ 89 | biggest 90 | ! 91 | [ 007 ] BRANCH 92 | 93 | [ 008 ] LABEL 94 | [ 0011 ] INDEX 95 | 2* 96 | [ sortlist ] SYMBOL_+ 97 | @ 98 | littlest 99 | @ 100 | < 101 | [ 107 ] BRANCHZ 102 | [ 0011 ] INDEX 103 | 2* 104 | [ sortlist ] SYMBOL_+ 105 | @ 106 | littlest 107 | ! 108 | [ 007 ] LABEL 109 | [ 107 ] LABEL 110 | 111 | R> 112 | 1 113 | + 114 | DUP_>R 115 | 500 116 | U> 117 | [ 0011 ] BRANCHZ 118 | [ 0011 DROP_INDEX ] R>DROP 119 | 120 | EXIT [ 0012 ] LABEL 121 | ; 122 | 123 | : main 124 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 125 | 126 | 1 127 | 2 U! 128 | 129 | [ 130 | sortlist 131 | 2 132 | + 133 | ] LITERAL 134 | 3 U! 135 | 136 | [ 0026 ] LABEL 137 | 138 | -64 FP+! 139 | bInitarr 140 | 64 FP+! 141 | 142 | 500 143 | top 144 | TUCK_! 145 | 146 | 1 147 | > 148 | [ 0028 ] BRANCHZ 149 | 150 | [ 0023 ] LABEL 151 | 152 | 1 153 | 154 | top 155 | @_SWAP 156 | [ 4 ] DUP_U! 157 | > 158 | [ 0027 ] BRANCHZ 159 | 160 | [ 0022 ] LABEL 161 | 162 | 4 U@ 163 | 2* 164 | [ sortlist ] SYMBOL_+ 165 | 4 U@ 166 | 2* 167 | 3 U@ + 168 | @_SWAP 169 | @_SWAP 170 | > 171 | [ 0021 ] BRANCHZ 172 | 173 | 4 U@ 174 | 2* 175 | [ sortlist ] SYMBOL_+ 176 | @ 177 | 178 | 4 U@ 179 | 2* 180 | [ sortlist ] SYMBOL_+ 181 | 4 U@ 182 | 2* 183 | 3 U@ + 184 | @_SWAP 185 | ! 186 | 187 | 4 U@ 188 | 2* 189 | 3 U@ + 190 | ! 191 | 192 | [ 0021 ] LABEL 193 | 4 U@ 194 | 1 195 | + 196 | top 197 | @_SWAP 198 | [ 4 ] DUP_U! 199 | <= 200 | [ 0022 ] BRANCHZ 201 | 202 | [ 0027 ] LABEL 203 | 204 | -1 205 | top 206 | +! 207 | top 208 | @ 209 | 1 210 | <= 211 | [ 0023 ] BRANCHZ 212 | 213 | [ 0028 ] LABEL 214 | 215 | 3 U@ 216 | @ 217 | littlest 218 | @ 219 | - 220 | [ 0025 ] BRANCHNZ 221 | [ 222 | sortlist 223 | 1000 224 | + 225 | ] LITERAL 226 | @ 227 | biggest 228 | @ 229 | - 230 | [ 0016 ] BRANCHZ 231 | [ 0025 ] LABEL 232 | -64 FP+! 233 | do_error 234 | 64 FP+! 235 | 236 | [ 0016 ] LABEL 237 | 2 U@ 238 | 1 239 | + 240 | [ 2 ] DUP_U! 241 | dup . 242 | 29 243 | > 244 | [ 0026 ] BRANCHZ 245 | 246 | EXIT [ 0029 ] LABEL 247 | ; 248 | 249 | .( max 29) 250 | -------------------------------------------------------------------------------- /RTX2000/TESTS/quick.e.4th: -------------------------------------------------------------------------------- 1 | \ /* quick.c */ 2 | \ Improved source code assembler based on GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY quick.e.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE seed 4 CELL- ALLOT 13 | VARIABLE top 4 CELL- ALLOT 14 | VARIABLE littlest 4 CELL- ALLOT 15 | VARIABLE biggest 4 CELL- ALLOT 16 | VARIABLE sortlist 10004 CELL- ALLOT 17 | 18 | : .DATA 19 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 20 | 21 | : do_error 22 | ." Error in Quick." cr 23 | ; 24 | 25 | : Initrand 26 | 9219 seed ! ; 27 | 28 | : Rand 29 | seed @ 1309 * 13849 + seed TUCK_! ; 30 | 31 | 64 FRAME_SIZE ! 32 | : Initarr 33 | Initrand 34 | 0 biggest ! 35 | 0 littlest ! 36 | [ sortlist 2 + ] LITERAL 37 | 4999 FOR ( -- i ) 38 | Rand ( -- i temp ) 39 | 32668 - SWAP ( -- temp i ) 40 | [ $E0C0 , ] ( DDUP ! ) ( -- temp i ) 41 | OVER biggest @ > ( -- temp i flg ) 42 | IF ( -- temp i ) 43 | OVER biggest ! ( -- temp i ) 44 | ELSE ( -- temp i ) 45 | OVER littlest @ < ( -- temp i flg ) 46 | IF ( -- temp i ) 47 | OVER littlest ! ( -- temp i ) 48 | THEN ( -- temp i ) 49 | THEN ( -- temp i ) 50 | NIP 2 + ( -- i ) 51 | NEXT ( -- i ) 52 | DROP 53 | ; 54 | 55 | 64 FRAME_SIZE ! 56 | : Quicksort 57 | OVER 2 U! 58 | [ 3 ] DUP_U! 5 U! 59 | 6 U! 7 U! 60 | 2 U@ u2/ 3 U@ u2/ + -2 AND @ 4 U! 61 | 62 | 2 U@ ( -- i ) 63 | 5 U@ ( -- i j ) 64 | BEGIN ( -- i j ) 65 | SWAP ( -- j i ) 66 | BEGIN ( -- j i ) 67 | @+2 SWAP 4 U@ >= ( -- j i ) 68 | UNTIL ( -- j i ) 69 | 2 - SWAP ( -- i j ) 70 | BEGIN ( -- i j ) 71 | @-2 SWAP 4 U@ <= ( -- i j ) 72 | UNTIL ( -- i j ) 73 | 2 + ( -- i j ) 74 | OVER OVER U> ( -- i j flg ) 75 | IF ( -- i j ) 76 | -1 ( -- i j flg ) 77 | ELSE ( -- i j ) 78 | >R ( -- i ) 79 | @+0 ( -- *i i ) 80 | R> ( -- *i i j ) 81 | @+0 ( -- *i i *j j ) 82 | >R SWAP ( -- *i *j i ) 83 | !+2 ( -- *i i ) 84 | SWAP R> ( -- i *i j ) 85 | !-2 ( -- i j ) 86 | 0 ( -- i j flg ) 87 | THEN ( -- i j flg ) 88 | UNTIL ( -- i j ) 89 | 5 U! 2 U! 90 | 91 | 6 U@ 5 U@ U< 92 | IF 93 | 7 U@ 6 U@ 5 U@ 94 | -64 FP+! recurse 64 FP+! 95 | THEN 96 | 2 U@ 3 U@ U< 97 | IF 98 | 7 U@ 2 U@ 3 U@ 99 | -64 FP+! recurse 64 FP+! 100 | THEN 101 | ; 102 | 103 | 64 FRAME_SIZE ! 104 | : main 105 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 106 | 0 2 U! 107 | [ sortlist 2 + ] LITERAL 3 U! 108 | BEGIN 109 | -64 FP+! 110 | Initarr 111 | 64 FP+! 112 | sortlist 113 | [ sortlist 2 + ] LITERAL 114 | [ sortlist 10000 + ] LITERAL 115 | -64 FP+! 116 | Quicksort 117 | 64 FP+! 118 | 3 U@ @ littlest @ - 119 | [ 0033 ] BRANCHNZ 120 | [ sortlist 10000 + ] LITERAL @ 121 | biggest @ - 122 | IF 123 | [ 0033 ] LABEL 124 | -64 FP+! 125 | do_error 126 | 64 FP+! 127 | THEN 128 | 2 U@ 1 + [ 2 ] DUP_U! 129 | 49 > 130 | UNTIL 131 | 132 | EXIT 133 | ; 134 | 135 | .( max 49) cr 136 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/quick.ces: -------------------------------------------------------------------------------- 1 | \ /* quick.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | \ CESYS C version 6 | 7 | EMPTY 8 | : XY " DOS XY quick.ces" EVALUATE ; 9 | 10 | DECIMAL 11 | load gnutool.4th 12 | 13 | 100 REG-ADDR $FFC0 AND UBR! 14 | \ #define sortelements 5000 15 | 16 | \ int seed ; 17 | VARIABLE seed 4 CELL- ALLOT 18 | 19 | \ int sortlist[sortelements+1], 20 | \ biggest, littlest, top; 21 | VARIABLE top 4 CELL- ALLOT 22 | VARIABLE littlest 4 CELL- ALLOT 23 | VARIABLE biggest 4 CELL- ALLOT 24 | VARIABLE sortlist 10004 CELL- ALLOT 25 | 26 | : .DATA 27 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 28 | 29 | \ 30 | \ static void do_error() { 31 | : do_error ( FUNC ) ( 3 top> empty ) 32 | \ { printf ( " Error in Quick.\n"); } 33 | ." Error in Quick." cr 34 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 35 | 36 | 37 | : Initrand 38 | $2403 seed ! ; 39 | 40 | : Rand 41 | seed @ $51d * $3619 + seed ! 42 | seed @ ; 43 | 44 | : Initarr 45 | 17 g@ 64 + 17 g! 46 | Initrand 47 | 17 g@ 64 - 17 g! 48 | $0 biggest ! 49 | $0 littlest ! 50 | $1 0 u! 51 | 52 | [ 43 ] label 53 | 0 u@ $1388 <= 1 and 54 | [ 44 ] branchz 55 | 56 | 17 g@ 64 + 17 g! 57 | Rand 58 | 17 g@ 64 - 17 g! 59 | 1 u! 60 | 1 u@ $8064 + sortlist 0 u@ 2* + ! 61 | sortlist 0 u@ 2* + @ biggest @ > 1 and 62 | [ 46 ] branchz 63 | 64 | sortlist 0 u@ 2* + @ biggest ! 65 | [ 47 ] branch 66 | 67 | [ 46 ] label 68 | littlest @ sortlist 0 u@ 2* + @ > 1 and 69 | [ 48 ] branchz 70 | 71 | sortlist 0 u@ 2* + @ littlest ! 72 | 73 | [ 48 ] label 74 | [ 47 ] label 75 | [ 45 ] label 76 | 0 u@ $1 + 0 u! 77 | [ 43 ] branch 78 | 79 | [ 44 ] label 80 | ; 81 | 82 | : Quicksort 83 | 0 u! 1 u! 2 u! 84 | 1 u@ 3 u! 2 u@ 4 u! 85 | 0 u@ 1 u@ 2 u@ + $2 / 2* + @ 5 u! 86 | 87 | [ 50 ] label 88 | [ 53 ] label 89 | 90 | 5 u@ 0 u@ 3 u@ 2* + @ > 1 and 91 | [ 54 ] branchz 92 | 93 | 3 u@ $1 + 3 u! 94 | [ 53 ] branch 95 | 96 | [ 54 ] label 97 | [ 55 ] label 98 | 0 u@ 4 u@ 2* + @ 5 u@ > 1 and 99 | [ 56 ] branchz 100 | 101 | 4 u@ $ffff + 4 u! 102 | [ 55 ] branch 103 | 104 | [ 56 ] label 105 | 3 u@ 4 u@ <= 1 and 106 | [ 57 ] branchz 107 | 108 | 0 u@ 3 u@ 2* + @ 6 u! 109 | 0 u@ 4 u@ 2* + @ 0 u@ 3 u@ 2* + ! 110 | 6 u@ 0 u@ 4 u@ 2* + ! 111 | 3 u@ $1 + 3 u! 112 | 4 u@ $ffff + 4 u! 113 | 114 | [ 57 ] label 115 | [ 52 ] label 116 | 3 u@ 4 u@ <= 1 and 117 | [ 58 ] branchz 118 | 119 | [ 50 ] branch 120 | 121 | [ 58 ] label 122 | [ 51 ] label 123 | 4 u@ 1 u@ > 1 and 124 | [ 59 ] branchz 125 | 126 | 4 u@ 1 u@ 0 u@ 127 | 17 g@ 64 + 17 g! 128 | RECURSE \ Quicksort 129 | 17 g@ 64 - 17 g! 130 | 131 | [ 59 ] label 132 | 2 u@ 3 u@ > 1 and 133 | [ 60 ] branchz 134 | 135 | 2 u@ 3 u@ 0 u@ 136 | 17 g@ 64 + 17 g! 137 | RECURSE \ Quicksort 138 | 17 g@ 64 - 17 g! 139 | 140 | [ 60 ] label 141 | ; 142 | 143 | : main 144 | 100 REG-ADDR $FFC0 AND UBR! $0 0 u! 145 | 146 | [ 62 ] label 147 | $32 0 u@ 148 | dup . 149 | > 1 and 150 | [ 63 ] branchz 151 | 152 | 17 g@ 64 + 17 g! 153 | Initarr 154 | 17 g@ 64 - 17 g! 155 | 156 | $1388 $1 sortlist 157 | 17 g@ 64 + 17 g! 158 | Quicksort 159 | 17 g@ 64 - 17 g! 160 | 161 | [ sortlist 2 + ] literal @ littlest @ <> 1 and dup 162 | [ 67 ] branchz 163 | 164 | [ 66 ] branch 165 | 166 | [ 67 ] label 167 | drop 168 | [ sortlist 10000 + ] literal @ biggest @ <> 1 and 169 | 170 | [ 66 ] label 171 | [ 65 ] branchz 172 | 173 | 17 g@ 64 + 17 g! 174 | do_error 175 | 17 g@ 64 - 17 g! 176 | 177 | [ 65 ] label 178 | [ 64 ] label 179 | 180 | 0 u@ $1 + 0 u! 181 | [ 62 ] branch 182 | 183 | [ 63 ] label ; 184 | -------------------------------------------------------------------------------- /RTX2000/TESTS/towers.e.4th: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ Improved source code assembler based on GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY towers.e.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE movesdone 4 CELL- ALLOT 13 | VARIABLE freelist 4 CELL- ALLOT 14 | VARIABLE cellspace 76 CELL- ALLOT 15 | VARIABLE stack 8 CELL- ALLOT 16 | 17 | : do_error 18 | ." Error in Towers." cr 19 | ; 20 | 21 | : Error 22 | ." Error in Towers." cr 23 | ; 24 | 25 | : Makenull ( ADDR -- ) 26 | 0 SWAP ! ; 27 | 28 | 64 FRAME_SIZE ! 29 | : Getelement ( -- addr ) 30 | freelist @ DUP 0> 31 | IF 32 | DUP 33 | 2* 2* [ cellspace 2 + ] SYMBOL_+ @ 34 | freelist ! 35 | EXIT 36 | THEN 37 | Error 38 | ; 39 | 40 | 64 FRAME_SIZE ! 41 | : Push ( i ^s -- ) 42 | DUP @ 3 U! 43 | 4 U! 5 U! 44 | 3 U@ 0> 45 | IF 46 | 3 U@ 2* 2* [ cellspace ] SYMBOL_+ @ 47 | 5 U@ <= 48 | IF 49 | Error 50 | exit 51 | THEN 52 | THEN 53 | Getelement ( -- el ) 54 | DUP 2* 2* [ cellspace ] SYMBOL_+ DUP ( -- el ^el ^el ) 55 | [ 3 ] U@_SWAP ( -- el ^el s_val ^el ) 56 | 2 + ! ( -- el ^el ) 57 | SWAP 4 U@ ! ( -- ^el ) 58 | [ 5 ] U@_SWAP ! 59 | ; 60 | 61 | 64 FRAME_SIZE ! 62 | : Init 63 | 3 U! [ 4 ] dup_U! 64 | Makenull 65 | 3 U@ [ 5 ] DUP_U! 0> 66 | IF 67 | 5 U@ ( -- discctr ) 68 | BEGIN ( -- discctr ) 69 | DUP 4 U@ ( -- discctr discctr s ) 70 | -64 FP+! Push 64 FP+! ( -- discctr ) 71 | 1 - DUP ( -- discctr ) 72 | WHILE REPEAT ( -- discctr ) 73 | DROP ( -- ) 74 | EXIT ( -- ) 75 | THEN 76 | ; 77 | 78 | : Pop ( s -- ) 79 | DUP @ ( -- s *s ) 80 | DUP 0> ( -- s *s flg ) 81 | IF 82 | DUP >R 2* 2* [ cellspace ] SYMBOL_+ ( -- s adr ) 83 | @+2 ( -- s size adr+2 ) 84 | @+0 ( -- s size next adr+2 ) 85 | freelist @_SWAP ( -- s size next free adr+2 ) 86 | ! ( -- s size next ) 87 | R> freelist ! ( -- s size next ) 88 | ROT ! ( -- s size next ) 89 | EXIT 90 | THEN 91 | drop drop 92 | Error 93 | 0 94 | ; 95 | 96 | : Move ( ^s1 ^s2 -- ) 97 | SWAP Pop SWAP 98 | -64 FP+! Push 64 FP+! 99 | movesdone @ 1 + movesdone ! 100 | ; 101 | 102 | 64 FRAME_SIZE ! 103 | : tower ( i j k -- ) 104 | [ 099 ] LABEL \ Tail recursion elimination target 105 | DUP 1 - 106 | IF 107 | 2 U! 3 U! 108 | [ 4 ] DUP_U! 109 | 6 3 U@ - 4 U@ - [ 8 ] dup_U! 110 | 2 U@ 1 - 111 | -64 FP+! recurse 64 FP+! 112 | 4 U@ 2* [ stack ] SYMBOL_+ 113 | 3 U@ 2* [ stack ] SYMBOL_+ 114 | Move 115 | 8 U@ 3 U@ 2 U@ 1 - 116 | [ 099 ] BRANCH 117 | ELSE 118 | DROP 119 | SWAP 2* [ stack ] SYMBOL_+ 120 | SWAP 2* [ stack ] SYMBOL_+ 121 | Move 122 | EXIT 123 | THEN 124 | ; 125 | 126 | 64 FRAME_SIZE ! 127 | : main 128 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 129 | 0 >R 130 | 131 | BEGIN 132 | 17 FOR 133 | I DUP 1 + 2* 2* [ cellspace 2 + ] SYMBOL_+ ! 134 | NEXT 135 | 18 freelist ! 136 | [ stack 2 + ] LITERAL 14 137 | -64 FP+! Init 64 FP+! 138 | [ stack 4 + ] LITERAL Makenull 139 | [ stack 6 + ] LITERAL Makenull 140 | 0 movesdone ! 141 | 1 2 14 142 | -64 FP+! tower 64 FP+! 143 | movesdone @ 16383 - 144 | IF do_error THEN 145 | R> 1 + DUP_>R 146 | 34 147 | U> 148 | UNTIL 149 | R>DROP 150 | ; 151 | 152 | .( max 34) cr 153 | -------------------------------------------------------------------------------- /RTX2000/TESTS/queens.e.4th: -------------------------------------------------------------------------------- 1 | \ /* queens.c */ 2 | \ Improved hand-done assembler source code GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY queens.e.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE tries 4 CELL- ALLOT 11 | 12 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 13 | 14 | : do_error 15 | ." Error in Queens." cr ; 16 | 17 | 64 FRAME_SIZE ! 18 | : Try ( c x i q a b-- ) 19 | 1 tries +! ( -- c x i q a b ) 20 | 3 U! ( -- c x i q a ) 21 | 4 U! ( -- c x i q ) 22 | 0 OVER ! ( -- c x i q ) 23 | 7 U! ( -- c x i ) 24 | 8 U! ( -- c x ) 25 | 6 U! ( -- c ) 26 | 2 U! ( -- ) 27 | 0 ( -- j ) 28 | BEGIN ( -- j ) 29 | DUP 8 <> ( -- j flag) 30 | 7 U@ @ 0= AND ( -- j flag ) 31 | WHILE ( -- j ) 32 | 0 7 U@ ! ( -- j ) 33 | 1 + DUP ( -- j j ) 34 | 2* 3 U@ + @ ( -- j b[j] ) 35 | IF ( -- j ) 36 | DUP 8 U@ + [ 9 ] DUP_U! 2* 4 U@ + @ ( -- j flag ) 37 | IF ( -- j ) 38 | 8 U@ OVER - [ 10 ] DUP_U! 2* 2 U@ + 14 + @ ( -- j flag ) 39 | IF ( -- j ) 40 | DUP 8 U@ 2* 6 U@ + ! ( -- j ) 41 | 0 OVER 2* 3 U@ + ! ( -- j ) 42 | 0 9 U@ 2* 4 U@ + ! ( -- j ) 43 | 0 10 U@ 2* 2 U@ + 14 + ! ( -- j ) 44 | 8 U@ 7 <= ( -- j flag ) 45 | IF ( -- j ) 46 | 5 U! 47 | 2 U@ 6 U@ 8 U@ 1 + 7 U@ 4 U@ 3 U@ 48 | -64 FP+! RECURSE 64 FP+! 49 | 5 U@ ( -- j ) 50 | 7 U@ @ ( -- j flag ) 51 | IF ELSE 52 | -1 OVER 2* 3 U@ + ! ( -- j ) 53 | -1 9 U@ 2* 4 U@ + ! ( -- j ) 54 | -1 10 U@ 2* 2 U@ + 14 + ! ( -- j ) 55 | THEN ( -- j ) 56 | ELSE ( -- j ) 57 | -1 7 U@ ! ( -- j ) 58 | THEN ( -- j ) 59 | THEN ( -- j ) 60 | THEN ( -- j ) 61 | THEN ( -- j ) 62 | REPEAT ( -- j ) 63 | DROP ; 64 | 65 | 192 FRAME_SIZE ! 66 | 67 | : Doit 68 | -7 ( -- i ) 69 | BEGIN ( -- i ) 70 | DUP 0> ( -- i ) 71 | IF ( -- i ) 72 | DUP 9 < ( -- i ) 73 | IF ( -- i ) 74 | -1 OVER 2* UBR@ + 28 - ! ( -- i ) 75 | THEN ( -- i ) 76 | THEN ( -- i ) 77 | DUP 1 > ( -- i ) 78 | IF ( -- i ) 79 | -1 OVER 2* UBR@ + 64 - ! ( -- i ) 80 | THEN ( -- i ) 81 | DUP 8 < ( -- i ) 82 | IF ( -- i ) 83 | -1 OVER 2* UBR@ + 82 - ! ( -- i ) 84 | THEN ( -- i ) 85 | 1 + DUP ( -- i ) 86 | 16 > 87 | UNTIL ( -- i ) 88 | DROP ( -- ) 89 | UBR@ 96 - UBR@ 116 - 1 UBR@ 120 - UBR@ 64 - UBR@ 28 - 90 | -192 FP+! Try 192 FP+! 91 | [ -62 ] MEM_ARG@ 92 | 0= IF 93 | -192 FP+! do_error 192 FP+! 94 | 1000 tries +! 95 | THEN 96 | ; 97 | 98 | 64 FRAME_SIZE ! 99 | 100 | : main 101 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 102 | 1 >R 103 | 104 | BEGIN 105 | 0 tries ! 106 | -64 FP+! 107 | Doit 108 | 64 FP+! 109 | tries @ 113 - 110 | IF 111 | -64 FP+! do_error 64 FP+! 112 | THEN 113 | R> 1 + DUP_>R 114 | 2500 115 | U> 116 | UNTIL 117 | R>DROP 118 | ; 119 | 120 | .( 2500 max ) cr 121 | -------------------------------------------------------------------------------- /RTX2000/TESTS/towers.a.4th: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ CESYS compiled 3 | 4 | EMPTY 5 | : XY " DOS XY towers.a.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | 100 REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE movesdone 4 CELL- ALLOT 13 | VARIABLE freelist 4 CELL- ALLOT 14 | VARIABLE cellspace 76 CELL- ALLOT 15 | VARIABLE stack 8 CELL- ALLOT 16 | 17 | : do_error ." Error in Towers." cr ; 18 | 19 | : Makenull 20 | >r $0 stack r@ 2* + ! 21 | r> drop ; 22 | 23 | : Getelement 24 | freelist @ $0 > 1 and 25 | [ 44 ] branchz 26 | freelist @ 0 u! 27 | cellspace freelist @ 2* 2* + $2 + @ freelist ! 28 | [ 45 ] branch 29 | 30 | [ 44 ] label 31 | 17 g@ 64 + 17 g! 32 | do_error 33 | 17 g@ 64 - 17 g! 34 | 35 | [ 45 ] label 36 | 0 u@ ; 37 | 38 | : Push 39 | 0 u! 1 u! 40 | $0 2 u! 41 | stack 1 u@ 2* + @ $0 > 1 and 42 | [ 48 ] branchz 43 | 44 | cellspace stack 1 u@ 2* + @ 45 | 2* 2* + @ 0 u@ <= 1 and 46 | [ 49 ] branchz 47 | 48 | $1 2 u! 49 | 17 g@ 64 + 17 g! 50 | do_error 51 | 17 g@ 64 - 17 g! 52 | 53 | [ 49 ] label 54 | [ 48 ] label 55 | 56 | 2 u@ 0= 1 and 57 | [ 51 ] branchz 58 | 59 | 17 g@ 64 + 17 g! 60 | Getelement 61 | 17 g@ 64 - 17 g! 62 | 63 | 3 u! 64 | stack 1 u@ 2* + @ 65 | cellspace 3 u@ 2* 2* + $2 + ! 66 | 3 u@ stack 1 u@ 2* + ! 67 | 0 u@ cellspace 3 u@ 2* 2* + ! 68 | 69 | [ 51 ] label 70 | ; 71 | 72 | : Init 73 | 0 u! 1 u! 0 u@ 74 | 17 g@ 64 + 17 g! 75 | Makenull 76 | 17 g@ 64 - 17 g! 77 | 1 u@ 2 u! 78 | 79 | [ 53 ] label 80 | $1 2 u@ <= 1 and 81 | [ 54 ] branchz 82 | 83 | 0 u@ 2 u@ 84 | 17 g@ 64 + 17 g! 85 | Push 86 | 17 g@ 64 - 17 g! 87 | 88 | [ 55 ] label 89 | 2 u@ $1 - 2 u! 90 | [ 53 ] branch 91 | 92 | [ 54 ] label 93 | ; 94 | 95 | : Pop 96 | >r stack r@ 2* + @ $0 > 1 and 97 | [ 57 ] branchz 98 | cellspace stack 99 | r@ 2* + @ 2* 2* + @ 2 u! 100 | cellspace stack r@ 2* + @ 101 | 2* 2* + $2 + @ 1 u! 102 | freelist @ cellspace stack r@ 2* + @ 2* 2* + $2 + ! 103 | stack r@ 2* + @ freelist ! 104 | 1 u@ stack r@ 2* + ! 2 u@ r> drop exit 105 | 106 | [ 57 ] label 107 | 17 g@ 64 + 17 g! 108 | do_error 109 | 17 g@ 64 - 17 g! 110 | $0 r> drop ; 111 | 112 | : Move 113 | 0 u! 1 u! 1 u@ 0 u@ 114 | 17 g@ 64 + 17 g! 115 | Pop 116 | 17 g@ 64 - 17 g! 117 | 118 | 17 g@ 64 + 17 g! 119 | Push 120 | 17 g@ 64 - 17 g! 121 | movesdone @ $1 + movesdone ! 122 | ; 123 | 124 | : tower 125 | 0 u! 1 u! 2 u! 2 u@ $1 = 1 and 126 | [ 61 ] branchz 127 | 1 u@ 0 u@ 128 | 17 g@ 64 + 17 g! 129 | Move 130 | 17 g@ 64 - 17 g! 131 | [ 62 ] branch 132 | 133 | [ 61 ] label 134 | $6 0 u@ - 1 u@ - 3 u! 135 | 2 u@ $ffff + 3 u@ 0 u@ 136 | 17 g@ 64 + 17 g! 137 | RECURSE 17 g@ 64 - 17 g! 138 | 1 u@ 0 u@ 139 | 17 g@ 64 + 17 g! 140 | Move 141 | 17 g@ 64 - 17 g! 142 | 2 u@ $ffff + 1 u@ 3 u@ 143 | 17 g@ 64 + 17 g! 144 | RECURSE 17 g@ 64 - 17 g! 145 | 146 | [ 62 ] label 147 | ; 148 | 149 | : main 150 | 100 REG-ADDR $FFC0 AND UBR! $0 1 u! 151 | 152 | [ 64 ] label 153 | $23 1 u@ 154 | dup . 155 | > 1 and 156 | [ 65 ] branchz 157 | 158 | $1 0 u! 159 | 160 | [ 67 ] label 161 | 0 u@ $12 <= 1 and 162 | [ 68 ] branchz 163 | 0 u@ $ffff + cellspace 0 u@ 2* 2* + $2 + ! 164 | 165 | [ 69 ] label 166 | 0 u@ $1 + 0 u! 167 | [ 67 ] branch 168 | 169 | [ 68 ] label 170 | $12 freelist ! $e $1 171 | 17 g@ 64 + 17 g! 172 | Init 173 | 17 g@ 64 - 17 g! 174 | $2 175 | 17 g@ 64 + 17 g! 176 | Makenull 177 | 17 g@ 64 - 17 g! 178 | $3 179 | 17 g@ 64 + 17 g! 180 | Makenull 181 | 17 g@ 64 - 17 g! 182 | $0 movesdone ! $e $2 $1 183 | 17 g@ 64 + 17 g! 184 | tower 185 | 17 g@ 64 - 17 g! 186 | movesdone @ $3fff <> 1 and 187 | [ 70 ] branchz 188 | 189 | 17 g@ 64 + 17 g! 190 | do_error 191 | 17 g@ 64 - 17 g! 192 | 193 | [ 70 ] label 194 | [ 66 ] label 195 | 1 u@ $1 + 1 u! 196 | [ 64 ] branch 197 | 198 | [ 65 ] label 199 | ; 200 | 201 | .( max ) $23 . cr 202 | -------------------------------------------------------------------------------- /RTX2000/TESTS/queens.b.4th: -------------------------------------------------------------------------------- 1 | \ /* queens.c */ 2 | \ GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY queens.b.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | VARIABLE tries 4 CELL- ALLOT 11 | 12 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 13 | 14 | 64 frame_size ! 15 | : do_error 16 | ." Error in Queens." cr 17 | ; 18 | 19 | 64 frame_size ! 20 | : Try 21 | 22 | [ 2 ] MEM_ARG@ 23 | 2 U! 24 | 3 U! 25 | 4 U! 26 | [ 3 ] MEM_ARG@ 27 | 28 | 1 29 | tries 30 | +! 31 | 32 | OVER 33 | 0 34 | SWAP 35 | ! 36 | 37 | 0 38 | 39 | 5 U! 40 | 6 U! 41 | [ 7 ] DUP_U! 42 | 43 | SWAP 44 | 8 U! 45 | @ 46 | [ 0010 ] BRANCHNZ 47 | 48 | [ 009 ] LABEL 49 | 5 U@ 50 | 8 51 | - 52 | [ 004 ] BRANCHZ 53 | 54 | 5 U@ 55 | 1 56 | + 57 | 58 | 0 59 | 7 U@ ! 60 | 61 | DUP 62 | 2* 63 | 3 U@ + 64 | SWAP 65 | 5 U! 66 | @ 67 | [ 003 ] BRANCHZ 68 | 8 U@ 69 | 5 U@ + 70 | DUP 71 | 2* 72 | 4 U@ + 73 | SWAP 74 | 9 U! 75 | @ 76 | [ 103 ] BRANCHZ 77 | 8 U@ 78 | 5 U@ 79 | - 80 | DUP 81 | 2* 82 | 2 U@ + 83 | SWAP 84 | 10 U! 85 | 14 86 | + 87 | @ 88 | [ 203 ] BRANCHZ 89 | 90 | 8 U@ 91 | 2* 92 | 6 U@ + 93 | [ 5 ] U@_SWAP 94 | ! 95 | 96 | 5 U@ 97 | 2* 98 | 3 U@ + 99 | [ 0 ] LIT_SWAP 100 | ! 101 | 102 | 9 U@ 103 | 2* 104 | 4 U@ + 105 | [ 0 ] LIT_SWAP 106 | ! 107 | 108 | 10 U@ 109 | 2* 110 | 2 U@ + 111 | 14 112 | + 113 | 0 114 | SWAP ! 115 | 116 | 8 U@ 117 | 7 118 | <= 119 | [ 006 ] BRANCHZ 120 | 121 | 2 U@ 122 | [ 2 ] MEM_ARG! 123 | 6 U@ 124 | [ 3 ] MEM_ARG! 125 | 8 U@ 126 | 1 127 | + 128 | 7 U@ 129 | 4 U@ 130 | 3 U@ 131 | 132 | -64 FP+! 133 | recurse 64 FP+! 134 | 135 | 7 U@ 136 | @ 137 | [ 303 ] BRANCHNZ 138 | 139 | 5 U@ 140 | 2* 141 | 3 U@ + 142 | [ -1 ] LIT_SWAP 143 | ! 144 | 145 | 9 U@ 146 | 2* 147 | 4 U@ + 148 | [ -1 ] LIT_SWAP 149 | ! 150 | 151 | 10 U@ 152 | 2* 153 | 2 U@ + 154 | 14 155 | + 156 | -1 157 | SWAP ! 158 | 159 | [ 403 ] BRANCH 160 | 161 | [ 006 ] LABEL 162 | -1 163 | 7 U@ ! 164 | 165 | [ 003 ] LABEL 166 | [ 103 ] LABEL 167 | [ 203 ] LABEL 168 | [ 303 ] LABEL 169 | [ 403 ] LABEL 170 | 7 U@ 171 | @ 172 | [ 009 ] BRANCHZ 173 | 174 | [ 0010 ] LABEL 175 | EXIT [ 004 ] LABEL 176 | ; 177 | 178 | 192 frame_size ! 179 | : Doit 180 | 181 | -7 182 | 2 U! 183 | 184 | [ 0017 ] LABEL 185 | 186 | 2 U@ 187 | 0> 188 | [ 0014 ] BRANCHZ 189 | 2 U@ 190 | 8 191 | <= 192 | [ 0114 ] BRANCHZ 193 | 2 U@ 194 | 2* 195 | UBR@ + 196 | [ -1 ] LIT_SWAP 197 | 28 198 | - 199 | ! 200 | [ 0014 ] LABEL 201 | [ 0114 ] LABEL 202 | 203 | 2 U@ 204 | 1 205 | > 206 | [ 0015 ] BRANCHZ 207 | 2 U@ 208 | 2* 209 | UBR@ + 210 | [ -1 ] LIT_SWAP 211 | 64 212 | - 213 | ! 214 | 215 | [ 0015 ] LABEL 216 | 2 U@ 217 | 7 218 | <= 219 | [ 0016 ] BRANCHZ 220 | 2 U@ 221 | 2* 222 | UBR@ + 223 | [ -1 ] LIT_SWAP 224 | 82 225 | - 226 | ! 227 | [ 0016 ] LABEL 228 | 229 | 2 U@ 230 | 1 231 | + 232 | [ 2 ] DUP_U! 233 | 234 | 16 235 | > 236 | [ 0017 ] BRANCHZ 237 | 238 | [ 0019 ] LABEL 239 | 240 | UBR@ 241 | 96 242 | - 243 | [ 2 ] MEM_ARG! 244 | UBR@ 245 | 116 246 | - 247 | [ 3 ] MEM_ARG! 248 | 1 249 | UBR@ 250 | 120 251 | - 252 | UBR@ 253 | 64 254 | - 255 | UBR@ 256 | 28 257 | - 258 | 259 | -192 FP+! 260 | Try 261 | 192 FP+! 262 | 263 | [ -62 ] MEM_ARG@ 264 | [ 0018 ] BRANCHNZ 265 | -192 FP+! 266 | do_error 267 | 192 FP+! 268 | 1000 269 | tries 270 | +! 271 | EXIT [ 0018 ] LABEL 272 | ; 273 | 274 | 64 frame_size ! 275 | : main 276 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 277 | 278 | 1 279 | [ 0025 ADD_INDEX ] >R 280 | 281 | [ 0025 ] LABEL 282 | 283 | 0 284 | tries 285 | ! 286 | 287 | -64 FP+! 288 | Doit 289 | 64 FP+! 290 | 291 | tries 292 | @ 293 | 113 294 | - 295 | [ 0023 ] BRANCHZ 296 | -64 FP+! 297 | do_error 298 | 64 FP+! 299 | [ 0023 ] LABEL 300 | R> 301 | 1 302 | + 303 | DUP_>R 304 | dup . 305 | 2500 306 | U> 307 | [ 0025 ] BRANCHZ 308 | [ 0025 DROP_INDEX ] R>DROP 309 | EXIT [ 0026 ] LABEL 310 | ; 311 | 312 | .( max 2500) cr 313 | -------------------------------------------------------------------------------- /RTX2000/TESTS/ctest.4th: -------------------------------------------------------------------------------- 1 | 2 | \ test file for comparison operations 3 | hex 4 | : test 5 | 6 | 0 -1 <> 0= abort" fail 1 " 7 | 0 0 <> abort" fail 2 " 8 | -1 0 <> 0= abort" fail 3 " 9 | 4000 3FFF <> 0= abort" fail 4 " 10 | 4000 4000 <> abort" fail 5 " 11 | 4000 4001 <> 0= abort" fail 6 " 12 | -4000 -3FFF <> 0= abort" fail 7 " 13 | -4000 -4000 <> abort" fail 8 " 14 | -4000 -4001 <> 0= abort" fail 9 " 15 | 4000 -3FFF <> 0= abort" fail A " 16 | 4000 -4000 <> 0= abort" fail B " 17 | 4000 -4001 <> 0= abort" fail C " 18 | -4000 3FFF <> 0= abort" fail D " 19 | -4000 4000 <> 0= abort" fail E " 20 | -4000 4001 <> 0= abort" fail F " 21 | 22 | 0 -1 = abort" fail 11 " 23 | 0 0 = 0= abort" fail 12 " 24 | -1 0 = abort" fail 13 " 25 | 4000 3FFF = abort" fail 14 " 26 | 4000 4000 = 0= abort" fail 15 " 27 | 4000 4001 = abort" fail 16 " 28 | -4000 -3FFF = abort" fail 17 " 29 | -4000 -4000 = 0= abort" fail 18 " 30 | -4000 -4001 = abort" fail 19 " 31 | 4000 -3FFF = abort" fail 1A " 32 | 4000 -4000 = abort" fail 1B " 33 | 4000 -4001 = abort" fail 1C " 34 | -4000 3FFF = abort" fail 1D " 35 | -4000 4000 = abort" fail 1E " 36 | -4000 4001 = abort" fail 1F " 37 | 38 | 0 -1 > 0= abort" fail 21 " 39 | 0 0 > abort" fail 22 " 40 | -1 0 > abort" fail 23 " 41 | 4000 3FFF > 0= abort" fail 24 " 42 | 4000 4000 > abort" fail 25 " 43 | 4000 4001 > abort" fail 26 " 44 | -4000 -3FFF > abort" fail 27 " 45 | -4000 -4000 > abort" fail 28 " 46 | -4000 -4001 > 0= abort" fail 29 " 47 | 4000 -3FFF > 0= abort" fail 2A " 48 | 4000 -4000 > 0= abort" fail 2B " 49 | 4000 -4001 > 0= abort" fail 2C " 50 | -4000 3FFF > abort" fail 2D " 51 | -4000 4000 > abort" fail 2E " 52 | -4000 4001 > abort" fail 2F " 53 | 54 | 0 -1 >= 0= abort" fail 31 " 55 | 0 0 >= 0= abort" fail 32 " 56 | -1 0 >= abort" fail 33 " 57 | 4000 3FFF >= 0= abort" fail 34 " 58 | 4000 4000 >= 0= abort" fail 35 " 59 | 4000 4001 >= abort" fail 36 " 60 | -4000 -3FFF >= abort" fail 37 " 61 | -4000 -4000 >= 0= abort" fail 38 " 62 | -4000 -4001 >= 0= abort" fail 39 " 63 | 4000 -3FFF >= 0= abort" fail 3A " 64 | 4000 -4000 >= 0= abort" fail 3B " 65 | 4000 -4001 >= 0= abort" fail 3C " 66 | -4000 3FFF >= abort" fail 3D " 67 | -4000 4000 >= abort" fail 3E " 68 | -4000 4001 >= abort" fail 3F " 69 | 70 | 0 -1 < abort" fail 41 " 71 | 0 0 < abort" fail 42 " 72 | -1 0 < 0= abort" fail 43 " 73 | 4000 3FFF < abort" fail 44 " 74 | 4000 4000 < abort" fail 45 " 75 | 4000 4001 < 0= abort" fail 46 " 76 | -4000 -3FFF < 0= abort" fail 47 " 77 | -4000 -4000 < abort" fail 48 " 78 | -4000 -4001 < abort" fail 49 " 79 | 4000 -3FFF < abort" fail 4A " 80 | 4000 -4000 < abort" fail 4B " 81 | 4000 -4001 < abort" fail 4C " 82 | -4000 3FFF < 0= abort" fail 4D " 83 | -4000 4000 < 0= abort" fail 4E " 84 | -4000 4001 < 0= abort" fail 4F " 85 | 86 | 0 -1 <= abort" fail 51 " 87 | 0 0 <= 0= abort" fail 52 " 88 | -1 0 <= 0= abort" fail 53 " 89 | 4000 3FFF <= abort" fail 54 " 90 | 4000 4000 <= 0= abort" fail 55 " 91 | 4000 4001 <= 0= abort" fail 56 " 92 | -4000 -3FFF <= 0= abort" fail 57 " 93 | -4000 -4000 <= 0= abort" fail 58 " 94 | -4000 -4001 <= abort" fail 59 " 95 | 4000 -3FFF <= abort" fail 5A " 96 | 4000 -4000 <= abort" fail 5B " 97 | 4000 -4001 <= abort" fail 5C " 98 | -4000 3FFF <= 0= abort" fail 5D " 99 | -4000 4000 <= 0= abort" fail 5E " 100 | -4000 4001 <= 0= abort" fail 5F " 101 | 102 | -1 0< 0= abort" fail 1 " 103 | 0 0< abort" fail 2 " 104 | 1 0< abort" fail 3 " 105 | 106 | -1 0<> 0= abort" fail 1 " 107 | 0 0<> abort" fail 2 " 108 | 1 0<> 0= abort" fail 3 " 109 | 110 | -1 0= abort" fail 1 " 111 | 0 0= 0= abort" fail 2 " 112 | 1 0= abort" fail 3 " 113 | CR ." ALL TESTS PASSED" 114 | ; 115 | DECIMAL 116 | 117 | TEST 118 | -------------------------------------------------------------------------------- /RTX2000/TESTS/queens.c.4th: -------------------------------------------------------------------------------- 1 | \ /* queens.c */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY queens.c.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | 11 | VARIABLE tries 4 CELL- ALLOT 12 | 13 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 14 | 15 | 64 frame_size ! 16 | : do_error 17 | ." Error in Queens." cr 18 | ; 19 | 20 | 64 frame_size ! 21 | : Try 22 | 23 | [ 2 ] MEM_ARG@ 24 | [ 3 ] MEM_ARG@ 25 | 26 | 1 27 | tries 28 | +! 29 | 30 | 0 31 | 5_pick 32 | ! 33 | 34 | 0 35 | 36 | 5_pick 37 | @ 38 | [ 0010 ] BRANCHNZ 39 | 40 | [ 009 ] LABEL 41 | 0_pick 42 | 8 43 | - 44 | [ 004 ] BRANCHZ 45 | 46 | 1 47 | + 48 | 49 | 0 50 | 6_pick ! 51 | 52 | 0_pick 53 | 2* 54 | 4_pick + 55 | @ 56 | [ 003 ] BRANCHZ 57 | 58 | 6_PICK 59 | 1_pick + 60 | 0_pick 61 | 2* 62 | 6_pick + 63 | @ 64 | [ 103 ] BRANCHZ 65 | 66 | 7_PICK 67 | 2_pick 68 | - 69 | 0_pick 70 | 2* 71 | 5_pick + 72 | 14 73 | + 74 | @ 75 | [ 203 ] BRANCHZ 76 | 77 | 8_pick 78 | 2* 79 | 4_pick + 80 | 3_pick SWAP 81 | ! 82 | 83 | 2_pick 84 | 2* 85 | 6_pick + 86 | [ 0 ] LIT_SWAP 87 | ! 88 | 89 | 1_pick 90 | 2* 91 | 7_pick + 92 | [ 0 ] LIT_SWAP 93 | ! 94 | 95 | 0_pick 96 | 2* 97 | 5_pick + 98 | 14 99 | + 100 | 0 101 | SWAP ! 102 | 103 | 8_pick 104 | 7 105 | <= 106 | [ 006 ] BRANCHZ 107 | 108 | 10 U! 109 | 9 U! 110 | 5 U! 111 | [ 6 ] DUP_U! 112 | [ 3 ] MEM_ARG! 113 | [ 2 ] DUP_U! 114 | [ 2 ] MEM_ARG! 115 | 3 U! 116 | 4 U! 117 | 7 U! 118 | [ 8 ] DUP_U! 119 | 120 | 1 121 | + 122 | 123 | 7 U@ 124 | 4 U@ 125 | 3 U@ 126 | 127 | -64 FP+! 128 | recurse 64 FP+! 129 | 130 | 8 U@ 7 U@ 4 U@ 3 U@ 2 U@ 6 U@ 5 U@ 131 | 132 | 5_pick 133 | @ 134 | [ 303 ] BRANCHNZ 135 | 136 | 0_pick 137 | 2* 138 | 4_pick + 139 | [ -1 ] LIT_SWAP 140 | ! 141 | 142 | 9 U@ 143 | 2* 144 | 5_pick + 145 | [ -1 ] LIT_SWAP 146 | ! 147 | 148 | 10 U@ 149 | 2* 150 | 2 U@ + 151 | 14 152 | + 153 | -1 154 | SWAP ! 155 | 156 | [ 403 ] BRANCH 157 | 158 | [ 006 ] LABEL 159 | 160 | -1 161 | 8_pick ! 162 | 163 | [ 203 ] LABEL 164 | DROP 165 | 166 | [ 103 ] LABEL 167 | DROP 168 | 169 | [ 003 ] LABEL 170 | 171 | [ 303 ] LABEL 172 | 173 | [ 403 ] LABEL 174 | 5_pick 175 | @ 176 | 177 | [ 009 ] BRANCHZ 178 | 179 | [ 0010 ] LABEL 180 | 181 | [ 004 ] LABEL 182 | drop 183 | drop 184 | drop 185 | drop 186 | drop 187 | drop 188 | drop 189 | ; 190 | 191 | 192 frame_size ! 192 | : Doit 193 | 194 | -7 195 | 2 U! 196 | 197 | [ 0017 ] LABEL 198 | 199 | 2 U@ 200 | 0_pick 201 | 0> 202 | [ 0014 ] BRANCHZ 203 | 204 | 0_pick 205 | 8 206 | <= 207 | [ 0114 ] BRANCHZ 208 | 209 | 0_pick 210 | 2* 211 | UBR@ + 212 | [ -1 ] LIT_SWAP 213 | 28 214 | - 215 | ! 216 | [ 0014 ] LABEL 217 | [ 0114 ] LABEL 218 | 219 | 0_pick 220 | 1 221 | > 222 | [ 0015 ] BRANCHZ 223 | 0_pick 224 | 2* 225 | UBR@ + 226 | [ -1 ] LIT_SWAP 227 | 64 228 | - 229 | ! 230 | 231 | [ 0015 ] LABEL 232 | 0_pick 233 | 7 234 | <= 235 | [ 0016 ] BRANCHZ 236 | 237 | 0_pick 238 | 2* 239 | UBR@ + 240 | [ -1 ] LIT_SWAP 241 | 82 242 | - 243 | ! 244 | [ 0016 ] LABEL 245 | 246 | 1 247 | + 248 | [ 2 ] DUP_U! 249 | 250 | 16 251 | > 252 | [ 0017 ] BRANCHZ 253 | 254 | [ 0019 ] LABEL 255 | 256 | UBR@ 257 | 96 258 | - 259 | [ 2 ] MEM_ARG! 260 | UBR@ 261 | 116 262 | - 263 | [ 3 ] MEM_ARG! 264 | 1 265 | UBR@ 266 | 120 267 | - 268 | UBR@ 269 | 64 270 | - 271 | UBR@ 272 | 28 273 | - 274 | 275 | -192 FP+! 276 | Try 277 | 192 FP+! 278 | 279 | [ -62 ] MEM_ARG@ 280 | [ 0018 ] BRANCHNZ 281 | -192 FP+! 282 | do_error 283 | 192 FP+! 284 | 1000 285 | tries 286 | +! 287 | EXIT [ 0018 ] LABEL 288 | ; 289 | 290 | 64 frame_size ! 291 | : main 292 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 293 | 294 | 1 295 | [ 0025 ADD_INDEX ] >R 296 | 297 | [ 0025 ] LABEL 298 | 299 | 0 300 | tries 301 | ! 302 | 303 | -64 FP+! 304 | Doit 305 | 64 FP+! 306 | 307 | tries 308 | @ 309 | 113 310 | - 311 | [ 0023 ] BRANCHZ 312 | -64 FP+! 313 | do_error 314 | 64 FP+! 315 | [ 0023 ] LABEL 316 | R> 317 | 1 318 | + 319 | DUP_>R 320 | dup . 2500 321 | U> 322 | [ 0025 ] BRANCHZ 323 | [ 0025 DROP_INDEX ] R>DROP 324 | EXIT [ 0026 ] LABEL 325 | ; 326 | 327 | .( max 2500) cr 328 | -------------------------------------------------------------------------------- /RTX2000/TESTS/quick.b.4th: -------------------------------------------------------------------------------- 1 | \ /* quick.c */ 2 | \ GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY quick.b.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE seed 4 CELL- ALLOT 13 | VARIABLE top 4 CELL- ALLOT 14 | VARIABLE littlest 4 CELL- ALLOT 15 | VARIABLE biggest 4 CELL- ALLOT 16 | VARIABLE sortlist 10004 CELL- ALLOT 17 | 18 | : .DATA 19 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 20 | 21 | : do_error 22 | ." Error in Quick." cr 23 | ; 24 | 25 | 64 FRAME_SIZE ! 26 | : Initrand 27 | 9219 28 | seed 29 | ! 30 | ; 31 | 32 | 64 FRAME_SIZE ! 33 | : Rand 34 | 35 | seed 36 | @ 37 | 1309 38 | * 39 | 13849 40 | + 41 | seed 42 | 43 | TUCK_! 44 | ; 45 | 46 | 64 FRAME_SIZE ! 47 | : Initarr 48 | 49 | -64 FP+! 50 | Initrand 51 | 64 FP+! 52 | 53 | 0 54 | biggest 55 | ! 56 | 0 57 | littlest 58 | ! 59 | 60 | 1 61 | [ 0011 ADD_INDEX ] >R 62 | 63 | [ 0011 ] LABEL 64 | 65 | -64 FP+! 66 | Rand 67 | 64 FP+! 68 | 69 | [ 0011 ] INDEX 70 | 2* 71 | [ sortlist ] SYMBOL_+ 72 | SWAP 73 | 32668 74 | - 75 | SWAP ! 76 | 77 | [ 0011 ] INDEX 78 | 2* 79 | [ sortlist ] SYMBOL_+ 80 | @ 81 | biggest 82 | @ 83 | > 84 | [ 008 ] BRANCHZ 85 | [ 0011 ] INDEX 86 | 2* 87 | [ sortlist ] SYMBOL_+ 88 | @ 89 | biggest 90 | ! 91 | [ 007 ] BRANCH 92 | 93 | [ 008 ] LABEL 94 | [ 0011 ] INDEX 95 | 2* 96 | [ sortlist ] SYMBOL_+ 97 | @ 98 | littlest 99 | @ 100 | < 101 | [ 107 ] BRANCHZ 102 | [ 0011 ] INDEX 103 | 2* 104 | [ sortlist ] SYMBOL_+ 105 | @ 106 | littlest 107 | ! 108 | [ 007 ] LABEL 109 | [ 107 ] LABEL 110 | 111 | R> 112 | 1 113 | + 114 | DUP_>R 115 | 5000 116 | U> 117 | [ 0011 ] BRANCHZ 118 | [ 0011 DROP_INDEX ] R>DROP 119 | 120 | EXIT [ 0012 ] LABEL 121 | ; 122 | 123 | 64 FRAME_SIZE ! 124 | : Quicksort 125 | 126 | OVER 127 | 2 U! 128 | [ 3 ] DUP_U! 129 | 2 U@ 130 | 3 U@ + 131 | 4 U! 132 | 5 U! 133 | 6 U! 134 | 7 U! 135 | 4 U@ 136 | 0< 137 | [ 0014 ] BRANCHZ 138 | 139 | 1 140 | 4 U@ + 4 U! 141 | [ 0014 ] LABEL 142 | 4 U@ 143 | -2 144 | AND 145 | 7 U@ + 146 | @ 147 | 8 U! 148 | 149 | [ 0015 ] LABEL 150 | 2 U@ 151 | 2* 152 | 7 U@ + 153 | @ 154 | 8 U@ 155 | < 156 | [ 0028 ] BRANCHZ 157 | 158 | [ 0020 ] LABEL 159 | 2 U@ 160 | 1 161 | + 162 | DUP 163 | 2* 164 | 7 U@ + 165 | @_SWAP 166 | 2 U! 167 | 8 U@ 168 | >= 169 | [ 0020 ] BRANCHZ 170 | 171 | [ 0028 ] LABEL 172 | 5 U@ 173 | 2* 174 | 7 U@ + 175 | @ 176 | 8 U@ 177 | > 178 | [ 0027 ] BRANCHZ 179 | 180 | [ 0023 ] LABEL 181 | 5 U@ 182 | 1 183 | - 184 | DUP 185 | 2* 186 | 7 U@ + 187 | @ 188 | 9 U! 189 | 5 U! 190 | 8 U@ 191 | 9 U@ 192 | >= 193 | [ 0023 ] BRANCHZ 194 | 195 | [ 0027 ] LABEL 196 | 197 | 2 U@ 198 | 5 U@ 199 | <= 200 | [ 0017 ] BRANCHZ 201 | 202 | 2 U@ 203 | 2* 204 | 7 U@ + 205 | @ 206 | 207 | 2 U@ 208 | 2* 209 | 7 U@ + 210 | 5 U@ 211 | 2* 212 | 7 U@ + 213 | @ 214 | SWAP 215 | ! 216 | 217 | 5 U@ 218 | 2* 219 | 7 U@ + 220 | ! 221 | 222 | 2 U@ 223 | 1 224 | + 225 | -1 226 | 5 U@ + 5 U! 227 | 228 | 2 U! 229 | [ 0017 ] LABEL 230 | 231 | 2 U@ 232 | 5 U@ 233 | > 234 | [ 0015 ] BRANCHZ 235 | 236 | 6 U@ 237 | 5 U@ 238 | < 239 | [ 0025 ] BRANCHZ 240 | 7 U@ 241 | 6 U@ 242 | 5 U@ 243 | 244 | -64 FP+! 245 | recurse 64 FP+! 246 | 247 | [ 0025 ] LABEL 248 | 249 | 2 U@ 250 | 3 U@ 251 | < 252 | [ 0026 ] BRANCHZ 253 | 7 U@ 254 | 2 U@ 255 | 3 U@ 256 | 257 | -64 FP+! 258 | recurse 64 FP+! 259 | EXIT [ 0026 ] LABEL 260 | ; 261 | 262 | 64 FRAME_SIZE ! 263 | : main 264 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 265 | 266 | 0 267 | 2 U! 268 | [ 269 | sortlist 270 | 2 271 | + 272 | ] LITERAL 273 | 3 U! 274 | 275 | [ 0035 ] LABEL 276 | 277 | -64 FP+! 278 | Initarr 279 | 64 FP+! 280 | 281 | sortlist 282 | 1 283 | 5000 284 | 285 | -64 FP+! 286 | Quicksort 287 | 64 FP+! 288 | 289 | 3 U@ 290 | @ 291 | littlest 292 | @ 293 | - 294 | [ 0034 ] BRANCHNZ 295 | [ 296 | sortlist 297 | 10000 298 | + 299 | ] LITERAL 300 | @ 301 | biggest 302 | @ 303 | - 304 | [ 0032 ] BRANCHZ 305 | [ 0034 ] LABEL 306 | 307 | -64 FP+! 308 | do_error 309 | 64 FP+! 310 | 311 | [ 0032 ] LABEL 312 | 2 U@ 313 | 1 314 | + 315 | [ 2 ] DUP_U! 316 | dup . 317 | 49 318 | > 319 | [ 0035 ] BRANCHZ 320 | 321 | EXIT [ 0036 ] LABEL 322 | ; 323 | 324 | .( max 49) cr 325 | -------------------------------------------------------------------------------- /RTX2000/TESTS/quick.c.4th: -------------------------------------------------------------------------------- 1 | \ /* quick.c */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY quick.c.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE seed 4 CELL- ALLOT 13 | 14 | VARIABLE top 4 CELL- ALLOT 15 | VARIABLE littlest 4 CELL- ALLOT 16 | VARIABLE biggest 4 CELL- ALLOT 17 | VARIABLE sortlist 10004 CELL- ALLOT 18 | 19 | : .DATA 20 | 1000 2 DO I SORTLIST + @ . 2 +LOOP ; 21 | 22 | : do_error 23 | ." Error in Quick." cr 24 | ; 25 | 26 | 64 FRAME_SIZE ! 27 | : Initrand 28 | 9219 29 | seed 30 | ! 31 | ; 32 | 33 | 64 FRAME_SIZE ! 34 | : Rand 35 | 36 | seed 37 | @ 38 | 1309 39 | * 40 | 13849 41 | + 42 | seed 43 | 44 | TUCK_! 45 | ; 46 | 47 | 64 FRAME_SIZE ! 48 | : Initarr 49 | 50 | Initrand 51 | 52 | 0 53 | biggest 54 | ! 55 | 0 56 | littlest 57 | ! 58 | 59 | 1 60 | [ 0011 ADD_INDEX ] >R 61 | 62 | [ 0011 ] LABEL 63 | 64 | Rand 65 | 66 | 32668 67 | - 68 | 69 | [ 0011 ] INDEX 70 | 2* 71 | [ sortlist ] SYMBOL_+ 72 | 73 | ! 74 | 75 | [ 0011 ] INDEX 76 | 2* 77 | [ sortlist ] SYMBOL_+ 78 | @ 79 | biggest 80 | @ 81 | > 82 | [ 008 ] BRANCHZ 83 | [ 0011 ] INDEX 2* 84 | [ sortlist ] SYMBOL_+ 85 | @ 86 | biggest 87 | ! 88 | [ 007 ] BRANCH 89 | 90 | [ 008 ] LABEL 91 | [ 0011 ] INDEX 92 | 2* 93 | [ sortlist ] SYMBOL_+ 94 | @ 95 | littlest 96 | @ 97 | < 98 | [ 107 ] BRANCHZ 99 | [ 0011 ] INDEX 100 | 2* 101 | [ sortlist ] SYMBOL_+ 102 | @ 103 | littlest 104 | ! 105 | [ 007 ] LABEL 106 | [ 107 ] LABEL 107 | 108 | R> 109 | 1 110 | + 111 | DUP_>R 112 | 5000 113 | U> 114 | [ 0011 ] BRANCHZ 115 | [ 0011 DROP_INDEX ] R>DROP 116 | 117 | EXIT [ 0012 ] LABEL 118 | ; 119 | 120 | 64 FRAME_SIZE ! 121 | : Quicksort 122 | 123 | 1_PICK 124 | 1_PICK 125 | 1_PICK 126 | 1_PICK + 127 | 0_pick 128 | 0< 129 | 130 | [ 0014 ] BRANCHZ 131 | 132 | 1 133 | + 134 | [ 0014 ] LABEL 135 | 136 | 0_pick 137 | -2 138 | AND 139 | 6_pick + 140 | @ 141 | 142 | [ 0015 ] LABEL 143 | 144 | 3_pick 145 | 2* 146 | 7_pick + 147 | @ 148 | 1_pick 149 | < 150 | 151 | [ 0028 ] BRANCHZ 152 | 153 | [ 0020 ] LABEL 154 | 3_pick 155 | 1 156 | + 157 | 4_PUT 158 | 3_pick 159 | 2* 160 | 7_pick + 161 | @ 162 | 1_pick 163 | >= 164 | [ 0020 ] BRANCHZ 165 | 166 | [ 0028 ] LABEL 167 | 168 | 2_pick 169 | 170 | 2* 171 | 7_pick + 172 | @ 173 | 1_pick 174 | > 175 | [ 0027 ] BRANCHZ 176 | 177 | [ 0023 ] LABEL 178 | 2_pick 179 | 1 180 | - 181 | 3_PUT 182 | 2_pick 183 | 2* 184 | 7_pick + 185 | @ 186 | 1_pick 187 | <= 188 | [ 0023 ] BRANCHZ 189 | 190 | [ 0027 ] LABEL 191 | 192 | 3_PICK 193 | 3_pick 194 | <= 195 | [ 0017 ] BRANCHZ 196 | 197 | 3_pick 198 | 2* 199 | 7_pick + 200 | @ 201 | 202 | 4_pick 203 | 2* 204 | 8_pick + 205 | 4_pick 206 | 2* 207 | 9_pick + 208 | @ 209 | SWAP 210 | ! 211 | 212 | 3_pick 213 | 2* 214 | 8_pick + 215 | ! 216 | 217 | 3_pick 218 | 1 219 | + 220 | 4_PUT 221 | 222 | -1 223 | 3_pick + 224 | 3_PUT 225 | 226 | [ 0017 ] LABEL 227 | 228 | 3_PICK 229 | 3_pick 230 | > 231 | 232 | [ 0015 ] BRANCHZ 233 | 234 | drop 235 | drop 236 | 5 U! 237 | 2 U! 238 | 3 U! 239 | SWAP 7 U! 240 | [ 6 ] DUP_U! 241 | 242 | 5 U@ 243 | < 244 | [ 0025 ] BRANCHZ 245 | 7 U@ 246 | 6 U@ 247 | 5 U@ 248 | 249 | -64 FP+! 250 | recurse 64 FP+! 251 | 252 | [ 0025 ] LABEL 253 | 254 | 2 U@ 255 | 3 U@ 256 | < 257 | [ 0026 ] BRANCHZ 258 | 7 U@ 259 | 2 U@ 260 | 3 U@ 261 | 262 | -64 FP+! 263 | recurse 64 FP+! 264 | EXIT [ 0026 ] LABEL 265 | ; 266 | 267 | 64 FRAME_SIZE ! 268 | : main 269 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 270 | 271 | 0 272 | 2 U! 273 | [ 274 | sortlist 275 | 2 276 | + 277 | ] LITERAL 278 | 3 U! 279 | 280 | [ 0035 ] LABEL 281 | 282 | -64 FP+! 283 | Initarr 284 | 64 FP+! 285 | 286 | sortlist 287 | 1 288 | 5000 289 | 290 | -64 FP+! 291 | Quicksort 292 | 64 FP+! 293 | 294 | 3 U@ 295 | @ 296 | littlest 297 | @ 298 | - 299 | [ 0034 ] BRANCHNZ 300 | [ 301 | sortlist 302 | 10000 303 | + 304 | ] LITERAL 305 | @ 306 | biggest 307 | @ 308 | - 309 | [ 0032 ] BRANCHZ 310 | [ 0034 ] LABEL 311 | 312 | -64 FP+! 313 | do_error 314 | 64 FP+! 315 | 316 | [ 0032 ] LABEL 317 | 2 U@ 318 | 1 319 | + 320 | [ 2 ] DUP_U! 321 | dup . 49 322 | > 323 | [ 0035 ] BRANCHZ 324 | 325 | EXIT [ 0036 ] LABEL 326 | ; 327 | 328 | .( max 49) cr 329 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/towers.ces: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ /* from Stanford benchmark suite */ 3 | \ /* modified for reasonable 16-bit operation */ 4 | 5 | \ CESYS compiled 6 | 7 | EMPTY 8 | : XY " DOS XY towers.ces" EVALUATE ; 9 | 10 | \ #define maxcells 18 11 | \ #define stackrange 3 12 | \ #define true 1 13 | \ #define false 0 14 | 15 | DECIMAL 16 | load gnutool.4th 17 | 18 | 100 REG-ADDR $FFC0 AND UBR! 19 | 20 | \ int stack[stackrange+1]; 21 | \ struct element cellspace[maxcells+1]; 22 | \ int freelist, movesdone; 23 | VARIABLE movesdone 4 CELL- ALLOT 24 | VARIABLE freelist 4 CELL- ALLOT 25 | VARIABLE cellspace 76 CELL- ALLOT 26 | VARIABLE stack 8 CELL- ALLOT 27 | 28 | \ gcc_compiled.: 29 | ( RTX 2000 code generation) 30 | 31 | \ static void do_error() { 32 | : do_error ( FUNC ) ( 3 top> empty ) 33 | \ { printf (" Error in Towers.\n"); } 34 | ." Error in Towers." cr 35 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 36 | 37 | : Makenull 38 | >r $0 stack r@ 2* + ! 39 | r> drop ; 40 | 41 | : Getelement 42 | freelist @ $0 > 1 and 43 | [ 44 ] branchz 44 | freelist @ 0 u! 45 | cellspace freelist @ 2* 2* + $2 + @ freelist ! 46 | [ 45 ] branch 47 | 48 | [ 44 ] label 49 | 17 g@ 64 + 17 g! 50 | do_error 51 | 17 g@ 64 - 17 g! 52 | 53 | [ 45 ] label 54 | 0 u@ ; 55 | 56 | : Push 57 | 0 u! 1 u! 58 | $0 2 u! 59 | stack 1 u@ 2* + @ $0 > 1 and 60 | [ 48 ] branchz 61 | 62 | cellspace stack 1 u@ 2* + @ 63 | 2* 2* + @ 0 u@ <= 1 and 64 | [ 49 ] branchz 65 | 66 | $1 2 u! 67 | 17 g@ 64 + 17 g! 68 | do_error 69 | 17 g@ 64 - 17 g! 70 | 71 | [ 49 ] label 72 | [ 48 ] label 73 | 74 | 2 u@ 0= 1 and 75 | [ 51 ] branchz 76 | 77 | 17 g@ 64 + 17 g! 78 | Getelement 79 | 17 g@ 64 - 17 g! 80 | 81 | 3 u! 82 | stack 1 u@ 2* + @ 83 | cellspace 3 u@ 2* 2* + $2 + ! 84 | 3 u@ stack 1 u@ 2* + ! 85 | 0 u@ cellspace 3 u@ 2* 2* + ! 86 | 87 | [ 51 ] label 88 | ; 89 | 90 | : Init 91 | 0 u! 1 u! 0 u@ 92 | 17 g@ 64 + 17 g! 93 | Makenull 94 | 17 g@ 64 - 17 g! 95 | 1 u@ 2 u! 96 | 97 | [ 53 ] label 98 | $1 2 u@ <= 1 and 99 | [ 54 ] branchz 100 | 101 | 0 u@ 2 u@ 102 | 17 g@ 64 + 17 g! 103 | Push 104 | 17 g@ 64 - 17 g! 105 | 106 | [ 55 ] label 107 | 2 u@ $1 - 2 u! 108 | [ 53 ] branch 109 | 110 | [ 54 ] label 111 | ; 112 | 113 | : Pop 114 | >r stack r@ 2* + @ $0 > 1 and 115 | [ 57 ] branchz 116 | cellspace stack 117 | r@ 2* + @ 2* 2* + @ 2 u! 118 | cellspace stack r@ 2* + @ 119 | 2* 2* + $2 + @ 1 u! 120 | freelist @ cellspace stack r@ 2* + @ 2* 2* + $2 + ! 121 | stack r@ 2* + @ freelist ! 122 | 1 u@ stack r@ 2* + ! 2 u@ r> drop exit 123 | 124 | [ 57 ] label 125 | 17 g@ 64 + 17 g! 126 | do_error 127 | 17 g@ 64 - 17 g! 128 | $0 r> drop ; 129 | 130 | : Move 131 | 0 u! 1 u! 1 u@ 0 u@ 132 | 17 g@ 64 + 17 g! 133 | Pop 134 | 17 g@ 64 - 17 g! 135 | 136 | 17 g@ 64 + 17 g! 137 | Push 138 | 17 g@ 64 - 17 g! 139 | movesdone @ $1 + movesdone ! 140 | ; 141 | 142 | : tower 143 | 0 u! 1 u! 2 u! 2 u@ $1 = 1 and 144 | [ 61 ] branchz 145 | 1 u@ 0 u@ 146 | 17 g@ 64 + 17 g! 147 | Move 148 | 17 g@ 64 - 17 g! 149 | [ 62 ] branch 150 | 151 | [ 61 ] label 152 | $6 0 u@ - 1 u@ - 3 u! 153 | 2 u@ $ffff + 3 u@ 0 u@ 154 | 17 g@ 64 + 17 g! 155 | RECURSE \ tower 156 | 17 g@ 64 - 17 g! 157 | 1 u@ 0 u@ 158 | 17 g@ 64 + 17 g! 159 | Move 160 | 17 g@ 64 - 17 g! 161 | 2 u@ $ffff + 1 u@ 3 u@ 162 | 17 g@ 64 + 17 g! 163 | RECURSE \ tower 164 | 17 g@ 64 - 17 g! 165 | 166 | [ 62 ] label 167 | ; 168 | 169 | : main 170 | 100 REG-ADDR $FFC0 AND UBR! $0 1 u! 171 | 172 | [ 64 ] label 173 | $23 1 u@ 174 | dup . 175 | > 1 and 176 | [ 65 ] branchz 177 | 178 | $1 0 u! 179 | 180 | [ 67 ] label 181 | 0 u@ $12 <= 1 and 182 | [ 68 ] branchz 183 | 0 u@ $ffff + cellspace 0 u@ 2* 2* + $2 + ! 184 | 185 | [ 69 ] label 186 | 0 u@ $1 + 0 u! 187 | [ 67 ] branch 188 | 189 | [ 68 ] label 190 | $12 freelist ! $e $1 191 | 17 g@ 64 + 17 g! 192 | Init 193 | 17 g@ 64 - 17 g! 194 | $2 195 | 17 g@ 64 + 17 g! 196 | Makenull 197 | 17 g@ 64 - 17 g! 198 | $3 199 | 17 g@ 64 + 17 g! 200 | Makenull 201 | 17 g@ 64 - 17 g! 202 | $0 movesdone ! $e $2 $1 203 | 17 g@ 64 + 17 g! 204 | tower 205 | 17 g@ 64 - 17 g! 206 | movesdone @ $3fff <> 1 and 207 | [ 70 ] branchz 208 | 209 | 17 g@ 64 + 17 g! 210 | do_error 211 | 17 g@ 64 - 17 g! 212 | 213 | [ 70 ] label 214 | [ 66 ] label 215 | 1 u@ $1 + 1 u! 216 | [ 64 ] branch 217 | 218 | [ 65 ] label 219 | ; 220 | -------------------------------------------------------------------------------- /RTX2000/TESTS/sieve.d.4th: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Sieve Prime Number Program in C from Byte January 1983 */ 2 | \ Improved source code GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY sieve.d.4th" EVALUATE ; 6 | 7 | load gnutool.4th 8 | 9 | VARIABLE flags 8192 CELL- ALLOT 10 | 11 | DECIMAL 12 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 13 | 14 | : do_error 15 | ." Error in Sieve." CR 16 | ; 17 | 18 | 64 FRAME_SIZE ! 19 | : main 20 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 21 | 1 ( LIT) ( 6 top> empty ) 22 | [ 0020 ADD_INDEX ] >R ( 137 top> #65 ) 23 | ( TYPE 1 LOOP BEGIN) ( 7 top> empty ) 24 | [ 0020 ] LABEL ( 107 top> empty ) 25 | 0 ( LIT) ( 14 top> empty ) 26 | flags ( SYMBOL) ( 16 top> #64 ) 27 | [ ( 131 top> #69 #64 ) 28 | flags ( SYMBOL) ( 131 top> #69 #64 ) 29 | 8190 ( LIT) ( 131 top> #0x #69 #64 ) 30 | + ( 131 top> #0x #0x #69 #64 ) 31 | ] LITERAL ( 131 top> #0x #69 #64 ) 32 | ROT ( 132 top> #71d #69 #64 ) 33 | 2 U! ( 132 top> #64 #71d #69 ) 34 | OVER ( #69) ( 132 top> #71d #69 ) 35 | 3 U! ( 132 top> #69 #71d #69x ) 36 | U> ( 134 top> #71x #69x ) 37 | [ 0023 ] BRANCHNZ ( 134 top> #0x ) 38 | [ ( 135 top> empty ) 39 | flags ( SYMBOL) ( 135 top> empty ) 40 | 8190 ( LIT) ( 135 top> #0x ) 41 | + ( 135 top> #0x #0x ) 42 | ] LITERAL ( 135 top> #0x ) 43 | 4 U! ( 17 top> #71 ) 44 | ( LOOP_BEGIN) ( 17 top> empty ) 45 | [ 009 ] LABEL ( 29 top> empty ) 46 | 1 ( LIT) ( 24 top> empty ) 47 | 3 U@ ( 24 top> #0x ) 48 | C! ( 24 top> #69x #0x ) 49 | 3 U@ ( 28 top> empty ) 50 | 1 ( LIT) ( 28 top> #69x ) 51 | + ( 28 top> #0x #69x ) 52 | [ 3 ] DUP_U! ( 21 top> #69 ) 53 | 4 U@ ( 21 top> #69x ) 54 | U> ( 22 top> #71x #69x ) 55 | [ 009 ] BRANCHZ ( 22 top> #0x ) 56 | ( LOOP_END) ( 34 top> empty ) 57 | [ 0023 ] LABEL ( 133 top> empty ) 58 | 0 ( LIT) ( 37 top> empty ) 59 | [ 0018 ADD_INDEX ] >R ( 125 top> #66 ) 60 | ( TYPE 1 LOOP BEGIN) ( 38 top> empty ) 61 | [ 0018 ] LABEL ( 88 top> empty ) 62 | flags ( SYMBOL) ( 46 top> empty ) 63 | [ 0018 ] INDEX + ( 46 top> #74x ) 64 | C@ ( 47 top> #75d ) 65 | [ 0012 ] BRANCHZ ( 50 top> #0x ) 66 | [ 0018 ] INDEX ( 53 top> empty ) 67 | 2* ( 53 top> #66x ) 68 | 3 ( LIT) ( 55 top> #78d ) 69 | + ( 55 top> #0x #0x ) 70 | [ 0018 ] INDEX ( 57 top> #68 ) 71 | OVER_+ ( #68 ) ( 57 top> #66x #68 ) 72 | [ 5 ] DUP_U! ( 119 top> #67 #68 ) 73 | SWAP ( 119 top> #67 #68 ) 74 | 6 U! ( 119 top> #68 #67 ) 75 | 8190 ( LIT) ( 119 top> #67x ) 76 | <= ( 121 top> #81x #67x ) 77 | [ 0021 ] BRANCHZ ( 121 top> #0x ) 78 | ( LOOP_BEGIN) ( 59 top> empty ) 79 | [ 0017 ] LABEL ( 74 top> empty ) 80 | 0 ( LIT) ( 67 top> empty ) 81 | flags ( SYMBOL) ( 67 top> #0x ) 82 | 5 U@ + ( 68 top> #74x #0x ) 83 | C! ( 68 top> #83x #0x ) 84 | 5 U@ ( 72 top> empty ) 85 | 6 U@ + ( 72 top> #67x ) 86 | [ 5 ] DUP_U! ( 62 top> #67 ) 87 | 8190 ( LIT) ( 62 top> #67x ) 88 | > ( 63 top> #81x #67x ) 89 | [ 0017 ] BRANCHZ ( 63 top> #0x ) 90 | ( TYPE 2 LOOP END) ( 79 top> empty ) 91 | [ 0021 ] LABEL ( 120 top> empty ) 92 | 1 ( LIT) ( 82 top> empty ) 93 | 2 U@ + 2 U! ( 86 top> #0x ) 94 | [ 0012 ] LABEL ( 86 top> empty ) 95 | R> ( 87 top> empty ) 96 | 1 ( LIT) ( 87 top> #66x ) 97 | + ( 87 top> #0x #66x ) 98 | DUP_>R ( #66 ) ( 41 top> #66 ) 99 | 8190 ( LIT) ( 41 top> #66x ) 100 | U> ( 42 top> #73x #66x ) 101 | [ 0018 ] BRANCHZ ( 42 top> #0x ) 102 | [ 0018 DROP_INDEX ] R>DROP ( 93 top> empty ) 103 | [ 0022 ] LABEL ( 126 top> empty ) 104 | 2 U@ ( 97 top> empty ) 105 | 1899 ( LIT) ( 97 top> #64x ) 106 | - ( 98 top> #85x #64x ) 107 | [ 005 ] BRANCHZ ( 98 top> #0x ) 108 | -64 FP+! ( Link) ( 100 top> empty ) 109 | do_error ( CALL) ( 100 top> empty ) 110 | 64 FP+! ( Unlink) ( 100 top> empty ) 111 | [ 005 ] LABEL ( 105 top> empty ) 112 | R> ( 106 top> empty ) 113 | 1 ( LIT) ( 106 top> #65x ) 114 | + ( 106 top> #0x #65x ) 115 | DUP_>R ( #65 ) ( 10 top> #65 ) 116 | 349 ( LIT) ( 10 top> #65x ) 117 | U> ( 11 top> #70x #65x ) 118 | [ 0020 ] BRANCHZ ( 11 top> #0x ) 119 | [ 0020 DROP_INDEX ] R>DROP ( 112 top> empty ) 120 | EXIT [ 0024 ] LABEL ( 138 top> empty ) 121 | ; ( END ) 122 | 123 | 124 | .( max 349) cr 125 | -------------------------------------------------------------------------------- /RTX2000/TESTS/towers.c.4th: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ GNU C 2020/3000 3 | 4 | EMPTY 5 | : XY " DOS XY towers.c.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE movesdone 4 CELL- ALLOT 13 | VARIABLE freelist 4 CELL- ALLOT 14 | VARIABLE cellspace 76 CELL- ALLOT 15 | VARIABLE stack 8 CELL- ALLOT 16 | 17 | : do_error 18 | ." Error in Towers." cr 19 | ; 20 | 21 | : Error 22 | ." Error in Towers." cr 23 | ; 24 | 25 | 64 FRAME_SIZE ! 26 | : Makenull 27 | 28 | 2* 29 | [ stack ] SYMBOL_+ 30 | [ 0 ] LIT_SWAP 31 | ! 32 | ; 33 | 34 | 64 FRAME_SIZE ! 35 | : Getelement 36 | 37 | freelist 38 | @ 39 | 0> 40 | [ 005 ] BRANCHZ 41 | 42 | freelist 43 | @ 44 | 45 | DUP 46 | 2* 47 | 2* 48 | [ cellspace ] SYMBOL_+ 49 | 2 50 | + 51 | @ 52 | freelist 53 | ! 54 | exit 55 | [ 006 ] BRANCH 56 | 57 | [ 005 ] LABEL 58 | 59 | -64 FP+! 60 | Error 61 | 64 FP+! 62 | [ 006 ] LABEL 63 | 64 | 0 65 | ; 66 | 67 | 64 FRAME_SIZE ! 68 | : Push 69 | 70 | 0 71 | 72 | 1_pick 73 | 2* 74 | [ stack ] SYMBOL_+ 75 | @ 76 | 0> 77 | 78 | [ 008 ] BRANCHZ 79 | 80 | 1_pick 81 | 2* 82 | [ stack ] SYMBOL_+ 83 | @ 84 | 2* 85 | 2* 86 | [ cellspace ] SYMBOL_+ 87 | @ 88 | 3_pick 89 | <= 90 | [ 108 ] BRANCHZ 91 | 92 | 1 93 | 1_PUT 94 | 95 | -64 FP+! 96 | Error 97 | 64 FP+! 98 | 99 | [ 008 ] LABEL 100 | [ 108 ] LABEL 101 | 102 | [ 0010 ] BRANCHNZ 103 | 104 | Getelement 105 | 106 | 0_pick 107 | 2* 108 | 2* 109 | [ cellspace ] SYMBOL_+ 110 | 2_pick 111 | 2* 112 | [ stack ] SYMBOL_+ 113 | @_SWAP 114 | 2 115 | + 116 | ! 117 | 118 | 1_pick 119 | 2* 120 | [ stack ] SYMBOL_+ 121 | 1_pick 122 | SWAP ! 123 | 124 | 2* 125 | 2* 126 | [ cellspace ] SYMBOL_+ 127 | 2_pick SWAP 128 | ! 129 | [ 0010 ] LABEL 130 | 131 | drop 132 | drop 133 | 134 | ; 135 | 136 | 64 FRAME_SIZE ! 137 | : Init 138 | 139 | OVER 140 | 141 | Makenull 142 | 143 | 0_pick 144 | 0> 145 | [ 0016 ] BRANCHZ 146 | 147 | SWAP 4 U! 148 | 149 | [ 0015 ] LABEL 150 | 151 | [ 5 ] DUP_U! 152 | 4 U@ 153 | 154 | Push 155 | -1 156 | 5 U@ + 157 | 0_pick 158 | 0> 159 | [ 0015 ] BRANCHNZ 160 | 161 | drop exit 162 | 163 | [ 0016 ] LABEL 164 | drop drop 165 | ; 166 | 167 | 64 FRAME_SIZE ! 168 | : Pop 169 | 170 | 0_pick 171 | 2* 172 | [ stack ] SYMBOL_+ 173 | @ 174 | 0> 175 | [ 0018 ] BRANCHZ 176 | 177 | 0_pick 178 | 2* 179 | [ stack ] SYMBOL_+ 180 | @ 181 | 182 | 2* 183 | 2* 184 | [ cellspace ] SYMBOL_+ 185 | @ 186 | 1_pick 187 | 2* 188 | [ stack ] SYMBOL_+ 189 | @ 190 | 191 | 2* 192 | 2* 193 | [ cellspace ] SYMBOL_+ 194 | 2 195 | + 196 | @ 197 | 2_pick 198 | 2* 199 | [ stack ] SYMBOL_+ 200 | @ 201 | 2* 202 | 2* 203 | [ cellspace ] SYMBOL_+ 204 | freelist 205 | @_SWAP 206 | 2 207 | + 208 | ! 209 | 210 | 2_pick 211 | 2* 212 | [ stack ] SYMBOL_+ 213 | @ 214 | freelist 215 | ! 216 | 217 | 2_pick 218 | 2* 219 | [ stack ] SYMBOL_+ 220 | ! 221 | NIP 222 | EXIT 223 | 224 | [ 0018 ] LABEL 225 | DROP 226 | 227 | -64 FP+! 228 | Error 229 | 64 FP+! 230 | EXIT [ 0017 ] LABEL 231 | ; 232 | 233 | 64 FRAME_SIZE ! 234 | : Move 235 | 236 | 2 U! 237 | 238 | Pop 239 | 2 U@ 240 | 241 | Push 242 | 243 | 1 244 | movesdone 245 | +! 246 | ; 247 | 248 | 64 FRAME_SIZE ! 249 | : tower 250 | 251 | 0_pick 252 | 1 253 | - 254 | [ 0022 ] BRANCHNZ 255 | 256 | DROP 257 | 258 | -64 FP+! 259 | Move 260 | 64 FP+! 261 | EXIT 262 | 263 | [ 0022 ] LABEL 264 | 265 | 6 266 | 2_pick 267 | - 268 | 3_pick 269 | - 270 | [ 8 ] DUP_U! 271 | SWAP 2 U! SWAP 3 U! 272 | OVER 4 U! 273 | 274 | 2 U@ 275 | 1 276 | - 277 | 278 | -64 FP+! 279 | recurse 64 FP+! 280 | 281 | 4 U@ 282 | 3 U@ 283 | 284 | -64 FP+! 285 | Move 286 | 64 FP+! 287 | 288 | 8 U@ 289 | 3 U@ 290 | 2 U@ 291 | 1 292 | - 293 | 294 | -64 FP+! 295 | recurse 64 FP+! 296 | 297 | EXIT [ 0023 ] LABEL 298 | ; 299 | 300 | 64 FRAME_SIZE ! 301 | : main 302 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 303 | 304 | 0 305 | [ 0033 ADD_INDEX ] >R 306 | 307 | [ 0033 ] LABEL 308 | 309 | 1 310 | [ 0031 ADD_INDEX ] >R 311 | 312 | [ 0031 ] LABEL 313 | 314 | [ 0031 ] INDEX 315 | 2* 316 | 2* 317 | [ cellspace ] SYMBOL_+ 318 | [ 0031 ] INDEX 319 | 1 320 | - 321 | SWAP 322 | 2 323 | + 324 | ! 325 | R> 326 | 1 327 | + 328 | DUP_>R 329 | 18 330 | U> 331 | [ 0031 ] BRANCHZ 332 | [ 0031 DROP_INDEX ] R>DROP 333 | 334 | [ 0034 ] LABEL 335 | 336 | 18 337 | freelist 338 | ! 339 | 340 | 1 341 | 14 342 | 343 | -64 FP+! 344 | Init 345 | 64 FP+! 346 | 347 | 2 348 | 349 | Makenull 350 | 351 | 3 352 | 353 | Makenull 354 | 355 | 0 356 | movesdone 357 | ! 358 | 359 | 1 360 | 2 361 | 14 362 | 363 | -64 FP+! 364 | tower 365 | 64 FP+! 366 | 367 | movesdone 368 | @ 369 | 16383 370 | - 371 | [ 0027 ] BRANCHZ 372 | 373 | -64 FP+! 374 | do_error 375 | 64 FP+! 376 | 377 | [ 0027 ] LABEL 378 | R> 379 | 1 380 | + 381 | DUP_>R 382 | dup . 34 383 | U> 384 | [ 0033 ] BRANCHZ 385 | [ 0033 DROP_INDEX ] R>DROP 386 | EXIT [ 0035 ] LABEL 387 | ; 388 | 389 | .( max 34) cr 390 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/sieve.rtx: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Siee Prime Number Program in C from Byte January 1983 */ 2 | 3 | EMPTY 4 | : XY " DOS XY sieve.rtx " EVALUATE ; 5 | 6 | load gnutool.4th 7 | 8 | \ char flags [size+1]; 9 | VARIABLE flags 8192 CELL- ALLOT 10 | \ #define true 1 11 | \ #define false 0 12 | \ #define size 8190 13 | 14 | DECIMAL 15 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 16 | 17 | \ gcc_compiled.: 18 | ( RTX 2000 code generation) 19 | 20 | \ static void do_error() { 21 | : do_error ( FUNC ) ( 3 top> empty ) 22 | \ printf(" Error in Sieve.\n"); } 23 | ." Error in Sieve." CR 24 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 25 | 26 | 27 | \ void main() 28 | : main ( FUNC ) ( 3 top> empty ) 29 | \ { 30 | \ int prime, count, iter; 31 | \ register i,k; 32 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 33 | 34 | \ for(iter = 1; iter < 350 ; iter++) 35 | 1 ( LIT) ( 6 top> empty ) 36 | [ 0019 ADD_INDEX ] >R ( 137 top> #66 ) 37 | ( TYPE 1 LOOP BEGIN) ( 7 top> empty ) 38 | 39 | \ { 40 | [ 0019 ] LABEL ( 99 top> empty ) 41 | 42 | \ count = 0 ; /* prime counter */ 43 | 0 ( LIT) ( 14 top> empty ) 44 | 2 U! ( 16 top> #65 ) 45 | 46 | \ for (i = 0; i <= size; i++) /* set all flags true */ 47 | 0 ( LIT) ( 131 top> empty ) 48 | [ 009 ADD_INDEX ] >R ( 131 top> #67 ) 49 | ( TYPE 1 LOOP BEGIN) ( 17 top> empty ) 50 | 51 | [ 009 ] LABEL ( 30 top> empty ) 52 | 53 | \ flags[i] = true ; 54 | 1 ( LIT) ( 24 top> empty ) 55 | flags ( SYMBOL) ( 24 top> #0x ) 56 | [ 009 ] INDEX + ( 25 top> #71x #0x ) 57 | C! ( 25 top> #72x #0x ) 58 | R> ( 29 top> empty ) 59 | 1 ( LIT) ( 29 top> #67x ) 60 | + ( 29 top> #0x #67x ) 61 | DUP_>R ( 20 top> #67 ) 62 | 8190 ( LIT) ( 20 top> #67x ) 63 | U> ( 21 top> #70x #67x ) 64 | [ 009 ] BRANCHZ ( 21 top> #0x ) 65 | [ 009 DROP_INDEX ] R>DROP ( 35 top> empty ) 66 | [ 0023 ] LABEL ( 132 top> empty ) 67 | 68 | \ for (i = 0; i <= size; i++) 69 | 0 ( LIT) ( 38 top> empty ) 70 | [ 0018 ADD_INDEX ] >R ( 125 top> #67 ) 71 | ( TYPE 1 LOOP BEGIN) ( 39 top> empty ) 72 | 73 | \ { 74 | [ 0018 ] LABEL ( 88 top> empty ) 75 | 76 | \ if (flags[i]) /* found a prime */ 77 | flags ( SYMBOL) ( 47 top> empty ) 78 | [ 0018 ] INDEX + ( 47 top> #71x ) 79 | C@ ( 48 top> #75d ) 80 | [ 0012 ] BRANCHZ ( 51 top> #0x ) 81 | 82 | \ { 83 | \ prime = i + i + 3 ; 84 | [ 0018 ] INDEX ( 54 top> empty ) 85 | 2* ( 54 top> #67x ) 86 | 3 ( LIT) ( 56 top> #78d ) 87 | + ( 56 top> #0x #0x ) 88 | [ 0018 ] INDEX ( 58 top> #64 ) 89 | OVER_+ ( 58 top> #67x #64 ) 90 | [ 3 ] DUP_U! ( 119 top> #68 #64 ) 91 | 92 | \ for (k = i+prime; k<=size; k+= prime) 93 | SWAP ( 119 top> #68 #64 ) 94 | 4 U! ( 119 top> #64 #68 ) 95 | 8190 ( LIT) ( 119 top> #68x ) 96 | <= ( 121 top> #81x #68x ) 97 | [ 0021 ] BRANCHZ ( 121 top> #0x ) 98 | ( LOOP_BEGIN) ( 60 top> empty ) 99 | [ 0017 ] LABEL ( 74 top> empty ) 100 | 101 | \ flags[k] = false; 102 | 0 ( LIT) ( 67 top> empty ) 103 | flags ( SYMBOL) ( 67 top> #0x ) 104 | 3 U@ + ( 68 top> #71x #0x ) 105 | C! ( 68 top> #83x #0x ) 106 | 3 U@ ( 72 top> empty ) 107 | 4 U@ + ( 72 top> #68x ) 108 | [ 3 ] DUP_U! ( 63 top> #68 ) 109 | 8190 ( LIT) ( 63 top> #68x ) 110 | > ( 64 top> #81x #68x ) 111 | [ 0017 ] BRANCHZ ( 64 top> #0x ) 112 | ( TYPE 2 LOOP END) ( 79 top> empty ) 113 | [ 0021 ] LABEL ( 120 top> empty ) 114 | 115 | \ count++; 116 | 1 ( LIT) ( 82 top> empty ) 117 | 2 U@ + 2 U! ( 86 top> #0x ) 118 | 119 | \ } 120 | [ 0012 ] LABEL ( 86 top> empty ) 121 | R> ( 87 top> empty ) 122 | 1 ( LIT) ( 87 top> #67x ) 123 | + ( 87 top> #0x #67x ) 124 | DUP_>R ( 42 top> #67 ) 125 | 8190 ( LIT) ( 42 top> #67x ) 126 | U> ( 43 top> #73x #67x ) 127 | [ 0018 ] BRANCHZ ( 43 top> #0x ) 128 | [ 0018 DROP_INDEX ] R>DROP ( 93 top> empty ) 129 | 130 | \ } 131 | [ 0022 ] LABEL ( 126 top> empty ) 132 | R> ( 98 top> empty ) 133 | 1 ( LIT) ( 98 top> #66x ) 134 | + ( 98 top> #0x #66x ) 135 | DUP_>R ( 10 top> #66 ) 136 | 349 ( LIT) ( 10 top> #66x ) 137 | U> ( 11 top> #69x #66x ) 138 | [ 0019 ] BRANCHZ ( 11 top> #0x ) 139 | [ 0019 DROP_INDEX ] R>DROP ( 104 top> empty ) 140 | 141 | \ } 142 | [ 0024 ] LABEL ( 138 top> empty ) 143 | 144 | \ if (count != 1899) do_error(); 145 | 2 U@ ( 108 top> empty ) 146 | 1899 ( LIT) ( 108 top> #65x ) 147 | - ( 109 top> #85x #65x ) 148 | [ 0020 ] BRANCHZ ( 109 top> #0x ) 149 | -64 FP+! ( Link) ( 111 top> empty ) 150 | do_error ( CALL) ( 111 top> empty ) 151 | 64 FP+! ( Unlink) ( 111 top> empty ) 152 | EXIT [ 0020 ] LABEL ( 113 top> empty ) 153 | \ } 154 | ; ( END ) 155 | 156 | -------------------------------------------------------------------------------- /RTX2000/COMVERS/sieve.ins: -------------------------------------------------------------------------------- 1 | \ /* Eratosthenes Siee Prime Number Program in C from Byte January 1983 */ 2 | 3 | EMPTY 4 | : XY " DOS XY sieve.ins " EVALUATE ; 5 | 6 | load GNUins.4 7 | 8 | \ char flags [size+1]; 9 | VARIABLE flags 8192 CELL- ALLOT 10 | \ #define true 1 11 | \ #define false 0 12 | \ #define size 8190 13 | 14 | DECIMAL 15 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 16 | 17 | \ gcc_compiled.: 18 | ( RTX 2000 code generation) 19 | 20 | \ static void do_error() { 21 | : do_error ( FUNC ) ( 3 top> empty ) 22 | \ printf(" Error in Sieve.\n"); } 23 | ." Error in Sieve." CR 24 | ; ( END ) ( 13 top> #2x )( RTX 2000 code generation) 25 | 26 | 27 | \ void main() 28 | : main ( FUNC ) ( 3 top> empty ) 29 | \ { 30 | \ int prime, count, iter; 31 | \ register i,k; 32 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 33 | 34 | \ for(iter = 1; iter < 350 ; iter++) 35 | 1 ( LIT) ( 6 top> empty ) 36 | [ 0019 ADD_INDEX ] >R ( 137 top> #66 ) 37 | ( TYPE 1 LOOP BEGIN) ( 7 top> empty ) 38 | 39 | \ { 40 | [ 0019 ] LABEL ( 99 top> empty ) 41 | 42 | \ count = 0 ; /* prime counter */ 43 | 0 ( LIT) ( 14 top> empty ) 44 | 2 U!! ( 16 top> #65 ) 45 | 46 | \ for (i = 0; i <= size; i++) /* set all flags true */ 47 | 0 ( LIT) ( 131 top> empty ) 48 | [ 009 ADD_INDEX ] >R ( 131 top> #67 ) 49 | ( TYPE 1 LOOP BEGIN) ( 17 top> empty ) 50 | 51 | [ 009 ] LABEL ( 30 top> empty ) 52 | 53 | \ flags[i] = true ; 54 | 1 ( LIT) ( 24 top> empty ) 55 | flags ( SYMBOL) ( 24 top> #0x ) 56 | [ 009 ] INDEX + ( 25 top> #71x #0x ) 57 | C! ( 25 top> #72x #0x ) 58 | R> ( 29 top> empty ) 59 | 1 ( LIT) ( 29 top> #67x ) 60 | + ( 29 top> #0x #67x ) 61 | DUP_>R ( 20 top> #67 ) 62 | 8190 ( LIT) ( 20 top> #67x ) 63 | U> ( 21 top> #70x #67x ) 64 | [ 009 ] BRANCHZ ( 21 top> #0x ) 65 | [ 009 DROP_INDEX ] R>DROP ( 35 top> empty ) 66 | [ 0023 ] LABEL ( 132 top> empty ) 67 | 68 | \ for (i = 0; i <= size; i++) 69 | 0 ( LIT) ( 38 top> empty ) 70 | [ 0018 ADD_INDEX ] >R ( 125 top> #67 ) 71 | ( TYPE 1 LOOP BEGIN) ( 39 top> empty ) 72 | 73 | \ { 74 | [ 0018 ] LABEL ( 88 top> empty ) 75 | 76 | \ if (flags[i]) /* found a prime */ 77 | flags ( SYMBOL) ( 47 top> empty ) 78 | [ 0018 ] INDEX + ( 47 top> #71x ) 79 | C@ ( 48 top> #75d ) 80 | [ 0012 ] BRANCHZ ( 51 top> #0x ) 81 | 82 | \ { 83 | \ prime = i + i + 3 ; 84 | [ 0018 ] INDEX ( 54 top> empty ) 85 | 2* ( 54 top> #67x ) 86 | 3 ( LIT) ( 56 top> #78d ) 87 | + ( 56 top> #0x #0x ) 88 | [ 0018 ] INDEX ( 58 top> #64 ) 89 | OVER_+ ( 58 top> #67x #64 ) 90 | [ 3 ] DUP_U! ( 119 top> #68 #64 ) 91 | 92 | \ for (k = i+prime; k<=size; k+= prime) 93 | SWAP ( 119 top> #68 #64 ) 94 | 4 U!! ( 119 top> #64 #68 ) 95 | 8190 ( LIT) ( 119 top> #68x ) 96 | <= ( 121 top> #81x #68x ) 97 | [ 0021 ] BRANCHZ ( 121 top> #0x ) 98 | ( LOOP_BEGIN) ( 60 top> empty ) 99 | [ 0017 ] LABEL ( 74 top> empty ) 100 | 101 | \ flags[k] = false; 102 | 0 ( LIT) ( 67 top> empty ) 103 | flags ( SYMBOL) ( 67 top> #0x ) 104 | 3 U@@ + ( 68 top> #71x #0x ) 105 | C! ( 68 top> #83x #0x ) 106 | 3 U@@ ( 72 top> empty ) 107 | 4 U@@ + ( 72 top> #68x ) 108 | [ 3 ] DUP_U! ( 63 top> #68 ) 109 | 8190 ( LIT) ( 63 top> #68x ) 110 | > ( 64 top> #81x #68x ) 111 | [ 0017 ] BRANCHZ ( 64 top> #0x ) 112 | ( TYPE 2 LOOP END) ( 79 top> empty ) 113 | [ 0021 ] LABEL ( 120 top> empty ) 114 | 115 | \ count++; 116 | 1 ( LIT) ( 82 top> empty ) 117 | 2 U@@ + 2 U!! ( 86 top> #0x ) 118 | 119 | \ } 120 | [ 0012 ] LABEL ( 86 top> empty ) 121 | R> ( 87 top> empty ) 122 | 1 ( LIT) ( 87 top> #67x ) 123 | + ( 87 top> #0x #67x ) 124 | DUP_>R ( 42 top> #67 ) 125 | 8190 ( LIT) ( 42 top> #67x ) 126 | U> ( 43 top> #73x #67x ) 127 | [ 0018 ] BRANCHZ ( 43 top> #0x ) 128 | [ 0018 DROP_INDEX ] R>DROP ( 93 top> empty ) 129 | 130 | \ } 131 | [ 0022 ] LABEL ( 126 top> empty ) 132 | R> ( 98 top> empty ) 133 | 1 ( LIT) ( 98 top> #66x ) 134 | + ( 98 top> #0x #66x ) 135 | DUP_>R ( 10 top> #66 ) 136 | dup . 349 ( LIT) ( 10 top> #66x ) 137 | U> ( 11 top> #69x #66x ) 138 | [ 0019 ] BRANCHZ ( 11 top> #0x ) 139 | [ 0019 DROP_INDEX ] R>DROP ( 104 top> empty ) 140 | 141 | \ } 142 | [ 0024 ] LABEL ( 138 top> empty ) 143 | 144 | \ if (count != 1899) do_error(); 145 | 2 U@@ ( 108 top> empty ) 146 | 1899 ( LIT) ( 108 top> #65x ) 147 | - ( 109 top> #85x #65x ) 148 | [ 0020 ] BRANCHZ ( 109 top> #0x ) 149 | -64 FP+! ( Link) ( 111 top> empty ) 150 | do_error ( CALL) ( 111 top> empty ) 151 | 64 FP+! ( Unlink) ( 111 top> empty ) 152 | EXIT [ 0020 ] LABEL ( 113 top> empty ) 153 | \ } 154 | ; ( END ) 155 | 156 | .( 349 max iteration) cr 157 | -------------------------------------------------------------------------------- /RTX2000/TESTS/towers.b.4th: -------------------------------------------------------------------------------- 1 | \ /* towers.c */ 2 | \ GNU C for RTX 2000 3 | 4 | EMPTY 5 | : XY " DOS XY towers.b.4th" EVALUATE ; 6 | 7 | DECIMAL 8 | load gnutool.4th 9 | 10 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 11 | 12 | VARIABLE movesdone 4 CELL- ALLOT 13 | VARIABLE freelist 4 CELL- ALLOT 14 | VARIABLE cellspace 76 CELL- ALLOT 15 | VARIABLE stack 8 CELL- ALLOT 16 | 17 | : do_error 18 | ." Error in Towers." cr 19 | ; 20 | 21 | : Error 22 | ." Error in Towers." cr 23 | ; 24 | 25 | 64 FRAME_SIZE ! 26 | : Makenull 27 | 28 | 2* 29 | [ stack ] SYMBOL_+ 30 | [ 0 ] LIT_SWAP 31 | ! 32 | ; 33 | 34 | 64 FRAME_SIZE ! 35 | : Getelement 36 | 37 | freelist 38 | @ 39 | 0> 40 | [ 005 ] BRANCHZ 41 | 42 | freelist 43 | @ 44 | 45 | DUP 46 | 2* 47 | 2* 48 | [ cellspace ] SYMBOL_+ 49 | 2 50 | + 51 | @ 52 | freelist 53 | ! 54 | 2 U! 55 | [ 006 ] BRANCH 56 | 57 | [ 005 ] LABEL 58 | 59 | -64 FP+! 60 | Error 61 | 64 FP+! 62 | [ 006 ] LABEL 63 | 64 | 2 U@ 65 | ; 66 | 67 | 64 FRAME_SIZE ! 68 | : Push 69 | 70 | 0 71 | 2 U! 72 | 73 | DUP 74 | 2* 75 | [ stack ] SYMBOL_+ 76 | 3 U! 77 | 4 U! 78 | 5 U! 79 | 3 U@ 80 | @ 81 | 0> 82 | [ 008 ] BRANCHZ 83 | 84 | 4 U@ 85 | 2* 86 | [ stack ] SYMBOL_+ 87 | @ 88 | 2* 89 | 2* 90 | [ cellspace ] SYMBOL_+ 91 | @ 92 | 5 U@ 93 | <= 94 | [ 108 ] BRANCHZ 95 | 96 | 1 97 | 2 U! 98 | 99 | -64 FP+! 100 | Error 101 | 64 FP+! 102 | 103 | [ 008 ] LABEL 104 | [ 108 ] LABEL 105 | 106 | 2 U@ 107 | [ 0010 ] BRANCHNZ 108 | 109 | -64 FP+! 110 | Getelement 111 | 64 FP+! 112 | 113 | DUP 114 | 2* 115 | 2* 116 | [ cellspace ] SYMBOL_+ 117 | 4 U@ 118 | 2* 119 | [ stack ] SYMBOL_+ 120 | @_SWAP 121 | 2 122 | + 123 | ! 124 | 125 | 4 U@ 126 | 2* 127 | [ stack ] SYMBOL_+ 128 | OVER 129 | SWAP ! 130 | 131 | 2* 132 | 2* 133 | [ cellspace ] SYMBOL_+ 134 | [ 5 ] U@_SWAP 135 | ! 136 | EXIT [ 0010 ] LABEL 137 | ; 138 | 139 | 64 FRAME_SIZE ! 140 | : Init 141 | 142 | OVER 143 | 4 U! 3 U! 144 | 145 | -64 FP+! 146 | Makenull 147 | 64 FP+! 148 | 149 | 3 U@ 150 | [ 5 ] DUP_U! 151 | 0> 152 | [ 0016 ] BRANCHZ 153 | 154 | [ 0015 ] LABEL 155 | 5 U@ 156 | 4 U@ 157 | 158 | -64 FP+! 159 | Push 160 | 64 FP+! 161 | -1 162 | 5 U@ + 5 U! 163 | 5 U@ 164 | 0> 165 | [ 0015 ] BRANCHNZ 166 | 167 | EXIT [ 0016 ] LABEL 168 | ; 169 | 170 | 64 FRAME_SIZE ! 171 | : Pop 172 | 173 | DUP 174 | 2* 175 | [ stack ] SYMBOL_+ 176 | SWAP 177 | 2 U! 178 | @ 179 | 0> 180 | [ 0018 ] BRANCHZ 181 | 182 | 2 U@ 183 | 2* 184 | [ stack ] SYMBOL_+ 185 | @ 186 | 187 | 2* 188 | 2* 189 | [ cellspace ] SYMBOL_+ 190 | @ 191 | 2 U@ 192 | 2* 193 | [ stack ] SYMBOL_+ 194 | @ 195 | 196 | 2* 197 | 2* 198 | [ cellspace ] SYMBOL_+ 199 | 2 200 | + 201 | @ 202 | 2 U@ 203 | 2* 204 | [ stack ] SYMBOL_+ 205 | @ 206 | 2* 207 | 2* 208 | [ cellspace ] SYMBOL_+ 209 | freelist 210 | @_SWAP 211 | 2 212 | + 213 | ! 214 | 215 | 2 U@ 216 | 2* 217 | [ stack ] SYMBOL_+ 218 | @ 219 | freelist 220 | ! 221 | 222 | 2 U@ 223 | 2* 224 | [ stack ] SYMBOL_+ 225 | ! 226 | EXIT 227 | 228 | [ 0018 ] LABEL 229 | -64 FP+! 230 | Error 231 | 64 FP+! 232 | EXIT [ 0017 ] LABEL 233 | ; 234 | 235 | 64 FRAME_SIZE ! 236 | : Move 237 | 238 | 2 U! 239 | 240 | -64 FP+! 241 | Pop 242 | 64 FP+! 243 | 2 U@ 244 | 245 | -64 FP+! 246 | Push 247 | 64 FP+! 248 | 249 | 1 250 | movesdone 251 | +! 252 | ; 253 | 254 | 64 FRAME_SIZE ! 255 | : tower 256 | 257 | 2 U! 258 | 3 U! 259 | 4 U! 260 | 261 | 2 U@ 262 | 1 263 | - 264 | [ 0022 ] BRANCHNZ 265 | 266 | 4 U@ 267 | 3 U@ 268 | 269 | -64 FP+! 270 | Move 271 | 64 FP+! 272 | EXIT 273 | 274 | [ 0022 ] LABEL 275 | 276 | 6 277 | 3 U@ 278 | - 279 | 4 U@ 280 | - 281 | [ 8 ] DUP_U! 282 | 4 U@ 283 | 284 | SWAP 285 | 286 | 2 U@ 287 | 1 288 | - 289 | 290 | -64 FP+! 291 | recurse 64 FP+! 292 | 293 | 4 U@ 294 | 3 U@ 295 | 296 | -64 FP+! 297 | Move 298 | 64 FP+! 299 | 300 | 8 U@ 301 | 3 U@ 302 | 2 U@ 303 | 1 304 | - 305 | 306 | -64 FP+! 307 | recurse 64 FP+! 308 | 309 | EXIT [ 0023 ] LABEL 310 | ; 311 | 312 | 64 FRAME_SIZE ! 313 | : main 314 | #REGS 100 - REG-ADDR $FFC0 AND UBR! 315 | 316 | 0 317 | [ 0033 ADD_INDEX ] >R 318 | 319 | [ 0033 ] LABEL 320 | 321 | 1 322 | [ 0031 ADD_INDEX ] >R 323 | 324 | [ 0031 ] LABEL 325 | 326 | [ 0031 ] INDEX 327 | 2* 328 | 2* 329 | [ cellspace ] SYMBOL_+ 330 | [ 0031 ] INDEX 331 | 1 332 | - 333 | SWAP 334 | 2 335 | + 336 | ! 337 | R> 338 | 1 339 | + 340 | DUP_>R 341 | 18 342 | U> 343 | [ 0031 ] BRANCHZ 344 | [ 0031 DROP_INDEX ] R>DROP 345 | 346 | [ 0034 ] LABEL 347 | 348 | 18 349 | freelist 350 | ! 351 | 352 | 1 353 | 14 354 | 355 | -64 FP+! 356 | Init 357 | 64 FP+! 358 | 359 | 2 360 | 361 | -64 FP+! 362 | Makenull 363 | 64 FP+! 364 | 365 | 3 366 | 367 | -64 FP+! 368 | Makenull 369 | 64 FP+! 370 | 371 | 0 372 | movesdone 373 | ! 374 | 375 | 1 376 | 2 377 | 14 378 | 379 | -64 FP+! 380 | tower 381 | 64 FP+! 382 | 383 | movesdone 384 | @ 385 | 16383 386 | - 387 | [ 0027 ] BRANCHZ 388 | 389 | -64 FP+! 390 | do_error 391 | 64 FP+! 392 | 393 | [ 0027 ] LABEL 394 | R> 395 | 1 396 | + 397 | DUP_>R 398 | dup . 399 | 34 400 | U> 401 | [ 0033 ] BRANCHZ 402 | [ 0033 DROP_INDEX ] R>DROP 403 | EXIT [ 0035 ] LABEL 404 | ; 405 | 406 | .( max 34) cr 407 | -------------------------------------------------------------------------------- /RTX2000/TESTS/slowtigr.4th: -------------------------------------------------------------------------------- 1 | \ TIGRE for the RTX 2000 using AppForth 2 | \ (C) Copyright 1990, all rights reserved -- Philip Koopman 3 | DECIMAL 4 | 5 | \ Portability & trace words 6 | : CELLS 2* ; 7 | : t\ [COMPILE] \ ; immediate \ Make a nop for run-time trace 8 | 9 | \ Heap space management 10 | 5000 CONSTANT #HEAP-CELLS \ Size of heap for tree data 11 | VARIABLE HEAP-SPACE #HEAP-CELLS CELLS 2* 100 + ALLOT 12 | HEAP-SPACE #HEAP-CELLS CELLS 2* + CONSTANT HEAP-LIMIT 13 | 14 | : INIT-HEAP ( -- ) 15 | HERE 100 + UBR! HEAP-SPACE 2 U! ; 16 | 17 | : HEAP_ALLOCATE ( nbytes -- first.addr ) t\ ." ALLOCATE " DUP . 18 | 2 U@ + DUP 2 U! 19 | DUP HEAP-LIMIT > ABORT" Out of heap space!" ; 20 | 21 | \ Initial tree building helpers 22 | : ^ CELLS 2* HEAP-SPACE + >ta U2/ ; 23 | : ^' ?COMP ' >TA U2/ ; IMMEDIATE 24 | : h, SWAP 2 U@ ! 1 CELLS 2 U@ + 2 U! 25 | 2 U@ ! 1 CELLS 2 U@ + 2 U! ; 26 | 27 | \ Compilation helping words 28 | : ]cells " CELLS ] literal " evaluate ; IMMEDIATE 29 | : eval " [ HERE 8 + ] literal >R >R; " evaluate ; IMMEDIATE 30 | : 2args " R> @ 2* eval " evaluate ( Evaluate 1st argument ) 31 | " R@ @ 2* eval " evaluate ( Evaluate 2nd argument ) ; IMMEDIATE 32 | 33 | \ I x -> x ( perform a jump to x ) 34 | : {I} ( -- ) ( RS: ^myrhs -- ) t\ ." I " 35 | R> @ 2* >R; ; 36 | 37 | \ K c x -> I c ( perform a jump to c ) 38 | : {K} ( -- ) ( RS: ^parentrhs ^myrhs -- ) t\ ." K " 39 | R> @ R> DROP 2* >R; ; 40 | 41 | \ S f g x -> (f x) (g x) ( perform a jump to rhs address ) 42 | : {S} ( -- ) ( RS: ^grandrhs ^parentrhs ^myrhs -- ) t\ ." S " 43 | [ 4 ]cells HEAP_ALLOCATE ( -- addr ) 44 | R> @ OVER ! \ graph: (f -) (- -) 45 | R> @ OVER [ 2 ]cells + ! \ graph: (f -) (g -) 46 | R@ @ DDUP SWAP [ 1 ]cells + ! \ graph: (f x) (g -) 47 | OVER [ 3 ]cells + ! \ graph: (f x) (g x) 48 | U2/ DUP R@ [ -1 ]cells + ! \ graph: ((f x) (g x) 49 | [ 1 ]cells + R@ ! \ graph: ((f x) (g x)) 50 | R> [ -1 ]cells + >R; ; 51 | 52 | \ LIT ( perform a return from evaluation call 53 | : {LIT} ( -- n ) ( RS: raddr ^myrhs -- ) t\ ." LIT " 54 | R> @ ; 55 | 56 | \ + x y -> LIT sum ( perform a return ) 57 | : {+} ( -- ) ( RS: raddr ^parentrhs ^myrhs -- ) t\ ." + " 58 | 2args + DUP R@ ! ^' {LIT} R> [ -1 ]cells + ! ; 59 | 60 | : {-} ( -- ) ( RS: raddr ^parentrhs ^myrhs -- ) t\ ." - " 61 | 2args - DUP R@ ! ^' {LIT} R> [ -1 ]cells + ! ; 62 | 63 | : {<} ( -- ) ( RS: raddr ^parentrhs ^myrhs -- ) t\ ." < " 64 | 2args < DUP R@ ! ^' {LIT} R> [ -1 ]cells + ! ; 65 | 66 | \ IF c x y -> I x || I y 67 | : {IF} ( -- ) ( RS: ^grandrhc ^parentrhs ^myrhs -- ) t\ ." IF " 68 | R> @ 2* eval ( evaluate argument ) 69 | IF R> @ R@ ! ELSE R> DROP THEN 70 | ^' {I} R@ [ -1 ]cells + ! 71 | R> @ 2* >R; ; 72 | 73 | \ Fast constants for small integers 74 | : {1} 1 ; 75 | : {2} 2 ; 76 | : {3} 3 ; 77 | 78 | \ suc(n) = n+1 79 | \ ((S ((S (K +) ) (K 1) ) ) I ). 80 | : SUC ( n -- suc ) 81 | INIT-HEAP 82 | ( 0 ) 2 ^ 1 ^ h, 83 | ( 1 ) ^' {LIT} SWAP h, 84 | ( 2 ) 3 ^ ^' {I} h, 85 | ( 3 ) ^' {S} 4 ^ h, 86 | ( 4 ) 5 ^ 7 ^ h, 87 | ( 5 ) ^' {S} 6 ^ h, 88 | ( 6 ) ^' {K} ^' {+} h, 89 | ( 7 ) ^' {K} 8 ^ h, 90 | ( 8 ) ^' {LIT} 1 h, 91 | 2 CELLS HEAP_ALLOCATE DROP HEAP-SPACE >R; ; 92 | 93 | \ computes nth Fibonacci number 94 | \ ((S ((S ((S (K IF)) ((S <) (K 3)))) (K 1))) 95 | \ ((S ((S (K +)) ((S (K CYCLE)) ((S -) (K 1))))) 96 | \ ((S (K CYCLE)) ((S -) (K 2))))). 97 | \ Note: CYCLE refers to node 2, which is root of function subtree 98 | : FIB ( n -- suc ) 99 | INIT-HEAP 100 | ( 0 ) 2 ^ 1 ^ h, 101 | ( 1 ) ^' {LIT} SWAP h, 102 | ( 2 ) 3 ^ 15 ^ h, 103 | ( 3 ) ^' {S} 4 ^ h, 104 | ( 4 ) 5 ^ 13 ^ h, 105 | ( 5 ) ^' {S} 6 ^ h, 106 | ( 6 ) 7 ^ 9 ^ h, 107 | ( 7 ) ^' {S} 8 ^ h, 108 | ( 8 ) ^' {K} ^' {IF} h, 109 | ( 9 ) 10 ^ 11 ^ h, 110 | ( 10 ) ^' {S} ^' {<} h, 111 | ( 11 ) ^' {K} ^' {3} h, 112 | ( 12 ) ^' {LIT} 3 h, 113 | ( 13 ) ^' {K} ^' {1} h, 114 | ( 14 ) ^' {LIT} 1 h, 115 | ( 15 ) 16 ^ 27 ^ h, 116 | ( 16 ) ^' {S} 17 ^ h, 117 | ( 17 ) 18 ^ 20 ^ h, 118 | ( 18 ) ^' {S} 19 ^ h, 119 | ( 19 ) ^' {K} ^' {+} h, 120 | ( 20 ) 21 ^ 23 ^ h, 121 | ( 21 ) ^' {S} 22 ^ h, 122 | ( 22 ) ^' {K} 2 ^ h, \ cycle 123 | ( 23 ) 24 ^ 25 ^ h, 124 | ( 24 ) ^' {S} ^' {-} h, 125 | ( 25 ) ^' {K} ^' {1} h, 126 | ( 26 ) ^' {LIT} 1 h, 127 | ( 27 ) 28 ^ 30 ^ h, 128 | ( 28 ) ^' {S} 29 ^ h, 129 | ( 29 ) ^' {K} 2 ^ h, \ cycle 130 | ( 30 ) 31 ^ 32 ^ h, 131 | ( 31 ) ^' {S} ^' {-} h, 132 | ( 32 ) ^' {K} ^' {2} h, 133 | ( 33 ) ^' {LIT} 2 h, 134 | 2 CELLS HEAP_ALLOCATE DROP HEAP-SPACE >R; ; 135 | 136 | : FIB-TABLE ( -- ) 137 | CR ." n FIB(n)" 138 | CR ." --- ------" CR 139 | 13 1 DO 140 | I 3 U.R I FIB 7 U.R CR 141 | LOOP ; 142 | -------------------------------------------------------------------------------- /RTX2000/TESTS/bperm.s: -------------------------------------------------------------------------------- 1 | \ gcc_compiled.: 2 | 3 | 4 | ( RTX 2000 code generation) 5 | 6 | 64 FRAME_SIZE ! 7 | 8 | : swap ( FUNC ) ( 3 top> empty ) 9 | ( #4 dummy reload ) ( 4 top> empty ) 10 | ( #5 dummy reload ) ( 5 top> #64 ) 11 | OVER ( #64) ( 9 top> #65 #64 ) 12 | @ ( 9 top> #0x #65 #64 ) 13 | 2 U! ( 9 top> #66 #65 #64 ) 14 | DUP ( #65) ( 10 top> #65 #64d ) 15 | @ ( 10 top> #0x #65 #64d ) 16 | ROT ( 10 top> #0x #65 #64d ) 17 | ! ( 10 top> #64x #0x #65 ) 18 | [ 2 ] U@_SWAP ( 11 top> #65d ) 19 | ! ( 11 top> #65d #66x ) 20 | ; ( END ) 21 | 22 | ( 12 top> empty ) 23 | 24 | ( RTX 2000 code generation) 25 | 26 | 64 FRAME_SIZE ! 27 | 28 | : initialize ( FUNC ) ( 3 top> empty ) 29 | 1 ( LIT) ( 6 top> empty ) 30 | [ 006 ADD_INDEX ] >R ( 35 top> #64 ) 31 | ( TYPE 1 LOOP BEGIN) ( 7 top> empty ) 32 | [ 006 ] LABEL ( 23 top> empty ) 33 | [ 006 ] INDEX ( 15 top> empty ) 34 | 2* ( 15 top> #64x ) 35 | [ permarray ] SYMBOL_+ ( 16 top> #67d ) 36 | [ 006 ] INDEX ( 18 top> #68d ) 37 | 1 ( LIT) ( 18 top> #64x #68d ) 38 | - ( 18 top> #0x #64x #68d ) 39 | SWAP ! ( 18 top> #0x #68d ) 40 | R> ( 22 top> empty ) 41 | 1 ( LIT) ( 22 top> #64x ) 42 | + ( 22 top> #0x #64x ) 43 | DUP_>R ( #64 ) ( 10 top> #64 ) 44 | 7 ( LIT) ( 10 top> #64x ) 45 | U> ( 11 top> #65x #64x ) 46 | [ 006 ] BRANCHZ ( 11 top> #0x ) 47 | [ 006 DROP_INDEX ] R>DROP ( 28 top> empty ) 48 | EXIT [ 007 ] LABEL ( 36 top> empty ) 49 | ; ( END ) 50 | 51 | ( 30 top> empty ) 52 | 53 | ( RTX 2000 code generation) 54 | 55 | 64 FRAME_SIZE ! 56 | 57 | : permute ( FUNC ) ( 3 top> empty ) 58 | ( #4 dummy reload ) ( 4 top> empty ) 59 | 1 ( LIT) ( 10 top> #64 ) 60 | pctr ( SYMBOL) ( 10 top> #0x #64 ) 61 | +! ( 10 top> #0x #0x #64 ) 62 | [ 2 ] DUP_U! ( 13 top> #64 ) 63 | 1 ( LIT) ( 13 top> #64x ) 64 | - ( 14 top> #68x #64x ) 65 | [ 009 ] BRANCHZ ( 14 top> #0x ) 66 | 2 U@ ( 19 top> empty ) 67 | 1 ( LIT) ( 19 top> #64x ) 68 | - ( 19 top> #0x #64x ) 69 | ( #4 Calling Arg ) ( 21 top> #4 ) 70 | -64 FP+! ( Link) ( 21 top> empty ) 71 | permute ( CALL) ( 21 top> empty ) 72 | 64 FP+! ( Unlink) ( 21 top> empty ) 73 | 2 U@ ( 24 top> empty ) 74 | 1 ( LIT) ( 24 top> #64x ) 75 | - ( 24 top> #0x #64x ) 76 | [ 3 ] DUP_U! ( 79 top> #65 ) 77 | 0> ( 79 top> #65x ) 78 | [ 0014 ] BRANCHZ ( 81 top> #0x ) 79 | 2 U@ ( 82 top> empty ) 80 | 2* ( 82 top> #64x ) 81 | 4 U! ( 26 top> #71 ) 82 | ( LOOP_BEGIN) ( 26 top> empty ) 83 | [ 0013 ] LABEL ( 66 top> empty ) 84 | 3 U@ ( 35 top> empty ) 85 | 2* ( 35 top> #65x ) 86 | 4 U@ ( 38 top> #73 ) 87 | [ permarray ] SYMBOL_+ ( 38 top> #71x #73 ) 88 | SWAP ( 39 top> #4 #73d ) WARNING -- stack argument problem! 89 | 90 | [ permarray ] SYMBOL_+ ( 39 top> #73x #4 ) 91 | ( #5 Calling Arg ) ( 42 top> #5 #4 ) 92 | ( #4 Calling Arg ) ( 42 top> #4 ) 93 | -64 FP+! ( Link) ( 42 top> empty ) 94 | swap ( CALL) ( 42 top> empty ) 95 | 64 FP+! ( Unlink) ( 42 top> empty ) 96 | 2 U@ ( 46 top> empty ) 97 | 1 ( LIT) ( 46 top> #64x ) 98 | - ( 46 top> #0x #64x ) 99 | ( #4 Calling Arg ) ( 48 top> #4 ) 100 | -64 FP+! ( Link) ( 48 top> empty ) 101 | permute ( CALL) ( 48 top> empty ) 102 | 64 FP+! ( Unlink) ( 48 top> empty ) 103 | 3 U@ ( 53 top> empty ) 104 | 2* ( 53 top> #65x ) 105 | 4 U@ ( 56 top> #78 ) 106 | [ permarray ] SYMBOL_+ ( 56 top> #71x #78 ) 107 | SWAP ( 57 top> #4 #78d ) WARNING -- stack argument problem! 108 | 109 | [ permarray ] SYMBOL_+ ( 57 top> #78x #4 ) 110 | ( #5 Calling Arg ) ( 60 top> #5 #4 ) 111 | ( #4 Calling Arg ) ( 60 top> #4 ) 112 | -64 FP+! ( Link) ( 60 top> empty ) 113 | swap ( CALL) ( 60 top> empty ) 114 | 64 FP+! ( Unlink) ( 60 top> empty ) 115 | 3 U@ ( 65 top> empty ) 116 | 1 ( LIT) ( 65 top> #65x ) 117 | - ( 65 top> #0x #65x ) 118 | [ 3 ] DUP_U! ( 29 top> #65 ) 119 | 0> ( 29 top> #65x ) 120 | [ 0013 ] BRANCHNZ ( 30 top> #0x ) 121 | ( LOOP_END) ( 71 top> empty ) 122 | [ 0014 ] LABEL ( 80 top> empty ) 123 | EXIT [ 009 ] LABEL ( 73 top> empty ) 124 | ; ( END ) 125 | 126 | ( 74 top> empty ) 127 | 128 | ( RTX 2000 code generation) 129 | 130 | 64 FRAME_SIZE ! 131 | 132 | : main ( FUNC ) ( 3 top> empty ) 133 | 0 ( LIT) ( 6 top> empty ) 134 | pctr ( SYMBOL) ( 6 top> #0x ) 135 | ! ( 6 top> #0x #0x ) 136 | 1 ( LIT) ( 8 top> empty ) 137 | [ 0019 ADD_INDEX ] >R ( 41 top> #64 ) 138 | ( TYPE 1 LOOP BEGIN) ( 9 top> empty ) 139 | [ 0019 ] LABEL ( 29 top> empty ) 140 | -64 FP+! ( Link) ( 17 top> empty ) 141 | initialize ( CALL) ( 17 top> empty ) 142 | 64 FP+! ( Unlink) ( 17 top> empty ) 143 | 7 ( LIT) ( 20 top> empty ) 144 | ( #4 Calling Arg ) ( 22 top> #4 ) 145 | -64 FP+! ( Link) ( 22 top> empty ) 146 | permute ( CALL) ( 22 top> empty ) 147 | 64 FP+! ( Unlink) ( 22 top> empty ) 148 | R> ( 28 top> empty ) 149 | 1 ( LIT) ( 28 top> #64x ) 150 | + ( 28 top> #0x #64x ) 151 | DUP_>R ( #64 ) ( 12 top> #64 ) 152 | 5 ( LIT) ( 12 top> #64x ) 153 | U> ( 13 top> #65x #64x ) 154 | [ 0019 ] BRANCHZ ( 13 top> #0x ) 155 | [ 0019 DROP_INDEX ] R>DROP ( 34 top> empty ) 156 | EXIT [ 0020 ] LABEL ( 42 top> empty ) 157 | ; ( END ) 158 | 159 | ( 36 top> empty ) 160 | VARIABLE pctr 4 CELL- ALLOT 161 | 162 | VARIABLE permarray 24 CELL- ALLOT 163 | -------------------------------------------------------------------------------- /RTX2000/TESTS/tigre.4th: -------------------------------------------------------------------------------- 1 | \ TIGRE for the RTX 2000 using AppForth 2 | \ (C) Copyright 1990, all rights reserved -- Philip Koopman 3 | DECIMAL 4 | 5 | \ ---------- OPCODES FOR SPEED 6 | 7 | : U> " \\ SWAP- CU2/ NOT 0< " EVALUATE ; IMMEDIATE 8 | 9 | \ ---------- 10 | 11 | \ Portability & trace words 12 | : CELLS 2* ; 13 | 14 | : t\ [COMPILE] \ ; immediate \ Make a nop for run-time trace 15 | 16 | \ Heap space management 17 | 5000 CONSTANT #HEAP-CELLS \ Size of heap for tree data 18 | VARIABLE HEAP-SPACE #HEAP-CELLS CELLS 2* 100 + ALLOT 19 | HEAP-SPACE #HEAP-CELLS CELLS 2* + CONSTANT HEAP-LIMIT 20 | 21 | : INIT-HEAP ( -- ) 22 | HEAP-SPACE 4 G! HEAP-LIMIT 6 G! ; 23 | 24 | : HEAP_ALLOCATE ( nbytes -- first.addr ) 25 | 4 G@ + 4 DUP_G! 26 | DUP 6 G@ U> 27 | IF -1 ABORT" Out of heap space!" THEN ; 28 | 29 | \ Initial tree building helpers 30 | : ^ CELLS 2* HEAP-SPACE + >ta U2/ ; 31 | : ^' ?COMP ' >TA U2/ ; IMMEDIATE 32 | : h, SWAP 4 G@ ! 1 CELLS 4 G@ + 4 G! 33 | 4 G@ ! 1 CELLS 4 G@ + 4 G! ; 34 | 35 | \ Compilation helping words 36 | : ]cells " CELLS ] literal " evaluate ; IMMEDIATE 37 | : 2args " R> @ 2* execute " evaluate ( Evaluate 1st argument ) 38 | " R@ @ 2* execute " evaluate ( Evaluate 2nd argument ) ; IMMEDIATE 39 | : strict " [ {lit} ] LITERAL OVER R> 2 !- ! " EVALUATE ; IMMEDIATE 40 | 41 | \ I x -> x ( perform a jump to x ) 42 | : {I} ( -- ) ( RS: ^myrhs -- ) t\ ." I " 43 | R> @ 2* >R; ; 44 | 45 | \ K c x -> I c ( perform a jump to c ) 46 | : {K} ( -- ) ( RS: ^parentrhs ^myrhs -- ) t\ ." K " 47 | R> @ R>DROP 2* >R; ; 48 | 49 | \ S f g x -> (f x) (g x) ( perform a jump to rhs address ) 50 | : {S} ( -- ) ( RS: ^grandrhs ^parentrhs ^myrhs -- ) t\ ." S " 51 | R> @ \ f 52 | R> @ \ f g 53 | R@ @ DUP \ f g x x 54 | [ 4 ]cells HEAP_ALLOCATE \ f g x x a 55 | [ 3 ]cells + \ f g x x d 56 | 4 !- \ f g x b 57 | 2 !+ DUP>R \ f g c 58 | 4 !- \ f a 59 | 0 !+ U2/ \ ^a 60 | R> U2/ \ ^a ^c 61 | R> \ ^a ^c f 62 | 2 !- \ ^a e 63 | 0 !+ \ e 64 | >R; ; 65 | 66 | $DE20 CONSTANT {LIT} 67 | 68 | \ + x y -> LIT sum ( perform a return ) 69 | : {+} ( -- ) ( RS: raddr ^parentrhs ^myrhs -- ) t\ ." + " 70 | 2args + strict ; 71 | 72 | 73 | : {-} ( -- ) ( RS: raddr ^parentrhs ^myrhs -- ) t\ ." - " 74 | 2args - strict ; 75 | 76 | : {<} ( -- ) ( RS: raddr ^parentrhs ^myrhs -- ) t\ ." < " 77 | 2args < strict ; 78 | 79 | \ IF c x y -> I x || I y 80 | : {IF} ( -- ) ( RS: ^grandrhc ^parentrhs ^myrhs -- ) t\ ." IF " 81 | R> @ 2* EXECUTE 82 | IF 83 | R> @ 84 | ^' {I} 85 | OVER R> 86 | 2 !- 87 | ! 88 | 2* >R; 89 | THEN 90 | R>DROP 91 | R> 92 | 2 @- 93 | ^' {I} 94 | SWAP ! 95 | 2* >R; ; 96 | 97 | \ Fast constants for small integers 98 | : {1} 1 ; 99 | : {2} 2 ; 100 | : {3} 3 ; 101 | 102 | \ suc(n) = n+1 103 | \ ((S ((S (K +) ) (K 1) ) ) I ). 104 | : SUC ( n -- suc ) 105 | INIT-HEAP 106 | ( 0 ) 2 ^ 1 ^ h, 107 | ( 1 ) {lit} SWAP h, 108 | ( 2 ) 3 ^ ^' {I} h, 109 | ( 3 ) ^' {S} 4 ^ h, 110 | ( 4 ) 5 ^ 7 ^ h, 111 | ( 5 ) ^' {S} 6 ^ h, 112 | ( 6 ) ^' {K} ^' {+} h, 113 | ( 7 ) ^' {K} 8 ^ h, 114 | ( 8 ) {lit} 1 h, 115 | 2 CELLS HEAP_ALLOCATE DROP HEAP-SPACE >R; ; 116 | 117 | \ computes nth Fibonacci number 118 | \ ((S ((S ((S (K IF)) ((S <) (K 3)))) (K 1))) 119 | \ ((S ((S (K +)) ((S (K CYCLE)) ((S -) (K 1))))) 120 | \ ((S (K CYCLE)) ((S -) (K 2))))). 121 | \ Note: CYCLE refers to node 2, which is root of function subtree 122 | : ( n -- suc ) 123 | INIT-HEAP 124 | ( 0 ) 2 ^ 1 ^ h, 125 | ( 1 ) {lit} SWAP h, 126 | ( 2 ) 3 ^ 15 ^ h, 127 | ( 3 ) ^' {S} 4 ^ h, 128 | ( 4 ) 5 ^ 13 ^ h, 129 | ( 5 ) ^' {S} 6 ^ h, 130 | ( 6 ) 7 ^ 9 ^ h, 131 | ( 7 ) ^' {S} 8 ^ h, 132 | ( 8 ) ^' {K} ^' {IF} h, 133 | ( 9 ) 10 ^ 11 ^ h, 134 | ( 10 ) ^' {S} ^' {<} h, 135 | ( 11 ) ^' {K} ^' {3} h, 136 | ( 12 ) {lit} 3 h, 137 | ( 13 ) ^' {K} ^' {1} h, 138 | ( 14 ) {lit} 1 h, 139 | ( 15 ) 16 ^ 27 ^ h, 140 | ( 16 ) ^' {S} 17 ^ h, 141 | ( 17 ) 18 ^ 20 ^ h, 142 | ( 18 ) ^' {S} 19 ^ h, 143 | ( 19 ) ^' {K} ^' {+} h, 144 | ( 20 ) 21 ^ 23 ^ h, 145 | ( 21 ) ^' {S} 22 ^ h, 146 | ( 22 ) ^' {K} 2 ^ h, \ cycle 147 | ( 23 ) 24 ^ 25 ^ h, 148 | ( 24 ) ^' {S} ^' {-} h, 149 | ( 25 ) ^' {K} ^' {1} h, 150 | ( 26 ) {lit} 1 h, 151 | ( 27 ) 28 ^ 30 ^ h, 152 | ( 28 ) ^' {S} 29 ^ h, 153 | ( 29 ) ^' {K} 2 ^ h, \ cycle 154 | ( 30 ) 31 ^ 32 ^ h, 155 | ( 31 ) ^' {S} ^' {-} h, 156 | ( 32 ) ^' {K} ^' {2} h, 157 | ( 33 ) {lit} 2 h, 158 | 2 CELLS HEAP_ALLOCATE DROP 159 | ; 160 | 161 | : FIB HEAP-SPACE >R; ; 162 | 163 | : FIB-TABLE ( -- ) 164 | CR ." n FIB(n)" 165 | CR ." --- ------" CR 166 | 13 1 DO 167 | I 3 U.R I FIB 7 U.R CR 168 | LOOP ; 169 | 170 | : TEST 171 | \ TICKS 172 | 999 FOR 12 FIB DROP NEXT 173 | \ TICKS SWAP- ( ticks) 174 | \ 547 ( raps/fib / 10, appx) 175 | \ 182 ( ticks/sec * 10) 176 | \ ROT */ . ." K RAPS" 177 | ; 178 | 179 | \ : XX CR TIMER 10 FOR 999 FOR 12 NEXT NEXT CLICK ." ( / 10) OVERHEAD" CR 180 | \ TIMER 999 FOR 12 FIB DROP NEXT CLICK ." TOTAL RUN TIME" CR ; 181 | 182 | -------------------------------------------------------------------------------- /RTX2000/math.txt: -------------------------------------------------------------------------------- 1 | \ Notes for RTX 2000 floating point 2 | \ (C) COPYRIGHT 1990 PHIL KOOPMAN JR./Harris Semiconductor 3 | 4 | : T+ ( t1 t2 -- t3 ) 5 | ( -- Dm1 e1 Dm2 e2 ) ( RS: -- ) 6 | >R ROT >R ( -- Dm1 Dm2 ) ( RS: -- e2 e1 ) 7 | >R OVER R> SWAP OVER AND 2* ( -- Dm1 Dm2 flg ) ( RS: -- e2 e1 ) 8 | IF \ Both inputs are non-zero ( -- Dm1 Dm2 ) ( RS: -- e2 e1 ) 9 | R> ( -- Dm1 Dm2 e1 ) ( RS: -- e2 ) 10 | DUP R@ < ( -- Dm1 Dm2 e1 e1R ( -- Dm1 Dm2 e1 e2 ) ( RS: -- e2 Dm2 ) 14 | D>R DSWAP DR> SWAP ( -- Dm2 Dm1 e2 e1 ) ( RS: -- e2 Dm2 ) 15 | ELSE ( t1 has bigger exponent ) ( -- Dm1 Dm2 e1 ) ( RS: -- e2 ) 16 | R> OVER >R ( -- Dm1 Dm2 e1 e2 ) ( RS: -- e1 ) 17 | 5 PICK 5 PICK D>R ( -- Dm1 Dm2 e1 e2 ) ( RS: -- e1 Dm1 ) 18 | THEN ( -- Dm4 Dm5 e4 e5 ) ( RS: -- e4 Dm4 ) 19 | 2 PICK 5 PICK XOR 0< >R ( -- Dm4 Dm5 e4 e5 ) ( RS: -- e4 Dm4 sub?) 20 | - >R ( -- Dm4 Dm5 ) ( RS: -- e4 Dm4 sub? deltae ) 21 | ROT 2* LSR -ROT ( -- Dum4 Dm5 ) ( RS: -- e4 Dm4 sub? de ) 22 | 2* LSR ( -- Dum4 Dum5 ) ( RS: -- e4 Dm4 sub? de ) 23 | R> 32 MIN DLSRN ( -- Dum4 Dum6 ) ( RS: -- e4 Dm4 sub?) 24 | DDUP OR 0= 25 | IF \ too small to matter ( -- Dum4 Dum6 ) ( RS: -- e4 Dm4 sub?) 26 | DDROP DDROP ( -- ) ( RS: -- e4 Dm4 sub?) 27 | R> DROP ( -- ) ( RS: -- e4 Dm4 ) 28 | DR> R> EXIT ( -- Dm4 e4 ) ( RS: -- ) 29 | ELSE \ big enough to do it ( -- Dum4 Dum6 ) ( RS: -- e4 Dm4 sub?) 30 | R> ( -- Dum4 Dum6 sub? ) ( RS: -- e4 Dm4) 31 | IF \ signs different, subtract ( -- Dum4 Dum6 ) ( RS: -- e4 Dm4) 32 | DR> SWAP DROP 0< ( -- Dum4 Dum6 Dm4<0 ) ( RS: -- e4) 33 | IF DSWAP THEN ( -- Dum7 Dum8 ) ( RS: -- e4) 34 | DNEGATE 0 DADC 0= ( -- Dm9 nwsgn ) ( RS: -- e4) 35 | >R DABS R> ( -- Dum9 nwsgn ) ( RS: -- e4) 36 | ELSE \ signs the same, do an add ( -- Dum4 Dum6 ) ( RS: -- e4 Dm4) 37 | D+ DR> SWAP DROP 0< ( -- Dum9 nwsgn ) ( RS: -- e4) 38 | THEN ( -- Dum9 nwsgn ) ( RS: -- e4) 39 | R> SWAP >R ( -- Dum9 e4 ) ( RS: -- nwsgn ) 40 | UDNORMALIZE ( -- Dum3 e3 ) ( RS: -- nwsgn ) 41 | R> IF TNEGATE EXIT THEN ( -- Dm3 e3 ) ( RS: -- ) 42 | EXIT ( -- Dm3 e3 ) ( RS: -- ) 43 | THEN 44 | ELSE \ One input is zero ( -- Dm1 Dm2 ) ( RS: -- e2 e1 ) 45 | DUP 2* ( -- Dm1 Dm2 m2<>0 ) ( RS: -- e2 e1 ) 46 | IF \ Dm2 not zero ( -- Dm1 Dm2 ) ( RS: -- e2 e1 ) 47 | D>R DDROP DR> ( -- Dm2 ) ( RS: -- e2 e1 ) 48 | R> DROP R> ( -- Dm2 e2 ) ( RS: -- ) 49 | EXIT ( -- Dm2 e2 ) ( RS: -- ) 50 | ELSE \ Dm2 is zero ( -- Dm1 Dm2 ) ( RS: -- e2 e1 ) 51 | DDROP ( -- Dm1 ) ( RS: -- e2 e1 ) 52 | R> R> DROP ( -- Dm1 e1 ) ( RS: -- ) 53 | EXIT ( -- Dm1 e1 ) ( RS: -- ) 54 | THEN 55 | THEN 56 | ; 57 | 58 | 59 | : T* ( t1 t2 -- t3 ) 60 | ( Dm1 e1 Dm2 e2 -- ) 61 | \ add exponents 62 | >R ROT R> + ( -- Dm1 Dm2 e3 ) 63 | >R ( -- Dm1 Dm2 ) ( RS: -- e3 ) 64 | \ compute sign of result 65 | DUP >R SWAP >R OVER >R ROT >R XOR 0< R> R> R> R> 66 | DDUP XOR 0< -ROT ( -- sgn Dm1 Dm2 ) ( RS: -- e3 ) 67 | \ compute product, discarding sign bits 68 | D2* DSWAP D2* ( -- sgn Dum2 Dum1 ) ( RS: -- e3 ) 69 | DUM* >R >R DDROP R> R> ( -- sgn Dum3 ) ( RS: -- e3 ) 70 | \ either normalized, or shift right 1 bit 71 | DUP 0< 72 | IF 73 | \ shift right and apply sign 74 | ROT DRRC DROP ( -- Dum3 ) ( RS: -- e3 ) 75 | R> 1+ EXIT ( -- Dum3 e3 ) 76 | ELSE 77 | \ apply sign 78 | DLSL ROT DRRC DROP ( -- Dum3 ) ( RS: -- e3 ) 79 | R> EXIT ( -- Dum3 e3 ) 80 | THEN 81 | ; 82 | 83 | : T/ ( t1 t2 -- t3 ) 84 | ( -- Dm1 e1 Dm2 e2 ) ( RS: -- ) 85 | \ check for divide by zero 86 | OVER 2* 0= ( -- Dm1 e1 Dm2 e2 =0? ) ( RS: -- ) 87 | IF \ result of /0 is zero 88 | DROP DDROP DROP DDROP 0 0 0 ( -- Dm2 e2 ) ( RS: -- ) 89 | EXIT ( -- Dm2 e2 ) ( RS: -- ) 90 | ELSE ( -- Dm1 e1 Dm2 e2 ) ( RS: -- ) 91 | >R ROT R> ( -- Dm1 Dm2 e1 e2 ) ( RS: -- ) 92 | 2 PICK 5 PICK XOR >R ( -- Dm1 Dm2 e1 e2 ) ( RS: -- sgn ) 93 | - >R ( -- Dm1 Dm2 ) ( RS: -- sgn e3 ) 94 | LSL LSR ( -- Dm1 Dum2 ) ( RS: -- sgn e3 ) 95 | DSWAP LSL LSR ( -- Dum2 Dum1 ) ( RS: -- sgn e3 ) 96 | 0 0 DSWAP ( -- Dum2 0. Dum1 ) ( RS: -- sgn e3 ) 97 | QLSR DROT ( -- Qum1 Dum2 ) ( RS: -- sgn e3 ) 98 | DUM/MOD ( -- Durem Duquot ) ( RS: -- sgn e3 ) 99 | D>R DDROP DR> ( -- Duquot ) ( RS: -- sgn e3 ) 100 | R> ( -- uquot e3 ) ( RS: -- sgn ) 101 | 1- UDNORMALIZE ( -- Dum3 e3 ) ( RS: -- sgn ) 102 | R> ( -- Dum3 e3 sgn ) ( RS: -- ) 103 | ?TNEGATE EXIT ( -- Dm3 e3 ) ( RS: -- ) 104 | THEN ; 105 | --------------------------------------------------------------------------------