780ebb4b00
this will allow us to manage bloat in the loader by using a bytecoded HLL rather than lots of C code. It also offers an opportunity for vendors or others with special applications to significantly customise the boot process without having to commit to a divergent code branch. This early commit is to allow others to experiment with the most effective mechanisms for integrating FICL with the loader as it currently stands. Ficl is distributed with the following license conditions: "Ficl is freeware. Use it in any way that you like, with the understanding that the code is not supported." All source files contain authorship attributions. Obtained from: John Sadler (john_sadler@alum.mit.edu)
141 lines
3.2 KiB
Forth
141 lines
3.2 KiB
Forth
\ ** ficl/softwords/classes.fr
|
|
\ ** F I C L 2 . 0 C L A S S E S
|
|
\ john sadler 1 sep 98
|
|
\ Needs oop.fr
|
|
|
|
.( loading ficl utility classes ) cr
|
|
also oop definitions
|
|
|
|
\ REF subclass holds a pointer to an object. It's
|
|
\ mainly for aggregation to help in making data structures.
|
|
\
|
|
object subclass c-ref
|
|
cell: .class
|
|
cell: .instance
|
|
|
|
: get ( inst class -- refinst refclass )
|
|
drop 2@ ;
|
|
: set ( refinst refclass inst class -- )
|
|
drop 2! ;
|
|
end-class
|
|
|
|
object subclass c-byte
|
|
char: .payload
|
|
|
|
: get drop c@ ;
|
|
: set drop c! ;
|
|
end-class
|
|
|
|
object subclass c-2byte
|
|
2 chars: .payload
|
|
|
|
: get drop w@ ;
|
|
: set drop w! ;
|
|
end-class
|
|
|
|
object subclass c-4byte
|
|
cell: .payload
|
|
|
|
: get drop @ ;
|
|
: set drop ! ;
|
|
end-class
|
|
|
|
|
|
\ ** C - P T R
|
|
\ Base class for pointers to scalars (not objects).
|
|
\ Note: use c-ref to make references to objects. C-ptr
|
|
\ subclasses refer to untyped quantities of various sizes.
|
|
|
|
\ Derived classes must specify the size of the thing
|
|
\ they point to, and supply get and set methods.
|
|
|
|
\ All derived classes must define the @size method:
|
|
\ @size ( inst class -- addr-units )
|
|
\ Returns the size in address units of the thing the pointer
|
|
\ refers to.
|
|
object subclass c-ptr
|
|
c-4byte obj: .addr
|
|
|
|
\ get the value of the pointer
|
|
: get-ptr ( inst class -- addr )
|
|
c-ptr => .addr
|
|
c-4byte => get
|
|
;
|
|
|
|
\ set the pointer to address supplied
|
|
: set-ptr ( addr inst class -- )
|
|
c-ptr => .addr
|
|
c-4byte => set
|
|
;
|
|
|
|
\ increment the pointer in place
|
|
: inc-ptr ( inst class -- )
|
|
2dup 2dup ( i c i c i c )
|
|
c-ptr => get-ptr -rot ( i c addr i c )
|
|
--> @size + -rot ( addr' i c )
|
|
c-ptr => set-ptr
|
|
;
|
|
|
|
\ decrement the pointer in place
|
|
: dec-ptr ( inst class -- )
|
|
2dup 2dup ( i c i c i c )
|
|
c-ptr => get-ptr -rot ( i c addr i c )
|
|
--> @size - -rot ( addr' i c )
|
|
c-ptr => set-ptr
|
|
;
|
|
|
|
\ index the pointer in place
|
|
: index-ptr ( index inst class -- )
|
|
locals| class inst index |
|
|
inst class c-ptr => get-ptr ( addr )
|
|
inst class --> @size index * + ( addr' )
|
|
inst class c-ptr => set-ptr
|
|
;
|
|
|
|
end-class
|
|
|
|
|
|
\ ** C - C E L L P T R
|
|
\ Models a pointer to cell (a 32 bit scalar).
|
|
c-ptr subclass c-cellPtr
|
|
: @size 2drop 4 ;
|
|
\ fetch and store through the pointer
|
|
: get ( inst class -- cell )
|
|
c-ptr => get-ptr @
|
|
;
|
|
: set ( value inst class -- )
|
|
c-ptr => get-ptr !
|
|
;
|
|
end-class
|
|
|
|
|
|
\ ** C - 2 B Y T E P T R
|
|
\ Models a pointer to a 16 bit scalar
|
|
c-ptr subclass c-2bytePtr
|
|
: @size 2drop 2 ;
|
|
\ fetch and store through the pointer
|
|
: get ( inst class -- value )
|
|
c-ptr => get-ptr w@
|
|
;
|
|
: set ( value inst class -- )
|
|
c-ptr => get-ptr w!
|
|
;
|
|
end-class
|
|
|
|
|
|
\ ** C - B Y T E P T R
|
|
\ Models a pointer to an 8 bit scalar
|
|
c-ptr subclass c-bytePtr
|
|
: @size 2drop 1 ;
|
|
\ fetch and store through the pointer
|
|
: get ( inst class -- value )
|
|
c-ptr => get-ptr c@
|
|
;
|
|
: set ( value inst class -- )
|
|
c-ptr => get-ptr c!
|
|
;
|
|
end-class
|
|
|
|
|
|
previous definitions
|