~vdupras/duskos

b1a2f639e71bf0f337f280e44c8cd977dfb7ebef — Virgil Dupras 4 days ago 3ac7474
Rename r~ to rdrop
M Makefile => Makefile +1 -2
@@ 33,8 33,7 @@ pcrun: pc.img

.PHONY: testpc
testpc: pc.img
	cat fs/xcomp/pc/init.fs fs/xcomp/pc/inittest.fs > fs/init.fs
	mcopy -D overwrite -i pc.img fs/init.fs ::
	cat fs/xcomp/pc/init.fs fs/xcomp/pc/inittest.fs | mcopy -D overwrite -i pc.img - ::init.fs
	qemu-system-i386 -nographic -drive file=pc.img,format=raw | tee /dev/stderr | grep "All tests passed"

.PHONY: run

M fs/cc/ast.fs => fs/cc/ast.fs +2 -2
@@ 188,7 188,7 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
: isIdent? ( tok -- f )
  dup 1+ c@ identifier1st? not if drop 0 exit then
  c@+ >r begin ( a )
    c@+ identifier? not if r~ drop 0 exit then next drop 1 ;
    c@+ identifier? not if rdrop drop 0 exit then next drop 1 ;
: expectIdent ( tok -- tok ) dup isIdent? _assert ;
: isChar? ( tok c -- f ) over 1+ c@ = swap c@ 1 = and ;
: isChar?^ ( c tok -- f ) swap isChar? ; \ for "case..of"


@@ 229,7 229,7 @@ alias noop parseExpression ( tok -- node ) \ forward declaration
      _err
    endcase
    nextt case
      '}' of isChar?^ r~ exit endof
      '}' of isChar?^ rdrop exit endof
      ',' of isChar?^ endof
      _err
    endcase

M fs/cc/gen.fs => fs/cc/gen.fs +1 -1
@@ 178,7 178,7 @@ ASTIDCNT wordtbl gentbl ( node -- )
    r@ firstchild ?dup if ( node )
      selop1 gennode ( value in op1 ) op1<>op2
      selop1 r@ decl>op vmmov,
    then r~
    then rdrop
  then ;
'w genchildren ( Unit )
:w ( Function )

M fs/cc/tok.fs => fs/cc/tok.fs +3 -3
@@ 34,7 34,7 @@ create symbols2 ," <=>===!=&&||++---><<>>+=-=*=/=%=&=^=|=/**///#["

: isSym2? ( c1 c2 -- f )
  A>r 23 >r symbols2 >A begin ( c1 c2 )
    over Ac@+ = over Ac@+ = and if 2drop r~ r>A 1 exit then
    over Ac@+ = over Ac@+ = and if 2drop rdrop r>A 1 exit then
  next 2drop 0 r>A ;

\ are c1/c2 either << or >>?


@@ 76,10 76,10 @@ create _ 10 c, ," 09AZaz__$$"
      else ( c1 c2 ) to putback 1 ( c1 len ) _writesym then ( tok )
      dup case
        S" /*" of s= drop begin ( )
            nextt? dup not if ( EOF! ) r~ exit then ( tok ) S" */" s= until
            nextt? dup not if ( EOF! ) rdrop exit then ( tok ) S" */" s= until
          nextt? endof
        S" //" of s= drop begin ( )
            cc< dup not if ( EOF! ) r~ exit then LF = until
            cc< dup not if ( EOF! ) rdrop exit then LF = until
          nextt? endof
      endcase
    endof

M fs/cc/tree.fs => fs/cc/tree.fs +3 -3
@@ 27,10 27,10 @@
  then ;
\ Return the next node with the specified id
: nextnodeid ( ref node id -- ref node )
  >r begin nextnode dup not if r~ exit then dup nodeid r@ = until r~ ;
  >r begin nextnode dup not if rdrop exit then dup nodeid r@ = until rdrop ;
\ Return the parent node with the specified id
: parentnodeid ( node id -- node )
  >r begin parentnode dup not if r~ exit then dup nodeid r@ = until r~ ;
  >r begin parentnode dup not if rdrop exit then dup nodeid r@ = until rdrop ;
: lastchild ( node -- child )
  firstchild dup if begin dup nextsibling ?dup not if exit then nip again then ;
: nodedepth ( node -- n ) firstchild ?dup if nodedepth 1+ else 0 then ;


@@ 41,7 41,7 @@
    ?dup while
    r@ over = not while
    swap 1+ swap nextsibling repeat ( R:child idx node )
    drop r~ else abort" child not found" then ;
    drop rdrop else abort" child not found" then ;
: createnode ( id -- node ) here >r , 16 allot0 r> ;
: addnode ( node parent -- )
  2dup swap to parentnode ( node parent )

M fs/fs/fatlo.fs => fs/fs/fatlo.fs +2 -2
@@ 176,7 176,7 @@ create fcursors( FCursorSize FCURSORCNT * allot0

: findfreecursor ( -- fcursor )
  FCURSORCNT >r fcursors( begin ( a )
    dup FCUR_free? if ( found! ) r~ exit then FCursorSize + next
    dup FCUR_free? if ( found! ) rdrop exit then FCursorSize + next
  abort" out of file cursors!" ;

\ read multiple sectors in buf


@@ 205,7 205,7 @@ create fcursors( FCursorSize FCURSORCNT * allot0
: fatreadbuf ( n fcursor -- a? n )
  dup FCUR_free? if 2drop 0 exit then ( n fcursor )
  dup >r FCUR_size r@ FCUR_pos - ( n maxn )
  dup 1- 0< if ( EOF ) 2drop r~ 0 exit then
  dup 1- 0< if ( EOF ) 2drop rdrop 0 exit then
  min ( n ) \ make sure that n doesn't go over size
  r@ FCUR_pos r@ fatseek ( n )
  r@ FCUR_bufpos r@ FCUR_)buf over - ( n a nmax )

M fs/lib/str.fs => fs/lib/str.fs +2 -2
@@ 12,7 12,7 @@ $100 value STR_MAXSZ
: [c]? ( c a u -- i )
  ?dup not if 2drop -1 exit then A>r over >r >r >A ( c )
  begin dup Ac@+ = if leave then next ( c )
  A- Ac@ = if A> r> - ( i ) else r~ -1 then r>A ;
  A- Ac@ = if A> r> - ( i ) else rdrop -1 then r>A ;

\\ append character to end of string
: sappend ( c str -- ) tuck s) c! dup c@ 1+ swap c! ;


@@ 44,7 44,7 @@ $100 value STR_MAXSZ
\ ranges.
: rmatch ( c range -- f )
  A>r >A Ac@+ >> ( len/2 ) >r begin ( c )
    dup Ac@+ Ac@+ ( c c lo hi ) =><= if drop r~ r>A 1 exit then
    dup Ac@+ Ac@+ ( c c lo hi ) =><= if drop rdrop r>A 1 exit then
  next ( c ) drop 0 r>A ;

create _ 2 c, ," 09"

M fs/sys/file.fs => fs/sys/file.fs +1 -1
@@ 10,7 10,7 @@ create _buf $100 allot
  begin ( dirid a )
    c@+ dup '/' = if ( dirid a c )
      drop swap _buf fchild ( a dirid )
      ?dup not if drop 0 r~ r>A exit then swap ( dirid a )
      ?dup not if drop 0 rdrop r>A exit then swap ( dirid a )
      0 _buf c!+ >A
    else ( dirid a c )
      Ac!+ _buf c@ 1+ _buf c! then

M fs/xcomp/bootlo.fs => fs/xcomp/bootlo.fs +3 -3
@@ 15,7 15,7 @@
: again compile (br) , ; immediate
: until compile (?br) , ; immediate
: next compile (next) , ; immediate
: leave r> r~ 1 >r >r ;
: leave r> rdrop 1 >r >r ;
: = - not ;
: \ begin in< $0a = until ; immediate
\ hello, this is a comment!


@@ 75,14 75,14 @@
\ has to be a single word following "of".
\ case x of = ... endof y of < ... endof ... endcase
\ is syntactic sugar for:
\ >r x r@ = if ... else y r@ < if ... else ... then then r~
\ >r x r@ = if ... else y r@ < if ... else ... then then rdrop
\ NOTE: if you want to access your reference value in the final "else", you
\ need to use "r@".
: case ( -- then-stopgap ) 0 compile >r ; immediate
: of ( -- jump-addr ) compile r@ ' execute, [compile] if ; immediate
alias else endof immediate
: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
  ?dup if begin [compile] then ?dup not until then compile r~ ; immediate
  ?dup if begin [compile] then ?dup not until then compile rdrop ; immediate

\ Emitting
$20 const SPC $0d const CR $0a const LF $08 const BS

M fs/xcomp/i386.fs => fs/xcomp/i386.fs +1 -1
@@ 236,7 236,7 @@ xcode r@
  AX pspush,
  ret,

xcode r~
xcode rdrop
  ax pop,
  sp CELLSZ i) add,
  ax jmp,

M posix/vm.c => posix/vm.c +1 -1
@@ 843,7 843,7 @@ static char *opnames[OPCNT] = {
    "execute", "(cell)", "(val)", "(alias)", "(does)", "(s)", "(br)", "(?br)",
    "(next)", NULL, NULL, "boot<", "(emit)", "stderr", "key", "drop",
    "dup", "?dup", "swap", "over", "rot", "rot>", "nip", "tuck",
    "r>", ">r", "r@", "r~", "scnt", "rcnt", ">A", "A>",
    "r>", ">r", "r@", "rdrop", "scnt", "rcnt", ">A", "A>",
    "Ac@", "Ac!", "A+", "A-", "A>r", "r>A", "[to]", "to?",
    "1+", "1-", "c@", "c!", "c,", "w@", "w!", "@",
    "!", "+!", ",", "+", "-", "*", "/mod", "and",