commit 6247d39ddc67b255201353b96f047a3df6573d8f
parent 67a226bfd9ae2a03179f020c1bb7c50fb0f90e56
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 8 Jun 2022 08:37:27 -0400
Make the (s) literal return a string instead of a range
Diffstat:
10 files changed, 44 insertions(+), 34 deletions(-)
diff --git a/boot.fs b/boot.fs
@@ -37,14 +37,16 @@
create _ ')' c,
: ( _ 1 waitw ; immediate
( hello, another comment! )
+: c@+ dup 1+ swap c@ ;
+: c!+ tuck c! 1+ ;
: fill ( a u b -- *A* ) rot> >r >A begin dup Ac!+ next drop ;
: allot0 ( n -- ) here over 0 fill allot ;
\ transform a fstring into a null-terminated string.
create _ $100 allot
-: tocstr ( sa sl -- a ) >r _ r@ move 0 _ r> + c! _ ;
+: tocstr ( str -- a ) c@+ >r _ r@ move 0 _ r> + c! _ ;
: fclose ( fd -- ) 6 ( close ) swap 0 0 ( close fd 0 0 ) lnxcall drop ;
create _ 'C' c, 'a' c, 'n' c, ''' c, 't' c, $20 c, 'o' c, 'p' c, 'e' c, 'n' c,
-: fopen ( sa sl -- fd )
+: fopen ( fname -- fd )
tocstr 5 ( open ) swap 0 0 ( open cstr noflag O_RDONLY ) lnxcall
dup 0< if _ 10 rtype abort then ;
create _ 1 allot
@@ -58,5 +60,5 @@ _fds value 'curfd
: f< ( -- c-or-0 ) fd@ fread ;
: fin< f< ?dup not if ( EOF )
fd~ fd@ not if ['] iin< to in< then $20 then ;
-: f<< word fopen >fd ['] fin< to in< ;
+: f<< word 2drop 'curword fopen >fd ['] fin< to in< ;
f<< init.fs
diff --git a/dusk.asm b/dusk.asm
@@ -156,12 +156,14 @@ defword '(alias)', 7, word_aliasroutine
jnz to_is_set
jmp [eax]
+; String literal. What follows it is a byte with the length of the string.
+; What we do here is to push the address of that string to PS, and then read
+; that length byte, then skip that many bytes and jump there.
defword '(s)', 3, word_strlit
pop esi ; addr of str
+ pspush esi
mov eax, 0
lodsb ; len
- pspush esi ; addr of first char
- pspush eax ; len
add esi, eax ; ret to PC right after str
jmp esi
@@ -589,6 +591,11 @@ defword 'stack?', 6, word_stackcond
call _rtype_loop
jmp word_abort
+; ( -- str )
+defword "'curword", 8, word_curwordaddr
+ pspush curword
+ ret
+
; ( -- sa sl )
defword 'curword', 7, word_curword
xor eax, eax
diff --git a/fs/cc/ast.fs b/fs/cc/ast.fs
@@ -34,7 +34,7 @@ create bopsprectbl 1 c, 1 c, 0 c, 0 c, 2 c, 2 c, 2 c, 2 c,
3 c, 3 c, 4 c, 4 c,
: bopid ( ta tl -- opid? f )
- >s BOPTlist sfind dup 0< if drop 0 else 1 then ;
+ r>str BOPTlist sfind dup 0< if drop 0 else 1 then ;
: bopprec ( opid -- precedence ) BOPSCNT min bopsprectbl + c@ ;
: boptoken ( opid -- ta tl )
BOPSCNT min ?dup if ( opid )
@@ -127,7 +127,7 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
\ Takes a token and returns the corresponding typedef (not AST type).
\ For now, we always return 1 on "int".
-: isType? ( ta tl -- typeid? f ) S" int" R= dup if 1 swap then ;
+: isType? ( ta tl -- typeid? f ) S" int" c@+ R= dup if 1 swap then ;
: expectConst ( ta tl -- n ) 2dup parse if rot> 2drop else _err then ;
: expectIdent ( ta tl -- ta tl )
A>r 2dup >r >A begin Ac@+ identifier? _assert next r>A ;
@@ -136,7 +136,9 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
\ Search the given token in a string list. if found, run the corresponding word
\ in optbl. Otherwise, parse error.
: tokenfromlist ( ta tl list optbl -- )
- >r rot> >s ( list R:optbl ) sfind dup 0< if s> _err then r> swap wexec ;
+ >r rot> r>str ( list tok R:optbl )
+ dup rot sfind ( tok idx ) dup 0< if c@+ _err then ( tok idx )
+ nip r> swap wexec ;
\ The binopswap operation is funky. It happens when we want to add a binop that
\ "eats up" the preceding node. There are 3 scenarios.
@@ -178,7 +180,7 @@ ASTIDCNT wordtbl astparsetbl
:w ( Statements ) StatementsTList StatementsOps tokenfromlist ;
:w ( Arguments ) ')' expectChar SeqClose ;
:w ( Expression )
- 2dup S" ;" R= if 2drop SeqClose exit then
+ 2dup S" ;" c@+ R= if 2drop SeqClose exit then
activeempty? if 2dup uopid if UnaryOp 2drop exit then then
2dup bopid if ( ta tl binopid )
rot> 2drop ( bopid )
diff --git a/fs/init.fs b/fs/init.fs
@@ -1,5 +1,5 @@
\ Initialization layer. Called at the end of boot.fs
f<< lib/core.fs
f<< sys/rdln.fs
-: init S" Dusk OS" rtype rdln$ ;
+: init S" Dusk OS" stype rdln$ ;
init
diff --git a/fs/lib/core.fs b/fs/lib/core.fs
@@ -8,12 +8,11 @@ $08 value BS $04 value EOF
: <> ( n n -- l h ) 2dup > if swap then ;
: min <> drop ; : max <> nip ;
-: c@+ dup 1+ swap c@ ;
-: c!+ tuck c! 1+ ;
-
+\ emit all chars of "str"
+: stype ( str -- ) c@+ rtype ;
: ," begin in< dup '"' = if drop exit then c, again ;
: S" compile (s) here 1 allot here ," here -^ ( 'len len ) swap c! ; immediate
-: ." [compile] S" compile rtype ; immediate
+: ." [compile] S" compile stype ; immediate
: abort" [compile] ." compile abort ; immediate
: [c]? ( c a u -- i )
@@ -31,5 +30,5 @@ create _ ," 0123456789abcdef"
scnt >A begin dup .x spc> >r scnt not until
begin r> scnt A> = until ;
: .S ( -- )
- S" SP " rtype scnt .x1 spc> S" RS " rtype rcnt .x1 spc>
- S" -- " rtype stack? psdump ;
+ S" SP " stype scnt .x1 spc> S" RS " stype rcnt .x1 spc>
+ S" -- " stype stack? psdump ;
diff --git a/fs/lib/scratch.fs b/fs/lib/scratch.fs
@@ -15,4 +15,7 @@ scratch( value scratch>
: scratchallot ( n -- a )
scratch> over + scratch) >= if scratch( to scratch> then
scratch> tuck + to scratch> ( a ) ;
+\ push a range to the scratchpad as a string
+: r>str ( a u -- str )
+ dup 1+ scratchallot ( src u dst-1 ) >r dup r@ c!+ swap ( src dst u ) move r> ;
diff --git a/fs/str.fs b/fs/str.fs
@@ -1,24 +1,21 @@
\ String utilities
-\ All string utilies operate on an "active string", which we set with ">s"
$100 value STR_MAXSZ \ maximum size of strings (including size byte)
-0 value sa
-0 value sl
-
-: >s ( sa sl -- ) to sl to sa ;
-: s> ( -- sa sl ) sa sl ;
+\ is c a whitespace?
: ws? ( c -- f ) SPC <= ;
-: stype ( str -- ) c@+ rtype ;
+\ Return whether s1 and s2 are equal
+: s= ( s1 s2 -- f ) over c@ 1+ []= ;
+\ "skip" str, that is, return the address following its last char
+: s) ( str -- a ) c@+ + ;
\ find active string in "list" and return its index, -1 if not found.
\ A list is a simple sequence of strings (length byte, then contents, then
\ another one...) ended by a 0 length
-: sfind ( list -- idx ) -1 swap begin ( idx a )
- swap 1+ swap c@+ ( idx sa sl )
- ?dup not if 2drop -1 exit then ( idx sa sl )
- 2dup + rot> ( idx nexta sa sl ) s> R= until ( idx a )
- drop ( a ) ;
+: sfind ( str list -- idx ) -1 rot> begin ( idx s a )
+ rot 1+ rot> ( idx s a )
+ 2dup s= if ( found ) 2drop exit then
+ s) dup c@ not until ( idx s a ) 2drop drop -1 ;
\ trim whitespaces from the right of string
: rtrim ( sa sl -- sa sl ) 1+ begin 1- 2dup + 1- c@ ws? not until ;
diff --git a/fs/sys/rdln.fs b/fs/sys/rdln.fs
@@ -13,7 +13,7 @@ in) value in>
dup emitv dup rot c!+ ( c ptr+1 ) dup in) = rot SPC < or ( ptr+1 f )
then ;
: rdln
- in( LNSZ SPC fill S" ok" rtype nl>
+ in( LNSZ SPC fill S" ok" stype nl>
in( begin key lntype until drop nl> ;
: rdln<? ( -- c-or-0 )
in> in) < if in> c@+ swap to in> else 0 then ;
diff --git a/tests/testccast.fs b/tests/testccast.fs
@@ -6,8 +6,8 @@ opentestc
parseast
curunit firstchild dup astid AST_FUNCTION #eq ( fnode )
-: s S" retconst";
-dup 'data c@+ s R= #
+: s S" retconst" ;
+dup 'data s s= #
firstchild nextsibling dup astid AST_STATEMENTS #eq ( snode )
firstchild dup astid AST_RETURN #eq ( rnode )
firstchild ( expr ) firstchild ( factor )
diff --git a/tests/teststr.fs b/tests/teststr.fs
@@ -7,6 +7,6 @@ create list
3 c, ," bar"
0 c,
-: _ S" foo" >s list sfind 1 #eq ; _
-: _ S" hello" >s list sfind 0 #eq ; _
-: _ S" baz" >s list sfind -1 #eq ; _
+: _ S" foo" list sfind 1 #eq ; _
+: _ S" hello" list sfind 0 #eq ; _
+: _ S" baz" list sfind -1 #eq ; _
