Skip to content

Instantly share code, notes, and snippets.

@crcx
Last active January 19, 2024 16:49
Show Gist options
  • Save crcx/8060687 to your computer and use it in GitHub Desktop.
Save crcx/8060687 to your computer and use it in GitHub Desktop.
Port of Retro's combinator implementations to Forth. This also has a gForth implementation of quotations from Alexander Skobelev.
\ This is an implementation of quotations and some combinators
\ for use with Forth. The combinators should work with most
\ Forth systems; the quotation implementation here is gForth
\ specific.
\ ************************************************************
\ dip
\ Stack: value quote -- value
\ Executes a quotation with a value being temporarily removed
\ from the stack. The value is restored after the quotation
\ is executed.
\
\ This is similar to a form like:
\
\ >r ... r>
\
\ Where the ... is the code in the quotation.
: dip swap >r execute r> ;
\ ************************************************************
\ sip
\ Stack: value quote -- value
\ Executes a quotation. A copy of the value is placed back on
\ the stack after the quotation is executed.
\ This is similar to a form like:
\
\ dup >r ... r>
\
\ Where the ... is the code in the quotation.
: sip over >r execute r> ;
\ bi
\ Stack: value quote1 quote2 -- ?
\ Make a copy of the value, and apply quote1. After execution
\ completes, put the value on the stack and execute the second
\ quote.
\
\ E.g.,:
\
\ 12 [ 3 * ] [ 4 * ] bi
\
\ Equates to:
\
\ 12 3 * 12 4 *
: bi ['] sip dip execute ;
\ bi*
\ Stack: value1 value2 quote1 quote2 -- ?
\ Move value2 and quote2 off the stack, and execute quote1.
\ After this completes, restore value2 and quote2 to the stack
\ and execute quote2.
\
\ E.g.,:
\
\ 2 4 [ 3 * ] [ 5 * ] bi*
\
\ Equates to:
\
\ 2 3 * 4 5 *
: bi* ['] dip dip execute ;
\ bi@
\ Stack: value1 value2 quote -- ?
\ Move value2 off the stack and execute quote. Then return
\ value2 to the stack, and execute the quote again.
\
\ E.g.,:
\
\ 2 4 [ 3 * ] bi@
\
\ Equates to:
\
\ 2 3 * 4 3 *
: bi@ dup bi* ;
\ tri
\ Stack: value quote1 quote2 quote3 -- ?
\ Execute each quote against a copy of the value.
\
\ E.g.,
\
\ 1 [ 2 * ] [ 3 * ] [ 4 * ] tri
\
\ Equates to:
\
\ 1 2 * 1 3 * 1 4 *
: tri swap >r ['] sip dip sip r> execute ;
\ ************************************************************
\ tri*
\ Stack: value1 value2 value3 quote1 quote2 quote3 -- ?
\ Execute quote1 against value1, quote2 against value2, and
\ quote3 against value3.
\
\ E.g.,
\
\ 1 2 3 [ 5 * ] [ 6 * ] [ 7 * ] tri*
\
\ Equates to:
\
\ 1 5 * 2 6 * 3 7 *
\
\ Thanks to i440r in #forth for helping implement the helper
\ function (tri*) which reshuffles the initial stack of:
\ abcxyz to axbycz.
: (tri*) swap 2>r -rot r> swap r> ;
: tri* (tri*) 2>r 2>r execute 2r> execute 2r> execute ;
\ tri@
\ Stack: value1 value2 value3 quote -- ?
\ Move value2 and value3 off the stack, and execute quote.
\ Then restore value2 and execute the quote again. Finally
\ this restores value3 and executes the quote a final time.
\
\ E.g.,
\
\ 1 2 3 [ 6 + ] tri@
\
\ Equates to:
\
\ 1 6 + 2 6 + 3 6 +
: tri@ dup dup tri* ;
\ ************************************************************
\ I've not found a portable way to implement quotations, so
\ the implementation here is from the Dec 18, 2013 post on
\ C.L.F. by Alexander Skobelev titled "What about code blocks
\ (not Forth blocks)?"
\
\ Following some discussion in the thread, I've renamed the
\ words to [: and ;]. In Retro and Parable these are [ and ],
\ but those are used for other purposes in Forth.
0 >body constant BODY-OFFSET
:noname ; @ constant CFA-VALUE
variable cfa-addr
\ LOCAL-EXIT is EXIT that keeps locals
: local-exit postpone ;s ; immediate
: [: ( -- )
\ C: build a block prefix: keep HERE in cfa-addr, compile
\ in CFA-VALUE
postpone ahead align HERE dup cfa-addr ! BODY-OFFSET allot
CFA-VALUE swap ! ; immediate
: ;] ( E: -- xt)
postpone local-exit postpone then cfa-addr @
postpone literal ; immediate
\ ************************************************************
\ When these combinators are loaded, the Forth system will
\ behave differently: they replace standard conditionals and
\ add new loop combinations.
\ A helper function
: 0; dup 0= if drop rdrop then ;
\ if
\ Stack: flag true-quote false-quote --
\ Execute true-quote if flag is true, or false-quote if not.
\
\ E.g.,
\
\ true [ 1 ] [ 2 ] if
\
\ Equates to this in standard Forth:
\
\ true if 1 else 2 then
: if rot if drop execute else nip execute then ;
\ if-true
\ Stack: flag quote --
\ Execute quote if flag is true
: if-true [: ;] if ;
\ if-false
\ Stack: flag quote --
\ Execute quote if flag is false
: if-false [: ;] swap if ;
\ repeat
\ Stack: count quote --
\ Execute quote the specified number of times.
: repeat swap 0 ?do [: execute ;] sip loop drop ;
\ while-true
\ Stack: quote --
\ Execute quote repeatedly until quote returns a flase flag.
: while-true
[: begin dup dip swap 0; drop again ;] execute drop ;
\ while-false
\ Stack: quote --
\ Execute quote repeatedly until quote returns a true flag.
: while-false
[: begin dup dip swap -1 xor 0; drop again ;] execute drop ;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment