Force optimizing compile, inside (to),

parent 2576a437
Pipeline #750 failed with stage
in 8 minutes
......@@ -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
......
......@@ -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 "
......
......@@ -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 ;
......
......@@ -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}.
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment