commit 5cff8c8e52213881ade1059ae72e41a6ebed53df
parent 5ef6c1fb84ed08b38cf007b6490853b1d72d26f5
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Tue, 9 Aug 2022 13:48:01 -0400
Make "struct" into something more elegant and convenient
and include it into bootlo because I'm going to use it in fatlo.
See doc/usage.
Diffstat:
11 files changed, 134 insertions(+), 29 deletions(-)
diff --git a/Makefile b/Makefile
@@ -21,7 +21,7 @@ pc.bin: dusk buildpc.fs $(ALLSRCS)
pc.img: mbr.bin pc.bin
dd if=/dev/zero of=$@ bs=1M count=1
# We need to reserve (-R) enough sectors for MBR + pc.bin
- mformat -M 512 -d 1 -R 48 -i $@ ::
+ mformat -M 512 -d 1 -R 56 -i $@ ::
dd if=mbr.bin of=$@ bs=1 seek=62 conv=notrunc
dd if=pc.bin of=$@ bs=1 seek=512 conv=notrunc
mcopy -sQ -i $@ fs/* ::
diff --git a/fs/cc/cc.fs b/fs/cc/cc.fs
@@ -3,7 +3,7 @@ require sys/scratch.fs
require sys/xhere.fs
1 value _debug
S" /cc/vm" findpath# ( hdl )
-scratch[ ARCH c@+ dup 3 + c, move, ," .fs" ]scratch ( hdl fname )
+syspad :[ ARCH c@+ dup 3 + c, move, ," .fs" syspad :] ( hdl fname )
fchild dup bool const HASCC ( hdl )
HASCC not [if] drop ." Unsupported arch for CC" nl> \s [then]
( hdl ) fload
diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs
@@ -232,7 +232,7 @@ ASTIDCNT wordtbl gentbl ( node -- )
r> ( selectedop ) if op1<>op2 else selop1 then ;
\ TODO: this doesn't work with lvalues yet
:w ( List )
- dup childcount dup 1+ 4 * scratchallot dup >r ( node len a )
+ dup childcount dup 1+ 4 * syspad :allot dup >r ( node len a )
over >r tuck ! 4 + swap firstchild begin ( a node )
dup ast.const.value ( a node value ) rot tuck ! ( node a )
4 + swap nextsibling next ( a node ) 2drop
diff --git a/fs/cc/tok.fs b/fs/cc/tok.fs
@@ -59,7 +59,7 @@ create _ 10 c, ," 09AZaz__$$"
( c ) else ( EOF ) drop 0 then ;
: _writesym ( c3? c2? c1 len -- str )
- 4 scratchallot dup >r ( c3? c2? c1 len a )
+ 4 syspad :allot dup >r ( c3? c2? c1 len a )
over >r c!+ ( c a ) begin c!+ next drop r> ( str ) ;
\ Returns the next token as a string or 0 when there's no more token to consume.
@@ -87,7 +87,7 @@ create _ 10 c, ," 09AZaz__$$"
cc< cc< ''' = not if _err then ( c ) ''' tuck ( ' c ' ) 3 _writesym
endof
of ident-or-lit? \ identifier or number literal
- r@ ( c ) A>r MAXTOKSZ scratchallot >A A>r ( R:tok )
+ r@ ( c ) A>r MAXTOKSZ syspad :allot >A A>r ( R:tok )
0 Ac!+ ( len placeholder ) begin ( c )
Ac!+ cc< dup ident-or-lit? not until to putback
r> ( buf ) A> over 1+ - ( tok len ) over c! r>A
diff --git a/fs/doc/usage.txt b/fs/doc/usage.txt
@@ -82,3 +82,53 @@ Each metadata element has this structure:
4b link to next
4b type ID
( any other type-specific data )
+
+# Structures
+
+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
+
+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
+
+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"
diff --git a/fs/lib/scratch.fs b/fs/lib/scratch.fs
@@ -1,5 +1,4 @@
\ Scratchpads
-?f<< /lib/struct.fs
\ Scratchpads are circular buffers for placing semi-temporary strings (or
\ other sequences). The scratchpad has a running pointer and when we need
@@ -9,24 +8,29 @@
\ The system scratchpad lives at sys/scratch.
-struct Scratchpad
- bfield scratchsize
- bfield scratch>
- 'bfield scratch(
-0 value _here
+8 struct Scratchpad
+ size ptr :buf( :)buf :allot :[]>str :[ :]
-: scratchpad$ ( size "name" -- ) create dup , here CELLSZ + , allot ;
-: scratch) scratch( scratchsize + ;
-: scratchallot ( n -- a )
- scratch> over + scratch) >= if ." scratch reload!" nl> scratch( to scratch> then
- scratch> swap to+ scratch> ( a ) ;
+: _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 ) ;
\ push a range to the scratchpad as a string
-: []>str ( a u -- str )
- dup 1+ scratchallot ( src u dst-1 ) >r dup r@ c!+ swap ( src dst u ) move r> ;
+: _[]>str ( a u -- str )
+ dup 1+ _allot ( src u dst-1 ) >r dup r@ c!+ swap ( src dst u ) move r> ;
+
+0 value _here
\ Open a scratch area for writing
-: scratch[ ( -- ) here to _here scratch> to here ;
+: _[ ( -- ) 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
-: ]scratch ( -- a ) scratch> here to scratch> _here to here ;
+: _] ( -- a ) here to@! Scratchpad ptr _here to here ;
+
+: scratchpad$ ( size -- )
+ dup , Scratchpad ') ,
+ ['] _buf( , ['] _buf , ['] _allot , ['] _[]>str , ['] _[ , ['] _] , allot ;
+
diff --git a/fs/sys/file.fs b/fs/sys/file.fs
@@ -40,14 +40,12 @@ 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.
-$200 scratchpad$ filespad
+instance Scratchpad filespad $200 scratchpad$
\ This creates a "f<" reader with the file descriptor embedded in it. This
\ allows for a straightforward override of input/output words.
: [f<] ( curfd -- word )
- filespad to@! Scratchpad >r
- scratch[ litn compile getc exit, ]scratch
- r> to Scratchpad ;
+ filespad :[ litn compile getc exit, filespad :] ;
: require word dup findpath# floaded? not if
stype abort" required" else drop then ;
diff --git a/fs/sys/scratch.fs b/fs/sys/scratch.fs
@@ -9,5 +9,4 @@
\ TODO: investigate why CC has memory corruption when running tests with a $4000
\ syspad.
-$8000 scratchpad$ syspad
-syspad to Scratchpad
+instance Scratchpad syspad $8000 scratchpad$
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -77,4 +77,25 @@ floaded #
0 ( file doesn't exist ) floaded? not #
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
+: myword MyFoo bar ;
+myword 1 #eq
+OtherFoo bar 3 #eq
+myword 1 #eq
testend
diff --git a/fs/tests/lib/all.fs b/fs/tests/lib/all.fs
@@ -3,6 +3,5 @@ f<< /tests/lib/core.fs
f<< /tests/lib/bit.fs
f<< /tests/lib/str.fs
f<< /tests/lib/xdict.fs
-f<< /tests/lib/struct.fs
f<< /tests/lib/crc.fs
f<< /tests/lib/io.fs
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -78,7 +78,8 @@
: &c@ ( n -- ) doer , does> @ c@ ;
: &+@ ( n -- ) doer , does> @ + @ ;
: &+! ( n -- ) doer , does> @ + ! ;
-: field ( off -- ) doer , does> ( a 'w ) @ + to? ?dup if execute else @ then ;
+: ?toexec ( a -- ??? ) to? ?dup if execute else @ then ;
+: field ( off -- ) doer , does> ( a 'w ) @ + ?toexec ;
\ A structure method. Called with a strucure as the top argument and will
\ execute the word pointer at a specific offset with that structure pointer
\ till on the top of PS.
@@ -105,8 +106,10 @@ alias else endof immediate
?dup if begin [compile] then ?dup not until then compile rdrop ; immediate
\ Linked lists. See doc/usage.
-alias @ llnext
+: llnext @ ;
: llend ( ll -- lastll ) begin dup @ ?dup while nip repeat ( ll ) ;
+: llcnt ( ll -- count )
+ A>r 0 >A begin dup @ ?dup while A+ nip repeat drop A> r>A ;
: lladd ( ll -- newll ) here swap llend ! here 0 , ;
\ Emitting
@@ -161,6 +164,37 @@ alias noop [then]
litn litn compile _ else
swap _ then ; immediate
+\ Structures
+\ Structure's structure:
+\ 4b link to field list
+\ Field's structure:
+\ 4b next
+\ Xb string
+
+create _currentinst CELLSZ allot
+: (struct()) ( off -- a ) _currentinst @ + ;
+: (struct) ( off ) _currentinst @ + ?toexec ;
+: (struct:) ( off ) _currentinst @ + to? ?dup if execute else @ execute then ;
+: _parens ( off ) compiling if litn compile (struct()) else (struct()) then ;
+: struct ( cnt -- )
+ doer >r here 0 ,
+ begin ( ll ) lladd word c@+ dup c, move, next drop immediate
+does> ( ??? 'struct -- ??? *to* )
+ word case ( 'struct R:str )
+ S" '(" of s= drop 0 _parens endof
+ S" ')" of s= llcnt CELLSZ * ( off ) _parens endof
+ \ find field in list
+ 0 swap @ begin ( cnt ll )
+ ?dup not if curword stype abort" field doesn't exist!" then
+ dup 4 + curword s= if leave else llnext swap 1+ swap then
+ next ( cnt ll ) drop CELLSZ * ( off )
+ curword 1+ c@ ':' = if ['] (struct:) else ['] (struct) then
+ compiling if swap litn execute, else execute then
+ endcase ;
+: _inst! _currentinst ! ;
+: instance ' doer , here _currentinst ! immediate does>
+ dup CELLSZ + compiling if litn compile _inst! else _inst! then @ execute ;
+
\ Drive API
\ Anticipating lib/drive
: drvsecsz ( drv -- sz ) @ ;
