commit 44b675ea84c0b35fbf77196a5c24293a455975e2
parent 8e8705fc2598f1c5b7e2032585030bf9d58faafb
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 10 Aug 2022 18:45:43 -0400
Refactor structs
The other system was too complex for its own good. Now, it feels fine.
Diffstat:
8 files changed, 106 insertions(+), 111 deletions(-)
diff --git a/fs/doc/usage.txt b/fs/doc/usage.txt
@@ -89,46 +89,48 @@ Structures are an effective way to address offsets from base addresses while
keeping the general namespace clean. Structures have a name and a list of fields
and are declared thus:
-3 struct Foo bar baz :bleh
+ 3 struct Foo bar baz :bleh
This describes an 12 byte wide struct with 3 fields. All fields in structs are
always contiguous and 4 bytes wide.
The name is a string identifying the field. It has no existence in the system
dictionary and will only be used in the context of that structure, so name
-clashes are not a problem. Field names can be any word except "'(" and "')"
-which are reserved
+clashes are not a problem.
+
+A struct hold no data by itself and can't be used directly to access fields from
+memory. You refer to fields in a struct by supplying it with a source pointer,
+like this:
+
+ create data1 1 , 2 , ' mybleh ,
+ create data2 3 , 4 , ' mybleh ,
+ data1 Foo bar . --> prints 1
+ data2 Foo baz . --> prints 4
+
+Fields obey "to" semantics:
+
+ 42 to+ data1 Foo bar
+ data1 Foo bar . --> prints 43
+
+Field access can be compiled:
+
+ : foobar data2 Foo baz ;
+ foobar . --> prints 4
A field name starting with : is a "method". This means that it behaves like an
alias instead of like a value. The ":" stays in the name, you have to include it
-when you invoke the method.
-
-You create new instances with "instance", followed by the struct name, followed
-by the name of your new instance. This *doesn't* allocate and initialize the
-memory associated to the fields. You have to do it yourself.
-
-Accessing fields is where the fun begins. You refer to a field by calling the
-intance's name, followed by the field name. This will refer to the particular
-address in a way that obeys "to" semantics.
-
-There are two special field names, "'(" and "')" which yield the starting and
-ending address of the struct instance. These words don't obey "to" semantics.
-
-The struct name can itself be used like an instance. When you refer to the
-struct name, it will refer to the last instance being used. This is useful in
-methods, when you want to have to kind of reference to "self".
-
-Example:
-
-3 struct Foo bar baz :bleh
-: mybleh ." hello! " Foo baz . ;
-instance Foo MyFoo 1 , 2 , ' mybleh ,
-instance Foo OtherFoo 3 , 4 , ' mybleh ,
-MyFoo bar . \ prints 1
-OtherFoo bar . \ prints 3
-: myword 42 to MyFoo baz ; myword
-MyFoo baz . \ prints 42
-1 to+ MyFoo baz
-MyFoo baz . \ print 43
-MyFoo :bleh \ print "hello! 2"
-OtherFoo :bleh \ print "hello! 4"
+when you invoke the method. When the method is invoked, a copy of the data
+pointer is pushed to PS. For example, if you had:
+
+ : mybleh dup Foo bar swap Foo baz + ;
+
+defined before the previous examples, then you could do:
+
+ data1 Foo :bleh . --> prints 3
+ data2 Foo :bleh . --> prints 7
+
+You will often want to bind data to structs. You can do so with "structbind":
+
+ data1 structbind Foo MyData1
+ MyData1 :bleh
+ : someword MyData1 bar ;
diff --git a/fs/fs/fatlo.fs b/fs/fs/fatlo.fs
@@ -43,11 +43,13 @@ fatdrv value bufdrv \ drive from which this sector was read
\ FATcnt >1 means backup FATs
\ rootentcnt count of 32b entries
\ FATsz in bytes
-instance _ FATHeader 7 CELLSZ * allot
+create _FATHeader 7 CELLSZ * allot
+_FATHeader structbind _ FATHeader
\ TODO: support more than one FAT FS at once
-instance Filesystem FATFS
+create _FATFS
fatdrv , 0 , 0 , ' abort , ' FATHeader ,
+_FATFS structbind Filesystem FATFS
: readFATvolume ( -- )
0 fatbuf( fatdrv drv@
@@ -165,9 +167,10 @@ here const )fnbuf
\ Get ID for direntry
: getid ( direntry -- id ) fatbuf( - bufsec BPB_BytsPerSec * + ;
-: fatchild ( dirid name -- id-or-0 )
- fnbuf! getdirentry readdir findindir dup if getid then ;
-current to FATFS :child
+: FATFS:child ( dirid name self -- id-or-0 )
+ drop fnbuf! getdirentry readdir findindir dup if getid then ;
+\ current to FATFS :child
+current _FATFS 4 + !
\ File cursor
\ 12b IO handle prelude
@@ -242,8 +245,8 @@ create fcursors( FCursorSize FCURSORCNT * allot0
: fatclose ( fcursor ) dup dup 8 + @ ( 'flush ) execute 0 swap FCUR_flags! ;
\ This is the "low" part. Complete open is finalized in fs/fat
-: fatopenlo ( id -- hdl )
- getdirentry findfreecursor >r
+: FATFS:open ( id self -- hdl )
+ drop getdirentry findfreecursor >r
\ write IO handle prelude: readbuf, writebuf, flush
['] fatreadbuf r@ ! ['] abort r@ 4 + ! ['] drop r@ 8 + !
\ write File handle prelude: fseek fclose
@@ -253,4 +256,4 @@ create fcursors( FCursorSize FCURSORCNT * allot0
dup fatbuf( - bufsec BPB_BytsPerSec * + ( dirent doffset ) r@ 32 + !
-1 r@ FCUR_clusteridx! 0 r@ FCUR_pos!
DIR_FileSize r@ FCUR_size! ( ) r> ;
-current to FATFS :open
+current _FATFS 8 + !
diff --git a/fs/lib/scratch.fs b/fs/lib/scratch.fs
@@ -12,25 +12,26 @@
8 struct Scratchpad
size ptr :buf( :)buf :allot :[]>str :[ :]
-: _buf( Scratchpad ') ;
-: _buf) _buf( Scratchpad size + ;
-: _allot ( n -- a )
- Scratchpad ptr over + _buf) >= if
- ." scratch reload!" nl> _buf( to Scratchpad ptr then
- Scratchpad ptr swap to+ Scratchpad ptr ( a ) ;
+: _buf( ( self -- a ) ['] Scratchpad structsz + ;
+: _buf) ( self -- a ) dup _buf( swap Scratchpad size + ;
+: _allot ( n self -- a )
+ dup >r Scratchpad ptr over + r@ _buf) >= if
+ ." scratch reload!" nl> r@ _buf( to r@ Scratchpad ptr then
+ r@ Scratchpad ptr swap to+ r> Scratchpad ptr ( a ) ;
\ push a range to the scratchpad as a string
-: _[]>str ( a u -- str )
- dup 1+ _allot ( src u dst-1 ) >r dup r@ c!+ swap ( src dst u ) move r> ;
+: _[]>str ( a u self -- str )
+ over 1+ swap _allot ( src u dst-1 )
+ >r dup r@ c!+ swap ( src dst u ) move r> ;
0 value _here
\ Open a scratch area for writing
-: _[ ( -- ) here to _here Scratchpad ptr to here ;
+: _[ ( self -- ) here to _here Scratchpad ptr to here ;
\ Stop writing to the scratch area and restore here
\ Returns the address of the beginning of the written area
-: _] ( -- a ) here to@! Scratchpad ptr _here to here ;
+: _] ( self -- a ) here swap to@! Scratchpad ptr _here to here ;
: scratchpad$ ( size -- )
- dup , Scratchpad ') ,
+ here over , _buf( ,
['] _buf( , ['] _buf , ['] _allot , ['] _[]>str , ['] _[ , ['] _] , allot ;
diff --git a/fs/sys/file.fs b/fs/sys/file.fs
@@ -40,7 +40,8 @@ create _buf $100 allot
\ We need a private scratchpad here because some cursors can be quite
\ long-lived. If we use the system scratchpad, short-lived data will overwrite
\ our cursors.
-instance Scratchpad filespad $200 scratchpad$
+create _filespad $8000 scratchpad$
+_filespad structbind Scratchpad filespad
\ This creates a "f<" reader with the file descriptor embedded in it. This
\ allows for a straightforward override of input/output words.
diff --git a/fs/sys/scratch.fs b/fs/sys/scratch.fs
@@ -9,4 +9,5 @@
\ TODO: investigate why CC has memory corruption when running tests with a $4000
\ syspad.
-instance Scratchpad syspad $8000 scratchpad$
+create _syspad $8000 scratchpad$
+_syspad structbind Scratchpad syspad
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -92,28 +92,20 @@ S" /tests/harness.fs" findpath floaded? #
\ Structures
3 struct Foo bar baz :bleh
-: mybleh Foo bar Foo baz + ;
-instance Foo MyFoo 1 , 2 , ' mybleh ,
-instance Foo OtherFoo 3 , 4 , ' mybleh ,
-MyFoo '( @ 1 #eq
-MyFoo ') MyFoo '( - 3 CELLSZ * #eq
-MyFoo bar 1 #eq
-OtherFoo bar 3 #eq
-: myword 42 to MyFoo baz ; myword
-MyFoo baz 42 #eq
-1 to+ MyFoo baz
-MyFoo baz 43 #eq
-MyFoo :bleh 44 #eq
-OtherFoo :bleh 7 #eq
-\ struct selection is made at each execution, not only at compile time
-: myword MyFoo bar ;
-myword 1 #eq
-OtherFoo bar 3 #eq
-myword 1 #eq
-\ Each structure has their own "last instance" copy
-1 struct Bar baz
-instance Bar MyBar 42 ,
-Bar baz 42 #eq
-MyFoo bar 1 #eq
-Bar baz 42 #eq
+: mybleh dup Foo bar swap Foo baz + ;
+create data1 1 , 2 , ' mybleh ,
+create data2 3 , 4 , ' mybleh ,
+data1 Foo bar 1 #eq
+data2 Foo baz 4 #eq
+42 to+ data1 Foo baz
+data1 Foo baz 44 #eq
+: myword data2 Foo bar ;
+myword 3 #eq
+data1 Foo :bleh 45 #eq
+: myword data2 Foo :bleh ;
+myword 7 #eq
+data1 structbind Foo MyData1
+MyData1 bar 1 #eq
+: myword MyData1 :bleh ;
+myword 45 #eq
testend
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -171,38 +171,30 @@ alias noop [then]
swap _ then ; immediate
\ Structures
-\ Structure's structure:
+
+: _val' ( 'data 'off -- a ) @ + ;
+: _method over + @ execute ;
+
\ 4b link to dict
-\ 4b pointer to last instance used
-
-: _getinst' ( 'struct -- ''inst ) CELLSZ + ;
-: _field' ( off 'struct -- a ) _getinst' @ + ;
-: _field'' ( 'struct 'off -- a ) @ swap _field' ;
-: _parens ( 'struct off )
- compiling if litn litn compile _field' else swap _field' then ;
-: 'structsz ( 'struct -- sz ) @ llcnt CELLSZ * ;
-: structsz ( w -- sz ) does' 'structsz ;
-: @execute @ execute ;
: struct ( cnt -- )
- doer >r here 0 , 0 , 0 begin ( 'dict off )
+ doer immediate >r here 0 , 0 begin ( 'dict off )
over word entry ( 'dict off )
- compile (to) ['] _field'' ,
- curword 1+ c@ ':' = if ['] @execute else ['] @ then , dup , exit,
- CELLSZ + next ( 'dict off )
- 2drop immediate
-does> ( ??? 'struct -- ??? *to* )
- word case ( 'struct R:str )
- S" '(" of s= 0 _parens endof
- S" ')" of s= dup 'structsz ( 'struct off ) _parens endof
- \ find field in list
- curword over @ ( 'struct str 'dict ) find ( 'struct 'field )
- ?dup not if curword stype abort" field doesn't exist!" then
- compiling if swap litn execute, else execute then
- endcase ;
-: _inst! ( 'inst -- )
- dup CELLSZ + swap @ ( 'inst w ) does' _getinst' ! ;
-: instance ' doer here swap , _inst! immediate does>
- dup compiling if litn compile _inst! else _inst! then @ execute ;
+ curword 1+ c@ ':' = if
+ dup litn compile _method else
+ compile (to) ['] _val' , ['] @ , dup , then ( 'dict off )
+ exit, CELLSZ + next ( 'dict off ) 2drop
+ does> ( 'data? 'struct -- *to* ) \ when imm, 'data? is absent
+ @ ( 'data? 'fielddict )
+ word swap ( 'data? str 'dict ) find ( 'data? 'field )
+ ?dup not if curword stype abort" field doesn't exist!" then
+ compiling if ( 'field ) execute, else execute then ;
+: structsz ( 'struct -- sz ) does' @ llcnt CELLSZ * ;
+
+\ 4b link to struct
+\ 4b link to data
+: structbind ( 'data -- ) ' doer , , immediate does> ( 'bind -- *to* )
+ dup @ swap CELLSZ + @ ( 'struct 'data )
+ compiling if litn else swap then execute ;
\ Drive API
\ Anticipating lib/drive
diff --git a/posix/glue.fs b/posix/glue.fs
@@ -1,8 +1,11 @@
-instance Filesystem POSIXFS
+: _:child ( 'data ) drop _fchild ;
+: _:open ( 'data ) drop _fopen ;
+create _POSIXFS
' abort ,
- ' _fchild ,
- ' _fopen ,
+ ' _:child ,
+ ' _:open ,
' abort ,
' abort ,
+_POSIXFS structbind Filesystem POSIXFS
current to activefs
