6809 assembler and simulator (examples) 2/2

[Lennart Benschop]

Archive-name: 6809/part2
Submitted-by: len...@blade.stack.urc.tue.nl

#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: README bench09.asm ef09.asm test09.asm
# Wrapped by benschop@ebe on Wed Nov 3 15:45:39 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f README -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"README\"
else
echo shar: Extracting \"README\" \(1588 characters\)
sed "s/^X//" >README <<'END_OF_README'
XAssembler and simulator for the 6809.
X
XI wrote an assembler and a simulator for the Motorola M6809 processor.
X
XThe first file of this shell archive contains C source, the second part
Xconttains example programs that can be run on the simulator.
X
XThe archive contains:
Xa09.c the 6809 assembler. It's fairly portable (ansi) C. It works on both
X Unix and DOS (TC2.0).
X
X Features of the assembler.
X - generates binary file starting at the first address
X where code is actually generated. So an initial block of RMB's
X (maybe at a different ORG) is not included in the file.
X - Accepts standard syntax.
X - full expression evaluator.
X - Statements SET, MACRO, PUBLIC, EXTERN IF/ELSE/ENDIF INCLUDE not yet
X implemented. Some provisions are already made internally for macros
X and/or relocatable objects.
X
XV09.c the 6809 simulator. Loads a binary image (from a09) at adress $100
X and starts executing. SWI2 and SWI3 are for character output/input.
X SYNC stops simulation. When compiling set -DBIG_ENDIAN if your
X computer is big-endian. Set TERM_CONTROL for a crude single character
X (instead of ANSI line-by-line) input. Works on Unix.
Xv09tc.c same for Turbo C. Has its own term control.
X
Xtest09.asm and bench09.asm simple test and benchmark progs.
X
Xef09.asm Implementation of E-Forth, a very rudimentary and portable Forth.
X Type WORDS to see what words you have. You can evaluate RPN integer
X expressions, like "12 34 + 5 * . " You can make new words like
X " : SQUARED DUP * ; " etc.
X
END_OF_README
if test 1588 -ne `wc -c <README`; then
echo shar: \"README\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f bench09.asm -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"bench09.asm\"
else
echo shar: Extracting \"bench09.asm\" \(409 characters\)
sed "s/^X//" >bench09.asm <<'END_OF_bench09.asm'
X ;6809 Benchmark program.
X
X org $100
X
X lds #$100
X
X ldb #'a'
X jsr outc
X
X
X ldy #0
Xloop ldx #data
X lda #(enddata-data)
X clrb
Xloop2: addb ,x+
X deca
X bne loop2
X cmpb #210
X lbne error
X leay -1,y
X bne loop
X
X ldb #'b'
X jsr outc
X jmp realexit
X
Xerror ldb #'e'
X jsr outc
X jmp realexit
X
Xoutc swi2
X rts
X
Xrealexit sync
X
Xdata fcb 1,2,3,4,5,6,7,8,9,10
X fcb 11,12,13,14,15,16,17,18,19,20
Xenddata
X
X end
END_OF_bench09.asm
echo shar: Missing newline added to \"bench09.asm\"
if test 409 -ne `wc -c <bench09.asm`; then
echo shar: \"bench09.asm\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f ef09.asm -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"ef09.asm\"
else
echo shar: Extracting \"ef09.asm\" \(48780 characters\)
sed "s/^X//" >ef09.asm <<'END_OF_ef09.asm'
X TITLE 6809 eForth
X
X
X;===============================================================
X;
X; eForth 1.0 by Bill Muench and C. H. Ting, 1990
X; Much of the code is derived from the following sources:
X; 8086 figForth by Thomas Newman, 1981 and Joe smith, 1983
X; aFORTH by John Rible
X; bFORTH by Bill Muench
X;
X; The goal of this implementation is to provide a simple eForth Model
X; which can be ported easily to many 8, 16, 24 and 32 bit CPU's.
X; The following attributes make it suitable for CPU's of the '90:
X;
X; small machine dependent kernel and portable high level code
X; source code in the MASM format
X; direct threaded code
X; separated code and name dictionaries
X; simple vectored terminal and file interface to host computer
X; aligned with the proposed ANS Forth Standard
X; easy upgrade path to optimize for specific CPU
X;
X; You are invited to implement this Model on your favorite CPU and
X; contribute it to the eForth Library for public use. You may use
X; a portable implementation to advertise more sophisticated and
X; optimized version for commercial purposes. However, you are
X; expected to implement the Model faithfully. The eForth Working
X; Group reserves the right to reject implementation which deviates
X; significantly from this Model.
X;
X; As the ANS Forth Standard is still evolving, this Model will
X; change accordingly. Implementations must state clearly the
X; version number of the Model being tracked.
X;
X; Representing the eForth Working Group in the Silicon Valley FIG Chapter.
X; Send contributions to:
X;
X; Dr. C. H. Ting
X; 156 14th Avenue
X; San Mateo, CA 94402
X; (415) 571-7639
X;
X;===============================================================
X
X;; Version control
X
XVER EQU 1 ;major release version
XEXT EQU 0 ;minor extension
X
X;; Constants
X
XTRUEE EQU -1 ;true flag
X
XCOMPO EQU $40 ;lexicon compile only bit
XIMEDD EQU $80 ;lexicon immediate bit
XMASKK EQU $1F7F ;lexicon bit mask
X
XCELLL EQU 2 ;size of a cell
XBASEE EQU 10 ;default radix
XVOCSS EQU 8 ;depth of vocabulary stack
X
XBKSPP EQU 127 ;back space
XLF EQU 10 ;line feed
XCRR EQU 13 ;carriage return
XERR EQU 27 ;error escape
XTIC EQU 39 ;tick
X
XCALLL EQU $12BD ;NOP CALL opcodes
X
X;; Memory allocation
X
XEM EQU $4000 ;top of memory
XUS EQU 64*CELLL ;user area size in cells
XRTS EQU 128*CELLL ;return stack/TIB size
X
XUPP EQU EM-US ;start of user area (UP0)
XRPP EQU UPP-8*CELLL ;start of return stack (RP0)
XTIBB EQU RPP-RTS ;terminal input buffer (TIB)
XSPP EQU TIBB-8*CELLL ;start of data stack (SP0)
X
XCOLDD EQU $100 ;cold start vector
XCODEE EQU COLDD+US ;code dictionary
XNAMEE EQU EM-$0400 ;name dictionary
X
X;; Initialize assembly variables
X
X
X;; Main entry points and COLD start data
X
X
X ORG COLDD ;beginning of cold boot area
X
XORIG lds #SPP ;Init stack pointer.
X ldy #RPP ;Init return stack pointer
X ldu #COLD1 ;Init Instr pointer.
X pulu pc ;next.
X
X; COLD start moves the following to USER variables.
X; MUST BE IN SAME ORDER AS USER VARIABLES.
X
X
XUZERO RMB 8 ;reserved space in user area
X FDB SPP ;SP0
X FDB RPP ;RP0
X FDB QRX ;'?KEY
X FDB TXSTO ;'EMIT
X FDB ACCEP ;'EXPECT
X FDB KTAP ;'TAP
X FDB TXSTO ;'ECHO
X FDB DOTOK ;'PROMPT
X FDB BASEE ;BASE
X FDB 0 ;tmp
X FDB 0 ;SPAN
X FDB 0 ;>IN
X FDB 0 ;#TIB
X FDB TIBB ;TIB
X FDB 0 ;CSP
X FDB INTER ;'EVAL
X FDB NUMBQ ;'NUMBER
X FDB 0 ;HLD
X FDB 0 ;HANDLER
X FDB 0 ;CONTEXT pointer
X RMB VOCSS*2 ;vocabulary stack
X FDB 0 ;CURRENT pointer
X FDB 0 ;vocabulary link pointer
X FDB CTOP ;CP
X FDB NTOP ;NP
X FDB LASTN ;LAST
XULAST:
X
X ORG CODEE ;beginning of the code dictionary
X
X;; Device dependent I/O
X
X; BYE ( -- )
X; Exit eForth.
X
X FDB BYE,0
XL100 FCB 3,"BYE"
XBYE sync
X
X; ?RX ( -- c T | F )
X; Return input character and true, or a false if no input.
X
X FDB QRX,L100
XL110 FCB 3,"?RX"
XQRX ldx #0
X swi3
X bcc qrx1
X stx ,--s
X pulu pc
Xqrx1 clra
X std ,--s
X leax -1,x
X stx ,--s
X pulu pc
X
X; TX! ( c -- )
X; Send character c to the output device.
X FDB TXSTO,L110
XL120 FCB 3,"TX!"
XTXSTO ldd ,s++
X cmpb #$ff
X bne tx1
X ldb #32
Xtx1 swi2
X pulu pc
X
X
X; !IO ( -- )
X; Initialize the serial I/O devices.
X
X FDB STOIO,L120
XL130 FCB 3,"!IO"
XSTOIO pulu pc
X
X;; The kernel
X
X; doLIT ( -- w )
X; Push an inline literal.
X
X FDB DOLIT,L130
XL140 FCB COMPO+5,"doLIT"
XDOLIT ldd ,u++
X std ,--s
X pulu pc
X
X; doLIST ( a -- )
X; Process colon list.
X
X FDB DOLST,L140
XL150 FCB COMPO+6,"doLIST"
XDOLST stu ,--y
X ldu ,s++
X pulu pc
X
X; next ( -- )
X; Run time code for the single index loop.
X; : next ( -- ) \ hilevel model
X; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;
X
X FDB DONXT,L150
XL160 FCB COMPO+4,"next"
XDONXT ldd ,y
X subd #1
X bcs next1
X std ,y
X ldu ,u
X pulu pc
Xnext1 leay 2,y
X leau 2,u
X pulu pc
X
X
X; ?branch ( f -- )
X; Branch if flag is zero.
X
X FDB QBRAN,L160
XL170 FCB COMPO+7,"?branch"
XQBRAN $CODE COMPO+7,'?branch',QBRAN
X ldd ,s++
X beq bran1
X leau 2,u
X pulu pc
Xbran1 ldu ,u
X pulu pc
X
X; branch ( -- )
X; Branch to an inline address.
X
X FDB BRAN,L170
XL180 FCB COMPO+6,"branch"
XBRAN ldu ,u
X pulu pc
X
X; EXECUTE ( ca -- )
X; Execute the word at ca.
X
X FDB EXECU,L180
XL190 FCB 7,"EXECUTE"
XEXECU rts
X
X; EXIT ( -- )
X; Terminate a colon definition.
X
X FDB EXIT,L190
XL200 FCB 4,"EXIT"
XEXIT ldu ,y++
X pulu pc
X
X; ! ( w a -- )
X; Pop the data stack to memory.
X
X FDB STORE,L200
XL210 FCB 1,"!"
XSTORE ldx ,s++
X ldd ,s++
X std ,x
X pulu pc
X
X; @ ( a -- w )
X; Push memory location to the data stack.
X
X FDB AT,L210
XL220 FCB 1,"@"
XAT ldd [,s]
X std ,s
X pulu pc
X
X; C! ( c b -- )
X; Pop the data stack to byte memory.
X
X FDB CSTOR,L220
XL230 FCB 2,"C!"
XCSTOR ldx ,s++
X ldd ,s++
X stb ,x
X pulu pc
X
X
X; C@ ( b -- c )
X; Push byte memory location to the data stack.
X
X FDB CAT,L230
XL240 FCB 2,"C@"
XCAT ldb [,s]
X clra
X std ,s
X pulu pc
X
X; RP@ ( -- a )
X; Push the current RP to the data stack.
X
X FDB RPAT,L240
XL250 FCB 3,"RP@"
XRPAT pshs y
X pulu pc
X
X; RP! ( a -- )
X; Set the return stack pointer.
X
X FDB RPSTO,L250
XL260 FCB 3,"RP!"
XRPSTO puls y
X pulu pc
X
X; R> ( -- w )
X; Pop the return stack to the data stack.
X
X FDB RFROM,L260
XL270 FCB 2,"R>"
XRFROM ldd ,y++
X std ,--s
X pulu pc
X
X; R@ ( -- w )
X; Copy top of return stack to the data stack.
X
X FDB RAT,L270
XL280 FCB 2,"R@"
XRAT ldd ,y
X std ,--s
X pulu pc
X
X; >R ( w -- )
X; Push the data stack to the return stack.
X
X FDB TOR,L280
XL290 FCB 2,">R"
XTOR ldd ,s++
X std ,--y
X pulu pc
X
X; SP@ ( -- a )
X; Push the current data stack pointer.
X
X FDB SPAT,L290
XL300 FCB 3,"SP@"
XSPAT tfr s,d ; sts ,--s would also do?
X std ,--s
X pulu pc
X
X; SP! ( a -- )
X; Set the data stack pointer.
X
X FDB SPSTO,L300
XL310 FCB 3,"SP!"
XSPSTO lds ,s
X pulu pc
X
X; DROP ( w -- )
X; Discard top stack item.
X
X FDB DROP,L310
XL320 FCB 4,"DROP"
XDROP leas 2,s
X pulu pc
X
X; DUP ( w -- w w )
X; Duplicate the top stack item.
X
X FDB DUPP,L320
XL330 FCB 3,"DUP"
XDUPP ldd ,s
X std ,--s
X pulu pc
X
X; SWAP ( w1 w2 -- w2 w1 )
X; Exchange top two stack items.
X
X FDB SWAP,L330
XL340 FCB 4,"SWAP"
XSWAP ldx ,s++
X ldd ,s++
X pshs d,x
X pulu pc
X
X; OVER ( w1 w2 -- w1 w2 w1 )
X; Copy second stack item to top.
X
X FDB OVER,L340
XL350 FCB 4,"OVER"
XOVER ldd 2,s
X std ,--s
X pulu pc
X
X; 0< ( n -- t )
X; Return true if n is negative.
X
X FDB ZLESS,L350
XL360 FCB 2,"0<"
XZLESS ldb ,s
X sex
X tfr a,b
X std ,s
X pulu pc
X
X; AND ( w w -- w )
X; Bitwise AND.
X
X FDB ANDD,L360
XL370 FCB 3,"AND"
XANDD ldd ,s++
X anda ,s
X andb 1,s
X std ,s
X pulu pc
X
X; OR ( w w -- w )
X; Bitwise inclusive OR.
X
X FDB ORR,L370
XL380 FCB 2,"OR"
XORR ldd ,s++
X ora ,s
X orb 1,s
X std ,s
X pulu pc
X
X; XOR ( w w -- w )
X; Bitwise exclusive OR.
X
X FDB XORR,L380
XL390 FCB 3,"XOR"
XXORR ldd ,s++
X eora ,s
X eorb 1,s
X std ,s
X pulu pc
X
X; UM+ ( u u -- udsum )
X; Add two unsigned single numbers and return a double sum.
X
X FDB UPLUS,L390
XL400 FCB 3,"UM+"
XUPLUS ldd ,s
X addd 2,s
X std 2,s
X ldd #0
X adcb #0
X std ,s
X pulu pc
X
X;; System and user variables
X
X; doVAR ( -- a )
X; Run time routine for VARIABLE and CREATE.
X
X FDB DOVAR,L400
XL410 FCB COMPO+5,"doVAR"
XDOVAR
X jsr DOLST
X FDB RFROM,EXIT
X
X; UP ( -- a )
X; Pointer to the user area.
X
X FDB UP,L410
XL420 FCB 2,"UP"
XUP
X jsr DOLST
X FDB DOVAR
X FDB UPP
X
X; doUSER ( -- a )
X; Run time routine for user variables.
X
X FDB DOUSE,L420
XL430 FCB COMPO+5,"doUSER"
XDOUSE
X jsr DOLST
X FDB RFROM,AT,UP,AT,PLUS,EXIT
X
X; SP0 ( -- a )
X; Pointer to bottom of the data stack.
X
X FDB SZERO,L430
XL440 FCB 3,"SP0"
XSZERO
X jsr DOLST
X FDB DOUSE,8
X
X; RP0 ( -- a )
X; Pointer to bottom of the return stack.
X
X FDB RZERO,L440
XL450 FCB 3,"RP0"
XRZERO
X jsr DOLST
X FDB DOUSE,10
X
X; '?KEY ( -- a )
X; Execution vector of ?KEY.
X
X FDB TQKEY,L450
XL460 FCB 5,"'?KEY"
XTQKEY
X jsr DOLST
X FDB DOUSE,12
X
X; 'EMIT ( -- a )
X; Execution vector of EMIT.
X
X FDB TEMIT,L460
XL470 FCB 5,"'EMIT"
XTEMIT
X jsr DOLST
X FDB DOUSE,14
X
X; 'EXPECT ( -- a )
X; Execution vector of EXPECT.
X
X FDB TEXPE,L470
XL480 FCB 7,"'EXPECT"
XTEXPE
X jsr DOLST
X FDB DOUSE,16
X
X; 'TAP ( -- a )
X; Execution vector of TAP.
X
X FDB TTAP,L480
XL490 FCB 4,"'TAP"
XTTAP
X jsr DOLST
X FDB DOUSE,18
X
X; 'ECHO ( -- a )
X; Execution vector of ECHO.
X
X FDB TECHO,L490
XL500 FCB 5,"'ECHO"
XTECHO
X jsr DOLST
X FDB DOUSE,20
X
X; 'PROMPT ( -- a )
X; Execution vector of PROMPT.
X
X FDB TPROM,L500
XL510 FCB 7,"'PROMPT"
XTPROM
X jsr DOLST
X FDB DOUSE,22
X
X
X; BASE ( -- a )
X; Storage of the radix base for numeric I/O.
X
X FDB BASE,L510
XL520 FCB 4,"BASE"
XBASE
X jsr DOLST
X FDB DOUSE,24
X
X; tmp ( -- a )
X; A temporary storage location used in parse and find.
X
X FDB TEMP,L520
XL530 FCB COMPO+3,"tmp"
XTEMP
X jsr DOLST
X FDB DOUSE,26
X
X; SPAN ( -- a )
X; Hold character count received by EXPECT.
X
X FDB SPAN,L530
XL540 FCB 4,"SPAN"
XSPAN
X jsr DOLST
X FDB DOUSE,28
X
X; >IN ( -- a )
X; Hold the character pointer while parsing input stream.
X
X FDB INN,L540
XL550 FCB 3,">IN"
XINN
X jsr DOLST
X FDB DOUSE,30
X
X; #TIB ( -- a )
X; Hold the current count in and address of the terminal input buffer.
X
X FDB NTIB,L550
XL560 FCB 4,"#TIB"
XNTIB
X jsr DOLST
X FDB DOUSE,32 ;It contains TWO cells!!!!
X
X; CSP ( -- a )
X; Hold the stack pointer for error checking.
X
X FDB CSP,L560
XL570 FCB 3,"CSP"
XCSP
X jsr DOLST
X FDB DOUSE 36
X
X; 'EVAL ( -- a )
X; Execution vector of EVAL.
X
X FDB TEVAL,L570
XL580 FCB 5,"'EVAL"
XTEVAL
X jsr DOLST
X FDB DOUSE,38
X
X; 'NUMBER ( -- a )
X; Execution vector of NUMBER?.
X
X FDB TNUMB,L580
XL590 FCB 7,"'NUMBER"
XTNUMB
X jsr DOLST
X FDB DOUSE,40
X
X; HLD ( -- a )
X; Hold a pointer in building a numeric output string.
X
X FDB HLD,L590
XL600 FCB 3,"HLD"
XHLD
X jsr DOLST
X FDB DOUSE,42
X
X; HANDLER ( -- a )
X; Hold the return stack pointer for error handling.
X
X FDB HANDL,L600
XL610 FCB 7,"HANDLER"
XHANDL
X jsr DOLST
X FDB DOUSE,44
X
X; CONTEXT ( -- a )
X; A area to specify vocabulary search order.
X
X FDB CNTXT,L610
XL620 FCB 7,"CONTEXT"
XCNTXT
X jsr DOLST
X FDB DOUSE,46 ;plus space for voc stack.
X
X; CURRENT ( -- a )
X; Point to the vocabulary to be extended.
X
X FDB CRRNT,L620
XL630 FCB 7,"CURRENT"
XCRRNT
X jsr DOLST
X FDB DOUSE,48+VOCSS*2 ;Extra cell
X
X; CP ( -- a )
X; Point to the top of the code dictionary.
X
X FDB CP,L630
XL640 FCB 2,"CP"
XCP
X jsr DOLST
X FDB DOUSE,52+VOCSS*2
X
X; NP ( -- a )
X; Point to the bottom of the name dictionary.
X
X FDB NP,L640
XL650 FCB 2,"NP"
XNP
X jsr DOLST
X FDB DOUSE,54+VOCSS*2
X
X; LAST ( -- a )
X; Point to the last name in the name dictionary.
X
X FDB LAST,L650
XL660 FCB 4,"LAST"
XLAST
X jsr DOLST
X FDB DOUSE,56+VOCSS*2
X
X;; Common functions
X
X; doVOC ( -- )
X; Run time action of VOCABULARY's.
X
X FDB DOVOC,L660
XL670 FCB COMPO+5,"doVOC"
XDOVOC
X jsr DOLST
X FDB RFROM,CNTXT,STORE,EXIT
X
X; FORTH ( -- )
X; Make FORTH the context vocabulary.
X
X FDB FORTH,L670
XL680 FCB 5,"FORTH"
XFORTH
X jsr DOLST
X FDB DOVOC
X FDB 0 ;vocabulary head pointer
X FDB 0 ;vocabulary link pointer
X
X; ?DUP ( w -- w w | 0 )
X; Dup tos if its is not zero.
X
X FDB QDUP,L680
XL690 FCB 4,"?DUP"
XQDUP
X jsr DOLST
X FDB DUPP
X FDB QBRAN,QDUP1
X FDB DUPP
XQDUP1: FDB EXIT
X
X; ROT ( w1 w2 w3 -- w2 w3 w1 )
X; Rot 3rd item to top.
X
X FDB ROT,L690
XL700 FCB 3,"ROT"
XROT
X jsr DOLST
X FDB TOR,SWAP,RFROM,SWAP,EXIT
X
X; 2DROP ( w w -- )
X; Discard two items on stack.
X
X FDB DDROP,L700
XL710 FCB 5,"2DROP"
XDDROP
X jsr DOLST
X FDB DROP,DROP,EXIT
X
X; 2DUP ( w1 w2 -- w1 w2 w1 w2 )
X; Duplicate top two items.
X
X FDB DDUP,L710
XL720 FCB 4,"2DUP"
XDDUP
X jsr DOLST
X FDB OVER,OVER,EXIT
X
X; + ( w w -- sum )
X; Add top two items.
X
X FDB PLUS,L720
XL730 FCB 1,"+"
XPLUS
X jsr DOLST
X FDB UPLUS,DROP,EXIT
X
X; NOT ( w -- w )
X; One's complement of tos.
X
X FDB INVER,L730
XL740 FCB 3,"NOT"
XINVER jsr DOLST
X FDB DOLIT,-1,XORR,EXIT
X
X; NEGATE ( n -- -n )
X; Two's complement of tos.
X
X FDB NEGAT,L740
XL750 FCB 6,"NEGATE"
XNEGAT jsr DOLST
X FDB INVER,DOLIT,1,PLUS,EXIT
X
X; DNEGATE ( d -- -d )
X; Two's complement of top double.
X
X FDB DNEGA,L750
XL760 FCB 7,"DNEGATE"
XDNEGA jsr DOLST
X FDB INVER,TOR,INVER
X FDB DOLIT,1,UPLUS
X FDB RFROM,PLUS,EXIT
X
X; - ( n1 n2 -- n1-n2 )
X; Subtraction.
X
X FDB SUBB,L760
XL770 FCB 1,"-"
XSUBB jsr DOLST
X FDB NEGAT,PLUS,EXIT
X
X; ABS ( n -- n )
X; Return the absolute value of n.
X
X FDB ABSS,L770
XL780 FCB 3,"ABS"
XABSS jsr DOLST
X FDB DUPP,ZLESS
X FDB QBRAN,ABS1
X FDB NEGAT
XABS1: FDB EXIT
X
X; = ( w w -- t )
X; Return true if top two are equal.
X
X FDB EQUAL,L780
XL790 FCB 1,"="
XEQUAL jsr DOLST
X FDB XORR
X FDB QBRAN,EQU1
X FDB DOLIT,0,EXIT
XEQU1: FDB DOLIT,TRUEE,EXIT
X
X; U< ( u u -- t )
X; Unsigned compare of top two items.
X
X FDB ULESS,L790
XL800 FCB 2,"U<"
XULESS jsr DOLST
X FDB DDUP,XORR,ZLESS
X FDB QBRAN,ULES1
X FDB SWAP,DROP,ZLESS,EXIT
XULES1: FDB SUBB,ZLESS,EXIT
X
X; < ( n1 n2 -- t )
X; Signed compare of top two items.
X
X FDB LESS,L800
XL810 FCB 1,"<"
XLESS jsr DOLST
X FDB DDUP,XORR,ZLESS
X FDB QBRAN,LESS1
X FDB DROP,ZLESS,EXIT
XLESS1: FDB SUBB,ZLESS,EXIT
X
X; MAX ( n n -- n )
X; Return the greater of two top stack items.
X
X FDB MAX,L810
XL820 FCB 3,"MAX"
XMAX jsr DOLST
X FDB DDUP,LESS
X FDB QBRAN,MAX1
X FDB SWAP
XMAX1: FDB DROP,EXIT
X
X; MIN ( n n -- n )
X; Return the smaller of top two stack items.
X
X FDB MIN,L820
XL830 FCB 3,"MIN"
XMIN jsr DOLST
X FDB DDUP,SWAP,LESS
X FDB QBRAN,MIN1
X FDB SWAP
XMIN1: FDB DROP,EXIT
X
X; WITHIN ( u ul uh -- t )
X; Return true if u is within the range of ul and uh. ( ul <= u < uh )
X
X FDB WITHI,L830
XL840 FCB 6,"WITHIN"
XWITHI jsr DOLST
X FDB OVER,SUBB,TOR
X FDB SUBB,RFROM,ULESS,EXIT
X
X;; Divide
X
X; UM/MOD ( udl udh un -- ur uq )
X; Unsigned divide of a double by a single. Return mod and quotient.
X
X FDB UMMOD,L840
XL850 FCB 6,"UM/MOD"
XUMMOD jsr DOLST
X FDB DDUP,ULESS
X FDB QBRAN,UMM4
X FDB NEGAT,DOLIT,15,TOR
XUMM1: FDB TOR,DUPP,UPLUS
X FDB TOR,TOR,DUPP,UPLUS
X FDB RFROM,PLUS,DUPP
X FDB RFROM,RAT,SWAP,TOR
X FDB UPLUS,RFROM,ORR
X FDB QBRAN,UMM2
X FDB TOR,DROP,DOLIT,1,PLUS,RFROM
X FDB BRAN,UMM3
XUMM2: FDB DROP
XUMM3: FDB RFROM
X FDB DONXT,UMM1
X FDB DROP,SWAP,EXIT
XUMM4: FDB DROP,DDROP
X FDB DOLIT,-1,DUPP,EXIT
X
X; M/MOD ( d n -- r q )
X; Signed floored divide of double by single. Return mod and quotient.
X
X FDB MSMOD,L850
XL860 FCB 5,"M/MOD"
XMSMOD jsr DOLST
X FDB DUPP,ZLESS,DUPP,TOR
X FDB QBRAN,MMOD1
X FDB NEGAT,TOR,DNEGA,RFROM
XMMOD1: FDB TOR,DUPP,ZLESS
X FDB QBRAN,MMOD2
X FDB RAT,PLUS
XMMOD2: FDB RFROM,UMMOD,RFROM
X FDB QBRAN,MMOD3
X FDB SWAP,NEGAT,SWAP
XMMOD3: FDB EXIT
X
X; /MOD ( n n -- r q )
X; Signed divide. Return mod and quotient.
X
X FDB SLMOD,L860
XL870 FCB 4,"/MOD"
XSLMOD jsr DOLST
X FDB OVER,ZLESS,SWAP,MSMOD,EXIT
X
X; MOD ( n n -- r )
X; Signed divide. Return mod only.
X
X FDB MODD,L870
XL880 FCB 3,"MOD"
XMODD jsr DOLST
X FDB SLMOD,DROP,EXIT
X
X; / ( n n -- q )
X; Signed divide. Return quotient only.
X
X FDB SLASH,L880
XL890 FCB 1,"/"
XSLASH jsr DOLST
X FDB SLMOD,SWAP,DROP,EXIT
X
X;; Multiply
X
X; UM* ( u u -- ud )
X; Unsigned multiply. Return double product.
X
X FDB UMSTA,L890
XL900 FCB 3,"UM*"
XUMSTA jsr DOLST
X FDB DOLIT,0,SWAP,DOLIT,15,TOR
XUMST1: FDB DUPP,UPLUS,TOR,TOR
X FDB DUPP,UPLUS,RFROM,PLUS,RFROM
X FDB QBRAN,UMST2
X FDB TOR,OVER,UPLUS,RFROM,PLUS
XUMST2: FDB DONXT,UMST1
X FDB ROT,DROP,EXIT
X
X; * ( n n -- n )
X; Signed multiply. Return single product.
X
X FDB STAR,L900
XL910 FCB 1,"*"
XSTAR jsr DOLST
X FDB UMSTA,DROP,EXIT
X
X; M* ( n n -- d )
X; Signed multiply. Return double product.
X
X FDB MSTAR,L910
XL920 FCB 2,"M*"
XMSTAR jsr DOLST
X FDB DDUP,XORR,ZLESS,TOR
X FDB ABSS,SWAP,ABSS,UMSTA
X FDB RFROM
X FDB QBRAN,MSTA1
X FDB DNEGA
XMSTA1: FDB EXIT
X
X; */MOD ( n1 n2 n3 -- r q )
X; Multiply n1 and n2, then divide by n3. Return mod and quotient.
X
X FDB SSMOD,L920
XL930 FCB 5,"*/MOD"
XSSMOD jsr DOLST
X FDB TOR,MSTAR,RFROM,MSMOD,EXIT
X
X; */ ( n1 n2 n3 -- q )
X; Multiply n1 by n2, then divide by n3. Return quotient only.
X
X FDB STASL,L930
XL940 FCB 2,"*/"
XSTASL jsr DOLST
X FDB SSMOD,SWAP,DROP,EXIT
X
X;; Miscellaneous
X
X; CELL+ ( a -- a )
X; Add cell size in byte to address.
X
X FDB CELLP,L940
XL950 FCB 5,"CELL+"
XCELLP jsr DOLST
X FDB DOLIT,CELLL,PLUS,EXIT
X
X; CELL- ( a -- a )
X; Subtract cell size in byte from address.
X
X FDB CELLM,L950
XL960 FCB 5,"CELL-"
XCELLM jsr DOLST
X FDB DOLIT,0-CELLL,PLUS,EXIT
X
X; CELLS ( n -- n )
X; Multiply tos by cell size in bytes.
X
X FDB CELLS,L960
XL970 FCB 5,"CELLS"
XCELLS jsr DOLST
X FDB DOLIT,CELLL,STAR,EXIT
X
X; ALIGNED ( b -- a )
X; Align address to the cell boundary.
X
X FDB ALGND,L970
XL975 FCB 7,"ALIGNED"
XALGND jsr DOLST
X FDB EXIT
X
X; BL ( -- 32 )
X; Return 32, the blank character.
X
X FDB BLANK,L975
XL980 FCB 2,"BL"
XBLANK jsr DOLST
X FDB DOLIT,' ',EXIT
X
X; >CHAR ( c -- c )
X; Filter non-printing characters.
X
X FDB TCHAR,L980
XL990 FCB 5,">CHAR"
XTCHAR jsr DOLST
X FDB DOLIT,$7F,ANDD,DUPP ;mask msb
X FDB DOLIT,127,BLANK,WITHI ;check for printable
X FDB QBRAN,TCHA1
X FDB DROP,DOLIT,'_' ;replace non-printables
XTCHA1: FDB EXIT
X
X; DEPTH ( -- n )
X; Return the depth of the data stack.
X
X FDB DEPTH,L990
XL1000 FCB 5,"DEPTH"
XDEPTH jsr DOLST
X FDB SPAT,SZERO,AT,SWAP,SUBB
X FDB DOLIT,CELLL,SLASH,EXIT
X
X; PICK ( ... +n -- ... w )
X; Copy the nth stack item to tos.
X
X FDB PICK,L1000
XL1010 FCB 4,"PICK"
XPICK jsr DOLST
X FDB DOLIT,1,PLUS,CELLS
X FDB SPAT,PLUS,AT,EXIT
X
X;; Memory access
X
X; +! ( n a -- )
X; Add n to the contents at address a.
X
X FDB PSTOR,L1010
XL1020 FCB 2,"+!"
XPSTOR jsr DOLST
X FDB SWAP,OVER,AT,PLUS
X FDB SWAP,STORE,EXIT
X
X; 2! ( d a -- )
X; Store the double integer to address a.
X
X FDB DSTOR,L1020
XL1030 FCB 2,"2!"
XDSTOR jsr DOLST
X FDB SWAP,OVER,STORE
X FDB CELLP,STORE,EXIT
X
X; 2@ ( a -- d )
X; Fetch double integer from address a.
X
X FDB DAT,L1030
XL1040 FCB 2,"2@"
XDAT jsr DOLST
X FDB DUPP,CELLP,AT
X FDB SWAP,AT,EXIT
X
X; COUNT ( b -- b +n )
X; Return count byte of a string and add 1 to byte address.
X
X FDB COUNT,L1040
XL1050 FCB 5,"COUNT"
XCOUNT jsr DOLST
X FDB DUPP,DOLIT,1,PLUS
X FDB SWAP,CAT,EXIT
X
X; HERE ( -- a )
X; Return the top of the code dictionary.
X
X FDB HERE,L1050
XL1060 FCB 4,"HERE"
XHERE jsr DOLST
X FDB CP,AT,EXIT
X
X; PAD ( -- a )
X; Return the address of the text buffer above the code dictionary.
X
X FDB PAD,L1060
XL1070 FCB 3,"PAD"
XPAD jsr DOLST
X FDB HERE,DOLIT,80,PLUS,EXIT
X
X; TIB ( -- a )
X; Return the address of the terminal input buffer.
X
X FDB TIB,L1070
XL1080 FCB 3,"TIB"
XTIB jsr DOLST
X FDB NTIB,CELLP,AT,EXIT
X
X; @EXECUTE ( a -- )
X; Execute vector stored in address a.
X
X FDB ATEXE,L1080
XL1090 FCB 8,"@EXECUTE"
XATEXE jsr DOLST
X FDB AT,QDUP ;?address or zero
X FDB QBRAN,EXE1
X FDB EXECU ;execute if non-zero
XEXE1: FDB EXIT ;do nothing if zero
X
X; CMOVE ( b1 b2 u -- )
X; Copy u bytes from b1 to b2.
X
X FDB CMOVE,L1090
XL1100 FCB 5,"CMOVE"
XCMOVE jsr DOLST
X FDB TOR
X FDB BRAN,CMOV2
XCMOV1: FDB TOR,DUPP,CAT
X FDB RAT,CSTOR
X FDB DOLIT,1,PLUS
X FDB RFROM,DOLIT,1,PLUS
XCMOV2: FDB DONXT,CMOV1
X FDB DDROP,EXIT
X
X; FILL ( b u c -- )
X; Fill u bytes of character c to area beginning at b.
X
X FDB FILL,L1100
XL1110 FCB 4,"FILL"
XFILL jsr DOLST
X FDB SWAP,TOR,SWAP
X FDB BRAN,FILL2
XFILL1: FDB DDUP,CSTOR,DOLIT,1,PLUS
XFILL2: FDB DONXT,FILL1
X FDB DDROP,EXIT
X
X; -TRAILING ( b u -- b u )
X; Adjust the count to eliminate trailing white space.
X
X FDB DTRAI,L1110
XL1120 FCB 9,"-TRAILING"
XDTRAI jsr DOLST
X FDB TOR
X FDB BRAN,DTRA2
XDTRA1: FDB BLANK,OVER,RAT,PLUS,CAT,LESS
X FDB QBRAN,DTRA2
X FDB RFROM,DOLIT,1,PLUS,EXIT
XDTRA2: FDB DONXT,DTRA1
X FDB DOLIT,0,EXIT
X
X; PACK$ ( b u a -- a )
X; Build a counted string with u characters from b. Null fill.
X
X FDB PACKS,L1120
XL1130 FCB 5,"PACK$"
XPACKS jsr DOLST
X FDB DUPP,TOR ;strings only on cell boundary
X FDB DDUP,CSTOR
X FDB DOLIT,1,PLUS ;count mod cell
X FDB DDUP,PLUS
X FDB DOLIT,0,SWAP,CSTOR ;null fill cell
X FDB SWAP,CMOVE,RFROM,EXIT ;move string
X
X;; Numeric output, single precision
X
X; DIGIT ( u -- c )
X; Convert digit u to a character.
X
X FDB DIGIT,L1130
XL1140 FCB 5,"DIGIT"
XDIGIT jsr DOLST
X FDB DOLIT,9,OVER,LESS
X FDB DOLIT,7,ANDD,PLUS
X FDB DOLIT,'0',PLUS,EXIT
X
X; EXTRACT ( n base -- n c )
X; Extract the least significant digit from n.
X
X FDB EXTRC,L1140
XL1150 FCB 7,"EXTRACT"
XEXTRC jsr DOLST
X FDB DOLIT,0,SWAP,UMMOD
X FDB SWAP,DIGIT,EXIT
X
X; <# ( -- )
X; Initiate the numeric output process.
X
X FDB BDIGS,L1150
XL1160 FCB 2,"<#"
XBDIGS jsr DOLST
X FDB PAD,HLD,STORE,EXIT
X
X; HOLD ( c -- )
X; Insert a character into the numeric output string.
X
X
X FDB HOLD,L1160
XL1170 FCB 4,"HOLD"
XHOLD jsr DOLST
X FDB HLD,AT,DOLIT,1,SUBB
X FDB DUPP,HLD,STORE,CSTOR,EXIT
X
X; # ( u -- u )
X; Extract one digit from u and append the digit to output string.
X
X FDB DIG,L1170
XL1180 FCB 1,"#"
XDIG jsr DOLST
X FDB BASE,AT,EXTRC,HOLD,EXIT
X
X; #S ( u -- 0 )
X; Convert u until all digits are added to the output string.
X
X FDB DIGS,L1180
XL1190 FCB 2,"#S"
XDIGS jsr DOLST
XDIGS1: FDB DIG,DUPP
X FDB QBRAN,DIGS2
X FDB BRAN,DIGS1
XDIGS2: FDB EXIT
X
X; SIGN ( n -- )
X; Add a minus sign to the numeric output string.
X
X FDB SIGN,L1190
XL1200 FCB 4,"SIGN"
XSIGN jsr DOLST
X FDB ZLESS
X FDB QBRAN,SIGN1
X FDB DOLIT,'-',HOLD
XSIGN1: FDB EXIT
X
X; #> ( w -- b u )
X; Prepare the output string to be TYPE'd.
X
X FDB EDIGS,L1200
XL1210 FCB 2,"#>"
XEDIGS jsr DOLST
X FDB DROP,HLD,AT
X FDB PAD,OVER,SUBB,EXIT
X
X; str ( w -- b u )
X; Convert a signed integer to a numeric string.
X
X FDB STR,L1210
XL1220 FCB 3,"str"
XSTR jsr DOLST
X FDB DUPP,TOR,ABSS
X FDB BDIGS,DIGS,RFROM
X FDB SIGN,EDIGS,EXIT
X
X; HEX ( -- )
X; Use radix 16 as base for numeric conversions.
X
X FDB HEX,L1220
XL1230 FCB 3,"HEX"
XHEX jsr DOLST
X FDB DOLIT,16,BASE,STORE,EXIT
X
X; DECIMAL ( -- )
X; Use radix 10 as base for numeric conversions.
X
X FDB DECIM,L1230
XL1240 FCB 7,"DECIMAL"
XDECIM jsr DOLST
X FDB DOLIT,10,BASE,STORE,EXIT
X
X;; Numeric input, single precision
X
X; DIGIT? ( c base -- u t )
X; Convert a character to its numeric value. A flag indicates success.
X
X FDB DIGTQ,L1240
XL1250 FCB 6,"DIGIT?"
XDIGTQ jsr DOLST
X FDB TOR,DOLIT,'0',SUBB
X FDB DOLIT,9,OVER,LESS
X FDB QBRAN,DGTQ1
X FDB DOLIT,7,SUBB
X FDB DUPP,DOLIT,10,LESS,ORR
XDGTQ1: FDB DUPP,RFROM,ULESS,EXIT
X
X; NUMBER? ( a -- n T | a F )
X; Convert a number string to integer. Push a flag on tos.
X
X FDB NUMBQ,L1250
XL1260 FCB 7,"NUMBER?"
XNUMBQ jsr DOLST
X FDB BASE,AT,TOR,DOLIT,0,OVER,COUNT
X FDB OVER,CAT,DOLIT,'$',EQUAL
X FDB QBRAN,NUMQ1
X FDB HEX,SWAP,DOLIT,1,PLUS
X FDB SWAP,DOLIT,1,SUBB
XNUMQ1: FDB OVER,CAT,DOLIT,'-',EQUAL,TOR
X FDB SWAP,RAT,SUBB,SWAP,RAT,PLUS,QDUP
X FDB QBRAN,NUMQ6
X FDB DOLIT,1,SUBB,TOR
XNUMQ2: FDB DUPP,TOR,CAT,BASE,AT,DIGTQ
X FDB QBRAN,NUMQ4
X FDB SWAP,BASE,AT,STAR,PLUS,RFROM
X FDB DOLIT,1,PLUS
X FDB DONXT,NUMQ2
X FDB RAT,SWAP,DROP
X FDB QBRAN,NUMQ3
X FDB NEGAT
XNUMQ3: FDB SWAP
X FDB BRAN,NUMQ5
XNUMQ4: FDB RFROM,RFROM,DDROP,DDROP,DOLIT,0
XNUMQ5: FDB DUPP
XNUMQ6: FDB RFROM,DDROP
X FDB RFROM,BASE,STORE,EXIT
X
X;; Basic I/O
X
X; ?KEY ( -- c T | F )
X; Return input character and true, or a false if no input.
X
X
X FDB QKEY,L1260
XL1270 FCB 4,"?KEY"
XQKEY jsr DOLST
X FDB TQKEY,ATEXE,EXIT
X
X; KEY ( -- c )
X; Wait for and return an input character.
X
X FDB KEY,L1270
XL1280 FCB 3,"KEY"
XKEY jsr DOLST
XKEY1: FDB QKEY
X FDB QBRAN,KEY1
X FDB EXIT
X
X; EMIT ( c -- )
X; Send a character to the output device.
X
X FDB EMIT,L1280
XL1290 FCB 4,"EMIT"
XEMIT jsr DOLST
X FDB TEMIT,ATEXE,EXIT
X
X; NUF? ( -- t )
X; Return false if no input, else pause and if CR return true.
X
X FDB NUFQ,L1290
XL1300 FCB 4,"NUF?"
XNUFQ jsr DOLST
X FDB QKEY,DUPP
X FDB QBRAN,NUFQ1
X FDB DDROP,KEY,DOLIT,CRR,EQUAL
XNUFQ1: FDB EXIT
X
X; PACE ( -- )
X; Send a pace character for the file downloading process.
X
X FDB PACE,L1300
XL1310 FCB 4,"PACE"
XPACE jsr DOLST
X FDB DOLIT,11,EMIT,EXIT
X
X; SPACE ( -- )
X; Send the blank character to the output device.
X
X FDB SPACE,L1310
XL1320 FCB 5,"SPACE"
XSPACE jsr DOLST
X FDB BLANK,EMIT,EXIT
X
X; SPACES ( +n -- )
X; Send n spaces to the output device.
X
X FDB SPACS,L1320
XL1330 FCB 6,"SPACES"
XSPACS jsr DOLST
X FDB DOLIT,0,MAX,TOR
X FDB BRAN,CHAR2
XCHAR1: FDB SPACE
XCHAR2: FDB DONXT,CHAR1
X FDB EXIT
X
X; TYPE ( b u -- )
X; Output u characters from b.
X
X FDB TYPES,L1330
XL1340 FCB 4,"TYPE"
XTYPES jsr DOLST
X FDB TOR
X FDB BRAN,TYPE2
XTYPE1: FDB DUPP,CAT,EMIT
X FDB DOLIT,1,PLUS
XTYPE2: FDB DONXT,TYPE1
X FDB DROP,EXIT
X
X; CR ( -- )
X; Output a carriage return and a line feed.
X
X FDB CR,L1340
XL1350 FCB 2,"CR"
XCR jsr DOLST
X FDB DOLIT,CRR,EMIT
X FDB DOLIT,LF,EMIT,EXIT
X
X; do$ ( -- a )
X; Return the address of a compiled string.
X
X FDB DOSTR,L1350
XL1360 FCB COMPO+3,"do$"
XDOSTR jsr DOLST
X FDB RFROM,RAT,RFROM,COUNT,PLUS
X FDB ALGND,TOR,SWAP,TOR,EXIT
X
X; $"| ( -- a )
X; Run time routine compiled by $". Return address of a compiled string.
X
X FDB STRQP,L1360
XL1370 FCB COMPO+3,'$','"','|'
XSTRQP jsr DOLST
X FDB DOSTR,EXIT ;force a call to do$
X
X; ."| ( -- )
X; Run time routine of ." . Output a compiled string.
X
X FDB DOTQP,L1370
XL1380 FCB COMPO+3,'.','"','|'
XDOTQP jsr DOLST
X FDB DOSTR,COUNT,TYPES,EXIT
X
X; .R ( n +n -- )
X; Display an integer in a field of n columns, right justified.
X
X FDB DOTR,L1380
XL1390 FCB 2,".R"
XDOTR jsr DOLST
X FDB TOR,STR,RFROM,OVER,SUBB
X FDB SPACS,TYPES,EXIT
X
X; U.R ( u +n -- )
X; Display an unsigned integer in n column, right justified.
X
X FDB UDOTR,L1390
XL1400 FCB 3,"U.R"
XUDOTR jsr DOLST
X FDB TOR,BDIGS,DIGS,EDIGS
X FDB RFROM,OVER,SUBB
X FDB SPACS,TYPES,EXIT
X
X; U. ( u -- )
X; Display an unsigned integer in free format.
X
X FDB UDOT,L1400
XL1410 FCB 2,"U."
XUDOT jsr DOLST
X FDB BDIGS,DIGS,EDIGS
X FDB SPACE,TYPES,EXIT
X
X; . ( w -- )
X; Display an integer in free format, preceeded by a space.
X
X FDB DOT,L1410
XL1420 FCB 1,"."
XDOT jsr DOLST
X FDB BASE,AT,DOLIT,10,XORR ;?decimal
X FDB QBRAN,DOT1
X FDB UDOT,EXIT ;no, display unsigned
XDOT1: FDB STR,SPACE,TYPES,EXIT ;yes, display signed
X
X; ? ( a -- )
X; Display the contents in a memory cell.
X
X FDB QUEST,L1420
XL1430 FCB 1,"?"
XQUEST jsr DOLST
X FDB AT,DOT,EXIT
X
X;; Parsing
X
X; parse ( b u c -- b u delta ; <string> )
X; Scan string delimited by c. Return found string and its offset.
X
X FDB PARS,L1430
XL1440 FCB 5,"parse"
XPARS jsr DOLST
X FDB TEMP,STORE,OVER,TOR,DUPP
X FDB QBRAN,PARS8
X FDB DOLIT,1,SUBB,TEMP,AT,BLANK,EQUAL
X FDB QBRAN,PARS3
X FDB TOR
XPARS1: FDB BLANK,OVER,CAT ;skip leading blanks ONLY
X FDB SUBB,ZLESS,INVER
X FDB QBRAN,PARS2
X FDB DOLIT,1,PLUS
X FDB DONXT,PARS1
X FDB RFROM,DROP,DOLIT,0,DUPP,EXIT
XPARS2: FDB RFROM
XPARS3: FDB OVER,SWAP
X FDB TOR
XPARS4: FDB TEMP,AT,OVER,CAT,SUBB ;scan for delimiter
X FDB TEMP,AT,BLANK,EQUAL
X FDB QBRAN,PARS5
X FDB ZLESS
XPARS5: FDB QBRAN,PARS6
X FDB DOLIT,1,PLUS
X FDB DONXT,PARS4
X FDB DUPP,TOR
X FDB BRAN,PARS7
XPARS6: FDB RFROM,DROP,DUPP
X FDB DOLIT,1,PLUS,TOR
XPARS7: FDB OVER,SUBB
X FDB RFROM,RFROM,SUBB,EXIT
XPARS8: FDB OVER,RFROM,SUBB,EXIT
X
X; PARSE ( c -- b u ; <string> )
X; Scan input stream and return counted string delimited by c.
X
X FDB PARSE,L1440
XL1450 FCB 5,"PARSE"
XPARSE jsr DOLST
X FDB TOR,TIB,INN,AT,PLUS ;current input buffer pointer
X FDB NTIB,AT,INN,AT,SUBB ;remaining count
X FDB RFROM,PARS,INN,PSTOR,EXIT
X
X; .( ( -- )
X; Output following string up to next ) .
X
X FDB DOTPR,L1450
XL1460 FCB IMEDD+2,".("
XDOTPR jsr DOLST
X FDB DOLIT,')',PARSE,TYPES,EXIT
X
X; ( ( -- )
X; Ignore following string up to next ) . A comment.
X
X FDB PAREN,L1460
XL1470 FCB IMEDD+1,"("
XPAREN jsr DOLST
X FDB DOLIT,')',PARSE,DDROP,EXIT
X
X; \ ( -- )
X; Ignore following text till the end of line.
X
X FDB BKSLA,L1470
XL1480 FCB IMEDD+1,"\"
XBKSLA jsr DOLST
X FDB NTIB,AT,INN,STORE,EXIT
X
X; CHAR ( -- c )
X; Parse next word and return its first character.
X
X FDB CHAR,L1480
XL1490 FCB 4,"CHAR"
XCHAR jsr DOLST
X FDB BLANK,PARSE,DROP,CAT,EXIT
X
X; TOKEN ( -- a ; <string> )
X; Parse a word from input stream and copy it to name dictionary.
X
X FDB TOKEN,L1490
XL1500 FCB 5,"TOKEN"
XTOKEN jsr DOLST
X FDB BLANK,PARSE,DOLIT,31,MIN
X FDB NP,AT,OVER,SUBB,CELLM
X FDB PACKS,EXIT
X
X; WORD ( c -- a ; <string> )
X; Parse a word from input stream and copy it to code dictionary.
X
X FDB WORD,L1500
XL1510 FCB 4,"WORD"
XWORD jsr DOLST
X FDB PARSE,HERE,PACKS,EXIT
X
X;; Dictionary search
X
X; NAME> ( na -- ca )
X; Return a code address given a name address.
X
X FDB NAMET,L1510
XL1520 FCB 5,"NAME>"
XNAMET jsr DOLST
X FDB CELLM,CELLM,AT,EXIT
X
X; SAME? ( a a u -- a a f \ -0+ )
X; Compare u bytes in two strings. Return 0 if identical.
X
X FDB SAMEQ,L1520
XL1530 FCB 5,"SAME?"
XSAMEQ jsr DOLST
X FDB TOR
X FDB BRAN,SAME2
XSAME1: FDB OVER,RAT,PLUS,CAT
X FDB OVER,RAT,PLUS,CAT
X FDB SUBB,QDUP
X FDB QBRAN,SAME2
X FDB RFROM,DROP,EXIT
XSAME2: FDB DONXT,SAME1
X FDB DOLIT,0,EXIT
X
X; find ( a va -- ca na | a F )
X; Search a vocabulary for a string. Return ca and na if succeeded.
X
X FDB FIND,L1530
XL1540 FCB 4,"find"
XFIND jsr DOLST
X FDB SWAP,DUPP,CAT,DOLIT,1,SUBB
X FDB TEMP,STORE
X FDB DUPP,AT,TOR,CELLP,SWAP
XFIND1: FDB AT,DUPP
X FDB QBRAN,FIND6
X FDB DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR
X FDB QBRAN,FIND2
X FDB CELLP,DOLIT,-1
X FDB BRAN,FIND3
XFIND2: FDB CELLP,TEMP,AT,SAMEQ
XFIND3: FDB BRAN,FIND4
XFIND6: FDB RFROM,DROP
X FDB SWAP,CELLM,SWAP,EXIT
XFIND4: FDB QBRAN,FIND5
X FDB CELLM,CELLM
X FDB BRAN,FIND1
XFIND5: FDB RFROM,DROP,SWAP,DROP
X FDB CELLM
X FDB DUPP,NAMET,SWAP,EXIT
X
X; NAME? ( a -- ca na | a F )
X; Search all context vocabularies for a string.
X
X FDB NAMEQ,L1540
XL1550 FCB 5,"NAME?"
XNAMEQ jsr DOLST
X FDB CNTXT,DUPP,DAT,XORR
X FDB QBRAN,NAMQ1
X FDB CELLM
XNAMQ1: FDB TOR
XNAMQ2: FDB RFROM,CELLP,DUPP,TOR
X FDB AT,QDUP
X FDB QBRAN,NAMQ3
X FDB FIND,QDUP
X FDB QBRAN,NAMQ2
X FDB RFROM,DROP,EXIT
XNAMQ3: FDB RFROM,DROP
X FDB DOLIT,0,EXIT
X
X;; Terminal response
X
X; ^H ( bot eot cur -- bot eot cur )
X; Backup the cursor by one character.
X
X FDB BKSP,L1550
XL1560 FCB 2,"^H"
XBKSP jsr DOLST
X FDB TOR,OVER,RFROM,SWAP,OVER,XORR
X FDB QBRAN,BACK1
X FDB DOLIT,BKSPP,TECHO,ATEXE,DOLIT,1,SUBB
X FDB BLANK,TECHO,ATEXE
X FDB DOLIT,BKSPP,TECHO,ATEXE
XBACK1: FDB EXIT
X
X; TAP ( bot eot cur c -- bot eot cur )
X; Accept and echo the key stroke and bump the cursor.
X
X FDB TAP,L1560
XL1570 FCB 3,"TAP"
XTAP jsr DOLST
X FDB DUPP,TECHO,ATEXE
X FDB OVER,CSTOR,DOLIT,1,PLUS,EXIT
X
X; kTAP ( bot eot cur c -- bot eot cur )
X; Process a key stroke, CR or backspace.
X
X FDB KTAP,L1570
XL1580 FCB 4,"kTAP"
XKTAP jsr DOLST
X FDB DUPP,DOLIT,CRR,XORR
X FDB QBRAN,KTAP2
X FDB DOLIT,BKSPP,XORR
X FDB QBRAN,KTAP1
X FDB BLANK,TAP,EXIT
XKTAP1: FDB BKSP,EXIT
XKTAP2: FDB DROP,SWAP,DROP,DUPP,EXIT
X
X; accept ( b u -- b u )
X; Accept characters to input buffer. Return with actual count.
X
X FDB ACCEP,L1580
XL1590 FCB 6,"ACCEPT"
XACCEP jsr DOLST
X FDB OVER,PLUS,OVER
XACCP1: FDB DDUP,XORR
X FDB QBRAN,ACCP4
X FDB KEY,DUPP
X; FDB BLANK,SUBB,DOLIT,95,ULESS
X FDB BLANK,DOLIT,127,WITHI
X FDB QBRAN,ACCP2
X FDB TAP
X FDB BRAN,ACCP3
XACCP2: FDB TTAP,ATEXE
XACCP3: FDB BRAN,ACCP1
XACCP4: FDB DROP,OVER,SUBB,EXIT
X
X; EXPECT ( b u -- )
X; Accept input stream and store count in SPAN.
X
X FDB EXPEC,L1590
XL1600 FCB 6,"EXPECT"
XEXPEC jsr DOLST
X FDB TEXPE,ATEXE,SPAN,STORE,DROP,EXIT
X
X; QUERY ( -- )
X; Accept input stream to terminal input buffer.
X
X FDB QUERY,L1600
XL1610 FCB 5,"QUERY"
XQUERY jsr DOLST
X FDB TIB,DOLIT,80,TEXPE,ATEXE,NTIB,STORE
X FDB DROP,DOLIT,0,INN,STORE,EXIT
X
X;; Error handling
X
X; CATCH ( ca -- 0 | err# )
X; Execute word at ca and set up an error frame for it.
X
X FDB CATCH,L1610
XL1620 FCB 5,"CATCH"
XCATCH jsr DOLST
X FDB SPAT,TOR,HANDL,AT,TOR ;save error frame
X FDB RPAT,HANDL,STORE,EXECU ;execute
X FDB RFROM,HANDL,STORE ;restore error frame
X FDB RFROM,DROP,DOLIT,0,EXIT ;no error
X
X; THROW ( err# -- err# )
X; Reset system to current local error frame an update error flag.
X
X FDB THROW,L1620
XL1630 FCB 5,"THROW"
XTHROW jsr DOLST
X FDB HANDL,AT,RPSTO ;restore return stack
X FDB RFROM,HANDL,STORE ;restore handler frame
X FDB RFROM,SWAP,TOR,SPSTO ;restore data stack
X FDB DROP,RFROM,EXIT
X
X; NULL$ ( -- a )
X; Return address of a null string with zero count.
X
X FDB NULLS,L1630
XL1640 FCB 5,"NULL$"
XNULLS jsr DOLST
X FDB DOVAR ;emulate CREATE
X FDB 0
X FCB 99,111,121,111,116,101
X
X; ABORT ( -- )
X; Reset data stack and jump to QUIT.
X
X FDB ABORT,L1640
XL1650 FCB 5,"ABORT"
XABORT jsr DOLST
X FDB NULLS,THROW
X
X; abort" ( f -- )
X; Run time routine of ABORT" . Abort with a message.
X
X FDB ABORQ,L1650
XL1660 FCB COMPO+6,"abort",'"'
XABORQ jsr DOLST
X FDB QBRAN,ABOR1 ;text flag
X FDB DOSTR,THROW ;pass error string
XABOR1: FDB DOSTR,DROP,EXIT ;drop error
X
X;; The text interpreter
X
X; $INTERPRET ( a -- )
X; Interpret a word. If failed, try to convert it to an integer.
X
X FDB INTER,L1660
XL1670 FCB 10,"$INTERPRET"
XINTER jsr DOLST
X FDB NAMEQ,QDUP ;?defined
X FDB QBRAN,INTE1
X FDB AT,DOLIT,COMPO<<8,ANDD ;?compile only lexicon bits
X FDB ABORQ
X FCB 13," compile only"
X FDB EXECU,EXIT ;execute defined word
XINTE1: FDB TNUMB,ATEXE ;convert a number
X FDB QBRAN,INTE2
X FDB EXIT
XINTE2: FDB THROW ;error
X
X; [ ( -- )
X; Start the text interpreter.
X
X FDB LBRAC,l1670
XL1680 FCB IMEDD+1,"["
XLBRAC jsr DOLST
X FDB DOLIT,INTER,TEVAL,STORE,EXIT
X
X; .OK ( -- )
X; Display 'ok' only while interpreting.
X
X FDB DOTOK,L1680
XL1690 FCB 3,".OK"
XDOTOK jsr DOLST
X FDB DOLIT,INTER,TEVAL,AT,EQUAL
X FDB QBRAN,DOTO1
X FDB DOTQP
X FCB 3," ok"
XDOTO1: FDB CR,EXIT
X
X; ?STACK ( -- )
X; Abort if the data stack underflows.
X
X FDB QSTAC,L1690
XL1700 FCB 6,"?STACK"
XQSTAC jsr DOLST
X FDB DEPTH,ZLESS ;check only for underflow
X FDB ABORQ
X FCB 10," underflow"
X FDB EXIT
X
X; EVAL ( -- )
X; Interpret the input stream.
X
X FDB EVAL,L1700
XL1710 FCB 4,"EVAL"
XEVAL jsr DOLST
XEVAL1: FDB TOKEN,DUPP,CAT ;?input stream empty
X FDB QBRAN,EVAL2
X FDB TEVAL,ATEXE,QSTAC ;evaluate input, check stack
X FDB BRAN,EVAL1
XEVAL2: FDB DROP,TPROM,ATEXE,EXIT ;prompt
X
X;; Shell
X
X; PRESET ( -- )
X; Reset data stack pointer and the terminal input buffer.
X
X FDB PRESE,L1710
XL1720 FCB 6,"PRESET"
XPRESE jsr DOLST
X FDB SZERO,AT,SPSTO
X FDB DOLIT,TIBB,NTIB,CELLP,STORE,EXIT
X
X; xio ( a a a -- )
X; Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT.
X
X FDB XIO,L1720
XL1730 FCB COMPO+3,"xio"
XXIO jsr DOLST
X FDB DOLIT,ACCEP,TEXPE,DSTOR
X FDB TECHO,DSTOR,EXIT
X
X; FILE ( -- )
X; Select I/O vectors for file download.
X
X FDB FILE,L1730
XL1740 FCB 4,"FILE"
XFILE jsr DOLST
X FDB DOLIT,PACE,DOLIT,DROP
X FDB DOLIT,KTAP,XIO,EXIT
X
X; HAND ( -- )
X; Select I/O vectors for terminal interface.
X
X FDB HAND,L1740
XL1750 FCB 4,"HAND"
XHAND jsr DOLST
X FDB DOLIT,DOTOK,DOLIT,EMIT
X FDB DOLIT,KTAP,XIO,EXIT
X
X; I/O ( -- a )
X; Array to store default I/O vectors.
X
X FDB ISLO,L1750
XL1760 FCB 3,"I/O"
XISLO jsr DOLST
X FDB DOVAR ;emulate CREATE
X FDB QRX,TXSTO ;default I/O vectors
X
X; CONSOLE ( -- )
X; Initiate terminal interface.
X
X FDB CONSO,L1760
XL1770 FCB 7,"CONSOLE"
XCONSO jsr DOLST
X FDB ISLO,DAT,TQKEY,DSTOR ;restore default I/O device
X FDB HAND,EXIT ;keyboard input
X
X; QUIT ( -- )
X; Reset return stack pointer and start text interpreter.
X
X FDB QUIT,L1770
XL1780 FCB 4,"QUIT"
XQUIT jsr DOLST
X FDB RZERO,AT,RPSTO ;reset return stack pointer
XQUIT1: FDB LBRAC ;start interpretation
XQUIT2: FDB QUERY ;get input
X FDB DOLIT,EVAL,CATCH,QDUP ;evaluate input
X FDB QBRAN,QUIT2 ;continue till error
X FDB TPROM,AT,TOR ;save input device
X FDB CONSO,NULLS,OVER,XORR ;?display error message
X FDB QBRAN,QUIT3
X FDB SPACE,COUNT,TYPES ;error message
X FDB DOTQP
X FCB 3," ? " ;error prompt
XQUIT3: FDB RFROM,DOLIT,DOTOK,XORR ;?file input
X FDB QBRAN,QUIT4
X FDB DOLIT,ERR,EMIT ;file error, tell host
XQUIT4: FDB PRESE ;some cleanup
X FDB BRAN,QUIT1
X
X;; The compiler
X
X; ' ( -- ca )
X; Search context vocabularies for the next word in input stream.
X
X FDB TICK,L1780
XL1790 FCB 1,"'"
XTICK jsr DOLST
X FDB TOKEN,NAMEQ ;?defined
X FDB QBRAN,TICK1
X FDB EXIT ;yes, push code address
XTICK1: FDB THROW ;no, error
X
X; ALLOT ( n -- )
X; Allocate n bytes to the code dictionary.
X
X FDB ALLOT,L1790
XL1800 FCB 5,"ALLOT"
XALLOT jsr DOLST
X FDB CP,PSTOR,EXIT ;adjust code pointer
X
X; , ( w -- )
X; Compile an integer into the code dictionary.
X
X FDB COMMA,L1800
XL1810 FCB 1,","
XCOMMA jsr DOLST
X FDB HERE,DUPP,CELLP ;cell boundary
X FDB CP,STORE,STORE,EXIT ;adjust code pointer and compile
X
X; [COMPILE] ( -- ; <string> )
X; Compile the next immediate word into code dictionary.
X
X FDB BCOMP,L1810
XL1820 FCB IMEDD+9,"[COMPILE]"
XBCOMP jsr DOLST
X FDB TICK,COMMA,EXIT
X
X; COMPILE ( -- )
X; Compile the next address in colon list to code dictionary.
X
X FDB COMPI,L1820
XL1830 FCB COMPO+7,"COMPILE"
XCOMPI jsr DOLST
X FDB RFROM,DUPP,AT,COMMA ;compile address
X FDB CELLP,TOR,EXIT ;adjust return address
X
X; LITERAL ( w -- )
X; Compile tos to code dictionary as an integer literal.
X
X FDB LITER,L1830
XL1840 FCB IMEDD+7,"LITERAL"
XLITER jsr DOLST
X FDB COMPI,DOLIT,COMMA,EXIT
X
X; $," ( -- )
X; Compile a literal string up to next " .
X
X FDB STRCQ,L1840
XL1850 FCB 3,"$,",'"'
XSTRCQ jsr DOLST
X FDB DOLIT,'"',WORD ;move string to code dictionary
X FDB COUNT,PLUS,ALGND ;calculate aligned end of string
X FDB CP,STORE,EXIT ;adjust the code pointer
X
X; RECURSE ( -- )
X; Make the current word available for compilation.
X
X FDB RECUR,L1850
XL1860 FCB IMEDD+7,"RECURSE"
XRECUR jsr DOLST
X FDB LAST,AT,NAMET,COMMA,EXIT
X
X;; Structures
X
X; FOR ( -- a )
X; Start a FOR-NEXT loop structure in a colon definition.
X
X FDB FOR,L1860
XL1870 FCB IMEDD+3,"FOR"
XFOR jsr DOLST
X FDB COMPI,TOR,HERE,EXIT
X
X; BEGIN ( -- a )
X; Start an infinite or indefinite loop structure.
X
X FDB BEGIN,L1870
XL1880 FCB IMEDD+5,"BEGIN"
XBEGIN jsr DOLST
X FDB HERE,EXIT
X
X; NEXT ( a -- )
X; Terminate a FOR-NEXT loop structure.
X
X FDB NEXT,L1880
XL1890 FCB IMEDD+4,"NEXT"
XNEXT jsr DOLST
X FDB COMPI,DONXT,COMMA,EXIT
X
X; UNTIL ( a -- )
X; Terminate a BEGIN-UNTIL indefinite loop structure.
X
X FDB UNTIL,L1890
XL1900 FCB IMEDD+5,"UNTIL"
XUNTIL jsr DOLST
X FDB COMPI,QBRAN,COMMA,EXIT
X
X; AGAIN ( a -- )
X; Terminate a BEGIN-AGAIN infinite loop structure.
X
X FDB AGAIN,L1900
XL1910 FCB IMEDD+5,"AGAIN"
XAGAIN jsr DOLST
X FDB COMPI,BRAN,COMMA,EXIT
X
X; IF ( -- A )
X; Begin a conditional branch structure.
X
X FDB IFF,L1910
XL1920 FCB IMEDD+2,"IF"
XIFF jsr DOLST
X FDB COMPI,QBRAN,HERE
X FDB DOLIT,0,COMMA,EXIT
X
X; AHEAD ( -- A )
X; Compile a forward branch instruction.
X
X FDB AHEAD,L1920
XL1930 FCB IMEDD+5,"AHEAD"
XAHEAD jsr DOLST
X FDB COMPI,BRAN,HERE,DOLIT,0,COMMA,EXIT
X
X; REPEAT ( A a -- )
X; Terminate a BEGIN-WHILE-REPEAT indefinite loop.
X
X FDB REPEA,L1930
XL1940 FCB IMEDD+6,"REPEAT"
XREPEA jsr DOLST
X FDB AGAIN,HERE,SWAP,STORE,EXIT
X
X; THEN ( A -- )
X; Terminate a conditional branch structure.
X
X FDB THENN,L1940
XL1950 FCB IMEDD+4,"THEN"
XTHENN jsr DOLST
X FDB HERE,SWAP,STORE,EXIT
X
X; AFT ( a -- a A )
X; Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through.
X
X FDB AFT,L1950
XL1960 FCB IMEDD+3,"AFT"
XAFT jsr DOLST
X FDB DROP,AHEAD,BEGIN,SWAP,EXIT
X
X; ELSE ( A -- A )
X; Start the false clause in an IF-ELSE-THEN structure.
X
X FDB ELSEE,L1960
XL1970 FCB IMEDD+4,"ELSE"
XELSEE jsr DOLST
X FDB AHEAD,SWAP,THENN,EXIT
X
X; WHILE ( a -- A a )
X; Conditional branch out of a BEGIN-WHILE-REPEAT loop.
X
X FDB WHILE,L1970
XL1980 FCB IMEDD+5,"WHILE"
XWHILE jsr DOLST
X FDB IFF,SWAP,EXIT
X
X; ABORT" ( -- ; <string> )
X; Conditional abort with an error message.
X
X FDB ABRTQ,L1980
XL1990 FCB IMEDD+6,"ABORT",'"'
XABRTQ jsr DOLST
X FDB COMPI,ABORQ,STRCQ,EXIT
X
X; $" ( -- ; <string> )
X; Compile an inline string literal.
X
X FDB STRQ,L1990
XL2000 FCB IMEDD+2,'$','"'
XSTRQ jsr DOLST
X FDB COMPI,STRQP,STRCQ,EXIT
X
X; ." ( -- ; <string> )
X; Compile an inline string literal to be typed out at run time.
X
X FDB DOTQ,L2000
XL2010 FCB IMEDD+2,'.','"'
XDOTQ jsr DOLST
X FDB COMPI,DOTQP,STRCQ,EXIT
X
X;; Name compiler
X
X; ?UNIQUE ( a -- a )
X; Display a warning message if the word already exists.
X
X FDB UNIQU,L2010
XL2020 FCB 7,"?UNIQUE"
XUNIQU jsr DOLST
X FDB DUPP,NAMEQ ;?name exists
X FDB QBRAN,UNIQ1
X FDB DOTQP ;redefinitions are OK
X FCB 7," reDef " ;but the user should be warned
X FDB OVER,COUNT,TYPES ;just in case its not planned
XUNIQ1: FDB DROP,EXIT
X
X; $,n ( na -- )
X; Build a new dictionary name using the string at na.
X
X FDB SNAME,L2020
XL2030 FCB 3,"$,n"
XSNAME jsr DOLST
X FDB DUPP,CAT ;?null input
X FDB QBRAN,PNAM1
X FDB UNIQU ;?redefinition
X FDB DUPP,LAST,STORE ;save na for vocabulary link
X FDB HERE,ALGND,SWAP ;align code address
X FDB CELLM ;link address
X FDB CRRNT,AT,AT,OVER,STORE
X FDB CELLM,DUPP,NP,STORE ;adjust name pointer
X FDB STORE,EXIT ;save code pointer
XPNAM1: FDB STRQP
X FCB 5," name" ;null input
X FDB THROW
X
X;; FORTH compiler
X
X; $COMPILE ( a -- )
X; Compile next word to code dictionary as a token or literal.
X
X FDB SCOMP,L2030
XL2040 FCB 8,"$COMPILE"
XSCOMP jsr DOLST
X FDB NAMEQ,QDUP ;?defined
X FDB QBRAN,SCOM2
X FDB AT,DOLIT,IMEDD<<8,ANDD ;?immediate
X FDB QBRAN,SCOM1
X FDB EXECU,EXIT ;its immediate, execute
XSCOM1: FDB COMMA,EXIT ;its not immediate, compile
XSCOM2: FDB TNUMB,ATEXE ;try to convert to number
X FDB QBRAN,SCOM3
X FDB LITER,EXIT ;compile number as integer
XSCOM3: FDB THROW ;error
X
X; OVERT ( -- )
X; Link a new word into the current vocabulary.
X
X FDB OVERT,L2040
XL2050 FCB 5,"OVERT"
XOVERT jsr DOLST
X FDB LAST,AT,CRRNT,AT,STORE,EXIT
X
X; ; ( -- )
X; Terminate a colon definition.
X
X FDB SEMIS,L2050
XL2060 FCB IMEDD+COMPO+1,";"
XSEMIS jsr DOLST
X FDB COMPI,EXIT,LBRAC,OVERT,EXIT
X
X; ] ( -- )
X; Start compiling the words in the input stream.
X
X FDB RBRAC,L2060
XL2070 FCB 1,"]"
XRBRAC jsr DOLST
X FDB DOLIT,SCOMP,TEVAL,STORE,EXIT
X
X; call, ( ca -- )
X; Assemble a call instruction to ca.
X
X FDB CALLC,L2070
XL2080 FCB 5,"call,"
XCALLC jsr DOLST
X FDB DOLIT,CALLL,HERE,CSTOR ;Direct Threaded Code
X FDB DOLIT,1,ALLOT
X FDB COMMA,EXIT ;DTC 6809 extended addr jsr
X
X; : ( -- ; <string> )
X; Start a new colon definition using next word as its name.
X
X FDB COLON,L2080
XL2090 FCB 1,":"
XCOLON jsr DOLST
X FDB TOKEN,SNAME,DOLIT,DOLST
X FDB CALLC,RBRAC,EXIT
X
X; IMMEDIATE ( -- )
X; Make the last compiled word an immediate word.
X
X FDB IMMED,L2090
XL2100 FCB 9,"IMMEDIATE"
XIMMED jsr DOLST
X FDB DOLIT,IMEDD<<8,LAST,AT,AT,ORR
X FDB LAST,AT,STORE,EXIT
X
X;; Defining words
X
X; USER ( u -- ; <string> )
X; Compile a new user variable.
X
X FDB USER,L2100
XL2110 FCB 4,"USER"
XUSER jsr DOLST
X FDB TOKEN,SNAME,OVERT
X FDB DOLIT,DOLST,CALLC
X FDB DOLIT,DOUSE,COMMA
X FDB COMMA,EXIT
X
X; CREATE ( -- ; <string> )
X; Compile a new array entry without allocating code space.
X
X FDB CREAT,L2110
XL2120 FCB 6,"CREATE"
XCREAT jsr DOLST
X FDB TOKEN,SNAME,OVERT
X FDB DOLIT,DOLST,CALLC
X FDB DOLIT,DOVAR,COMMA,EXIT
X
X; VARIABLE ( -- ; <string> )
X; Compile a new variable initialized to 0.
X
X FDB VARIA,L2120
XL2130 FCB 8,"VARIABLE"
XVARIA jsr DOLST
X FDB CREAT,DOLIT,0,COMMA,EXIT
X
X;; Tools
X
X; _TYPE ( b u -- )
X; Display a string. Filter non-printing characters.
X
X FDB UTYPE,L2130
XL2140 FCB 5,"_TYPE"
XUTYPE jsr DOLST
X FDB TOR ;start count down loop
X FDB BRAN,UTYP2 ;skip first pass
XUTYP1: FDB DUPP,CAT,TCHAR,EMIT ;display only printable
X FDB DOLIT,1,PLUS ;increment address
XUTYP2: FDB DONXT,UTYP1 ;loop till done
X FDB DROP,EXIT
X
X; dm+ ( a u -- a )
X; Dump u bytes from , leaving a+u on the stack.
X
X FDB DUMPP,L2140
XL2150 FCB 3,"dm+"
XDUMPP jsr DOLST
X FDB OVER,DOLIT,4,UDOTR ;display address
X FDB SPACE,TOR ;start count down loop
X FDB BRAN,PDUM2 ;skip first pass
XPDUM1: FDB DUPP,CAT,DOLIT,3,UDOTR ;display numeric data
X FDB DOLIT,1,PLUS ;increment address
XPDUM2: FDB DONXT,PDUM1 ;loop till done
X FDB EXIT
X
X; DUMP ( a u -- )
X; Dump u bytes from a, in a formatted manner.
X
X FDB DUMP,L2150
XL2160 FCB 4,"DUMP"
XDUMP jsr DOLST
X FDB BASE,AT,TOR,HEX ;save radix, set hex
X FDB DOLIT,16,SLASH ;change count to lines
X FDB TOR ;start count down loop
XDUMP1: FDB CR,DOLIT,16,DDUP,DUMPP ;display numeric
X FDB ROT,ROT
X FDB DOLIT,2,SPACS,UTYPE ;display printable characters
X FDB NUFQ,INVER ;user control
X FDB QBRAN,DUMP2
X FDB DONXT,DUMP1 ;loop till done
X FDB BRAN,DUMP3
XDUMP2: FDB RFROM,DROP ;cleanup loop stack, early exit
XDUMP3: FDB DROP,RFROM,BASE,STORE ;restore radix
X FDB EXIT
X
X; .S ( ... -- ... )
X; Display the contents of the data stack.
X
X FDB DOTS,L2160
XL2170 FCB 2,".S"
XDOTS jsr DOLST
X FDB CR,DEPTH ;stack depth
X FDB TOR ;start count down loop
X FDB BRAN,DOTS2 ;skip first pass
XDOTS1: FDB RAT,PICK,DOT ;index stack, display contents
XDOTS2: FDB DONXT,DOTS1 ;loop till done
X FDB DOTQP
X FCB 4," <sp"
X FDB EXIT
X
X; !CSP ( -- )
X; Save stack pointer in CSP for error checking.
X
X FDB STCSP,L2170
XL2180 FCB 4,"!CSP"
XSTCSP jsr DOLST
X FDB SPAT,CSP,STORE,EXIT ;save pointer
X
X; ?CSP ( -- )
X; Abort if stack pointer differs from that saved in CSP.
X
X FDB QCSP,L2180
XL2190 FCB 4,"?CSP"
XQCSP jsr DOLST
X FDB SPAT,CSP,AT,XORR ;compare pointers
X FDB ABORQ ;abort if different
X FCB 6,"stacks"
X FDB EXIT
X
X; >NAME ( ca -- na | F )
X; Convert code address to a name address.
X
X FDB TNAME,L2190
XL2200 FCB 5,">NAME"
XTNAME jsr DOLST
X FDB CRRNT ;vocabulary link
XTNAM1: FDB CELLP,AT,QDUP ;check all vocabularies
X FDB QBRAN,TNAM4
X FDB DDUP
XTNAM2: FDB AT,DUPP ;?last word in a vocabulary
X FDB QBRAN,TNAM3
X FDB DDUP,NAMET,XORR ;compare
X FDB QBRAN,TNAM3
X FDB CELLM ;continue with next word
X FDB BRAN,TNAM2
XTNAM3: FDB SWAP,DROP,QDUP
X FDB QBRAN,TNAM1
X FDB SWAP,DROP,SWAP,DROP,EXIT
XTNAM4: FDB DROP,DOLIT,0,EXIT
X
X; .ID ( na -- )
X; Display the name at address.
X
X FDB DOTID,L2200
XL2210 FCB 3,".ID"
XDOTID jsr DOLST
X FDB QDUP ;if zero no name
X FDB QBRAN,DOTI1
X FDB COUNT,DOLIT,$1F,ANDD ;mask lexicon bits
X FDB UTYPE,EXIT ;display name string
XDOTI1: FDB DOTQP
X FCB 9," {noName}"
X FDB EXIT
X
X; SEE ( -- ; <string> )
X; A simple decompiler.
X
X FDB SEE,L2210
XL2220 FCB 3,"SEE"
XSEE jsr DOLST
X FDB TICK ;starting address
X FDB CR,CELLP
XSEE1: FDB CELLP,DUPP,AT,DUPP ;?does it contain a zero
X FDB QBRAN,SEE2
X FDB TNAME ;?is it a name
XSEE2: FDB QDUP ;name address or zero
X FDB QBRAN,SEE3
X FDB SPACE,DOTID ;display name
X FDB BRAN,SEE4
XSEE3: FDB DUPP,AT,UDOT ;display number
XSEE4: FDB NUFQ ;user control
X FDB QBRAN,SEE1
X FDB DROP,EXIT
X
X; WORDS ( -- )
X; Display the names in the context vocabulary.
X
X FDB WORDS,L2220
XL2230 FCB 5,"WORDS"
XWORDS jsr DOLST
X FDB CR,CNTXT,AT ;only in context
XWORS1: FDB AT,QDUP ;?at end of list
X FDB QBRAN,WORS2
X FDB DUPP,SPACE,DOTID ;display a name
X FDB CELLM,NUFQ ;user control
X FDB QBRAN,WORS1
X FDB DROP
XWORS2: FDB EXIT
X
X;; Hardware reset
X
X; VER ( -- n )
X; Return the version number of this implementation.
X
X FDB VERSN,L2230
XL2240 FCB 3,"VER"
XVERSN jsr DOLST
X FDB DOLIT,VER*256+EXT,EXIT
X
X; hi ( -- )
X; Display the sign-on message of eForth.
X
X FDB HI,L2240
XL2250 FCB 2,"hi"
XHI jsr DOLST
X FDB STOIO,CR,DOTQP ;initialize I/O
X FCB 11,"eForth v" ;model
X FCB VER+'0','.',EXT+'0' ;version
X FDB CR,EXIT
X
X; 'BOOT ( -- a )
X; The application startup vector.
X
X FDB TBOOT,L2250
XL2260 FCB 5,"'BOOT"
XTBOOT jsr DOLST
X FDB DOVAR
X FDB HI ;application to boot
X
X; COLD ( -- )
X; The hilevel cold start sequence.
X
X FDB COLD,L2260
XL2270 FCB 4,"COLD"
XCOLD jsr DOLST
XCOLD1: FDB DOLIT,UZERO,DOLIT,UPP
X FDB DOLIT,ULAST-UZERO,CMOVE ;initialize user area
X FDB PRESE ;initialize data stack and TIB
X FDB TBOOT,ATEXE ;application boot
X FDB FORTH,CNTXT,AT,DUPP ;initialize search order
X FDB CRRNT,DSTOR,OVERT
X FDB QUIT ;start interpretation
X FDB BRAN,COLD1 ;just in case
X
X;===============================================================
X
XLASTN EQU L2270 ;last name address in name dictionary
X
XNTOP EQU NAMEE ;next available memory in name dictionary
XCTOP EQU * ;next available memory in code dictionary
X
X
X END ORIG
X
X;===============================================================
X
END_OF_ef09.asm
if test 48780 -ne `wc -c <ef09.asm`; then
echo shar: \"ef09.asm\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f test09.asm -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"test09.asm\"
else
echo shar: Extracting \"test09.asm\" \(8042 characters\)
sed "s/^X//" >test09.asm <<'END_OF_test09.asm'
X ; 6809 Test program.
X
Xtestnr equ 32
X
X org $100
X jmp entry
Xerror ldx #errmsg
X bsr outs
X lda testnr
X bsr outa
X ldx #newline
X bsr outs
X sync
X
Xerrmsg fcb "ERROR ",0
Xnewline fcb 13,10,0
Xouts ldb ,x+
X beq done1
X swi2
X bra outs
Xdone1 rts
Xoutdig addb # 48
X cmpb # 57
X bls od2
X addb #7
Xod2 swi2
X rts
Xouta tfr a,b
X lsrb
X lsrb
X lsrb
X lsrb
X bsr outdig
X tfr a,b
X andb # 15
X bra outdig
Xpassmsg fcb "PASSED ",0
Xgood ldx #passmsg
X jsr outs
X lda testnr
X jsr outa
X ldx #newline
X jsr outs
X inc testnr
X rts
X
Xentry clr testnr
X jsr good ;test #0, does it print msg?
X andcc #0 ;test #1, conditional (long) branches
X lbvs error ; andcc, orcc
X lbcs error
X lbeq error
X lbmi error
X lbls error
X lblt error
X lble error
X lbrn error
X bvs errt1
X bcs errt1
X beq errt1
X bmi errt1
X bls errt1
X blt errt1
X ble errt1
X brn errt1
X lbvc goot1
Xerrt1 jmp error
Xgoot1 lbcc goot2
X jmp error
Xgoot2 lbne goot3
X jmp error
Xgoot3 lbpl goot4
X jmp error
Xgoot4 lbhi goot5
X jmp error
Xgoot5 lbge goot6
X jmp error
Xgoot6 lbgt goot7
X jmp error
Xgoot7 lbra goot8
X jmp error
Xgoot8 bvc goot9
X jmp error
Xgoot9 bcc goot10
X jmp error
Xgoot10 bne goot11
X jmp error
Xgoot11 bpl goot12
X jmp error
Xgoot12 bhi goot13
X jmp error
Xgoot13 bge goot14
X jmp error
Xgoot14 bgt goot15
X jmp error
Xgoot15 bra goot16
X jmp error
Xgoot16 tfr cc,a
X tsta
X lbne error
X andcc #0
X orcc #1
X lbcc error
X lbeq error
X lbvs error
X lbmi error
X orcc #2
X lbvc error
X lbeq error
X lbmi error
X orcc #4
X lbne error
X lbmi error
X orcc #8
X lbpl error
X tfr cc,a
X cmpa #15
X lbne error
X orcc #15
X orcc #240
X tfr cc,a
X inca
X lbne error
X orcc #255
X andcc #$aa
X tfr cc,a
X cmpa #$aa
X lbne error
X jsr good
X
X lds #0 ; test #2: registers and their values, tfr, exg
X lda #$28
X ldb #$7f
X ldu #3417
X ldx #2221
X ldy #16555
X cmpa #$28
X lbne error
X cmpb #$7f
X lbne error
X cmpd #$287f
X lbne error
X cmpx #2221
X lbne error
X cmpy #13
X lbeq error
X cmpy #16555
X lbne error
X cmpu #3417
X lbne error
X cmps #0
X lbne error
X exg x,y
X cmpx #16555
X lbne error
X cmpy #2221
X lbne error
X exg x,d
X cmpd #16555
X lbne error
X cmpx #$287f
X lbne error
X cmpy #2221
X lbne error
X exg x,d
X exg a,dp
X tsta
X lbne error
X exg a,dp
X exg a,b
X cmpa #$7f
X lbne error
X cmpb #$28
X lbne error
X tfr b,a
X cmpb #$28
X lbne error
X cmpa #$28
X lbne error
X tfr u,x
X cmpu #3417
X lbne error
X cmpx #3417
X lbne error
X tfr pc,x
Xhere cmpx #here
X lbne error
X tfr u,s
X cmps #3417
X lbne error
X lds #0
X clra
X tfr b,cc
X tfr cc,a
X cmpa #$28
X lbne error
X jsr good
X
X lda #128 ;Arithmetic and their status.
X adda #255
X lbcc error
X lbvc error
X lbmi error
X cmpa #127
X lbne error
X lda #0
X adda #255
X lbcs error
X lbvs error
X lbpl error
X cmpa #255
X lbne error
X orcc #1
X lda #255
X adca #0
X lbne error
X lbmi error
X lbcc error
X lda #216
X adda #40
X lbne error
X lda #80
X adda #40
X lbcs error
X lbvs error
X cmpa #120
X lbne error
X orcc #1
X lda #80
X adca #40
X lbcs error
X lbvs error
X cmpa #121
X lbne error
X andcc #254
X ldb #80
X adcb #40
X lbcs error
X lbvs error
X cmpb #120
X lbne error
X ldb #80
X subb #120
X lbcc error
X lbvs error
X cmpb #216
X lbne error
X andcc #254
X lda #140
X sbca #20
X lbvc error
X lbcs error
X cmpa #120
X lbne error
X orcc #1
X lda #140
X sbca #20
X lbvc error
X lbcs error
X cmpa #119
X lbne error
X ldd #40000
X subd #20000
X lbvc error
X lbcs error
X cmpd #20000
X lbne error
X ldd #20000
X subd #40000
X lbvc error
X lbcc error
X cmpd #-20000
X lbne error
X ldd #30000
X addd #-20000
X lbcc error
X lbvs error
X cmpd #10000
X lbne error
X jsr good
X
X lda #$23 ;Test #4 decimal arithmetic.
X adda #$34
X daa
X lbcs error
X cmpa #$57
X lbne error
X orcc #1
X lda #$19
X adca #$29
X daa
X lbcs error
X cmpa #$49
X lbne error
X lda #$92
X adda #$8
X daa
X lbcc error
X cmpa #$00
X jsr good
X
X lda #128 ;Test#5 MUL and SEX
X ldb #2
X mul
X lbeq error
X lbcc error
X cmpd #256
X lbne error
X lda #0
X ldb #23
X mul
X lbne error
X lbcs error
X cmpd #0
X lbne error
X lda #10
X ldb #20
X mul
X lbcs error
X cmpd #200
X lbne error
X lda #100
X ldb #49
X mul
X cmpd #4900
X lbne error
X clrb
X sex
X cmpd #0
X lbne error
X ldb #128
X sex
X cmpd #-128
X lbne error
X ldb #50
X sex
X cmpd #50
X lbne error
X jsr good
X
X lda #$55 ; Test #6 Shifts and rotates.
X asla
X lbcs error
X cmpa #$aa
X lbne error
X asla
X lbcc error
X cmpa #$54
X lbne error
X lda #$0
X andcc #254
X rola
X lbne error
X orcc #1
X rola
X deca
X lbne error
X andcc #254
X rora
X lbne error
X orcc #1
X rora
X cmpa #128
X lbne error
X asra
X cmpa #192
X lbne error
X lsra
X cmpa #96
X lbne error
X ldb # 54
X aslb
X cmpb # 108
X lbne error
X jsr good
X
X orcc #15 ; Test #7 INC, DEC and NEG
X lda # 33
X inca
X lbeq error
X lbvs error
X lbcc error
X lbmi error
X deca
X lbeq error
X lbvs error
X lbcc error
X lbmi error
X clra
X andcc #254
X deca
X lbcs error
X lbpl error
X inca
X lbne error
X ldb #126
X negb
X lbvs error
X lbcc error
X cmpb #130
X lbne error
X decb
X decb
X negb
X lbvc error
X cmpb #128
X lbne error
X clrb
X negb
X lbcs error
X lbne error
X jsr good
X
X ;test #8 Addessing modes.
X ldx #testdat+4
X lda ,x
X cmpa #5
X lbne error
X lda ,x+
X cmpa #5
X lbne error
X cmpx #testdat+5
X lbne error
X ldd ,x++
X cmpd #6*256+7
X lbne error
X cmpx #testdat+7
X lbne error
X ldx #testdat+4
X lda ,-x
X cmpa #4
X lbne error
X cmpx #testdat+3
X lbne error
X ldd ,--x
X cmpd #2*256+3
X lbne error
X cmpx #testdat+1
X lbne error
X ldx #testdat+4
X lda -2,x
X cmpa #3
X lbne error
X lda 2,x
X cmpa #7
X lbne error
X ldx #td1
X ldd [,x]
X cmpd #3*256+4
X lbne error
X cmpx #td1
X lbne error
X jsr good
X bra next1
Xtestdat fcb 1,2,3,4,5,6,7,8,9,10
Xtd1 fdb testdat+2
Xnext1
X
X sync
X end $100
X
X
X
END_OF_test09.asm
if test 8042 -ne `wc -c <test09.asm`; then
echo shar: \"test09.asm\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of shell archive.
exit 0