home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-02-06 | 93.8 KB | 2,300 lines |
- \ COMPILE.SEQ Compiler test code by Tom Zimmer
-
- comment:
-
- An optimizing target compiler for the Public Domain Forth
- system F-PC by Tom Zimmer.
-
- Released to the Public Domain this date 10/11/89 by the
- author Tom Zimmer.
-
-
- comment;
-
- only forth also definitions hidden also
-
- \ ***************************************************************************
- \ Buffered printing words to increase performance when creating a listing
- \ ***************************************************************************
-
- 2048 constant pr_max
- create pr_buf pr_max 2+ allot
- 0 value pr_cnt
-
- : buf_prinit ( -- ) \ initialize the print buffer
- pr_buf pr_max blank
- off> pr_cnt ;
-
- : buf_prflush ( -- ) \ flush the contents of the print
- \ buffer to printer
- ?cs: pr_buf pr_cnt prntypel
- off> pr_cnt ;
-
- : buf_premit ( c1 -- ) \ put char c1 in print buffer
- pr_cnt pr_max >=
- if buf_prflush
- then
- pr_buf pr_cnt + c!
- incr> pr_cnt
- incr> #out ;
-
- : buf_prtypel ( seg a1 n1 -- ) \ type text to print buffer from
- \ far segment location
- pr_cnt over + pr_max >=
- if buf_prflush
- then
- >r ?cs: pr_buf pr_cnt + r@ cmovel
- r@ +!> pr_cnt
- r> +!> #out
- \u ?.prlines ?.prlines
- ;
-
- only forth also
-
- \ ***************************************************************************
- \ Create some aliases to allow their use while in the compiler
- \ ***************************************************************************
-
- ' forth alias [forth] immediate
- ' assembler alias [assembler] immediate
- vocabulary target ' target alias [target] immediate
- vocabulary htarget ' htarget alias [htarget] immediate \ h = HIDDEN
- vocabulary compiler ' compiler alias [compiler] immediate
- defer tversion ' noop is tversion
- compiler also definitions
-
- ' here alias fhere \ make fhere an alias for HERE
- \u sys ' sys alias /dos
-
- defer "errmsg2
-
- defined ?.#dis nip 0=
- #if
- ' 2drop alias ?.#dis \ if no disassembler, then discard params
- #then
-
- \ ***************************************************************************
- \ Target assembly and access words
-
- $1000 value codesegs \ max size of target program space 64k
-
- $100 value code-start \ start of compiled code
- $000 value data-start \ start of compiled data
- variable dp-t code-start dp-t ! \ target dictionary pointer
- variable dp-d data-start dp-d ! \ target DATA dictionary pointer
- 0 value seg-code \ target origin code segment
- $FFFF value ram-seg \ physical segment in target of ram
- \ $FFFF signifies whole system is
- \ ram based, and no move from ROM
- \ is needed at initialization time.
- $00 value target-origin \ origin in memory for target code
- $C000 value data-origin \ origin in memory for target data
- $FFEE value rptop \ where we will initialize return stk
- $100 value rpsize \ return stack size in bytes
- 0 value >in-t \ a place to save >IN
- 5 value data-seg+ \ Offset to the instruction that
- \ adjusts DS to where data really is.
- 0 value cold_start \ Offset to CALL instruction to
- \ out cold entry point in application
-
- : /code-start ( | <addr> -- ) \ set target CODE starting address
- bl word number drop =: code-start ;
-
- : /code-limit ( | <addr> -- ) \ set max size of CODE compiled
- bl word number drop =: data-origin ;
-
- : /data-start ( | <addr> -- ) \ set target data starting address
- bl word number drop =: data-start ;
-
- : /ram-start ( | <addr> -- ) \ set the segment in target memory
- \ where ram really is, data is them
- \ moved into that ram from ROM
- bl word number drop =: ram-seg ;
-
- : /ram-end ( | <n1> -- ) \ set amount of available ram
- bl word number drop =: rptop ;
-
-
- ' DP-T @REL>ABS CONSTANT 'DOVAR \ pointer to DOVAR
-
- \ ***************************************************************************
- \ Target CODE space memory operators
-
- : ?sizecheck ( -- )
- dp-t @ data-origin u>
- if 0 " TOO MUCH CODE!" "errmsg2 abort then
- dp-d @ $FD00 data-origin - u>
- if 0 " TOO MUCH STATIC DATA!" "errmsg2 abort then ;
-
- defer c!-t \ defered for flexibility with Mike Mayo's index compiler
- defer !-t
- defer c,-t
- defer ,-t
-
- : cs: ( taddr -- taddr tseg ) seg-code swap ;
- : erase-t ( a1 n1 --- ) >r cs: r> 0 lfill ;
- : there ( taddr -- addr ) target-origin + ;
- : c@-t ( taddr -- char ) there cs: c@l ;
- : @-t ( taddr -- n ) there cs: @l ;
- : %c!-t ( char taddr -- ) there cs: c!l ;
- : %!-t ( n taddr -- ) there cs: !l ;
- : here-t ( -- taddr ) dp-t @ ;
- : allot-t ( n -- ) dp-t +! ;
- : %c,-t ( char -- ) here-t c!-t 1 allot-t ;
- : %,-t ( n -- ) here-t !-t 2 allot-t ;
- : s,-t ( addr len -- ) 0max 0 ?do count c,-t loop drop ;
- : cset-t ( n1 addr -- ) dup c@-t rot or swap c!-t ;
-
- ' %c!-t is c!-t \ link defered functions to defered word
- ' %!-t is !-t
- ' %c,-t is c,-t
- ' %,-t is ,-t
-
- : %data-seg-fix ( -- )
- here-t paragraph 16 * dp-t ! \ paragraph align here
- data-seg+ @-t $E4F6 - \ verify SYSINIT compiled
- \ and is NOT changed
- if 0 " TARGET-INIT MUST be first in TARGET" "errmsg2
- abort
- then
- here-t paragraph \ calc end of CODE used
- data-seg+ !-t ; \ set real DATA seg offset
-
- defer data-seg-fix
-
- ' %data-seg-fix is data-seg-fix \ install default function
-
- \ ***************************************************************************
- \ Target DATA space memory operators
-
- : here-d ( -- taddr ) dp-d @ ;
- : allot-d ( n -- ) dp-d +! ;
- : dhere ( taddr -- addr ) data-origin + ;
- : @-d ( taddr -- n ) dhere cs: @l ;
- : c@-d ( taddr -- c1 ) dhere cs: c@l ;
- : c!-d ( char taddr -- ) dhere cs: c!l ;
- : !-d ( n taddr -- ) dhere cs: !l ;
- : c,-d ( char -- ) here-d c!-d 1 allot-d ;
- : ,-d ( n -- ) here-d !-d 2 allot-d ;
- : s,-d ( addr len -- ) 0max 0 ?do count c,-d loop drop ;
-
- : dp-set ( -- ) \ adjust target DP to next free data space
- here-d 0 !-d ; \ DP is always at address zero (0) in target
-
- ' here-t alias here \ HERE is now a target word.
- \ Use fhere for host if you need it.
-
- 0 value ?targeting
-
- : >TARGET-MEM ( -- )
- ?targeting ?exit
- [ASSEMBLER]
- ['] c,-t is c,
- ['] ,-t is ,
- ['] c@-t is tc@
- ['] @-t is t@
- ['] c!-t is tc!
- ['] !-t is t!
- ['] here-t is here
- on> ?targeting ;
-
- : >FORTH-MEM ( -- )
- ?targeting 0= ?exit
- [forth] ['] c, [assembler] is c,
- [forth] ['] , [assembler] is ,
- [forth] ['] c@ [assembler] is tc@
- [forth] ['] @ [assembler] is t@
- [forth] ['] c! [assembler] is tc!
- [forth] ['] ! [assembler] is t!
- [forth] ['] fhere [assembler] is here
- off> ?targeting ;
-
- \ ***************************************************************************
- \ Target segment list creation and maintenance words for CODE & DATA
-
- \ SEGMENTS array
- \
- \ +0 +2 +4 +6
- \ nxt-code-ptr, xxxxxxxx, nxt-data-ptr, xxxxxxxx
- \ \ \
- \ (points to) (data chain same as code chain)
- \ \
- \ \ +0 +2 +4
- \ (segment)-> nxt-code-ptr, start-code, end-code
- \ \
- \ \ +0 +2 +4
- \ (segment)-> nxt-code-ptr, start-code, end-code
- \ \
- \ \
- \ 0 (zero)
- \
- \ ***************************************************************************
-
- create segments 8 allot \ an array to hold the code and
- segments 8 erase \ data segment pointer chain
-
- : end-cseg ( -- )
- segments 2+ @ ?dup \ if prev seg not NULL
- if here-t swap 4 + ! \ save end addr in struct
- then ;
-
- : cseg ( a1 | <name> -- ) \ create memory CODE segments words
- create fhere segments @ ,
- segments ! \ link into segment list
- ( +2 ) dup , \ start of segment
- ( +4 ) , \ current address in segment
- does> end-cseg
- dup segments 2+ ! \ link me into segments
- 4 + @ dp-t ! ; \ set HERE-T to my segment
-
- : end-dseg ( -- )
- segments 6 + @ ?dup \ if prev seg not NULL
- if here-d swap 8 + ! \ save end addr in struct
- then ;
-
- : dseg ( a1 | <name> -- ) \ create memory DATA segments words
- create fhere segments 4 + @ ,
- segments 4 + ! \ link into segment list
- ( +2 ) dup , \ start of segment
- ( +4 ) , \ current address in segment
- does> end-dseg
- dup segments 6 + ! \ link me into segments
- 4 + @ dp-d ! ; \ set HERE-T to my segment
-
- \ ***************************************************************************
- \ Target image save function
-
- handle targethndl
-
- forth definitions
-
- DEFER TARGET-INITIALIZE
-
- 0 value #unres
- 0 value cerrors
- 0 value does-addr
- handle image.name
- handle symbol.name
- handle listing.name
- handle lines.name
- create image.ext ," COM" 0 , \ default to .COM extension
-
- : set.filenames ( -- ) \ set the filenames for various files
- seqhandle image.name $>handle image.ext image.name $>ext
- seqhandle symbol.name $>handle " SYM" ">$ symbol.name $>ext
- seqhandle listing.name $>handle " LST" ">$ listing.name $>ext
- seqhandle lines.name $>handle " LIN" ">$ lines.name $>ext ;
-
- : ?cerrors ( -- f1 )
- cerrors dup
- if cr ." \3 Image not saved \2 COMPILE ERRORS! "
- cr here-t code-start -
- here-d data-start - + 5 .r ." Bytes compiled" cr
- then ;
-
- : %save-image.com ( | -- )
- [compiler]
- ?cerrors ?exit
- #unres
- if cr ." \3 Image not saved \0, some symbols \2 UNRESOLVED! "
- cr here-t code-start -
- here-d data-start - + 5 .r ." Bytes compiled"
- else image.name targethndl $>handle
- targethndl hcreate \ make image.com
- if 0 " Error while creating executable file." "errmsg2
- abort
- then
- cr cr ." Created executable file - " targethndl count type
- data-seg-fix \ adjust HERE-T and fix
- \ DATA segment alignment
- dp-set \ set targets DP
- code-start here-t over - dup>r
- targethndl seg-code exhwrite r> - \ write CODE
- if 0 " Error while saving CODE to executable file."
- "errmsg2 abort
- then
- cr ." Wrote " here-t code-start - dup>r 5 u.r
- ." Bytes of CODE rounded up to Paragraph."
- data-origin here-d
- targethndl seg-code exhwrite here-d -
- if 0 " Error while saving DATA to executable file."
- "errmsg2 abort
- then
- cr ." Wrote " here-d data-start - 5 u.r ." Bytes of DATA, "
- here-d r> + 5 u.r ." Bytes total.
- then cr ;
-
- DEFER SAVE-IMAGE.COM ' %SAVE-IMAGE.COM IS SAVE-IMAGE.COM
-
- compiler definitions
-
- \ ***************************************************************************
- \ Initialize the target compiler code space and link in the new target words
- \ to the assembler.
-
- : tseg_init ( -- ) \ switch assembler to target space
- \u unedit unedit
- seg-code 0= \ allocate the space needed for
- \ the target compile process
- if codesegs alloc 8 = memchk nip \ allocate DOS memory
- dup =: seg-code \ init SEG-CODE
- 0 codesegs $010 * 1- 0 lfill \ Zero out area
- \u dumpseg seg-code =: dumpseg \ preset dumpseg
- then
- [assembler] \ assembler defered words
- global_ref \ use global references
- >TARGET-MEM ;
-
- \ ***************************************************************************
- \ Mark the current CODE dictionary address as the current cold program
- \ entry point.
-
- : %set_cold_entry ( -- ) \ mark HERE-T as the cold entry point
- here-t cold_start - 2-
- cold_start !-t ;
-
- DEFER SET_COLD_ENTRY ' %SET_COLD_ENTRY IS SET_COLD_ENTRY
-
- \ ***************************************************************************
- \ Automatic local variable generator for assembler macros
-
- 0 value br# \ branch label depth
-
- : 0br# ( -- )
- off> br# ;
-
- : +br# ( -- n1 )
- br#
- incr> br# ;
-
- : -br# ( -- n1 )
- decr> br#
- br# dup 0<
- if 0 " Attempt to resolve an branch label" "errmsg2
- abort
- then ;
-
- \ ***************************************************************************
- \ Compiler control words
-
- variable ?fnddoes> \ dis CREATE DOES> have a DOES> portion?
-
- 0 value ?unres \ unresolved flag
- 0 value ?lib \ library flag
- 0 value ?0opt1
- 0 value ?opt
- 0 value ?lst
- 0 value ?show
- 0 value ?definit
- true value ?bye
- 0 value opt_limit
- 0 value ?quiet
- 0 value ?interpretive
-
- : /opt ( -- ) \ enable optimization for this compile
- on> ?opt
- on> ?0opt1 ;
-
- : /optoff ( -- ) \ disable optimization for this compile,
- \ this is the default mode
- off> ?opt
- off> ?0opt1 ;
-
- ' /optoff alias /noopt
-
- : .?opt ( -- )
- cr >rev ." Status of ?OPT is " ?opt . >norm cr ;
-
- /optoff
-
- : opt_off1 ( -- ) \ turn off the optimizers for a while
- \ after compiling a branch destination
- off> ?opt
- here-t 1- =: opt_limit ;
-
- : ?reopt ( -- ) \ re-enable the optimizers if they were
- \ turned off for a while
- ?0opt1 =: ?opt ;
-
- : /definit ( -- ) \ include the TYPE & SPACES initialization
- \ code in the compiled image file
- on> ?definit ;
-
- : /definitoff ( -- ) \ don't initialize TYPE and SPACES
- ?interpretive ?exit
- off> ?definit ;
-
- ' /definitoff alias /noinit
-
- /definit
-
- : check_/noinit ( -- ) \ verify the /NOINIT option is in effect
- ?definit
- if cr beep
- cr seqhandle count type
- ." should be used with the /NOINIT option."
- cr cr beep
- then ;
-
- : check_/definit ( -- ) \ verify the /DEFINIT option is in effect
- ?definit 0=
- if cr beep
- cr seqhandle count type
- ." should be used with the /DEFINIT option."
- cr cr beep
- then ;
-
- : /lst ( -- ) \ enable the creation of a listing file
- \unless /code /code \ include output code
- \unless /src /src \ and source code
- on> ?lst ;
-
- ' /lst alias /list
-
- : /lstoff ( -- ) \ don't build a listing file
- off> ?lst ;
-
- ' /lstoff alias /nolst
- ' /lstoff alias /nolist
- ' /lstoff alias /listoff
- ' showlines alias /src
- ' hidelines alias /srcoff
- ' hidelines alias /nosrc
-
- /srcoff
- /lstoff
-
- : /show ( -- ) \ show the symbols on the screen as they
- \ are compiled
- on> ?show ;
-
- ' /show alias /sho
-
- : /showoff ( -- ) \ don't show the symbols on the screen
- \ as they are compiled. This is the default
- \ mode.
- off> ?show ;
-
- ' /showoff alias /noshow
-
- /showoff
-
- : /quiet ( -- )
- on> ?quiet
- slow
- \u statoff statoff
- ;
-
- ' /quiet alias /q
-
- code #bye ( n1 -- )
- pop ax
- mov ah, # $4C
- int $21
- next end-code
-
- : newbye ( -- )
- RESTORE_VECTORS
- BYEFUNC
- cerrors #bye ;
-
- ' newbye >body @ ' bye >body ! \ link NEWBYE into BYE
-
- : /bye ( -- ) \ leave compiler after the compile
- bye ;
-
- : /stay ( -- )
- off> ?bye ;
-
- ' /stay alias /sta
-
- \u newfile : /edit ( <filename> -- ) \ edit file specified, don't compile
- \u newfile newfile bye ;
-
- \u newfile ' /edit alias /e
-
- \ ***************************************************************************
- \ Interpret the "TCOM=" string from the environment.
-
- create env$ 256 allot
-
- : env@ ( a1 n1 --- ) \ extract the command spec
- dup>r "envfind 0=
- if drop env$ off
- else r@ + envsize swap
- env$ dup clr-hcb >nam -rot
- do evseg i c@l 0= ?leave
- evseg i c@l over c! 1+
- 1 env$ c+!
- loop drop
- then r>drop ;
-
- : env_interpret ( -- )
- " TCOM=" env@ \ get the "TCOM=" string from environ
- env$ c@ 0= ?exit \ leave if nothing to interpret
- save> 'tib
- save> #tib
- save> >in
- env$ count #tib ! 'tib ! >in off \ set to interpret
- interpret \ an interpret it
- restore> >in
- restore> #tib \ restore everything
- restore> 'tib ;
-
- : tcom_path@ ( -- )
- " TPATH=" env@
- env$ count fpath$ place ;
-
- \ ***************************************************************************
- \ A display word so user has something to watch while compiling
-
- 0 value spinval
-
- : spinner ( -- )
- ?lst ?show or ?quiet or ?exit
- incr> spinval
- spinval 1 and ?exit
- at?
- " |/-\" drop spinval 2/ 3 and + 1 type
- at ;
-
- : spinner2 ( -- )
- ?lst ?show or ?quiet or ?exit
- incr> spinval
- spinval 1 and ?exit
- at? over 2+ over at
- " |/-\" drop spinval 2/ 3 and + 1 type
- spinval 7 and 0=
- if space >attrib3 space
- here-t code-start - dup 1 u.r ." _Code+"
- here-d data-start - dup 1 u.r ." _Data="
- 0 tuck d+ 1 ud.r ." _Total"
- space >norm
- then
- at ;
-
- \ ***************************************************************************
- \ Zero out one local label, so we can have more than one set of
- \ conditionals in a colon definition. Used with -BR# above.
- \ See MACRO REPEAT for an example of usage.
-
- : 01lab ( n1 -- ) \ zero out one label for re-use
- [assembler]
- a;
- llab>line b/llab erase ;
-
- : BR#SWAP ( -- ) \ exchange two most recent branch array
- \ elements.
- [assembler]
- a;
- br# 2- dup
- [forth]
- 0<
- if 0 " Attempt to resolve an branch label" "errmsg2
- abort
- then
- [assembler]
- llab>line dup>r pad b/llab 2* cmove
- pad b/llab + r@ b/llab cmove
- pad r> b/llab + b/llab cmove ;
-
- \ ***************************************************************************
- \ Define the fields of the BODY of a target compiler provided function.
- \
- \ here is the structure of a function BODY:
- \
- \ +0 +1 +6 +8 +10 +12
- \ ┌──────┬──────────┬─────────────┬───────────┬───────────┬───────────┐
- \ │ type │ JMP NEST │ res-address │ res-chain │ Ref-count │ Data-size │
- \ └──────┴──────────┴─────────────┴───────────┴───────────┴───────────┘
- \
- \ FIELD builds words that adjust to the various fields of the body
-
-
- : field ( n1 n2 -- n3 ) \ compile time
- ( a1 -- a2 )
- create over c, + \ compile offset & increment to next
- ;code pop bx \ get pointer to
- sub ax, ax \ clear AX
- mov al, 0 [bx] \ get byte field offset into AL
- add ax, # 3 \ offset to body
- mov di, sp \ get a copy of stack pointer
- add 0 [di], ax \ add AX to address on stack
- next
- end-code
-
- \ Equivelant high level code for above assembly ;code.
- \
- \ does> c@ swap >body + \ adjust a1 to field address a2
- \ \ from CFA
-
- 0 \ starting at field offset zero (0),
- \ define field operators
- 1 field >dtype \ definition type byte
- 5 field >execute \ execution address to compile word
- 2 field >resaddr \ resolution address
- 2 field >chain \ chain of unresolved references
- 2 field >count \ count of times used
- 2 field >dsize \ size of data symbol
- 2 field >dinitial \ initial value of VALUEs
- 2 field >inited \ has value been initialized yet
- drop \ cleanup stack
-
- \ ***************************************************************************
- \ Make data type constants for target objects
-
- : dtype ( n1 | <name> -- n2 )
- dup constant 1+ ;
-
- \ !!!! DO NOT CHANGE THE ORDER OF ANY OF THE FOLLOWING WORDS !!!!
- \ These constants also specify the execution order in the later "EXEC:"
- \ words LIB_COMPILE and TARG_COMPILE.
-
- 0 \ these must start with ZERO for the EXEC: in TARG_COMPILE later
- \ in this file to work properly.
-
- ( Macro ) dtype {M} \ ─┐
- ( Constant ) dtype {C} \ ├─ these MUST to be together,
- ( 2Constant ) dtype {2C} \ │ between statments are used
- ( FConstant ) dtype {F} \ ─┘ later to check for a range
- ( Data ) dtype {D} \ of types.
- ( Value ) dtype {V}
- ( Subroutine ) dtype {S}
- ( dEfer ) dtype {E}
- ( Table ) dtype {T}
- drop
-
- \ ***************************************************************************
- \ Debug support for target compiler
-
- \u (see) : tsee ( | <name> -- )
- \u (see) ' >execute (see) ;
-
- \u ldump : tdump ( a1 n1 -- )
- \u ldump seg-code -rot ldump ;
-
- \ ONLY make TDIS if the disassembler is available
-
- \unless =seg : tdis ( a1 --- ) seg-code =seg dis ;
-
- \u adebug : tdebug ( | <name> -- )
- \u adebug ' >execute adebug ;
-
- \ ***************************************************************************
- \ Symbol write routines, builds a simple symbol table for BXDEBUG.
-
- 1024 constant symwsize
- handle symhndl \ file handle for symbol writing
- create symbuf 32 allot \ symbol name buffer
- create symwbuf symwsize allot \ symbol write buffer
- 0 value symwcnt \ symbol write buffer character count
- 0 value ?sym
- 0 value ?typed \ include data type flag bit in symbol name?
- 0 value ?lin
- 0 value ?noredef \ allow redefinitions
- 0 value ?dis \ load disassembler?
- 0 value ?dbg \ load debugger?
-
- defer symheader ' noop is symheader
- defer symfooter ' noop is symfooter
- defer symwrite ' noop is symwrite
-
- : /symoff ( -- ) \ don't create a symbol table
- off> ?sym ;
-
- ' /symoff alias /nosym
-
- /symoff \ default is no symbol table file
-
- : ?symopen ( -- f1 ) \ is symbol file open, if not make it
- \ return f1=true if symbol file is open
- symhndl >hndle @ 0<
- if off> symwcnt \ reset buffer len
- symbol.name symhndl $>handle
- symhndl hcreate dup
- if 0 " Could not make symbol file." "errmsg2
- off> ?sym
- else symheader
- then 0=
- else true
- then ;
-
- : symwflush ( -- ) \ write symbol buffer contents to disk
- symwbuf symwcnt symhndl hwrite drop
- off> symwcnt ;
-
- : symbwrite ( a1 n1 -- ) \ buffered write to symbol file
- >r \ preserve len on return stk
- symwcnt r@ + symwsize >= \ write buffer full?
- if symwflush \ then flush buffer
- then
- symwbuf symwcnt + r@ cmove \ append data
- r> +!> symwcnt ; \ adj count
-
- : symcr ( -- ) \ write a CRLF to symbol file
- $0A0D sp@ 2 symbwrite drop ; \ write CRLF
-
- : symclose ( -- ) \ close the symbol file if it was open
- ?sym
- if symfooter
- symwflush \ write any remaining stuff
- symhndl hclose drop \ and close the file
- off> ?sym
- then ;
-
- : symbye ( -- ) \ function to perform when leaving forth
- symclose
- defers byefunc ;
-
- ' symbye is byefunc
-
- \ ***************************************************************************
- \ The following four words can be redefined to allow building a symbol table
- \ in a different format than is provided. You will need to know the format
- \ of the symbol table you want to generate.
-
- : %symheader ( -- ) \ write header for debugger symbol file
- ;
-
- : %symfooter ( -- ) \ write footer for debugger symbol file
- symcr
- $001A sp@ 2 symbwrite drop ; \ write Ctrl Z & null
-
- : %symwrite ( a1 -- a1 ) \ a1 = CFA of symbol
- ?symopen
- if dup>r
- symcr
- dup >resaddr @ 0 <# # # # # #> symbwrite
- spcs 1 symbwrite
- yseg @ over >name ?cs: symbuf 32 cmovel
- symbuf c@ 31 and symbuf c!
- symbuf count + 1- dup c@ 127 and swap c!
- ?typed
- if r@ >dtype c@ dup {S} =
- swap {M} = or
- if $80 symbuf 1+ c+! then
- then r>drop
- symbuf count symbwrite
- then ;
-
- : /sym ( -- ) \ create a symbol table file for BXDEBUG
- " SYM" ">$ symbol.name $>ext \ set the file extension
- ['] %symheader is symheader \ install the defered
- ['] %symfooter is symfooter \ symbol table building
- ['] %symwrite is symwrite \ words.
- on> ?sym \ turn on symbol generation
- off> ?typed \ don't include type flag
- on> ?lin ; \ and line table generation
-
- ' /sym alias /symbols
-
- : /redefok ( -- ) off> ?noredef ;
- : /noredef ( -- ) on> ?noredef ;
-
- /noredef \ default to no redefinition allowed
-
- : /forth ( -- ) \ enable interpretive Forth in target
- on> ?interpretive
- /sym
- on> ?typed
- /definit ;
-
- : /dis ( -- ) \ enable disassembly in target
- on> ?dis
- /forth ;
-
- : /nodis ( -- ) off> ?dis ;
-
- : /debug ( -- ) \ enable debugging in target
- on> ?dbg
- /dis ;
-
- ' /debug alias /dbg
-
- : /nodebug ( -- ) off> ?dbg ;
-
- \ ***************************************************************************
- \ perform the compile
-
- : ?$fload ( a1 f1 -- f2 )
- if $fload
- else drop false
- then ;
-
- : do_ok ( -- )
- target-initialize \ initialize the target compiler
- ok \ compile the currently open file
- ?interpretive 0= ?exit
- /redefok \ allow redefinitions
- " DIS.SEQ" ">$ ?dis ?$fload
- if cr ." Couldn't open " seqhandle count type
- ." , no disassembler will be available."
- then
- " TDEBUG.SEQ" ">$ ?dbg ?$fload
- if cr ." Couldn't open " seqhandle count type
- ." , no debugger will be available."
- then
- " TFORTH.SEQ" ">$ $fload
- if cr ." Couldn't open " seqhandle count type
- ." , can't append a Forth environment."
- then ;
-
- \ ***************************************************************************
-
- 0 value prevline
- handle linhndl
-
- : /lin ( -- )
- on> ?lin ;
-
- : /linoff ( -- )
- off> ?lin ;
-
- : ?linopen ( -- )
- linhndl >hndle @ 0<
- if lines.name linhndl $>handle
- linhndl hcreate
- if 0 " Could not make lines file." "errmsg2
- off> ?lin
- then
- -1 =: prevline
- then ;
-
- : linclose ( -- ) \ close the lines file if it was open
- ?lin
- if $0A0D sp@ 2 linhndl hwrite 2drop
- $001A sp@ 2 linhndl hwrite 2drop
- linhndl hclose drop \ and close the file
- off> ?lin
- then ;
-
- : linbye ( -- ) \ function to perform when leaving forth
- linclose
- defers byefunc ;
-
- ' linbye is byefunc
-
- : line->srcfile ( -- )
- ?lin 0= ?exit
- prevline loadline @ = ?exit \ leave if already written
- ?linopen
- save> base hex
- here-t 0 <# bl hold # # # # #> linhndl hwrite drop
- loadline @ 1 =
- if seqhandle count linhndl hwrite drop
- then
- loadline @ =: prevline
- $0A0D sp@ 2 linhndl hwrite 2drop
- restore> base ;
-
- : srcrun ( -- )
- line->srcfile
- defers interpret ;
-
- ' srcrun is interpret
-
- : srcloading ( -- a1 ) \ to be plugged into LOADING of comment
- \ functions.
- line->srcfile
- loading ;
-
- ' srcloading ' <comment:> >body @ xseg @ + 0 !L \ fix COMMENT:
- ' srcloading ' <.comment:> >body @ xseg @ + 0 !L \ fix .COMMENT:
- ' srcloading ' <#if> >body @ xseg @ + 0 !L \ fix #IF
-
- \ ***************************************************************************
- \ output error messages
-
- true
- \u >pathend" drop false \ load following if >PATHEND" not defined
- #IF
- : >pathend" ( a1 --- a2 n1 ) \ return a2 and count=n1 of filename
- count
- begin 2dup '\' scan ?dup
- while 2swap 2drop 1 -1 d+
- repeat drop ;
- #ENDIF
-
- : "errmsg ( cfa a1 n1 -- ) \ display error message
- [ hidden ]
- cr seqhandle >pathend" type \ display filename
- ." (" loadline @ 1 .r ." ) " \ and line number where found
- rot ?dup \ display cfa if non-zero
- if dup >name .id ." at " h.
- else fhere count type space
- then type \ display message
- incr> cerrors ; \ bump found error count
-
- ' "errmsg is "errmsg2
- \u "errmsg3 ' "errmsg is "errmsg3
-
- \ ***************************************************************************
- \ Make a header in target
-
- 0 value ?header
-
- : /header ( -- ) \ enable building headers in target
- on> ?header ;
-
- : /nohead ( -- ) \ disable building headers in target
- off> ?header ;
-
- /nohead \ default to no headers in target
-
- defer comp_header ' drop is comp_header \ default to nothing
-
- : make_header ( a1 -- )
- ?header
- if yseg @ over >name ?cs: symbuf 32 cmovel
- symbuf c@ 31 and symbuf c!
- symbuf count + 1- dup c@ 127 and swap c!
- symbuf comp_header
- then drop ;
-
- \ ***************************************************************************
- \ Create a new symbol of type c1.
-
- : new_symbol ( c1 -- ) \ add a new symbol of type c1 to symbol list
- current @ context ! \ initialize things
- create
- ( c1 ) c, \ +0 type BYTE "C"all
- !csp \ save stack
- 233 C, \ +1 BYTE JMP
- >nest fhere 2+ - , \ +2 WORD DOCOL relative
- xhere paragraph + dup xdpseg ! \ align LIST
- xseg @ - , \ +4 WORD LIST relative
- xdp off ; \ reset OFFSET
-
- \ ***************************************************************************
- \ Display a symbol
-
- : %.asymbol ( a1 -- ) \ a1 = CFA of symbol
- save> base hex
- @> .inst ['] noop <>
- if cr
- dup >resaddr @ 0 <# # # # # #> type
- space 7 0 do ." -----" loop space
- dup >name .id
- else ?show
- if ?cr
- dup >resaddr @ 0 <# # # # # #> type
- 2 spaces dup >name .id
- tab
- then
- then ?sym
- if symwrite
- then drop
- restore> base spinner2 ;
-
- defer .asymbol ' %.asymbol is .asymbol
-
- \ ***************************************************************************
- \ Display a macro name when used
-
- : ?.macro ( a1 -- ) \ a1 = CFA of symbol
- @> .inst ['] noop <>
- if cr ." --M-- "
- dup >name .id
- then drop ;
-
- \ ***************************************************************************
- \ Stack for items to be resolved at the end of the current definition compile.
-
- 128 constant max_res \ maximum number of symbols to resolve at one time
-
- create res_stack max_res 2+ 2* allot
- res_stack max_res 2+ 2* erase \ clear stack
-
- 0 value resptr \ resolution stack pointer
-
- : >res ( a1 -- ) \ add symbol a1 to symbols to be resolved
- res_stack resptr + !
- resptr 2+ max_res 2* >
- if 0 " Exceeded allowed depth of Resolution Stack!"
- "errmsg abort
- then
- 2 +!> resptr ;
-
- : res> ( -- a1 ) \ get an item from the resolution stack
- resptr 2 <
- if 0 " Resolve Stack Underflow!" "errmsg abort
- then
- -2 +!> resptr
- resptr res_stack + @ ;
-
- : ?resdepth ( -- n1 ) \ return depth of resolution stack in items
- resptr 2/ ;
-
- \ ***************************************************************************
- \ Macro defining words. MACRO's compile IN-LINE assembly code when
- \ executed at their ">EXECUTE" address. Compiled ONLY if referenced,
- \ and EVERY time referenced.
-
- DEFER MACRO-START
-
- : MACRO ( | <name> -- )
- fhere >r
- {M} new_symbol \ +0 BYTE "M"acro
- -1 , \ +6 WORD unresolved sym
- 0 , \ +8 WORD unresolved chain
- 0 , \ +10 WORD reference count
- compile (lit) \ compile (lit)
- r> x, \ followed by addr of symbol
- compile ?.macro
- macro-start
- \ **** hide
- ] ; \ compile remaining portion
-
- DEFER END-MACRO IMMEDIATE \ see the library for this definition
-
- \ ***************************************************************************
- \ Add a symbol that is being used, but is not yet defined.
-
- : add_symbol ( a1 -- ) \ add a symbol not yet resolved
- >r \ Save a1 out of the way of !CSP
- \ in NEW_SYMBOL.
- {S} new_symbol \ +0 BYTE type "S" a SUBROUTINE
- -1 , \ +6 WORD resolved address
- r> , \ +8 WORD unresolved chain
- 0 , ; \ +10 WORD reference count
-
- \ ***************************************************************************
- \ resolve one symbol a1 to here-t
-
- 0 value ?inline
-
- DEFER RESOLVE_1 ( a1 -- )
-
- : %resolve_1 ( a1 -- ) \ resolve one reverence to HERE-T
- here-t over 2+ - swap !-T ;
-
- ' %resolve_1 is resolve_1 \ link in default resolver
-
- : res_symbol ( a1 -- ) \ resolve here-t to a1
- ?inline \ don't resolve if compiled INLINE
- if .asymbol
- else dup >resaddr @ -1 =
- if dup make_header
- here-t over >resaddr ! \ resolve symbol
- dup .asymbol
- >chain dup @ swap off \ resolve chain
- begin ?dup
- while dup @-t swap resolve_1
- \ resolve one ref
- repeat
- else drop
- then
- 0br# \ clear the branch control stuff
- clear_labels
- then ;
-
- \ ***************************************************************************
- \ Either resolve a symbol already defined, or make a new symbol if its not
- \ yet defined. Flag if already defined and resolved.
-
- 0 value tsym_bottom
-
- : do_symbol ( | <name> -- )
- >in @ >r \ save >IN for later
- defined dup
- if drop \ discard flag
- dup tsym_bottom u> \ is it a real symbol
- then
- if dup >resaddr @ -1 <> \ already resolved or
- \ its a MACRO, CONSTANT or
- \ 2CONSTANT
- over >dtype c@ {M} {F} between or
- ?noredef and
- if " Attempt to REDEFINE a symbol! " "errmsg
- else res_symbol
- then
- else drop
- r@ >in !
- fhere >r
- 0 add_symbol \ add a new symbol
- r@ make_header
- here-t r@ >resaddr ! \ resolve address
- r> .asymbol
- then r>drop ;
-
- \ ***************************************************************************
- \ When actually target compiling code, compile a call to a routine
-
- \ see the library for this definition
- DEFER COMP_CALL ( a1 -- ) \ a1 = CFA of symbol
- DEFER COMP_JMP_IMM ( a1 -- ) \ a1 = actual code addr
- DEFER SUB_RET ( -- ) \ subtract one RET instruction
-
- : compile_call ( a1 -- ) \ compile call to routine
- @> .inst ['] noop <>
- if save> base hex
- cr
- here-t 0 <# # # # # #> type 4 spaces
- ." CALL "
- dup >name .id
- restore> base
- then comp_call ;
-
- \ ***************************************************************************
- \ resolver for the data type definitions
-
- : ?dresolve ( a1 -- a1 ) \ resolve symbol if needed
- \ not CONSTANT or 2CONSTANT
- dup >dtype c@ {C} {F} between 0=
- over >resaddr @ -1 = and \ not yet resolved
- if here-d over >resaddr ! \ set start address
- dup >dsize @ allot-d \ allocate needed space
- dup .asymbol \ show symbols name
- then ; \ return address in DS:
-
- \ ***************************************************************************
- \ resolver for the TABLE type definition
-
- : ?tresolve ( a1 -- a1 ) \ resolve symbol if needed
- \ NOT CONSTANT OR 2CONSTANT
- dup >dtype c@ {C} {F} between 0=
- over >resaddr @ -1 = and \ not yet resolved
- if here-d over >resaddr ! \ set start address
- dup >dsize length s,-d \ move table to target
- dup .asymbol \ show symbols name
- then ; \ return address in DS:
-
- \ ***************************************************************************
- \ perform the in-line compiling/handling of numbers
-
- \ see the library for these definitions
- DEFER COMP_SINGLE \ compile a single precision number
- DEFER COMP_FETCH \ see library
- DEFER COMP_STORE \ see library
- DEFER COMP_PERFORM \ see library
- DEFER COMP_OFF \ see library
- DEFER COMP_ON \ see library
- DEFER COMP_INCR \ see library
- DEFER COMP_DECR \ see library
- DEFER COMP_PSTORE \ see library
- DEFER COMP_SAVE \ see library
- DEFER COMP_SAVEST \ see library
- DEFER COMP_REST \ see library
- DEFER COMP_FPUSH \ see library
-
- \ resolve and compile a single number
- : res_comp_single ( a1 -- ) \ a1 = address of symbol
- ?dresolve
- dup >count incr
- >resaddr @ comp_single ;
-
- : res_comp_double ( a1 -- ) \ compile a double number, is already
- dup >count incr \ resolved, since used only for
- dup >dinitial @ comp_single \ 2CONSTANT's
- >resaddr @ comp_single ;
-
- : res_comp_fconst ( a1 -- ) \ compile a floating constant
- dup >count incr
- dup >dinitial @ comp_single
- >resaddr @ comp_single
- comp_fpush ;
-
- : res_comp_value ( a1 -- ) \ resolve and compile single, plus
- \ move initial VALUE into target
- dup res_comp_single
- comp_fetch \ follow with a fetch
- dup >inited @ 0= \ value initialized?
- if dup >dinitial @ \ get initial value
- over >resaddr @ !-d \ store in target
- dup >inited on \ mark as initialized
- then drop ;
-
- : res_comp_defer ( a1 -- )
- res_comp_single comp_perform ;
-
- : res_comp_macro ( a1 -- )
- dup >r >execute execute r> >count incr ;
-
- : res_comp_call ( a1 -- )
- dup compile_call >count incr ;
-
- : res_comp_table ( a1 -- )
- execute comp_single ;
-
- \ ***************************************************************************
- \ These words expect a literal to follow compiled inline. They pick up the
- \ literal and pass it as a parameter to the function specified. This
- \ technique saves two bytes per occurance of the specified operation, for
- \ a savings of about 2k in the target compiler .EXE file size.
-
- : inlines ( a1 | <name> -- ) \ make words that pick up inline
- \ literals and pass them to
- \ functions as parameters
- create ,
- does> 2r@ @L r> 2+ >r swap perform ;
-
- ' res_comp_single inlines res_comp_lit
- ' res_comp_double inlines res_comp_dbl
- ' res_comp_fconst inlines res_comp_fcn
- ' res_comp_value inlines res_comp_val
- ' res_comp_call inlines res_comp_cll
- ' res_comp_defer inlines res_comp_def
- ' res_comp_table inlines res_comp_tbl
- ' comp_single inlines comp_lit
-
- \ ***************************************************************************
- \ Resolve forward references by executing the unresolved resolution stack
- \ until it is empty. As each CFA on the resolution stack is executed, its
- \ definition is compiled, possibly putting additional words on the
- \ resolution stack.
-
- : do_resolve ( -- ) \ execute the resolve stack
- ?inline ?exit
- \u ?long ?long_lib save!> ?long \ use short branches for library
- begin ?resdepth \ do it till its empty
- while res>
- dup >count incr
- dup >resaddr @ -1 =
- if >execute execute
- else drop
- then
- repeat
- \u ?long restore> ?long
- ;
-
- \ ***************************************************************************
- \ Library code routines, used for CODE definitions that are accessed by
- \ CALL rather than MACRO. An LCODE routine is only included in the
- \ target if it is referenced.
-
- DEFER LCODE-START
-
- : LCODE ( | <name> -- ) \ Library CODE routine
- fhere >r \ save here for later
- 0 add_symbol \ make a symbol not yet used
- compile (lit) \ compile (lit)
- r> x, \ followed by addr of symbol
- compile res_symbol \ resolve usage of symbol
- lcode-start
- ] ; \ compile remaining portion
-
- DEFER END-LCODE IMMEDIATE \ see the library for this definition
-
- : LLABEL ( | <name> -- ) \ Library LABEL routine
- LCODE
- does> body>
- dup >resaddr @ 0<
- if dup >chain @ swap \ link chain @ to here
- here-t 1+ over >chain ! \ link here+1 into chain
- >res \ add to resolution stack
- else >resaddr @
- then ;
-
- \ ***************************************************************************
- \ Library and Target compiler functions. These words either compile actual
- \ code into the target "TARG_COMPILE", or compiler functions into the library
- \ "LIB_COMPILE" that will LATER compile code into the target.
-
- : LIB_COMPILE ( a1 -- )
- dup >dtype c@ \ body contains TYPE byte
- case
- ( Macro ) {M} of >execute x, endof
- ( Constant ) {C} of compile res_comp_lit x, endof
- ( 2Constant ) {2C} of compile res_comp_dbl x, endof
- ( FConstant ) {F} of compile res_comp_fcn x, endof
- ( Data ) {D} of compile res_comp_lit x, endof
- ( Value ) {V} of compile res_comp_val x, endof
- ( Subroutine ) {S} of compile res_comp_cll x, endof
- ( dEfer ) {E} of compile res_comp_def x, endof
- ( Table ) {T} of compile res_comp_tbl x, endof
- ( elseof )
- drop
- " is NOT a target symbol! " "errmsg
- endcase ;
-
- : TARG_COMPILE ( a1 -- ) \ Compile a target symbol
- \ body contains TYPE byte
- dup >dtype c@ dup {M} {T} between
- if EXEC:
- ( Macro ) res_comp_macro
- ( Constant) res_comp_single
- ( 2Constant ) res_comp_double
- ( FConstant ) res_comp_fconst
- ( Data ) res_comp_single
- ( Value ) res_comp_value
- ( Subroutine) res_comp_call
- ( dEfer ) res_comp_defer
- ( Table ) res_comp_table
- else drop
- " is an invalid symbol! " "errmsg
- then ;
-
- \ ***************************************************************************
- \ Lookup a word from input stream, with auto TIB refill if needed.
-
- 0 value tcomlow \ lowest allowable target definition in TCOM
-
- : TDEFINED ( | <name> -- a1 f1 ) \ get a word from input stream
- begin @> >in =: >in-t
- bl word dup c@ 0= \ if nothing in line
- ?fillbuff \ optionally refill buffer
- while drop 0 >in !
- filltib \ refill the buffer
- line->srcfile
- #tib @ 0=
- if 0 " End of file reached while compiling!"
- "errmsg abort
- then
- spinner \ something to watch
- repeat skip'c' ?uppercase find ;
-
- : target? ( a1 f1 -- a2 f2 ) \ must be target word
- dup
- if over tcomlow u< \ found too low?
- over 0< and \ not immediate
- if 2drop here false \ not target word
- then
- then ;
-
- \ ***************************************************************************
- \ Library COLON definitions. L: words are only included in the target
- \ dictionary if they are referenced They are accessed with a CALL.
- \ No forward references are allowed while creating Library definitions.
- \ When L: words are later referenced, they are auto-resolving.
-
- DEFER START-T: ' NOOP IS START-T:
-
- : (L:) ( | <name> .. ;F -- ) \ define a function in host
- ?exec
- on> ?lib \ librarying
- fhere >r \ save here for later
- 0 add_symbol \ make a symbol not yet used
- compile (lit) \ compile (lit)
- r> x, \ followed by addr of symbol
- compile res_symbol \ resolve usage of symbol
- compile start-t: \ start a colon definition
- spinner2 \ something to look at
- ;
-
- : (LM:) ( | <name> .. ;F -- ) \ define a function in host
- ?exec
- on> ?lib \ librarying
- 0 add_symbol \ make a symbol not yet used
- spinner2 \ something to look at
- ;
-
- : (L]) ( -- )
- state on
- begin ?stack tdefined target? ?dup
- if 0>
- if execute \ execute immediate words
- else lib_compile \ compile into library
- then
- else number double?
- if swap dup
- compile comp_lit x,
- then drop
- compile comp_lit x,
- then true done?
- until off> ?lib ;
-
- : [;] ( --- ) \ turn off compiling, but don't
- \ actually compile anything.
- state @ 0=
- if 0 " Not Compiling!" "errmsg
- then
- ?csp
- [compile] [ ; immediate
-
- DEFER END-L: \ See the library for this definition
- DEFER END-LM:
-
- : L: ( | <name> -- )
- (L:) (L])
- END-L: ; immediate
-
- : LM: ( | <name> -- )
- fhere >r
- (LM:) (L])
- END-LM:
- {M} r> >dtype c! ; \ data type is macro
-
- : LALLOT ( n1 -- )
- drop
- 0 " Can't use ALLOT in the library!" "errmsg ;
-
- : LASCII ( | <letter> -- ) \ compile inline an ascii letter
- bl word 1+ c@
- compile comp_lit x, ; immediate
-
- \ ***************************************************************************
- \ A couple of variables used to determine how to resolve LOOPing branches
- \ in the compiler.
-
- VARIABLE ?DOING ?DOING OFF
- VARIABLE ?LEAVING ?LEAVING OFF
-
- \ ***************************************************************************
- \ Forward store and fetch words
-
- : ?vvd ( a1 -- <a1> f1 ) \ is it a value, variable or defered
- dup >dtype c@ \ TYPE must be
- dup {V} = \ a VALUE or
- over {D} = or \ a VARIABLE
- swap {E} = or 0= \ a DEFERed word
- if " Attempt to use !> type operator on an invalid symbol"
- "errmsg true
- else false
- then ;
-
- \ define words that pickup the following word and use it like a variable
-
- defer for_does>
-
- : %for_does> ( a1 -- )
- ' ?vvd
- if drop
- else ?lib
- if compile res_comp_lit x, @ x,
- else res_comp_single perform
- then
- then ;
-
- ' %for_does> is for_does>
-
- : for>word ( a1 | <name> -- )
- create , immediate
- does> for_does> ;
-
- \ ***************************************************************************
- \ Directs TCOM to compile the definition following inline in the current
- \ colon definition being built. INLINE only works when preceeding references
- \ to LIBRARY definitions.
- \ ***************************************************************************
-
- : INLINE ( | <name> -- )
- ' DUP >DTYPE C@ {S} =
- IF ON> ?INLINE \ make it compile inline
- >EXECUTE EXECUTE \ compile it inline
- SUB_RET
- OFF> ?INLINE \ restore NON-inline
- ELSE TARG_COMPILE
- THEN ; IMMEDIATE
-
- \ Use NO_INLINE at the beginning of LIBRARY words that have multiple
- \ exits. Note that NO_INLINE will only work in CODE words, NOT IN ICODE
- \ words. Make sure that your ICODE words DON'T HAVE MULTIPLE EXITS!
-
- : %NO_INLINE ( -- )
- ?INLINE
- IF 0 " This word cannot be used INLINE!" "errmsg
- THEN ;
-
- : NO_INLINE ( -- )
- COMPILE %NO_INLINE ; IMMEDIATE
-
- : NO_TINLINE ( -- )
- 0 " ONLY Library words can be INLINE" "errmsg ;
-
- \ ***************************************************************************
- \ New target CODE to create the proper target header and symbol.
-
- DEFER TCODE-START
-
- : TCODE ( | <name> -- ) \ a target CODE word
- fhere >r
- do_symbol
- ['] no_tinline >body @ r> >execute >body !
- \ no target inline allowed
- \ relink to error routine
- tcode-start
- ; \ "DO_SYMBOL" above marks this
- \ header as "LAST" wheather it makes
- \ a new header, or uses one that is
- \ already defined as in a forward
- \ reference resolution.
-
- : TLABEL ( | <name> -- ) \ a target LABEL word
- TCODE
- does> body> >resaddr @ ;
-
- \ ***************************************************************************
- \ Immediately compile either the CODE word or the MACRO being defined
- \ after these words ICODE, or IMACRO. If the CODE word or MACRO being
- \ defined contains no references to external symbols, then we can compile
- \ the function now and simply move the compiled code into the target when
- \ it is referenced rather than waiting until it is referenced and then
- \ compiling it into the target. Use of these words makes the target
- \ compiler somewhat faster and smaller. Again, the ICODE and IMACRO words
- \ MUST CONTAIN ONLY STRAIGHT ASSEMBLY, WITH NO EXTERNAL REFERENCES!!
-
- \ NOTE#1: The sequence "$FAEB fhere 5 - !" below is a short jump from the
- \ second CFA of the ICODE and IMACRO words to the first CFA of the
- \ ICODE and IMACRO words. In a normal CODE or MACRO word the second
- \ CFA is executed to compile the function into the target. In these
- \ words the first CFA needs to be executed to move the functions
- \ object code into the target. Thus the jump is needed for proper
- \ operation of the function.
-
- : ICODE ( | <name> -- a1 ) \ Immediate compiled Library CODE
- {S} new_symbol
- ( see NOTE#1) $FAEB fhere 5 - ! \ link target body to normal body
- \ make resolver just execute this
- \ DOES word
- -1 , \ mark unresolved sym
- 0 , \ resolution chain
- 0 , \ referenced count
- fhere 0 , \ holds length of generated CODE
- tcode-start
- \ **** hide
- does> body>
- dup >resaddr @ -1 = \ if not yet resolved
- if dup res_symbol \ resolve symbol
- here-t \ where code will lay down
- over >dsize length s,-t \ move CODE to target
- over >dsize @ ?.#dis \ dissasem a1,n1
- then >count incr ; \ bump usage
-
- : IMACRO ( | <name> -- a1 ) \ Immediate compiled Library MACRO
- {M} new_symbol
- ( see NOTE#1) $FAEB fhere 5 - ! \ link target body to normal body
- \ make resolver just execute this
- \ DOES word
- -1 , \ mark unresolved symbol
- 0 , \ unresolved resolution chain
- 0 , \ referenced count
- fhere 0 , \ holds length of generated CODE
- tcode-start
- \ **** hide
- does> body>
- dup ?.MACRO \ display MACRO name
- here-t
- over >dsize length s,-t \ move CODE to target
- over >dsize @ ?.#dis \ dissasem a1,n1
- >count incr ; \ bump usage
-
- : END-ICODE ( a1 -- ) \ complete Imm compile CODE
- [assembler]
- end-code
- fhere over - 2- swap ! ; \ store len in table header
-
- ' end-icode alias END-IMACRO ( a1 -- ) \ complete Imm compile MACRO
-
- \ ***************************************************************************
- \ Data type definitions.
-
- : VARIABLE ( | <name> -- ) \ Variable Data
- {D} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear reference counter
- 2 , \ data size of a variable
- does> body>
- ?dresolve \ resolve it if used
- dup >count incr \ bump usage
- >resaddr @ ; \ return address in DS:
-
- : 2VARIABLE ( | <name> -- ) \ Variable Data
- {D} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear reference counter
- 4 , \ data size of a 2variable
- does> body>
- ?dresolve \ resolve it if used
- dup >count incr \ bump usage
- >resaddr @ ; \ return address in DS:
-
- ' 2variable alias FVARIABLE \ a floating var is like a double var
-
- : VALUE ( n1 | <name> -- ) \ variable constant
- {V} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear reference counter
- 2 , \ data size of a value
- , \ place to hold initial value
- 0 , \ 0 = haven't initialized it yet
- does> body>
- ?dresolve \ resolve it if used
- dup >count incr \ bump usage
- dup >inited @ 0= \ if not initialized
- if dup >dinitial @ \ get initial value
- over >resaddr @ !-d \ set it in target
- dup >inited on \ mark initialized
- then
- >resaddr @ @-d ; \ return contents of
- \ address in target DS:
-
- : DEFER ( n1 | <name> -- ) \ a defered word
- {E} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear reference counter
- 2 , \ data size of a defered word
- does> drop
- 0 " Can't use target DEFERed words in interpret mode!"
- "errmsg abort ;
-
- \ As in "32 ARRAY <name>".
-
- : ARRAY ( N1 | <name> -- ) \ An Array of Data
- {D} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear referenced counter
- , \ save array size word
- does> body>
- ?dresolve \ resolve it if used
- dup >count incr \ bump usage
- >resaddr @ ; \ return address in DS:
-
- : CONSTANT ( n1 | <name> -- ) \ Literal Data
- {C} new_symbol
- , \ save constant value HIGH
- 0 , \ clear dummy unresolved chain
- 0 , \ clear reference counter
- does> body>
- dup >count incr \ bump usage
- >resaddr @ ; \ return actual value
-
- : 2CONSTANT ( d1 | <name> -- ) \ Literal double Data
- {2C} new_symbol
- , \ save constant value
- 0 , \ clear dummy unresolved chain
- 0 , \ clear reference counter
- 0 , \ clear dummy data length
- , \ save const value LOW in >DINITIAL
- does> body>
- dup >count incr \ bump usage
- dup >dinitial @
- swap >resaddr @ ; \ return actual double value
-
- forth
- defer float_pop
-
- : FCONSTANT ( d1 | <name> -- ) \ floating point constant
- {F} new_symbol
- float_pop
- , \ save constant value
- 0 , \ clear dummy unresolved chain
- 0 , \ clear reference counter
- 0 , \ clear dummy data length
- , \ save const value LOW in >DINITIAL
- does> drop
- 0 " Can't use floating constants in interpret mode!"
- "errmsg abort ;
-
- ' FCONSTANT ALIAS FCON
-
- : CREATE ( | <name> -- ) \ create a pointer to free data space
- {D} new_symbol
- here-d , \ set resolution address to here-d
- 0 , \ clear unresolved chain
- 0 , \ clear reference counter
- does> body>
- dup >count incr \ bump usage
- >resaddr @ ; \ return offset into DS:
-
- : HANDLE ( | <name> -- ) \ An array for a handle data struct
- {D} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear referenced counter
- b/hcb , \ data size is B/HCB bytes
- does> body>
- ?dresolve \ resolve it if used
- dup >count incr \ bump usage
- >resaddr @ ; \ return address in DS:
-
- \ Allow definition of a table of data in the target or library, used as
- \ follows:
- \
- \ TABLE NUMBERS
- \ 0 C, 1 C, 2 C, 3 C, 4 C,
- \ 5 C, 6 C, 7 C, 8 C, 9 C,
- \ END-TABLE
- \
- \ When "NUMBERS" is first referenced in the target, the table will be
- \ moved into the target data space, and the data address of "NUMBERS"
- \ will be compiled into the target. Later references simply compile the
- \ address of the table.
-
- : TABLE ( | <name> -- a1 ) \ Define a Table of data
- {T} new_symbol
- -1 , \ mark as unresolved symbol
- 0 , \ clear unresolved chain
- 0 , \ clear reference counter
- fhere 0 , \ leaves here on stack for later
- \ resolution by END-TABLE
- forth \ select the FORTH vocabulary
- does> body>
- ?tresolve \ resolve table when used
- dup >count incr \ bump usage
- >resaddr @ ; \ return address in DS:
-
- : END-TABLE ( a1 -- ) \ complete the definition of a table
- fhere over - 2- swap ! \ store length in table header
- target ; \ reselect target vocabulary
-
- \ ***************************************************************************
- \ This word is used to follow target library definitions that need to have
- \ an interpret time function.
- \ See the 11/25/89 note in TCOM.TXT for a usage example.
-
- : EXECUTES> ( | <name> -- ) \ make word do name
- LAST @ NAME>
- DUP @REL>ABS 'DOVAR <>
- OVER >DTYPE C@ {E} <> AND \ not a DEFERED word
- if " Is an ICODE/IMACRO word, can't use EXECUTE>"
- "errmsg
- also forth ' drop previous beep exit
- then dup 1+
- fhere over - 2- swap ! \ make it jump to new function
- 233 SWAP C! \ change CALL to JMP
- ?TARGETING >R
- SETASSEM
- >FORTH-MEM \ set to assemble for FORTH memory
- [ASSEMBLER]
- MOV AX, # ALSO FORTH ' PREVIOUS \ lookup word following
- JMP AX
- END-CODE
- [FORTH]
- R> \ if we were targeting, back to TARGET
- IF >TARGET-MEM
- THEN ;
-
- \ ***************************************************************************
- \ This word NO-INTERPRET is used to prevent some target words from being used
- \ while in interpret mode.
-
- : %NO-INTERP2 ( a1 -- ) \ error abort if we try to interpret
- \ the word defined preceeding NO-INTERPRET
- body>
- " Can't use this TARGET word in INTERPRET mode!" "errmsg
- abort ;
-
- CODE %NO-INTERP ( -- ) \ get here from a CALL
- MOV AX, # ' %NO-INTERP2
- JMP AX END-CODE
-
- : NO-INTERPRET ( -- )
- last @ name> dup @rel>abs 'dovar <>
- if " is an ICODE/IMACRO word, can't use NO-INTERPRET"
- "errmsg
- also forth ' drop previous beep exit
- then 1+
- ['] %NO-INTERP OVER - 2- SWAP ! ; \ go to %NO-INTERP
-
- \ ***************************************************************************
-
- : TASCII ( | <letter> -- ) \ compile inline an ascii letter
- ( | <letter> -- c1 ) \ interpret time
- bl word 1+ c@ state @
- if comp_single
- then ; immediate
-
- : ," ( | string" -- ) \ compile string data
- '"' word dup c@ 1+ s,-d ;
-
- \ ***************************************************************************
- \ Display the target words that have been referenced, along with their
- \ resolution addresses or values
-
- : .unsym ( link -- )
- dup link> dup >execute @rel>abs 'docol =
- if dup >count @
- if save> base
- dup >resaddr @ -1 =
- if \ not MACRO, CONSTANT or 2CONSTANT
- dup >dtype c@ {M} {F} between 0=
- if ?quiet
- if dup
- " is Unresolved"
- "errmsg
- else dup >name .id tab
- ." \2 UNRES "
- then
- \u totalwords totalwords incr
- #unres 1+ =: #unres
- then
- then restore> base
- ?cr
- then
- then 2drop ;
-
- : l.name ( link -- )
- dup link> dup >execute @rel>abs 'docol =
- if dup >count @
- if save> base
- dup >resaddr @ -1 =
- if dup >dtype c@ {M} <>
- if ." \2 UNRES"
- else ." \1 MACRO"
- then
- else dup >resaddr @ hex 5 .r SPACE
- then restore> base
- dup >dtype c@ {D} =
- if ." \1v" else space then
- dup >name .id tab ?cr
- \u totalwords totalwords incr
- then
- then 2drop ;
-
- : %.labels ( -- )
- \u totalwords totalwords off
- 0 =: #unres
- savestate
- cols 10 - rmargin !
- 20 tabsize !
- 0 lmargin !
- ['] target >body
- fhere 500 + #threads 2* cmove \ copy threads
- cr
- begin fhere 500 + #threads
- largest dup \ search thread copy
- ?keypause
- while dup ?unres
- if .unsym
- else l.name
- then y@ swap ! \ insert last link to thread
- repeat 2drop
- decimal
- restorestate ;
-
- : .labels ( -- )
- cr ." Referenced words ----- "
- cr
- 0 =: ?unres
- %.labels
- \u totalwords cr totalwords @ . ." Words Referenced"
- cr ;
-
- ' .labels alias .symbols
-
- : .unres ( -- )
- cr ." --------------------"
- true =: ?unres
- %.labels
- \u totalwords cr totalwords @ . ." Unresolved References"
- ;
-
- \ ***************************************************************************
- \ Compile the definition of " for inline strings in target and library
-
- : %%T" ( a1 -- ) \ compile string into target
- here-d 1+ comp_single \ address of first char of $
- dup c@ comp_single \ compile length of $
- dup c@ 1+ s,-d \ compile string to data area
- ;
- FORTH
- DEFER %T"
-
- ' %%T" IS %T"
-
- : T" ( | string" -- ) \ compile a string into target
- ( -- a1 n1 ) \ runtime - return address and length
- '"' word \ get the string to HERE
- %T" ; immediate \ compile it into target
-
- : L" ( | string" -- ) \ compile a string later compiled
- \ into the target
- [compile] " compile ">$
- compile %T" ; immediate
-
- \ ***************************************************************************
- \ Define and compile the target definition of a colon word. Automatic
- \ forward reference resolution is performed on these definitions.
-
- FORTH
- DEFER END-T: ( -- ) \ See the library for this definition
-
- : (T:) ( | <name> .. ; -- ) \ new defining word
- ?exec
- 0 =: ?lib
- !csp
- current @ context !
- fhere >r
- do_symbol
- ['] no_tinline >body @ r> >execute >body !
- \ no target inline allowed
- \ relink to error routine
- set_cold_entry \ mark as program entry point
- start-t:
- 0BR#
- clear_labels ;
-
- : (T]) ( -- )
- state on
- begin ?stack tdefined target? ?dup \ find the word
- if 0>
- if execute \ execute immediate words
- else targ_compile \ compile the rest
- then
- else %number \ a number?
- if ( d1 -- ) \ compile literal number
- double? \ double if '.' found
- if swap
- comp_single
- else drop
- then comp_single
- else 2drop \ discard double zero
- >in-t =: >in \ reset >IN to before word
- fhere >r
- 0 add_symbol \ or add to symbol table
- compile unnest \ undefined, so NOOP it
- r@ >count incr
- r> compile_call
- then
- then state @ 0=
- until ?sizecheck ; \ check the space used sofar
-
- : T: ( | <name> .. ; -- ) \ TARGET : defining word
- (T:) (T])
- end-t:
- do_resolve ; \ resolve all new referenced symbols
-
- : TM: ( | <NAME> .. ; -- ) \ Target MACRO : defining word
- LM:
- do_resolve ;
-
- \ make some aliases for the normal Forth definitions of these words
-
- assembler also
-
- ' : alias for:
- ' ; alias for; immediate
- ' allot alias fallot
- ' code alias fcode
- ' label alias flabel
- ' end-code alias fend-code
- ' ascii alias fascii immediate
- ' " alias f" immediate
- ' ." alias f." immediate
- ' abort" alias fabort" immediate
- ' ['] alias f['] immediate
-
- here !> tcomlow \ lower limit for TCOM target words
-
- \ new target compiler defered words
-
- FORTH defer : immediate ' for: compiler is :
- FORTH defer ; immediate ' for; compiler is ;
- FORTH
- defer m: immediate
- defer allot
- defer code immediate
- defer label immediate
- assembler definitions forth
- defer end-code immediate
- target definitions forth
- defer ascii immediate
- defer " immediate
- defer ." immediate
- defer abort" immediate
- defer ['] immediate
- defer l." immediate
- defer t." immediate
- defer labort" immediate
- defer tabort" immediate
- defer l['] immediate
- defer t['] immediate
-
- \ Compiler MODE selection words
-
- : >library ( -- ) \ Select Library
- F['] L: =: :
- F['] [;] =: ;
- F['] LM: =: M:
- F['] LCODE =: CODE
- F['] LLABEL =: LABEL
- F['] END-LCODE =: END-CODE
- F['] L" =: "
- F['] L." =: ."
- F['] LABORT" =: ABORT"
- F['] LALLOT =: ALLOT
- F['] LASCII =: ASCII
- F['] L['] =: ['] ;
-
- : >target ( -- ) \ Select Target compiler
- F['] T: =: :
- F['] [;] =: ;
- F['] TM: =: M:
- F['] TCODE =: CODE
- F['] TLABEL =: LABEL
- F['] FEND-CODE =: END-CODE
- F['] T" =: "
- F['] T." =: ."
- F['] TABORT" =: ABORT"
- F['] ALLOT-D =: ALLOT
- F['] TASCII =: ASCII
- F['] T['] =: ['] ;
-
- : >forth ( -- ) \ select Forth
- F['] FOR: =: :
- F['] FOR; =: ;
- F['] FOR: =: M:
- F['] FCODE =: CODE
- F['] FLABEL =: LABEL
- F['] FEND-CODE =: END-CODE
- F['] F" =: "
- F['] F." =: ."
- F['] FABORT" =: ABORT"
- F['] FALLOT =: ALLOT
- F['] FASCII =: ASCII
- F['] F['] =: ['] ;
-
- >FORTH \ Select FORTH for now
-
- \ ***************************************************************************
- \ Allow new user created defining words to be added and used in the target
- \ compiler.
-
- : TDOES> ( | -- )
- ?exec
- 0 =: ?lib
- !csp
- current @ context !
- 0BR#
- clear_labels
- HERE-T =: DOES-ADDR
- (T]) END-T: DO_RESOLVE ; \ resolve all new symbols
-
- : :: ( | <name> -- ) \ make a new defining word
- >FORTH
- [FORTH]
- ?FNDDOES> OFF
- (:) \ make a : def
- STATE ON
- BEGIN ?STACK TDEFINED ?DUP
- IF >R
- CASE
- [TARGET]
- F['] CREATE OF COMPILE (T:)
- COMPILE HERE-D
- COMPILE COMP_SINGLE
- HERE-T [COMPILE] LITERAL
- COMPILE COMP_JMP_IMM
- \ **** COMPILE REVEAL
- ENDOF
- F['] DOES> OF [COMPILE] ; ?FNDDOES> ON ENDOF
- F['] , OF COMPILE ,-D ENDOF
- F['] C, OF COMPILE C,-D ENDOF
- F['] ALLOT OF COMPILE ALLOT-D ENDOF
- [FORTH]
- R@ 0> IF EXECUTE ELSE X, THEN
- ENDCASE R>DROP
- ELSE NUMBER DOUBLE?
- IF [COMPILE] DLITERAL
- ELSE DROP [COMPILE] LITERAL
- THEN
- THEN TRUE DONE?
- UNTIL ?FNDDOES> @ [FORTH] 0=
- IF 0 " No DOES> portion specified" "errmsg abort
- THEN [TARGET] >TARGET TDOES> ;
-
- \ ***************************************************************************
- \ Do the target compile.
-
- : targ ( -- )
- [FORTH]
- ?quiet 0=
- if cr
- ." Compiling.. "
- ?opt
- if ." with Optimization.. "
- then
- then
- set.filenames
- ?lst
- if listing.name $pfile
- if 0 " Could not create listing file." "errmsg abort
- then
- buf_prinit
- [ also hidden ]
- savescr
- \u #prlines savecursor
- \u #prlines 20 8 60 10 box&fill
- \u #prlines ." \1 Building listing file...... "
- \u #prlines restcursor
- \u #prlines 0 =: #prlines
- \u oldfix @> errfix =: oldfix
- F['] pemit save!> emit
- F['] buf_prtypel save!> typel
- \u outfix F['] outfix is errfix
- F['] buf_premit save!> pemit
- printing on cr
- do_ok
- cr cr
- .symbols
- cr cr
- restscr
- printing off
- buf_prflush
- pclose
- restore> pemit
- restore> typeL
- restore> emit
- \u oldfix oldfix =: errfix
- else do_ok
- -1 =: spinval spinner2 \ show spinner one final time
- then .unres \ Display any unresolved references
- [ previous ]
- symclose \ close symbol file
- save-image.com \ write .COM file to disk
- ?bye
- if /bye \ leave now or
- else
- cr
- ." Type \`PRINT .SYMBOLS\` to make a printed copy of your programs SYMBOLS."
- cr
- ." Type \`/BYE\` to leave."
- then
- forth decimal ;
-
- false \u words drop true \ true if "WORDS" is defined
- #IF
-
- : .compiler ( -- )
-
- cr ." /definit = Include the default initialization from file DEFINIT.SEQ."
- cr ." /noinit = Don't include any default initialization, user does it."
- \u newfile cr ." /edit <file> = Start as editor on <file>. Not in small version.(no compile)"
- cr ." /lst = Generate a listing file with source, asm & symbols."
- cr ." /lstoff = Don't generate a listing file ............ (default)."
- cr ." /opt = Enable compiler optimization."
- cr ." /optoff = Disable compile optimization ............. (default)."
- cr ." /show = Show symbols as they are compiled."
- cr ." /showoff = Don't show symbols as they are compiled .. (default)."
- cr ." /src = Enable the listing of source lines."
- cr ." /srcoff = Disable the listing of source lines ...... (default)."
- cr ." /stay = Stay in Forth after the compile finishes."
- cr ." /sym = Generate a symbol file for BXDEBUG."
- cr ." /symoff = Don't generate a symbol file ............. (default)."
- cr ." /help = Re-display help screen. Press the \2 F1 \0 key for MORE HELP."
- cr ." /help2 = Display second help screen."
- ;
-
- : /help ( -- )
- cr ." Command line format: "
- ." \`TCOM <filename> <option> <option> <...>\`"
- cr
- \unless .alist .alist
- .compiler
- cr ." \3 *** Type /BYE to leave the compiler *** " ;
-
- : /help2 ( -- ) \ second set of command line options
- cr ." Command line options Help screen two."
- cr
- cr ." /forth = Append an interactive Forth to program. (need TFORTH.SEQ)"
- cr ." /dis = Also append the disassembler. (need DIS.SEQ)"
- cr ." /debug = Also append the debugger. (need TDEBUG.SEQ)"
- cr ." /quiet = Reduce visual output, use with I/O redirection."
- cr ." /code-start <adr> = Start compiling code at <adr>."
- cr ." /data-start <adr> = Start compiling data at <adr>."
- cr ." /code-limit <n1> = Size limit between CODE and DATA. (default=$C000)"
- cr ." /ram-start <adr> = Set the RAM segment in target memory. (ROMable)"
- cr ." /ram-end <n1> = Set the end of target ram. (default=$FFEE)"
- cr ." /bye = Return to DOS ....... (NOT a command line option)."
- cr ." /DOS = Shell out to DOS .....(NOT a command line option)."
- cr ." /help = Re-display first help screen."
- cr ." /help2 = Display this help screen again."
- ;
-
- #ELSE
-
- : /help
- cr ." Command line format: "
- ." \`TCOM <filename> <option> <option> <...>\`"
- cr ." Options avaliable: "
- ." \`/opt /sym /lst /code /src /show\`"
- cr cr
- ." Type \`/BYE <enter>\` to return to DOS (don't include the \`s)."
- cr ;
-
- #THEN
-
- : .public ( -- )
- cr
- ." \3 TCOM \0 the Target COMpiler by Tom Zimmer "
- ." \3 Version 1.28 " tversion cr
- ." \1 ********** This is a Public Domain program ********** "
- eeol at? eeol at ;
-
- : ?.instruct ( -- )
- [ also forth ]
- seqhandle >hndle @ 0<
- if dark
- .public
- /help
- false =: ?bye
- forth
- interpret
- quit
- then ;
-
- : ?cmd_err ( a1 n1 f1 -- )
- [forth]
- if 0 -rot "errmsg cr
- ?bye if /bye then
- ." Type \1 /BYE \0 to leave"
- F['] <run> is run errfix
- sp0 @ sp! printing off
- forth
- quit
- then ;
-
- : ?compile_err ( a1 n1 f1 -- )
- [forth]
- if 0 -rot "errmsg cr
- ?bye if /bye then
- F['] (?serror) is ?error abort
- else 2drop
- then ;
-
- : DOTARG ( -- )
- [forth]
- sp0 @ 'tib !
- >in off
- span off
- #tib off
- loading off
- only forth also definitions
- defaultstate
- tcom_path@ \ get the environment specified path
- default \ open a file if one is present
- 20 tabsize ! \ adjust the tab size
- warning off
- \u autoeditoff autoeditoff \ no autoedit on error
- only
- forth also
- compiler also
- target also definitions
- assembler also
- off> cerrors
- F['] ?cmd_err save!> ?error
- env_interpret \ get the default command line args
- interpret \ get the overridding args
- restore> ?error
- .public
- ?.instruct
- F['] ?compile_err save!> ?error
- targ
- restore> ?error ;
-
- ' DOTARG IS BOOT \ Make TARG the Initializer
-
- \ ***************************************************************************
- \ Some immediate words to handle values in the target
-
- ' noop for>word &>
- ' comp_store for>word !>
- ' comp_fetch for>word @>
- ' comp_off for>word off>
- ' comp_on for>word on>
- ' comp_incr for>word incr>
- ' comp_decr for>word decr>
- ' comp_pstore for>word +!>
- ' comp_save for>word save>
- ' comp_savest for>word save!>
- ' comp_rest for>word restore>
-
- HERE =: TSYM_BOTTOM \ bottom of target dictionary
-
-
-