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

Diff for /gforth/cross.fs between versions 1.32 and 1.41

version 1.32, 1995/11/30 18:01:47 version 1.41, 1996/10/20 20:35:24
Line 173  bigendian Line 173  bigendian
 \ MakeKernal                                           12dec92py  \ MakeKernal                                           12dec92py
   
 >MINIMAL  >MINIMAL
 : makekernal ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   bit$  over 1- cell>bit rshift 1+ initmem    bit$  over 1- cell>bit rshift 1+ initmem
   image over initmem tdp off ;    image over initmem tdp off ;
   
Line 194  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 194  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : align+  ( taddr -- rest )  : align+  ( taddr -- rest )
     cell tuck 1- and - [ cell 1- ] Literal and ;      cell tuck 1- and - [ cell 1- ] Literal and ;
 : cfalign+  ( taddr -- rest )  : cfalign+  ( taddr -- rest )
     \ see kernal.fs:cfaligned      \ see kernel.fs:cfaligned
     float tuck 1- and - [ float 1- ] Literal and ;      float tuck 1- and - [ float 1- ] Literal and ;
   
 >TARGET  >TARGET
Line 202  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 202  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 \ assumes cell alignment granularity (as GNU C)  \ assumes cell alignment granularity (as GNU C)
   
 : cfaligned ( taddr1 -- taddr2 )  : cfaligned ( taddr1 -- taddr2 )
     \ see kernal.fs      \ see kernel.fs
     dup cfalign+ + ;      dup cfalign+ + ;
   
 >CROSS  >CROSS
Line 278  Variable last-ghost Line 278  Variable last-ghost
   
 : gfind   ( string -- ghost true/1 / string false )  : gfind   ( string -- ghost true/1 / string false )
 \ searches for string in word-list ghosts  \ searches for string in word-list ghosts
 \ !! wouldn't it be simpler to just use search-wordlist ? ae  
   dup count [ ' ghosts >body ] ALiteral search-wordlist    dup count [ ' ghosts >body ] ALiteral search-wordlist
   dup IF  >r >body nip r>  THEN ;    dup IF >r >body nip r>  THEN ;
   
 VARIABLE Already  VARIABLE Already
   
Line 357  variable ResolveFlag Line 356  variable ResolveFlag
 VARIABLE ^imm  VARIABLE ^imm
   
 >TARGET  >TARGET
 : immediate     20 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      40 flag! ;  : restrict      20 flag! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  \ ALIAS2 ansforth conform alias                          9may93jaw
Line 382  VARIABLE ^imm Line 381  VARIABLE ^imm
 s" crossdoc.fd" r/w create-file throw value doc-file-id  s" crossdoc.fd" r/w create-file throw value doc-file-id
 \ contains the file-id of the documentation file  \ contains the file-id of the documentation file
   
 : \G ( -- )  : T-\G ( -- )
     source >in @ /string doc-file-id write-line throw      source >in @ /string doc-file-id write-line throw
     source >in ! drop ; immediate      postpone \ ;
   
 Variable to-doc  Variable to-doc  to-doc on
   
 : cross-doc-entry  ( -- )  : cross-doc-entry  ( -- )
     to-doc @ tlast @ 0<> and    \ not an anonymous (i.e. noname) header      to-doc @ tlast @ 0<> and    \ not an anonymous (i.e. noname) header
Line 399  Variable to-doc Line 398  Variable to-doc
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
         s"  )" doc-file-id write-file throw          s"  )" doc-file-id write-file throw
         [char] \ parse 2drop                                              [char] \ parse 2drop                                    
         POSTPONE \g          T-\G
         >in !          >in !
     THEN  to-doc on ;      THEN ;
   
 \ Target TAGS creation  \ Target TAGS creation
   
 s" TAGS" r/w create-file throw value tag-file-id  s" kernel.TAGS" r/w create-file throw value 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,
Line 464  VARIABLE ;Resolve 1 cells allot Line 463  VARIABLE ;Resolve 1 cells allot
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
   dup 0< IF  to-doc off  THEN  
   (THeader over resolve T A, H 80 flag! ;    (THeader over resolve T A, H 80 flag! ;
 >CROSS  >CROSS
   
Line 501  ghost unloop    ghost ;S Line 499  ghost unloop    ghost ;S
 ghost lit       ghost (compile) ghost !         2drop drop  ghost lit       ghost (compile) ghost !         2drop drop
 ghost (does>)   ghost noop                      2drop  ghost (does>)   ghost noop                      2drop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
 ghost '  ghost '                                         drop
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
Line 528  Cond: chars ;Cond Line 526  Cond: chars ;Cond
 : alit, ( n -- )  compile lit T A,  H ;  : alit, ( n -- )  compile lit T A,  H ;
   
 >TARGET  >TARGET
   Cond: \G  T-\G ;Cond
   
 Cond:  Literal ( n -- )   restrict? lit, ;Cond  Cond:  Literal ( n -- )   restrict? lit, ;Cond
 Cond: ALiteral ( n -- )   restrict? alit, ;Cond  Cond: ALiteral ( n -- )   restrict? alit, ;Cond
   
Line 569  Cond: [Char]   ( "<char>" -- )  restrict Line 569  Cond: [Char]   ( "<char>" -- )  restrict
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader ;Resolve ! there ;Resolve cell+ !
   docol, depth T ] H ;    docol, depth T ] H ;
   
   : :noname ( -- colon-sys )
     T align H there docol, depth T ] H ;
   
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
   
 Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond  Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
Line 703  DO: ( ghost -- ) ABORT" CROSS: Don't exe Line 706  DO: ( ghost -- ) ABORT" CROSS: Don't exe
 Builder Defer  Builder Defer
 by Defer :dodefer resolve  by Defer :dodefer resolve
   
   Build:  ( inter comp -- ) swap T immediate A, A, H ;
   DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   Builder interpret/compile:
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
 >CROSS  >CROSS
Line 877  Cond: [ELSE]    [ELSE] ;Cond Line 884  Cond: [ELSE]    [ELSE] ;Cond
   
 bigendian Constant bigendian  bigendian Constant bigendian
   
 Create magic  s" gforth00" here over allot swap move  Create magic  s" Gforth10" here over allot swap move
   
 [char] 1 bigendian + cell + magic 7 + c!  char 1 bigendian + cell + magic 7 + c!
   
 : save-cross ( "name" -- )  : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type    bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r    w/o bin create-file throw >r
     s" #! "  r@ write-file throw
     bl parse r@ write-file throw
     s"  -i"  r@ write-file throw
     #lf      r@ emit-file throw
     r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
     ?do
         bl over emit-file throw
     loop
     drop
   magic 8       r@ write-file throw \ write magic    magic 8       r@ write-file throw \ write magic
   image @ there r@ write-file throw \ write image    image @ there r@ write-file throw \ write image
   bit$  @ there 1- cell>bit rshift 1+    bit$  @ there 1- cell>bit rshift 1+
Line 905  cell constant cell Line 921  cell constant cell
 \ include bug5.fs  \ include bug5.fs
 \ only forth also minimal definitions  \ only forth also minimal definitions
   
 : \  postpone \ ;  : \  postpone \ ;  immediate
 : \G postpone \G ;  : (  postpone ( ;  immediate
 : (  postpone ( ;  
 : include bl word count included ;  : include bl word count included ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;
 : cr cr ;  : cr cr ;
Line 921  only forth also minimal definitions Line 936  only forth also minimal definitions
 : hex           hex ;  : hex           hex ;
   
 : tudp          T tudp H ;  : tudp          T tudp H ;
 : tup           T tup H ;  minimal  : tup           T tup H ;
   
   : doc-off       false T to-doc H ! ;
   : doc-on        true  T to-doc H ! ;
   
   minimal
   
 \ for debugging...  \ for debugging...
 : order         order ;  : order         order ;
Removed from v.1.32  
changed lines
  Added in v.1.41

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