From 67d25d837ac55f28a366c0a3b262e439a6e75fc3 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sat, 19 Aug 2017 12:15:28 +0200 Subject: Add AmForth --- amforth-6.5/common/words/map-stack.asm | 61 ++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 amforth-6.5/common/words/map-stack.asm (limited to 'amforth-6.5/common/words/map-stack.asm') diff --git a/amforth-6.5/common/words/map-stack.asm b/amforth-6.5/common/words/map-stack.asm new file mode 100644 index 0000000..48995a1 --- /dev/null +++ b/amforth-6.5/common/words/map-stack.asm @@ -0,0 +1,61 @@ +; ( i*x XT e-addr -- j*y true | i*x false ) +; Tools +; Iterate over a stack + +.if cpu_msp430==1 + HEADER(XT_MAPSTACK,9,"map-stack",DOCOLON) +.endif + +.if cpu_avr8==1 +VE_MAPSTACK: + .dw $ff09 + .db "map-stack",0 + .dw VE_HEAD + .set VE_HEAD = VE_MAPSTACK +XT_MAPSTACK: + .dw DO_COLON +PFA_MAPSTACK: +.endif + .dw XT_DUP + .dw XT_CELLPLUS + .dw XT_SWAP + .dw XT_FETCHE + .dw XT_CELLS + .dw XT_BOUNDS + .dw XT_QDOCHECK + .dw XT_DOCONDBRANCH + DEST(PFA_MAPSTACK3) + .dw XT_DODO +PFA_MAPSTACK1: + .dw XT_I + .dw XT_FETCHE ; -- i*x XT id + .dw XT_SWAP + .dw XT_TO_R + .dw XT_R_FETCH + .dw XT_EXECUTE ; i*x id -- j*y true | i*x false + .dw XT_QDUP + .dw XT_DOCONDBRANCH + DEST(PFA_MAPSTACK2) + .dw XT_R_FROM + .dw XT_DROP + .dw XT_UNLOOP + .dw XT_EXIT +PFA_MAPSTACK2: + .dw XT_R_FROM + .dw XT_TWO + .dw XT_DOPLUSLOOP + DEST(PFA_MAPSTACK1) +PFA_MAPSTACK3: + .dw XT_DROP + .dw XT_ZERO + .dw XT_EXIT + +; +; : map-stack ( i*x XT e-addr -- j*y ) +; dup cell+ swap @e cells bounds ?do +; ( -- i*x XT ) +; i @e swap >r r@ execute +; ?dup if r> drop unloop exit then +; r> +; 2 +loop drop 0 +; ; -- cgit v1.2.3