Может, кому интересно будет...
Я тут пытался кое-что наваять на gforth с использованием их OOP библиотечки, и мне понадобились стеки для объектов. Причем стеков нужно много, и начальный их размер маленький, но теоретически в любой стек в процессе может понадобиться засунуть количество объектов, стремящееся к бесконечности, поэтому стеки должны автоматически менять размер, желательно в любую сторону. Четыре операции: засунуть в стек, высунуть из стека, посмотреть, что лежит на стеке на заданной глубине, и ROLL. Проще сделать стеки, растущие вверх, по-моему, где-то в папке devel у SP-Forth есть исходник, реализующий это. Но из-за ROLL я решил не париться в коде с перетаскиванием туда-сюда содержимого памяти, а сделать стек, растущий вниз, и использовать обычный ROLL, меняя указатель стека данных.
Оно вроде бы работает. Там в коде есть вывод сообщений о изменении размера и вывод содержимого памяти, это для наглядности тестового примера, при реальном использовании это, естественно, лучше убрать.
Код:
#! /opt/local/bin/gforth
S" objects.fs" required
15 CONSTANT DEFAULT_STACK_SIZE
DEFAULT_STACK_SIZE VALUE StackSize
StackSize VALUE StackResizingTerm
0 VALUE OriginalStackPointer
object class
cell% inst-var __stack_heap_address
cell% inst-var __stack_size
cell% inst-var __stack_pointer
selector __destroy_stack
selector __get_stack_heap_address
selector __get_stack_size
selector __get_stack_pointer
selector __get_stack_available_cells
selector __get_stack_depth
selector __resize_stack
selector __increase_stack_if_needed
selector __decrease_stack_if_needed
selector __push_object_on_stack
selector __pop_object_from_stack
selector __roll_object_on_stack
selector __inspect_object_on_stack
m: ( stack_addr -- )
StackSize CELLS ALLOCATE DROP __stack_heap_address !
StackSize __stack_size !
__stack_heap_address @ __stack_size @ 1- CELLS + __stack_pointer !
;m overrides construct
m: ( stack_addr -- )
__stack_heap_address @ free DROP
;m overrides __destroy_stack
m: ( stack_addr -- u )
__stack_heap_address @
;m overrides __get_stack_heap_address
m: ( stack_addr -- u )
__stack_size @
;m overrides __get_stack_size
m: ( stack_addr -- u )
__stack_pointer @
;m overrides __get_stack_pointer
m: ( stack_addr -- u )
__stack_pointer @ __stack_heap_address @ - CELL /
;m overrides __get_stack_available_cells
m: ( stack_addr -- u )
__stack_heap_address @ __stack_size @ CELLS + __stack_pointer @ - CELL /
;m overrides __get_stack_depth
m: ( n stack_addr -- )
this __get_stack_depth 0 0 0 { ResizingTerm StackDepth NewStackSize NewStackPointer NewStackHeapAddress -- }
__stack_size @ ResizingTerm + TO NewStackSize
NewStackSize CELLS ALLOCATE DROP TO NewStackHeapAddress
NewStackHeapAddress NewStackSize CELLS + StackDepth CELLS - TO NewStackPointer
__stack_pointer @ NewStackPointer StackDepth 1- CELLS CMOVE
NewStackSize __stack_size !
NewStackPointer __stack_pointer !
__stack_heap_address @ free DROP
NewStackHeapAddress __stack_heap_address !
;m overrides __resize_stack
m: ( stack_addr -- )
this __get_stack_available_cells 0= IF StackResizingTerm this __resize_stack S" ( Resizing + ) " TYPE THEN
;m overrides __increase_stack_if_needed
m: ( stack_addr -- )
this __get_stack_available_cells StackResizingTerm - 0= IF StackResizingTerm NEGATE this __resize_stack S" ( Resizing - ) " TYPE THEN
;m overrides __decrease_stack_if_needed
m: ( object_addr stack_addr -- )
{ ObjectAddress -- }
this __increase_stack_if_needed
ObjectAddress __stack_pointer @ !
__stack_pointer @ CELL - __stack_pointer !
;m overrides __push_object_on_stack
m: ( stack_addr -- )
__stack_pointer @ CELL + __stack_pointer !
__stack_pointer @ @
this __decrease_stack_if_needed
;m overrides __pop_object_from_stack
m: ( u stack_addr -- )
{ RollingObject -- }
this __increase_stack_if_needed
SP@ TO OriginalStackPointer
__stack_pointer @ CELL + SP!
RollingObject ROLL
OriginalStackPointer SP!
this __decrease_stack_if_needed
__stack_heap_address @ __stack_size @ CELLS DUMP
;m overrides __roll_object_on_stack
m: ( u stack_addr -- object_addr )
1+ { ObjectToInspect -- }
__stack_pointer @ ObjectToInspect CELLS + @
;m overrides __inspect_object_on_stack
end-class stack_object
0 VALUE MyStack
: test_stacks
stack_object heap-new TO MyStack
CR CR
100 0 DO
i MyStack __push_object_on_stack
i .
LOOP
CR
S" Current stack size: " TYPE MyStack __get_stack_size . CR
MyStack __get_stack_heap_address MyStack __get_stack_size CELLS dump
CR
0 99 DO
i . S" = " TYPE MyStack __pop_object_from_stack . CR
-1 +LOOP
CR CR
14 0 DO
i MyStack __push_object_on_stack
LOOP
14 0 DO
i MyStack __inspect_object_on_stack .
LOOP
CR
14 0 DO
13 MyStack __roll_object_on_stack
LOOP
14 0 DO
MyStack __pop_object_from_stack .
LOOP
MyStack __destroy_stack
MyStack free
;