PG 1000 Circuit Board Solder Side

78C10 Solder Side

NEC78C10 Microcomputer

NEC 78C10 Microcomputer

At the heart of the Roland PG1000 is a NEC 78C10 single-chip microcomputer. It integrates on-chip functions that are normally provided by external components. These functions include a 16-bit ALU, a 256-byte RAM memory (used for program variables), an eight channel Analog to Digital converter (used to convert 56 slider voltages), a 16-bit timer/event counter, two 8-bit timers, a USART serial interface (used to send MIDI) and a total 44 input/output lines (used for the LCD screen, pushbuttons, LEDs, serial I/O, and other uses). What follows is the pin configuration for the 64-pin chip, and a table of its instruction set. More detailed info can be found in the NEC Single-Chip Microcontroller Data Book (1990, NEC Electronics Inc).
09 0A 0B 0C 0D 0E 0F 1A 1B 1C 1D 1E 1F 29 2A 2B 2C 2D 2E 2F 39
NOP LDAW wa LXI rp2,word ANIW wa,byte ANI A,byte MOV A, r1 MOV A, r1 MOV A, r1 MOV A, r1 MOV A, r1 MOV A, r1 MOV A, r1 MOV A, r1 EXA EXX INX rp DCX rp LXI rp2,word ORIW wa,byte XRI A,byte ORI A,byte MOV r1,A MOV r1,A MOV r1,A MOV r1,A MOV r1,A MOV r1,A MOV r1,A MOV r1,A INRW wa JB INX rp DCX rp LXI rp2,word GTIW wa,byte ADINC A,byte GTI A,byte LDAX rpa2 LDAX rpa2 LDAX rpa2 LDAX rpa2 LDAX rpa2 LDAX rpa2 LDAX rpa2 DCRW wa BLOCK INX rp DCX rp LXI rp2,word LTIW wa,byte SUINB A,byte LTI A,byte STAX rpa2
No operation A < ( V / offset ) SP < word (V / offset) < (V / offset) AND byte A < A AND byte A < EAH A < EAL A<B A<C A<D A<E A<H A<L Alternate V, A, EA register sets Alternate B, C, D, E, H, L register sets BC < BC +1 BC < BC - 1 BC < word (V / offset) < (V / offset) OR byte A < A EX-OR byte A < A OR byte EAH < A EAL < A B<A C<A D<A E<A H<A L<A (V / offset) < (V / offset) + 1, Skip if carry PC(hi) < B, PC(lo) < C DE < DE +1 DE < DE - 1 DE < word (V / offset) < (V / offset) - byte - 1, Skip if no borrow A < A + byte, Skip if no carry A < A - byte - 1, Skip if no borrow A < (BC) A < (DE) A < (HL) A < (DE)+ A < (HL)+ A < (DE)A < (HL)(V / offset) < (V / offset) - 1, Skip if borrow Block transfer (HL)+ to (DE)+ for C counts HL < HL + 1 HL < HL - 1 HL < word (V / offset) - byte, Skip if borrow A < A - byte, Skip if no borrow A - byte, Skip if borrow (BC) < A
3A 3B 3C 3D 3E 3F 48 0A 48 0B 48 0C 48 0A 48 0B 48 0C 48 2A 48 2B 48 2D 48 2E 48 2F 48 3A 48 3B 48 3D 48 3E 48 3F 48 40
STAX rpa2 STAX rpa2 STAX rpa2 STAX rpa2 STAX rpa2 STAX rpa2 CALL word INR r2 INR r2 INR r2 LXI rp2,word ONIW wa,byte ADI A,byte ONI A,byte SLRC r2 SLRC r2 SLRC r2 SLLC r2 SLLC r2 SLLC r2 SK f SK f SK f SK f SK f SK f SLR r2 SLR r2 SLR r2 SLL r2 SLL r2 SLL r2 JEA CALB CLC STC MUL r2 MUL r2 MUL r2 RLR r2 RLR r2 RLR r2 RLL r2 RLL r2 RLL r2 RLD RRD NEGA HLT DIV r2 DIV r2 DIV r2 SKIT irf

(DE) < A (HL) < A (DE)+ < A (HL)+ < A (DE)- < A (HL)- < A Subroutine call, PC < word A < A + 1, Skip if carry B < B + 1, Skip if carry C < C + 1, Skip if carry EA < word (V / offset) AND byte, Skip if no zero A < A + byte A AND byte, Skip if no zero A shift logical right, Skip if carry B shift logical right, Skip if carry C shift logical right, Skip if carry A shift logical left, Skip if carry B shift logical left, Skip if carry C shift logical left, Skip if carry Skip if CY = 1, Skip if HC = 1, Skip if Z = 1, Skip if CY = 1, Skip if HC = 1, Skip if Z = 1, A shift logical right B shift logical right C shift logical right A shift logical left B shift logical left C shift logical left PC < EA Subroutine call, PC < BC CY < 0 CY < 1 EA < EA x A, EA < EA x B, EA < EA x C, A rotate logical right B rotate logical right C rotate logical right A rotate logical left B rotate logical left C rotate logical left A, (HL) rotate left digit A, (HL) rotate right digit Negate A, add 1 (two's complement) Set Halt mode EA < EA div A, A < remainder EA < EA div B, B < remainder EA < EA div C, C < remainder Skip if NMI = 1,
48 4A 48 4B 48 4C 48 6A 48 6B 48 6C 48 8B 48 8C 48 8D 48 8E 48 8F 48 9B 48 9C 48 9D 48 9E 48 9F
SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf SKNIT irf LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 LDEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3 STEAX rpa3
Skip if FT0 = 1, Skip if FT1 = 1, Skip if F1 = 1, Skip if F2 = 1, Skip if FE0 = 1, Skip if FE1 = 1, Skip if FEIN = 1, Skip if FAD = 1, Skip if FSR = 1, Skip if FST = 1, Skip if ER = 1, Skip if OV = 1, Skip if AN4 = 1, Skip if AN5 = 1, Skip if AN6 = 1, Skip if AN7 = 1, Skip if SB = 1, Skip if NMI = 0, Skip if FT0 = 0, Skip if FT1 = 0, Skip if F1 = 0, Skip if F2 = 0, Skip if FE0 = 0, Skip if FE1 = 0, Skip if FEIN = 0, Skip if FAD = 0, Skip if FSR = 0, Skip if FST = 0, Skip if ER = 0, Skip if OV = 0, Skip if AN4 = 0, Skip if AN5 = 0, Skip if AN6 = 0, Skip if AN7 = 0, Skip if SB = 0, EAL<(DE), EAH<(DE+1) EAL<(HL), EAH<(HL+1) EAL<(DE++), EAH<(DE++ +1) EAL<(HL++), EAH<(HL++ +1) EAL<(DE+byte), EAH<(DE+byte+1) EAL<(HL+A), EAH<(HL+A+1) EAL<(HL+B), EAH<(HL+B+1) EAL<(HL+EA), EAH<(HL+EA+1) EAL<(HL+byte), EAH<(HL+byte+1) (DE)<EAL, (DE+1)<EAH (HL)<EAL, (HL+1)<EAH (DE++)<EAL, (DE++ +1)<EAH (HL++)<EAL, (HL++ +1)<EAH (DE+byte)<EAL, (DE+byte+1)<EAH (HL+A)<EAL, (HL+A+1)<EAH (HL+B)<EAL, (HL+B+1)<EAH (HL+EA)<EAL, (HL+EA+1)<EAH (HL+byte)<EAL, (HL+byte+1)<EAH

the word may only be used during compilation of a colon definition. the word is a defining word. the word is IMMEDIATE and will execute during compilation, unless special action is taken. a user value.
================================================================ Stack notes ( compile \ run \ child ;Return ;Float ; <input stream> ) ( before -- after ;R before -- after ;F before -- after ; <string> ) ================================================================ Glossary !( w a -- )"store" Store a 16-bit number at aligned address. !CSP( -- )"set c s p" Save the values of the current stack pointers. !IO( -- )"store i o" Initialize the serial I/O device. #( d -- d )"number sign" Convert one digit of a number using the current base. Must be used within <# and #>. #>( d -- b u )"number sign greater" Terminate a numeric conversion. #S( ud -- )"number sign s" Convert all digits of a number using the current base. #TIB( -- a )"number t i b" The system double variable which holds the size and aligned address of the terminal input buffer. $"( -- ; <string> \ -- $ )I,C"string quote" Used only within a definition to compile an inline packed string terminated by the " double quote character. At run-time the address of the packed string is pushed on the data stack. $"|( -- $ )C"string quote primitive" Return the address of a compiled inline packed string. The run-time primitive compiled by ". $,"( -- ; <string> )"string comma quote" Compile an inline packed character string into the code area, terminated by the " double quote character. $,n( $ -- )"string comma n" Create a name for a definition using string. code is compiled. The name is not linked into the dictionary. $COMPILE( $ -- ) Convert a string to a word address.
Set the code pointer to the next free cell in the code area, no
Execute the word in interpreting mode or compile it if in compiling mode.
$INTERPRET( $ -- )"string interpret" At the interactive level, if a word is defined perform its action. If not, try to convert it to a number, if
that fails, issue an error message. '( -- ca ; <string> )"tick" Return the code address of the word following. '?KEY( -- a )U"tick question key" The system input device status vector. 'BOOT( -- a ) Return the address of a system boot-up routine. 'ECHO( -- a )U"tick echo" The system echo device vector. 'EMIT( -- a )U"tick emit" The system output device vector. 'EVAL( -- a )"tick eval" The system interpret/compile vector. 'EXPECT( -- a )U"tick expect" The system line input vector. 'NUMBER( -- a )"tick number" The system number conversion vector. 'PROMPT( -- a )U"tick prompt" The system prompt vector. 'TAP( -- a )U"tick tap" The input case function vector. (( -- ; <string> )I"paren" Begin a comment. The comment is terminated by the )character. May be used inside or outside a definition. *( n n -- n )"star" Multiply two signed numbers. Return a 16-bit signed number. */( n1 n2 n3 -- q )"star slash" Multiply n1 by n2 producing the 32-bit intermediate product d. Divide d by n3 producing a 16-bit quotient. */MOD( n1 n2 n3 -- r q )"star slash mod" Multiply n1 by n2 producing the 32-bit intermediate product d. Divide d by n3 producing a 16-bit remainder and a 16-bit quotient. +( w w -- w )"plus" Addition. +!( n a -- )"plus store" Increment the 16-bit value at address by n. ,( w -- )"comma" Compile a 16-bit value into the code area. -( w w -- w )"minus" Subtract the top from the second element on the data stack. -TRAILING( b u -- b u )"dash trailing" Adjust the count to eliminate any trailing white-space in the string.( n -- )"dot" Display the single value, use the current base. If BASE is DECIMAL , display as a signed number."( -- ; <string> )I,C"dot quote" Used only within a definition to compile an inline packed string terminated by the " double quote character. At run-time the string is displayed on the current output device.

Tables:

The sliders are not converted in the same order in which they are physically laid out in the box. A table of 64 has been created in ROM at address 00200H to translate the slider numbers to physical position numbers:

(numbers in decimal)

The following chart shows the physical layout of the sliders on the Roland PG1000 box:
(External) (External) 12 04|48|55
11|09 01|30|35 36|45 35|49 57|06 07|12 13|18 19

Utility Words

UTILITY WORDS
: CASE ( n --- , Use 'n' as a pointer to following list of words, execute the pointed word, then leave the current word ) R> ( Remove return stack pointer to next token, put on data stack ) SWAP ( pointer 'n' to the top ) 2* + ( pointer + 2n ) @EXECUTE ( execute token at pointer + 2n, leave current word )
The CASE word is used as follows:
: XXX ( n --- ) ANYWORDS CASE PG0 PG1 PG2 ;
If n=0, PG0 is executed after CASE. If n=1, PG1 is executed after CASE. If n=2, PG2 is executed after CASE. Only the one PG is executed after which XXX terminates. Warning!! If n is greater than the number of words between CASE and ';' minus one, the program will bomb.
********************************************

: INCR OVER : DECR OVER

( n, nmax 1+ <
--- n+1, Increment n but set to zero if greater than nmax ) IF DROP 0 ELSE 1+ THEN ; Decrement n but set to nmax if less than zero ) SWAP DROP ELSE DROP 1THEN ;
( n, nmax --- n-1, 10< IF
********************************************** CODE

AFE 52 FC ENDCODE

( POP C < JMP B < JMP
n --- ) BC C-1, Skip if borrow back 1 B-1, Skip if borrow back 3
*********************************************
A1 0B 48,4A FD 4D,D8 ENDCODE
( n -- , Transmit Midi, Wait for last transmit, then send n ) POP BC A<C SKIT FST, Skip if interrupt JMP TO SKIT MOV TXB,A **********************************************
( -- word --, Decompiles word ) ' CR 1+ BEGIN ( Code address of word plus one ) DUP DUP SPACE. 7C EMIT @ DUP IF >NAME THEN ?DUP IF.ID ELSE DUP @ U. THEN 2+ NUF? UNTIL DROP
DUMMY ; ( -- , Do nothing word for filling in CASE definitions )

REMOTE FILE LOADING:

Build a TEXT-ONLY file in Word (or other) of the words you want to load. When using White Knight, go under Custom / Otions / Text Transfer and set the "Wait after each line sent for the ^K character (the Pacing character used in Eforth). Type in the Eforth word FILE. Character echoes are now turned off. Go under File to Send a Text File. Make sure there is the HAND command at the end of your text file to return control back to the console. Type WORDS to see if your text was loaded.

LCD Screen

The HD44780 LCD Controller
Display is 2 Lines of 16 Characters. Position addresses are 0 to F for the top line, and 40 to 4F for the bottom line. Cursor automatically increments to the next position after a character write, except for the jump between the end of the top line and beginning of the bottom line. Characters can be taken from internal ROM which holds all the ASCII characters plus other special characters (see the chart) or from an internal RAM which must be loaded at power on by the user. This project uses only the ROM. There are two Write modes controlled by the RS input line: RS = 0, LCD setup commands such as Cursor on/off/ position, Clear, etc. RS = 1, write character to cursor position.

Core LCD Words:

CODE LLI 64 0A EF ENDCODE CODE LLC 64 1A 10 ENDCODE CODE LCD A1 0B AENDCODE : LI LLI ( --, Sets RS=0 for LCD setup commands ) Pc < Pc AND EF ( --- , Sets RS=1 for character displaying ) Pc < Pc OR 10 (n--- , Loads POP BC A < C BC < A000 (BC) < A LCD command 'n')
(n --, Load LCD setup command 'n'. Exit with RS=1 for char writes.) LCD LLC 1FF DELAY ;
Example LCD Display Commands:
1 LI F LI C0 LI 41 LCD Clear LCD Screen. Turn on the Cursor C LI 80 LI Turn off the Cursor Position cursor at start
Position cursor at start of 2nd line. Display ASCII 'A' at current cursor position, increment cursor.

Power Up Reset Routine

: LCDINIT D7A 47E 1CC 1CC DELAY DELAY DELAY DELAY DELAY DELAY DELAY DELAY DELAY DELAY ( Initialize LCD display ) 38 LI ( Function Set-8 bit input, 2 lines, 5x7 char ) 38 LI 38 LI 38 LI 08 LI ( Display off, cursor off, blink off ) 01 LI ( Clear display, home the cursor ) 02 LI ( Cursor at home - top left position ) 06 LI ( Entry Mode Set - cursor auto increment,shift off ) 0F LI ( Display on, cursor on, blink on ) ;

Display Routines

: #DISP ( n,p --- , Display 'n' as a 3-digit number in current base at LCD position 'p' and reset cursor to start of number ) ( Move cursor to 'p', and save ) ( Convert 'n' to 3 ascii digits. Leave address and 3 on stack ) ( Locations of the 3 digits in TIB) ( Display 3 digits and reset cursor )

Main Program

HEX : BDOWN 20 LED! 0 eFLD C@ 7 AND CASE U/D0 U/D1 U/D2 U/D3 U/D3 U/D4 U/D5 U/D6 U/D7 ; : DUMMY ; : MCASE CASE DUMMY DUMMY DUMMY BLOAD BMIDI BUP BDOWN BLEFT BRIGHT ; : MAIN CR 1 LI DECIMAL 1 LI eUPDAT eDISP BEGIN 0 LED! S@ MCASE FFFF DELAY NUF? UNTIL." END MAIN " CR ; HAND

Final Assembly Code

Page 60,100 ;=============================================================== ; ; eForth 1.0 by Bill Muench and C. H. Ting, 1990 ; ; This is an implementation for the NEC 78C10 microcomputer by ; John Talbert, 1994, Oberlin Conservatory. ; ; Register Use: Interpreter Pointer = DE ; Data Stack Pointer = SP ; Return Stack Pointer = HL ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; Free to use: BC, EA, VA, Alternate Registers. 'doList' is accessed as a subroutine through a CALT instruction (Call to Jump Table). This shows up as a 'DB 80H' line in the $COLON and $USER Macros. When executed the processor jumps to an address vector located at 80H. The vectored 'doList' code is then located at 0F0H. The word 'call,' was changed to load 80H into the code area for a doLST assembly.
A 9600 Baud serial I/O is provided. PortB/bit0 is used for serial output and PortC/bit3 (INT2) is used for the serial input. The serial input is interrupt driven with a vectored interrupt routine located at 0A0H. The code words ?RX, TX!, and !IO make up the rest of the serial I/O code. Three USER variables have been set up for use by these serial I/O routines: SERIN, which holds the received character and a flag; HAFBIT, which adjusts the software timing of the receiver to read in the middle of each bit frame (set it for 1/2 the BITIME minus 5); and BITIME, which adjusts the software for a specific baud rate (17H for 9600 baud assuming a 12Mhz processor clock). The 78C10 is an 8-bit micro, therefore cell aligning to even addresses is unnecessary. The $ALIGN Macro was taken out along with the NOP's used for cell alignment in the other Macros. All occurrences of the word ALGND were erased also. The word SEE no longer works because it relies on cell alignment. All of the system FORTH code is to be stored in ROM (up to 32K) starting at address 0000H. Then there is 2K of RAM starting at address COOOH. This memory setup required the following changes: 1) Return and Data stacks and TIB moved to RAM. (See the Memory allocation EQU assignments.) 2) The USER variables were moved to the micro's internal RAM at FF00H to FFFFH. 3) PAD word was changed to move the temporary buffer area to RAM space. 4) The vocabulary pointers found in the word FORTH were moved to RAM space by creating two new USER variables, FHEAD and FLINK and changing DOVOC to read: DW FHEAD,CNTXT,STORE,EXIT. 5) NTOP and CTOP were moved to RAM space to allow dictionary expansion into RAM space. Several words were added to the ROM Dictionary. The simple operators 1+,1-,2+,2-,2*,2/, were defined in machine code. The words C, ,

; CCOMPILE, CODE, and ENDCODE were created to enable the creation ; of code definition. ; ; The NEC78C10 offers the following advantages: ; 1) Ten 16-bit internal registers and a 16-bit ALU. ; Many 16-bit instructions for those FORTH stack operations. ; 2) Three 8-bit I/O ports. ; 3) Eight 8-bit Analog to Digital Converters. ; 4) Internal counters and programmable clock generators. ; 5) Internal hardware serial I/O. (can be used for MIDI I/O). ; 6) 64K address space including 256 bytes of internal RAM. ; ; ;================================================================== ;; Version control VER EQU 01H ;major release version EXT EQU 01H ;minor extension ;; Constants COMPO IMEDD MASKK CELLL BASEE VOCSS BKSPP LF CRR ERR TIC CALLL EQU EQU EQU EQU EQU EQU EQU EQU EQU EQU EQU EQU 040H 080H 07F1FH 80H ;lexicon compile only bit ;lexicon immediate bit ;lexicon bit mask ;size of a cell ;default radix ;depth of vocabulary stack ;backspace ;line feed ;carriage return ;error escape ;tick ;CALT opcodes
;; Memory allocation COLDD RPP TIBB SPP UPP NAMEE CODEE CTOP NTOP PADD SLDTR ADCINT EQU EQU EQU EQU EQU EQU EQU EQU EQU EQU EQU EQU
0//code>--//--<name//up>--<sp//tib>--rp//em 00100H 0C2F0H 0C200H 0C1F0H 0FF00H 03FFDH 00300H 0C390H 0C7FFH 0C300H 00200H 00280H ;cold start ;start of return stack (RP0) ;terminal input buffer (TIB) ;start of data stack (SP0) ;start of user area (UP0) ;name dictionary ;code dictionary ;RAM code dict. expansion ;RAM name dict. expansion ;PAD area ;Table for Slider# translate ;ADC Interrupt routine
;; Initialize assembly variables _LINK _NAME _CODE _USER = = = = 0 NAMEE CODEE 4*CELLL ;force a null link ;initialize name pointer ;initialize code pointer ;first user variable offset
;; Define assembly macros

; $CODE LABEL:

Compile a code definition header. MACRO _CODE _LEN _NAME _NAME DW _LINK DB _CODE ENDM LEX,NAME,LABEL = $ = (LEX AND 01FH)/CELLL = _NAME-((_LEN+3)*CELLL) _CODE,_LINK = $ LEX,NAME ;;assembly label ;;save code pointer ;;string cell count, round down ;;new header on cell boundary ;;set name pointer ;;token pointer and link ;;link points to a name string ;;name string ;;restore code pointer

ORG ; $COLON

Compile a colon definition header. MACRO $CODE DB 80H ENDM LEX,NAME,LABEL LEX,NAME,LABEL ;;include CALT doLIST

; $USER

Compile a user variable header. MACRO $CODE DB 80H DW _USER ENDM LEX,NAME,LABEL LEX,NAME,LABEL DOUSE,_USER = _USER+CELLL ;;include CALT doLIST ;;followed by doUSER and offset ;;update user area offset

WITHIN

( u ul uh -- t ) Return true if u is within the range of ul and uh. $COLON DW DW 6,'WITHIN',WITHI OVER,SUBB,TOR SUBB,RFROM,ULESS,EXIT ;ul <= u < uh

;; Quick Operators ;

( n -- n+1 ) $CODE 2,'1+',ONEP DB 0A1H DB 12H DB 0B1H $NEXT ( n -- n-1 ) $CODE 2,'1-',ONEM DB 0A1H DB 013H DB 0B1H $NEXT ( n -- n+2 ) $CODE 2,'2+',TWOP
;POP BC ;BC<BC+1 ;PUSH BC
;POP BC ;BC<BC-1 ;PUSH BC
DB 0A1H DB 12H,12H DB 0B1H $NEXT ; 2( n -- n-2 ) $CODE 2,'2-',TWOM DB 0A1H DB 13H,13H DB 0B1H $NEXT ( n -- n*2 ) $CODE 2,'2*',TWOSL DB 0A4H DB 48H,0A4H DB 0B4H $NEXT ( n -- n/2 ) $CODE 2,'2/',TWOSR DB 0A4H DB 48H,0A0H DB 0B4H $NEXT
;POP BC ;BC<BC+2 ;PUSH BC
;POP BC ;BC<BC-2 ;PUSH BC
;POP EA ;EA Logical Shift Left ;PUSH EA
;POP EA ;EA Logical Shift Right ;PUSH EA
;; Divide ; ; UM/MOD ( udl udh u -- ur uq ) Unsigned divide of a double by a single. Return mod and quotient. $COLON DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW 6,'UM/MOD',UMMOD DDUP,ULESS QBRAN,UMM4 NEGAT,DOLIT,15,TOR TOR,DUPP,UPLUS TOR,TOR,DUPP,UPLUS RFROM,PLUS,DUPP RFROM,RAT,SWAP,TOR UPLUS,RFROM,ORR QBRAN,UMM2 TOR,DROP,ONEP,RFROM BRAN,UMM3 DROP RFROM DONXT,UMM1 DROP,SWAP,EXIT DROP,DDROP DOLIT,-1,DUPP,EXIT
UMM2: UMM3: UMM4: ; M/MOD ; quotient.

;overflow, return max

( d n -- r q ) Signed floored divide of double by single. Return mod and $COLON DW DW DW 5,'M/MOD',MSMOD DUPP,ZLESS,DUPP,TOR QBRAN,MMOD1 NEGAT,TOR,DNEGA,RFROM
MMOD1: MMOD2: MMOD3: ; ; /MOD

DW DW DW DW DW DW DW

TOR,DUPP,ZLESS QBRAN,MMOD2 RAT,PLUS RFROM,UMMOD,RFROM QBRAN,MMOD3 SWAP,NEGAT,SWAP EXIT
( n n -- r q ) Signed divide. Return mod and quotient. $COLON DW 4,'/MOD',SLMOD OVER,ZLESS,SWAP,MSMOD,EXIT
( n n -- r ) Signed divide. Return mod only. $COLON DW 3,'MOD',MODD SLMOD,DROP,EXIT
( n n -- q ) Signed divide. Return quotient only. $COLON DW 1,'/',SLASH SLMOD,SWAP,DROP,EXIT
;; Multiply ; ; UM* ( u u -- ud ) Unsigned multiply. Return double product. $COLON DW DW DW DW DW DW DW 3,'UM*',UMSTA DOLIT,0,SWAP,DOLIT,15,TOR DUPP,UPLUS,TOR,TOR DUPP,UPLUS,RFROM,PLUS,RFROM QBRAN,UMST2 TOR,OVER,UPLUS,RFROM,PLUS DONXT,UMST1 ROT,DROP,EXIT

UMST1:

UMST2: ; ; *
( n n -- n ) Signed multiply. Return single product. $COLON DW 1,'*',STAR UMSTA,DROP,EXIT
( n n -- d ) Signed multiply. Return double product. $COLON DW DW DW DW DW DW 2,'M*',MSTAR DDUP,XORR,ZLESS,TOR ABSS,SWAP,ABSS,UMSTA RFROM QBRAN,MSTA1 DNEGA EXIT

PNAM1:

;; FORTH compiler ; ; $COMPILE ( a -- ) Compile next word to code dictionary as a token or literal. $COLON DW DW DW DW DW DW DW DW DW DW 8,'$COMPILE',SCOMP NAMEQ,QDUP QBRAN,SCOM2 AT,DOLIT,IMEDD,ANDD QBRAN,SCOM1 EXECU,EXIT COMMA,EXIT TNUMB,ATEXE QBRAN,SCOM3 LITER,EXIT THROW ;?defined ;?immediate ;its immediate, execute ;its not immediate, compile ;try to convert to number ;compile number as integer ;error
SCOM1: SCOM2: SCOM3: ; ; CCOMPILE
( a -- ) Compile next byte to code dictionary as machine code. $COLON DW DW DW DW DW DW DW DW DW DW 8,'CCOMPILE',CCOMP NAMEQ,QDUP QBRAN,CCOM2 AT,DOLIT,IMEDD,ANDD QBRAN,CCOM1 EXECU,EXIT DROP,EXIT TNUMB,ATEXE QBRAN,CCOM3 CCOMMA,EXIT THROW ;?defined ;?immediate ;its immediate, execute ;its not immediate,drop ;try to convert to number ;compile as code byte ;error
CCOM1: CCOM2: CCOM3: ; ; OVERT
( -- ) Link a new word into the current vocabulary. $COLON DW 5,'OVERT',OVERT LAST,AT,CRRNT,AT,STORE,EXIT
( -- ) Terminate a colon definition.

$COLON DW ; ; ]

IMEDD+COMPO+1,';',SEMIS COMPI,EXIT,LBRAC,OVERT,EXIT
( -- ) Start compiling the words in the input stream. $COLON DW 1,']',RBRAC DOLIT,SCOMP,TEVAL,STORE,EXIT
( ca -- ) Assemble a call instruction to doLST. $COLON DW 5,'call,',CALLC DOLIT,CALLL,CCOMMA,EXIT ;Direct Threaded Code
( -- ; <string> ) Start a new colon definition using next word as its name. $COLON DW DW 1,':',COLON TOKEN,SNAME CALLC,RBRAC,EXIT

IMMEDIATE

( -- ) Make the last compiled word an immediate word. $COLON DW DW 9,'IMMEDIATE',IMMED DOLIT,IMEDD,LAST,AT,AT,ORR LAST,AT,STORE,EXIT
;; Defining words ; ; USER ( u -- ; <string> ) Compile a new user variable. $COLON DW DW ; ; CREATE 4,'USER',USER TOKEN,SNAME,OVERT,CALLC COMPI,DOUSE,COMMA,EXIT
( -- ; <string> ) Compile a new array entry without allocating code space. $COLON DW DW 6,'CREATE',CREAT TOKEN,SNAME,OVERT,CALLC COMPI,DOVAR,EXIT

VARIABLE

( -- ; <string> ) Compile a new variable initialized to 0. $COLON DW 8,'VARIABLE',VARIA CREAT,DOLIT,0,COMMA,EXIT

( -- ) Start a new code definition using next word as its name. $COLON DW DW 4,'CODE',CODE TOKEN,SNAME DOLIT,CCOMP,TEVAL,STORE,EXIT

ENDCODE

( -- ) Terminate a code definition $COLON DW DW DW IMEDD+COMPO+7,'ENDCODE',ENDCD DOLIT,48H,CCOMMA,DOLIT,84H,CCOMMA DOLIT,48H,CCOMMA,DOLIT,28H,CCOMMA LBRAC,OVERT,EXIT ;$NEXT
;; Tools ; ; _TYPE ( b u -- ) Display a string. Filter non-printing characters. $COLON DW DW DW DW DW DW 5,'_TYPE',UTYPE TOR BRAN,UTYP2 DUPP,CAT,TCHAR,EMIT ONEP DONXT,UTYP1 DROP,EXIT ;start count down loop ;skip first pass ;display only printable ;increment address ;loop till done

UTYP1: UTYP2: ; ; dm+

( a u -- a ) Dump u bytes from , leaving a+u on the stack. $COLON DW DW DW DW DW DW DW 3,'dm+',DMP OVER,DOLIT,4,UDOTR SPACE,TOR BRAN,PDUM2 DUPP,CAT,DOLIT,3,UDOTR ONEP DONXT,PDUM1 EXIT ;display address ;start count down loop ;skip first pass ;display numeric data ;increment address ;loop till done

PDUM1: PDUM2: ; ; DUMP

( a u -- ) Dump u bytes from a, in a formatted manner. $COLON DW DW DW DW DW DW DW DW DW DW DW DW DW 4,'DUMP',DUMP BASE,AT,TOR,HEX DOLIT,16,SLASH TOR CR,DOLIT,16,DDUP,DMP ROT,ROT SPACE,SPACE,UTYPE NUFQ,INVER QBRAN,DUMP2 DONXT,DUMP1 BRAN,DUMP3 RFROM,DROP DROP,RFROM,BASE,STORE EXIT ;save radix, set hex ;change count to lines ;start count down loop ;display numeric ;display printable characters ;user control ;loop till done ;cleanup loop stack, early exit ;restore radix

DUMP1:

DUMP2: DUMP3: ; ;.S
(. --. ) Display the contents of the data stack. $COLON DW DW DW 2,'.S',DOTS CR,DEPTH TOR BRAN,DOTS2 ;stack depth ;start count down loop ;skip first pass

DOTS1: DOTS2:

DW DW D$ DW
RAT,PICK,DOT DONXT,DOTS1 DOTQP,' <sp' EXIT
;index stack, display contents ;loop till done
( -- ) Save stack pointer in CSP for error checking. $COLON DW 4,'!CSP',STCSP SPAT,CSP,STORE,EXIT ;save pointer
( -- ) Abort if stack pointer differs from that saved in CSP. $COLON DW D$ DW 4,'?CSP',QCSP SPAT,CSP,AT,XORR ABORQ,'stacks' EXIT ;compare pointers ;abort if different

>NAME

( ca -- na | F ) Convert code address to a name address. $COLON DW DW DW DW DW DW DW DW DW DW DW DW DW DW 5,'>NAME',TNAME CRRNT ;vocabulary link TWOP,AT,QDUP ;check all vocabularies QBRAN,TNAM4 DDUP AT,DUPP ;?last word in a vocabulary QBRAN,TNAM3 DDUP,NAMET,XORR ;compare QBRAN,TNAM3 TWOM ;continue with next word BRAN,TNAM2 SWAP,DROP,QDUP QBRAN,TNAM1 SWAP,DROP,SWAP,DROP,EXIT DROP,DOLIT,0,EXIT ;false flag

TNAM1: TNAM2:

TNAM3: TNAM4: ; ;.ID
( na -- ) Display the name at address. $COLON DW DW DW DW D$ DW 3,'.ID',DOTID QDUP QBRAN,DOTI1 COUNT,DOLIT,01FH,ANDD UTYPE,EXIT DOTQP,' {noName}' EXIT ;if zero no name ;mask lexicon bits ;display name string

DOTI1: ; ; WORDS

( -- ) Display the names in the context vocabulary. $COLON DW DW DW DW DW 5,'WORDS',WORDS CR,CNTXT,AT AT,QDUP QBRAN,WORS2 DUPP,SPACE,DOTID TWOM,NUFQ ;only in context ;?at end of list ;display a name ;user control

WORS1:

WORS2:

QBRAN,WORS1 DROP EXIT

;; Hardware reset ; ; VER ( -- n ) Return the version number of this implementation. $COLON DW ; ; hi 3,'VER',VERSN DOLIT,VER*256+EXT,EXIT
( -- ) Display the sign-on message of eForth. $COLON DW D$ DW DW DW DW DW 2,'hi',HI STOIO,CR DOTQP,'eForth v' BASE,AT,HEX VERSN,BDIGS,DIG,DIG DOLIT,'.',HOLD DIGS,EDIGS,TYPEE BASE,STORE,CR,EXIT ;initialize I/O
( -- a ) The application startup vector. $COLON DW DW 5,"'BOOT",TBOOT DOVAR HI

;application to boot

SEE1: SEE2:

SEE3: SEE4:

( --word-- ) Decompiles word. $COLON 3,'SEE',SEE DW TICK DW CR,ONEP DW DUPP,DUPP,SPACE,DOT,DOLIT,07CH,EMIT,AT,DUPP DW QBRAN,SEE2 DW TNAME DW QDUP DW QBRAN,SEE3 DW DOTID DW BRAN,SEE4 DW DUPP,AT,UDOT DW TWOP,NUFQ DW QBRAN,SEE1 DW DROP,EXIT ( -- ) Init routine for starting ADC Interrupts $CODE 7,'ADCINIT',ADCIN DB 64H,4EH,1 ;MKH AND 1, skip if not zero DB 0D1H ;JUMP TO $NEXT DB 64H,0AH,1FH ;PC<PC AND 1F DB 68H,0FFH ;V<FF DB 69H,0 ;A<0 DB 63H,0F3H ;(V/F3)<A

ADCINIT

DB 4DH,0C8H DB 48H,48H DB 00 DB 64H,0EH,0FEH $NEXT ; ; ADCOFF
;ANM <A ;SKIT FAD, reset INTFAD ;NOP ;ENABLE INTAD
( --- ) Disable ADC Interrupts. $CODE 6,'ADCOFF',ADCOF DB 64H,1EH,1 ;;MKH < MKH OR 1 $NEXT ( n -- ) Wait for last transmit, $CODE 2,'TM',TM DB 0A1H DB 0BH DB 48H,4AH DB 0FDH DB 4DH,0D8H $NEXT ( n -- ) Wait for n loops. $CODE 5,'DELAY',DELAY DB 0A1H DB 53H DB 0FEH DB 52H DB 0FCH $NEXT then send midi byte n. ;POP BC ;A<C ;SKIT FST, skip if interrupt ;JMP TO SKIT ;MOV TXB,A
;POP BC ;C<C-1, Skip if borrow ;JMP ;B<B-1, Skip if borrow ;JMP

UD4A: UD4B: UD4C: ; ; CFLD4

UD5A: UD5B: ; ; CFLD5

UD5AA: UD5BB: ; ; BSUP

MNCASE

( --- ) Button case for Main. $COLON 6,'MNCASE',MNCASE DW SAT,CASE DW DUMMY,BSDWN,BSUP,BLOAD,BMIDI,BUP,BDOWN,BLEFT,BRIGH DW EXIT ( --- stat) Loop thru ADC values until an enabled one is found. $CODE 5,'MLOOP',MLOOP DB 68H,0FFH ;V<FF DB 6AH,0C6H ;B<C6 DB 1,0E0H ;A<(V/E0), LOOPBACK DB 41H ;A<A+1 skip if carry DB 07H,3FH ;A<A AND 3F DB 63H,0E0H ;(V/E0)<A DB DB DB DB DB 46H,0C0H 1BH 29H 47H,80H 0F2H ;A<A+C0 ;C<A ;A<(BC), midi byte1 ;A AND 80, skip if no zero ;JMP LOOPBACK, if disabled ;A<A AND 7F ;A shift right ;A shift right ;A shift right ;A shift right ;C<A ;B<0 ;PUSH BC, push status# on stack
DB 7H,7FH DB 48H,21H DB 48H,21H DB 48H,21H DB 48H,21H DB 1BH DB 6AH,0 DB 0B1H $NEXT ; ; ADCV ( --- adc value) Push stack with current $CODE 4,'ADCV',ADCV DB 1,0E0H DB 1BH DB 6AH,0C6H DB 29H DB 1BH DB 6AH,0 DB 0B1H $NEXT ( --- diff value) Push stack with current $CODE 5,'SLAST',SLAST DB 1,0E0H DB 46H,40H DB 1BH DB 6AH,0C6H DB 29H DB 1BH DB 6AH,0 DB 0B1H
diff value for MIDI operation. ;A<(V/E0), Midi loop count. ;A<A+40 ;C<A ;B<C6 ;A<(BC) ;C<A ;B<0 ;PUSH BC
$NEXT ; ; BYT2 ( --- byt2 value) Push stack with current $CODE 4,'BYT2',BYT2 DB 1,0E0H DB 46H,80H DB 1BH DB 6AH,0C6H DB 29H DB 1BH DB 6AH,0 DB 0B1H $NEXT ( --- byt1 value) Push stack with current $CODE 4,'BYT1',BYT1 DB 1,0E0H DB 46H,0C0H DB 1BH DB 6AH,0C6H DB 29H DB 1BH DB 6AH,0 DB 0B1H $NEXT ( --- flag value) Push stack with current $CODE 4,'FLAG',FLAG DB 1,0E0H DB 1BH DB 6AH,0C7H DB 29H DB 1BH DB 6AH,0 DB 0B1H $NEXT BYTE2 value for MIDI operation. ;A<(V/E0), Midi loop count. ;A<A+80 ;C<A ;B<C6 ;A<(BC) ;C<A ;B<0 ;PUSH BC
( --- ) Store FF in FLAG of current slider. $CODE 5,'FLGON',FLGON DB 1,0E0H ;A<(V/E0) DB 1BH ;C<A DB 6AH,0C7H ;B<C7 DB 69H,0FFH ;A<FF DB 39H ;(BC)<A $NEXT ( --- ) Store 0 in FLAG of current slider. $CODE 6,'FLGOFF',FLGOFF DB 1,0E0H ;A<(V/E0) DB 1BH ;C<A DB 6AH,0C7H ;B<C7 DB 69H,0 ;A<0 DB 39H ;(BC)<A
$NEXT ; ?DIFF ; (old,new --- /shifted new,0F/ OR /00/) Flag=0F if /old-new/>1, else Flag=0. $CODE 5,'?DIFF',QDIFF DB 0A4H ;POP EA, new DB 0A1H ;POP BC, old DB 09H ;A<EAL DB 60H,0E3H ;A<A-C DB DB DB DB DB DB DB DB DB DB DB 6BH,0FFH 60H,0EBH 69H,0 6BH,0 47H,0FEH 0C7H 9H 48H,21H 19H 0B4H 6BH,0FFH ;C<FF ;A-C, skip if no zero ;A<0 ;C<0 ;A AND FE, skip if no zero ;JMP AHEAD ;A<EAL ;A SHIFT RIGHT ;EAL<A ;PUSH EA ;C<FF ;B<0, AHEAD ;PUSH BC

;; Dictionary search ; ; NAME> $COLON DW ; SAME? ( na -- ca ) Return a code address given a name address. 5,'NAME>',NAMET TWOM,TWOM,AT,EXIT ( a a u -- a a f \ -0+ )
; $COLON DW DW SAME1: DW DW DW DW SAME2: DW ; ; find $COLON DW DW DW FIND1: DW DW DW DW DW FIND2: FIND3: FIND6: DW FIND4: DW DW FIND5: DW DW ; ; NAME? $COLON DW DW DW NAMQ1: NAMQ2: DW DW
Compare u cells in two strings. Return 0 if identical. 5,'SAME?',SAMEQ TOR BRAN,SAME2 DW OVER,RAT,TWOSL,PLUS,AT OVER,RAT,TWOSL,PLUS,AT SUBB,QDUP QBRAN,SAME2 RFROM,DROP,EXIT ;strings not equal DW DONXT,SAME1 DOLIT,0,EXIT ;strings equal ( a va -- ca na | a F ) Search a vocabulary for a string. Return ca and na if succeeded. 4,'find',FIND SWAP,DUPP,CAT DOLIT,CELLL,SLASH,TEMP,STORE DUPP,AT,TOR,TWOP,SWAP DW AT,DUPP QBRAN,FIND6 DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR QBRAN,FIND2 TWOP,DOLIT,-1 ;true flag BRAN,FIND3 DW TWOP,TEMP,AT,SAMEQ DW BRAN,FIND4 DW RFROM,DROP SWAP,TWOM,SWAP,EXIT DW QBRAN,FIND5 TWOM,TWOM BRAN,FIND1 DW RFROM,DROP,SWAP,DROP TWOM DUPP,NAMET,SWAP,EXIT ( a -- ca na | a F ) Search all context vocabularies for a string. 5,'NAME?',NAMEQ CNTXT,DUPP,DAT,XORR ;?context=also QBRAN,NAMQ1 TWOM ;no, start with context DW TOR DW RFROM,TWOP,DUPP,TOR ;next in search order AT,QDUP QBRAN,NAMQ3

DW DW DW NAMQ3: DW

FIND,QDUP QBRAN,NAMQ2 RFROM,DROP,EXIT DW RFROM,DROP DOLIT,0,EXIT
;search vocabulary ;found name ;name not found ;false flag
;; Terminal response ; ; ^H $COLON DW DW DW DW DW BACK1: ; ; TAP $COLON DW DW ; ; kTAP $COLON DW DW DW DW DW KTAP1: KTAP2: ; ; accept $COLON DW ACCP1: DW DW ; DW ( bot eot cur -- bot eot cur ) Backup the cursor by one character. 2,'^H',BKSP TOR,OVER,RFROM,SWAP,OVER,XORR QBRAN,BACK1 DOLIT,BKSPP,TECHO,ATEXE,ONEM BLANK,TECHO,ATEXE DOLIT,BKSPP,TECHO,ATEXE DW EXIT ( bot eot cur c -- bot eot cur ) Accept and echo the key stroke and bump the cursor. 3,'TAP',TAP DUPP,TECHO,ATEXE OVER,CSTOR,ONEP,EXIT ( bot eot cur c -- bot eot cur ) Process a key stroke, CR or backspace. 4,'kTAP',KTAP DUPP,DOLIT,CRR,XORR QBRAN,KTAP2 DOLIT,BKSPP,XORR QBRAN,KTAP1 BLANK,TAP,EXIT DW BKSP,EXIT DW DROP,SWAP,DROP,DUPP,EXIT ( b u -- b u ) Accept characters to input buffer. Return with actual count. 6,'accept',ACCEP OVER,PLUS,OVER DW DDUP,XORR QBRAN,ACCP4 KEY,DUPP DW BLANK,SUBB,DOLIT,95,ULESS BLANK,DOLIT,127,WITHI
DW DW DW ACCP2: ACCP3: ACCP4: ; ; EXPECT $COLON DW ; ; QUERY $COLON DW DW
QBRAN,ACCP2 TAP BRAN,ACCP3 DW TTAP,ATEXE DW BRAN,ACCP1 DW DROP,OVER,SUBB,EXIT ( b u -- ) Accept input stream and store count in SPAN. 6,'EXPECT',EXPEC TEXPE,ATEXE,SPAN,STORE,DROP,EXIT ( -- ) Accept input stream to terminal input buffer. 5,'QUERY',QUERY TIB,DOLIT,80,TEXPE,ATEXE,NTIB,STORE DROP,DOLIT,0,INN,STORE,EXIT
;; Error handling ; ; CATCH $COLON DW DW DW DW ; ; THROW $COLON DW DW DW DW ; ; NULL$ $COLON DW DW DB ( ca -- 0 | err# ) Execute word at ca and set up an error frame for it. 5,'CATCH',CATCH SPAT,TOR,HANDL,AT,TOR RPAT,HANDL,STORE,EXECU RFROM,HANDL,STORE RFROM,DROP,DOLIT,0,EXIT ;save error frame ;execute ;restore error frame ;no error

( err# -- err# ) Reset system to current local error frame an update error flag. 5,'THROW',THROW HANDL,AT,RPSTO RFROM,HANDL,STORE RFROM,SWAP,TOR,SPSTO DROP,RFROM,EXIT ;restore return stack ;restore handler frame ;restore data stack
( -- a ) Return address of a null string with zero count. 5,'NULL$',NULLS DOVAR 0 99,111,121,111,116,101 ;emulate CREATE

ABORT $COLON DW

( -- ) Reset data stack and jump to QUIT. 5,'ABORT',ABORT NULLS,THROW

abort"

( f -- ) Run time routine of ABORT". Abort with a message. COMPO+6,'abort"',ABORQ QBRAN,ABOR1 DOSTR,THROW DW DOSTR,DROP,EXIT ;text flag ;pass error string ;drop error

$COLON DW DW ABOR1:

;; The text interpreter ; ; $INTERPRET $COLON DW DW DW D$ DW INTE1: DW DW INTE2: ; ; [ $COLON DW ; ;.OK $COLON DW DW D$ DOTO1: ; ; ?STACK ( a -- ) Interpret a word. If failed, try to convert it to an integer. 10,'$INTERPRET',INTER NAMEQ,QDUP QBRAN,INTE1 AT,DOLIT,COMPO,ANDD ABORQ,' compile only' EXECU,EXIT DW TNUMB,ATEXE QBRAN,INTE2 EXIT DW THROW ;?defined ;?compile only lexicon bits ;execute defined word ;convert a number ;error
( -- ) Start the text interpreter. IMEDD+1,'[',LBRAC DOLIT,INTER,TEVAL,STORE,EXIT ( -- ) Display 'ok' only while interpreting. 3,'.OK',DOTOK DOLIT,INTER,TEVAL,AT,EQUAL QBRAN,DOTO1 DOTQP,' ok' DW CR,EXIT ( -- ) Abort if the data stack underflows.
$COLON DW D$ DW ; ; EVAL $COLON EVAL1: DW DW DW EVAL2: ;; Shell ; ; PRESET $COLON DW DW ; ; xio $COLON DW DW ; ; FILE $COLON DW DW ; ; HAND $COLON DW DW ; ; I/O
6,'?STACK',QSTAC DEPTH,ZLESS ABORQ,' underflow' EXIT
;check only for underflow
( -- ) Interpret the input stream. 4,'EVAL',EVAL DW TOKEN,DUPP,CAT ;?input stream empty QBRAN,EVAL2 TEVAL,ATEXE,QSTAC ;evaluate input, check stack BRAN,EVAL1 DW DROP,TPROM,ATEXE,EXIT ;prompt
( -- ) Reset data stack pointer and the terminal input buffer. 6,'PRESET',PRESE SZERO,AT,SPSTO DOLIT,TIBB,NTIB,TWOP,STORE,EXIT ( a a a -- ) Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT. COMPO+3,'xio',XIO DOLIT,ACCEP,TEXPE,DSTOR TECHO,DSTOR,EXIT ( -- ) Select I/O vectors for file download. 4,'FILE',FILE DOLIT,PACE,DOLIT,DROP DOLIT,KTAP,XIO,EXIT ( -- ) Select I/O vectors for terminal interface. 4,'HAND',HAND DOLIT,DOTOK,DOLIT,EMIT DOLIT,KTAP,XIO,EXIT ( -- a ) Array to store default I/O vectors.
$COLON DW DW ; ; CONSOLE $COLON DW DW ; ; QUIT $COLON DW QUIT1: QUIT2: DW DW DW DW DW DW D$ QUIT3: DW DW QUIT4: DW ;; The compiler ; ; ' $COLON DW DW DW TICK1: ; ; ALLOT $COLON DW
3,'I/O',ISLO DOVAR QRX,TXSTO
;emulate CREATE ;default I/O vectors
( -- ) Initiate terminal interface. 7,'CONSOLE',CONSO ISLO,DAT,TQKEY,DSTOR HAND,EXIT ;restore default I/O device ;keyboard input
( -- ) Reset return stack pointer and start text interpreter. 4,'QUIT',QUIT RZERO,AT,RPSTO DW LBRAC DW QUERY DOLIT,EVAL,CATCH,QDUP QBRAN,QUIT2 TPROM,AT,SWAP CONSO,NULLS,OVER,XORR QBRAN,QUIT3 SPACE,COUNT,TYPEE DOTQP,' ? ' DW DOLIT,DOTOK,XORR QBRAN,QUIT4 DOLIT,ERR,EMIT DW PRESE BRAN,QUIT1 ;reset return stack pointer ;start interpretation ;get input ;evaluate input ;continue till error ;save input device ;?display error message ;error message ;error prompt ;?file input ;file error, tell host ;some cleanup

;; Defining words

USER $COLON DW DW
( u -- ; <string> ) Compile a new user variable. 4,'USER',USER TOKEN,SNAME,OVERT,CALLC COMPI,DOUSE,COMMA,EXIT ( -- ; <string> ) Compile a new array entry without allocating code space. 6,'CREATE',CREAT TOKEN,SNAME,OVERT,CALLC COMPI,DOVAR,EXIT ( -- ; <string> ) Compile a new variable initialized to 0. 8,'VARIABLE',VARIA CREAT,DOLIT,0,COMMA,EXIT ( -- ) Start a new code definition using next word as its name. $COLON DW DW 4,'CODE',CODE TOKEN,SNAME DOLIT,CCOMP,TEVAL,STORE,EXIT ( -- ) Terminate a code definition IMEDD+COMPO+7,'ENDCODE',ENDCD DOLIT,48H,CCOMMA,DOLIT,84H,CCOMMA DOLIT,48H,CCOMMA,DOLIT,28H,CCOMMA LBRAC,OVERT,EXIT ;$NEXT

CREATE $COLON DW DW

VARIABLE $COLON DW

ENDCODE $COLON DW DW DW

;; Tools ; ; _TYPE $COLON DW DW UTYP1: DW UTYP2: DW ( b u -- ) Display a string. Filter non-printing characters. 5,'_TYPE',UTYPE TOR ;start count down loop BRAN,UTYP2 ;skip first pass DW DUPP,CAT,TCHAR,EMIT ;display only printable ONEP ;increment address DW DONXT,UTYP1 ;loop till done DROP,EXIT

dm+ $COLON DW DW DW

( a u -- a ) Dump u bytes from , leaving a+u on the stack. 3,'dm+',DMP OVER,DOLIT,4,UDOTR ;display address SPACE,TOR ;start count down loop BRAN,PDUM2 ;skip first pass DW DUPP,CAT,DOLIT,3,UDOTR ;display numeric data ONEP ;increment address DW DONXT,PDUM1 ;loop till done EXIT ( a u -- ) Dump u bytes from a, in a formatted manner. $COLON DW DW DW 4,'DUMP',DUMP BASE,AT,TOR,HEX ;save radix, set hex DOLIT,16,SLASH ;change count to lines TOR ;start count down loop DW CR,DOLIT,16,DDUP,DMP ;display numeric ROT,ROT SPACE,SPACE,UTYPE ;display printable characters NUFQ,INVER ;user control QBRAN,DUMP2 DONXT,DUMP1 ;loop till done BRAN,DUMP3 DW RFROM,DROP ;cleanup loop stack, early exit DW DROP,RFROM,BASE,STORE ;restore radix EXIT (. --. ) Display the contents of the data stack. $COLON DW DW DW 2,'.S',DOTS CR,DEPTH TOR BRAN,DOTS2 DW RAT,PICK,DOT DW DONXT,DOTS1 DOTQP,' <sp' EXIT ;stack depth ;start count down loop ;skip first pass ;index stack, display contents ;loop till done
PDUM1: DW PDUM2: DW ; ; DUMP
DUMP1: DW DW DW DW DW DW DUMP2: DUMP3: DW ; ;.S
DOTS1: DOTS2: D$ DW ; ; !CSP $COLON DW
( -- ) Save stack pointer in CSP for error checking. 4,'!CSP',STCSP SPAT,CSP,STORE,EXIT ;save pointer

?CSP $COLON DW D$ DW

( -- ) Abort if stack pointer differs from that saved in CSP. 4,'?CSP',QCSP SPAT,CSP,AT,XORR ABORQ,'stacks' EXIT ;compare pointers ;abort if different

>NAME $COLON DW

( ca -- na | F ) Convert code address to a name address. 5,'>NAME',TNAME CRRNT ;vocabulary link DW TWOP,AT,QDUP ;check all vocabularies QBRAN,TNAM4 DDUP DW AT,DUPP ;?last word in a vocabulary QBRAN,TNAM3 DDUP,NAMET,XORR ;compare QBRAN,TNAM3 TWOM ;continue with next word BRAN,TNAM2 DW SWAP,DROP,QDUP QBRAN,TNAM1 SWAP,DROP,SWAP,DROP,EXIT DW DROP,DOLIT,0,EXIT ;false flag ( na -- ) Display the name at address. $COLON DW DW DW DW 3,'.ID',DOTID QDUP ;if zero no name QBRAN,DOTI1 COUNT,DOLIT,01FH,ANDD ;mask lexicon bits UTYPE,EXIT ;display name string D$ DOTQP,' {noName}' EXIT ( -- ) Display the names in the context vocabulary. $COLON DW 5,'WORDS',WORDS CR,CNTXT,AT DW AT,QDUP QBRAN,WORS2 DUPP,SPACE,DOTID TWOM,NUFQ QBRAN,WORS1 ;only in context ;?at end of list ;display a name ;user control

TNAM1: DW DW TNAM2: DW DW DW DW DW TNAM3: DW DW TNAM4: ; ;.ID

DOTI1: DW ; ; WORDS

WORS1: DW DW DW DW

DW WORS2:

DROP DW
;; Hardware reset ; ; VER $COLON DW ; ; hi $COLON DW D$ DW DW DW DW DW ; ; 'BOOT $COLON DW DW ; ; SEE ( -- n ) Return the version number of this implementation. 3,'VER',VERSN DOLIT,VER*256+EXT,EXIT ( -- ) Display the sign-on message of eForth. 2,'hi',HI STOIO,CR DOTQP,'eForth v' BASE,AT,HEX VERSN,BDIGS,DIG,DIG DOLIT,'.',HOLD DIGS,EDIGS,TYPEE BASE,STORE,CR,EXIT ;initialize I/O
( -- a ) The application startup vector. 5,"'BOOT",TBOOT DOVAR HI

;application to boot

SEE1: SEE2:

SEE3: SEE4:

( --word-- ) Decompiles word. $COLON 3,'SEE',SEE DW TICK DW CR,ONEP DW DUPP,DUPP,SPACE,DOT,AT,DUPP DW QBRAN,SEE2 DW TNAME DW QDUP DW QBRAN,SEE3 DW DOTID DW BRAN,SEE4 DW DUPP,AT,UDOT DW TWOP,NUFQ DW QBRAN,SEE1 DW DROP,EXIT

ADCINIT

( -- ) Init routine for starting ADC Interrupts $CODE 7,'ADCINIT',ADCINIT DB 68H,0FFH ;V<FF DB 69H,0C6H ;A<C6 DB 63H,0F2H ;(V/F2)<A DB 69H,0 ;A<0 DB 63H,0F3H ;(V/F3)<A DB 4DH,0C8H ;ANM <A DB 48H,48H ;SKIT FAD, reset INTFAD DB 00 ;NOP DB 64H,0EH,0FEH ;ENABLE INTAD $NEXT ( n -- ) Wait for last transmit, then send midi byte n. $CODE 5,'TMIDI',TMIDI DB 0A1H ;POP BC DB 0BH ;A<C DB 48H,4AH ;SKIT FST, skip if interrupt DB 0FDH ;JMP TO SKIT DB 4DH,0D8H ;MOV TXB,A $NEXT ( n -- ) Wait for n loops. $CODE 5,'DELAY',DELAY DB 0A1H DB 53H DB 0FEH DB 52H DB 0FCH $NEXT
;POP BC ;C<C-1, Skip if borrow ;JMP ;B<B-1, Skip if borrow ;JMP
( n -- ) Load control n to LCD display. $CODE 4,'LCD',LCD DB 0A1H ;POP BC DB 0BH ;A<C DB 14H,0,0A0H ;BC<A000 DB 39H ;(BC)<A $NEXT ( --- ) Sets RS=0 for LCD setup commands. $CODE 3,'LLI',LLI DB 64H,0AH,0EFH ;Pc<Pc AND EF $NEXT
( --- ) Sets RS=1 for LCD character loading $CODE 3,'LLC',LLC DB 64H,1AH,10H ;Pc<Pc OR 10 $NEXT ( n --- ) load LCD setup instruction n, exit ready for char loads $COLON 2,'LI',LI DW LLI,LCD,LLC,EXIT ( -- ) Initialize LCD display. $COLON 7,'LCDINIT',LCDINIT DW DOLIT,0D7AH,DELAY DW DOLIT,038H,LI DW DOLIT,047EH,DELAY DW DOLIT,038H,LI DW DOLIT,017H,DELAY DW DOLIT,038H,LI DW DOLIT,017H,DELAY DW DOLIT,038H,LI DW DOLIT,017H,DELAY DW DOLIT,08H,LI DW DOLIT,017H,DELAY DW DOLIT,01H,LI DW DOLIT,01CCH,DELAY DW DOLIT,02H,LI DW DOLIT,01CCH,DELAY DW DOLIT,06H,LI DW DOLIT,17H,DELAY DW DOLIT,0EH,LI DW DOLIT,17H,DELAY DW EXIT ( n,p --- ) Display n as a 3-digit number at LCD position p. $COLON 5,'#DISP',NDISP DW DUPP,LI,SWAP DW BDIGS,DIG,DIG,DIG,EDIGS DW DROP,DUPP,CAT,LCD,ONEP DW DUPP,CAT,LCD,ONEP,CAT,LCD,LI,EXIT ( a,p --- ) Display packed string at a to LCD position p. $COLON 4,'DISP',DISP DW LI,DUPP,CAT,TWOM,TOR

F4D F0 C1 0F FF D7 0A 0B 4E 4D D0 4D D2 4D D4D D4 4D D06 4D CA
8/27/94 23:19:56 Page 1-6 DB DB DB DB DB DB 34H LOW RPP HIGH RPP 69H,00H,4DH,0E8H 68H,0FFH 10H,68H,0FFH,69H,0 ;HL<RPP, HL=return stack pointer ;ZCM<0, zero cross disabled (3-26) ;V<FF ;V'<FF, A"<0, V<FF, A<0

334 335

012D 012F 013C 013F 014B
34 F0 C00 4D EFF FF 64 FF 83 5C 4D 4D B3 EA CC 4D DA DB 48 D3 CC
; COLD start moves the following to USER variables. ; MUST BE IN SAME ORDER AS USER VARIABLES. 014E 0004[ 0000 C1F0 C2F0 032E R 0347 R 0D34 R 0D09 R 0347 R 0E2A R 000A C0DEE R 0963 R 0000 0006[ 0000 ] 018A 018C 018E C390 DW DW DW DW DW CTOP ;CURRENT pointer ;vocabulary link pointer ;FORTH HEAD ;FORTH LINK ;CP UZERO: ] DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW SPP RPP QRX TXSTO ACCEP KTAP TXSTO DOTOK BASEE TIBB 0 INTER NUMBQ 0 VOCSS DUP (0) ;SP0 ;RP0 ;'?KEY ;'EMIT ;'EXPECT ;'TAP ;'ECHO ;'PROMPT ;BASE ;tmp ;SPAN ;>IN ;#TIB ;TIB ;CSP ;'EVAL ;'NUMBER ;HLD ;HANDLER ;CONTEXT pointer ;vocabulary stack DW 4 DUP (0) ;reserved
015A 015C 015E 0168 016A 016C 016E 0178 017A 017C 017E
8/27/94 23:19:56 Page 1-7 DW DW DW DW DW NTOP LASTN 0 06H 16H ;NP ;LAST ;SERIN host receive char & flag ;HAFBIT time for serial host, ; (1/2 BITIME - 5) ;BITIME baud for serial host

390 391

0198 019A 019C 019E 0200

C7FF ULAST: ORG 0200H ;

Interrupt routine for Analog to Digital Converters DB 10H ;EXA DB 11H ;EXX Load ADC Address and Counter into HL. Uses FFF2 and FFF3. DB 68H,0FFH ;V'<FF DB 01H,0F2H ;A<(V/F2) DB 1EH ;H<A DB 01H,0F3H ;A<(V/F3) DB 1FH ;L<A Store ADC 0. DB 2BH ;A<(HL) DB 57H,80H ;A AND 80, Skip if zero DB 0CDH ;Jump to EXIT if slider is disabled. DB 1AH ;B<A DB 4CH,0E0H ;A<CR0 DB 48H,21H ;A Shift right, Midi is 7 bits, throw LSB. DB 60H,6AH ;B-A, Skip if not zero DB 0C5H ;Jump to EXIT if slider has not changed. DB 3DH ;(HL)<A, Store slider data, 0 in top bit. DB 69H,0FFH ;A<FF DB 0BFH,38H ;(HL+38)<A, Store slider change flag. DB 32H ;HL<HL+1, EXIT Store ADC 1. DB 2BH ;A<(HL) DB 57H,80H ;A AND 80, Skip if zero DB 0CDH ;Jump to EXIT if slider is disabled. DB 1AH ;B<A DB 4CH,0E1H ;A<CR1 DB 48H,21H ;A Shift right, Midi is 7 bits, throw LSB. DB 60H,6AH ;B-A, Skip if not zero DB 0C5H ;Jump to EXIT if slider has not changed. DB 3DH ;(HL)<A, Store slider data, 0 in top bit. DB 69H,0FFH ;A<FF DB 0BFH,38H ;(HL+38)<A, Store slider change flag. DB 32H ;HL<HL+1, EXIT Store ADC 2. DB 2BH ;A<(HL) DB 57H,80H ;A AND 80, Skip if zero DB 0CDH ;Jump to EXIT if slider is disabled. DB 1AH ;B<A DB 4CH,0E2H ;A<CR2 DB 48H,21H ;A Shift right, Midi is 7 bits, throw LSB. DB 60H,6AH ;B-A, Skip if not zero DB 0C5H ;Jump to EXIT if slider has not changed.

04CB 3E77 3E77 3E7B 04CB 04CB 04CC
04CB R 3E85 R 0496 R 0018

1 ; ; tmp

BASE: ORG ORG
( -- a ) A temporary storage location used in parse and find. TEMP: ORG ORG $USER _NAME DW DB _CODE DB 80H DW COMPO+3,'tmp',TEMP _CODE,_LINK COMPO+3,'tmp' DOUSE,_USER ; ; ; ; ; ; ;
04D0 3E6F 3E6F 3E73 04D0 04D0 04D1
04D0 R 3E7B R 6D 0496 R 001A
( -- a ) Hold character count received by EXPECT. $USER _NAME DW DB _CODE DB 80H DW 4,'SPAN',SPAN _CODE,_LINK 4,'SPAN' DOUSE,_USER ;
04D5 3E65 3E65 3E69 04D5 04D5 04D6

04D5 R 3E73 R 4E R 001C

1 ; ; >IN

SPAN: ORG ORG

( -- a ) Hold the character pointer while parsing input stream. $USER 3,'>IN',INN
8/27/94 23:19:56 Page 1-22 INN: ORG ORG ; _NAME DW DB _CODE DB 80H DW _CODE,_LINK 3,'>IN' DOUSE,_USER ; ; ; ; ; ;

1230 1231

04DA 3E5D 3E5D 3E61 04DA 04DA 04DB
04DA R 3E69 R 03 3E 49 4E R 001E
( -- a ) Hold the current count and address of the terminal input buffer. $USER _NAME DW DB _CODE DB 80H DW 4,'#TIB',NTIB _CODE,_LINK 4,'#TIB' DOUSE,_USER _USER = _USER+CELLL ;
04DF 3E53 3E53 04DF R 3E61 R 3E04DF 04DF 80 04ER 0020 = 0024

1 ; ; CSP

NTIB: ORG ORG
( -- a ) Hold the stack pointer for error checking. CSP: ORG ORG $USER _NAME DW DB _CODE DB 80H DW 3,'CSP',CSP _CODE,_LINK 3,'CSP' DOUSE,_USER ; ;
04E4 3E4B 3E4B 3E4F 04E4 04E4 04E5

04E4 R 3E57 R R 0024

; ; ; ; ;
( -- a ) Execution vector of EVAL. $USER _NAME DW DB _CODE DB 80H DW 5,"'EVAL",TEVAL _CODE,_LINK 5,"'EVAL" DOUSE,_USER ; ; ; ; ; ; ;
04E9 3E41 3E41 3E45 04E9 04E9 04EA
04E9 R 3E4F R 41 4C R 0026

TEVAL: ORG ORG

'NUMBER
( -- a ) Execution vector of NUMBER?. $USER 7,"'NUMBER",TNUMB _CODE,_LINK 7,"'NUMBER" DOUSE,_USER ; ; ; ; ; ; ;
04EE 3E35 3E35 3E39 04EE 04EE 04EF
04EE R 3E45 R 4E 55 4D R 0028

TNUMB: ORG ORG

8/27/94 23:19:56 Page 1-23

1286 1287

; ; 04F3 3E2D 3E2D 3E31 04F3 04F3 04F; ; 04F8 3E21 3E21 3E25 04F8 04F8 04F; ; 04FD 3E15 3E15 04FD R 3E25 R 3E43 4F 4E 58 04FD 04FD 80 04FE 0496 R 002E = 003C 1 ; ; 0502 3E09 3ER 3E19 R 3E0D 4E 0496 R 003C = ; ; 0507 3DFF 2 2
( -- a ) Hold a pointer in building a numeric output string. HLD: ORG ORG $USER _NAME DW DB _CODE DB 80H DW 3,'HLD',HLD _CODE,_LINK 3,'HLD' DOUSE,_USER ; ;
04F3 R 3E39 R 4C 0496 R 002A
( -- a ) Hold the return stack pointer for error handling. $USER 7,'HANDLER',HANDL _CODE,_LINK 7,'HANDLER' DOUSE,_USER ; ; ; ; ; ; ;

( n n -- d ) Signed multiply. Return double product. MSTAR: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW DW DW DW DW DW 2,'M*',MSTAR _CODE,_LINK 2,'M*' DDUP,XORR,ZLESS,TOR ABSS,SWAP,ABSS,UMSTA RFROM QBRAN,MSTA1 DNEGA EXIT ; ; ; ; ; ;
0738 R 3CB3 R 02 4D 2A 80 055B 0413 05AC 06FA 0405 03B0394 R 0473 R 0453 R R R 0442 R 05AC R R R R 0751 R R R

MSTA1: ; ; */MOD

( n1 n2 n3 -- r q ) Multiply n1 and n2, then divide by n3. Return mod and quotient. $COLON 5,'*/MOD',SSMOD _CODE,_LINK 5,'*/MOD' TOR,MSTAR,RFROM,MSMOD,EXIT ; ; ; ; ; ;
0753 3C9D 3C9D 3CA0753 0754
0753 R 3CAB R 05 2A 2F 4D 4F 0413 R 0738 R 0405 R 06AA R 0394 R

SSMOD: ORG ORG

; ; 075E 3C95 3C95 3C99 075E 075E 075F 2 1
( n1 n2 n3 -- q ) Multiply n1 by n2, then divide by n3. Return quotient only. STASL: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW 2,'*/',STASL _CODE,_LINK 2,'*/' SSMOD,SWAP,DROP,EXIT ; ; ; ; ; ;
075E R 3CA1 R 02 2A 2F R 0442 R 0436 R 0394 R
;; Miscellaneous ; ; 0767 3C8D 3C8D 3C2 BL ( -- 32 ) Return 32, the blank character. $COLON 0767 R 3C99 R 4C BLANK: ORG _NAME DW DB 2,'BL',BLANK _CODE,_LINK 2,'BL' ; ; ;
8/27/94 23:19:56 Page 1-36 ORG _CODE DB 80H DW ; ;

2014 2015

80 038D R R

DOLIT,' ',EXIT

>CHAR
( c -- c ) Filter non-printing characters. $COLON 5,'>CHAR',TCHAR _CODE,_LINK 5,'>CHAR' DOLIT,07FH,ANDD,DUPP DOLIT,127,BLANK,WITHI QBRAN,TCHA1 DROP,DOLIT,'_' EXIT ; ; ; ; ; ; ;mask msb ;check for printable ;replace non-printables
076E 3C83 3C83 3C87 076E 076E 076F 0777 077F 0783 0789
076E R 3C91 R 05 3E 80 038D 043B 038D 0610 03B0394 R R R R R R R 007F 0461 R 007F 0767 R 0789 R 038D R 005F

TCHAR: ORG ORG

TCHA1: ; ; DEPTH
( -- n ) Return the depth of the data stack. $COLON _NAME DW DB _CODE DB 80H DW DW 5,'DEPTH',DEPTH _CODE,_LINK 5,'DEPTH' SPAT,SZERO,AT,SWAP,SUBB DOLIT,CELLL,SLASH,EXIT ; ; ; ; ; ;
078B 3C79 3C79 3C7D 078B 078B 078C 0796
078B R 3C87 R 80 041C 0442 038D 0394 R 04A3 R 03DE R R 059B R R 0002 06F1 R R

DEPTH: ORG ORG

; ; 079E 3C6F 3C6F 3C73 079E 079E 079F 07A1
(. +n --. w ) Copy the nth stack item to tos. $COLON _NAME DW DB _CODE DB 80H DW DW 4,'PICK',PICK _CODE,_LINK 4,'PICK' ONEP,TWOSL SPAT,PLUS,AT,EXIT ;

PICK: ORG ORG

079E R 3C7D R 4B 80 061F R 063D R 041C R 0565 R 03DE R 0394 R
;; Memory access ; ; +! ( n a -- ) Add n to the contents at address a.
8/27/94 23:19:56 Page 1-37 $COLON 2,'+!',PSTOR _CODE,_LINK 2,'+!' SWAP,OVER,AT,PLUS SWAP,STORE,EXIT ; ; ; ; ; ;

2070 2071

07AB 3C67 3C67 3C6B 07AB 07AB 07AC 07B4
07AB R 3C73 R 02 2B 0442 R 044A R 03DE R 0565 R 0442 R 03D3 R 0394 R

0822 3C11 3C11 3C0829 082D 0833 0837
0822 R 3C1F R 49 4C 4C 03CC 055B 039D 0555 R R R R R 03E9 082D 0394 R 0442 R R R 061F R R R

FILL1: FILL2: ; ;

FILL: ORG ORG

-TRAILING

( b u -- b u ) Adjust the count to eliminate trailing white space. $COLON _NAME DW DB _CODE DB 80H DW DW DW DW DW DW DW 9,'-TRAILING',DTRAI _CODE,_LINK 9,'-TRAILING' TOR BRAN,DTRA2 BLANK,OVER,RAT,PLUS,CAT,LESS QBRAN,DTRA2 RFROM,ONEP,EXIT DONXT,DTRA1 DOLIT,0,EXIT ; ; ; ; ;
083B 3C03 3C03 3C07 083B 083B 083C 083E 0842 084E 085C
083B R 3C15 R 09 2D 4C 03CC 03B039D 038D R R R R R R R R

DTRA1:

DTRAI: ORG ORG
0858 044A 03F061F 0842 0000
R R 040C R R 05E1 R R R 0394 R R 0394 R

DTRA2: ; ; PACK$

;adjusted count ;count=0
( b u a -- a ) Build a counted string with u characters from b. Null fill. $COLON _NAME DW DB _CODE DB 80H DW DW 5,'PACK$',PACKS _CODE,_LINK 5,'PACK$' DUPP,TOR OVER,DUPP,DOLIT,0 ; ; ; ; ; ; ;strings only on cell boundary
0862 3BF9 3BF9 3BFD 0863 0867
0862 R 3C07 R 4B 043B R 0413 R 044A R 043B R 038D R

PACKS: ORG ORG

8/27/94 23:19:56 Page 1-40

2238 2239

086F 0877 087D 0885 088B
0000 038D 0436 059B 038D 03D3 055B 0442 0394
0002 064D R 044A R 0565 R R 03E9 R 061F R 0803 R 0405 R

DW DW DW DW DW

DOLIT,CELLL,UMMOD,DROP SUBB,OVER,PLUS DOLIT,0,SWAP,STORE DDUP,CSTOR,ONEP SWAP,CMOVE,RFROM,EXIT
;count mod cell ;null fill cell ;save count ;move string
;; Numeric output, single precision ; ; 0893 3BEF 3BEF 3BF089C 08A1 DIGIT ( u -- c ) Convert digit u to a character. $COLON _NAME DW DB _CODE DB 80H DW DW DW ; ; 08AC 3BE3 3BE3 3BE7 08AC 08AC 08AD 08B1 EXTRACT 5,'DIGIT',DIGIT _CODE,_LINK 5,'DIGIT' DOLIT,9,OVER,LESS DOLIT,7,ANDD,PLUS DOLIT,'0',PLUS,EXIT ; ; ; ; ; ;
0893 R 3BFD R 80 038D 05E1 038D 0565 038D 0394 R 0009 044A R R R R R R R R

DIGIT: ORG ORG

( n base -- n c ) Extract the least significant digit from n. $COLON 7,'EXTRACT',EXTRC _CODE,_LINK 7,'EXTRACT' DOLIT,0,SWAP,UMMOD SWAP,DIGIT,EXIT ; ; ; ; ; ;
08AC R 3BF3 R 038D R R 064D R 0442 R 0893 R 0394 R

EXTRC: ORG ORG

; ; 08BB 3BDB 3BDB 3BDF 08BB 08BB 08BC 2 1
( -- ) Initiate the numeric output process. BDIGS: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW 2,'<#',BDIGS _CODE,_LINK 2,'<#' PAD,HLD,STORE,EXIT ; ; ; ; ;
08BB R 3BE7 R 02 3C 07E6 R 04F3 R 03D3 R 0394 R
8/27/94 23:19:56 Page 1-41 ( c -- ) Insert a character into the numeric output string. $COLON 4,'HOLD',HOLD ; _CODE,_LINK 4,'HOLD' HLD,AT,ONEM DUPP,HLD,STORE,CSTOR,EXIT ; ; ; ; ;

2294 2295

; ; 08C4 3BD1 3BD1 3BD5 08C4 08C4 08C5 08CB 2 1
08C4 R 3BDF R 4F 4C 04F3 R 03DE R 0626 R 043B R 04F3 R 03D3 R 03E9 R 0394 R

0A71 R 3B29 R 6F 0405 07D0394 R 040C R 0405 R R 0565 R R 0442 R 0413 R R

$"|

( -- a ) Run time routine compiled by $". Return address of a compiled $COLON _NAME DW DB _CODE DB 80H DW COMPO+3,'$"|',STRQP _CODE,_LINK COMPO+3,'$"|' DOSTR,EXIT
0A84 3B15 3B15 3B19 0A84 0A84 0A85
0A84 R 3B21 R 22 7C 80 0A71 R 0394 R

; ;."|

STRQP: ORG ORG
; ; ; ;force a call to do$
( -- ) Run time routine of.". Output a compiled string.
8/27/94 23:19:56 Page 1-47

2630 2631

0A89 3B0D 3B0D 3B11 0A89 0A89 0A8A
0A89 R 3B19 R 43 2E 22 7C 80 0A71 R 07D4 R 0A4B R 0394 R

DOTQP: ORG ORG

$COLON _NAME DW DB _CODE DB 80H DW
COMPO+3,'."|',DOTQP _CODE,_LINK COMPO+3,'."|' DOSTR,COUNT,TYPEE,EXIT
; ; 0A92 3B05 3B05 3B09 0A92 0A92 0A93 0A9D 2 1
( n +n -- ) Display an integer in a field of n columns, right justified. DOTR: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW DW 2,'.R',DOTR _CODE,_LINK 2,'.R' TOR,STR,RFROM,OVER,SUBB SPACS,TYPEE,EXIT ; ;
0A92 R 3B11 R 02 2E 0413 R 090D R 0405 R 044A R 059B R 0A36 R 0A4B R 0394 R
; ; 0AA3 3AFD 3AFD 3B01 0AA3 0AA3 0AA4 0AAC 0AB1
( u +n -- ) Display an unsigned integer in n column, right justified. UDOTR: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW DW DW 3,'U.R',UDOTR _CODE,_LINK 3,'U.R' TOR,BDIGS,DIGS,EDIGS RFROM,OVER,SUBB SPACS,TYPEE,EXIT ; ; ; ; ;
0AA3 R 3B09 R 2E 0413 08FE 0405 0A36 R 08BB R 08E0 R R R 044A R 059B R R 0A4B R 0394 R
; ; 0AB8 3AF5 3AF5 3AF9 0AB8 0AB8 0AB9 0ABF 2 1
( u -- ) Display an unsigned integer in free format. UDOT: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW DW 2,'U.',UDOT _CODE,_LINK 2,'U.' BDIGS,DIGS,EDIGS SPACE,TYPEE,EXIT ; ;
0AB8 R 3B01 R 2E 80 08BB R 08E0 R 08FE R 0A2F R 0A4B R 0394 R
( w -- ) Display an integer in free format, preceeded by a space.
8/27/94 23:19:56 Page 1-48 $COLON 1,'.',DOT ; _CODE,_LINK 1,'.' BASE,AT,DOLIT,10,XORR QBRAN,DOT1 UDOT,EXIT STR,SPACE,TYPEE,EXIT ; ; ;

2686 2687

0AC5 3AEF 3AEF 3AF3 0AC5 0AC5 0AC6 0AD0 0AD4 0AD8
0AC5 R 3AF9 R 01 2E 80 04CB 000A 03B7 0AB8 090D 0394 R 03DE 0473 R R 0AD8 R 0394 R 0A2F R R 038D R R R R 0A4B R

DOT: ORG ORG

; ; ;?decimal ;no, display unsigned ;yes, display signed

DOT1: ; ; ?

( a -- ) Display the contents in a memory cell. QUEST: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW 1,'?',QUEST _CODE,_LINK 1,'?' AT,DOT,EXIT ; ; ; ; ;
0AE0 3AE9 3AE9 3AED 0AE0 0AE0 0AE1
0AE0 R 3AF3 R 01 3F 80 03DE R 0AC5 R 0394 R
;; Parsing ; ; 0AE7 3ADF 3ADF 3AE3 0AE7 0AE7 0AE8 0AF2 0AF6 0B00 0B04 0B06 0B0C 0B12 0B16 0B18 0B1C 0B28 0B2A 0B2E 0B1 parse ( b u c -- b u delta ; <string> ) Scan string delimited by c. Return found string and its offset. $COLON _NAME DW DB _CODE DB 80H DW DW DW DW DW DW DW DW DW DW DW DW DW DW DW 5,'parse',PARS _CODE,_LINK 5,'parse' TEMP,STORE,OVER,TOR,DUPP QBRAN,PARS8 ONEM,TEMP,AT,BLANK,EQUAL QBRAN,PARS3 TOR BLANK,OVER,CAT ;skip leading blanks ONLY SUBB,ZLESS,INVER QBRAN,PARS2 ONEP DONXT,PARS1 RFROM,DROP,DOLIT,0,DUPP,EXIT RFROM OVER,SWAP TOR TEMP,AT,OVER,CAT,SUBB ; ; ; ; ; ;

; ; 0BB8 3AB7 3AB7 3ABB 0BB8 0BB8 0BB1
( -- c ) Parse next word and return its first character. $COLON _NAME DW DB _CODE DB 80H DW 4,'CHAR',CHAR _CODE,_LINK 4,'CHAR' BLANK,PARSE,DROP,CAT,EXIT ;

CHAR: ORG ORG

0BB8 R 3AC5 R 0767 R 0B78 R 0436 R 03F1 R 0394 R
; ; 0BC3 3AAD 3AAD 3AB1 0BC3 0BC3 0BC4 0BCE 0BD1
( -- a ; <string> ) Parse a word from input stream and copy it to name dictionary. $COLON _NAME DW DB _CODE DB 80H DW DW DW 5,'TOKEN',TOKEN _CODE,_LINK 5,'TOKEN' BLANK,PARSE,DOLIT,31,MIN NP,AT,OVER,SUBB,TWOM PACKS,EXIT ; ; ; ; ; ;
0BC3 R 3ABB R 4F 4B 45 4E 001F 0516 059B 0862 R 0BR R 03DE R 0635 R 0394 R 038D R R 044A R R R

TOKEN: ORG ORG

; ; 0BDC 3AA3 3AA3 3AA7 0BDC 2
( c -- a ; <string> ) Parse a word from input stream and copy it to code dictionary. $COLON _NAME DW DB _CODE 4,'WORD',WORDD _CODE,_LINK 4,'WORD' ; ; ; ; ;

0BDC R 3AB1 R 4F 52 44

WORDD: ORG ORG
8/27/94 23:19:56 Page 1-51 DB 80H DW ; PARSE,HERE,PACKS,EXIT

2854 2855

0BDC 0BDD
80 0B78 R 07DF R 0862 R 0394 R
;; Dictionary search ; ; 0BE5 3A99 3A99 3A9D 0BE5 0BE5 0BE1 NAME> ( na -- ca ) Return a code address given a name address. $COLON _NAME DW DB _CODE DB 80H DW 5,'NAME>',NAMET _CODE,_LINK 5,'NAME>' TWOM,TWOM,AT,EXIT ; ; ; ; ; ;
0BE5 R 3AA7 R 05 4E 41 4D 45 3E R 0635 R 03DE R 0394 R

NAMET: ORG ORG

; ; 0BEE 3A8F 3A8F 3A93 0BEE 0BEE 0BEF 0BF1 0BF5 0BFF 0C09 0C0D 0C11 0C17 0C1B 2 1
( a a u -- a a f \ -0+ ) Compare u cells in two strings. Return 0 if identical. $COLON _NAME DW DB _CODE DB 80H DW DW DW DW DW DW DW DW DW 5,'SAME?',SAMEQ _CODE,_LINK 5,'SAME?' TOR BRAN,SAME2 OVER,RAT,TWOSL,PLUS,AT OVER,RAT,TWOSL,PLUS,AT SUBB,QDUP QBRAN,SAME2 RFROM,DROP,EXIT DONXT,SAME1 DOLIT,0,EXIT ; ; ; ; ; ;
0BEE R 3A9D R 41 4D 45 3F 03CC 044A 0565 044A 0565 059B 03B039D 038D R R R R R R R R R R R

SAMEQ: ORG ORG

3078 3079

0D91 0D91 0D92 0D9C 0DA4 0DAA
80 041C 03DE 03FB 039B 0000
R 0413 R 0413 R 04F8 R R 04F8 R R
R 04F8 R R R 03D3 R R 03D3 R R 038D R
SPAT,TOR,HANDL,AT,TOR RPAT,HANDL,STORE,EXECU
RFROM,HANDL,STORE ;restore error frame RFROM,DROP,DOLIT,0,EXIT ;no error
; ; 0DB4 3A2B 3A2B 3A2F 0DB4 0DB4 0DB5 0DBB 0DC1 0DC1
( err# -- err# ) Reset system to current local error frame an update error flag. $COLON 5,'THROW',THROW _CODE,_LINK 5,'THROW' HANDL,AT,RPSTO RFROM,HANDL,STORE RFROM,SWAP,TOR,SPSTO DROP,RFROM,EXIT ; ; ; ; ; ; ;restore return stack ;restore handler frame ;restore data stack
0DB4 R 3A39 R 4F 04F0436 R R R R R 03DE R 0400 R 04F8 R 03D3 R 0442 R 0413 R 0405 R 0394 R

THROW: ORG ORG

; ; 0DCF 3A21 3A21 3A25 0DCF 0DCF 0DD0 0DD2 0DD1
( -- a ) Return address of a null string with zero count. $COLON 5,'NULL$',NULLS _CODE,_LINK 5,'NULL$' DOVAR 0 99,111,121,111,116,101 ; ; ; ; ; ; ;emulate CREATE
0DCF R 3A2F R 05 4E 55 4C 4C 048C R 6F 79 6F 74 65

NULLS: ORG ORG

_NAME DW DB _CODE DB 80H DW DW DB
; ; 0DDA 3A17 3A17 3A1B 0DDA 0DDA 0DDB ; ;
( -- ) Reset data stack and jump to QUIT. $COLON _NAME DW DB _CODE DB 80H DW 5,'ABORT',ABORT _CODE,_LINK 5,'ABORT' NULLS,THROW ; ; ; ; ; ;

ABORT: ORG ORG

0DDA R 3A25 R 42 4F 80 0DCF R 0DB4 R
( f -- ) Run time routine of ABORT". Abort with a message. $COLON COMPO+6,'abort"',ABORQ
8/27/94 23:19:56 Page 1-56 ABORQ: ORG ORG ; ; ;

3134 3135

0DDF 3A0B 3A0B 3A0F 0DDF 0DDF 0DE0 0DE4 0DE8
0DDF R 3A1B R 62 6F 03B7 R 0DE8 R 0A71 R 0DB4 R 0A71 R 0436 R 0394 R

ABOR1:

_NAME DW DB _CODE DB 80H DW DW DW
_CODE,_LINK COMPO+6,'abort"' QBRAN,ABOR1 DOSTR,THROW DOSTR,DROP,EXIT
; ; ; ;text flag ;pass error string ;drop error
;; The text interpreter ; ; 0DEE 39FB 39FB 39FF 0DEE 0DEE 0DEF 0DF3 0DF7 0DFF 0E01 0E01 0E01 0E0F 0E0F 0E13 0E17 0E1B 0E1D $INTERPRET ( a -- ) Interpret a word. If failed, try to convert it to an integer. $COLON _NAME DW DB _CODE DB 80H DW DW DW D$ DW DB _LEN DB _CODE DW DW DW DW DW 10,'$INTERPRET',INTER _CODE,_LINK 10,'$INTERPRET' NAMEQ,QDUP QBRAN,INTE1 AT,DOLIT,COMPO,ANDD ABORQ,' compile only' ABORQ 0,' compile only' _CODE-_LEN-1 EXECU,EXIT TNUMB,ATEXE QBRAN,INTE2 EXIT THROW ; ; ; ; ; ;?defined ;?compile only lexicon bits ;
0DEE R 3A0F R 0A 4E 0C96 03B7 03DE 0461 R 053D R R 0E13 R R 038D R 0040 R

INTER: ORG ORG

0DDF R 63 6F 6D 0D 039B 04EE 03B0DB4 R 0394 R R 07F6 R R 0E1D R R R

1 INTE1: INTE2: ; ; [

; ; ; ; ;execute defined word ;convert a number ;error
( -- ) Start the text interpreter. LBRAC: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW IMEDD+1,'[',LBRAC _CODE,_LINK IMEDD+1,'[' DOLIT,INTER,TEVAL,STORE,EXIT ; ; ; ; ;

0E1F 39F5 39F5 39F9 0E1F 0E1F 0E20
0E1F R 39FF R 81 5B 80 038D R 0DEE R 04E9 R 03D3 R 0394 R

; ; 0E2A 2

( -- ) Display 'ok' only while interpreting. DOTOK: $COLON 3,'.OK',DOTOK ;
8/27/94 23:19:56 Page 1-57 ORG ORG _NAME DW DB _CODE DB 80H DW DW D$ DW DB _LEN DB _CODE DW ; ; ; ;

3190 3191

39ED 39ED 39F1 0E2A 0E2A 0E2B 0E35 0E39 0E3B 0E3B 0E3B 0E3F 0E3F
0E2A R 39F9 R 03 2E 4F 4B 80 038D R 0DEE R 04E9 R 03DE R 05B9 R 03B7 R 0E3F R 0A89 R 6F 6B 03 0A62 R 0394 R
_CODE,_LINK 3,'.OK' DOLIT,INTER,TEVAL,AT,EQUAL QBRAN,DOTO1 DOTQP,' ok' DOTQP 0,' ok' _CODE-_LEN-1 CR,EXIT
1 ORG ORG DOTO1: ; ; ?STACK
( -- ) Abort if the data stack underflows. $COLON 6,'?STACK',QSTAC _CODE,_LINK 6,'?STACK' DEPTH,ZLESS ABORQ,' underflow' ABORQ 0,' underflow' _CODE-_LEN-1 EXIT ; ; ;
0E43 39E1 39E1 39E5 0E43 0E43 0E44 0E48 0E4A 0E4A 0E4A 0E55 0E55
0E43 R 39F1 R 06 3F 4B 80 078B R 0453 R 0DDF R 75 6E 72 0A 0394 R

QSTAC: ORG ORG

ORG ORG EVAL
_NAME DW DB _CODE DB 80H DW D$ DW DB _LEN DB _CODE DW
; ; ; ;check only for underflow ; ; ; ; ;
( -- ) Interpret the input stream. $COLON _NAME DW DB _CODE DB 80H DW DW DW DW DW 4,'EVAL',EVAL _CODE,_LINK 4,'EVAL' TOKEN,DUPP,CAT QBRAN,EVAL2 TEVAL,ATEXE,QSTAC BRAN,EVAL1 DROP,TPROM,ATEXE,EXIT ; ; ; ; ; ; ;?input stream empty ;evaluate input, check stack ;prompt
0E57 39D7 39D7 39DB 0E57 0E57 0E58 0E5E 0E62 0E68 0E6C
0E57 R 39E5 R 4C 80 0BC3 03B7 04E9 03CC R R R R R R 043B 0E6C 07F6 0E58 04C6 R 03F1 R R R 0E43 R R R 07F6 R
2 EVAL: 2 ORG 2 ORG 1 EVAL1:
EVAL2: ;; Shell ; ; PRESET
( -- ) Reset data stack pointer and the terminal input buffer.
8/27/94 23:19:56 Page 1-58

3246 3247

0E74 39CB 39CB 39CF 0E74 0E74 0E75 0E7B
0E74 R 39DB R 04A3 R 03DE R 0429 R 038D R C200 04DF R 062D R 03D3 R 0394 R

PRESE: ORG ORG

$COLON _NAME DW DB _CODE DB 80H DW DW
6,'PRESET',PRESE _CODE,_LINK 6,'PRESET' SZERO,AT,SPSTO DOLIT,TIBB,NTIB,TWOP,STORE,EXIT
; ; 0E87 39C3 39C3 39C7 0E87 0E87 0E88 0E1
( a a a -- ) Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT. XIO: ORG ORG $COLON _NAME DW DB _CODE DB 80H DW DW COMPO+3,'xio',XIO _CODE,_LINK COMPO+3,'xio' DOLIT,ACCEP,TEXPE,DSTOR TECHO,DSTOR,EXIT ; ; ; ; ; ;
0E87 R 39CF R 69 6F 80 038D R 0D34 R 04B7 R 07BA R 04C1 R 07BA R 0394 R
; ; 0E96 39B9 39B9 39BD 0E96 0E96 0E97 0E9F 2 1
( -- ) Select I/O vectors for file download. $COLON 4,'FILE',FILE ; _CODE,_LINK 4,'FILE' DOLIT,PACE,DOLIT,DROP DOLIT,KTAP,XIO,EXIT ; ; ; ; ;
0E96 R 39C7 R 49 4C 038D 0436 038D 0394 R 0A26 R 038D R R R 0D09 R 0E87 R R

FILE: ORG ORG

152B R 365F R 4C 80 038D R 00CD 0394 R

; ; L0

FLD6: ORG ORG
( --- CD ) LCD Field start. $COLON 4,'FLD6',FLD6 _NAME DW DB _CODE DB 80H DW _CODE,_LINK 4,'FLD6' DOLIT,0CDH,EXIT

3649 364D 1532 1532

1532 R 3655 R 02 4C 30 80

L0: ORG ORG

( --- a ) Packed string. 'a' is addr of count byte. $COLON 2,'L0',L0 ; _NAME ; DW _CODE,_LINK ; DB 2,'L0' ; _CODE ; DB 80H ;
8/27/94 23:19:56 Page 1-84 SD$ 'Slider' DW DOLIT DW _LEN,EXIT DB 0,'Slider' _LEN DB _CODE-_LEN-1 _CODE

4702 4703

1539 1540
038D R 1539 R 0394 R 6C 06

; ; L1

1547 154E
1540 R 364D R 02 4C 038D R 1547 R 0394 R 23 06

; ; L2

L1: ORG ORG
( --- a ) Packed string. 'a' is addr of count byte. $COLON 2,'L1',L1 ; _NAME ; DW _CODE,_LINK ; DB 2,'L1' ; _CODE ; DB 80H ; SD$ 'Setup#' DW DOLIT DW _LEN,EXIT ; DB 0,'Setup#' ; _LEN ; DB _CODE-_LEN-1 ; _CODE ; ( --- a ) Packed string. 'a' is addr of count byte. $COLON 2,'L2',L2 ; _NAME ; DW _CODE,_LINK ; DB 2,'L2' ; _CODE ; DB 80H ; SD$ '* MIDI Running *' DW DOLIT DW _LEN,EXIT ; DB 0,'* MIDI Running *' _LEN ; DB _CODE-_LEN-1 ; _CODE ; ( --- a ) Packed string. 'a' is addr of count byte. $COLON 3,'L20',L20 ; _NAME ; DW _CODE,_LINK ; DB 3,'L20' ; _CODE ; DB 80H ; SD$ 'Ch ' DW DOLIT DW _LEN,EXIT ; DB 0,'Ch ' ; _LEN ;
154E 363D 154E 154E 154F 1566
154E R 3645 R 02 4C 038D R 1555 R 0394 R 00 2A 20 4D 49 10

; ; L20

L2: ORG ORG

156D 156D

1566 R 363D R 03 4C 80 038D R 156D R 0394 R 68 20

L20: ORG ORG

8/27/94 23:19:56 Page 1-85 DB _CODE _CODE-_LEN-1 ; ;

4758 4759

156D 1571

; ; L21

3629 362D 1578 157C
1571 R 3635 R 03 4C 80 038D R 1578 R 0394 R 00 4F 03

; ; L40

L21: ORG ORG
( --- a ) Packed string. 'a' is addr of count byte. $COLON 3,'L21',L21 ; _NAME ; DW _CODE,_LINK ; DB 3,'L21' ; _CODE ; DB 80H ; SD$ 'Off' DW DOLIT DW _LEN,EXIT ; DB 0,'Off' ; _LEN ; DB _CODE-_LEN-1 ; _CODE ; ( --- a ) Packed string. 'a' is addr of count byte. $COLON 3,'L40',L40 ; _NAME ; DW _CODE,_LINK ; DB 3,'L40' ; _CODE ; DB 80H ; SD$ 'Key# ' DW DOLIT DW _LEN,EXIT ; DB 0,'Key# ' _LEN ; DB _CODE-_LEN-1 ; _CODE ; ( --- a ) Packed string. 'a' is addr of count byte. $COLON 3,'L41',L41 ; _NAME ; DW _CODE,_LINK ; DB 3,'L41' ; _CODE ; DB 80H ; SD$ 'Key# A-T' DW DOLIT DW _LEN,EXIT ; DB 0,'Key# A-T' _LEN ; DB _CODE-_LEN-1 ; _CODE ; ( --- a ) Packed string. 'a' is addr of count byte.
157C 3625 157C 157C 157D 157F 1583 158C
157C R 362D R 03 4C 80 038D R 1583 R 0394 R 00 4B 20 08

; ; L41

L40: ORG ORG
158C 361D 158C 158C 158D 158F 1593 159C
158C R 3625 R 03 4C 80 038D R 1593 R 0394 R 00 4B 41 08

; ; L42

L41: ORG ORG
8/27/94 23:19:56 Page 1-86 $COLON 3,'L42',L42 ; ; ; ; ; ; ; ; ; ;