144 lines
4.0 KiB
Forth
144 lines
4.0 KiB
Forth
\ Copyright 2024 Bradley D. Nelson
|
|
\
|
|
\ Licensed under the Apache License, Version 2.0 (the "License");
|
|
\ you may not use this file except in compliance with the License.
|
|
\ You may obtain a copy of the License at
|
|
\
|
|
\ http://www.apache.org/licenses/LICENSE-2.0
|
|
\
|
|
\ Unless required by applicable law or agreed to in writing, software
|
|
\ distributed under the License is distributed on an "AS IS" BASIS,
|
|
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
\ See the License for the specific language governing permissions and
|
|
\ limitations under the License.
|
|
|
|
vocabulary arrays also internals also arrays definitions
|
|
|
|
128 constant stack-depth
|
|
|
|
( Stack for arrays )
|
|
create astack stack-depth cells allot
|
|
variable ap astack ap !
|
|
: apush ( a -- ) cell ap +! ap @ ! ;
|
|
: apop ( -- a ) ap @ @ cell negate ap +! ;
|
|
: top ( -- a ) ap @ @ ;
|
|
: under ( -- a ) ap @ cell - @ ;
|
|
|
|
( Secondary stack for arrays )
|
|
create arstack stack-depth cells allot
|
|
variable arp arstack arp !
|
|
: >a apop cell arp +! arp @ ! ;
|
|
: a> arp @ @ cell negate arp +! apush ;
|
|
|
|
( Array types )
|
|
0 constant MIXED
|
|
1 constant STRING
|
|
2 constant INTEGER
|
|
3 constant REAL
|
|
create array-sizes cell , 1 , cell , 4 ,
|
|
: >esize ( type -- n ) cells array-sizes + @ ;
|
|
|
|
\ ref n ^type data...
|
|
3 cells constant header-size
|
|
: >type ( a -- a ) -1 cells + ;
|
|
: >count ( a -- a ) -2 cells + ;
|
|
: >ref ( a -- a ) -3 cells + ;
|
|
|
|
( Size of array data in bytes )
|
|
: bytes ( a -- n ) dup >type @ >esize swap >count @ * ;
|
|
|
|
( Create an uninitialized array )
|
|
: array ( n type -- a )
|
|
2dup >esize * header-size + allocate throw header-size + apush
|
|
top >type ! top >count ! 0 top >ref ! ;
|
|
|
|
( Reference counting for arrays )
|
|
: ref ( a -- ) 1 over >ref +! ;
|
|
: unref ( a -- )
|
|
dup 0= if drop exit then
|
|
-1 over >ref +!
|
|
dup >ref @ 0< if
|
|
dup >type @ MIXED = if
|
|
dup dup >count @ 0 ?do
|
|
dup @ recurse cell+
|
|
loop
|
|
drop
|
|
then
|
|
header-size - free throw exit
|
|
then drop ;
|
|
|
|
( Stack manipulation )
|
|
: adrop ( a: a -- ) apop unref ;
|
|
: anip ( a: a b -- b ) apop apop unref apush ;
|
|
: adup ( a: a -- a a ) top ref apush ;
|
|
: aswap ( a: a b -- b a ) apop apop swap apush apush ;
|
|
|
|
( Index into the top of the stack )
|
|
: a@ ( n a: a -- a: a ) cells top + @ ref adrop apush ;
|
|
|
|
( Raw array creation words )
|
|
: empty ( -- a: a ) 0 MIXED array ;
|
|
: box ( a: a -- a ) apop 1 MIXED array top ! ;
|
|
: _s ( a n -- a: a ) dup STRING array top swap cmove ;
|
|
: _c ( ch -- a: a ) 1 STRING array top c! ;
|
|
: _i ( n -- a: a ) 1 INTEGER array top ! ;
|
|
: _f ( f: n -- a: a ) 1 REAL array top sf! ;
|
|
: _s" postpone s" state @ if postpone _s else _s then ; immediate
|
|
|
|
: aconstant create apop , does> @ ref apush ;
|
|
|
|
( Convert integer array to floats )
|
|
: n>f
|
|
top >count @ REAL array
|
|
under top top >count @ 0 ?do over @ s>f dup sf! sfloat+ >r cell+ r> loop 2drop anip ;
|
|
|
|
( Force integers to real. )
|
|
: binuminal
|
|
top >type @ INTEGER = under >type @ REAL = and if n>f then
|
|
under >type @ INTEGER = top >type @ REAL = and if apop n>f apush then
|
|
;
|
|
|
|
0 value layer
|
|
: lst ( a -- )
|
|
layer spaces
|
|
dup >type @ case
|
|
MIXED of
|
|
." [" cr
|
|
2 +to layer
|
|
dup >count @ 0 ?do
|
|
dup @ recurse cell+ cr
|
|
loop
|
|
drop
|
|
-2 +to layer
|
|
layer spaces ." ]"
|
|
endof
|
|
STRING of dup >count @ type endof
|
|
INTEGER of dup >count @ 0 ?do dup @ . cell+ loop drop endof
|
|
REAL of dup >count @ 0 ?do dup sf@ f. sfloat+ loop drop endof
|
|
endcase
|
|
;
|
|
: a. ( a -- ) top lst adrop ;
|
|
|
|
: catenate ( a: a a -- a ) ( catenate )
|
|
binuminal
|
|
top >type @ under >type @ = if
|
|
under >count @ top >count @ + top >type @ array apop >r
|
|
under r@ under bytes cmove
|
|
top r@ under bytes + top bytes cmove
|
|
under under bytes 0 fill
|
|
top top bytes 0 fill
|
|
r> apush anip anip
|
|
exit
|
|
then
|
|
top >type @ MIXED = if apop box apush recurse exit then
|
|
under >type @ MIXED = if box recurse exit then
|
|
apop apop 2 MIXED array top cell+ ! top !
|
|
;
|
|
: ,c catenate ;
|
|
|
|
( Building arrays on the stack. )
|
|
: [[ ap @ ;
|
|
: ]] ap @ swap - cell/ empty for aft aswap box aswap ,c then next ;
|
|
|
|
previous previous forth definitions
|