86ef202.asm

eForth is a small portable Forth design for a wide range of microprocessors. This is the first imple

		$COLON	1,',',COMMA
		DW	HERE,DUPP,CELLP		;cell boundary
		DW	CP,STORE,STORE,EXIT	;adjust code pointer and compile

;   [COMPILE]	( -- ; <string> )
;		Compile the next immediate word into code dictionary.

		$COLON	IMEDD+9,'[COMPILE]',BCOMP
		DW	TICK,COMMA,EXIT

;   COMPILE	( -- )
;		Compile the next address in colon list to code dictionary.

		$COLON	COMPO+7,'COMPILE',COMPI
		DW	RFROM,DUPP,AT,COMMA	;compile address
		DW	CELLP,TOR,EXIT		;adjust return address

;   LITERAL	( w -- )
;		Compile tos to code dictionary as an integer literal.

		$COLON	IMEDD+7,'LITERAL',LITER
		DW	COMPI,DOLIT,COMMA,EXIT

;   $,"		( -- )
;		Compile a literal string up to next " .

                $COLON  3,'$,"',STRCQ
                DW      DOLIT,'"',PARSE,HERE,PACKS   ;string to code dictionary
                DW      COUNT,PLUS        ;calculate aligned end of string
		DW	CP,STORE,EXIT		;adjust the code pointer

;; Structures

;   FOR		( -- a )
;		Start a FOR-NEXT loop structure in a colon definition.

		$COLON	IMEDD+3,'FOR',FOR
		DW	COMPI,TOR,HERE,EXIT

;   BEGIN	( -- a )
;		Start an infinite or indefinite loop structure.

		$COLON	IMEDD+5,'BEGIN',BEGIN
		DW	HERE,EXIT

;   NEXT	( a -- )
;		Terminate a FOR-NEXT loop structure.

		$COLON	IMEDD+4,'NEXT',NEXT
		DW	COMPI,DONXT,COMMA,EXIT

;   UNTIL	( a -- )
;		Terminate a BEGIN-UNTIL indefinite loop structure.

		$COLON	IMEDD+5,'UNTIL',UNTIL
		DW	COMPI,QBRAN,COMMA,EXIT

;   AGAIN	( a -- )
;		Terminate a BEGIN-AGAIN infinite loop structure.

		$COLON	IMEDD+5,'AGAIN',AGAIN
		DW	COMPI,BRAN,COMMA,EXIT

;   IF		( -- A )
;		Begin a conditional branch structure.

		$COLON	IMEDD+2,'IF',IFF
		DW	COMPI,QBRAN,HERE
		DW	DOLIT,0,COMMA,EXIT

;   AHEAD	( -- A )
;		Compile a forward branch instruction.

		$COLON	IMEDD+5,'AHEAD',AHEAD
		DW	COMPI,BRAN,HERE,DOLIT,0,COMMA,EXIT

;   REPEAT	( A a -- )
;		Terminate a BEGIN-WHILE-REPEAT indefinite loop.

		$COLON	IMEDD+6,'REPEAT',REPEA
		DW	AGAIN,HERE,SWAP,STORE,EXIT

;   THEN	( A -- )
;		Terminate a conditional branch structure.

		$COLON	IMEDD+4,'THEN',THENN
		DW	HERE,SWAP,STORE,EXIT

;   AFT		( a -- a A )
;		Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through.

		$COLON	IMEDD+3,'AFT',AFT
		DW	DROP,AHEAD,BEGIN,SWAP,EXIT

;   ELSE	( A -- A )
;		Start the false clause in an IF-ELSE-THEN structure.

		$COLON	IMEDD+4,'ELSE',ELSEE
		DW	AHEAD,SWAP,THENN,EXIT

;   WHILE	( a -- A a )
;		Conditional branch out of a BEGIN-WHILE-REPEAT loop.

		$COLON	IMEDD+5,'WHILE',WHILE
		DW	IFF,SWAP,EXIT

;   ABORT"	( -- ; <string> )
;		Conditional abort with an error message.

		$COLON	IMEDD+6,'ABORT"',ABRTQ
		DW	COMPI,ABORQ,STRCQ,EXIT

;   $"		( -- ; <string> )
;		Compile an inline string literal.

		$COLON	IMEDD+2,'$"',STRQ
		DW	COMPI,STRQP,STRCQ,EXIT

;   ."		( -- ; <string> )
;		Compile an inline string literal to be typed out at run time.

		$COLON	IMEDD+2,'."',DOTQ
		DW	COMPI,DOTQP,STRCQ,EXIT

;; Name compiler

;   ?UNIQUE	( a -- a )
;		Display a warning message if the word already exists.

                $COLON  7,'?UNIQUE',UNIQU
		DW	DUPP,NAMEQ		;?name exists
		DW	QBRAN,UNIQ1
		DW	DOTQP			;redefinitions are OK
		DB	7,' reDef '		;but the user should be warned
		DW	OVER,COUNT,TYPES	;just in case its not planned
UNIQ1:		DW	DROP,EXIT

;   $,n		( na -- )
;		Build a new dictionary name using the string at na.

                $COLON  3,'$,n',SNAME
		DW	DUPP,CAT		;?null input
		DW	QBRAN,PNAM1
		DW	UNIQU			;?redefinition
                DW      DUPP,COUNT,PLUS
                DW      CP,STORE
		DW	DUPP,LAST,STORE		;save na for vocabulary link
		DW	CELLM			;link address
                DW      CNTXT,AT,SWAP
		DW	STORE,EXIT		;save code pointer
PNAM1:          DW      STRQP
		DB	5,' name'		;null input
                DW      BRAN,ABOR1

;; FORTH compiler

;   $COMPILE	( a -- )
;		Compile next word to code dictionary as a token or literal.

                $COLON  8,'$COMPILE',SCOMP
		DW	NAMEQ,QDUP		;?defined
		DW	QBRAN,SCOM2
		DW	AT,DOLIT,IMEDD,ANDD	;?immediate
		DW	QBRAN,SCOM1
		DW	EXECU,EXIT		;its immediate, execute
SCOM1:		DW	COMMA,EXIT		;its not immediate, compile
SCOM2:          DW      NUMBQ            ;try to convert to number
                DW      QBRAN,ABOR1
		DW	LITER,EXIT		;compile number as integer

;   OVERT	( -- )
;		Link a new word into the current vocabulary.

                $COLON  5,'OVERT',OVERT
                DW      LAST,AT,CNTXT,STORE,EXIT

;   ;		( -- )
;		Terminate a colon definition.

		$COLON	IMEDD+COMPO+1,';',SEMIS
		DW	COMPI,EXIT,LBRAC,OVERT,EXIT

;   ]		( -- )
;		Start compiling the words in the input stream.

		$COLON	1,']',RBRAC
		DW	DOLIT,SCOMP,TEVAL,STORE,EXIT

;   call,	( ca -- )
;		Assemble a call instruction to ca.

                $COLON  5,'call,',CALLC
		DW	DOLIT,CALLL,COMMA,HERE	;Direct Threaded Code
		DW	CELLP,SUBB,COMMA,EXIT	;DTC 8086 relative call

;   :		( -- ; <string> )
;		Start a new colon definition using next word as its name.

		$COLON	1,':',COLON
		DW	TOKEN,SNAME,DOLIT,DOLST
		DW	CALLC,RBRAC,EXIT

;   IMMEDIATE	( -- )
;		Make the last compiled word an immediate word.

		$COLON	9,'IMMEDIATE',IMMED
		DW	DOLIT,IMEDD,LAST,AT,AT,ORR
		DW	LAST,AT,STORE,EXIT

;; Defining words

;   CREATE	( -- ; <string> )
;		Compile a new array entry without allocating code space.

		$COLON	6,'CREATE',CREAT
		DW	TOKEN,SNAME,OVERT
		DW	DOLIT,DOLST,CALLC
		DW	DOLIT,DOVAR,COMMA,EXIT

;   VARIABLE	( -- ; <string> )
;		Compile a new variable initialized to 0.

		$COLON	8,'VARIABLE',VARIA
		DW	CREAT,DOLIT,0,COMMA,EXIT

;; Tools

;   _TYPE	( b u -- )
;		Display a string. Filter non-printing characters.

                $COLON  5,'_TYPE',UTYPE
		DW	TOR			;start count down loop
		DW	BRAN,UTYP2		;skip first pass
UTYP1:		DW	DUPP,CAT,TCHAR,EMIT	;display only printable
                DW      ONEP            ;increment address
UTYP2:		DW	DONXT,UTYP1		;loop till done
		DW	DROP,EXIT

;   dm+		( a u -- a )
;		Dump u bytes from , leaving a+u on the stack.

                $COLON  3,'dm+',DUMPP
		DW	OVER,DOLIT,4,UDOTR	;display address
		DW	SPACE,TOR		;start count down loop
		DW	BRAN,PDUM2		;skip first pass
PDUM1:		DW	DUPP,CAT,DOLIT,3,UDOTR	;display numeric data
                DW      ONEP            ;increment address
PDUM2:		DW	DONXT,PDUM1		;loop till done
		DW	EXIT

;   DUMP	( a u -- )
;		Dump u bytes from a, in a formatted manner.

		$COLON	4,'DUMP',DUMP
		DW	BASE,AT,TOR,HEX		;save radix, set hex
		DW	DOLIT,16,SLASH		;change count to lines
		DW	TOR			;start count down loop
DUMP1:		DW	CR,DOLIT,16,DDUP,DUMPP	;display numeric
		DW	ROT,ROT
		DW	DOLIT,2,SPACS,UTYPE	;display printable characters
		DW	NUFQ,INVER		;user control
		DW	QBRAN,DUMP2
		DW	DONXT,DUMP1		;loop till done
		DW	BRAN,DUMP3
DUMP2:		DW	RFROM,DROP		;cleanup loop stack, early exit
DUMP3:		DW	DROP,RFROM,BASE,STORE	;restore radix
		DW	EXIT

;   .S		( ... -- ... )
;		Display the contents of the data stack.

		$COLON	2,'.S',DOTS
		DW	CR,DEPTH		;stack depth
		DW	TOR			;start count down loop
		DW	BRAN,DOTS2		;skip first pass
DOTS1:		DW	RAT,PICK,DOT		;index stack, display contents
DOTS2:		DW	DONXT,DOTS1		;loop till done
		DW	DOTQP
                DB      5,' <sp '
		DW	EXIT

;   >NAME	( ca -- na | F )
;		Convert code address to a name address.

                $COLON  5,'>NAME',TNAME
                DW      CNTXT                   ;vocabulary link
TNAM2:		DW	AT,DUPP			;?last word in a vocabulary
                DW      QBRAN,TNAM4
		DW	DDUP,NAMET,XORR		;compare
		DW	QBRAN,TNAM3
		DW	CELLM			;continue with next word
		DW	BRAN,TNAM2
TNAM3:          DW      SWAP,DROP,EXIT
TNAM4:          DW      DDROP,DOLIT,0,EXIT

;   .ID		( na -- )
;		Display the name at address.

                $COLON  3,'.ID',DOTID
		DW	QDUP			;if zero no name
		DW	QBRAN,DOTI1
		DW	COUNT,DOLIT,01FH,ANDD	;mask lexicon bits
		DW	UTYPE,EXIT		;display name string
DOTI1:		DW	DOTQP
		DB	9,' {noName}'
		DW	EXIT

;   SEE		( -- ; <string> )
;               A simple decompiler. Updated for byte machines, 08mar98cht

		$COLON	3,'SEE',SEE
		DW	TICK			;starting address
                DW      CR,CELLP
SEE1:           DW      ONEP,DUPP,AT,DUPP      ;?does it contain a zero
		DW	QBRAN,SEE2
		DW	TNAME			;?is it a name
SEE2:		DW	QDUP			;name address or zero
		DW	QBRAN,SEE3
		DW	SPACE,DOTID		;display name
                DW      ONEP
		DW	BRAN,SEE4
SEE3:           DW      DUPP,CAT,UDOT            ;display number
SEE4:		DW	NUFQ			;user control
		DW	QBRAN,SEE1
		DW	DROP,EXIT

;   WORDS	( -- )
;		Display the names in the context vocabulary.

		$COLON	5,'WORDS',WORDS
                DW      CR,CNTXT             ;only in context
WORS1:		DW	AT,QDUP			;?at end of list
		DW	QBRAN,WORS2
		DW	DUPP,SPACE,DOTID	;display a name
		DW	CELLM,NUFQ		;user control
		DW	QBRAN,WORS1
		DW	DROP
WORS2:		DW	EXIT

;   READ        ( bufffer len -- len-read , filename )
;       Open a file by name and load it into buffer.
;
                $COLON  4,'READ',READ
                DW      DOLIT,ULAST,DOLIT,32
                DW      DOLIT,0,FILL
                DW      BLANK,WORDD,COUNT
                DW      DOLIT,ULAST,SWAP,CMOVE
                DW      DOLIT,3D00H
                DW      OPENF,DUPP,DOLIT,-1
                DW      XORR
                DW      QBRAN,READ1
                DW      DUPP,TOR
                DW      READF
                DW      DUPP,DOLIT,-1,XORR
                DW      QBRAN,READ2
                DW      RFROM,CLOSE
                DW      EXIT
READ2:          DW      RFROM,DROP
READ1:          DW      DOLIT,'?',EMIT,CR,ABORT

;   LOAD        ( buffer len -- )
;       Load file read into the buffer.

                $COLON  4,'LOAD',LOAD
                DW      INN,AT,TOR
                DW      NTIB,DAT,TOR,TOR
                DW      NTIB,DSTOR
                DW      DOLIT,0,INN,STORE
                DW      EVAL
                DW      RFROM,RFROM,NTIB,DSTOR
                DW      RFROM,INN,STORE
                DW      EXIT
                
;   DOWNLOAD    ( -- , <filename> )
;       Load file read into the buffer.

                $COLON  8,'DOWNLOAD',DLOAD
                DW      HERE,DOLIT,1000,PLUS
                DW      DUPP
                DW      SPAT,DOLIT,1000,SUBB
                DW      OVER,SUBB,READ
                DW      LOAD
                DW      EXIT

;       checksum ( addr len -- sum )
;       Add words to form 16-bit sum. len must be even.

                $COLON  8,'checksum',CHECKS
                DW      DOLIT,0,TEMP,STORE
                DW      TWOSL,DOLIT,-1,PLUS
                DW      TOR
CHECK1:         DW      DUPP,AT,TEMP,PSTOR
                DW      CELLP
                DW      DONXT,CHECK1
                DW      DROP,TEMP,AT
                DW      EXIT

;       EXE file header for SAVE
EXEHDR:         DW      5A4DH           ;signature
                DW      22H             ;extra bytes
                DW      0CH             ;pages
                DW      0               ;reloc items
                DW      20H             ;header size
                DW      0               ;min alloc
                DW      0FFFFH          ;max alloc
                DW      0               ;init SS
                DW      0               ;init SP
                DW      0BC66H          ;checksum
                DW      0               ;init IP
                DW      0               ;init CS
                DW      1EH             ;reloc table
                DW      0               ;overlay
                DW      1               ;?
                DW      0               ;reloc table

;       UPLOAD  ( -- , <filename> )
;       Save current image to an EXE file.

                $COLON  6,'UPLOAD',ULOAD
                DW      HERE,DOLIT,1,ANDD,ALLOT
                DW      DOLIT,UPP,DOLIT,UZERO
		DW	DOLIT,ULAST-UZERO,CMOVE	;initialize user area
                DW      DOLIT,ULAST,DOLIT,32
                DW      ERASE
                DW      BLANK,WORDD,COUNT       ;get file name
                DW      DOLIT,ULAST,SWAP,CMOVE
                DW      PAD,DOLIT,200H,ERASE
                DW      DOLIT,EXEHDR,PAD
                DW      DOLIT,20H,CMOVE         ;init header
                DW      CP,AT,DOLIT,0,DOLIT,200H
                DW      UMMOD,ONEP              ;add 512 bytes of header
                DW      OVER
                DW      QBRAN,SAVE0
                DW      ONEP
SAVE0:          DW      PAD,DOLIT,4,PLUS,STORE
                DW      PAD,CELLP,STORE
                DW      PAD,DOLIT,200H,CHECKS
                DW      DOLIT,0,CP,AT,CHECKS
                DW      PLUS,DOLIT,-1,XORR
                DW      PAD,DOLIT,18,PLUS,STORE
                DW      DOLIT,3D01H             ;open to write
                DW      OPENF,DUPP,DOLIT,-1
                DW      EQUAL
                DW      QBRAN,SAVE1
                DW      DROP,DOLIT,0            ;create read/write
                DW      CREATF,DUPP,DOLIT,-1
                DW      XORR
                DW      QBRAN,SAVE3
SAVE1:          DW      TOR                     ;save handle
                DW      PAD,DOLIT,200H
                DW      RFROM,DUPP,TOR
                DW      WRITEF                  ;write header
                DW      DUPP,DOLIT,-1,XORR
                DW      QBRAN,SAVE2
                DW      DOLIT,0,CP,AT
                DW      RFROM,DUPP,TOR
                DW      WRITEF                  ;write program
                DW      DUPP,DOLIT,-1,XORR
                DW      QBRAN,SAVE2
                DW      RFROM,CLOSE             ;ok. close file
                DW      EXIT
SAVE2:          DW      RFROM,DROP              ;write error
SAVE3:          DW      DOLIT,'?',EMIT,CR,ABORT ;create error

                
;; Hardware reset

;   hi		( -- )
;		Display the sign-on message of eForth.

		$COLON	2,'hi',HI
                DW      CR,DOTQP          ;initialize I/O
                DB      13,'86eForth v',VER+'0','.',EXT+'0'     ;version
		DW	CR,EXIT

;   'BOOT       ( -- a )
;               The application startup vector.

		$COLON  5,"'BOOT",TBOOT
		DW      DOVAR
		DW      HI                      ;application to boot

;   COLD	( -- )
;		The hilevel cold start sequence.

		$COLON	4,'COLD',COLD
COLD1:		DW	DOLIT,UZERO,DOLIT,UPP
		DW	DOLIT,ULAST-UZERO,CMOVE	;initialize user area
		DW	PRESE			;initialize data stack and TIB
		DW      TBOOT,ATEXE             ;application boot
                DW      OVERT
		DW	QUIT			;start interpretation
		DW	BRAN,COLD1		;just in case

;===============================================================

LASTN           =       _LINK                   ;last name address in name dictionary

CTOP            EQU     $                       ;next available memory in code dictionary

MAIN		ENDS

END	ORIG

;===============================================================