Verified Commit e3663c3a authored by Bernd Paysan's avatar Bernd Paysan
Browse files

Force optimizing compile, inside (to),

parent 2576a437

cross.fs

+29 −29
Original line number Diff line number Diff line
@@ -107,7 +107,7 @@ defined? emit-file defined? toupper and \ drop 0 
  ELSE ' >body ! THEN ; immediate

: 0>= 0< 0= ;

: d<> rot <> -rot <> or ;

: toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;

: toupper dup 'a' 'z' 1+ within IF 'A' 'a' - + THEN ;

Variable ebuf

: emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;

0a Constant #lf
@@ -127,7 +127,7 @@ Create bases 10 , 2 , A , 100 , 


\ !! protect BASE saving wrapper against exceptions

: getbase ( addr u -- addr' u' )

    over c@ [char] $ - dup 4 u<

    over c@ '$' - dup 4 u<

    IF

	cells bases + @ base ! 1 /string

    ELSE
@@ -135,14 +135,14 @@ Create bases 10 , 2 , A , 100 , 
    THEN ;



: sign? ( addr u -- addr u flag )

    over c@ [char] - =  dup >r

    over c@ '-' =  dup >r

    IF

	1 /string

    THEN

    r> ;



: s>unumber? ( addr u -- ud flag )

    over [char] ' =

    over ''' =

    IF 	\ a ' alone is rather unusual :-)

	drop char+ c@ 0 true EXIT 

    THEN
@@ -153,7 +153,7 @@ Create bases 10 , 2 , A , 100 , 
    WHILE \ there are characters left

	dup r> -

    WHILE \ the last >number parsed something

	dup 1- dpl ! over c@ [char] . =

	dup 1- dpl ! over c@ '.' =

    WHILE \ the current char is '.'

	1 /string

    REPEAT  THEN \ there are unparseable characters left
@@ -265,7 +265,7 @@ hex \ the defualt base for the cross-compiler is hex !! 
    \ puts down string as cstring

    dup c, here swap chars dup allot move ;



: ," [char] " parse string, ;

: ," '"' parse string, ;



: SetValue ( n -- <name> )

\G Same behaviour as "Value" if the <name> is not defined
@@ -473,7 +473,7 @@ sourcepath value fpath 


: path= ( path-addr "dir1|dir2|dir3" ) \ gforth

    \G Make a complete new search path; the path separator is |.

    name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP

    name 2dup bounds ?DO i c@ '|' = IF 0 i c! THEN LOOP

    rot only-path ;



: fpath= ( "dir1|dir2|dir3" ) \ gforth
@@ -506,9 +506,9 @@ sourcepath value fpath 
    \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if

    \G it has a colon as second character ("C:...").  Paths simply

    \G containing a / are not absolute!

    2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....

    over c@ [char] / = >r

    over c@ [char] ~ = >r

    2dup 2 u> swap 1+ c@ ':' = and >r \ dos absoulte: c:/....

    over c@ '/' = >r

    over c@ '~' = >r

    \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic

    S" ./" string-prefix?

    r> r> r> or or or ;
@@ -516,7 +516,7 @@ sourcepath value fpath 
Create ofile 0 c, 255 chars allot

Create tfile 0 c, 255 chars allot



: pathsep? dup [char] / = swap [char] \ = or ;

: pathsep? dup '/' = swap '\' = or ;



: need/   ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ;
@@ -1426,7 +1426,7 @@ Variable mirrored-link \ linked list for mirrored regions 
\G prints a 16 or 32 Bit nice hex value

  base @ >r hex

  tcell 2 u>

  IF s>d <# # # # # [char] . hold # # # # #> type

  IF s>d <# # # # # '.' hold # # # # #> type

  ELSE s>d <# # # # # # #> type

  THEN r> base ! space ;
@@ -2240,10 +2240,10 @@ Variable to-doc to-doc on 


	Last-Header-Ghost @ >ghostname doc-file-id write-file throw

	>in @

	[char] ( parse 2drop

	[char] ) parse doc-file-id write-file throw

	'(' parse 2drop

	')' parse doc-file-id write-file throw

	s"  )" doc-file-id write-file throw

	[char] \ parse 2drop					

	'\' parse 2drop					

	T-\G

	>in !

    THEN ;
@@ -2280,7 +2280,7 @@ Create tag-tab 1 c, 09 c, 
	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

\	>in @ 0 <# #s [char] , hold #> tag-file-id write-line throw

\	>in @ 0 <# #s ',' hold #> tag-file-id write-line throw

	s" ,0" tag-file-id write-line throw

	base !

    ELSE  2drop  THEN ;
@@ -2369,8 +2369,8 @@ NoHeaderFlag off 
\G escapes / and \ to produce sed output

  bounds 

  DO I c@ dup

	CASE	[char] / OF drop ." \/" ENDOF

		[char] \ OF drop ." \\" ENDOF

	CASE	'/' OF drop ." \/" ENDOF

		'\' OF drop ." \\" ENDOF

		dup OF emit ENDOF

	ENDCASE

    LOOP ;
@@ -3800,7 +3800,7 @@ Cond: NEXT 1 ncontrols? next, ;Cond 


\ String words                                         23feb93py



: ,"            [char] " parse ht-string, X align ;

: ,"            '"' parse ht-string, X align ;



X has? control-rack [IF]

Cond: ."        compile (.")     T ," H ;Cond
@@ -3812,11 +3812,11 @@ Cond: ." '" parse tuck 2>r ahead, there 2r> ht-mem, X align 
                >r then, r> compile ALiteral compile Literal compile type ;Cond

Cond: S"        '" parse tuck 2>r ahead, there 2r> ht-mem, X align

                >r then, r> compile ALiteral compile Literal ;Cond

Cond: C"        ahead, there [char] " parse ht-string, X align

Cond: C"        ahead, there '"' parse ht-string, X align

                >r then, r> compile ALiteral ;Cond

Cond: ABORT"    if, ahead, there [char] " parse ht-string, X align

Cond: ABORT"    if, ahead, there '"' parse ht-string, X align

                >r then, r> compile ALiteral compile c(abort") then, ;Cond

Cond: WARNING"  if, ahead, there [char] " parse ht-string, X align

Cond: WARNING"  if, ahead, there '"' parse ht-string, X align

                >r then, r> compile ALiteral compile c(warning") then, ;Cond

[THEN]
@@ -3847,12 +3847,12 @@ Cond: defers T ' >body @ compile, H ;Cond 
: chained	T linked A, H ;



: err"   s" ErrLink linked" evaluate T , H

         [char] " parse ht-string, X align ;

         '"' parse ht-string, X align ;



: env"  [char] " parse s" EnvLink linked" evaluate

: env"  '"' parse s" EnvLink linked" evaluate

        ht-string, X align X , ;



: 2env" [char] " parse s" EnvLink linked" evaluate

: 2env" '"' parse s" EnvLink linked" evaluate

        here >r ht-string, X align X , X ,

        r> dup T c@ H 80 and swap T c! H ;
@@ -4296,7 +4296,7 @@ also forth 
\ [IFDEF] builttag	: builttag builttag ;	[THEN]

previous



: s" [char] " parse s-buffer place s-buffer count ; \ for environment?

: s" '"' parse s-buffer place s-buffer count ; \ for environment?

: + + ;

: 1+ 1 + ;

: 2+ 2 + ;
@@ -4340,13 +4340,13 @@ previous 
: included swap >image swap included ;

: require require ;

: needs require ;

: .( [char] ) parse type ;

: ERROR" [char] " parse 

: .( ')' parse type ;

: ERROR" '"' parse 

  rot 

  IF cr ." *** " type ."  ***" -1 ABORT" CROSS: Target error, see text above" 

  ELSE 2drop 

  THEN ;

: ." [char] " parse type ;

: ." '"' parse type ;

: cr cr ;



: times 0 ?DO dup X c, LOOP drop ; \ used for space table creation

ds2texi.fs

+6 −6
Original line number Diff line number Diff line
@@ -56,16 +56,16 @@ create description-buffer 4096 chars allot 
: skip-prefix ( c-addr1 u1 -- c-addr2 u2 )

    2dup s" --" string-prefix?

    IF

	[char] - skip [char] - scan 1 /string

	'-' skip '-' scan 1 /string

    THEN ;



: replace-_ ( c-addr u -- )

    \ replaces _ with -

    chars bounds

    +DO

	i c@ [char] _ =

	i c@ '_' =

	if

	    [char] - i c!

	    '-' i c!

	endif

	1 chars

    +loop ;
@@ -88,7 +88,7 @@ create description-buffer 4096 chars allot 
    get-current documentation set-current

    create

	latest name>string skip-prefix 2,		\ name

	[char] ) parse save-mem 2,	\ stack-effect

	')' parse save-mem 2,	\ stack-effect

	bl sword condition-wordset 2,	\ wordset

	bl sword dup	\ pronounciation

	if
@@ -104,7 +104,7 @@ create description-buffer 4096 chars allot 
    >r

    s" @{}" r@ scan 0<>

    if

	[char] @ emit

	'@' emit

    endif

    drop r> emit ;
@@ -126,7 +126,7 @@ create description-buffer 4096 chars allot 
    ." @cindex "

    ." @code{" r@ doc-name 2@ typetexi ." }"

    cr

    r@ doc-name 2@ drop c@ [char] : <> if

    r@ doc-name 2@ drop c@ ':' <> if

	\ cut out words starting with :, info-lookup cannot handle them

	\ !! deal with : by replacing it here and in info-lookup?

	." @kindex "

float.fs

+1 −1
Original line number Diff line number Diff line
@@ -83,7 +83,7 @@ Create f!-table ' f! , ' f+! , 


to: fvalue-to ( r xt-fvalue -- ) \ gforth

    >body f!-table to-!exec ;

to-opt: >body postpone Literal f!-table to-!, ;

opt: drop postpone >body f!-table to-!, ;



: fvalue ( r "name" -- ) \ float-ext f-value

    fconstant ['] fvalue-to set-to ['] opt-fval set-optimizer ;

kernel/comp.fs

+8 −2
Original line number Diff line number Diff line
@@ -595,11 +595,17 @@ interpret/compile: opt: 
interpret/compile: comp:

( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth



: opt!-compile, ( xt -- )

    \G force optimizing compile,

    ['] compile, defer@ >r ['] opt-compile, is compile,

    ['] compile, catch

    r> is compile,  throw ;



: (to), ( xt -- ) ( generated code: v -- )

    \g in compiled @code{to @i{name}}, xt is that of @i{name}.  This

    \g word generates code for storing v (of type appropriate for

    \g @i{name}) there.  This word is a factor of @code{to}.

    dup >lits >namevt @ >vtto @ opt-compile,

    dup >lits >namevt @ >vtto @ opt!-compile,

    \ OPT: part of the SET-TO part of the defining word of <name>.

    \ This here needs to be optimizing even for gforth-itc, because

    \ otherwise this code won't work.
@@ -650,7 +656,7 @@ interpret/compile: comp: 
    \g this is the TO-method for normal values

    >body !-table to-!exec ;

opt: ( value-xt -- ) \ run-time: ( n -- )

    ?fold-to >body postpone Literal !-table to-!, ;

    drop postpone >body !-table to-!, ;



: <IS> ( "name" xt -- ) \ gforth

    \g Changes the @code{defer}red word @var{name} to execute @var{xt}.

prims2x.fs

+4 −4
Original line number Diff line number Diff line
@@ -154,7 +154,7 @@ $12340000 immarg ! 
    endif ;



: quote ( -- )

    [char] " emit ;

    '"' emit ;



\ count output lines to generate sync lines for output
@@ -1421,7 +1421,7 @@ is output-c-prim-num 
    stacks stack# th @ { stack }

    items 0 +do

	effect-endp @ { item }

	i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem

	i 0 <# #s stack stack-pointer 2@ holds '_' hold #> save-mem

	item item-name 2!

	stack item item-stack !

	stack stack-type @ item item-type !
@@ -1778,8 +1778,8 @@ print-token ! 
	endif

	0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )

	dup c@ bl = if

	    char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error

	    char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!

	    char+ dup c@ '"' <> 0= s" sync line syntax" ?print-error

	    char+ dup 100 '"' scan drop swap 2dup - save-mem filename 2!

	    char+

	endif

	dup c@ nl-char <> 0= s" sync line syntax" ?print-error