classes.fr revision 76116
154359Sroberto\ #if (FICL_WANT_OOP) 2182007Sroberto\ ** ficl/softwords/classes.fr 3290000Sglebius\ ** F I C L 2 . 0 C L A S S E S 4182007Sroberto\ john sadler 1 sep 98 554359Sroberto\ Needs oop.fr 654359Sroberto\ 754359Sroberto\ $FreeBSD: head/sys/boot/ficl/softwords/classes.fr 76116 2001-04-29 02:36:36Z dcs $ 8182007Sroberto 9290000Sglebiusalso oop definitions 1054359Sroberto 11182007Sroberto\ REF subclass holds a pointer to an object. It's 12182007Sroberto\ mainly for aggregation to help in making data structures. 13182007Sroberto\ 14182007Srobertoobject subclass c-ref 15182007Sroberto cell: .class 16182007Sroberto cell: .instance 17182007Sroberto 18182007Sroberto : get ( inst class -- refinst refclass ) 19182007Sroberto drop 2@ ; 20182007Sroberto : set ( refinst refclass inst class -- ) 21182007Sroberto drop 2! ; 22182007Srobertoend-class 23182007Sroberto 24182007Srobertoobject subclass c-byte 25182007Sroberto char: .payload 26182007Sroberto 27182007Sroberto : get drop c@ ; 28182007Sroberto : set drop c! ; 29182007Srobertoend-class 30182007Sroberto 31182007Srobertoobject subclass c-2byte 32182007Sroberto 2 chars: .payload 33182007Sroberto 34182007Sroberto : get drop w@ ; 3554359Sroberto : set drop w! ; 3654359Srobertoend-class 3754359Sroberto 3854359Srobertoobject subclass c-4byte 3954359Sroberto 4 chars: .payload 40182007Sroberto 4154359Sroberto : get drop q@ ; 4254359Sroberto : set drop q! ; 43290000Sglebiusend-class 4454359Sroberto 4554359Sroberto 4654359Srobertoobject subclass c-cell 4754359Sroberto cell: .payload 4854359Sroberto 4954359Sroberto : get drop @ ; 5054359Sroberto : set drop ! ; 5154359Srobertoend-class 5254359Sroberto 5354359Sroberto 5454359Sroberto\ ** C - P T R 5554359Sroberto\ Base class for pointers to scalars (not objects). 5654359Sroberto\ Note: use c-ref to make references to objects. C-ptr 5754359Sroberto\ subclasses refer to untyped quantities of various sizes. 5854359Sroberto 5954359Sroberto\ Derived classes must specify the size of the thing 6054359Sroberto\ they point to, and supply get and set methods. 6154359Sroberto 6254359Sroberto\ All derived classes must define the @size method: 6354359Sroberto\ @size ( inst class -- addr-units ) 6454359Sroberto\ Returns the size in address units of the thing the pointer 6554359Sroberto\ refers to. 6654359Srobertoobject subclass c-ptr 6754359Sroberto c-cell obj: .addr 6854359Sroberto 6954359Sroberto \ get the value of the pointer 7054359Sroberto : get-ptr ( inst class -- addr ) 7154359Sroberto c-ptr => .addr 7254359Sroberto c-cell => get 7354359Sroberto ; 7454359Sroberto 7554359Sroberto \ set the pointer to address supplied 7654359Sroberto : set-ptr ( addr inst class -- ) 77290000Sglebius c-ptr => .addr 7854359Sroberto c-cell => set 7954359Sroberto ; 8054359Sroberto 8154359Sroberto \ force the pointer to be null 8254359Sroberto : clr-ptr 8354359Sroberto 0 -rot c-ptr => .addr c-cell => set 8454359Sroberto ; 8554359Sroberto 8654359Sroberto \ return flag indicating null-ness 8754359Sroberto : ?null ( inst class -- flag ) 8854359Sroberto c-ptr => get-ptr 0= 8954359Sroberto ; 9054359Sroberto 9154359Sroberto \ increment the pointer in place 9254359Sroberto : inc-ptr ( inst class -- ) 9354359Sroberto 2dup 2dup ( i c i c i c ) 9454359Sroberto c-ptr => get-ptr -rot ( i c addr i c ) 9554359Sroberto --> @size + -rot ( addr' i c ) 9654359Sroberto c-ptr => set-ptr 9754359Sroberto ; 9854359Sroberto 9954359Sroberto \ decrement the pointer in place 10054359Sroberto : dec-ptr ( inst class -- ) 10154359Sroberto 2dup 2dup ( i c i c i c ) 10254359Sroberto c-ptr => get-ptr -rot ( i c addr i c ) 103290000Sglebius --> @size - -rot ( addr' i c ) 10454359Sroberto c-ptr => set-ptr 105290000Sglebius ; 10654359Sroberto 10754359Sroberto \ index the pointer in place 10854359Sroberto : index-ptr { index 2:this -- } 109290000Sglebius this --> get-ptr ( addr ) 11054359Sroberto this --> @size index * + ( addr' ) 11154359Sroberto this --> set-ptr 11254359Sroberto ; 11354359Sroberto 11454359Srobertoend-class 11554359Sroberto 11654359Sroberto 11754359Sroberto\ ** C - C E L L P T R 11854359Sroberto\ Models a pointer to cell (a 32 or 64 bit scalar). 11954359Srobertoc-ptr subclass c-cellPtr 12054359Sroberto : @size 2drop 1 cells ; 12154359Sroberto \ fetch and store through the pointer 12254359Sroberto : get ( inst class -- cell ) 12354359Sroberto c-ptr => get-ptr @ 12454359Sroberto ; 12554359Sroberto : set ( value inst class -- ) 12654359Sroberto c-ptr => get-ptr ! 12754359Sroberto ; 128290000Sglebiusend-class 129290000Sglebius 13054359Sroberto 13154359Sroberto\ ** C - 4 B Y T E P T R 13254359Sroberto\ Models a pointer to a quadbyte scalar 13354359Srobertoc-ptr subclass c-4bytePtr 13454359Sroberto : @size 2drop 4 ; 135290000Sglebius \ fetch and store through the pointer 13654359Sroberto : get ( inst class -- value ) 13754359Sroberto c-ptr => get-ptr q@ 13854359Sroberto ; 13954359Sroberto : set ( value inst class -- ) 14054359Sroberto c-ptr => get-ptr q! 141290000Sglebius ; 14254359Sroberto end-class 14354359Sroberto 14454359Sroberto\ ** C - 2 B Y T E P T R 14554359Sroberto\ Models a pointer to a 16 bit scalar 146290000Sglebiusc-ptr subclass c-2bytePtr 14754359Sroberto : @size 2drop 2 ; 14854359Sroberto \ fetch and store through the pointer 14954359Sroberto : get ( inst class -- value ) 15054359Sroberto c-ptr => get-ptr w@ 15154359Sroberto ; 15254359Sroberto : set ( value inst class -- ) 15354359Sroberto c-ptr => get-ptr w! 15454359Sroberto ; 15554359Srobertoend-class 15654359Sroberto 15754359Sroberto 15854359Sroberto\ ** C - B Y T E P T R 15954359Sroberto\ Models a pointer to an 8 bit scalar 16054359Srobertoc-ptr subclass c-bytePtr 16154359Sroberto : @size 2drop 1 ; 16254359Sroberto \ fetch and store through the pointer 16354359Sroberto : get ( inst class -- value ) 16454359Sroberto c-ptr => get-ptr c@ 16554359Sroberto ; 16654359Sroberto : set ( value inst class -- ) 16754359Sroberto c-ptr => get-ptr c! 16854359Sroberto ; 16954359Srobertoend-class 17054359Sroberto 17154359Sroberto 17254359Srobertoprevious definitions 17354359Sroberto\ #endif 17454359Sroberto