Category : Forth Source Code
Archive   : FPCSLICE.ZIP
Filename : FORMDYN.SEQ

\ FORMDYN.SEQ CREATES & MAINTAINS HEADERS IN DATA SEGMENT
\ copyright 1988 Robert J. Gesswein
\ -----------------------------------------------------------------------
: @SIZE ( form-header.pfa -- n ) 2 I@ ;
: @LINK ( hxxx.pfa -- n ) 4 I@ ;
: @TYPE ( hxxx.pfa -- n ) 6 I@ ;
: @PAR ( hxxx.pfa -- ) 8 I@ ;
: @OF.FORM ( hxxx.pfa -- n ) 10 I@ ;
: @BYTES/ ( hxxx.pfa -- n ) 12 I@ ;
: @TOT ( hxxx.pfa -- n ) 14 I@ ;
: @TOTSIZE ( hxxx.pfa -- n ) 12 I2@ * ;
: HSLI? ( hxxx.pfa -- f ) @TYPE 1 = ;
\ -----------------------------------------------------------------------
: @STRU-AL-START ( form.header.pfa -- aL )
BEGIN
DUP @PAR
WHILE
@PAR
REPEAT
EXECUTE@ ;
: @STRU-SIZE ( structure.header.pfa -- size ) @STRU-AL-START @L ;
: @STRU-AL-END ( form.header.pfa -- aL ) @STRU-AL-START 2DUP @L + ;
\ -----------------------------------------------------------------------
0 CONSTANT ControlBlockTotal \ total of all control block bytes (default values)
0 CONSTANT SliceArrayTotal \ total of all sli/lnk bytes (default values)
\ -----------------------------------------------------------------------
: TOTAL.SLI&LNK.OFFSETS ( header-pfa -- )
0 !> ControlBlockTotal
0 !> SliceArrayTotal \ zero w/ each header
BEGIN
@LINK ?DUP
WHILE \ while link<>0
DUP @TYPE \ ( f-xxx.pfa type ->
0> IF
DUP HSLI?
IF SCB.Bytes ELSE LCB.Bytes THEN
+!> ControlBlockTotal
THEN
REPEAT ;

\ -->
\ -----------------------------------------------------------------------
: SET.SLI/LNK.OFFSET ( n -- ) \ n = SCB.Bytes or LCB.Bytes
ControlBlockTotal SliceArrayTotal + CB.AL@ !L \ off. to 1st slice
XXXPfa @TOTSIZE +!> SliceArrayTotal
NEGATE +!> ControlBlockTotal ;
\ -----------------------------------------------------------------------
: FILL.SCB ( -- ) \ sets all but offset
0 S.CURR!
XXXPfa @BYTES/ S.BYTES!
0 S.FIRST!
0 S.HERE!
XXXPfa @TOT S.TOT! ;

: FILL.LCB.HEADER ( -- ) \ sets all but offset
L.OFF@ L.CURROFF!
0 L.CURR!
XXXPfa @TOT L.TOT!
XXXPfa @TOTSIZE L.SIZE! ;
\ -----------------------------------------------------------------------
: {SET.NODE} ( -- n )
XXXPfa @BYTES/ LCB.NodeBytes + \ default bytes in link
DUP LN.BYTES! LN.PREV! ;

: SET.LCB.NODES ( -- ) RUN-LSLICES-DOING> {SET.NODE} ;
\ -----------------------------------------------------------------------
: SET.SLI/LNK.DEFAULTS ( xxx.pfa -- )
DUP XXXPfa! DUP VAR.AL CB.AL! \ set xxx.pfa & cb.al
HSLI? IF \ if a slice
SCB.Bytes SET.SLI/LNK.OFFSET
FILL.SCB
ELSE \ else a link
LCB.Bytes SET.SLI/LNK.OFFSET
FILL.LCB.HEADER
SET.LCB.NODES
THEN ;

\ -->
\ -----------------------------------------------------------------------
DEFER {make.instance} ( header.pfa -- ) \ header.pfa = of.form

: NEXT.LEVEL.IN ( -- )
SET-SLICE-ACTION> {make.instance} \ for run-slices or lslices
XXXPfa HSLI? IF RUN-SLICES ELSE RUN-LSLICES THEN ;

: MAKE.INSTANCE ( header-pfa -- )
DUP TOTAL.SLI&LNK.OFFSETS
BEGIN
@LINK ?DUP
WHILE
DUP @TYPE 0> IF \ if f-sli or f-lnk
>R \ xxx.pfa to rstack (saved for recursion)
CB.AL@ XXXPfa \ save for return
R@ SET.SLI/LNK.DEFAULTS

ControlBlockTotal SliceArrayTotal \ save for return
NEXT.LEVEL.IN

!> SliceArrayTotal !> ControlBlockTotal
XXXPfa! CB.AL! \ restore values
R> \ bring back xxx.pfa for next link
THEN
REPEAT ;

: set.make.instance ( -- ) XXXPfa @OF.FORM MAKE.INSTANCE ;
' set.make.instance IS {make.instance}

: MAKE-INSTANCE ( -- } header-pfa' )
PFA-OF
DUP @SIZE OVER EXECUTE@ !L \ store total size as first el.
MAKE.INSTANCE ;

\ -->
\ -----------------------------------------------------------------------
0 CONSTANT BytesChanging \ bytes to insert (positive) or delete (negative)
2VARIABLE PtOfChange \ aL where insert/delete is to take place
\ -----------------------------------------------------------------------
: ADJ.PARENT.NODE.PTRS ( lcb.aL -- ) \ adj curr's ln.bytes & next's ln.prev
2DUP L.CurOff# I@L + 2DUP \ current node.aL
2DUP LN.Bytes# I@L + \ next node.aL
BytesChanging -ROT LN.Prev# + +!L \ first bump next's ln.prev
BytesChanging -ROT LN.Bytes# + +!L ; \ bump curr. ln.bytes

\ adjust l.c.b. that contain the changing lslice/slice inside it
: ADJ.PARENT.LCB.PTRS ( lnk.pfa -- )
VAR.AL
2DUP BytesChanging -ROT L.Size# + +!L \ bump lslice total-size
ADJ.PARENT.NODE.PTRS ;

: BUMP.LATER.CNTL.BLOCK.OFFSETS ( hxxx.pfa -- )
\ Was BUMP.LATER.CONTROL.BLOCK.OFFSETS had too many charactors--tjb
BEGIN
@LINK ?DUP \ later node exist?
WHILE
BytesChanging OVER VAR.AL +!L \ bump offset
REPEAT ;

: ADJUST.POINTERS ( -- ) \ adjusts parent and later outside control blocks
XXXPfa
BEGIN
DUP BUMP.LATER.CNTL.BLOCK.OFFSETS
@PAR @PAR ?DUP
WHILE
DUP ADJ.PARENT.LCB.PTRS
REPEAT ;
\ -----------------------------------------------------------------------
: MOVE.STRU.INSERT ( -- )
PtOfChange 2@ 2DUP BytesChanging + \ ( aL-from aL-to ->
XXXPfa @STRU-AL-END PLUCK PtOfChange 2@ PLUCK - \ bytes to move
CMOVEL>
PtOfChange 2@ BytesChanging 0 LFILL ; \ blank space to zeros

: MOVE.STRU.DELETE ( -- )
PtOfChange 2@ BytesChanging - DUP>R PtOfChange 2@ \ ( aL-from aL-to ->
XXXPfa @STRU-AL-END PLUCK R> - \ bytes to move
CMOVEL ;
\ -----------------------------------------------------------------------
: BUMP.TOT.STRU.SIZE ( -- ) BytesChanging XXXPfa @STRU-AL-START +!L ;

\ -->
\ -----------------------------------------------------------------------
: ADD.SLICE ( -- ) \ adds a slice at slice#
XXXPfa SLICE.AL PtOfChange 2!
XXXPfa @BYTES/ !> BytesChanging
ADJUST.POINTERS MOVE.STRU.INSERT BUMP.TOT.STRU.SIZE
S.TOT@ 1+ S.TOT! \ one slice added
XXXPfa @OF.FORM MAKE.INSTANCE ; \ add defaults inside slice

: INSERT.SLICE ( -- ) ADD.SLICE ; \ insert at current slice

: APPEND.SLICE ( -- ) S.TOT@ SET-SLICE# ADD.SLICE ;
\ -----------------------------------------------------------------------
: DEL.FOR.SLICE ( -- ) \ expects scb.al set!
S.TOT@ 1- S.TOT!
S.CURR@ S.HERE@ < \ on a used node?
IF S.HERE@ 1- S.HERE! THEN
S.CURR@ S.TOT@ >= \ current past total?
IF S.CURR@ 1- S.CURR! THEN ;

: DELETE.SLICE ( -- )
XXXPfa SLICE.AL PtOfChange 2!
S.BYTES@ NEGATE !> BytesChanging
ADJUST.POINTERS MOVE.STRU.DELETE BUMP.TOT.STRU.SIZE
DEL.FOR.SLICE ;
\ -----------------------------------------------------------------------
: ADD.FOR.LSLICE ( -- )
L.SIZE@ BytesChanging + L.SIZE!
L.TOT@ 1+ L.TOT!
BytesChanging LN.BYTES! ;

: ADD.LINK ( ln.prev.bytes -- ) \ in w/ bytes to set in new node's ln.prev
NODE.AL PtOfChange 2!
XXXPfa @BYTES/ LCB.NodeBytes + !> BytesChanging
ADJUST.POINTERS MOVE.STRU.INSERT BUMP.TOT.STRU.SIZE
LN.PREV! ADD.FOR.LSLICE
XXXPfa @OF.FORM MAKE.INSTANCE ; \ add forms inside link

: INSERT.LINK ( -- )
LN.PREV@ \ hold prev bytes for new link
XXXPfa @BYTES/ LCB.NodeBytes + LN.PREV! \ points to new link
ADD.LINK ;

: APPEND.LINK ( -- ) \ first byte after end
LAST-LSLICE LN.BYTES@ \ hold prev bytes for new link
L.TOT@ L.CURR! L.CURROFF@ LN.BYTES@ + L.CURROFF! \ new link pos.
ADD.LINK ;
\ -----------------------------------------------------------------------
: DELETE.FOR.LSLICE ( f-lnk.pfa -- )
L.SIZE@ BytesChanging + L.SIZE!
L.TOT@ 1- L.TOT!
L.CURR@ L.TOT@ >= IF PREV-LSLICE THEN ;
\ prev is guaranteed to be there by ln.prev! below

: DELETE.LINK ( -- )
NODE.AL PtOfChange 2!
LN.BYTES@ NEGATE !> BytesChanging
LN.PREV@ \ hold prev bytes for next moving in
ADJUST.POINTERS MOVE.STRU.DELETE BUMP.TOT.STRU.SIZE
LN.PREV! DELETE.FOR.LSLICE ;

\ -->
\ -----------------------------------------------------------------------
DEFER {DO.TO.SLICE} DEFER {DO.TO.LINK}

: DO.TO.ACTION ( -- )
XXXPfa @TYPE 0>
IF
XXXPfa HSLI? IF {DO.TO.SLICE} ELSE {DO.TO.LINK} THEN
ELSE
." not a slice or link" ABORT
THEN ;

: INSERT ( -- )
['] INSERT.SLICE IS {DO.TO.SLICE}
['] INSERT.LINK IS {DO.TO.LINK}
DO.TO.ACTION ;

: DELETE ( -- )
['] DELETE.SLICE IS {DO.TO.SLICE}
['] DELETE.LINK IS {DO.TO.LINK}
DO.TO.ACTION ;

: APPEND ( -- )
['] APPEND.SLICE IS {DO.TO.SLICE}
['] APPEND.LINK IS {DO.TO.LINK}
DO.TO.ACTION ;

\ --|