Commit 56147e25 authored by anton's avatar anton

Added compat/strcomp.fs, introducing STR=, STRING-PREFIX?, and STR<

replaced most occurences of COMPARE with STR= and STRING-PREFIX?
parent d6169874
......@@ -252,6 +252,7 @@ COMPAT = compat/README \
compat/exception.fs \
compat/loops.fs \
compat/required.fs \
compat/strcomp.fs \
compat/struct.fs \
compat/vocabulary.fs
......@@ -366,6 +367,9 @@ FORTH_GEN = $(FORTH_GEN0) @KERNEL@ gforth.fi
# this is used for antidependences,
FORTH_GEN1 = $(FORTH_GEN0) @kernel_fi@
#kernel dependencies
KERN_DEPS = $(KERN_SRC) kernel/version.fs machpc.fs $(FORTH_GEN0) compat/strcomp.fs
#distributed documentation
DOCDIST = doc/gforth.info doc/gforth.info-* doc/gforth.ps
......@@ -564,22 +568,22 @@ bench: gforth-fast$(EXE) gforth.fi
# 3. copy new kernels to kernlXYZ.fi
# these are the ones we want to use now
kernl16l.fi-: $(KERN_SRC) kernel/version.fs mach16l.fs machpc.fs $(FORTH_GEN0)
kernl16l.fi-: $(KERN_DEPS) mach16l.fs
$(FORTHB) -e 's" mach16l.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl16l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl16b.fi-: $(KERN_SRC) kernel/version.fs mach16b.fs machpc.fs $(FORTH_GEN0)
kernl16b.fi-: $(KERN_DEPS) mach16b.fs
$(FORTHB) -e 's" mach16b.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl16b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32l.fi-: $(KERN_SRC) kernel/version.fs mach32l.fs machpc.fs $(FORTH_GEN0)
kernl32l.fi-: $(KERN_DEPS) mach32l.fs
$(FORTHB) -e 's" mach32l.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl32l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl32b.fi-: $(KERN_SRC) kernel/version.fs mach32b.fs machpc.fs $(FORTH_GEN0)
kernl32b.fi-: $(KERN_DEPS) mach32b.fs
$(FORTHB) -e 's" mach32b.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl32b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64l.fi-: $(KERN_SRC) kernel/version.fs mach64l.fs machpc.fs $(FORTH_GEN0)
kernl64l.fi-: $(KERN_DEPS) mach64l.fs
$(FORTHB) -e 's" mach64l.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl64l.fi- $(bindir)/gforth-$(VERSION) bye"
kernl64b.fi-: $(KERN_SRC) kernel/version.fs mach64b.fs machpc.fs $(FORTH_GEN0)
kernl64b.fi-: $(KERN_DEPS) mach64b.fs
$(FORTHB) -e 's" mach64b.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl-%.fi: arch/%/mach.fs $(KERN_SRC) kernel/version.fs $(FORTH_GEN0)
......
\ string comparisons
\ This file is in the public domain. NO WARRANTY.
\ Uses of COMPARE can be replaced with STR=, STRING-PREFIX?, and STR<
\ (and these can be implemented more efficiently and used more easily
\ than COMPARE). See <news:2002Aug12.110229@a0.complang.tuwien.ac.at>
\ and following.
s" gforth" environment? [if]
defined str=
[else]
0
[then]
0= [if]
: str= ( c-addr1 u1 c-addr2 u2 -- f )
compare 0= ;
: string-prefix? ( c-addr1 u1 c-addr2 u2 -- f )
\G Is @var{c-addr2 u2} a prefix of @var{c-addr1 u1}?
tuck 2>r min 2r> str= ;
: str< ( c-addr1 u1 c-addr2 u2 -- f )
compare 0< ;
[then]
......@@ -30,6 +30,8 @@ ToDo:
[THEN]
s" compat/strcomp.fs" included
hex
\ debugging for compiling
......@@ -259,9 +261,9 @@ hex
\ FIXME move down
: comment? ( c-addr u -- c-addr u )
2dup s" (" compare 0=
2dup s" (" str=
IF postpone (
ELSE 2dup s" \" compare 0= IF postpone \ THEN
ELSE 2dup s" \" str= IF postpone \ THEN
THEN ;
: X ( -- <name> )
......@@ -474,8 +476,8 @@ sourcepath value fpath
2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
over c@ [char] / = >r
over c@ [char] ~ = >r
\ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
2 min S" ./" compare 0=
\ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
S" ./" string-prefix?
r> r> r> or or or ;
Create ofile 0 c, 255 chars allot
......@@ -491,14 +493,14 @@ Create tfile 0 c, 255 chars allot
REPEAT ;
: remove~+ ( -- )
ofile count 3 min s" ~+/" compare 0=
ofile count s" ~+/" string-prefix?
IF
ofile count 3 /string ofile place
THEN ;
: expandtopic ( -- ) \ stack effect correct? - anton
\ expands "./" into an absolute name
ofile count 2 min s" ./" compare 0=
ofile count s" ./" string-prefix?
IF
ofile count 1 /string tfile place
0 ofile c! sourcefilename extractpath ofile place
......@@ -511,7 +513,7 @@ Create tfile 0 c, 255 chars allot
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw
over swap
BEGIN dup WHILE
dup >r '/ scan 2dup 4 min s" /../" compare 0=
dup >r '/ scan 2dup s" /../" string-prefix?
IF
dup r> - >r 4 /string over r> + 4 -
swap 2dup + >r move dup r> over -
......@@ -574,7 +576,7 @@ fpath= ~+
: included? ( c-addr u -- f )
file-list
BEGIN @ dup
WHILE >r 2dup r@ >fl-name count compare 0=
WHILE >r 2dup r@ >fl-name count str=
IF rdrop 2drop true EXIT THEN
r>
REPEAT
......@@ -3439,17 +3441,17 @@ Create parsed 20 chars allot \ store word we parsed
1 BEGIN
BEGIN bl word count dup WHILE
comment? 20 umin parsed place upcase parsed count
2dup s" [IF]" compare 0= >r
2dup s" [IFUNDEF]" compare 0= >r
2dup s" [IFDEF]" compare 0= r> or r> or
2dup s" [IF]" str= >r
2dup s" [IFUNDEF]" str= >r
2dup s" [IFDEF]" str= r> or r> or
IF 2drop 1+
ELSE 2dup s" [ELSE]" compare 0=
ELSE 2dup s" [ELSE]" str=
IF 2drop 1- dup
IF 1+
THEN
ELSE
2dup s" [ENDIF]" compare 0= >r
s" [THEN]" compare 0= r> or
2dup s" [ENDIF]" str= >r
s" [THEN]" str= r> or
IF 1- THEN
THEN
THEN
......@@ -3497,7 +3499,7 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
IF >in ! X :
ELSE drop
BEGIN bl word dup c@
IF count comment? s" ;" compare 0= ?EXIT
IF count comment? s" ;" str= ?EXIT
ELSE refill 0= ABORT" CROSS: Out of Input while C:"
THEN
AGAIN
......
......@@ -61,7 +61,7 @@ create description-buffer 4096 chars allot
description-buffer tuck - ;
: skip-prefix ( c-addr1 u1 -- c-addr2 u2 )
2dup 2 min s" --" compare 0=
2dup s" --" string-prefix?
IF
[char] - skip [char] - scan 1 /string
THEN ;
......@@ -165,7 +165,7 @@ create description-buffer 4096 chars allot
\ with the prefix addr2 u2 and continuing with a word in the
\ wordlist `documentation'. f is true if xt is executed.
>r dup >r
3 pick over compare 0=
3 pick over str=
if \ addr2 u2 is a prefix of addr1 u1
r> /string documentation search-wordlist
if \ the rest of addr1 u1 is in documentation
......
......@@ -36,7 +36,7 @@ Variable au
: search-magic ( fd -- ) >r
BEGIN magicbuf 8 r@ read-file throw 8 = WHILE
magicbuf s" Gforth2" tuck compare 0= UNTIL
magicbuf s" Gforth2" tuck str= UNTIL
ELSE true abort" No magic found" THEN
1 magicbuf 7 + c@ 5 rshift 3 and lshift tchars !
1 magicbuf 7 + c@ 1 rshift 3 and lshift tcell !
......
......@@ -685,7 +685,7 @@ interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
\ don't use 'locals|'! use '{'! A portable and free '{'
\ implementation is compat/anslocals.fs
BEGIN
name 2dup s" |" compare 0<>
name 2dup s" |" str= 0=
WHILE
(local)
REPEAT
......
......@@ -72,7 +72,7 @@ interpret/compile: ctrl ( "<char>" -- ctrl-code )
nip nip
THEN ;
s" os-class" environment? [IF] s" unix" compare 0= [ELSE] true [THEN]
s" os-class" environment? [IF] s" unix" str= [ELSE] true [THEN]
[IF]
: history-file ( -- addr u )
s" GFORTHHIST" getenv dup 0= IF
......
......@@ -113,9 +113,9 @@ Variable htmldir
: rework-htmldir ( addr u -- addr' u' / ior )
htmldir $! htmldir $@ compact.. htmldir $!len drop
htmldir $@ 3 min s" ../" compare 0=
htmldir $@ s" ../" string-prefix?
IF -1 EXIT THEN \ can't access below current directory
htmldir $@ 1 min s" ~" compare 0=
htmldir $@ s" ~" string-prefix?
IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip
nip - nip $ins
ELSE DocumentRoot $@ htmldir 0 $ins THEN
......@@ -144,7 +144,7 @@ Variable htmldir
: .connection ( -- )
." Connection: "
connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and
connection $@ s" Keep-Alive" str= maxnum @ 0> and
IF connection $@ type cr
." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr
-1 maxnum +! ELSE ." close" cr maxnum off THEN ;
......
......@@ -42,12 +42,12 @@ Variable argc ( -- addr ) \ gforth
: do-option ( addr1 len1 addr2 len2 -- n )
2swap
2dup s" -e" compare 0= >r
2dup s" --evaluate" compare 0= r> or
2dup s" -e" str= >r
2dup s" --evaluate" str= r> or
IF 2drop ( dup >r ) evaluate
( r> >tib +! ) 2 EXIT THEN
2dup s" -h" compare 0= >r
2dup s" --help" compare 0= r> or
2dup s" -h" str= >r
2dup s" --help" str= r> or
IF ." Image Options:" cr
." FILE load FILE (with `require')" cr
." -e STRING, --evaluate STRING interpret STRING (with `EVALUATE')" cr
......
......@@ -23,6 +23,7 @@
\ Needs:
require ./vars.fs
require ../compat/strcomp.fs
hex
......
......@@ -631,7 +631,7 @@ G -1 warnings T !
>r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
>stderr
." redefined " name>string 2dup type
compare 0<> if
str= 0= if
." with " type
else
2drop
......
......@@ -140,8 +140,8 @@
2dup 2 u> swap 1+ c@ ': = and >r \ dos absoulte: c:/....
over c@ '/ = >r
over c@ '~ = >r
\ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
2 min S" ./" compare 0=
\ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
S" ./" string-prefix?
r> r> r> or or or ;
Create ofile 0 c, 255 chars allot
......@@ -157,14 +157,14 @@ Create tfile 0 c, 255 chars allot
REPEAT ;
: remove~+ ( -- )
ofile count 3 min s" ~+/" compare 0=
ofile count s" ~+/" string-prefix?
IF
ofile count 3 /string ofile place
THEN ;
: expandtopic ( -- ) \ stack effect correct? - anton
\ expands "./" into an absolute name
ofile count 2 min s" ./" compare 0=
ofile count s" ./" string-prefix?
IF
ofile count 1 /string tfile place
0 ofile c! sourcefilename extractpath ofile place
......@@ -178,7 +178,7 @@ Create tfile 0 c, 255 chars allot
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw
over swap
BEGIN dup WHILE
dup >r '/ scan 2dup 4 min s" /../" compare 0=
dup >r '/ scan 2dup s" /../" string-prefix?
IF
dup r> - >r 4 /string over r> + 4 -
swap 2dup + >r move dup r> over -
......
......@@ -60,7 +60,7 @@ create image-included-files 4 , A, ( pointer to and count of included files )
\G @file{./foo.fs}
included-files 2@ 0
?do ( c-addr u addr )
dup >r 2@ 2over compare 0=
dup >r 2@ 2over str=
if
2drop rdrop unloop
true EXIT
......
......@@ -36,7 +36,7 @@ Variable sys-buf
: locate ( "name" -- ) s" " last-file $! bl sword
s" TAGS" r/o open-file throw >r
BEGIN r@ tag-line WHILE
s" " line-buf $@ compare 0=
s" " line-buf $@ str=
IF r@ get-file
ELSE 2dup check-word
IF print-location 2drop r> close-file throw EXIT THEN
......
......@@ -601,8 +601,8 @@ Objects definitions
:ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ;
: inter-method, ( interface -- ) \ oof-interface- oof
:ilist + @ bl word count 2dup s" '" compare
0= dup >r IF 2drop bl word count THEN
:ilist + @ bl word count 2dup s" '" str=
dup >r IF 2drop bl word count THEN
rot search-wordlist
dup 0= abort" Not an interface method!"
r> IF drop state @ IF postpone Literal THEN EXIT THEN
......
......@@ -837,7 +837,7 @@ stack inst-stream IP Cell
THEN ;
: output-tag-file ( -- )
name-filename 2@ last-name-filename 2@ compare if
name-filename 2@ last-name-filename 2@ str= 0= if
name-filename 2@ last-name-filename 2!
#ff emit cr
name-filename 2@ type
......@@ -1131,7 +1131,7 @@ print-token !
\ when input points to a newline, check if the next line is a
\ sync line. If it is, perform the appropriate actions.
rawinput @ >r
s" #line " r@ over compare 0<> if
s" #line " r@ over str= 0= if
rdrop 1 line +! EXIT
endif
0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
......
......@@ -132,7 +132,7 @@ Variable data-buffer
Content-Length @ IF
Content-Length $@ s>number drop r> read-sized EXIT THEN
Transfer-Encoding @ IF
Transfer-Encoding $@ s" chunked" compare 0= IF
Transfer-Encoding $@ s" chunked" str= 0= IF
r> read-chunked EXIT THEN THEN
r> read-to-end ;
......
......@@ -100,9 +100,9 @@ interpret/compile: .\" ( compilation 'ccc"' -- ; run-time -- ) \ gforth dot-back
s" x1fg" drop \-escape 31 <> throw drop .s
s" 00129" drop \-escape 10 <> throw drop .s
s" a" drop \-escape 7 <> throw drop .s
\"-parse " s" " compare 0<> throw .s
\"-parse " s" " str= 0= throw .s
\"-parse \a\b\c\e\f\n\r\t\v\100\x40xabcde" dump
s\" \a\bcd\e\fghijklm\12opq\rs\tu\v" \-escape-table over compare 0<> throw
s\" \w\0101\x041\"\\" name wAA"\ compare 0<> throw
s\" \a\bcd\e\fghijklm\12opq\rs\tu\v" \-escape-table over str= 0= throw
s\" \w\0101\x041\"\\" name wAA"\ str= 0= throw
s\" s\\\" \\" ' evaluate catch 0= throw
[endif]
......@@ -45,7 +45,7 @@
forthstart
begin \ search for start of file ("#! " at a multiple of 8)
8 -
dup 3 s" #! " compare 0=
dup 3 s" #! " str=
until ( imagestart )
here over - r@ write-file throw
r> close-file throw ;
......
......@@ -46,7 +46,7 @@ require simp-see.fs
include bufio.fs
include debug.fs
include history.fs
s" os-class" environment? dup [IF] drop s" unix" compare 0= [THEN]
s" os-class" environment? dup [IF] drop s" unix" str= [THEN]
[IF]
include vt100key.fs
[ELSE]
......@@ -58,7 +58,7 @@ require blocks.fs
require intcomp.fs
require savesys.fs
require table.fs
s" os-class" environment? dup [IF] drop s" unix" compare 0= [THEN]
s" os-class" environment? dup [IF] drop s" unix" str= [THEN]
[IF]
require ekey.fs
[ELSE]
......
......@@ -126,10 +126,3 @@ AUser CSP
2drop
repeat
- + dup >r resize throw r> ;
: str= ( c-addr1 u1 c-addr2 u2 -- f )
compare 0= ;
: string-prefix? ( c-addr1 u1 c-addr2 u2 -- f )
\G Is @var{c-addr2 u2} a prefix of @var{c-addr1 u1}?
tuck 2>r min 2r> compare 0= ;
......@@ -99,19 +99,19 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c, $00 c, $10 c, $4A c, $46 c,
: bw@ ( addr -- x ) 0 swap 2 bounds ?DO 8 lshift I c@ + LOOP ;
: gif? ( -- flag )
s" GIF89a" imgbuf over compare 0=
s" GIF87a" imgbuf over compare 0= or ;
s" GIF89a" imgbuf over str=
s" GIF87a" imgbuf over str= or ;
: gif-size ( -- w h )
imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift +
imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift + ;
: png? ( -- flag )
pngsig 8 imgbuf over compare 0= ;
pngsig 8 imgbuf over str= ;
: png-size ( -- w h )
imgbuf $14 + b@ imgbuf $10 + b@ ;
: jpg? ( -- flag )
jfif 10 imgbuf over compare 0= ;
jfif 10 imgbuf over str= ;
: jpg-size ( fd -- w h ) >r
2. BEGIN
2dup r@ reposition-file throw
......@@ -195,7 +195,7 @@ Defer parse-line
over c@ '% = over 0> and IF do-size on 1 /string THEN
over c@ '\ = over 0> and IF do-icon off 1 /string THEN ;
s" Gforth" environment? [IF] s" 0.5.0" compare 0= [IF]
s" Gforth" environment? [IF] s" 0.5.0" str= [IF]
: parse-string ( c-addr u -- ) \ core,block
loadfilename# @ >r
1 loadfilename# ! \ "*evaluated string*"
......@@ -297,7 +297,7 @@ wordlist Constant autoreplacements
: get-rest ( addr -- ) 0 parse -trailing rot $! ;
Create $lf 1 c, #lf c,
: get-par ( addr -- ) >r s" " r@ $+!
BEGIN 0 parse 2dup s" ." compare WHILE
BEGIN 0 parse 2dup s" ." str= 0= WHILE
r@ $@len IF $lf count r@ $+! THEN r@ $+!
refill 0= UNTIL ELSE 2drop THEN
rdrop ;
......@@ -405,7 +405,7 @@ longtags set-current
: . end-sec on 0 indent ;
: :code s" pre" >env
BEGIN source >in @ /string type cr refill WHILE
source s" :endcode" compare 0= UNTIL THEN
source s" :endcode" str= UNTIL THEN
-env ;
: \ postpone \ ;
......
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