Diff for /gforth/cross.fs between versions 1.101 and 1.102

version 1.101, 2001/09/04 09:15:28 version 1.102, 2001/09/04 11:09:59
Line 656  hex Line 656  hex
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>  4715 Constant <skip>
   
 \  Compiler States  \ iForth makes only immediate directly after create
   \ make atonce trick! ?
 Variable comp-state  
 0 Constant interpreting  
 1 Constant compiling  
 2 Constant resolving  
 3 Constant assembling  
   
 Defer lit, ( n -- )  
 Defer alit, ( n -- )  
   
 Defer branch, ( target-addr -- )        \ compiles a branch  
 Defer ?branch, ( target-addr -- )       \ compiles a ?branch  
 Defer branchmark, ( -- branch-addr )    \ reserves room for a branch  
 Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch  
 Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch  
 Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)  
 Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark  
 Defer branchfrom, ( -- )                \ ?!  
 Defer branchtomark, ( -- target-addr )  \ marks a branch destination  
   
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  
 Defer prim, ( tcfa -- )                 \ compiles a primitive invocation  
                                         \ at current position  
 Defer colonmark, ( -- addr )            \ marks a colon call  
 Defer colon-resolve ( tcfa addr -- )  
   
 Defer addr-resolve ( target-addr addr -- )  
 Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )  
   
 Defer do,       ( -- do-token )  Variable atonce atonce off
 Defer ?do,      ( -- ?do-token )  
 Defer for,      ( -- for-token )  
 Defer loop,     ( do-token / ?do-token -- )  
 Defer +loop,    ( do-token / ?do-token -- )  
 Defer next,     ( for-token )  
   
 [IFUNDEF] ca>native  : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
 defer ca>native   
 [THEN]  
   
 \ ghost structure  : GhostHeader <fwd> , 0 , ['] NoExec , ;
   
 : >magic ;              \ type of ghost  : >magic ;              \ type of ghost
 : >link cell+ ;         \ pointer where ghost is in target, or if unresolved  : >link cell+ ;         \ pointer where ghost is in target, or if unresolved
                         \ points to the where we have to resolve (linked-list)                          \ points to the where we have to resolve (linked-list)
 : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost  : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost
 : >comp 3 cells + ;     \ compilation semantics  : >end 3 cells + ;      \ room for additional tags
 : >end 4 cells + ;      \ room for additional tags  
                         \ for builder (create, variable...) words the                          \ for builder (create, variable...) words the
                         \ execution symantics of words built are placed here                          \ execution symantics of words built are placed here
   
 \ resolve structure  
   
 : >next ;               \ link to next field  
 : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer  
 : >taddr cell+ cell+ ;    
 : >ghost 3 cells + ;  
 : >file 4 cells + ;  
 : >line 5 cells + ;  
   
 \ refer variables  
   
 Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>  Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
 Variable last-ghost     \ last ghost that is created  Variable last-ghost     \ last ghost that is created
 Variable last-header-ghost \ last ghost definitions with header  Variable last-header-ghost \ last ghost definitions with header
   
 : (refered) ( ghost addr tag -- )  
 \G creates a reference to ghost at address taddr  
     rot >r here r@ >link @ , r> >link !   
     ( taddr tag ) ,  
     ( taddr ) ,   
     last-header-ghost @ ,   
     loadfile ,   
     sourceline# ,   
   ;  
   
 \ iForth makes only immediate directly after create  
 \ make atonce trick! ?  
   
 Variable atonce atonce off  
   
 : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;  
   
 : is-forward   ( ghost -- )  
   colonmark, 0 (refered) ; \ compile space for call  
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ['] is-forward , ;  
   
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >in @ GhostName swap >in !
   <T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
Line 811  ghost (does>)   ghost noop Line 743  ghost (does>)   ghost noop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
 ghost '                                         drop  ghost '                                         drop
 ghost :docol    ghost :doesjump ghost :dodoes   2drop drop  ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
 ghost :dovar    ghost :dodefer  ghost :dofield  2drop drop  ghost :dovar                                    drop
 ghost over      ghost =         ghost drop      2drop drop  ghost over      ghost =         ghost drop      2drop drop
 ghost call      ghost useraddr  ghost execute   2drop drop  ghost - drop
 ghost +         ghost -         ghost @         2drop drop  
 ghost 2drop drop  ghost 2drop drop
 ghost 2dup drop  ghost 2dup drop
   
Line 871  false DefaultValue dcomps Line 802  false DefaultValue dcomps
 false DefaultValue hash  false DefaultValue hash
 false DefaultValue xconds  false DefaultValue xconds
 false DefaultValue header  false DefaultValue header
 false DefaultValue backtrace  
 false DefaultValue new-input  
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 944  Variable user-vars 0 user-vars ! Line 873  Variable user-vars 0 user-vars !
 : target>bitmask-size ( u1 -- u2 )  : target>bitmask-size ( u1 -- u2 )
   1- tcell>bit rshift 1+ ;    1- tcell>bit rshift 1+ ;
   
 : allocatetarget ( size -- adr )  : allocatetarget ( size --- adr )
   dup allocate ABORT" CROSS: No memory for target"    dup allocate ABORT" CROSS: No memory for target"
   swap over swap erase ;    swap over swap erase ;
   
Line 1050  T has? rom H Line 979  T has? rom H
 ' dictionary ALIAS rom-dictionary  ' dictionary ALIAS rom-dictionary
   
   
 : setup-target ( -- )   \G initialize target's memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" T $has? H    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       \ address-space area nip 0<>        \ address-space area nip 0<>
Line 1087  T has? rom H Line 1016  T has? rom H
         ELSE    r> drop THEN          ELSE    r> drop THEN
    REPEAT drop ;     REPEAT drop ;
   
 \ MakeKernel                                                    22feb99jaw  \ MakeKernal                                                    22feb99jaw
   
 : makekernel ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   dup dictionary >rlen ! setup-target ;    dup dictionary >rlen ! setup-target ;
Line 1337  previous Line 1266  previous
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   \  Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
   Defer lit, ( n -- )
   Defer alit, ( n -- )
   
   Defer branch, ( target-addr -- )        \ compiles a branch
   Defer ?branch, ( target-addr -- )       \ compiles a ?branch
   Defer branchmark, ( -- branch-addr )    \ reserves room for a branch
   Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch
   Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch
   Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)
   Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Defer branchfrom, ( -- )                \ ?!
   Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
   Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position
   Defer colonmark, ( -- addr )            \ marks a colon call
   Defer colon-resolve ( tcfa addr -- )
   
   Defer addr-resolve ( target-addr addr -- )
   Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Defer do,       ( -- do-token )
   Defer ?do,      ( -- ?do-token )
   Defer for,      ( -- for-token )
   Defer loop,     ( do-token / ?do-token -- )
   Defer +loop,    ( do-token / ?do-token -- )
   Defer next,     ( for-token )
   
   [IFUNDEF] ca>native
   defer ca>native 
   [THEN]
   
 >TARGET  >TARGET
 DEFER >body             \ we need the system >body  DEFER >body             \ we need the system >body
                         \ and the target >body                          \ and the target >body
Line 1352  DEFER dodoes, Line 1320  DEFER dodoes,
 DEFER ]comp     \ starts compilation  DEFER ]comp     \ starts compilation
 DEFER comp[     \ ends compilation  DEFER comp[     \ ends compilation
   
 : (prim) T a, H ;                               ' (prim) IS prim,  : (cc) T a, H ;                                 ' (cc) IS colon,
   
 : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) IS colon-resolve  : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) IS colon-resolve
 : (ar) T ! H ;                                  ' (ar) IS addr-resolve  : (ar) T ! H ;                                  ' (ar) IS addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )  : (dr)  ( ghost res-pnt target-addr addr )
         >tempdp drop over           >tempdp drop over 
Line 1366  DEFER comp[     \ ends compilation Line 1334  DEFER comp[     \ ends compilation
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 prim, ;                                  ' (cm) IS colonmark,      -1 colon, ;                                 ' (cm) IS colonmark,
   
 >TARGET  >TARGET
 : compile, prim, ;  : compile, colon, ;
 >CROSS  >CROSS
   
   \ resolve structure
   
   : >next ;               \ link to next field
   : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
   : >taddr cell+ cell+ ;  
   : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
   : (refered) ( ghost addr tag -- )
   \G creates a reference to ghost at address taddr
       rot >r here r@ >link @ , r> >link ! 
       ( taddr tag ) ,
       ( taddr ) , 
       last-header-ghost @ , 
       loadfile , 
       sourceline# , 
     ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
     T here aligned H swap (refered)      T here aligned H swap (refered)
Line 1441  Exists-Warnings on Line 1428  Exists-Warnings on
   ELSE  true abort" CROSS: Ghostnames inconsistent "    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
 : colon-resolved   ( ghost -- )  
     >link @ colon, ; \ compile-call  
 : prim-resolved  ( ghost -- )  
     >link @ prim, ;  
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another definition with the      \ is ghost resolved?, second resolve means another definition with the
Line 1455  Exists-Warnings on Line 1437  Exists-Warnings on
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
     dup r@ >link ! <res> r@ >magic !      dup r@ >link ! <res> r@ >magic !
     r@ >comp @ ['] is-forward = IF  
         ['] prim-resolved  r@ >comp !  THEN  
     \ loop through forward referencies      \ loop through forward referencies
     r> -rot       r> -rot 
     comp-state @ >r Resolving comp-state !      comp-state @ >r Resolving comp-state !
Line 1468  Exists-Warnings on Line 1448  Exists-Warnings on
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
   : is-forward   ( ghost -- )
     colonmark, 0 (refered) ; \ compile space for call
   
   : is-resolved   ( ghost -- )
     >link @ colon, ; \ compile-call
   
 : gexecute   ( ghost -- )  : gexecute   ( ghost -- )
     dup >comp @ execute ;    dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;
   
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
   dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;    dup @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
   
 \ !! : ghost,     ghost  gexecute ;  \ !! : ghost,     ghost  gexecute ;
   
Line 1529  variable ResolveFlag Line 1515  variable ResolveFlag
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
   \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
 bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+  bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
 : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;  : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
   
 VARIABLE ^imm  VARIABLE ^imm
   
 \ !! should be target wordsize specific  
 $80 constant alias-mask  
 $40 constant immediate-mask  
 $20 constant restrict-mask  
   
 >TARGET  >TARGET
 : immediate     immediate-mask flag!  : immediate     40 flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      restrict-mask flag! ;  : restrict      20 flag! ;
   
 : isdoer          : isdoer        
 \G define a forth word as doer, this makes obviously only sence on  \G define a forth word as doer, this makes obviously only sence on
Line 1556  $20 constant restrict-mask Line 1538  $20 constant restrict-mask
   
 >TARGET  >TARGET
 : string,  ( addr count -- )  : string,  ( addr count -- )
     dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;    dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
   
 : lstring, ( addr count -- )  : lstring, ( addr count -- )
     dup T , H bounds  ?DO  I c@ T c, H  LOOP ;    dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
   
 : name,  ( "name" -- )  bl word count T lstring, cfalign H ;  : name,  ( "name" -- )  bl word count T lstring, cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
 >CROSS  >CROSS
Line 1579  Variable to-doc  to-doc on Line 1563  Variable to-doc  to-doc on
     IF      IF
         s" " doc-file-id write-line throw          s" " doc-file-id write-line throw
         s" make-doc " doc-file-id write-file throw          s" make-doc " doc-file-id write-file throw
         Last-Header-Ghost @ >ghostname doc-file-id write-file throw  
           tlast @ >image count 1F and doc-file-id write-file throw
         >in @          >in @
         [char] ( parse 2drop          [char] ( parse 2drop
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
Line 1713  NoHeaderFlag off Line 1698  NoHeaderFlag off
     IF  dup >end tdoes !      IF  dup >end tdoes !
     ELSE 0 tdoes !      ELSE 0 tdoes !
     THEN      THEN
     alias-mask flag!      80 flag!
     cross-doc-entry cross-tag-entry ;      cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
Line 1730  VARIABLE ;Resolve 1 cells allot Line 1715  VARIABLE ;Resolve 1 cells allot
     IF      IF
         .sourcepos ." needs prim: " >in @ bl word count type >in ! cr          .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
     THEN      THEN
     (THeader over resolve T A, H alias-mask flag! ;      (THeader over resolve T A, H 80 flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< s" prims" T $has? H 0= and      dup 0< s" prims" T $has? H 0= and
Line 1776  Comment (       Comment \ Line 1761  Comment (       Comment \
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
 T has? peephole H [IF]  
 : (cc) compile call T >body a, H ;              ' (cc) IS colon,  
 [ELSE]  
     ' (prim) IS colon,  
 [THEN]  
   
 : [G']   : [G'] 
 \G ticks a ghost and returns its address  \G ticks a ghost and returns its address
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"    bl word gfind 0= ABORT" CROSS: Ghost don't exists"
Line 1815  Cond: [']  T ' H alit, ;Cond Line 1794  Cond: [']  T ' H alit, ;Cond
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
 : (doer,)   ( ghost -- ) ]comp addr, comp[ 1 fillcfa ;   ' (doer,) IS doer,  : (doer,)   ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,
   
 : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,  : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,
   
Line 1885  Cond: [Char]   ( "<char>" -- )  restrict Line 1864  Cond: [Char]   ( "<char>" -- )  restrict
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
   
 \ !! Known Bug: Special Literals and plug-ins work only correct  \ !! Known Bug: Special Literals and plug-ins work only correct
 \ on targets with char = 8 bit  \ on 16 and 32 Bit Targets and 32 Bit Hosts!
   
 Cond: MAXU  Cond: MAXU
   restrict?     restrict? 
   compile lit tcell 0 ?DO FF T c, H LOOP     tcell 1 cells u> 
     IF    compile lit tcell 0 ?DO FF T c, H LOOP 
     ELSE  ffffffff lit, THEN
   ;Cond    ;Cond
   
 Cond: MINI  Cond: MINI
   restrict?    restrict?
   compile lit bigendian     tcell 1 cells u>
   IF    80 T c, H tcell 1 ?DO 0 T c, H LOOP     IF    compile lit bigendian 
   ELSE  tcell 1 ?DO 0 T c, H LOOP 80 T c, H          IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP 
   THEN          ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
           THEN
     ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
   ;Cond    ;Cond
     
 Cond: MAXI  Cond: MAXI
  restrict?   restrict?
  compile lit bigendian    tcell 1 cells u>
  IF     7F T c, H tcell 1 ?DO FF T c, H LOOP   IF     compile lit bigendian 
  ELSE   tcell 1 ?DO FF T c, H LOOP 7F T c, H          IF      7F T c, H tcell 1 ?DO FF T c, H LOOP
  THEN          ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H
           THEN
    ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
  ;Cond   ;Cond
   
 >CROSS  >CROSS
Line 1978  Cond: ; ( -- ) restrict? Line 1963  Cond: ; ( -- ) restrict?
                comp[                 comp[
                state off                 state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve                 IF ;Resolve @ ;Resolve cell+ @ resolve THEN
                   ['] colon-resolved ;Resolve @ >comp ! THEN  
                 Interpreting comp-state !                  Interpreting comp-state !
                ;Cond                 ;Cond
 Cond: [  restrict? state off Interpreting comp-state ! ;Cond  Cond: [  restrict? state off Interpreting comp-state ! ;Cond
Line 1997  Create GhostDummy ghostheader Line 1981  Create GhostDummy ghostheader
     GhostDummy >link ! GhostDummy       GhostDummy >link ! GhostDummy 
     tlastcfa @ >tempdp dodoes, tempdp> ;      tlastcfa @ >tempdp dodoes, tempdp> ;
   
 : g>body ( ghost -- body )  
     >link @ T >body H ;  
 : does-resolved ( ghost -- )  
     dup g>body alit, >end @ g>body colon, ;  
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
         compile (does>) doeshandler,           compile (does>) doeshandler, 
         \ resolve words made by builders          \ resolve words made by builders
         tdoes @ ?dup IF  @ dup T here H resolve          tdoes @ ?dup IF  @ T here H resolve THEN
             ['] prim-resolved swap >comp !  THEN  
         ;Cond          ;Cond
 : DOES> switchrom doeshandler, T here H !does depth T ] H ;  : DOES> switchrom doeshandler, T here H !does depth T ] H ;
   
Line 2016  Cond: DOES> restrict? Line 1994  Cond: DOES> restrict?
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create-xt do-ghost "name" -- )  : Builder    ( Create-xt do:-xt "name" -- )
 \ builds up a builder in current vocabulary  \ builds up a builder in current vocabulary
 \ create-xt is executed when word is interpreted  \ create-xt is executed when word is interpreted
 \ do:-xt is executet when the created word from builder is executed  \ do:-xt is executet when the created word from builder is executed
 \ for do:-xt an additional entry after the normal ghost-enrys is used  \ for do:-xt an additional entry after the normal ghost-enrys is used
   
   Make-Ghost            ( Create-xt do-ghost ghost )    Make-Ghost            ( Create-xt do:-xt ghost )
   rot swap              ( do-ghost Create-xt ghost )    rot swap              ( do:-xt Create-xt ghost )
   >exec ! , ;    >exec ! , ;
   \  rot swap >exec dup @ ['] NoExec <>
   \  IF 2drop ELSE ! THEN , ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2046  Cond: DOES> restrict? Line 2026  Cond: DOES> restrict?
   executed-ghost @    executed-ghost @
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   Theader >r dup , dup gdoes,    Theader >r dup gdoes,
 \ stores execution semantic in the built word  \ stores execution semantic in the built word
 \ if the word already has a semantic (concerns S", IS, .", DOES>)  \ if the word already has a semantic (concerns S", IS, .", DOES>)
 \ then keep it  \ then keep it
   >end @    >end @ >exec @ r> >exec dup @ ['] NoExec =
   dup >exec @ r@ >exec dup @ ['] NoExec =  IF ! ELSE 2drop THEN    IF ! ELSE 2drop THEN ;
   >comp @ r> >comp ! ;  
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
Line 2060  Cond: DOES> restrict? Line 2039  Cond: DOES> restrict?
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost )    (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )
   \ store  poiter to code-field    \ store  poiter to code-field
   switchram T cfalign H    switchram T cfalign H
   there swap T ! H    there swap T ! H
Line 2087  Cond: DOES> restrict? Line 2066  Cond: DOES> restrict?
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   g>body false ;    >link @ T >body H false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- ghost [xt] [colon-sys] )  : DO:     ( -- addr [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname postpone gdoes> postpone ?EXIT ;    :noname postpone gdoes> postpone ?EXIT ;
   
 : by:     ( -- ghost [xt] [colon-sys] ) \ name  : by:     ( -- addr [xt] [colon-sys] ) \ name
   ghost    ghost
   :noname postpone gdoes> postpone ?EXIT ;    :noname postpone gdoes> postpone ?EXIT ;
   
 : ;DO ( ghost [xt] [colon-sys] -- ghost )  : ;DO ( addr [xt] [colon-sys] -- addr )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
 T has? peephole H [IF]  : by      ( -- addr ) \ Name
 : compile: ( ghost -- ghost [xt] [colon-sys] )  
     :noname  postpone g>body ;  
 : ;compile ( ghost [xt] [colon-sys] -- ghost )  
     postpone ;  over >comp ! ; immediate  
 [ELSE]  
 : compile:  ( ghost -- ghost xt colon-sys )  :noname ;  
 : ;compile ( ghost xt colon-sys -- ghost )  
     postpone ; drop ['] prim-resolved over >comp ! ; immediate  
 [THEN]  
   
 : by      ( -- ghost ) \ Name  
   ghost >end @ ;    ghost >end @ ;
   
 >TARGET  >TARGET
Line 2123  T has? peephole H [IF] Line 2091  T has? peephole H [IF]
   
 Build:  ( n -- ) ;  Build:  ( n -- ) ;
 by: :docon ( ghost -- n ) T @ H ;DO  by: :docon ( ghost -- n ) T @ H ;DO
 compile: alit, compile @ ;compile  
 Builder (Constant)  Builder (Constant)
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 2140  Builder 2Constant Line 2107  Builder 2Constant
   
 BuildSmart: ;  BuildSmart: ;
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
 \ compile: alit, ;compile  
 Builder Create  Builder Create
   
 T has? rom H [IF]  T has? rom H [IF]
Line 2150  Builder Variable Line 2116  Builder Variable
 [ELSE]  [ELSE]
 Build: T 0 , H ;  Build: T 0 , H ;
 by Create  by Create
 \ compile: alit, ;compile  
 Builder Variable  Builder Variable
 [THEN]  [THEN]
   
Line 2161  Builder 2Variable Line 2126  Builder 2Variable
 [ELSE]  [ELSE]
 Build: T 0 , 0 , H ;  Build: T 0 , 0 , H ;
 by Create  by Create
 \ compile: alit, ;compile  
 Builder 2Variable  Builder 2Variable
 [THEN]  [THEN]
   
Line 2172  Builder AVariable Line 2136  Builder AVariable
 [ELSE]  [ELSE]
 Build: T 0 A, H ;  Build: T 0 A, H ;
 by Create  by Create
 \ compile: alit, ;compile  
 Builder AVariable  Builder AVariable
 [THEN]  [THEN]
   
Line 2195  Variable tudp 0 tudp ! Line 2158  Variable tudp 0 tudp !
   
 Build: 0 u, X , ;  Build: 0 u, X , ;
 by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
 compile: compile useraddr T @ , H ;compile  
 Builder User  Builder User
   
 Build: 0 u, X , 0 u, drop ;  Build: 0 u, X , 0 u, drop ;
Line 2216  Builder AValue Line 2178  Builder AValue
   
 BuildSmart:  ( -- ) [T'] noop T A, H ;  BuildSmart:  ( -- ) [T'] noop T A, H ;
 by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 compile: alit, compile @ compile execute ;compile  
 Builder Defer  Builder Defer
   
 Build: ( inter comp -- ) swap T immediate A, A, H ;  Build: ( inter comp -- ) swap T immediate A, A, H ;
Line 2233  Builder interpret/compile: Line 2194  Builder interpret/compile:
   
 Build: ;  Build: ;
 by: :dofield T @ H + ;DO  by: :dofield T @ H + ;DO
 compile: T @ H lit, compile + ;compile  
 Builder (Field)  Builder (Field)
   
 Build: ( align1 offset1 align size "name" --  align2 offset2 )  Build: ( align1 offset1 align size "name" --  align2 offset2 )
Line 2248  Builder Field Line 2208  Builder Field
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   
   
 Build: ( m v -- m' v )  dup T , cell+ H ;  Build: ( m v -- m' v )  dup T , cell+ H ;
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
 Builder input-method  Builder input-method
Line 2256  Build: ( m v size -- m v' )  over T , H Line 2217  Build: ( m v size -- m v' )  over T , H
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
 Builder input-var  Builder input-var
   
   
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 2442  Cond: compile ( -- ) restrict? \ name Line 2405  Cond: compile ( -- ) restrict? \ name
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) addr, THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: [compile] ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) addr, THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: [compile] ( -- ) restrict? \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
Line 2632  bigendian Constant bigendian Line 2595  bigendian Constant bigendian
 : tempdp> tempdp> ;  : tempdp> tempdp> ;
 : const constflag on ;  : const constflag on ;
 : warnings name 3 = 0= twarnings ! drop ;  : warnings name 3 = 0= twarnings ! drop ;
   : redefinitions-start twarnings off ;
   : redefinitions-end twarnings on ;
   : group 0 word drop ;
   
 : | ;  : | ;
 \ : | NoHeaderFlag on ; \ This is broken (damages the last word)  \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
Line 2705  previous Line 2672  previous
 : .s            .s ;  : .s            .s ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  
   
 : group  source >in ! drop ;  
   
 \ turnkey direction  \ turnkey direction
 : H forth ; immediate  : H forth ; immediate
 : T minimal ; immediate  : T minimal ; immediate
Line 2726  previous Line 2689  previous
 : unlock previous forth also cross ;  : unlock previous forth also cross ;
   
 \ also minimal  \ also minimal
 : [[+++ also unlock ;  : [[ also unlock ;
 : +++]] previous previous also also ;  : ]] previous previous also also ;
   
 unlock definitions also minimal  unlock definitions also minimal
 : lock   lock ;  : lock   lock ;

Removed from v.1.101  
changed lines
  Added in v.1.102


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>