ProfitPress Mega CDROM2 Shareware Freeware (MSDOS)(1992)(Eng)

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

/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FPC355_4.ZIP / TCOMSRC.ZIP / COMPILER.SEQ < prev next >

Wrap

Text File | 1991-04-25 | 104.9 KB | 2,552 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; \ *************************************************************************** \ Automatic local label generator for assembler labels only forth also assembler definitions also $180 !> max-llabs \ we want upto about 300 local labels create %tllab[] max-llabs b/llab * allot %tllab[] max-llabs b/llab * erase \ clear the array %tllab[] !> llab[] \ set new array to %tllab[] forth definitions also $40 constant lab1# \ first local label number to use lab1# value lab# \ branch label depth : 0lab# ( -- ) lab1# !> lab# llab[] max-llabs b/llab * erase ; \ clear the array : +lab# ( -- n1 ) lab# incr> lab# ; : init_labels ( -- ) \ initializes temp labels ONLY, leave locals alone llab[] lab1# 1- b/llab * erase false !> ll-used? ; : labdoassem ( --- ) @> run =: arunsave ['] run-a; is run 0 ['] drop a;! aprior 4 + 2@ aprior 2! lihere =: linestrt ll-global? 0= if init_labels \ in case labels used then also assembler ; ' labdoassem is setassem only forth also definitions hidden also \ *************************************************************************** \ Buffered printing words to increase performance when creating a listing \ *************************************************************************** 4096 constant pr_max \ actual buffer size pr_max 1- constant pr_limit \ highest allowable char count create pr_buf pr_max 2+ allot \ listing output buffer 0 value pr_cnt \ listing buffer output counter 0 value ?lst \ true if we are in listing mode? : 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 save> #out ?cs: pr_buf pr_cnt prntypel off> pr_cnt restore> #out ; \ keep #OUT at its previous value : bye_lst_flush ( -- ) \ flush listing file buffer ?lst if buf_prflush then defers byefunc ; ' bye_lst_flush is byefunc \ link into things to be done on exit : buf_premit ( c1 -- ) \ put char c1 in print buffer pr_cnt pr_limit >= 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_limit >= if buf_prflush then >r ?cs: pr_buf pr_cnt + r@ cmovel r@ +!> pr_cnt r> +!> #out \+ ?.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 \+ sys ' sys alias /dos defer "errmsg2 defer .alist ' noop is .alist \ default to no more help defer line-done ' noop is line-done \ action at the end of every line \ In case no disassembler is present, discard the a1,n1 parameters defer ?.#dis ' 2drop is ?.#dis \ *************************************************************************** \ Target assembly and access words $10000. 2constant codebytes \ max target program is 64k bytes codebytes pointer seg-code \ target origin code segment $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 $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 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 ' %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, curseg-ptr, nxt-data-ptr, curseg-ptr \ \ \ \ (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 0 value ccseg \ current code segment 0 value cdseg \ current data segment : end-cseg ( -- ) segments 2+ @ ?dup \ if prev seg not NULL if here-t swap 4 + ! \ save end addr in struct then ; : org ( a1 -- ) \ define a headerless segment end-cseg \ close previous segment fhere segments @ , \ link previous to this seg dup segments ! \ this seg into segment list segments 2+ ! \ make this, current segment ( +2 ) dup , \ start of segment ( +4 ) dup , \ current address in segment dup dp-t ! \ adjust code pointer !> linestrt ; \ no code yet compiled here : cseg! ( seg -- ) \ set the current code segment end-cseg \ finish current segment dup segments 2+ ! \ link me into segments 4 + @ dup dp-t ! \ set HERE-T to my segment !> linestrt ; \ no more code here yet : cseg ( a1 | <name> -- ) \ create memory CODE segments words create org does> cseg! ; : dseg> ( -- ) \ return from the data segment ccseg cseg! ; : >dseg ( -- ) \ select the current data segment segments 2+ @ !> ccseg cdseg cseg! ; : %dorg ( a1 -- ) \ create a data segment in code space end-cseg segments 2+ @ >r \ save current code segment org \ set the data origin segments 2+ @ !> cdseg \ save current data segment r> !> ccseg \ reset saved code segment dseg> ; \ return to the code segment : %dseg ( a1 | <name> -- ) \ create data code segment word create %dorg does> !> cdseg ; : end-vseg ( -- ) segments 6 + @ ?dup \ if prev seg not NULL if here-d swap 4 + ! \ save end addr in struct then ; : vorg ( a1 -- ) end-vseg \ close prevous segment fhere segments 4 + @ , \ link previous to this seg dup segments 4 + ! \ this seg into segment list segments 6 + ! \ make this, current segment ( +2 ) dup , \ start of segment ( +4 ) dup , \ current address in segment dp-d ! ; \ adjust data pointer : vseg ( a1 | <name> -- ) \ create memory DATA segments words create vorg does> end-vseg dup segments 6 + ! \ link me into segments 4 + @ dp-d ! ; \ set HERE-T to my segment defer end-dseg ' end-vseg is end-dseg defer dorg ' vorg is dorg defer dseg ' vseg is dseg : /data_in_ram ( -- ) \ put data in with variables ['] end-vseg is end-dseg ['] vorg is dorg ['] vseg is dseg ; : /data_in_rom ( -- ) \ put data in with code in rom \ but in its own place ['] end-cseg is end-dseg ['] %dorg is dorg ['] %dseg is dseg ; : /data_in_code ( -- ) \ put data in with the code in rom \ actually lay it inline with code ['] end-cseg is end-dseg ['] org is dorg ['] cseg is dseg ; \ *************************************************************************** \ Target image save function handle targethndl forth definitions : NOTI ( -- ) TRUE ABORT" No Target initialization function installed" ; DEFER TARGET-INITIALIZE ' NOTI IS TARGET-INITIALIZE DEFER TARGET-FINISH ' NOOP IS TARGET-FINISH 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 \+ unedit unedit seg-code 0= \ allocate the space needed for \ the target compile process if 0 " Not enough memory for compile buffer" "errmsg2 abort then seg-code 0 codebytes $FFFF. dmin drop 0 lfill \ Zero out 64k of code area \+ dumpseg seg-code =: dumpseg \ preset dumpseg [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#val \ branch label depth : 0br# ( -- ) off> br#val ; : +br# ( -- n1 ) br#val incr> br#val ; : -br# ( -- n1 ) decr> br#val br#val dup 0< if 0 " Attempt to resolve an branch label" "errmsg2 abort then ; : br# ( -- ) br#val 1- 0max ; \ *************************************************************************** \ 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 ?code 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 ; ' showlines alias /src \ this MUST be here so /LST can use it! ' hidelines alias /srcoff ' hidelines alias /nosrc /srcoff : /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 \+ statoff statoff ; ' /quiet alias /q : defaultattrib ( -- ) \ set the compilers screen attributes to \ match the current screen attributes. video-seg @ at? 160 * swap 2* + 1+ c@L attrib ! ; code #bye ( n1 -- ) \ terminate to DOS with errorcode n1 pop ax mov ah, # $4C int $21 next end-code : newbye ( -- ) \ return to dos after performing cleanup ['] qtypel is typel ['] (emit) is emit ['] (print) is pemit printing off RESTORE_VECTORS BYEFUNC ?cerrors drop cerrors #bye ; ' newbye >body @ ' bye >body ! \ link NEWBYE into BYE : /bye ( -- ) \ leave compiler after the compile newbye ; : /stay ( -- ) off> ?bye ; ' /stay alias /sta \+ newfile : /edit ( <filename> -- ) \ edit file specified, don't compile \+ newfile newfile newbye ; \+ 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 ?code or ?show or ?quiet or ?exit incr> spinval spinval 1 and ?exit at? " |/-\" drop spinval 2/ 3 and + 1 type at ; : spinner2 ( -- ) ?lst ?code or ?show or ?quiet or ?exit incr> spinval spinval 1 and ?exit attrib @ >r at? over 2+ over at " |/-\" drop spinval 2/ 3 and + 1 type spinval 7 and 0= if save> base decimal 40 sp>col >attrib3 3 spaces 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 " restore> base r@ attrib ! 78 sp>col then at r> attrib ! ; \ *************************************************************************** \ 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#val 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 \+ (see) : tsee ( | <name> -- ) \+ (see) ' >execute (see) ; \+ ldump : tdump ( a1 n1 -- ) \+ ldump seg-code -rot ldump ; \ ONLY make TDIS if the disassembler is available \+ =seg : tdis ( a1 --- ) seg-code =seg dis ; \+ adebug : tdebug ( | <name> -- ) \+ 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 ?sym 0= ?exit ?symopen if dup>r symcr save> base hex dup >resaddr @ 0 <# # # # # #> symbwrite restore> base 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 ( -- ) fhere off \ clear out anything at HERE target-initialize \ initialize the target compiler ok \ compile the currently open file ?interpretive if /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 then target-finish ; \ *************************************************************************** 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 \+ >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 dup 1 31 between if 2dup type then 2drop space then type \ display message incr> cerrors ; \ bump found error count ' "errmsg is "errmsg2 \+ "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 ?code 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 drop restore> base ; defer .asymbol ' %.asymbol is .asymbol : out_symbol ( a1 -- ) \ a1 = cfa of symbol dup .asymbol symwrite drop spinner2 ; \ *************************************************************************** \ Display a macro name when used : %?.macro ( a1 -- ) \ a1 = CFA of symbol ?code if cr ." --M-- " dup >name .id then drop ; defer ?.macro ' %?.macro is ?.macro \ *************************************************************************** \ Display a call name when used : %?.call ( a1 -- ) ?code if save> base hex cr here-t 3 - 0 <# # # # # #> type 4 spaces ." CALL " dup >name .id restore> base then drop ; defer ?.call ' %?.call is ?.call \ *************************************************************************** \ 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 0 , 0 , ; \ *************************************************************************** \ 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 out_symbol else dup >resaddr @ -1 = if dup make_header here-t over >resaddr ! \ resolve symbol dup out_symbol >chain dup @ swap off \ resolve chain begin ?dup while dup @-t swap resolve_1 \ resolve one ref repeat else drop then init_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 tcomlow \ lowest allowable target definition in TCOM : do_symbol ( | <name> -- ) >in @ >r \ save >IN for later defined dup if drop \ discard flag dup tcomlow 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> out_symbol 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 dup comp_call ?.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 out_symbol \ 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 out_symbol \ 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 >count incr >execute execute ; : res_comp_call ( a1 -- ) dup >count incr compile_call ; : 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 \+ ?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 \+ ?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. : 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 a; line-done 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. : %TLABEL ( | <name> -- ) \ define an unresolved lacal label save> context {S} new_symbol restore> context -1 , \ not yet resolved 0 , \ clear dummy unresolved chain 0 , \ clear reference counter 0 , \ data size is 0 +lab# dup , \ save the label number \ in ">DINITIAL" field [assembler] $ \ an unresolved local label [compiler] does> body> dup >count incr \ bump usage >dinitial @ [assembler] $ \ an unresolved local label [compiler] ; : TINTERP ( -- ) line->srcfile begin ?stack @> >in !> >in-t defined if execute else %number if double? 0= if drop then else 2drop \ discard double zero >in-t !> >in \ reset >IN fhere >r %tlabel \ add label to syms r> >count incr then then false done? until a; line-done ; DEFER TCODE-START 0 VALUE INTERPSAVE 0 VALUE ?TCODING : TCODE ( | <name> -- ) \ a target CODE word on> ?tcoding tdefined target? 0= \ if not already defined if drop \ cleanup stack >in-t !> >in do_symbol else dup res_symbol dup >name last ! \ for DOES> below >dinitial @ [assembler] $$:f \ else resolve local label [compiler] then @> interpret !> interpsave ['] tinterp is interpret 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. does> body> >resaddr @ ; : TEND-CODE ( -- ) \ finish a target code definition ?tcoding 0= abort" Code words must start with CODE or LABEL" [assembler] end-code [forth] off> ?tcoding interpsave ?dup if !> interpret then ; : TLABEL ( | <name> -- ) \ Define a new code label ?tcoding 0= \ if not in a code word, then use CODE if TCODE exit then tdefined target? 0= if >in-t =: >in \ reset >IN save> context {S} new_symbol restore> context here-t , 0 , \ clear dummy unresolved chain 0 , \ clear reference counter 0 , \ data size is 0 +lab# dup , \ save the label number \ in ">DINITIAL" field [assembler] $:| \ define a local label [compiler] else here-t over >resaddr ! \ resolve to HERE \ word was already defined, dup >name last ! \ so setup for DOES> later? dup >dinitial @ true save!> ?long \ backward branch is allowed \ to be long is $E9 type JMP [assembler] $:| \ else resolve local label [compiler] restore> ?long then out_symbol \ display the symbol does> body> dup >count incr \ bump usage >dinitial @ [assembler] $ \ reference local label [compiler] ; \ *************************************************************************** \ 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 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 : %%T," ( | string" -- ) \ compile string data '"' word dup c@ 1+ s,-d ; FORTH DEFER ," COMPILER ' %%T," IS ," \ *************************************************************************** \ 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 \+ 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 \+ totalwords totalwords incr then then 2drop ; : %.labels ( -- ) \+ 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 ?lst 0= if ?keypause then 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 \+ totalwords cr totalwords @ . ." Words Referenced" cr ; ' .labels alias .symbols : .unres ( -- ) cr ." --------------------" true =: ?unres %.labels \+ 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: init_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['] TEND-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 ! init_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. compiler definitions : targ ( -- ) [FORTH] ?quiet 0= if cr ." Compiling.. " ?opt if ." with Optimization.. " then then set.filenames \ init file handle names 0lab# \ init local label array ?lst if listing.name $pfile if 0 " Could not create listing file." "errmsg abort then buf_prinit [ also hidden ] savescr \+ #prbytes savecursor \+ #prbytes 20 8 60 10 box&fill \+ #prbytes ." \1 Building listing file...... " \+ #prbytes restcursor \+ #prbytes 0.0 #prbytes 2! \+ #prsave 0.0 #prsave 2! \+ oldfix @> errfix =: oldfix F['] pemit save!> emit F['] buf_prtypel save!> typel \+ outfix F['] outfix is errfix F['] buf_premit save!> pemit printing on ( cr ) do_ok at? 2>r cr cr .symbols cr cr 2r> at restscr printing off buf_prflush pclose restore> pemit restore> typeL restore> emit \+ oldfix oldfix =: errfix else do_ok -1 =: spinval spinner2 \ show spinner one final time then end-cseg \ end the code & data segments end-dseg .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 \+ 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." \+ 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 .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.35 " tversion cr ." \1 ******** All TCOM Compilers are Public Domain ******* " eeol at? eeol at ; : ?.instruct ( -- ) [ also forth ] seqhandle >hndle @ 0< if dark .public /help false =: ?bye forth interpret off> cerrors 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 \ leave if not in "/STAY" F['] (?serror) is ?error \ reset ?ERROR to normal abort \ and abort else 2drop then ; : DOTARG ( -- ) [forth] sp0 @ 'tib ! >in off span off #tib off loading off only forth also definitions defaultstate defaultattrib \ set the default attributes to screen tcom_path@ \ get the environment specified path default \ open a file if one is present 20 tabsize ! \ adjust the tab size warning off \+ 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 target definitions ' 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>