[BACK]Return to cross.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

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

version 1.93, 2001/03/11 21:47:27 version 1.101, 2001/09/04 09:15:28
Line 678  Defer branchfrom, ( -- )  \ ?! Line 678  Defer branchfrom, ( -- )  \ ?!
 Defer branchtomark, ( -- target-addr )  \ marks a branch destination  Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  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 colonmark, ( -- addr )            \ marks a colon call
 Defer colon-resolve ( tcfa addr -- )  Defer colon-resolve ( tcfa addr -- )
   
Line 942  Variable user-vars 0 user-vars ! Line 944  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 1048  T has? rom H Line 1050  T has? rom H
 ' dictionary ALIAS rom-dictionary  ' dictionary ALIAS rom-dictionary
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize target's 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 1085  T has? rom H Line 1087  T has? rom H
         ELSE    r> drop THEN          ELSE    r> drop THEN
    REPEAT drop ;     REPEAT drop ;
   
 \ MakeKernal                                                    22feb99jaw  \ MakeKernel                                                    22feb99jaw
   
 : makekernel ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   dup dictionary >rlen ! setup-target ;    dup dictionary >rlen ! setup-target ;
Line 1350  DEFER dodoes, Line 1352  DEFER dodoes,
 DEFER ]comp     \ starts compilation  DEFER ]comp     \ starts compilation
 DEFER comp[     \ ends compilation  DEFER comp[     \ ends compilation
   
 : (cc) T a, H ;                                 ' (cc) IS colon,  : (prim) T a, H ;                               ' (prim) IS prim,
   
 : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) IS colon-resolve  : (cr) >tempdp ]comp prim, 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 1364  DEFER comp[     \ ends compilation Line 1366  DEFER comp[     \ ends compilation
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 colon, ;                                 ' (cm) IS colonmark,      -1 prim, ;                                  ' (cm) IS colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, prim, ;
 >CROSS  >CROSS
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
Line 1439  Exists-Warnings on Line 1441  Exists-Warnings on
   ELSE  true abort" CROSS: Ghostnames inconsistent "    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
 : is-resolved   ( ghost -- )  : colon-resolved   ( ghost -- )
   >link @ colon, ; \ compile-call      >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
Line 1451  Exists-Warnings on Line 1455  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  ['] is-resolved r@ >comp !  THEN      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 1574  Variable to-doc  to-doc on Line 1579  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 1772  Comment (       Comment \ Line 1776  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 1805  Cond: [']  T ' H alit, ;Cond Line 1815  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 gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,  : (doer,)   ( ghost -- ) ]comp addr, comp[ 1 fillcfa ;   ' (doer,) IS doer,
   
 : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,  : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,
   
Line 1968  Cond: ; ( -- ) restrict? Line 1978  Cond: ; ( -- ) restrict?
                comp[                 comp[
                state off                 state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve
                     ['] 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 1986  Create GhostDummy ghostheader Line 1997  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  @ T here H resolve THEN          tdoes @ ?dup IF  @ dup T here H resolve
               ['] 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 1999  Cond: DOES> restrict? Line 2016  Cond: DOES> restrict?
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create-xt do:-xt "name" -- )  : Builder    ( Create-xt do-ghost "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:-xt ghost )    Make-Ghost            ( Create-xt do-ghost ghost )
   rot swap              ( do:-xt Create-xt ghost )    rot swap              ( do-ghost Create-xt ghost )
   >exec ! , ;    >exec ! , ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
Line 2029  Cond: DOES> restrict? Line 2046  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 gdoes,    Theader >r dup , 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
Line 2067  Cond: DOES> restrict? Line 2084  Cond: DOES> restrict?
   postpone TCreate     postpone TCreate 
   [ [THEN] ] ;    [ [THEN] ] ;
   
 : g>body ( ghost -- body )  
     >link @ T >body H ;  
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
Line 2089  Cond: DOES> restrict? Line 2104  Cond: DOES> restrict?
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
   T has? peephole H [IF]
 : compile: ( ghost -- ghost [xt] [colon-sys] )  : compile: ( ghost -- ghost [xt] [colon-sys] )
     :noname  postpone g>body ;      :noname  postpone g>body ;
 : ;compile ( ghost [xt] [colon-sys] -- ghost )  : ;compile ( ghost [xt] [colon-sys] -- ghost )
     postpone ;  over >comp ! ;      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  : by      ( -- ghost ) \ Name
   ghost >end @ ;    ghost >end @ ;
Line 2102  Cond: DOES> restrict? Line 2123  Cond: DOES> restrict?
   
 Build:  ( n -- ) ;  Build:  ( n -- ) ;
 by: :docon ( ghost -- n ) T @ H ;DO  by: :docon ( ghost -- n ) T @ H ;DO
 \ compile: alit, compile @ ;compile  compile: alit, compile @ ;compile
 Builder (Constant)  Builder (Constant)
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 2129  Builder Variable Line 2150  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 2139  Builder 2Variable Line 2161  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 2149  Builder AVariable Line 2172  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 2171  Variable tudp 0 tudp ! Line 2195  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 @ , ;compile  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 2192  Builder AValue Line 2216  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  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 2209  Builder interpret/compile: Line 2233  Builder interpret/compile:
   
 Build: ;  Build: ;
 by: :dofield T @ H + ;DO  by: :dofield T @ H + ;DO
 \ compile: T @ H lit, compile + ;compile  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 2418  Cond: compile ( -- ) restrict? \ name Line 2442  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
         bl word gfind dup 0= ABORT" CROSS: Can't compile"
         0> IF    gexecute
            ELSE  dup >magic @ <imm> =
                  IF   gexecute
                  ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: postpone ( -- ) 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
Line 2674  previous Line 2705  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 2691  previous Line 2726  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.93  
changed lines
  Added in v.1.101

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