commit f440785490b4da379d7d4ea3b6bf704834d64d06
parent 1a8c9e834a6a38c3c79fd8e6124e550702a0b764
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 15 May 2023 21:01:13 -0400
Introduce new ":[methods]" pattern in structures
See doc/struct. This new pattern doesn't improve code density (the opposite in
fact), but it allows to avoid painful code repetition, with the worst offender
being the IO struct. Whenever the structure of those structs that are widely
extended would change, one would have to go modify all extending structs.
Not anymore.
Diffstat:
18 files changed, 235 insertions(+), 133 deletions(-)
diff --git a/fs/doc/dict.txt b/fs/doc/dict.txt
@@ -154,11 +154,14 @@ allot0 u -- Allot u and fill this space with zeroes.
move src dst u -- Copy u bytes from address src to address dst, moving
upwards.
move, src u -- Copy u bytes to "here" and increase "here" by u.
+-move, src u -- Rewind "here" by u, then call "move,".
fill a u c -- Fill range [a, a+u] with byte c.
align4 n -- Allot 0, 1, 2 or 3 bytes so that "here+n" is divisible
by 4.
nc, n -- Parse n numbers from input stream and write them as
8-bit values.
+nabort, n -- Write address of word "abort" n times. Used for method
+ placeholders.
[c]? c a u -- i Search for character c in range [a, a+u] and yield its
index or -1 if not found.
@@ -268,6 +271,7 @@ find name 'dict -- word-or-0
match was found.
' "x" -- w Find x in system dictionary and error out if not found.
['] "x" -- *I* Find x and compile its address as a literal.
+'" "x" -- *I* Compile x as a string followed by a call to '.
w>e w -- e Yield an entry (linked list pointer) from a word reference.
e>w e -- w Yield a word reference (executable) from an entry.
entry 'dict s --
diff --git a/fs/doc/struct.txt b/fs/doc/struct.txt
@@ -163,11 +163,97 @@ Warning: do not augment a struct with new fields if it has already been extended
by another struct because this will generate slot conflicts. You can augment a
struct that has been extended, that will work, but only with non-field words.
-## Name conventions
+## Structure conventions
+
+What is described above is the structure mechanism. That's how it works. If you
+look at how structures are used in Dusk OS, you'll see some patterns emerge that
+aren't described above. Those are conventions. You don't have to follow them in
+your own code, but if you want to interact with Dusk structures, you need to
+know about them.
A structure begins with an uppercase letter and a word in a namespace that is
intended to be called from the outside (so, not only methods) begin with a ":".
+A structure "constructor" has the name ":new". Is is expected to consume
+initialization arguments from PS and yield a single element: the address of the
+created structure.
+
+Structure allocation is often made directly to "here" (with dynamic allocation
+details left to the caller), but not always.
+
+When a structure extends another, it's common practive for the extending struct
+to call its base struct's ":new" method and add to it.
+
+Structure methods initialization is a bit tricky. The whole point of those
+methods is to allow a structure that extends another structure to override them.
+For this to be done harmoniously, the "extender" struct, at *compile* time,
+needs to make a list of those methods it want to write, and overwrite the
+methods that were written by the base struct. For simplicity, this is often done
+using a combination of "S[" and "-move,". Example:
+
+ struct[ MyAbstract
+ smethod :foo
+ : :new here ['] abort , ;
+ ]struct
+ extends MyAbstract struct[ MyImpl
+ sfield myfield
+ : impl drop 42 ;
+ : :new MyAbstract :new S[ ' impl , ]S c@+ -move, 54 ( myfield ) , ;
+ ]struct
+ MyImpl :new dup :foo . \ prints 42
+ myfield . \ prints 54
+
+For this to work, methods need to be the last fields of the struct (but
+"extenders" can add other fields on top of it), which is another convention that
+Dusk OS follows.
+
+Because the pattern above requires every struct "extender" to repeat the name
+of the methods and because this is tedious and verbose, another convention
+emerges from that: Method implementations have the name of the method, minus the
+":" prefix, and base structs have a ":[methods]" word that dynamically look for
+those names and write them. Then, "extenders" call this method at compile time
+and write this string down in their ":new" implementation. This results in code
+that looks like this:
+
+ struct[ MyAbstract
+ smethod :foo
+ : :new here ['] abort , ;
+ : :[methods] '" foo" , ;
+ ]struct
+ extends MyAbstract struct[ MyImpl
+ sfield myfield
+ : foo drop 42 ;
+ : :new MyAbstract :new S[ :[methods] , ]S c@+ -move, 54 ( myfield ) , ;
+ ]struct
+
+With one "extender", the gain is slim (null in fact), but as extenders multiply,
+this patterns allows us to minimize code duplication and make changes in base
+structures much easier.
+
+Note that this pattern only works for direct extension overrides (the most
+frequent case). If a struct extender needs to override a method from a structure
+more than 1 level deep in the hierarchy, the pattern is a bit more complex and
+involves base structures creating a "METHSZ" constant. Here's an example:
+
+ struct[ A
+ sfield a
+ SZ &+ :methods(
+ smethod :foo
+ : :new here 0 ( a ) , ['] abort , ;
+ : :[methods] '" foo" , ;
+ ]struct
+ extends A struct[ B
+ sfield b
+ : :new A :new 0 ( b ) , ;
+ ]struct
+ extends B struct[ C
+ sfield c
+ : :new B :new 0 ( c ) ,
+ S[ A :[methods] ]S c@+ dip over A :methods( | move ;
+ ]struct
+
+So, a bit more verbose than the direct variant, but it happens much less often.
+
## API
struct[ "name" -- Create a struct named "name" and enter its definition
diff --git a/fs/drv/fbgrid/fbgrid.fs b/fs/drv/fbgrid/fbgrid.fs
@@ -73,10 +73,7 @@ extends Grid struct[ FbGrid
repeat rdrop rdrop rdrop ;
: :new ( -- grid )
screen width 8 / screen height 8 / Grid :new
- ['] cell! over ['] :cell! sfield!
- ['] cursor! over ['] :cursor! sfield!
- ['] newln over ['] :newln sfield!
- ['] highlight over ['] :highlight sfield! ;
+ S[ :[methods] ]S c@+ -move, ;
]struct
: fbgrid$ screen :activate FbGrid :new ['] grid rebind
diff --git a/fs/drv/pc/com.fs b/fs/drv/pc/com.fs
@@ -19,10 +19,9 @@ $3f8 const COMPORT
extends IO struct[ COM1
create _buf 0 c,
- : _readbuf ( n self -- a? read-n )
+ : readbuf ( n self -- a? read-n )
2drop com>? if _buf tuck c! 1 else 0 then ;
- : _writebuf ( a n self -- written-n )
- 2drop c@ >com 1 ;
- : :new here 0 , ['] _readbuf , ['] _writebuf , ['] drop dup , , ;
+ : writebuf ( a n self -- written-n ) 2drop c@ >com 1 ;
+ : :new IO :new S[ :[methods] ]S c@+ -move, ;
]struct
COM1 :new structbind COM1 com1
diff --git a/fs/drv/pc/vesa.fs b/fs/drv/pc/vesa.fs
@@ -102,7 +102,7 @@ $111 value vesamode
extends Screen struct[ VESA2Screen \ for VBE2
\ Here, we deal only with linear modes
- : _activate ( self -- )
+ : activate ( self -- )
vesamode _modeinfo dup VBEModeInfo :linear? _assert ( mode )
_curmode :self VBEModeInfo SZ move
0 vesamode $4000 or $4f02 int10h ( self bx ax )
@@ -112,12 +112,10 @@ extends Screen struct[ VESA2Screen \ for VBE2
_curmode pitch over to pitch
_curmode framebuffer swap to buffer ;
- : _deactivate ( self -- ) 0 to buffer vgatext! ;
+ : deactivate ( self -- ) 0 to buffer vgatext! ;
: :new ( -- screen )
- 0 0 COLOR_RGB565 Screen :new ( screen )
- ['] _activate over ['] :activate sfield!
- ['] _deactivate over ['] :deactivate sfield! ;
+ 0 0 COLOR_RGB565 Screen :new ( screen ) S[ :[methods] ]S c@+ -move, ;
]struct
$a0000 const VESABANK \ for nonlinear modes, the address of the 64K bank
@@ -130,7 +128,7 @@ extends Screen struct[ VESA1Screen \ for VBE1.2
0 value bank \ currently activated bank
1 value bankmult
- : _activate ( self -- )
+ : activate ( self -- )
vesamode _modeinfo dup VBEModeInfo :linear? not _assert
dup VBEModeInfo winfuncptr _assert ( mode )
_curmode :self VBEModeInfo SZ move
@@ -142,19 +140,17 @@ extends Screen struct[ VESA1Screen \ for VBE1.2
$40 _curmode granularity / to bankmult
VESABANK swap to buffer ;
- : _deactivate ( self -- ) 0 to buffer vgatext! ;
+ : deactivate ( self -- ) 0 to buffer vgatext! ;
: _bank! ( n -- )
dup bankmult * 0 $4f05 int10h 2drop ( dup 1 $4f05 int10h 2drop ) to bank ;
: _?bank! ( off -- ) 16 rshift dup bank = if drop else _bank! then ;
- : _xyoffbank ( x y self -- n ) _xyoff dup _?bank! $ffff and ;
+ : xyoff ( x y self -- n ) Plane xyoff dup _?bank! $ffff and ;
: :new ( -- screen )
0 0 COLOR_RGB565 Screen :new ( screen )
- 0 ( bank ) ,
- ['] _activate over ['] :activate sfield!
- ['] _deactivate over ['] :deactivate sfield!
- ['] _xyoffbank over ['] :xyoff sfield! ;
+ S[ :[methods] ]S c@+ -move, 0 ( bank ) ,
+ S[ Plane :[methods] ]S c@+ dip over Plane :methods( | move ;
]struct
diff --git a/fs/drv/pc/vga.fs b/fs/drv/pc/vga.fs
@@ -19,12 +19,7 @@ extends Grid struct[ VgaGrid
create _tbl $f , $7f ,
: highlight ( f pos -- ) << _mem( + 1+ swap bool CELLSZ * _tbl + @ swap c! ;
- : :new ( -- grid )
- _COLS _LINES Grid :new
- ['] cell! over ['] :cell! sfield!
- ['] cursor! over ['] :cursor! sfield!
- ['] newln over ['] :newln sfield!
- ['] highlight over ['] :highlight sfield! ;
+ : :new ( -- grid ) _COLS _LINES Grid :new S[ :[methods] ]S c@+ -move, ;
]struct
\ Set video mode to text mode, 80x25
diff --git a/fs/fs/fat.fs b/fs/fs/fat.fs
@@ -113,12 +113,12 @@ $e5 const DIRFREE
r> findfreedirentry dup DirEntry SZ 0 fill ( direntry )
fnbuf( over DirEntry NAMESZ move ( direntry ) ;
-:realias :newfile ( dirid name self -- id ) >r
+:realias newfile ( dirid name self -- id ) >r
r@ _newentry ( dirent ) r@ writecursector r> :getid ;
: _makedir ( dirent -- dirent ) $10 over to DirEntry attr ;
-:realias :newdir ( dirid name self -- id )
+:realias newdir ( dirid name self -- id )
r! allocatecluster0 >r ( dirid name ) \ V1=self V2=cluster
V1 _newentry ( dirent ) _makedir ( dirent )
V2 over to DirEntry cluster V1 writecursector ( dirent )
@@ -142,10 +142,10 @@ $e5 const DIRFREE
swap r@ :FirstSectorOfCluster ( dst sec )
swap r@ secpercluster swap r> writesectors ;
-:realias :info ( id self -- info ) FATInfo :read ;
+:realias info ( id self -- info ) FATInfo :read ;
\ TODO: deallocate the chain before clearing the entry
-:realias :remove ( id self -- )
+:realias remove ( id self -- )
tuck :getdirentry ( dirent ) DIRFREE swap c! writecursector ;
\ Read next sector if a sequential read is available, else return false.
@@ -159,7 +159,7 @@ $e5 const DIRFREE
dup DirEntry :lastentry? if drop 0 else
dup DirEntry :iterable? not if V1 _next then then ( entry ) rdrop ;
-:realias :iter ( dirid previd self -- id-or-0 ) >r >r \ V1=self V2=previd
+:realias iter ( dirid previd self -- id-or-0 ) >r >r \ V1=self V2=previd
V1 :getdirentry V1 :readdir V1 :dirwin :buf( DirEntry SZ - V2 if begin ( entry )
V1 _next dup while dup V1 :getid V2 <> while repeat then then ( entry-or-0 )
dup if V1 _next dup if V1 :getid then then 2rdrop ;
@@ -204,7 +204,7 @@ create _FATTemplate
]struct
struct+[ FATFile
- : _flush ( hdl -- )
+ :realias flush ( hdl -- )
r! :dirty? not if rdrop exit then ( )
\ save buffer
r@ cluster r@ :buf( r@ :fat writecluster ( )
@@ -213,7 +213,6 @@ struct+[ FATFile
r@ :fat writecursector
\ undirty the cursor
r@ flags $fffffffd and to r> flags ;
- current ' :flush realias
\ grow fcursor to newsz, if needed
: _grow ( newsz self -- )
@@ -227,7 +226,7 @@ struct+[ FATFile
V1 size V1 :fat :ClusterSize / ?dup if
for ( cluster ) V1 :fat FAT@+ next then ( cluster ) drop rdrop ;
- : _writebuf ( buf n self -- n )
+ :realias writebuf ( buf n self -- n )
dup :free? if 2drop drop 0 exit then ( buf n self )
r! pos over + r@ _grow ( src n )
\ TODO: this seek below doesn't seem right. The buffer should be at all times
@@ -237,13 +236,11 @@ struct+[ FATFile
r@ :)buf r@ :ptr - ( src n nmax )
min ( src n ) r@ :ptr swap ( src dst n )
r! move r> ( n ) r@ pos over + r> :seek ;
- current ' :writebuf realias
\ TODO: deallocate truncated FATs if appropriate
- : _truncate ( self -- )
+ :realias truncate ( self -- )
dup pos ( self pos )
2dup swap to size ( self pos )
over :dirent to DirEntry filesize ( self )
:fat writecursector ;
- current ' :truncate realias
]struct
diff --git a/fs/fs/fatlo.fs b/fs/fs/fatlo.fs
@@ -137,7 +137,7 @@ $18 const HDRSZ
swap r@ :FirstSectorOfCluster ( dst sec )
swap r@ secpercluster swap r> :readsectors ;
-: :child ( dirid name self -- id-or-0 ) >r
+: child ( dirid name self -- id-or-0 ) >r
fnbuf! r@ :getdirentry r@ :readdir r@ :findindir
dup if r@ :getid then rdrop ;
]struct
@@ -162,15 +162,15 @@ extends File struct[ FATFile
: :dirent ( self -- dirent ) bi entryoff | :fat :getdirentry ;
: :cluster0 ( self -- cl ) :dirent DirEntry cluster ;
- alias abort :writebuf
- alias drop :flush
- alias abort :truncate
+ alias abort writebuf
+ alias drop flush
+ alias abort truncate
: _poscluster ( self -- idx ) bi pos | bufsz / ;
: _inbounds? ( self -- f ) bi _poscluster | clusteridx = ;
\ set self to pos. If new pos crosses cluster boundaries compared to current
\ pos, flush current buffer and read a new sector from disk.
- : :seek ( pos self -- )
+ : seek ( pos self -- )
dup :free? if 2drop exit then >r ( pos ) \ V1=self
dup 0< if abort" can't seek to negative pos" then
V1 to pos V1 _inbounds? not if
@@ -178,7 +178,7 @@ extends File struct[ FATFile
V1 :cluster0 ( idx cl ) swap for ( cl ) V1 :fat :FAT@ next ( cl )
dup V1 :buf( V1 :fat :readcluster ( cl ) V1 to cluster then rdrop ;
- : :readbuf ( n self -- a? n )
+ : readbuf ( n self -- a? n )
dup :free? if 2drop 0 exit then ( n self )
bi+ size | pos - ( n self maxn )
dup 1- 0< if ( EOF ) 2drop drop 0 exit then swap >r ( n maxn ) \ V1=self
@@ -187,19 +187,19 @@ extends File struct[ FATFile
r@ :ptr r@ :)buf over - ( n a nmax )
rot min ( a n ) dup r> to+ pos ( a n ) ;
- : :close ( self -- ) dup :flush :release ;
+ : close ( self -- ) dup :flush :release ;
: :open ( direntry self -- )
r! :hold dup V1 :fat :getid ( dirent entryoff ) \ V1=self
r@ to entryoff DirEntry filesize r@ to size ( )
0 to r@ pos -1 to r> clusteridx ;
: :new ( fat -- hdl )
- 0 align4 dup to' FAT lastcursor lladd ( fat newll ) drop here >r
- 0 ( putback ) , ['] :readbuf , ['] :writebuf , ['] :flush , ['] :close ,
- 0 ( pos ) , 0 ( size ) , 0 ( bufptr ) , dup FAT :ClusterSize ( bufsz ) ,
- ['] :seek , ['] :truncate , ( fat ) , 0 ( flags ) , 0 ( cluster ) ,
+ 0 align4 dup to' FAT lastcursor lladd drop ( fat )
+ File :new >r S[ :[methods] ]S c@+ -move, ( fat ) \ V1=hdl
+ S[ IO :[methods] ]S c@+ r@ IO :methods( swap move
+ dup ( fat ) , 0 ( flags ) , 0 ( cluster ) ,
-1 ( clusteridx ) , 0 ( entryoff ) ,
- here r@ to bufptr r@ bufsz allot r> ;
+ here r@ to bufptr FAT :ClusterSize dup allot r@ to bufsz r> ;
]struct
struct+[ FAT
@@ -208,21 +208,20 @@ struct+[ FAT
?dup while dup CELLSZ + FATFile :free? not while llnext repeat
nip CELLSZ + else FATFile :new then ;
- : :open ( id self -- hdl )
+ : open ( id self -- hdl )
tuck :getdirentry swap :findfreecursor ( dirent hdl )
tuck FATFile :open ;
- alias abort :info
- alias abort :iter
- alias abort :newfile
- alias abort :newdir
- alias abort :remove
+ alias abort info
+ alias abort iter
+ alias abort newfile
+ alias abort newdir
+ alias abort remove
: :mountvolume ( drv -- fs )
dup SectorWindow :new over SectorWindow :new rot
- here >r ( fatwin dirwin rot ) \ V1=fs
- dup , 0 ( flags ) , ['] :child , ['] :info , ['] :open ,
- ['] :iter , ['] :newfile , ['] :newdir , ['] :remove ,
+ dup Filesystem :new >r ( fatwin dirwin drv ) \ V1=fs
+ S[ :[methods] ]S c@+ -move,
0 ( bufcluster ) , 0 ( lastcursor ) , rot ( fatwin ) , swap ( dirwin ) ,
\ At this point, "here" points to the FAT-header-to-be. Read the first sector
\ directly in "here": we'll have the header right here!
diff --git a/fs/gr/plane.fs b/fs/gr/plane.fs
@@ -13,11 +13,12 @@ extends Rect struct[ Plane
sfield ty
sfield color
sfield buffer
+ SZ &+ :methods(
smethod :xyoff ( x y self -- n )
: _colorbytes ( id -- nbytes ) colorbpp >> >> >> ;
- : _xyoff ( x y self -- n )
+ : xyoff ( x y self -- n )
tuck pitch * rot> encoding _colorbytes * + ;
: _addr ( self -- a )
@@ -26,7 +27,8 @@ extends Rect struct[ Plane
: :new ( width height encoding -- plane )
>r >r >r 0 0 r> r> Rect :new ( rect )
r> ( encoding ) dup , _colorbytes over Rect width * ( pitch ) ,
- 0 ( tx ) , 0 ( ty ) , 0 ( color ) , 0 ( buffer ) , ['] _xyoff , ;
+ 0 ( tx ) , 0 ( ty ) , 0 ( color ) , 0 ( buffer ) , ['] xyoff , ;
+ : :[methods] '" xyoff" , ;
: :allotbuf ( self -- ) >r \ V1=self
here r@ pitch r@ height * allot r> to buffer ;
diff --git a/fs/lib/file.fs b/fs/lib/file.fs
@@ -2,36 +2,37 @@
extends File struct[ MemFile
: _maxn ( n hdl -- real-n ) >r V1 pos + V1 size min r> pos - ;
- : _readbuf ( n hdl -- a? read-n )
+ : readbuf ( n hdl -- a? read-n )
>r V1 _maxn ( read-n ) dup if V1 :ptr swap dup V1 to+ pos then rdrop ;
- : _writebuf ( a n hdl -- written-n )
+ : writebuf ( a n hdl -- written-n )
>r V1 _maxn ( a write-n ) dup if ( a write-n )
tuck V1 :ptr swap ( write-n a dst n ) move ( write-n ) dup V1 to+ pos
else nip then rdrop ;
- : _seek ( pos hdl -- ) to pos ;
- : :new ( sz -- hdl ) here swap ( hdl sz )
- 0 ( putback ) , ['] _readbuf , ['] _writebuf , ['] drop , ['] drop ,
- 0 ( pos ) , dup ( size ) , over SZ + ( bufptr ) , dup ( bufsz ) ,
- ['] _seek , ( sz ) allot ;
+ : seek ( pos hdl -- ) to pos ;
+ alias drop truncate
+ : :new ( sz -- hdl )
+ File :new >r S[ :[methods] ]S c@+ -move, ( sz ) \ V1=hdl
+ S[ IO :[methods] ]S c@+ r@ IO :methods( swap move
+ dup to r@ size dup to r@ bufsz here to r@ bufptr allot r> ;
]struct
extends File struct[ DriveFile
sfield secwin
: :secwin [compile] secwin [compile] SectorWindow ; immediate
- : _flush :secwin :flush ;
- : _seek ( pos self -- ) to pos ;
- : _readbuf ( n self -- a? read-n )
+ : flush :secwin :flush ;
+ : seek ( pos self -- ) to pos ;
+ : readbuf ( n self -- a? read-n )
over if
swap >r bi+ pos | :secwin :seek ( self a? n ) r> min
dup if rot over swap to+ pos then
else drop then ;
- : _writebuf ( a n self -- written-n )
- r! _readbuf ( src dst? n ) dup if
+ : writebuf ( a n self -- written-n )
+ r! readbuf ( src dst? n ) dup if
r! move r> r> :secwin :dirty! else nip rdrop then ;
+ alias drop truncate
: :new ( drv -- hdl )
- SectorWindow :new here ( secwin hdl )
- 0 ( putback ) , ['] _readbuf , ['] _writebuf , ['] _flush , ['] drop ,
- 0 ( pos ) , -1 ( size ) , over SectorWindow :buf( ( bufptr ) ,
- over SectorWindow :drv secsz ( bufsz ) , ['] _seek , ['] drop ( truncate ) ,
- swap ( secwin ) , dup 0 -1 rot :secwin :move ;
+ SectorWindow :new File :new >r S[ :[methods] ]S c@+ -move, ( secwin ) ,
+ S[ IO :[methods] ]S c@+ r@ IO :methods( swap move
+ -1 to r@ size r@ :secwin :buf( to r@ bufptr
+ r@ :secwin :drv secsz to r@ bufsz 0 -1 r@ :secwin :move r> ;
]struct
diff --git a/fs/sys/grid.fs b/fs/sys/grid.fs
@@ -39,9 +39,11 @@ extends ByteWriter struct[ Grid
: :spitoff ( self -- )
['] _emit swap ['] :writebyte sfield! ;
+ alias 2drop highlight
+ : :[methods] '" cell!" , '" cursor!" , '" newln" , '" highlight" , ;
: :new ( cols lines -- grid )
['] _emit ByteWriter :new rot ( cols ) , swap ( lines ) , 0 , 0 ,
- ['] abort , ['] abort , ['] abort , ['] 2drop , ;
+ 4 nabort, ;
: _dbgnum! ( n pos self -- )
tuck :spiton tuck :.x :spitoff ;
diff --git a/fs/sys/io.fs b/fs/sys/io.fs
@@ -48,14 +48,14 @@ extends IO struct[ SumIO
sfield fn
sfield res
- : _writebuf ( a n hdl -- written-n )
+ alias _ioerr readbuf
+ : writebuf ( a n hdl -- written-n )
dup >r fn >r swap >r dup >r V1 res for ( n r ) \ V1=hdl V2=fn V3=a
8b to@+ V3 V2 execute next ( n r )
V1 to res 2rdrop 2rdrop ( written-n ) ;
\ fn sig: ( sum c -- sum )
- : :new ( 'fn -- hdl ) here swap ( hdl 'fn )
- 0 ( putback ) , ['] _ioerr , ['] _writebuf , ['] drop , ['] drop ,
- ( 'fn ) , 0 , ;
+ : :new ( 'fn -- hdl )
+ IO :new S[ :[methods] ]S c@+ -move, swap ( 'fn ) , 0 , ;
]struct
extends IO struct[ MemIO
@@ -64,9 +64,9 @@ extends IO struct[ MemIO
sfield ptr
: _bounds ( n hdl -- n ) dup )buf swap ptr - min ;
- : _readbuf ( n hdl -- a? read-n ) >r \ V1=self
+ : readbuf ( n hdl -- a? read-n ) >r \ V1=self
V1 _bounds dup if r@ ptr swap dup to+ r> ptr else rdrop then ;
- : _writebuf ( a n hdl -- written-n ) >r \ V1=self
+ : writebuf ( a n hdl -- written-n ) >r \ V1=self
V1 _bounds dup if ( a n )
dup >r V1 ptr ( src n dst ) swap move \ V2=n
r> dup r> ( n n hdl ) to+ ptr ( written-n )
@@ -75,17 +75,17 @@ extends IO struct[ MemIO
: :eof? dup )buf swap ptr = ;
: :rewind ( hdl -- ) dup buf( swap to ptr ;
: :new ( a u -- hdl )
- here >r 0 ( putback ) , ['] _readbuf , ['] _writebuf , ['] drop , ['] drop ,
+ IO :new >r S[ :[methods] ]S c@+ -move,
over , over + , , r> ;
]struct
extends IO struct[ ByteWriter
smethod :writebyte ( c self -- )
- : _writebuf ( a n self -- written-n ) >r dup >r \ V1=self V2=n
+ alias _ioerr readbuf
+ : writebuf ( a n self -- written-n ) >r r! \ V1=self V2=n
for ( a ) c@+ V1 :writebyte next drop r> rdrop ;
: :new ( writebyte -- writer )
- here 0 ( putback ) , ['] _ioerr , ['] _writebuf , ['] drop , ['] drop ,
- swap ( writebyte ) , ;
+ IO :new S[ :[methods] ]S c@+ -move, swap ( writebyte ) , ;
]struct
diff --git a/fs/sys/rdln.fs b/fs/sys/rdln.fs
@@ -23,10 +23,10 @@ extends MemIO struct[ Rdln
begin key V1 :lntype until
V1 ptr V1 to )buf V1 :rewind r> )buf 1- c@ ESC <> ;
: _readbuf2 ( n hdl -- a? read-n )
- dup :eof? if begin ." ok\n" dup :typeline until nl> then _readbuf ;
+ dup :eof? if begin ." ok\n" dup :typeline until nl> then readbuf ;
: :reset ['] _readbuf2 over ['] :readbuf sfield! dup )buf swap to ptr ;
: :interpret
- ['] _readbuf over ['] :readbuf sfield!
+ ['] readbuf over ['] :readbuf sfield!
MemIO :interpret :reset ;
: :new MemIO :new dup :reset ;
]struct
diff --git a/fs/sys/screen.fs b/fs/sys/screen.fs
@@ -6,11 +6,10 @@ extends Plane struct[ Screen
smethod :deactivate ( self -- )
smethod :activated? ( self -- f )
- : _activated? ( self -- f ) buffer bool ;
-
+ : activated? ( self -- f ) buffer bool ;
: :new ( width height encoding -- screen )
- Plane :new ( screen )
- ['] abort , ['] abort , ['] _activated? , ;
+ Plane :new ( screen ) S[ :[methods] ]S c@+ -move, 3 nabort, ;
+ : :[methods] '" activate" , '" deactivate" , '" activated?" , ;
]struct
0 structbind Screen screen
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -158,4 +158,15 @@ extends Foo struct[ Bazooka
create data3 7 , 9 c, ' mybleh , 999 ,
data3 Bazooka bling 999 #eq
data3 Bazooka baz 9 #eq
+
+\ Test abstract method override mechanism
+struct[ MyAbstract
+ smethod :foo
+ : :[new] '" foo" , ;
+]struct
+extends MyAbstract struct[ MyImpl
+ : foo drop 42 ;
+ : :new here S[ MyAbstract :[new] ]S c@+ move, ;
+]struct
+MyImpl :new MyAbstract :foo 42 #eq
testend
diff --git a/fs/text/ed.fs b/fs/text/ed.fs
@@ -84,7 +84,7 @@ extends IO struct[ Edbuf
: :lastline? bi :lpos | :linecnt 1- = ;
: _eof? ( self -- f ) bi :lastline? | _eol? and ;
create _lf LF c,
- : _readbuf ( n self -- a? read-n ) >r ( n ) \ V1=self
+ : readbuf ( n self -- a? read-n ) >r ( n ) \ V1=self
r@ _eof? if rdrop drop 0 exit then
r@ _eol? if drop 1 r@ :godown 0 r> _cpos! _lf 1 exit then
r@ :sel Line cnt r@ :cpos - ( n1 n2 )
@@ -101,7 +101,7 @@ extends IO struct[ Edbuf
tuck V1 :cpos V2 Line :insert ( u )
rdrop r> to+ pos ;
- : _writebuf ( a n self -- written-n ) >r \ V1=self
+ : writebuf ( a n self -- written-n ) >r \ V1=self
2dup LF rot> [c]? ( a u idx ) dup 0< if
drop tuck r> _writeline ( written-n )
else ( a u idx )
@@ -128,11 +128,11 @@ extends IO struct[ Edbuf
lpos V1 :lpos V1 :sel Line cnt bool + ( linehi linelo )
tuck - 1+ swap V1 lines Array :delete V1 _ensureline then rdrop ;
+ alias :empty close
: :new ( -- edbuf )
- Arena :new Line SZ $200 Array :new here ( arena lines edbuf ) >r
- 0 ( putback ) , ['] _readbuf , ['] _writebuf , ['] drop , ['] :empty ,
- swap ( arena ) , ( lines ) , 0 ( pos ) ,
- r> dup :empty ;
+ Arena :new Line SZ $200 Array :new
+ IO :new S[ :[methods] ]S c@+ -move, ( arena lines edbuf )
+ rot ( arena ) , swap ( lines ) , 0 ( pos ) , dup :empty ;
: :goleft ( n self -- ) dup :cpos rot - max0 swap _cpos! ;
: :goright ( n self -- ) dup :cpos rot + over _cpos! _cbounds ;
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -253,23 +253,25 @@ alias drop emit
: nl> LF emit ; : spc> SPC emit ;
:realias rtype ( a u ) for c@+ emit next drop ;
: stype ( str -- ) c@+ rtype ;
-create _escapes 'n' c, 'r' c, '0' c,
-create _repl LF c, CR c, 0 c,
+create _escapes 3 nc, 'n' 'r' '0'
+create _repl 3 nc, LF CR 0
: "< ( -- c )
in< dup '"' = if drop -1 else dup '\' = if
drop in< dup _escapes 3 [c]? dup 0>= if nip _repl + c@ else drop then
then then ;
: ," begin "< dup -1 <> while c, repeat drop ;
code (s) r@ W>A, W) 8b) @, 1 W+n, RSP) +, rdrop W<>A, branchA,
-: _S compiling if compile (s) else here then here 1 allot here ;
-: S[ _S [compile] [ ; immediate
-: ]S ( str -- ) here -^ ( 'len len ) swap c! ;
-: S" _S ," [compile] ]S ; immediate
+: _S[ compiling if compile (s) else here then here 1 allot here ;
+: S[ _S[ [compile] [ ; immediate
+: _]S ( str -- ) here -^ ( 'len len ) swap c! ;
+: ]S _]S ] ;
+: S" _S[ ," _]S ; immediate
: ."
compiling if [compile] S" compile stype else
begin "< dup 0>= while emit repeat drop then ; immediate
: abort" [compile] ." compile abort ; immediate
: word" [compile] S" NEXTWORD litn compile ! ; immediate
+: '" [compile] word" compile ' ; immediate
code []= ( a1 a2 u -- f )
W=0>Z, 0 Z) branchC, PSP) @!, W>A, begin \ P+4=a1 P+0=u A=a2
@@ -289,6 +291,7 @@ code move ( src dst u -- )
8 ps+, drop, exit,
: move, ( src u -- ) here swap dup allot move ;
+: -move, ( src u -- ) here over - swap move ;
\ Structures
0 value _extends
@@ -321,7 +324,7 @@ code move ( src dst u -- )
else
word" :self" code exit, \ :self is our root
sysdict @ to _curroot then
- word" SZ" code _cur e>w structsz' litn compile @ exit,
+ word" SZ" code _cur e>w structsz' litn W) @, exit,
does> ( 'struct )
_structfind
dup 1- c@ $80 and not compiling and \ compile only if not immediate
@@ -361,11 +364,12 @@ create _ 0 , EMETA_8B , EMETA_16B ,
does> CELLSZ + @ over + @ execute ;
: ssmethod doer CELLSZ STRUCTFIELD_STATICMETHOD _sfield
does> CELLSZ + @ swap + @ execute ;
+: nabort, ( n -- ) ['] abort swap for dup , next drop ;
\ 4b link to struct
\ 4b link to data
: structbind ( 'data -- ) ' doer , , immediate does> ( 'bind -- *to* )
- @+ swap compiling if litn compile @ else @ swap then execute ;
+ @+ swap compiling if dup, m) @, else @ swap then execute ;
: rebind ( 'data 'bind -- ) does' CELLSZ + ! ;
struct[ Drive
@@ -373,10 +377,13 @@ struct[ Drive
sfield seccnt
smethod :sec@ ( sec dst drv -- )
smethod :sec! ( sec src drv -- )
+ : :new ( secsz seccnt -- drv ) here rot , swap , ;
+ : :[methods] '" sec@" , '" sec!" , ;
]struct
struct[ IO
sfield putback
+ SZ &+ :methods(
smethod :readbuf ( n hdl -- a? read-n )
smethod :writebuf ( a n hdl -- written-n )
smethod :flush ( hdl -- )
@@ -384,23 +391,25 @@ struct[ IO
: :getc ( hdl -- c )
dup putback ?dup if ( hdl c ) 0 rot to putback else ( hdl )
1 swap :readbuf if c@ else -1 ( EOF ) then then ;
+ : :new here 0 ( putback ) , 4 nabort, ;
+ alias drop close
+ alias drop flush
+ : :[methods] '" readbuf" , '" writebuf" , '" flush" , '" close" , ;
]struct
extends IO struct[ Pipe
sfield readio
sfield writeio
- : _readbuf readio :readbuf ;
- : _writebuf writeio :writebuf ;
- : _flush writeio :flush ;
+ : readbuf readio :readbuf ;
+ : writebuf writeio :writebuf ;
+ : flush writeio :flush ;
: :new ( readio writeio -- pipe )
- here 0 , ['] _readbuf , ['] _writebuf , ['] _flush , ['] drop ,
- rot ( readio ) , swap ( writeio ) , ;
+ IO :new S[ :[methods] ]S c@+ -move, rot ( readio ) , swap ( writeio ) , ;
: _chain! ( w1 'w2 -- ) dup @ rot swap chain swap ! ;
: :addrfilter ( w self -- ) CELLSZ + _chain! ;
: :addwfilter ( w self -- ) CELLSZ << + _chain! ;
- : :filters$ ( self -- )
- ['] _readbuf swap CELLSZ + !+ ['] _writebuf swap ! ;
+ : :filters$ ( self -- ) ['] readbuf swap CELLSZ + !+ ['] writebuf swap ! ;
]struct
: _ioerr abort" Invalid I/O" ;
@@ -426,7 +435,7 @@ struct+[ IO
struct[ Filesystem
sfield drv
- sfield flags \ b0=writeable
+ sfield flags
smethod :child
smethod :info
smethod :open
@@ -436,12 +445,16 @@ struct[ Filesystem
smethod :remove
: :drv [compile] drv [compile] Drive ; immediate
: :writeable? flags 1 and ;
+ : :new ( drv -- fs ) here swap ( drv ) , 0 ( flags ) , 7 nabort, ;
+ : :[methods]
+ '" child" , '" info" , '" open" , '" iter" ,
+ '" newfile" , '" newdir" , '" remove" , ;
]struct
\ bootfs holds a reference to boot FS. This is used until the full sys/file
\ subsystem takes over with Path mechanics.
-0 value bootfs \ has to be set before first use
+0 value bootfs
extends IO struct[ File
- sfield pos \ offset from beginning of file
+ sfield pos
sfield size
sfield bufptr
sfield bufsz
@@ -450,6 +463,9 @@ extends IO struct[ File
: :buf( bufptr ;
: :)buf bi :buf( | bufsz + ;
: :ptr bi+ pos | bufsz mod swap :buf( + ;
+ : :new ( -- hdl )
+ IO :new 0 ( pos ) , 0 ( size ) , 0 ( bufptr ) , 0 ( bufsz ) , 2 nabort, ;
+ : :[methods] '" seek" , '" truncate" , ;
]struct
\ File loading
diff --git a/posix/glue.fs b/posix/glue.fs
@@ -1,17 +1,15 @@
-: _ doer ' , does> nip @ execute ;
-_ _:child _fchild _ _:open _fopen _ _:info _finfo _ _:iter _fiter
-
-create _POSIXFS
- 0 , 0 ,
- ' _:child ,
- ' _:info ,
- ' _:open ,
- ' _:iter ,
- ' abort ,
- ' abort ,
- ' abort ,
-
-_POSIXFS to bootfs
+extends Filesystem struct[ POSIXFS
+ : _ doer ' , does> nip @ execute ;
+ _ child _fchild
+ _ open _fopen
+ _ info _finfo
+ _ iter _fiter
+ alias abort newfile
+ alias abort newdir
+ alias abort remove
+ : :new 0 Filesystem :new S[ :[methods] ]S c@+ -move, ;
+]struct
+POSIXFS :new to bootfs
: mountImage ( imgname -- drv )
_mountdrv here 512 , -1 , ['] _drv@ , ['] _drv! , ;
