Borland Programmer's Resource

home *** CD-ROM | disk | FTP | other *** search

/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / jax4th.i < prev next >

Wrap

Text File | 1995-05-19 | 12.1 KB | 441 lines

; jax4th.inc ... 32-bit ANS Forth for Windows NT ; copyright (c) 1993, 1994 by jack j. woehr ; p.o. box 51, golden, co 80402-0051 ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com ; sysop, rcfb (303) 278-0364 COMMENT ! This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (doc\license.txt) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ ! ;-----------------------; ; Register equates ; ;-----------------------; ip textequ <esi> ; Forth instruction pointer dsp textequ <esp> ; Forth data stack pointer rp textequ <ebp> ; Forth return stack pointer wp textequ <eax> ; Indirect-threading word pointer cp textequ <edi> ; Pointer to user dictionary dp textequ <ebx> ; Pointer to data space ;---------------; ; Constants ; ;---------------; ; Scaling tchar equ 2 ; Unicode characters cell equ 4 ; 32-bit Forth, byte-addressing processor ; Boolean TRUE equ 0FFFFFFFFH FALSE equ 0 ; Chars UniNotAChar equ 0FFFFH ; illegal Unicode char cRet equ 000DH ; carriage return lFeed equ 000AH ; line feed ;---------------; ; Bit Masks ; ;---------------; immedMask equ 8000H ; in name count word, marks word as immediate allNameMasks equ immedMask ; all non-count bits used in name count word userdictbit equ 31 userdictmask equ 80000000H ;-----------------------; ; System factors ; ;-----------------------; dStackSize equ 4000H ; half for data stack rStackSize equ 4000H ; half for return stackstackSize equ dStackSize + rStackSize ; complete stack allocation, as requested in linker statement in makefile defDataSize equ 10000H ; default data space size defDictSize equ 10000H ; default user dictionary size tibsize equ 256 ; terminal input buffer size searchOrderSize equ 8 ; max wordlists in search order blockSize equ 1024 ; number of chars in a BLOCK rlbuffsize equ tibsize ; maximum chars for READ-LINE is same as TIB for now ;---------------; ; Error Returns ; ;---------------; userErr equ 2000000H ; No Windows API error code has bit 29 set ( 0x20000000) ;---------------; ; Macros ; ;---------------; ;--( System Macros ) ; Embed a string as Unicode unicode macro aString irpc x,<aString> db '&x',0 ;; assemble as little-endian double-byte char endm endm ;--( Code Macros ) ; Store to a Forth VARIABLE offset from assembly store macro dataOffset,source mov DWORD PTR [dp+dataOffset],source endm ; Fetch From a Forth VARIABLE offset from assembly fetch macro dest,dataOffset mov dest,DWORD PTR [dp+dataOffset] endm ;--( Dictionary Macros ) ; Assign offsets in data space for Forth variables. varptr = 0 ; an allocation pointer avar macro varName varName = varptr varptr = varptr+cell endm ; Assembly-time allocation of data space by cells allotCells macro aName,numCells aName = varptr varptr = varptr + (numCells*cell) endm ; Back-links at head of various wordlists, single-threaded flinkptr = 0 ; FORTH-WORDLIST Standard words zlinkptr = 0 ; INTERNALS-WORDLIST Internals nlinkptr = 0 ; NONSTANDARD-WORDLIST Non-standard Forth words slinkptr = 0 ; SYSTEM-WORDLIST System calls, etc. linkme macro linkpointer align cell dd linkpointer ;; embedded back-link linkpointer = $-cell ;; point to address at which link pointer was compiled endm ; Create a count DWORD consisting of 0xFFFF followed by the character count so that an unambguous marker may be ; found when searching back from the CFA. countcell macro aCount align cell dw 0FFFFH dw aCount endm ; Create a non-IMMEDIATE name header consisting of count char and name chars. ; Mostly called by macro NAME, but this factoring is necessary because of chars like * / # in Forth names. namemanque macro aName,linkpointer linkme linkpointer namecntr = 0 irpc x,aName namecntr = namecntr+1 endm countcell namecntr unicode aName align cell endm ; Create a non-IMMEDIATE name header consisting of count char and name chars as above, ; but also define a token label for it. This is the normal call. NAYME is spelled funny because NAME is MASM keyword. nayme macro aName,linkpointer namemanque aName,linkpointer fw_&aName: endm ; Create an IMMEDIATE name header consisting of count char and name chars. ; Mostly called by macro INAME, but this factoring is necessary because of chars like * / # in Forth names. inamemanque macro aName,linkpointer linkme linkpointer namecntr = 0 irpc x,aName namecntr = namecntr+1 endm countcell <namecntr or immedMask> unicode aName align cell endm ; Create an IMMEDIATE name header consisting of count char and name chars as above, ; but also define a token label for it. This is the normal call. iname macro aName,linkpointer inamemanque aName,linkpointer fw_&aName: endm ; Create non-IMMEDIATE header for FORTH-WORDLIST fname macro aName nayme aName,flinkptr endm ; Create an IMMEDIATE header for FORTH-WORDLIST finame macro aName iname aName,flinkptr endm ; Create non-IMMEDATE header without label for FORTH-WORDLIST fnamemanque macro aName namemanque aName,flinkptr endm ; Create IMMEDIATE header without label for FORTH-WORDLIST finamemanque macro aName inamemanque aName,flinkptr endm ; Create non-IMMEDIATE header for INTERNALS-WORDLIST zname macro aName nayme aName,zlinkptr endm ; Create an IMMEDIATE header for INTERNALS-WORDLIST ziname macro aName iname aName,zlinkptr endm ; Create non-IMMEDATE header without label for INTERNALS-WORDLIST znamemanque macro aName namemanque aName,zlinkptr endm ; Create IMMEDIATE header without label for INTERNALS-WORDLIST zinamemanque macro aName inamemanque aName,zlinkptr endm ; Create non-IMMEDIATE header for NONSTANDARD-WORDLIST nname macro aName nayme aName,nlinkptr endm ; Create an IMMEDIATE header for NONSTANDARD-WORDLIST niname macro aName iname aName,nlinkptr endm ; Create non-IMMEDATE header without label for NONSTANDARD-WORDLIST nnamemanque macro aName namemanque aName,nlinkptr endm ; Create IMMEDIATE header without label for NONSTANDARD-WORDLIST ninamemanque macro aName inamemanque aName,nlinkptr endm ; Create non-IMMEDIATE header for SYSTEM-WORDLIST sname macro aName nayme aName,slinkptr endm ; Create an IMMEDIATE header for SYSTEM-WORDLIST siname macro aName iname aName,slinkptr endm ; Create non-IMMEDATE header without label for SYSTEM-WORDLIST snamemanque macro aName namemanque aName,slinkptr endm ; Create IMMEDIATE header without label for SYSTEM-WORDLIST sinamemanque macro aName inamemanque aName,slinkptr endm ; Assemble execution token into a Forth definition ; Kernel tokens are flat addresses ctok macro aName dd fw_&aName ;; for kernel tokens endm ;--( Execution Macros ) ; Push an item on the return stack pushrp macro source sub rp,cell mov [rp],source endm ; Pop an item from the return stack and discard poprp macro add rp,cell endm ; Pop an item for the return stack to a destination poprpto macro dest mov dest,[rp] poprp endm ; The Forth NEXT routine ; User dict tokens are distinguised from kernel tokens by their "odd"-ness. ; Here is the inner next routine once WP is loaded with a token: innext macro ;; on entry, WP already contains token found by instruction pointer local kerntok,kernex btr wp,userdictbit ;; user dict tokens are (addr|userdictbit)-cp jnc SHORT kerntok add wp,cp ;; add base kerntok: mov edx,[wp] ;; deference indirect pointer to execution engine btr edx,userdictbit ;; user pointers to kern exe engines are (addr|userdictbit) - cp jnc SHORT kernex add edx,cp ;; add base kernex: jmp edx endm ; Here is the entire next routine: next macro lodsd ;; WP (EAX) := @IP++ innext ;; execute the token in WP endm ; Used by conditionals compiled in user dictionary .. token is in WP dereftok macro local kerntok btr wp,userdictbit ;; user dict tokens are (addr|userdictbit)-cp jnc SHORT kerntok add wp,cp ;; add base kerntok: endm ;--( Compilation Macros ) docode macro dd $+cell endm defers macro ;; value must be init'ed at boot time ctok DODEFER dd varptr varptr = varptr + cell endm literal macro aLit ctok DOLIT dd aLit endm charlit macro aChar ;; accepts ASCII only ctok DOLIT db aChar,0,0,0 endm compif macro aLabel ;; also WHILE ctok DOIF dd aLabel endm compelse macro aLabel ;; also REPEAT AGAIN ctok DOELSE dd aLabel endm compuntil macro aLabel ctok DOUNTIL dd aLabel endm compdo macro aLabel ctok DODO dd aLabel endm comploop macro aLabel ctok DOLOOP dd aLabel endm compqdo macro aLabel ctok DOQDO dd aLabel endm compplloop macro aLabel ctok DOPLUSLOOP dd aLabel endm ;-----------------------; ; Forth Data Space ; ;-----------------------; ;--( Variables ) avar lastCatch ; holds catch frame pointer avar lastCaught ; holds IP pointing to cell following THROW avar conMode ; Holds Console Mode avar lastError ; TRUE for no error or an error code after funcalls avar outChar ; hold one char for output avar ntConEBP ; holds value of EBP from startup avar ntConESP ; holds value of ESP from startup avar rpzero ; holds Forth's initial setting of RP avar memHandle ; pointer to allocated memory block avar stdIn ; Console handle avar stdOut ; Console handle avar stdErr ; Console handle avar datap ; Returned by HERE avar dictp ; Dictionary space pointer avar flinkp ; Last FORTH-WORDLIST link avar zlinkp ; Last INTERNALS-WORDLIST link avar nlinkp ; Last NONSTANDARD-WORDLIST link avar slinkp ; Last SYSTEM-WORDLIST link avar wllink ; points to last wordlist in chain avar endq ; TRUE when input stream found to be at end in FIND avar nonaming ; TRUE if the current definition was initiated by :NONAME avar var_hld ; used by <# # #S HOLD #> avar var_state ; STATE variable avar var_blk ; BLK variable avar var_scr ; SCR variable avar var_srcid ; SOURCE-ID variable avar var_numtib ; #TIB variable avar var_tib ; 'TIB variable avar var_to_in ; >IN variable avar var_base ; BASE variable avar var_dpl ; DPL variable, holds position of "dot" (.) in number input avar last ; holds link token of last entry added to dictionary avar cstack ; saved stack pointer during compilation avar current ; current compilation wordlist avar blockFile ; holds handle for active BLOCK file avar blockNum ; holds number of block in buffer avar updated ; TRUE if block has been updated avar inDefinition ; TRUE if compiling a : (colon) or :NONAME definition avar var_ferror ; holds error from last bum file operation ;--( Larger Items ) allotCells searchOrder,searchOrderSize ; search order array ;--( Buffers ) allotCells wordBuffer,(256*tchar)/cell ; holds result of WORD allotCells stringBuffer,(256*tchar)/cell ; holds result of interpretive S" allotCells asciizBuffer,256/cell ; holds converted asciiz strings for syscalls allotCells blockBuffer,(blockSize*tchar)/cell ; our single block buffer allotCells ticktib,(tibsize*tchar)/cell ; input buffer allotCells tickpad,(128*tchar)/cell ; pad buffer allotCells tickftib,(tibsize*tchar)/cell ; file input buffer allotCells ticknum,(128*tchar)/cell ; numeric output conversion buffer ticknumend equ varptr ; end of numeric conversion buffer allotCells rlBuffer,((rlbuffsize+2)*tchar)/cell ; READ-LINE buffer, 256 + 2 for EOL chars allotCells zeroBuffer,(tibsize*tchar)/cell ; CREATE-FILE needs a zero-pad buffer ; Can't expect the user to do it. ; END of jax4th.i