Diff for /gforth/cross.fs between versions 1.113 and 1.118

version 1.113, 2001/09/12 14:45:38 version 1.118, 2002/01/05 20:16:17
Line 202  Create bases   10 ,   2 ,   A , 100 , Line 202  Create bases   10 ,   2 ,   A , 100 ,
   
 [THEN]  [THEN]
   
   \ this provides assert( and struct stuff
   \GFORTH [IFUNDEF] assert1(
   \GFORTH also forth definitions require assert.fs previous
   \GFORTH [THEN]
   
   >CROSS
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
 \ Warnings off  \ Warnings off
   
Line 705  Plugin branchtoresolve, ( branch-addr -- Line 712  Plugin branchtoresolve, ( branch-addr --
 Plugin branchtomark, ( -- target-addr ) \ marks a branch destination  Plugin branchtomark, ( -- target-addr ) \ marks a branch destination
   
 Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position  Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position
   Plugin xt, ( tcfa -- )                  \ compiles xt
 Plugin prim, ( tcfa -- )                \ compiles primitive invocation  Plugin prim, ( tcfa -- )                \ compiles primitive invocation
 Plugin colonmark, ( -- addr )           \ marks a colon call  Plugin colonmark, ( -- addr )           \ marks a colon call
 Plugin colon-resolve ( tcfa addr -- )  Plugin colon-resolve ( tcfa addr -- )
Line 891  Variable cross-space-dp-orig Line 899  Variable cross-space-dp-orig
   THEN ;    THEN ;
   
 Defer is-forward  Defer is-forward
   Defer do-refered
   
   : prim-forward   ( ghost -- )
     colonmark, 1 do-refered ; \ compile space for call
   ' prim-forward IS is-forward
   
 : (ghostheader) ( -- )  : (ghostheader) ( -- )
   ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,       ghost-list linked <fwd> , 0 , ['] NoExec , what's is-forward ,
   0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
   
 : ghostheader ( -- ) (ghostheader) 0 , ;  : ghostheader ( -- ) (ghostheader) 0 , ;
   
Line 1007  Variable reuse-ghosts reuse-ghosts off Line 1020  Variable reuse-ghosts reuse-ghosts off
   
 \ ' >ghostname ALIAS @name  \ ' >ghostname ALIAS @name
   
   : findghost ( "ghostname" -- ghost ) 
     bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;
   
 : [G'] ( -- ghost : name )  : [G'] ( -- ghost : name )
 \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"    findghost
   ghost state @ IF postpone literal THEN ; immediate    state @ IF postpone literal THEN ; immediate
   
 : g>xt ( ghost -- xt )  : g>xt ( ghost -- xt )
 \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.  \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
Line 1041  End-Struct addr-struct Line 1057  End-Struct addr-struct
   dup @ ?dup IF nip EXIT THEN    dup @ ?dup IF nip EXIT THEN
   addr-struct %allocerase tuck swap ! ;    addr-struct %allocerase tuck swap ! ;
   
   >cross
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
   Ghost - drop \ need a ghost otherwise "-" would be treated as a number
   
 Ghost 0=                                        drop  Ghost 0=                                        drop
 Ghost branch    Ghost ?branch                   2drop  Ghost branch    Ghost ?branch                   2drop
 Ghost (do)      Ghost (?do)                     2drop  
 Ghost (for)                                     drop  
 Ghost (loop)    Ghost (+loop)                   2drop  
 Ghost (next)                                    drop  
 Ghost unloop    Ghost ;S                        2drop  Ghost unloop    Ghost ;S                        2drop
 Ghost lit       Ghost (compile) Ghost !         2drop drop  Ghost lit       Ghost !                         2drop
 Ghost (does>)   Ghost noop                      2drop  Ghost noop                                      drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  
 Ghost '                                         drop  
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop  Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
 Ghost :dovar                                    drop  Ghost :dovar                                    drop
 Ghost over      Ghost =         Ghost drop      2drop drop  Ghost over      Ghost =         Ghost drop      2drop drop
 Ghost - drop  
 Ghost 2drop drop  Ghost 2drop drop
 Ghost 2dup drop  Ghost 2dup drop
   Ghost call drop
   Ghost @ drop
   Ghost useraddr drop
   Ghost execute drop
   Ghost + drop
   Ghost decimal drop
   Ghost hex drop
   Ghost lit@ drop
   Ghost lit-perform drop
   Ghost lit+ drop
   Ghost does-exec drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
   
 >cross  
 \ we define it ans like...  \ we define it ans like...
 wordlist Constant target-environment  wordlist Constant target-environment
   
Line 1618  T has? relocate H Line 1639  T has? relocate H
 : A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;
   
   \ high-level ghosts
   
   >CROSS
   
   : call-forward ( ghost -- )
       there 0 colon, 0 do-refered ;
   ' call-forward IS is-forward
   
   Ghost (do)      Ghost (?do)                     2drop
   Ghost (for)                                     drop
   Ghost (loop)    Ghost (+loop)                   2drop
   Ghost (next)                                    drop
   Ghost (does>)   Ghost (compile)                 2drop
   Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
   Ghost (C")                                      drop
   Ghost '                                         drop
   
   \ ' prim-forward IS is-forward
   
   \ user ghosts
   
   Ghost state drop
   
 \ \ --------------------        Host/Target copy etc.           29aug01jaw  \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
Line 1676  previous Line 1719  previous
 >CROSS  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
   : (xt) T a, H ;                                 ' (xt) plugin-of xt,
 : (prim) T a, H ;                               ' (prim) plugin-of prim,  : (prim) T a, H ;                               ' (prim) plugin-of prim,
   
 : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) plugin-of colon-resolve  : (cr) >tempdp colon, tempdp> ;                 ' (cr) plugin-of colon-resolve
 : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve  : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )  : (dr)  ( ghost res-pnt target-addr addr )
         >tempdp drop over           >tempdp drop over 
Line 1690  previous Line 1734  previous
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 prim, ;                                  ' (cm) plugin-of colonmark,      -1 xt, ;                                    ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
Line 1716  previous Line 1760  previous
     loadfile ,       loadfile , 
     sourceline# ,       sourceline# , 
     space>      space>
   ;  ;
   
   ' (refered) IS do-refered
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
Line 1780  Defer resolve-warning Line 1826  Defer resolve-warning
 : prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
     >link @ prim, ;      >link @ prim, ;
   
 \ FIXME: not used currently  0 Value resolved
 : does-resolved ( ghost -- )  
     dup g>body alit, >do:ghost @ g>body colon, ;  
   
 : (is-forward)   ( ghost -- )  
   colonmark, 0 (refered) ; \ compile space for call  
 ' (is-forward) IS is-forward  
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
Line 1807  Defer resolve-warning Line 1847  Defer resolve-warning
     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      r@ to resolved
       r@ >comp @ ['] prim-forward = IF
           ['] prim-resolved  r@ >comp !  THEN
       r@ >comp @ what's is-forward = IF
         ['] prim-resolved  r@ >comp !  THEN          ['] prim-resolved  r@ >comp !  THEN
     \ loop through forward referencies      \ loop through forward referencies
     r> -rot       r> -rot 
Line 1946  Variable to-doc  to-doc on Line 1989  Variable to-doc  to-doc on
 \ Target TAGS creation  \ Target TAGS creation
   
 s" kernel.TAGS" r/w create-file throw value tag-file-id  s" kernel.TAGS" r/w create-file throw value tag-file-id
   s" kernel.tags" r/w create-file throw value vi-tag-file-id
 \ contains the file-id of the tags file  \ contains the file-id of the tags file
   
 Create tag-beg 2 c,  7F c, bl c,  Create tag-beg 2 c,  7F c, bl c,
 Create tag-end 2 c,  bl c, 01 c,  Create tag-end 2 c,  bl c, 01 c,
 Create tag-bof 1 c,  0C c,  Create tag-bof 1 c,  0C c,
   Create tag-tab 1 c,  09 c,
   
 2variable last-loadfilename 0 0 last-loadfilename 2!  2variable last-loadfilename 0 0 last-loadfilename 2!
                           
Line 1964  Create tag-bof 1 c,  0C c, Line 2009  Create tag-bof 1 c,  0C c,
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
     THEN ;      THEN ;
   
 : cross-tag-entry  ( -- )  : cross-gnu-tag-entry  ( -- )
     tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
     IF      IF
         put-load-file-name          put-load-file-name
         source >in @ min tag-file-id write-file throw          source >in @ min tag-file-id write-file throw
         tag-beg count tag-file-id write-file throw          tag-beg count tag-file-id write-file throw
         tlast @ >image count 1F and tag-file-id write-file throw          Last-Header-Ghost @ >ghostname tag-file-id write-file throw
         tag-end count tag-file-id write-file throw          tag-end count tag-file-id write-file throw
         base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw          base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
Line 1978  Create tag-bof 1 c,  0C c, Line 2023  Create tag-bof 1 c,  0C c,
         base !          base !
     THEN ;      THEN ;
   
   : cross-vi-tag-entry ( -- )
       tlast @ 0<> \ not an anonymous (i.e. noname) header
       IF
           sourcefilename vi-tag-file-id write-file throw
           tag-tab count vi-tag-file-id write-file throw
           Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw
           tag-tab count vi-tag-file-id write-file throw
           s" /^" vi-tag-file-id write-file throw
           source vi-tag-file-id write-file throw
           s" $/" vi-tag-file-id write-line throw
       THEN ;
   
   : cross-tag-entry ( -- )
       cross-gnu-tag-entry
       cross-vi-tag-entry ;
   
 \ Check for words  \ Check for words
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
Line 2086  Variable aprim-nr -20 aprim-nr ! Line 2147  Variable aprim-nr -20 aprim-nr !
 : copy-execution-semantics ( ghost-from ghost-dest -- )  : copy-execution-semantics ( ghost-from ghost-dest -- )
   >r    >r
   dup >exec @ r@ >exec !    dup >exec @ r@ >exec !
     dup >comp @ r@ >comp !
   dup >exec2 @ r@ >exec2 !    dup >exec2 @ r@ >exec2 !
   dup >exec-compile @ r@ >exec-compile !    dup >exec-compile @ r@ >exec-compile !
   dup >ghost-xt @ r@ >ghost-xt !    dup >ghost-xt @ r@ >ghost-xt !
Line 2132  Defer setup-prim-semantics Line 2194  Defer setup-prim-semantics
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
 : Primitive  ( -- ) \ name  : Primitive  ( -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  drop  EXIT  THEN  >in !
   dup 0< s" prims" T $has? H 0= and    s" prims" T $has? H 0=
   IF    IF
      .sourcepos ." needs prim: " >in @ bl word count type >in ! cr       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
   THEN    THEN
   \  ['] prim-forward IS is-forward
   prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
   dup >ghost-flags <primitive> set-flag    dup >ghost-flags <primitive> set-flag
   over resolve T A, H alias-mask flag!    over resolve T A, H alias-mask flag!
   \  ['] call-forward IS is-forward
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2176  Comment (       Comment \ Line 2240  Comment (       Comment \
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( "name" -- ) \ name  : compile  ( "name" -- ) \ name
 \  bl word gfind 0= ABORT" CROSS: Can't compile "    findghost
   ghost  
   dup >exec-compile @ ?dup    dup >exec-compile @ ?dup
   IF    nip compile,    IF    nip compile,
   ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict    ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict
Line 2199  Cond: [']  T ' H alit, ;Cond Line 2262  Cond: [']  T ' H alit, ;Cond
   
 : [T']  : [T']
 \ returns the target-cfa of a ghost, or compiles it as literal  \ returns the target-cfa of a ghost, or compiles it as literal
   postpone [G'] state @ IF postpone g>xt ELSE g>xt THEN ; immediate    postpone [G'] 
     state @ IF postpone g>xt ELSE g>xt THEN ; immediate
   
 \ \ threading modell                                    13dec92py  \ \ threading modell                                    13dec92py
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
Line 2324  Cond: MAXI Line 2388  Cond: MAXI
  ;Cond   ;Cond
   
 >CROSS  >CROSS
   
 \ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw  \ number? defined at the top                           11may93jaw
Line 2344  Cond: MAXI Line 2409  Cond: MAXI
   IF    0> IF swap lit,  THEN  lit, discard    IF    0> IF swap lit,  THEN  lit, discard
   ELSE  2drop restore-input throw Ghost gexecute THEN  ;    ELSE  2drop restore-input throw Ghost gexecute THEN  ;
   
 >TARGET  
 \ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
   >CROSS
   
 : compiling-state ( -- )  : compiling-state ( -- )
 \G set states to compililng  \G set states to compililng
     Compiling comp-state !      Compiling comp-state !
Line 2362  Cond: MAXI Line 2428  Cond: MAXI
    IF >ghost-xt @ execute X off ELSE drop THEN     IF >ghost-xt @ execute X off ELSE drop THEN
    Interpreting comp-state ! ;     Interpreting comp-state ! ;
   
   >TARGET
   
 : ]   : ] 
     compiling-state      compiling-state
     BEGIN      BEGIN
Line 2415  Cond: ; ( -- ) Line 2483  Cond: ; ( -- )
         fini,          fini,
         comp[          comp[
         ;Resolve @           ;Resolve @ 
         IF      ;Resolve @ ;Resolve cell+ @ resolve           IF  ['] colon-resolved ;Resolve @ >comp !
                 ['] colon-resolved ;Resolve @ >comp !              ;Resolve @ ;Resolve cell+ @ resolve 
         THEN          THEN
         interpreting-state          interpreting-state
         ;Cond          ;Cond
Line 2425  Cond: [ ( -- ) interpreting-state ;Cond Line 2493  Cond: [ ( -- ) interpreting-state ;Cond
   
 >CROSS  >CROSS
   
 Create GhostDummy ghostheader  0 Value created
 <res> GhostDummy >magic !  
   
 : !does ( does-action -- )  : !does ( does-action -- )
 \ !! zusammenziehen und dodoes, machen!  
     tlastcfa @ [G'] :dovar killref      tlastcfa @ [G'] :dovar killref
 \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;      >space here >r ghostheader space>
 \ !! geht so nicht, da dodoes, ghost will!      r@ created >do:ghost ! r@ swap resolve
     GhostDummy >link ! GhostDummy       r> tlastcfa @ >tempdp dodoes, tempdp> ;
     tlastcfa @ >tempdp dodoes, tempdp> ;  
   
   
 Defer instant-interpret-does>-hook  Defer instant-interpret-does>-hook
   
   : does-resolved ( ghost -- )
       compile does-exec g>xt T a, H ;
   \    dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;
   
 : resolve-does>-part ( -- )  : resolve-does>-part ( -- )
 \ resolve words made by builders  \ resolve words made by builders
   Last-Header-Ghost @ >do:ghost @ ?dup     Last-Header-Ghost @ >do:ghost @ ?dup 
   IF    there resolve     IF  there resolve  THEN ;
         \ TODO: set special DOES> resolver action here  
   THEN ;  
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
Line 2452  Cond: DOES> Line 2518  Cond: DOES>
         resolve-does>-part          resolve-does>-part
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does   : DOES>
   instant-interpret-does>-hook      ['] does-resolved created >comp !
   depth T ] H ;      switchrom doeshandler, T here H !does 
       instant-interpret-does>-hook
       depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                              01nov92py  \ Creation                                              01nov92py
Line 2472  Cond: DOES> Line 2540  Cond: DOES>
   ghost to built     ghost to built 
   built >created @ 0= IF    built >created @ 0= IF
     built >created on      built >created on
     ['] prim-resolved built >comp !   
   THEN ;    THEN ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
Line 2492  Cond: DOES> Line 2559  Cond: DOES>
   ;    ;
   
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
 \g stores execution semantic and compilation semantic in the built word     \g stores execution semantic and compilation semantic in the built word
    swap >do:ghost @      swap >do:ghost @ 2dup swap >do:ghost !
    \ we use the >exec2 field for the semantic of a created word,     \ we use the >exec2 field for the semantic of a created word,
    \ using exec or exec2 makes no difference for normal cross-compilation     \ using exec or exec2 makes no difference for normal cross-compilation
    \ but is usefull for instant where the exec field is already     \ but is usefull for instant where the exec field is already
Line 2501  Cond: DOES> Line 2568  Cond: DOES>
    2dup >exec @ swap >exec2 !      2dup >exec @ swap >exec2 ! 
    >comp @ swap >comp ! ;     >comp @ swap >comp ! ;
   
   0 Value createhere
   
   : create-resolve ( -- )
       created createhere resolve 0 ;Resolve ! ;
   : create-resolve-immediate ( -- )
       create-resolve T immediate H ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   executed-ghost @ (Theader    executed-ghost @ (Theader
   dup >created on    dup >created on  dup to created
   2dup takeover-x-semantics hereresolve gdoes, ;    2dup takeover-x-semantics
     there to createhere drop gdoes, ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
Line 2514  Cond: DOES> Line 2589  Cond: DOES>
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   executed-ghost @ (THeader     executed-ghost @ (THeader 
   dup >created on    dup >created on  dup to created
   2dup takeover-x-semantics    2dup takeover-x-semantics
   there 0 T a, H alias-mask flag!    there 0 T a, H alias-mask flag!
   \ 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
   there tlastcfa !     there tlastcfa ! 
   hereresolve gdoes, ;    there to createhere drop gdoes, ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;    :noname postpone TCreate ;
Line 2535  Cond: DOES> Line 2610  Cond: DOES>
   [ [THEN] ] ;    [ [THEN] ] ;
   
 : ;Build  : ;Build
   postpone ; built >exec ! ; immediate    postpone create-resolve postpone ; built >exec ! ; immediate
   
   : ;Build-immediate
       postpone create-resolve-immediate
       postpone ; built >exec ! ; immediate
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @ g>body ;    executed-ghost @ g>body ;
Line 2660  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu Line 2739  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu
 by: :dodefer ( ghost -- ) X @ texecute ;DO  by: :dodefer ( ghost -- ) X @ texecute ;DO
   
 Builder interpret/compile:  Builder interpret/compile:
 Build: ( inter comp -- ) swap T immediate A, A, H ;Build  Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
Line 2713  DO:  abort" Not in cross mode" ;DO Line 2792  DO:  abort" Not in cross mode" ;DO
 T has? peephole H [IF]  T has? peephole H [IF]
   
 >CROSS  >CROSS
   
 : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,  : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,
   : (call-res) >tempdp resolved gexecute tempdp> drop ;
                                                   ' (call-res) plugin-of colon-resolve
   : (prim) dup 0< IF  ( $4000 - ) ELSE
       ." wrong usage of (prim) "
       dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN
       T a, H ;                                    ' (prim) plugin-of prim,
   
 \ if we want this, we have to spilt aconstant  \ if we want this, we have to spilt aconstant
 \ and constant!!  \ and constant!!
Line 2721  T has? peephole H [IF] Line 2807  T has? peephole H [IF]
 \ compile: g>body X @ lit, ;compile  \ compile: g>body X @ lit, ;compile
   
 Builder (Constant)  Builder (Constant)
 compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile
   
 Builder (Value)  Builder (Value)
 compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile
   
 \ this changes also Variable, AVariable and 2Variable  \ this changes also Variable, AVariable and 2Variable
 Builder Create  Builder Create
 \ compile: g>body alit, ;compile  compile: g>body alit, ;compile
   
 Builder User  Builder User
 compile: g>body compile useraddr T @ , H ;compile  compile: g>body compile useraddr T @ , H ;compile
   
 Builder Defer  Builder Defer
 compile: g>body alit, compile @ compile execute ;compile  compile: g>body compile lit-perform T A, H ;compile
   
 Builder (Field)  Builder (Field)
 compile: g>body T @ H lit, compile + ;compile  compile: g>body T @ H compile lit+ T , H ;compile
   
   Builder interpret/compile:
   compile: does-resolved ;compile
   
   Builder input-method
   compile: does-resolved ;compile
   
   Builder input-var
   compile: does-resolved ;compile
   
 [THEN]  [THEN]
   

Removed from v.1.113  
changed lines
  Added in v.1.118


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