home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / compiler.seq < prev    next >
Text File  |  1991-02-06  |  96KB  |  2,300 lines
  1. \ COMPILE.SEQ           Compiler test code              by Tom Zimmer
  2.  
  3. comment:
  4.  
  5.           An optimizing target compiler for the Public Domain Forth
  6.         system F-PC by Tom Zimmer.
  7.  
  8.           Released to the Public Domain this date 10/11/89 by the
  9.         author Tom Zimmer.
  10.  
  11.  
  12. comment;
  13.  
  14. only forth also definitions hidden also
  15.  
  16. \ ***************************************************************************
  17. \ Buffered printing words to increase performance when creating a listing
  18. \ ***************************************************************************
  19.  
  20. 2048 constant pr_max
  21. create pr_buf pr_max 2+ allot
  22. 0 value pr_cnt
  23.  
  24. : buf_prinit    ( -- )                  \ initialize the print buffer
  25.                 pr_buf pr_max blank
  26.                 off> pr_cnt ;
  27.  
  28. : buf_prflush   ( -- )                  \ flush the contents of the print
  29.                                         \ buffer to printer
  30.                 ?cs: pr_buf pr_cnt prntypel
  31.                 off> pr_cnt ;
  32.  
  33. : buf_premit    ( c1 -- )               \ put char c1 in print buffer
  34.                 pr_cnt pr_max >=
  35.                 if      buf_prflush
  36.                 then
  37.                 pr_buf pr_cnt + c!
  38.                 incr> pr_cnt
  39.                 incr> #out ;
  40.  
  41. : buf_prtypel   ( seg a1 n1 -- )        \ type text to print buffer from
  42.                                         \ far segment location
  43.                 pr_cnt over + pr_max >=
  44.                 if      buf_prflush
  45.                 then
  46.                 >r ?cs: pr_buf pr_cnt + r@ cmovel
  47.                 r@ +!> pr_cnt
  48.                 r> +!> #out
  49. \u ?.prlines    ?.prlines
  50.                 ;
  51.  
  52. only forth also
  53.  
  54. \ ***************************************************************************
  55. \ Create some aliases to allow their use while in the compiler
  56. \ ***************************************************************************
  57.  
  58.                         ' forth     alias [forth]     immediate
  59.                         ' assembler alias [assembler] immediate
  60. vocabulary target       ' target    alias [target]    immediate
  61. vocabulary htarget      ' htarget   alias [htarget]   immediate \ h = HIDDEN
  62. vocabulary compiler     ' compiler  alias [compiler]  immediate
  63. defer tversion  ' noop is tversion
  64. compiler also definitions
  65.  
  66.         ' here alias fhere              \ make fhere an alias for HERE
  67. \u sys  ' sys  alias /dos
  68.  
  69. defer "errmsg2
  70.  
  71. defined ?.#dis nip 0=
  72. #if
  73.         ' 2drop alias ?.#dis    \ if no disassembler, then discard params
  74. #then
  75.  
  76. \ ***************************************************************************
  77. \ Target assembly and access words
  78.  
  79. $1000 value codesegs            \ max size of target program space 64k
  80.  
  81.  $100 value code-start                  \ start of compiled code
  82.  $000 value data-start                  \ start of compiled data
  83.    variable dp-t code-start dp-t !      \ target dictionary pointer
  84.    variable dp-d data-start dp-d !      \ target DATA dictionary pointer
  85.     0 value seg-code                    \ target origin code segment
  86. $FFFF value ram-seg                     \ physical segment in target of ram
  87.                                         \ $FFFF signifies whole system is
  88.                                         \ ram based, and no move from ROM
  89.                                         \ is needed at initialization time.
  90.   $00 value target-origin               \ origin in memory for target code
  91. $C000 value data-origin                 \ origin in memory for target data
  92. $FFEE value rptop                       \ where we will initialize return stk
  93.  $100 value rpsize                      \ return stack size in bytes
  94.     0 value >in-t                       \ a place to save >IN
  95.     5 value data-seg+                   \ Offset to the instruction that
  96.                                         \ adjusts DS to where data really is.
  97.     0 value cold_start                  \ Offset to CALL instruction to
  98.                                         \ out cold entry point in application
  99.  
  100. : /code-start   ( | <addr> -- )         \ set target CODE starting address
  101.                 bl word number drop =: code-start ;
  102.  
  103. : /code-limit   ( | <addr> -- )         \ set max size of CODE compiled
  104.                 bl word number drop =: data-origin ;
  105.  
  106. : /data-start   ( | <addr> -- )         \ set target data starting address
  107.                 bl word number drop =: data-start ;
  108.  
  109. : /ram-start    ( | <addr> -- )         \ set the segment in target memory
  110.                                         \ where ram really is, data is them
  111.                                         \ moved into that ram from ROM
  112.                 bl word number drop =: ram-seg ;
  113.  
  114. : /ram-end      ( | <n1> -- )           \ set amount of available ram
  115.                 bl word number drop =: rptop ;
  116.  
  117.  
  118. ' DP-T @REL>ABS CONSTANT 'DOVAR         \ pointer to DOVAR
  119.  
  120. \ ***************************************************************************
  121. \ Target CODE space memory operators
  122.  
  123. : ?sizecheck    ( -- )
  124.                 dp-t @       data-origin   u>
  125.                 if      0 " TOO MUCH CODE!"        "errmsg2 abort then
  126.                 dp-d @ $FD00 data-origin - u>
  127.                 if      0 " TOO MUCH STATIC DATA!" "errmsg2 abort then ;
  128.  
  129. defer c!-t      \ defered for flexibility with Mike Mayo's index compiler
  130. defer !-t
  131. defer c,-t
  132. defer ,-t
  133.  
  134. : cs:           ( taddr -- taddr tseg ) seg-code swap ;
  135. : erase-t       ( a1 n1 --- )           >r cs: r> 0 lfill ;
  136. : there         ( taddr -- addr )       target-origin +   ;
  137. : c@-t          ( taddr -- char )       there cs: c@l ;
  138. : @-t           ( taddr -- n )          there cs: @l  ;
  139. : %c!-t         ( char taddr -- )       there cs: c!l ;
  140. : %!-t          ( n taddr -- )          there cs: !l  ;
  141. : here-t        ( -- taddr )            dp-t @   ;
  142. : allot-t       ( n -- )                dp-t +! ;
  143. : %c,-t         ( char -- )             here-t c!-t   1 allot-t   ;
  144. : %,-t          ( n -- )                here-t  !-t   2 allot-t   ;
  145. : s,-t          ( addr len -- )         0max 0 ?do count c,-t loop drop ;
  146. : cset-t        ( n1 addr -- )          dup c@-t rot or swap c!-t ;
  147.  
  148. ' %c!-t is c!-t         \ link defered functions to defered word
  149. ' %!-t  is !-t
  150. ' %c,-t is c,-t
  151. ' %,-t  is ,-t
  152.  
  153. : %data-seg-fix ( -- )
  154.                 here-t paragraph 16 * dp-t !    \ paragraph align here
  155.                 data-seg+ @-t $E4F6 -           \ verify SYSINIT compiled
  156.                                                 \ and is NOT changed
  157.                 if      0 " TARGET-INIT MUST be first in TARGET" "errmsg2
  158.                         abort
  159.                 then
  160.                 here-t paragraph                \ calc end of CODE used
  161.                 data-seg+ !-t ;                 \ set real DATA seg offset
  162.  
  163. defer data-seg-fix
  164.  
  165. ' %data-seg-fix is data-seg-fix         \ install default function
  166.  
  167. \ ***************************************************************************
  168. \ Target DATA space memory operators
  169.  
  170. : here-d        ( -- taddr )            dp-d @   ;
  171. : allot-d       ( n -- )                dp-d +! ;
  172. : dhere         ( taddr -- addr )       data-origin + ;
  173. : @-d           ( taddr -- n )          dhere cs: @l  ;
  174. : c@-d          ( taddr -- c1 )         dhere cs: c@l ;
  175. : c!-d          ( char taddr -- )       dhere cs: c!l ;
  176. : !-d           ( n taddr -- )          dhere cs: !l  ;
  177. : c,-d          ( char -- )             here-d c!-d   1 allot-d   ;
  178. : ,-d           ( n -- )                here-d  !-d   2 allot-d   ;
  179. : s,-d          ( addr len -- )         0max 0 ?do count c,-d loop drop ;
  180.  
  181. : dp-set        ( -- )          \ adjust target DP to next free data space
  182.                 here-d 0 !-d ;  \ DP is always at address zero (0) in target
  183.  
  184. ' here-t alias here             \ HERE is now a target word.
  185.                                 \ Use fhere for host if you need it.
  186.  
  187. 0 value ?targeting
  188.  
  189. : >TARGET-MEM   ( -- )
  190.                 ?targeting ?exit
  191.                 [ASSEMBLER]
  192.                 [']   c,-t  is  c,
  193.                 [']    ,-t  is   ,
  194.                 [']   c@-t  is tc@
  195.                 [']    @-t  is t@
  196.                 [']   c!-t  is tc!
  197.                 [']    !-t  is t!
  198.                 ['] here-t  is here
  199.                 on> ?targeting ;
  200.  
  201. : >FORTH-MEM    ( -- )
  202.                 ?targeting 0= ?exit
  203.                 [forth] [']    c, [assembler] is   c,
  204.                 [forth] [']     , [assembler] is    ,
  205.                 [forth] [']    c@ [assembler] is  tc@
  206.                 [forth] [']     @ [assembler] is   t@
  207.                 [forth] [']    c! [assembler] is  tc!
  208.                 [forth] [']     ! [assembler] is   t!
  209.                 [forth] ['] fhere [assembler] is here
  210.                 off> ?targeting ;
  211.  
  212. \ ***************************************************************************
  213. \ Target segment list creation and maintenance words for CODE & DATA
  214.  
  215. \  SEGMENTS array
  216. \
  217. \       +0            +2        +4            +6
  218. \       nxt-code-ptr, xxxxxxxx, nxt-data-ptr, xxxxxxxx
  219. \        \                       \
  220. \         (points to)              (data chain same as code chain)
  221. \                    \
  222. \                      \ +0            +2          +4
  223. \   (segment)->          nxt-code-ptr, start-code, end-code
  224. \                          \
  225. \                            \ +0            +2          +4
  226. \   (segment)->                nxt-code-ptr, start-code, end-code
  227. \                                \
  228. \                                  \
  229. \                                    0 (zero)
  230. \
  231. \ ***************************************************************************
  232.  
  233. create segments 8 allot         \ an array to hold the code and
  234.        segments 8 erase         \ data segment pointer chain
  235.  
  236. : end-cseg      ( -- )
  237.                 segments 2+ @ ?dup              \ if prev seg not NULL
  238.                 if      here-t swap 4 + !       \ save end addr in struct
  239.                 then    ;
  240.  
  241. : cseg  ( a1 | <name> -- )      \ create memory CODE segments words
  242.         create fhere segments @ ,
  243.                      segments !                 \ link into segment list
  244. ( +2 )  dup ,                                   \ start of segment
  245. ( +4 )  ,                                       \ current address in segment
  246.         does>   end-cseg
  247.                 dup segments 2+ !               \ link me into segments
  248.                 4 + @ dp-t ! ;                  \ set HERE-T to my segment
  249.  
  250. : end-dseg      ( -- )
  251.                 segments 6 + @ ?dup             \ if prev seg not NULL
  252.                 if      here-d swap 8 + !       \ save end addr in struct
  253.                 then    ;
  254.  
  255. : dseg  ( a1 | <name> -- )      \ create memory DATA segments words
  256.         create fhere segments 4 + @ ,
  257.                      segments 4 + !             \ link into segment list
  258. ( +2 )  dup ,                                   \ start of segment
  259. ( +4 )  ,                                       \ current address in segment
  260.         does>   end-dseg
  261.                 dup segments 6 + !              \ link me into segments
  262.                 4 + @ dp-d ! ;                  \ set HERE-T to my segment
  263.  
  264. \ ***************************************************************************
  265. \ Target image save function
  266.  
  267. handle targethndl
  268.  
  269. forth definitions
  270.  
  271. DEFER TARGET-INITIALIZE
  272.  
  273. 0 value #unres
  274. 0 value cerrors
  275. 0 value does-addr
  276. handle image.name
  277. handle symbol.name
  278. handle listing.name
  279. handle lines.name
  280. create image.ext  ," COM" 0 ,   \ default to .COM extension
  281.  
  282. : set.filenames ( -- )          \ set the filenames for various files
  283.              seqhandle image.name   $>handle image.ext  image.name   $>ext
  284.              seqhandle symbol.name  $>handle " SYM" ">$ symbol.name  $>ext
  285.              seqhandle listing.name $>handle " LST" ">$ listing.name $>ext
  286.              seqhandle lines.name   $>handle " LIN" ">$ lines.name   $>ext ;
  287.  
  288. : ?cerrors      ( -- f1 )
  289.                 cerrors dup
  290.         if      cr ." \3 Image not saved \2 COMPILE ERRORS! "
  291.                 cr here-t code-start -
  292.                    here-d data-start - + 5 .r ."  Bytes compiled" cr
  293.         then    ;
  294.  
  295. : %save-image.com ( | -- )
  296.                 [compiler]
  297.                 ?cerrors ?exit
  298.                 #unres
  299.         if      cr ." \3 Image not saved \0, some symbols \2 UNRESOLVED! "
  300.                 cr here-t code-start -
  301.                    here-d data-start - + 5 .r ."  Bytes compiled"
  302.         else    image.name targethndl $>handle
  303.                 targethndl hcreate                      \ make image.com
  304.                 if      0 " Error while creating executable file." "errmsg2
  305.                         abort
  306.                 then
  307.                 cr cr ." Created executable file - " targethndl count type
  308.                 data-seg-fix                    \ adjust HERE-T and fix
  309.                                                 \ DATA segment alignment
  310.                 dp-set                          \ set targets DP
  311.                 code-start here-t over - dup>r
  312.                 targethndl seg-code exhwrite r> -       \ write CODE
  313.                 if      0 " Error while saving CODE to executable file."
  314.                         "errmsg2 abort
  315.                 then
  316.                 cr ." Wrote " here-t code-start - dup>r 5 u.r
  317.                 ."  Bytes of CODE rounded up to Paragraph."
  318.                 data-origin here-d
  319.                 targethndl seg-code exhwrite here-d -
  320.                 if      0 " Error while saving DATA to executable file."
  321.                         "errmsg2 abort
  322.                 then
  323.                 cr ." Wrote " here-d data-start - 5 u.r ."  Bytes of DATA, "
  324.                 here-d r> + 5 u.r ."  Bytes total.
  325.         then    cr ;
  326.  
  327. DEFER SAVE-IMAGE.COM    ' %SAVE-IMAGE.COM IS SAVE-IMAGE.COM
  328.  
  329. compiler definitions
  330.  
  331. \ ***************************************************************************
  332. \ Initialize the target compiler code space and link in the new target words
  333. \ to the assembler.
  334.  
  335. : tseg_init     ( -- )          \ switch assembler to target space
  336. \u unedit       unedit
  337.                 seg-code 0=             \ allocate the space needed for
  338.                                         \ the target compile process
  339.                 if      codesegs alloc 8 = memchk nip   \ allocate DOS memory
  340.                         dup =: seg-code                 \ init SEG-CODE
  341.                         0 codesegs $010 * 1- 0 lfill    \ Zero out area
  342. \u dumpseg              seg-code =: dumpseg             \ preset dumpseg
  343.                 then
  344.                 [assembler]             \ assembler defered words
  345.                 global_ref              \ use global references
  346.                 >TARGET-MEM ;
  347.  
  348. \ ***************************************************************************
  349. \ Mark the current CODE dictionary address as the current cold program
  350. \ entry point.
  351.  
  352. : %set_cold_entry       ( -- )          \ mark HERE-T as the cold entry point
  353.                         here-t cold_start - 2-
  354.                         cold_start !-t ;
  355.  
  356. DEFER SET_COLD_ENTRY    ' %SET_COLD_ENTRY IS SET_COLD_ENTRY
  357.  
  358. \ ***************************************************************************
  359. \ Automatic local variable generator for assembler macros
  360.  
  361. 0 value br#             \ branch label depth
  362.  
  363. : 0br#          ( -- )
  364.                 off> br# ;
  365.  
  366. : +br#          ( -- n1 )
  367.                 br#
  368.                 incr> br# ;
  369.  
  370. : -br#          ( -- n1 )
  371.                 decr> br#
  372.                 br# dup 0<
  373.                 if      0 " Attempt to resolve an branch label" "errmsg2
  374.                         abort
  375.                 then    ;
  376.  
  377. \ ***************************************************************************
  378. \ Compiler control words
  379.  
  380. variable ?fnddoes>              \ dis CREATE DOES> have a DOES> portion?
  381.  
  382.    0 value ?unres               \ unresolved flag
  383.    0 value ?lib                 \ library flag
  384.    0 value ?0opt1
  385.    0 value ?opt
  386.    0 value ?lst
  387.    0 value ?show
  388.    0 value ?definit
  389. true value ?bye
  390.    0 value opt_limit
  391.    0 value ?quiet
  392.    0 value ?interpretive
  393.  
  394. : /opt          ( -- )          \ enable optimization for this compile
  395.                 on> ?opt
  396.                 on> ?0opt1 ;
  397.  
  398. : /optoff       ( -- )          \ disable optimization for this compile,
  399.                                 \ this is the default mode
  400.                 off> ?opt
  401.                 off> ?0opt1 ;
  402.  
  403. ' /optoff alias /noopt
  404.  
  405. : .?opt         ( -- )
  406.                 cr >rev ." Status of ?OPT is " ?opt . >norm cr ;
  407.  
  408. /optoff
  409.  
  410. : opt_off1      ( -- )          \ turn off the optimizers for a while
  411.                                 \ after compiling a branch destination
  412.                 off> ?opt
  413.                 here-t 1- =: opt_limit ;
  414.  
  415. : ?reopt        ( -- )          \ re-enable the optimizers if they were
  416.                                 \ turned off for a while
  417.                 ?0opt1 =: ?opt ;
  418.  
  419. : /definit      ( -- )         \ include the TYPE & SPACES initialization
  420.                                 \ code in the compiled image file
  421.                 on> ?definit ;
  422.  
  423. : /definitoff     ( -- )          \ don't initialize TYPE and SPACES
  424.                 ?interpretive ?exit
  425.                 off> ?definit ;
  426.  
  427. ' /definitoff alias /noinit
  428.  
  429. /definit
  430.  
  431. : check_/noinit ( -- )          \ verify the /NOINIT option is in effect
  432.                 ?definit
  433.                 if      cr beep
  434.                         cr seqhandle count type
  435.                            ."  should be used with the /NOINIT option."
  436.                         cr cr beep
  437.                 then    ;
  438.  
  439. : check_/definit ( -- )         \ verify the /DEFINIT option is in effect
  440.                 ?definit 0=
  441.                 if      cr beep
  442.                         cr seqhandle count type
  443.                            ."  should be used with the /DEFINIT option."
  444.                         cr cr beep
  445.                 then    ;
  446.  
  447. : /lst          ( -- )          \ enable the creation of a listing file
  448. \unless /code   /code           \ include output code
  449. \unless /src    /src            \ and source code
  450.                 on> ?lst ;
  451.  
  452. ' /lst alias /list
  453.  
  454. : /lstoff       ( -- )          \ don't build a listing file
  455.                 off> ?lst ;
  456.  
  457. ' /lstoff   alias /nolst
  458. ' /lstoff   alias /nolist
  459. ' /lstoff   alias /listoff
  460. ' showlines alias /src
  461. ' hidelines alias /srcoff
  462. ' hidelines alias /nosrc
  463.  
  464. /srcoff
  465. /lstoff
  466.  
  467. : /show         ( -- )          \ show the symbols on the screen as they
  468.                                 \ are compiled
  469.                 on> ?show ;
  470.  
  471. ' /show alias /sho
  472.  
  473. : /showoff      ( -- )          \ don't show the symbols on the screen
  474.                                 \ as they are compiled. This is the default
  475.                                 \ mode.
  476.                 off> ?show ;
  477.  
  478. ' /showoff alias /noshow
  479.  
  480. /showoff
  481.  
  482. : /quiet        ( -- )
  483.                 on> ?quiet
  484.                 slow
  485. \u statoff      statoff
  486.                 ;
  487.  
  488. ' /quiet alias /q
  489.  
  490. code #bye       ( n1 -- )
  491.                 pop ax
  492.                 mov ah, # $4C
  493.                 int $21
  494.                 next            end-code
  495.  
  496. : newbye        ( -- )
  497.                 RESTORE_VECTORS
  498.                 BYEFUNC
  499.                 cerrors #bye ;
  500.  
  501. ' newbye >body @ ' bye >body !  \ link NEWBYE into BYE
  502.  
  503. : /bye          ( -- )          \ leave compiler after the compile
  504.                 bye ;
  505.  
  506. : /stay         ( -- )
  507.                 off> ?bye ;
  508.  
  509. ' /stay alias /sta
  510.  
  511. \u newfile : /edit ( <filename> -- )    \ edit file specified, don't compile
  512. \u newfile         newfile bye ;
  513.  
  514. \u newfile      ' /edit alias /e
  515.  
  516. \ ***************************************************************************
  517. \ Interpret the "TCOM=" string from the environment.
  518.  
  519. create env$ 256 allot
  520.  
  521. : env@          ( a1 n1 --- )         \ extract the command spec
  522.                 dup>r   "envfind 0=
  523.                 if      drop env$ off
  524.                 else    r@ + envsize swap
  525.                         env$ dup clr-hcb >nam -rot
  526.                         do      evseg i c@l 0= ?leave
  527.                                 evseg i c@l over c! 1+
  528.                                 1 env$ c+!
  529.                         loop    drop
  530.                 then    r>drop ;
  531.  
  532. : env_interpret ( -- )
  533.                 " TCOM=" env@           \ get the "TCOM=" string from environ
  534.                 env$ c@ 0= ?exit        \ leave if nothing to interpret
  535.                 save> 'tib
  536.                 save> #tib
  537.                 save> >in
  538.                 env$ count #tib ! 'tib ! >in off        \ set to interpret
  539.                 interpret                               \ an interpret it
  540.                 restore> >in
  541.                 restore> #tib                           \ restore everything
  542.                 restore> 'tib ;
  543.  
  544. : tcom_path@    ( -- )
  545.                 " TPATH=" env@
  546.                 env$ count fpath$ place ;
  547.  
  548. \ ***************************************************************************
  549. \ A display word so user has something to watch while compiling
  550.  
  551. 0 value spinval
  552.  
  553. : spinner       ( -- )
  554.                 ?lst ?show or ?quiet or ?exit
  555.                 incr> spinval
  556.                 spinval 1 and ?exit
  557.                 at?
  558.                 " |/-\" drop spinval 2/ 3 and + 1 type
  559.                 at ;
  560.  
  561. : spinner2      ( -- )
  562.                 ?lst ?show or ?quiet or ?exit
  563.                 incr> spinval
  564.                 spinval 1 and ?exit
  565.                 at? over 2+ over at
  566.                 " |/-\" drop spinval 2/ 3 and + 1 type
  567.                 spinval 7 and 0=
  568.                 if      space >attrib3 space
  569.                         here-t code-start - dup 1  u.r ." _Code+"
  570.                         here-d data-start - dup 1  u.r ." _Data="
  571.                                      0 tuck d+  1 ud.r ." _Total"
  572.                         space >norm
  573.                 then
  574.                 at ;
  575.  
  576. \ ***************************************************************************
  577. \ Zero out one local label, so we can have more than one set of
  578. \ conditionals in a colon definition. Used with -BR# above.
  579. \ See MACRO REPEAT for an example of usage.
  580.  
  581. : 01lab         ( n1 -- )       \ zero out one label for re-use
  582.                 [assembler]
  583.                 a;
  584.                 llab>line b/llab erase ;
  585.  
  586. : BR#SWAP       ( -- )          \ exchange two most recent branch array
  587.                                 \ elements.
  588.                 [assembler]
  589.                 a;
  590.                 br# 2- dup
  591.                 [forth]
  592.                 0<
  593.                 if      0 " Attempt to resolve an branch label" "errmsg2
  594.                         abort
  595.                 then
  596.                 [assembler]
  597.                 llab>line dup>r pad b/llab 2* cmove
  598.                 pad    b/llab + r@  b/llab    cmove
  599.                 pad r> b/llab +     b/llab    cmove ;
  600.  
  601. \ ***************************************************************************
  602. \ Define the fields of the BODY of a target compiler provided function.
  603. \
  604. \ here is the structure of a function BODY:
  605. \
  606. \   +0     +1         +6            +8          +10         +12
  607. \   ┌──────┬──────────┬─────────────┬───────────┬───────────┬───────────┐
  608. \   │ type │ JMP NEST │ res-address │ res-chain │ Ref-count │ Data-size │
  609. \   └──────┴──────────┴─────────────┴───────────┴───────────┴───────────┘
  610. \
  611. \ FIELD builds words that adjust to the various fields of the body
  612.  
  613.  
  614. : field         ( n1 n2 -- n3 )         \ compile time
  615.                 ( a1 -- a2 )
  616.                 create over c, +        \ compile offset & increment to next
  617.                 ;code   pop bx          \ get pointer to
  618.                         sub ax, ax      \ clear AX
  619.                         mov al, 0 [bx]  \ get byte field offset into AL
  620.                         add ax, # 3     \ offset to body
  621.                         mov di, sp      \ get a copy of stack pointer
  622.                         add 0 [di], ax  \ add AX to address on stack
  623.                         next
  624.                 end-code
  625.  
  626. \ Equivelant high level code for above assembly ;code.
  627. \
  628. \               does> c@ swap >body +   \ adjust a1 to field address a2
  629. \                                       \ from CFA
  630.  
  631. 0                       \ starting at field offset zero (0),
  632.                         \ define field operators
  633.   1 field >dtype        \ definition type byte
  634.   5 field >execute      \ execution address to compile word
  635.   2 field >resaddr      \ resolution address
  636.   2 field >chain        \ chain of unresolved references
  637.   2 field >count        \ count of times used
  638.   2 field >dsize        \ size of data symbol
  639.   2 field >dinitial     \ initial value of VALUEs
  640.   2 field >inited       \ has value been initialized yet
  641. drop                    \ cleanup stack
  642.  
  643. \ ***************************************************************************
  644. \ Make data type constants for target objects
  645.  
  646. : dtype         ( n1 | <name> -- n2 )
  647.                 dup constant 1+ ;
  648.  
  649. \    !!!!  DO NOT CHANGE THE ORDER OF ANY OF THE FOLLOWING WORDS !!!!
  650. \ These constants also specify the execution order in the later "EXEC:"
  651. \ words LIB_COMPILE and TARG_COMPILE.
  652.  
  653. 0       \ these must start with ZERO for the EXEC: in TARG_COMPILE later
  654.         \ in this file to work properly.
  655.  
  656.         ( Macro )       dtype {M}       \    ─┐
  657.         ( Constant )    dtype {C}       \     ├─ these MUST to be together,
  658.         ( 2Constant )   dtype {2C}      \     │  between statments are used
  659.         ( FConstant )   dtype {F}       \    ─┘  later to check for a range
  660.         ( Data )        dtype {D}       \        of types.
  661.         ( Value )       dtype {V}
  662.         ( Subroutine )  dtype {S}
  663.         ( dEfer )       dtype {E}
  664.         ( Table )       dtype {T}
  665. drop
  666.  
  667. \ ***************************************************************************
  668. \ Debug support for target compiler
  669.  
  670. \u (see)        : tsee          ( | <name> -- )
  671. \u (see)                        ' >execute (see) ;
  672.  
  673. \u ldump        : tdump         ( a1 n1 -- )
  674. \u ldump                        seg-code -rot ldump ;
  675.  
  676. \       ONLY make TDIS if the disassembler is available
  677.  
  678. \unless =seg    : tdis  ( a1 --- ) seg-code =seg dis ;
  679.  
  680. \u adebug       : tdebug        ( | <name> -- )
  681. \u adebug                       ' >execute adebug ;
  682.  
  683. \ ***************************************************************************
  684. \ Symbol write routines, builds a simple symbol table for BXDEBUG.
  685.  
  686. 1024 constant symwsize
  687.   handle symhndl                \ file handle for symbol writing
  688.   create symbuf  32 allot       \ symbol name buffer
  689.   create symwbuf symwsize allot \ symbol write buffer
  690. 0 value  symwcnt                \ symbol write buffer character count
  691. 0 value  ?sym
  692. 0 value  ?typed                 \ include data type flag bit in symbol name?
  693. 0 value  ?lin
  694. 0 value  ?noredef               \ allow redefinitions
  695. 0 value  ?dis                   \ load disassembler?
  696. 0 value  ?dbg                   \ load debugger?
  697.  
  698.   defer  symheader      ' noop is symheader
  699.   defer  symfooter      ' noop is symfooter
  700.   defer  symwrite       ' noop is symwrite
  701.  
  702. : /symoff       ( -- )          \ don't create a symbol table
  703.                 off> ?sym ;
  704.  
  705. ' /symoff alias /nosym
  706.  
  707. /symoff                         \ default is no symbol table file
  708.  
  709. : ?symopen      ( -- f1 )       \ is symbol file open, if not make it
  710.                                 \ return f1=true if symbol file is open
  711.                 symhndl >hndle @ 0<
  712.                 if      off> symwcnt                    \ reset buffer len
  713.                         symbol.name symhndl $>handle
  714.                         symhndl hcreate dup
  715.                         if      0 " Could not make symbol file." "errmsg2
  716.                                 off> ?sym
  717.                         else    symheader
  718.                         then 0=
  719.                 else    true
  720.                 then    ;
  721.  
  722. : symwflush     ( -- )          \ write symbol buffer contents to disk
  723.                 symwbuf symwcnt symhndl hwrite drop
  724.                 off> symwcnt ;
  725.  
  726. : symbwrite     ( a1 n1 -- )    \ buffered write to symbol file
  727.                 >r                              \ preserve len on return stk
  728.                 symwcnt r@ + symwsize >=        \ write buffer full?
  729.                 if      symwflush               \ then flush buffer
  730.                 then
  731.                 symwbuf symwcnt + r@ cmove      \ append data
  732.                 r> +!> symwcnt ;                \ adj count
  733.  
  734. : symcr         ( -- )          \ write a CRLF to symbol file
  735.                 $0A0D sp@ 2 symbwrite drop ;     \ write CRLF
  736.  
  737. : symclose      ( -- )          \ close the symbol file if it was open
  738.                 ?sym
  739.                 if      symfooter
  740.                         symwflush                       \ write any remaining stuff
  741.                         symhndl hclose drop             \ and close the file
  742.                         off> ?sym
  743.                 then    ;
  744.  
  745. : symbye        ( -- )          \ function to perform when leaving forth
  746.                 symclose
  747.                 defers byefunc ;
  748.  
  749. ' symbye is byefunc
  750.  
  751. \ ***************************************************************************
  752. \ The following four words can be redefined to allow building a symbol table
  753. \ in a different format than is provided. You will need to know the format
  754. \ of the symbol table you want to generate.
  755.  
  756. : %symheader    ( -- )          \ write header for debugger symbol file
  757.                 ;
  758.  
  759. : %symfooter    ( -- )          \ write footer for debugger symbol file
  760.                 symcr
  761.                 $001A sp@ 2 symbwrite drop ;     \ write Ctrl Z & null
  762.  
  763. : %symwrite     ( a1 -- a1 )    \ a1 = CFA of symbol
  764.                 ?symopen
  765.                 if      dup>r
  766.                         symcr
  767.                         dup >resaddr @ 0 <# # # # # #>  symbwrite
  768.                         spcs 1                          symbwrite
  769.                         yseg @ over >name ?cs: symbuf 32 cmovel
  770.                         symbuf c@ 31 and symbuf c!
  771.                         symbuf count + 1- dup c@ 127 and swap c!
  772.                         ?typed
  773.                         if      r@ >dtype c@ dup  {S} =
  774.                                              swap {M} = or
  775.                                 if      $80 symbuf 1+ c+!   then
  776.                         then    r>drop
  777.                         symbuf count                    symbwrite
  778.                 then    ;
  779.  
  780. : /sym          ( -- )          \ create a symbol table file for BXDEBUG
  781.                 " SYM" ">$ symbol.name  $>ext   \ set the file extension
  782.                 ['] %symheader is symheader     \ install the defered
  783.                 ['] %symfooter is symfooter     \ symbol table building
  784.                 ['] %symwrite  is symwrite      \ words.
  785.                 on> ?sym                        \ turn on symbol generation
  786.                 off> ?typed                     \ don't include type flag
  787.                 on> ?lin ;                      \ and line table generation
  788.  
  789. ' /sym    alias /symbols
  790.  
  791. : /redefok      ( -- )  off> ?noredef ;
  792. : /noredef      ( -- )  on> ?noredef ;
  793.  
  794. /noredef        \ default to no redefinition allowed
  795.  
  796. : /forth        ( -- )          \ enable interpretive Forth in target
  797.                 on> ?interpretive
  798.                 /sym
  799.                 on> ?typed
  800.                 /definit ;
  801.  
  802. : /dis          ( -- )          \ enable disassembly in target
  803.                 on> ?dis
  804.                 /forth ;
  805.  
  806. : /nodis        ( -- )  off> ?dis ;
  807.  
  808. : /debug        ( -- )          \ enable debugging in target
  809.                 on> ?dbg
  810.                 /dis ;
  811.  
  812. ' /debug alias /dbg
  813.  
  814. : /nodebug      ( -- )  off> ?dbg ;
  815.  
  816. \ ***************************************************************************
  817. \ perform the compile
  818.  
  819. : ?$fload       ( a1 f1 -- f2 )
  820.                 if      $fload
  821.                 else    drop false
  822.                 then    ;
  823.  
  824. : do_ok         ( -- )
  825.                 target-initialize       \ initialize the target compiler
  826.                 ok                      \ compile the currently open file
  827.                 ?interpretive 0= ?exit
  828.                 /redefok        \ allow redefinitions
  829.                 " DIS.SEQ" ">$ ?dis ?$fload
  830.                 if      cr ." Couldn't open " seqhandle count type
  831.                         ." , no disassembler will be available."
  832.                 then
  833.                 " TDEBUG.SEQ" ">$ ?dbg ?$fload
  834.                 if      cr ." Couldn't open " seqhandle count type
  835.                         ." , no debugger will be available."
  836.                 then
  837.                 " TFORTH.SEQ" ">$ $fload
  838.                 if      cr ." Couldn't open " seqhandle count type
  839.                         ." , can't append a Forth environment."
  840.                 then    ;
  841.  
  842. \ ***************************************************************************
  843.  
  844. 0 value prevline
  845. handle linhndl
  846.  
  847. : /lin          ( -- )
  848.                 on> ?lin ;
  849.  
  850. : /linoff       ( -- )
  851.                 off> ?lin ;
  852.  
  853. : ?linopen      ( -- )
  854.                 linhndl >hndle @ 0<
  855.                 if      lines.name linhndl $>handle
  856.                         linhndl hcreate
  857.                         if      0 " Could not make lines file." "errmsg2
  858.                                 off> ?lin
  859.                         then
  860.                         -1 =: prevline
  861.                 then    ;
  862.  
  863. : linclose      ( -- )          \ close the lines file if it was open
  864.                 ?lin
  865.                 if      $0A0D sp@ 2 linhndl hwrite 2drop
  866.                         $001A sp@ 2 linhndl hwrite 2drop
  867.                         linhndl hclose drop             \ and close the file
  868.                         off> ?lin
  869.                 then    ;
  870.  
  871. : linbye        ( -- )          \ function to perform when leaving forth
  872.                 linclose
  873.                 defers byefunc ;
  874.  
  875. ' linbye is byefunc
  876.  
  877. : line->srcfile ( -- )
  878.                 ?lin 0= ?exit
  879.                 prevline loadline @ = ?exit     \ leave if already written
  880.                 ?linopen
  881.                 save> base hex
  882.                 here-t          0 <# bl hold # # # # #> linhndl hwrite drop
  883.                 loadline @ 1 =
  884.                 if      seqhandle count linhndl hwrite drop
  885.                 then
  886.                 loadline @ =: prevline
  887.                 $0A0D sp@ 2 linhndl hwrite 2drop
  888.                 restore> base ;
  889.  
  890. : srcrun        ( -- )
  891.                 line->srcfile
  892.                 defers interpret ;
  893.  
  894. ' srcrun is interpret
  895.  
  896. : srcloading    ( -- a1 )       \ to be plugged into LOADING of comment
  897.                                 \ functions.
  898.                 line->srcfile
  899.                 loading ;
  900.  
  901. ' srcloading ' <comment:>  >body @ xseg @ + 0 !L        \ fix COMMENT:
  902. ' srcloading ' <.comment:> >body @ xseg @ + 0 !L        \ fix .COMMENT:
  903. ' srcloading ' <#if>       >body @ xseg @ + 0 !L        \ fix #IF
  904.  
  905. \ ***************************************************************************
  906. \ output error messages
  907.  
  908. true
  909. \u >pathend"    drop false      \ load following if >PATHEND" not defined
  910. #IF
  911. : >pathend"     ( a1 --- a2 n1 )        \ return a2 and count=n1 of filename
  912.                 count
  913.                 begin   2dup '\' scan ?dup
  914.                 while   2swap 2drop 1 -1 d+
  915.                 repeat  drop ;
  916. #ENDIF
  917.  
  918. : "errmsg       ( cfa a1 n1 -- )        \ display error message
  919.                 [ hidden ]
  920.                 cr seqhandle >pathend" type     \ display filename
  921.                 ." (" loadline @ 1 .r ." ) "    \ and line number where found
  922.                 rot ?dup                        \ display cfa if non-zero
  923.                 if      dup >name .id ." at " h.
  924.                 else    fhere count type space
  925.                 then    type                    \ display message
  926.                 incr> cerrors ;                 \ bump found error count
  927.  
  928.                 ' "errmsg is "errmsg2
  929. \u "errmsg3     ' "errmsg is "errmsg3
  930.  
  931. \ ***************************************************************************
  932. \ Make a header in target
  933.  
  934. 0 value ?header
  935.  
  936. : /header       ( -- )                  \ enable building headers in target
  937.                 on> ?header ;
  938.  
  939. : /nohead       ( -- )                  \ disable building headers in target
  940.                 off> ?header ;
  941.  
  942. /nohead                                 \ default to no headers in target
  943.  
  944. defer comp_header       ' drop is comp_header   \ default to nothing
  945.  
  946. : make_header   ( a1 -- )
  947.                 ?header
  948.                 if      yseg @ over >name ?cs: symbuf 32 cmovel
  949.                         symbuf c@ 31 and symbuf c!
  950.                         symbuf count + 1- dup c@ 127 and swap c!
  951.                         symbuf comp_header
  952.                 then    drop ;
  953.  
  954. \ ***************************************************************************
  955. \ Create a new symbol of type c1.
  956.  
  957. : new_symbol    ( c1 -- )       \ add a new symbol  of type c1 to symbol list
  958.                 current @ context !             \ initialize things
  959.                 create
  960.                 ( c1 ) c,                       \ +0 type BYTE "C"all
  961.                 !csp                            \ save stack
  962.                 233 C,                          \ +1      BYTE JMP
  963.                 >nest fhere 2+ - ,              \ +2      WORD DOCOL relative
  964.                 xhere paragraph + dup xdpseg !  \ align LIST
  965.                 xseg @ - ,                      \ +4      WORD LIST relative
  966.                 xdp off ;                       \ reset OFFSET
  967.  
  968. \ ***************************************************************************
  969. \ Display a symbol
  970.  
  971. : %.asymbol     ( a1 -- )       \ a1 = CFA of symbol
  972.                 save> base hex
  973.                 @> .inst ['] noop <>
  974.                 if      cr
  975.                         dup >resaddr @ 0 <# # # # # #> type
  976.                         space 7 0 do ." -----" loop space
  977.                         dup >name .id
  978.                 else    ?show
  979.                         if      ?cr
  980.                                 dup >resaddr @ 0 <# # # # # #> type
  981.                                 2 spaces dup >name .id
  982.                                 tab
  983.                         then
  984.                 then    ?sym
  985.                 if      symwrite
  986.                 then    drop
  987.                 restore> base spinner2 ;
  988.  
  989. defer .asymbol  ' %.asymbol is .asymbol
  990.  
  991. \ ***************************************************************************
  992. \ Display a macro name when used
  993.  
  994. : ?.macro       ( a1 -- )       \ a1 = CFA of symbol
  995.                 @> .inst ['] noop <>
  996.                 if      cr ." --M-- "
  997.                         dup >name .id
  998.                 then    drop ;
  999.  
  1000. \ ***************************************************************************
  1001. \ Stack for items to be resolved at the end of the current definition compile.
  1002.  
  1003. 128 constant max_res    \ maximum number of symbols to resolve at one time
  1004.  
  1005. create res_stack max_res 2+ 2* allot
  1006.        res_stack max_res 2+ 2* erase  \ clear stack
  1007.  
  1008. 0 value resptr          \ resolution stack pointer
  1009.  
  1010. : >res          ( a1 -- )       \ add symbol a1 to symbols to be resolved
  1011.                 res_stack resptr + !
  1012.                 resptr 2+ max_res 2* >
  1013.                 if      0 " Exceeded allowed depth of Resolution Stack!"
  1014.                         "errmsg abort
  1015.                 then
  1016.                 2 +!> resptr ;
  1017.  
  1018. : res>          ( -- a1 )       \ get an item from the resolution stack
  1019.                 resptr 2 <
  1020.                 if      0 " Resolve Stack Underflow!" "errmsg abort
  1021.                 then
  1022.                 -2 +!> resptr
  1023.                 resptr res_stack + @ ;
  1024.  
  1025. : ?resdepth     ( -- n1 )       \ return depth of resolution stack in items
  1026.                 resptr 2/ ;
  1027.  
  1028. \ ***************************************************************************
  1029. \ Macro defining words. MACRO's compile IN-LINE assembly code when
  1030. \ executed at their ">EXECUTE" address. Compiled ONLY if referenced,
  1031. \ and EVERY time referenced.
  1032.  
  1033. DEFER MACRO-START
  1034.  
  1035. : MACRO         ( | <name> -- )
  1036.                 fhere >r
  1037.                 {M}  new_symbol                 \ +0    BYTE "M"acro
  1038.                 -1 ,                            \ +6    WORD unresolved sym
  1039.                 0 ,                             \ +8    WORD unresolved chain
  1040.                 0 ,                             \ +10   WORD reference count
  1041.                 compile (lit)                   \ compile (lit)
  1042.                 r> x,                           \ followed by addr of symbol
  1043.                 compile ?.macro
  1044.                 macro-start
  1045. \ ****          hide
  1046.                 ] ;                        \ compile remaining portion
  1047.  
  1048. DEFER END-MACRO IMMEDIATE       \ see the library for this definition
  1049.  
  1050. \ ***************************************************************************
  1051. \ Add a symbol that is being used, but is not yet defined.
  1052.  
  1053. : add_symbol    ( a1 -- )               \ add a symbol not yet resolved
  1054.                 >r                      \ Save a1 out of the way of !CSP
  1055.                                         \ in NEW_SYMBOL.
  1056.                 {S}  new_symbol         \ +0    BYTE type "S" a SUBROUTINE
  1057.                 -1 ,                    \ +6    WORD resolved address
  1058.                 r> ,                    \ +8    WORD unresolved chain
  1059.                 0 , ;                   \ +10   WORD reference count
  1060.  
  1061. \ ***************************************************************************
  1062. \ resolve one symbol a1 to here-t
  1063.  
  1064. 0 value ?inline
  1065.  
  1066. DEFER RESOLVE_1 ( a1 -- )
  1067.  
  1068. : %resolve_1    ( a1 -- )               \ resolve one reverence to HERE-T
  1069.                 here-t over 2+ - swap !-T ;
  1070.  
  1071. ' %resolve_1 is resolve_1               \ link in default resolver
  1072.  
  1073. : res_symbol    ( a1 -- )               \ resolve here-t to a1
  1074.                 ?inline         \ don't resolve if compiled INLINE
  1075.                 if      .asymbol
  1076.                 else    dup >resaddr @ -1 =
  1077.                         if      dup make_header
  1078.                                 here-t over >resaddr !  \ resolve symbol
  1079.                                 dup .asymbol
  1080.                                 >chain  dup @ swap off  \ resolve chain
  1081.                                 begin   ?dup
  1082.                                 while   dup @-t swap resolve_1
  1083.                                                         \ resolve one ref
  1084.                                 repeat
  1085.                         else    drop
  1086.                         then
  1087.                         0br#            \ clear the branch control stuff
  1088.                         clear_labels
  1089.                 then    ;
  1090.  
  1091. \ ***************************************************************************
  1092. \ Either resolve a symbol already defined, or make a new symbol if its not
  1093. \ yet defined.  Flag if already defined and resolved.
  1094.  
  1095. 0 value tsym_bottom
  1096.  
  1097. : do_symbol     ( | <name> -- )
  1098.                 >in @ >r                        \ save >IN for later
  1099.                 defined dup
  1100.                 if      drop                    \ discard flag
  1101.                         dup tsym_bottom u>      \ is it a real symbol
  1102.                 then
  1103.                 if      dup  >resaddr @ -1 <>   \ already resolved or
  1104.                                                 \ its a MACRO, CONSTANT or
  1105.                                                 \ 2CONSTANT
  1106.                         over >dtype c@ {M} {F} between or
  1107.                         ?noredef and
  1108.                         if      " Attempt to REDEFINE a symbol! " "errmsg
  1109.                         else    res_symbol
  1110.                         then
  1111.                 else    drop
  1112.                         r@ >in !
  1113.                         fhere >r
  1114.                         0 add_symbol            \ add a new symbol
  1115.                         r@ make_header
  1116.                         here-t r@ >resaddr !    \ resolve address
  1117.                         r> .asymbol
  1118.                 then    r>drop ;
  1119.  
  1120. \ ***************************************************************************
  1121. \ When actually target compiling code, compile a call to a routine
  1122.  
  1123.                         \ see the library for this definition
  1124. DEFER COMP_CALL         ( a1 -- )       \ a1 = CFA of symbol
  1125. DEFER COMP_JMP_IMM      ( a1 -- )       \ a1 = actual code addr
  1126. DEFER SUB_RET           ( -- )          \ subtract one RET instruction
  1127.  
  1128. : compile_call  ( a1 -- )               \ compile call to routine
  1129.                 @> .inst ['] noop <>
  1130.                 if      save> base hex
  1131.                         cr
  1132.                         here-t 0 <# # # # # #> type 4 spaces
  1133.                         ." CALL "
  1134.                         dup >name .id
  1135.                         restore> base
  1136.                 then    comp_call ;
  1137.  
  1138. \ ***************************************************************************
  1139. \ resolver for the data type definitions
  1140.  
  1141. : ?dresolve     ( a1 -- a1 )            \ resolve symbol if needed
  1142.                                         \ not CONSTANT or 2CONSTANT
  1143.                 dup >dtype c@ {C} {F} between 0=
  1144.                 over >resaddr @ -1 = and        \ not yet resolved
  1145.                 if      here-d over >resaddr !  \ set start address
  1146.                         dup >dsize @ allot-d    \ allocate needed space
  1147.                         dup .asymbol            \ show symbols name
  1148.                 then    ;                       \ return address in DS:
  1149.  
  1150. \ ***************************************************************************
  1151. \ resolver for the TABLE type definition
  1152.  
  1153. : ?tresolve     ( a1 -- a1 )            \ resolve symbol if needed
  1154.                                         \ NOT CONSTANT OR 2CONSTANT
  1155.                 dup >dtype c@ {C} {F} between 0=
  1156.                 over >resaddr @ -1 = and        \ not yet resolved
  1157.                 if      here-d over >resaddr !  \ set start address
  1158.                         dup >dsize length s,-d  \ move table to target
  1159.                         dup .asymbol            \ show symbols name
  1160.                 then    ;                       \ return address in DS:
  1161.  
  1162. \ ***************************************************************************
  1163. \ perform the in-line compiling/handling of numbers
  1164.  
  1165.                         \ see the library for these definitions
  1166. DEFER COMP_SINGLE       \ compile a single precision number
  1167. DEFER COMP_FETCH        \ see library
  1168. DEFER COMP_STORE        \ see library
  1169. DEFER COMP_PERFORM      \ see library
  1170. DEFER COMP_OFF          \ see library
  1171. DEFER COMP_ON           \ see library
  1172. DEFER COMP_INCR         \ see library
  1173. DEFER COMP_DECR         \ see library
  1174. DEFER COMP_PSTORE       \ see library
  1175. DEFER COMP_SAVE         \ see library
  1176. DEFER COMP_SAVEST       \ see library
  1177. DEFER COMP_REST         \ see library
  1178. DEFER COMP_FPUSH        \ see library
  1179.  
  1180.                                         \ resolve and compile a single number
  1181. : res_comp_single ( a1 -- )             \ a1 = address of symbol
  1182.                 ?dresolve
  1183.                 dup >count incr
  1184.                 >resaddr @ comp_single ;
  1185.  
  1186. : res_comp_double ( a1 -- )             \ compile a double number, is already
  1187.                 dup >count incr         \ resolved, since used only for
  1188.                 dup >dinitial @ comp_single     \ 2CONSTANT's
  1189.                     >resaddr  @ comp_single ;
  1190.  
  1191. : res_comp_fconst ( a1 -- )             \ compile a floating constant
  1192.                 dup >count incr
  1193.                 dup >dinitial @ comp_single
  1194.                     >resaddr  @ comp_single
  1195.                                 comp_fpush ;
  1196.  
  1197. : res_comp_value  ( a1 -- )             \ resolve and compile single, plus
  1198.                                         \ move initial VALUE into target
  1199.                 dup res_comp_single
  1200.                 comp_fetch                      \ follow with a fetch
  1201.                 dup >inited @ 0=                \ value initialized?
  1202.                 if      dup >dinitial @         \ get initial value
  1203.                         over >resaddr @ !-d     \ store in target
  1204.                         dup >inited on          \ mark as initialized
  1205.                 then    drop ;
  1206.  
  1207. : res_comp_defer ( a1 -- )
  1208.                 res_comp_single comp_perform ;
  1209.  
  1210. : res_comp_macro    ( a1 -- )
  1211.                 dup >r  >execute execute  r> >count incr ;
  1212.  
  1213. : res_comp_call ( a1 -- )
  1214.                 dup compile_call >count incr ;
  1215.  
  1216. : res_comp_table ( a1 -- )
  1217.                 execute comp_single ;
  1218.  
  1219. \ ***************************************************************************
  1220. \ These words expect a literal to follow compiled inline. They pick up the
  1221. \ literal and pass it as a parameter to the function specified.  This
  1222. \ technique saves two bytes per occurance of the specified operation, for
  1223. \ a savings of about 2k in the target compiler .EXE file size.
  1224.  
  1225. : inlines       ( a1 | <name> -- )      \ make words that pick up inline
  1226.                                         \ literals and pass them to
  1227.                                         \ functions as parameters
  1228.                 create ,
  1229.                 does> 2r@ @L r> 2+ >r swap perform ;
  1230.  
  1231. ' res_comp_single inlines res_comp_lit
  1232. ' res_comp_double inlines res_comp_dbl
  1233. ' res_comp_fconst inlines res_comp_fcn
  1234. ' res_comp_value  inlines res_comp_val
  1235. ' res_comp_call   inlines res_comp_cll
  1236. ' res_comp_defer  inlines res_comp_def
  1237. ' res_comp_table  inlines res_comp_tbl
  1238. ' comp_single     inlines comp_lit
  1239.  
  1240. \ ***************************************************************************
  1241. \ Resolve forward references by executing the unresolved resolution stack
  1242. \ until it is empty. As each CFA on the resolution stack is executed, its
  1243. \ definition is compiled, possibly putting additional words on the
  1244. \ resolution stack.
  1245.  
  1246. : do_resolve    ( -- )                  \ execute the resolve stack
  1247.                 ?inline ?exit
  1248. \u ?long        ?long_lib save!> ?long  \ use short branches for library
  1249.                 begin   ?resdepth       \ do it till its empty
  1250.                 while   res>
  1251.                         dup >count incr
  1252.                         dup >resaddr @ -1 =
  1253.                         if      >execute execute
  1254.                         else    drop
  1255.                         then
  1256.                 repeat
  1257. \u ?long        restore> ?long
  1258.                 ;
  1259.  
  1260. \ ***************************************************************************
  1261. \ Library code routines, used for CODE definitions that are accessed by
  1262. \ CALL rather than MACRO. An LCODE routine is only included in the
  1263. \ target if it is referenced.
  1264.  
  1265. DEFER LCODE-START
  1266.  
  1267. : LCODE         ( | <name> -- )         \ Library CODE routine
  1268.                 fhere >r                \ save here for later
  1269.                 0 add_symbol            \ make a symbol not yet used
  1270.                 compile (lit)           \ compile (lit)
  1271.                 r> x,                   \ followed by addr of symbol
  1272.                 compile res_symbol      \ resolve usage of symbol
  1273.                 lcode-start
  1274.                 ] ;                \ compile remaining portion
  1275.  
  1276. DEFER END-LCODE IMMEDIATE       \ see the library for this definition
  1277.  
  1278. : LLABEL        ( | <name> -- )         \ Library LABEL routine
  1279.                 LCODE
  1280.                 does> body>
  1281.                 dup >resaddr @ 0<
  1282.                 if      dup >chain @ swap       \ link chain @ to here
  1283.                         here-t 1+ over >chain ! \ link here+1 into chain
  1284.                         >res                    \ add to resolution stack
  1285.                 else    >resaddr @
  1286.                 then    ;
  1287.  
  1288. \ ***************************************************************************
  1289. \ Library and Target compiler functions. These words either compile actual
  1290. \ code into the target "TARG_COMPILE", or compiler functions into the library
  1291. \ "LIB_COMPILE" that will LATER compile code into the target.
  1292.  
  1293. : LIB_COMPILE   ( a1 -- )
  1294.                 dup >dtype c@   \ body contains TYPE byte
  1295.                 case
  1296. ( Macro )       {M}  of  >execute x,                            endof
  1297. ( Constant )    {C}  of  compile res_comp_lit    x,             endof
  1298. ( 2Constant )  {2C}  of  compile res_comp_dbl    x,             endof
  1299. ( FConstant )   {F}  of  compile res_comp_fcn    x,             endof
  1300. ( Data )        {D}  of  compile res_comp_lit    x,             endof
  1301. ( Value )       {V}  of  compile res_comp_val    x,             endof
  1302. ( Subroutine )  {S}  of  compile res_comp_cll    x,             endof
  1303. ( dEfer )       {E}  of  compile res_comp_def    x,             endof
  1304. ( Table )       {T}  of  compile res_comp_tbl    x,             endof
  1305.                   ( elseof )
  1306.                         drop
  1307.                         " is NOT a target symbol! " "errmsg
  1308.                 endcase ;
  1309.  
  1310. : TARG_COMPILE  ( a1 -- )       \ Compile a target symbol
  1311.                                 \ body contains TYPE byte
  1312.                 dup >dtype c@ dup {M} {T} between
  1313.                 if      EXEC:
  1314. ( Macro )               res_comp_macro
  1315. ( Constant)             res_comp_single
  1316. ( 2Constant )           res_comp_double
  1317. ( FConstant )           res_comp_fconst
  1318. ( Data )                res_comp_single
  1319. ( Value )               res_comp_value
  1320. ( Subroutine)           res_comp_call
  1321. ( dEfer )               res_comp_defer
  1322. ( Table )               res_comp_table
  1323.                 else    drop
  1324.                         " is an invalid symbol! " "errmsg
  1325.                 then    ;
  1326.  
  1327. \ ***************************************************************************
  1328. \ Lookup a word from input stream, with auto TIB refill if needed.
  1329.  
  1330. 0 value tcomlow         \ lowest allowable target definition in TCOM
  1331.  
  1332. : TDEFINED      ( | <name> -- a1 f1 )   \ get a word from input stream
  1333.                 begin   @> >in =: >in-t
  1334.                         bl word dup c@ 0=       \ if nothing in line
  1335.                         ?fillbuff               \ optionally refill buffer
  1336.                 while   drop 0 >in !
  1337.                         filltib                 \ refill the buffer
  1338.                         line->srcfile
  1339.                         #tib @ 0=
  1340.                         if      0 " End of file reached while compiling!"
  1341.                                 "errmsg abort
  1342.                         then
  1343.                         spinner                 \ something to watch
  1344.                 repeat  skip'c' ?uppercase find ;
  1345.  
  1346. : target?       ( a1 f1 -- a2 f2 )      \ must be target word
  1347.                 dup
  1348.                 if      over tcomlow u<                 \ found too low?
  1349.                         over 0< and                     \ not immediate
  1350.                         if      2drop here false        \ not target word
  1351.                         then
  1352.                 then    ;
  1353.  
  1354. \ ***************************************************************************
  1355. \ Library COLON definitions. L: words are only included in the target
  1356. \ dictionary if they are referenced They are accessed with a CALL.
  1357. \ No forward references are allowed while creating Library definitions.
  1358. \ When L: words are later referenced, they are auto-resolving.
  1359.  
  1360. DEFER START-T:  ' NOOP IS START-T:
  1361.  
  1362. : (L:)          ( | <name> .. ;F -- )   \ define a function in host
  1363.                 ?exec
  1364.                 on> ?lib                \ librarying
  1365.                 fhere >r                \ save here for later
  1366.                 0 add_symbol            \ make a symbol not yet used
  1367.                 compile (lit)           \ compile (lit)
  1368.                 r> x,                   \ followed by addr of symbol
  1369.                 compile res_symbol      \ resolve usage of symbol
  1370.                 compile start-t:        \ start a colon definition
  1371.                 spinner2                \ something to look at
  1372.                 ;
  1373.  
  1374. : (LM:)         ( | <name> .. ;F -- )   \ define a function in host
  1375.                 ?exec
  1376.                 on> ?lib                \ librarying
  1377.                 0 add_symbol            \ make a symbol not yet used
  1378.                 spinner2                \ something to look at
  1379.                 ;
  1380.  
  1381. : (L])          ( -- )
  1382.                 state on
  1383.                 begin   ?stack  tdefined target? ?dup
  1384.                         if      0>
  1385.                                 if      execute     \ execute immediate words
  1386.                                 else    lib_compile \ compile into library
  1387.                                 then
  1388.                         else    number  double?
  1389.                                 if      swap dup
  1390.                                         compile comp_lit x,
  1391.                                 then    drop
  1392.                                         compile comp_lit x,
  1393.                         then    true    done?
  1394.                 until   off> ?lib ;
  1395.  
  1396. : [;]           ( --- )                 \ turn off compiling, but don't
  1397.                                         \ actually compile anything.
  1398.                 state @ 0=
  1399.                 if      0 " Not Compiling!" "errmsg
  1400.                 then
  1401.                 ?csp
  1402.                 [compile] [  ; immediate
  1403.  
  1404. DEFER END-L:                    \ See the library for this definition
  1405. DEFER END-LM:
  1406.  
  1407. : L:            ( | <name> -- )
  1408.                 (L:) (L])
  1409.                 END-L: ; immediate
  1410.  
  1411. : LM:           ( | <name> -- )
  1412.                 fhere >r
  1413.                 (LM:) (L])
  1414.                 END-LM:
  1415.                 {M} r> >dtype c! ;      \ data type is macro
  1416.  
  1417. : LALLOT        ( n1 -- )
  1418.                 drop
  1419.                 0 " Can't use ALLOT in the library!" "errmsg ;
  1420.  
  1421. : LASCII        ( | <letter> -- )       \ compile inline an ascii letter
  1422.                 bl word 1+ c@
  1423.                 compile comp_lit x, ; immediate
  1424.  
  1425. \ ***************************************************************************
  1426. \ A couple of variables used to determine how to resolve LOOPing branches
  1427. \ in the compiler.
  1428.  
  1429. VARIABLE ?DOING         ?DOING   OFF
  1430. VARIABLE ?LEAVING       ?LEAVING OFF
  1431.  
  1432. \ ***************************************************************************
  1433. \ Forward store and fetch words
  1434.  
  1435. : ?vvd          ( a1 -- <a1> f1 )       \ is it a value, variable or defered
  1436.                 dup >dtype c@            \ TYPE must be
  1437.                 dup  {V}  =              \ a VALUE or
  1438.                 over {D}  = or           \ a VARIABLE
  1439.                 swap {E}  = or 0=        \ a DEFERed word
  1440.         if      " Attempt to use !> type operator on an invalid symbol"
  1441.                 "errmsg true
  1442.         else    false
  1443.         then    ;
  1444.  
  1445. \ define words that pickup the following word and use it like a variable
  1446.  
  1447. defer for_does>
  1448.  
  1449. : %for_does>    ( a1 -- )
  1450.                 ' ?vvd
  1451.                 if      drop
  1452.                 else    ?lib
  1453.                         if      compile res_comp_lit x, @ x,
  1454.                         else            res_comp_single perform
  1455.                         then
  1456.                 then    ;
  1457.  
  1458. ' %for_does> is for_does>
  1459.  
  1460. : for>word      ( a1 | <name> -- )
  1461.                 create , immediate
  1462.                 does> for_does> ;
  1463.  
  1464. \ ***************************************************************************
  1465. \ Directs TCOM to compile the definition following inline in the current
  1466. \ colon definition being built. INLINE only works when preceeding references
  1467. \ to LIBRARY definitions.
  1468. \ ***************************************************************************
  1469.  
  1470. : INLINE        ( | <name> -- )
  1471.                 ' DUP >DTYPE C@ {S} =
  1472.                 IF      ON> ?INLINE             \ make it compile inline
  1473.                         >EXECUTE EXECUTE        \ compile it inline
  1474.                         SUB_RET
  1475.                         OFF> ?INLINE            \ restore NON-inline
  1476.                 ELSE    TARG_COMPILE
  1477.                 THEN    ; IMMEDIATE
  1478.  
  1479. \ Use NO_INLINE at the beginning of LIBRARY words that have multiple
  1480. \ exits. Note that NO_INLINE will only work in CODE words, NOT IN ICODE
  1481. \ words. Make sure that your ICODE words DON'T HAVE MULTIPLE EXITS!
  1482.  
  1483. : %NO_INLINE    ( -- )
  1484.                 ?INLINE
  1485.                 IF      0 " This word cannot be used INLINE!" "errmsg
  1486.                 THEN    ;
  1487.  
  1488. : NO_INLINE     ( -- )
  1489.                 COMPILE %NO_INLINE ; IMMEDIATE
  1490.  
  1491. : NO_TINLINE    ( -- )
  1492.                 0 " ONLY Library words can be INLINE" "errmsg ;
  1493.  
  1494. \ ***************************************************************************
  1495. \ New target CODE to create the proper target header and symbol.
  1496.  
  1497. DEFER TCODE-START
  1498.  
  1499. : TCODE         ( | <name> -- )         \ a target CODE word
  1500.                 fhere >r
  1501.                 do_symbol
  1502.                 ['] no_tinline >body @ r> >execute >body !
  1503.                                                 \ no target inline allowed
  1504.                                                 \ relink to error routine
  1505.                 tcode-start
  1506.                 ;                  \ "DO_SYMBOL" above marks this
  1507.                                         \ header as "LAST" wheather it makes
  1508.                                         \ a new header, or uses one that is
  1509.                                         \ already defined as in a forward
  1510.                                         \ reference resolution.
  1511.  
  1512. : TLABEL        ( | <name> -- )         \ a target LABEL word
  1513.                 TCODE
  1514.                 does> body> >resaddr @ ;
  1515.  
  1516. \ ***************************************************************************
  1517. \ Immediately compile either the CODE word or the MACRO being defined
  1518. \ after these words ICODE, or IMACRO. If the CODE word or MACRO being
  1519. \ defined contains no references to external symbols, then we can compile
  1520. \ the function now and simply move the compiled code into the target when
  1521. \ it is referenced rather than waiting until it is referenced and then
  1522. \ compiling it into the target. Use of these words makes the target
  1523. \ compiler somewhat faster and smaller. Again, the ICODE and IMACRO words
  1524. \ MUST CONTAIN ONLY STRAIGHT ASSEMBLY, WITH NO EXTERNAL REFERENCES!!
  1525.  
  1526. \ NOTE#1: The sequence "$FAEB fhere 5 - !" below is a short jump from the
  1527. \       second CFA of the ICODE and IMACRO words to the first CFA of the
  1528. \       ICODE and IMACRO words. In a normal CODE or MACRO word the second
  1529. \       CFA is executed to compile the function into the target. In these
  1530. \       words the first CFA needs to be executed to move the functions
  1531. \       object code into the target. Thus the jump is needed for proper
  1532. \       operation of the function.
  1533.  
  1534. : ICODE         ( | <name> -- a1 )      \ Immediate compiled Library CODE
  1535.                 {S}  new_symbol
  1536. ( see NOTE#1)   $FAEB fhere 5 - !       \ link target body to normal body
  1537.                                         \ make resolver just execute this
  1538.                                         \ DOES word
  1539.                 -1 ,                    \ mark unresolved sym
  1540.                 0 ,                     \ resolution chain
  1541.                 0 ,                     \ referenced count
  1542.                 fhere 0 ,               \ holds length of generated CODE
  1543.                 tcode-start
  1544. \ ****          hide
  1545.                 does>   body>
  1546.                 dup >resaddr @ -1 =             \ if not yet resolved
  1547.                 if      dup res_symbol          \ resolve symbol
  1548.                         here-t                  \ where code will lay down
  1549.                         over >dsize length s,-t \ move CODE to target
  1550.                         over >dsize @ ?.#dis    \ dissasem a1,n1
  1551.                 then        >count incr ;       \ bump usage
  1552.  
  1553. : IMACRO        ( | <name> -- a1 )      \ Immediate compiled Library MACRO
  1554.                 {M}  new_symbol
  1555. ( see NOTE#1)   $FAEB fhere 5 - !       \ link target body to normal body
  1556.                                         \ make resolver just execute this
  1557.                                         \ DOES word
  1558.                 -1 ,                    \ mark unresolved symbol
  1559.                 0 ,                     \ unresolved resolution chain
  1560.                 0 ,                     \ referenced count
  1561.                 fhere 0 ,               \ holds length of generated CODE
  1562.                 tcode-start
  1563. \ ****          hide
  1564.                 does>   body>
  1565.                         dup ?.MACRO             \ display MACRO name
  1566.                         here-t
  1567.                         over >dsize length s,-t \ move CODE to target
  1568.                         over >dsize @ ?.#dis    \ dissasem a1,n1
  1569.                              >count incr ;      \ bump usage
  1570.  
  1571. : END-ICODE     ( a1 -- )                       \ complete Imm compile CODE
  1572.                 [assembler]
  1573.                 end-code
  1574.                 fhere over - 2- swap !  ;       \ store len in table header
  1575.  
  1576. ' end-icode alias END-IMACRO    ( a1 -- )       \ complete Imm compile MACRO
  1577.  
  1578. \ ***************************************************************************
  1579. \ Data type definitions.
  1580.  
  1581. : VARIABLE      ( | <name> -- )         \ Variable Data
  1582.                 {D}  new_symbol
  1583.                 -1 ,                    \ mark as unresolved symbol
  1584.                 0 ,                     \ clear unresolved chain
  1585.                 0 ,                     \ clear reference counter
  1586.                 2 ,                     \ data size of a variable
  1587.                 does>   body>
  1588.                         ?dresolve               \ resolve it if used
  1589.                         dup >count incr         \ bump usage
  1590.                             >resaddr @ ;        \ return address in DS:
  1591.  
  1592. : 2VARIABLE     ( | <name> -- )         \ Variable Data
  1593.                 {D}  new_symbol
  1594.                 -1 ,                    \ mark as unresolved symbol
  1595.                 0 ,                     \ clear unresolved chain
  1596.                 0 ,                     \ clear reference counter
  1597.                 4 ,                     \ data size of a 2variable
  1598.                 does>   body>
  1599.                         ?dresolve               \ resolve it if used
  1600.                         dup >count incr         \ bump usage
  1601.                             >resaddr @ ;        \ return address in DS:
  1602.  
  1603. ' 2variable alias FVARIABLE             \ a floating var is like a double var
  1604.  
  1605. : VALUE         ( n1 | <name> -- )      \ variable constant
  1606.                 {V}  new_symbol
  1607.                 -1 ,                    \ mark as unresolved symbol
  1608.                 0 ,                     \ clear unresolved chain
  1609.                 0 ,                     \ clear reference counter
  1610.                 2 ,                     \ data size of a value
  1611.                 ,                       \ place to hold initial value
  1612.                 0 ,                     \ 0 = haven't initialized it yet
  1613.                 does>   body>
  1614.                         ?dresolve               \ resolve it if used
  1615.                         dup >count incr         \ bump usage
  1616.                         dup >inited @ 0=        \ if not initialized
  1617.                         if      dup  >dinitial @        \ get initial value
  1618.                                 over >resaddr @ !-d     \ set it in target
  1619.                                 dup >inited on          \ mark initialized
  1620.                         then
  1621.                             >resaddr @ @-d ;    \ return contents of
  1622.                                                 \ address in target DS:
  1623.  
  1624. : DEFER         ( n1 | <name> -- )      \ a defered word
  1625.                 {E}  new_symbol
  1626.                 -1 ,                    \ mark as unresolved symbol
  1627.                 0 ,                     \ clear unresolved chain
  1628.                 0 ,                     \ clear reference counter
  1629.                 2 ,                     \ data size of a defered word
  1630.                 does>   drop
  1631.                 0 " Can't use target DEFERed words in interpret mode!"
  1632.                 "errmsg abort ;
  1633.  
  1634. \ As in  "32 ARRAY <name>".
  1635.  
  1636. : ARRAY         ( N1 | <name> -- )      \ An Array of Data
  1637.                 {D}  new_symbol
  1638.                 -1 ,                    \ mark as unresolved symbol
  1639.                 0 ,                     \ clear unresolved chain
  1640.                 0 ,                     \ clear referenced counter
  1641.                   ,                     \ save array size word
  1642.                 does>   body>
  1643.                         ?dresolve               \ resolve it if used
  1644.                         dup >count incr         \ bump usage
  1645.                             >resaddr @ ;        \ return address in DS:
  1646.  
  1647. : CONSTANT      ( n1 | <name> -- )      \ Literal Data
  1648.                 {C}  new_symbol
  1649.                   ,                     \ save constant value HIGH
  1650.                 0 ,                     \ clear dummy unresolved chain
  1651.                 0 ,                     \ clear reference counter
  1652.                 does>   body>
  1653.                         dup >count incr        \ bump usage
  1654.                             >resaddr @ ;        \ return actual value
  1655.  
  1656. : 2CONSTANT     ( d1 | <name> -- )      \ Literal double Data
  1657.                 {2C} new_symbol
  1658.                   ,                     \ save constant value
  1659.                 0 ,                     \ clear dummy unresolved chain
  1660.                 0 ,                     \ clear reference counter
  1661.                 0 ,                     \ clear dummy data length
  1662.                   ,                     \ save const value LOW in >DINITIAL
  1663.                 does>   body>
  1664.                         dup  >count incr        \ bump usage
  1665.                         dup  >dinitial @
  1666.                         swap >resaddr  @ ;      \ return actual double value
  1667.  
  1668. forth
  1669. defer float_pop
  1670.  
  1671. : FCONSTANT     ( d1 | <name> -- )      \ floating point constant
  1672.                 {F} new_symbol
  1673.                 float_pop
  1674.                   ,                     \ save constant value
  1675.                 0 ,                     \ clear dummy unresolved chain
  1676.                 0 ,                     \ clear reference counter
  1677.                 0 ,                     \ clear dummy data length
  1678.                   ,                     \ save const value LOW in >DINITIAL
  1679.                 does>   drop
  1680.                 0 " Can't use floating constants in interpret mode!"
  1681.                 "errmsg abort ;
  1682.  
  1683. ' FCONSTANT ALIAS FCON
  1684.  
  1685. : CREATE        ( | <name> -- )         \ create a pointer to free data space
  1686.                 {D}  new_symbol
  1687.                 here-d ,                \ set resolution address to here-d
  1688.                 0 ,                     \ clear unresolved chain
  1689.                 0 ,                     \ clear reference counter
  1690.                 does>   body>
  1691.                         dup >count incr         \ bump usage
  1692.                             >resaddr @ ;        \ return offset into DS:
  1693.  
  1694. : HANDLE        ( | <name> -- )         \ An array for a handle data struct
  1695.                 {D}  new_symbol
  1696.                 -1 ,                    \ mark as unresolved symbol
  1697.                 0 ,                     \ clear unresolved chain
  1698.                 0 ,                     \ clear referenced counter
  1699.                 b/hcb ,                 \ data size is B/HCB bytes
  1700.                 does>   body>
  1701.                         ?dresolve               \ resolve it if used
  1702.                         dup >count incr         \ bump usage
  1703.                             >resaddr @ ;        \ return address in DS:
  1704.  
  1705. \ Allow definition of a table of data in the target or library, used as
  1706. \ follows:
  1707. \
  1708. \       TABLE NUMBERS
  1709. \               0 C,    1 C,    2 C,    3 C,    4 C,
  1710. \               5 C,    6 C,    7 C,    8 C,    9 C,
  1711. \       END-TABLE
  1712. \
  1713. \ When "NUMBERS" is first referenced in the target, the table will be
  1714. \ moved into the target data space, and the data address of "NUMBERS"
  1715. \ will be compiled into the target. Later references simply compile the
  1716. \ address of the table.
  1717.  
  1718. : TABLE         ( | <name> -- a1 )      \ Define a Table of data
  1719.                 {T}  new_symbol
  1720.                 -1 ,                    \ mark as unresolved symbol
  1721.                 0 ,                     \ clear unresolved chain
  1722.                 0 ,                     \ clear reference counter
  1723.                 fhere 0 ,               \ leaves here on stack for later
  1724.                                         \ resolution by END-TABLE
  1725.                 forth                   \ select the FORTH vocabulary
  1726.                 does>   body>
  1727.                         ?tresolve               \ resolve table when used
  1728.                         dup >count incr         \ bump usage
  1729.                             >resaddr @ ;        \ return address in DS:
  1730.  
  1731. : END-TABLE     ( a1 -- )               \ complete the definition of a table
  1732.                 fhere over - 2- swap !  \ store length in table header
  1733.                 target ;                \ reselect target vocabulary
  1734.  
  1735. \ ***************************************************************************
  1736. \ This word is used to follow target library definitions that need to have
  1737. \ an interpret time function.
  1738. \ See the 11/25/89 note in TCOM.TXT for a usage example.
  1739.  
  1740. : EXECUTES>     ( | <name> -- )         \ make word do name
  1741.                 LAST @ NAME>
  1742.                 DUP @REL>ABS 'DOVAR <>
  1743.                 OVER >DTYPE C@ {E} <> AND       \ not a DEFERED word
  1744.                 if      "  Is an ICODE/IMACRO word, can't use EXECUTE>"
  1745.                         "errmsg
  1746.                         also forth ' drop previous beep exit
  1747.                 then    dup 1+
  1748.                 fhere over - 2- swap !   \ make it jump to new function
  1749.                 233 SWAP C!             \ change CALL to JMP
  1750.                 ?TARGETING >R
  1751.                 SETASSEM
  1752.                 >FORTH-MEM      \ set to assemble for FORTH memory
  1753.                 [ASSEMBLER]
  1754.                 MOV AX, # ALSO FORTH ' PREVIOUS   \ lookup word following
  1755.                 JMP AX
  1756.                 END-CODE
  1757.                 [FORTH]
  1758.                 R>              \ if we were targeting, back to TARGET
  1759.                 IF      >TARGET-MEM
  1760.                 THEN    ;
  1761.  
  1762. \ ***************************************************************************
  1763. \ This word NO-INTERPRET is used to prevent some target words from being used
  1764. \ while in interpret mode.
  1765.  
  1766. : %NO-INTERP2   ( a1 -- )       \ error abort if we try to interpret
  1767.                                 \ the word defined preceeding NO-INTERPRET
  1768.                 body>
  1769.                 " Can't use this TARGET word in INTERPRET mode!" "errmsg
  1770.                 abort ;
  1771.  
  1772. CODE %NO-INTERP ( -- )          \ get here from a CALL
  1773.                 MOV AX, # ' %NO-INTERP2
  1774.                 JMP AX          END-CODE
  1775.  
  1776. : NO-INTERPRET  ( -- )
  1777.                 last @ name> dup @rel>abs 'dovar <>
  1778.                 if      " is an ICODE/IMACRO word, can't use NO-INTERPRET"
  1779.                         "errmsg
  1780.                         also forth ' drop previous beep exit
  1781.                 then    1+
  1782.                 ['] %NO-INTERP OVER - 2- SWAP ! ; \ go to %NO-INTERP
  1783.  
  1784. \ ***************************************************************************
  1785.  
  1786. : TASCII        ( | <letter> -- )       \ compile inline an ascii letter
  1787.                 ( | <letter> -- c1 )    \ interpret time
  1788.                 bl word 1+ c@ state @
  1789.                 if      comp_single
  1790.                 then    ; immediate
  1791.  
  1792. : ,"            ( | string" -- )        \ compile string data
  1793.                 '"' word dup c@ 1+ s,-d ;
  1794.  
  1795. \ ***************************************************************************
  1796. \ Display the target words that have been referenced, along with their
  1797. \ resolution addresses or values
  1798.  
  1799. : .unsym        ( link -- )
  1800.                 dup link> dup >execute @rel>abs 'docol =
  1801.                 if      dup >count @
  1802.                         if      save> base
  1803.                                 dup >resaddr @ -1 =
  1804.                                 if      \ not MACRO, CONSTANT or 2CONSTANT
  1805.                                         dup >dtype c@ {M} {F} between 0=
  1806.                                         if      ?quiet
  1807.                                                 if      dup
  1808.                                                         " is Unresolved"
  1809.                                                         "errmsg
  1810.                                                 else    dup >name .id tab
  1811.                                                         ." \2  UNRES    "
  1812.                                                 then
  1813. \u totalwords                                   totalwords incr
  1814.                                                 #unres 1+ =: #unres
  1815.                                         then
  1816.                                 then    restore> base
  1817.                                 ?cr
  1818.                         then
  1819.                 then    2drop   ;
  1820.  
  1821. : l.name        ( link -- )
  1822.                 dup link> dup >execute @rel>abs 'docol =
  1823.                 if      dup >count @
  1824.                         if      save> base
  1825.                                 dup  >resaddr @ -1 =
  1826.                                 if      dup >dtype c@ {M} <>
  1827.                                         if      ." \2 UNRES"
  1828.                                         else    ." \1 MACRO"
  1829.                                         then
  1830.                                 else    dup >resaddr @ hex      5 .r SPACE
  1831.                                 then    restore> base
  1832.                                 dup >dtype c@ {D}  =
  1833.                                 if ." \1v"  else space then
  1834.                                 dup >name .id tab ?cr
  1835. \u totalwords                   totalwords incr
  1836.                         then
  1837.                 then    2drop   ;
  1838.  
  1839. : %.labels      ( -- )
  1840. \u totalwords   totalwords off
  1841.                 0 =: #unres
  1842.                 savestate
  1843.                 cols 10 - rmargin !
  1844.                 20 tabsize !
  1845.                 0  lmargin !
  1846.                 ['] target >body
  1847.                 fhere 500 + #threads 2* cmove    \ copy threads
  1848.                 cr
  1849.                 begin   fhere 500 + #threads
  1850.                         largest dup             \ search thread copy
  1851.                         ?keypause
  1852.                 while   dup     ?unres
  1853.                         if      .unsym
  1854.                         else    l.name
  1855.                         then    y@ swap !       \ insert last link to thread
  1856.                 repeat 2drop
  1857.                 decimal
  1858.                 restorestate ;
  1859.  
  1860. : .labels       ( -- )
  1861.                 cr ." Referenced words ----- "
  1862.                 cr
  1863.                 0 =: ?unres
  1864.                 %.labels
  1865. \u totalwords   cr totalwords @ . ." Words Referenced"
  1866.                 cr ;
  1867.  
  1868. ' .labels alias .symbols
  1869.  
  1870. : .unres        ( -- )
  1871.                 cr ." --------------------"
  1872.                 true =: ?unres
  1873.                 %.labels
  1874. \u totalwords   cr totalwords @ . ." Unresolved References"
  1875.                 ;
  1876.  
  1877. \ ***************************************************************************
  1878. \ Compile the definition of " for inline strings in target and library
  1879.  
  1880. : %%T"          ( a1 -- )               \ compile string into target
  1881.                 here-d 1+ comp_single   \ address of first char of $
  1882.                 dup c@    comp_single   \ compile length of $
  1883.                 dup c@ 1+ s,-d          \ compile string to data area
  1884.                 ;
  1885. FORTH
  1886. DEFER %T"
  1887.  
  1888. ' %%T" IS %T"
  1889.  
  1890. : T"            ( | string" -- )        \ compile a string into target
  1891.                 ( -- a1 n1 )            \ runtime - return address and length
  1892.                 '"' word                \ get the string to HERE
  1893.                 %T" ; immediate         \ compile it into target
  1894.  
  1895. : L"            ( | string" -- )        \ compile a string later compiled
  1896.                                         \ into the target
  1897.                 [compile] " compile ">$
  1898.                 compile %T" ; immediate
  1899.  
  1900. \ ***************************************************************************
  1901. \ Define and compile the target definition of a colon word. Automatic
  1902. \ forward reference resolution is performed on these definitions.
  1903.  
  1904. FORTH
  1905. DEFER END-T:    ( -- )          \ See the library for this definition
  1906.  
  1907. : (T:)          ( | <name> .. ; -- )            \ new defining word
  1908.                 ?exec
  1909.                 0 =: ?lib
  1910.                 !csp
  1911.                 current @ context !
  1912.                 fhere >r
  1913.                 do_symbol
  1914.                 ['] no_tinline >body @ r> >execute >body !
  1915.                                                 \ no target inline allowed
  1916.                                                 \ relink to error routine
  1917.                 set_cold_entry                  \ mark as program entry point
  1918.                 start-t:
  1919.                 0BR#
  1920.                 clear_labels ;
  1921.  
  1922. : (T])          ( -- )
  1923.                 state on
  1924.         begin   ?stack  tdefined target? ?dup   \ find the word
  1925.                 if      0>
  1926.                         if      execute         \ execute immediate words
  1927.                         else    targ_compile    \ compile the rest
  1928.                         then
  1929.                 else    %number                 \ a number?
  1930.                         if      ( d1 -- )       \ compile literal number
  1931.                                 double?         \ double if '.' found
  1932.                                 if      swap
  1933.                                         comp_single
  1934.                                 else    drop
  1935.                                 then    comp_single
  1936.                         else    2drop           \ discard double zero
  1937.                                 >in-t =: >in    \ reset >IN to before word
  1938.                                 fhere >r
  1939.                                 0 add_symbol    \ or add to symbol table
  1940.                                 compile unnest  \ undefined, so NOOP it
  1941.                                 r@ >count incr
  1942.                                 r> compile_call
  1943.                         then
  1944.                 then    state @ 0=
  1945.         until   ?sizecheck ;            \ check the space used sofar
  1946.  
  1947. : T:            ( | <name> .. ; -- )    \ TARGET : defining word
  1948.                 (T:) (T])
  1949.                 end-t:
  1950.                 do_resolve ;            \ resolve all new referenced symbols
  1951.  
  1952. : TM:           ( | <NAME> .. ; -- )    \ Target MACRO : defining word
  1953.                 LM:
  1954.                 do_resolve ;
  1955.  
  1956. \ make some aliases for the normal Forth definitions of these words
  1957.  
  1958. assembler also
  1959.  
  1960. ' :        alias for:
  1961. ' ;        alias for;           immediate
  1962. ' allot    alias fallot
  1963. ' code     alias fcode
  1964. ' label    alias flabel
  1965. ' end-code alias fend-code
  1966. ' ascii    alias fascii         immediate
  1967. ' "        alias f"             immediate
  1968. ' ."       alias f."            immediate
  1969. ' abort"   alias fabort"        immediate
  1970. ' [']      alias f[']           immediate
  1971.  
  1972. here !> tcomlow         \ lower limit for TCOM target words
  1973.  
  1974. \ new target compiler defered words
  1975.  
  1976. FORTH defer :                   immediate       ' for: compiler is :
  1977. FORTH defer ;                   immediate       ' for; compiler is ;
  1978. FORTH
  1979. defer m:                        immediate
  1980. defer allot
  1981. defer code                      immediate
  1982. defer label                     immediate
  1983. assembler definitions forth
  1984. defer end-code                  immediate
  1985. target definitions forth
  1986. defer ascii                     immediate
  1987. defer "                         immediate
  1988. defer ."                        immediate
  1989. defer abort"                    immediate
  1990. defer [']                       immediate
  1991. defer l."                       immediate
  1992. defer t."                       immediate
  1993. defer labort"                   immediate
  1994. defer tabort"                   immediate
  1995. defer l[']                      immediate
  1996. defer t[']                      immediate
  1997.  
  1998. \ Compiler MODE selection words
  1999.  
  2000. : >library      ( -- )                          \ Select Library
  2001.                 F['] L:          =: :
  2002.                 F['] [;]         =: ;
  2003.                 F['] LM:         =: M:
  2004.                 F['] LCODE       =: CODE
  2005.                 F['] LLABEL      =: LABEL
  2006.                 F['] END-LCODE   =: END-CODE
  2007.                 F['] L"          =: "
  2008.                 F['] L."         =: ."
  2009.                 F['] LABORT"     =: ABORT"
  2010.                 F['] LALLOT      =: ALLOT
  2011.                 F['] LASCII      =: ASCII
  2012.                 F['] L[']        =: ['] ;
  2013.  
  2014. : >target       ( -- )                          \ Select Target compiler
  2015.                 F['] T:          =: :
  2016.                 F['] [;]         =: ;
  2017.                 F['] TM:         =: M:
  2018.                 F['] TCODE       =: CODE
  2019.                 F['] TLABEL      =: LABEL
  2020.                 F['] FEND-CODE   =: END-CODE
  2021.                 F['] T"          =: "
  2022.                 F['] T."         =: ."
  2023.                 F['] TABORT"     =: ABORT"
  2024.                 F['] ALLOT-D     =: ALLOT
  2025.                 F['] TASCII      =: ASCII
  2026.                 F['] T[']        =: ['] ;
  2027.  
  2028. : >forth        ( -- )                          \ select Forth
  2029.                 F['] FOR:        =: :
  2030.                 F['] FOR;        =: ;
  2031.                 F['] FOR:        =: M:
  2032.                 F['] FCODE       =: CODE
  2033.                 F['] FLABEL      =: LABEL
  2034.                 F['] FEND-CODE   =: END-CODE
  2035.                 F['] F"          =: "
  2036.                 F['] F."         =: ."
  2037.                 F['] FABORT"     =: ABORT"
  2038.                 F['] FALLOT      =: ALLOT
  2039.                 F['] FASCII      =: ASCII
  2040.                 F['] F[']        =: ['] ;
  2041.  
  2042. >FORTH          \ Select FORTH for now
  2043.  
  2044. \ ***************************************************************************
  2045. \ Allow new user created defining words to be added and used in the target
  2046. \ compiler.
  2047.  
  2048. : TDOES>        ( | -- )
  2049.                 ?exec
  2050.                 0 =: ?lib
  2051.                 !csp
  2052.                 current @ context !
  2053.                 0BR#
  2054.                 clear_labels
  2055.                 HERE-T =: DOES-ADDR
  2056.                 (T]) END-T: DO_RESOLVE ;        \ resolve all new symbols
  2057.  
  2058. : ::            ( | <name> -- )         \ make a new defining word
  2059.         >FORTH
  2060.         [FORTH]
  2061.         ?FNDDOES> OFF
  2062.         (:)                             \ make a : def
  2063.         STATE ON
  2064.         BEGIN   ?STACK  TDEFINED ?DUP
  2065.                 IF      >R
  2066.                         CASE
  2067.                         [TARGET]
  2068.                         F['] CREATE OF  COMPILE (T:)
  2069.                                         COMPILE HERE-D
  2070.                                         COMPILE COMP_SINGLE
  2071.                                         HERE-T [COMPILE] LITERAL
  2072.                                         COMPILE COMP_JMP_IMM
  2073. \ ****                                  COMPILE REVEAL
  2074.                                                                  ENDOF
  2075.                         F['] DOES>  OF  [COMPILE] ; ?FNDDOES> ON ENDOF
  2076.                         F['] ,      OF  COMPILE ,-D              ENDOF
  2077.                         F['] C,     OF  COMPILE C,-D             ENDOF
  2078.                         F['] ALLOT  OF  COMPILE ALLOT-D          ENDOF
  2079.                         [FORTH]
  2080.                              R@ 0>  IF  EXECUTE   ELSE   X,   THEN
  2081.                         ENDCASE R>DROP
  2082.                 ELSE    NUMBER  DOUBLE?
  2083.                         IF           [COMPILE] DLITERAL
  2084.                         ELSE    DROP [COMPILE] LITERAL
  2085.                         THEN
  2086.                 THEN    TRUE    DONE?
  2087.         UNTIL   ?FNDDOES> @ [FORTH] 0=
  2088.         IF      0 " No DOES> portion specified" "errmsg abort
  2089.         THEN    [TARGET] >TARGET TDOES> ;
  2090.  
  2091. \ ***************************************************************************
  2092. \ Do the target compile.
  2093.  
  2094. : targ          ( -- )
  2095.                 [FORTH]
  2096.                 ?quiet 0=
  2097.                 if      cr
  2098.                         ." Compiling.. "
  2099.                         ?opt
  2100.                         if      ." with Optimization.. "
  2101.                         then
  2102.                 then
  2103.                 set.filenames
  2104.                 ?lst
  2105.         if      listing.name $pfile
  2106.                 if      0 " Could not create listing file." "errmsg abort
  2107.                 then
  2108.                 buf_prinit
  2109.                 [ also hidden ]
  2110.                 savescr
  2111. \u #prlines     savecursor
  2112. \u #prlines     20 8 60 10 box&fill
  2113. \u #prlines     ."  \1  Building listing file......   "
  2114. \u #prlines     restcursor
  2115. \u #prlines     0 =: #prlines
  2116. \u oldfix       @> errfix =: oldfix
  2117.                 F['] pemit  save!> emit
  2118.                 F['] buf_prtypel save!> typel
  2119. \u outfix       F['] outfix is errfix
  2120.                 F['] buf_premit save!> pemit
  2121.                 printing on cr
  2122.                 do_ok
  2123.                 cr cr
  2124.                 .symbols
  2125.                 cr cr
  2126.                 restscr
  2127.                 printing off
  2128.                 buf_prflush
  2129.                 pclose
  2130.                 restore> pemit
  2131.                 restore> typeL
  2132.                 restore> emit
  2133. \u oldfix       oldfix =: errfix
  2134.         else    do_ok
  2135.                 -1 =: spinval spinner2  \ show spinner one final time
  2136.         then    .unres                  \ Display any unresolved references
  2137.                 [ previous ]
  2138.                 symclose                \ close symbol file
  2139.                 save-image.com          \ write .COM file to disk
  2140.                 ?bye
  2141.                 if      /bye            \ leave now or
  2142.                 else
  2143.                 cr
  2144. ." Type \`PRINT .SYMBOLS\` to make a printed copy of your programs SYMBOLS."
  2145.                 cr
  2146. ." Type \`/BYE\` to leave."
  2147.                 then
  2148.                 forth decimal ;
  2149.  
  2150. false \u words drop true        \ true if "WORDS" is defined
  2151. #IF
  2152.  
  2153. : .compiler     ( -- )
  2154.  
  2155. cr ." /definit     = Include the default initialization from file DEFINIT.SEQ."
  2156. cr ." /noinit      = Don't include any default initialization, user does it."
  2157. \u newfile cr ." /edit <file> = Start as editor on <file>. Not in small version.(no compile)"
  2158. cr ." /lst         = Generate a listing file with source, asm & symbols."
  2159. cr ." /lstoff      = Don't generate a listing file ............ (default)."
  2160. cr ." /opt         = Enable compiler optimization."
  2161. cr ." /optoff      = Disable compile optimization ............. (default)."
  2162. cr ." /show        = Show symbols as they are compiled."
  2163. cr ." /showoff     = Don't show symbols as they are compiled .. (default)."
  2164. cr ." /src         = Enable  the listing of source lines."
  2165. cr ." /srcoff      = Disable the listing of source lines ...... (default)."
  2166. cr ." /stay        = Stay in Forth after the compile finishes."
  2167. cr ." /sym         = Generate a symbol file for BXDEBUG."
  2168. cr ." /symoff      = Don't generate a symbol file ............. (default)."
  2169. cr ." /help        = Re-display help screen. Press the \2 F1 \0 key for MORE HELP."
  2170. cr ." /help2       = Display second help screen."
  2171. ;
  2172.  
  2173. : /help         ( -- )
  2174.                 cr ." Command line format:    "
  2175.                 ." \`TCOM <filename> <option> <option> <...>\`"
  2176.                 cr
  2177. \unless .alist  .alist
  2178.                 .compiler
  2179.                 cr ." \3 *** Type /BYE to leave the compiler *** " ;
  2180.  
  2181. : /help2        ( -- )          \ second set of command line options
  2182.                 cr ." Command line options Help screen two."
  2183.                 cr
  2184. cr ." /forth            = Append an interactive Forth to program. (need TFORTH.SEQ)"
  2185. cr ." /dis              = Also append the disassembler.           (need DIS.SEQ)"
  2186. cr ." /debug            = Also append the debugger.               (need TDEBUG.SEQ)"
  2187. cr ." /quiet            = Reduce visual output, use with I/O redirection."
  2188. cr ." /code-start <adr> = Start compiling code at <adr>."
  2189. cr ." /data-start <adr> = Start compiling data at <adr>."
  2190. cr ." /code-limit <n1>  = Size limit between CODE and DATA.       (default=$C000)"
  2191. cr ." /ram-start  <adr> = Set the RAM segment in target memory.   (ROMable)"
  2192. cr ." /ram-end    <n1>  = Set the end of target ram.              (default=$FFEE)"
  2193. cr ." /bye              = Return to DOS ....... (NOT a command line option)."
  2194. cr ." /DOS              = Shell out to DOS .....(NOT a command line option)."
  2195. cr ." /help             = Re-display first help screen."
  2196. cr ." /help2            = Display this help screen again."
  2197.                 ;
  2198.  
  2199. #ELSE
  2200.  
  2201. : /help
  2202.         cr ." Command line format:    "
  2203.         ." \`TCOM <filename> <option> <option> <...>\`"
  2204.         cr ." Options avaliable:      "
  2205.         ." \`/opt /sym /lst /code /src /show\`"
  2206.         cr cr
  2207.         ." Type \`/BYE <enter>\` to return to DOS (don't include the \`s)."
  2208.         cr ;
  2209.  
  2210. #THEN
  2211.  
  2212. : .public       ( -- )
  2213.                 cr
  2214.                 ." \3 TCOM \0 the Target COMpiler by Tom Zimmer "
  2215.                 ." \3 Version 1.28 " tversion cr
  2216.                 ." \1 ********** This is a Public Domain program ********** "
  2217.                 eeol at? eeol at ;
  2218.  
  2219. : ?.instruct    ( -- )
  2220.                 [ also forth ]
  2221.                 seqhandle >hndle @ 0<
  2222.                 if      dark
  2223.                         .public
  2224.                         /help
  2225.                         false =: ?bye
  2226.                         forth
  2227.                         interpret
  2228.                         quit
  2229.                 then    ;
  2230.  
  2231. : ?cmd_err      ( a1 n1 f1 -- )
  2232.                 [forth]
  2233.                 if      0 -rot "errmsg cr
  2234.                         ?bye if /bye then
  2235.                         ."    Type \1 /BYE \0 to leave"
  2236.                         F['] <run> is run errfix
  2237.                         sp0 @ sp!   printing off
  2238.                         forth
  2239.                         quit
  2240.                 then    ;
  2241.  
  2242. : ?compile_err  ( a1 n1 f1 -- )
  2243.                 [forth]
  2244.                 if      0 -rot "errmsg cr
  2245.                         ?bye if /bye then
  2246.                         F['] (?serror) is ?error abort
  2247.                 else    2drop
  2248.                 then    ;
  2249.  
  2250. : DOTARG        ( -- )
  2251.                 [forth]
  2252.                 sp0 @  'tib !
  2253.                 >in     off
  2254.                 span    off
  2255.                 #tib    off
  2256.                 loading off
  2257.                 only forth also definitions
  2258.                 defaultstate
  2259.                 tcom_path@              \ get the environment specified path
  2260.                 default                 \ open a file if one is present
  2261.                 20 tabsize !            \ adjust the tab size
  2262.                 warning off
  2263. \u autoeditoff  autoeditoff             \ no autoedit on error
  2264.                 only
  2265.                 forth     also
  2266.                 compiler  also
  2267.                 target    also  definitions
  2268.                 assembler also
  2269.                 off> cerrors
  2270.                 F['] ?cmd_err save!> ?error
  2271.                 env_interpret           \ get the default command line args
  2272.                 interpret               \ get the overridding args
  2273.                 restore> ?error
  2274.                 .public
  2275.                 ?.instruct
  2276.                 F['] ?compile_err save!> ?error
  2277.                 targ
  2278.                 restore> ?error ;
  2279.  
  2280. ' DOTARG IS BOOT                \ Make TARG the Initializer
  2281.  
  2282. \ ***************************************************************************
  2283. \ Some immediate words to handle values in the target
  2284.  
  2285. ' noop        for>word &>
  2286. ' comp_store  for>word !>
  2287. ' comp_fetch  for>word @>
  2288. ' comp_off    for>word off>
  2289. ' comp_on     for>word on>
  2290. ' comp_incr   for>word incr>
  2291. ' comp_decr   for>word decr>
  2292. ' comp_pstore for>word +!>
  2293. ' comp_save   for>word save>
  2294. ' comp_savest for>word save!>
  2295. ' comp_rest   for>word restore>
  2296.  
  2297. HERE =: TSYM_BOTTOM             \ bottom of target dictionary
  2298.  
  2299.  
  2300.