# Forthy Friday (Macro)

**URL:** <https://racket.discourse.group/t/forthy-friday-macro/3547>\
**Category:** Show & Tell\
**Created:** [February 7, 2025, 3:05pm UTC](https://racket.discourse.group/t/forthy-friday-macro/3547 "2025-02-07T15:05:11Z")\
**Posts on this page:** 2\
**Page:** 1

<div class="post-metadata">

**Author:** ![bakgatviooldoos](https://yyz2.discourse-cdn.com/free1/user_avatar/racket.discourse.group/bakgatviooldoos/32/1381_2.png) [@bakgatviooldoos](https://racket.discourse.group/u/bakgatviooldoos)\
**Post date:** [February 7, 2025, 3:05pm UTC](https://racket.discourse.group/t/forthy-friday-macro/3547/1 "2025-02-07T15:05:11Z")

</div>

Hi, Racket Discourse.

I was feeling a bit antsy last night and thought it would be good idea to take a look at [`forsp`](https://github.com/xorvoid/forsp/tree/0c2a5c3eb5029b262b2696f89cc5f5bd9a8910e3), which I'd glanced at before, but forgotten about again in the meantime.

Anthony presents a very interesting semantics with his fusion of `forth` and `lisp` characteristics.

The evaluation is `call-by-push-value` (CBPV), which I find quite pleasing to use.

I translated some of his code into a `Racket` macro, substituting his use of `$` and `^` with `quasiquote` and `unquote`. I also took the liberty of referring to `pop` as `pull`, although this is immaterial.

```scheme
'foo
; pushes the value 'foo onto the stack

`foo
; pulls a value off the stack and binds it to 'foo in the environment

,foo
; refs the value of 'foo in the environment and pushes it onto the stack

 foo
; calls the value of 'foo if it is a procedure, or pushes it onto the stack otherwise

(foo ...)
; a closure which captures the environment, and pushes the thunk of `foo ...` onto the stack

foo bar
; call foo, then call bar

```

I won't claim to be 100% faithful to the author's explanation, since it was merely an exploratory dive into the system, and `forths` in general. Very charming, nonetheless.

Just look at this `Y-combinator`:

```scheme
(`f (`x (,x x) f) dup force) `Y

```

And the obligatory `list?`:

```scheme
(`g (,g Y)) `rec ; a helper for working with Y

 (`self
  `_
  (#false (,_ cdr self) (,_ pair?) if) #true (,_ nil?) if)
 rec
 `list?

```

The implementation is reasonably short, and could probably be streamlined some more:

> <https://gist.github.com/bakgatviooldoos/1e4fe7a9e3fefc10c2cae20d354370ca>

```scheme
#lang racket/base

(require
  (only-in
   racket/function disjoin)
  (only-in
   racket/dict dict-ref dict-set dict?)
  (only-in
   racket/bool nor)
  (for-syntax
   racket/base
   syntax/parse))

(define stack-item?
  (disjoin
   symbol? string? char? exact-integer? rational? boolean?
   null? pair?
   procedure?))

(define stack (make-parameter #false))
(define table (make-parameter #false))

(define (pull)
  (unless (pair? {stack})
    (error 'forsp "cannot pull from an empty stack"))
  (let ([ex (car {stack})])
    {stack (cdr {stack})}
    ex))

(define (push ex)
  (unless (stack-item? ex)
    (error 'forsp "expected a stack-item? found: ~a" ex))
  {stack (cons ex {stack})})

(define (pull/set ex)
  {table (dict-set {table} ex (pull))})

(define (unknown-handler ex)
  (λ _ (error 'forsp "unknown reference: ~a" ex)))

(define (ref/push ex)
  (push (dict-ref {table} ex (unknown-handler ex))))

(define (ref/call ex)
  (define ref (dict-ref {table} ex (unknown-handler ex)))
  (if (procedure? ref) (ref) (push ref)))

(define (nop/push) (push void))

(define (clo/push proc)
  (define tbl {table})
  (push (λ _ (parameterize ([table tbl]) (proc)))))

(define-syntax (forsp stx)
  (syntax-parse stx
    #:datum-literals (nil quote quasiquote unquote unquote-splicing)
    
    [(_ (~or* 'ex:id ex:string ex:char ex:exact-integer ex:boolean nil) exs ...)
     #;quote-push
     #'(begin (push (~? 'ex null)) (forsp exs ...))]

    [(_ `ex:id exs ...)
     #;quote-pull-set
     #'(begin (pull/set 'ex) (forsp exs ...))]

    [(_ ,ex:id exs ...)
     #;quote-ref-push
     #'(begin (ref/push 'ex) (forsp exs ...))]

    #;[(_ ,@ex:expr exs ...)
     #;quote-ref-push-xeno
     #'(begin (push ex) (forsp exs ...))]

    [(_ ex:id exs ...)
     #;quote-ref-call
     #'(begin (ref/call 'ex) (forsp exs ...))]

    [(_ () exs ...)
     #;void-push
     #'(begin (nop/push) (forsp exs ...))]

    [(_ (ex:expr ...) exs ...)
     #;closure-push
     #'(begin (clo/push (λ _ (forsp ex ...))) (forsp exs ...))]

    [(_) #''ok]))

```

And here we have some examples of its usage:

```scheme
(define ∘ compose1)

; some built-in functions available to the user
(define builtins
  `([symbol? . ,(∘ push symbol? pull)]
    [string? . ,(∘ push string? pull)]
    [char? . ,(∘ push char? pull)]
    [integer? . ,(∘ push exact-integer? pull)]
    [rational? . ,(∘ push rational? pull)]
    [boolean? . ,(∘ push boolean? pull)]
    
    [nil? . ,(∘ push null? pull)]
    [pair? . ,(∘ push pair? pull)]
    [dict? . ,(∘ push dict? pull)]
    [closure? . ,(∘ push procedure? pull)]
    
    [not . ,(∘ push not pull)]
    [nor . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (nor a b))))]
    [eq? . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (equal? a b))))]
    
    [cons . ,(∘ push (λ _ (cons (pull) (pull))))]
    [car . ,(∘ push car pull)]
    [cdr . ,(∘ push cdr pull)]
    
    [stack . ,(∘ push stack)]
    [table . ,(∘ push table)]
    
    [cswap . ,(λ _ (when (pull) (let ([a (pull)] [b (pull)]) (push a) (push b))))]

    [< . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (< a b))))]
    [≤ . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (<= a b))))]
    [> . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (> a b))))]
    [≥ . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (>= a b))))]
    [= . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (= a b))))]
    
    [+ . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (+ a b))))]
    [- . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (- a b))))]
    [* . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (* a b))))]
    [/ . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (/ a b))))]
    [« . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (arithmetic-shift a b))))]
    [» . ,(∘ push (λ _ (let ([b (pull)] [a (pull)]) (arithmetic-shift a (- b)))))]
    
    [chars . ,(∘ push string->list pull)]
    
    [print . ,(∘ println pull)]))

(define-syntax-rule
  (fresh-forsp ex ...)
  (parameterize ([stack null]
                 [table builtins])
    (forsp ex ...)))

(fresh-forsp
 ;------------------------------------------------------------
 ; utility procedures
 ;------------------------------------------------------------
 (`_ ,_ ,_) `dup
 (#true cswap) `swap
 (`_ _) `force
 (`a `b `c ,c ,b ,a ,c) `over2
 (`a `b `c ,b ,a ,c) `rot
 
 (force cswap `_ force) `if
 (`f `t `c `fn ,f ,t ,c fn) `endif

 (`f (`x (,x x) f) dup force) `Y
 (`g (,g Y)) `rec

 (`self
  `_
  (#false (,_ cdr self) (,_ pair?) if) #true (,_ nil?) if)
 rec
 `list?
 ;------------------------------------------------------------

 '-----------------------------
 `dashed-line

 'say-hello print
 "Hello, world!" print
 dashed-line print

 'make-a-list print
 nil 3 cons 2 cons 1 cons print
 dashed-line print

 'is-this-a-list? print
 2 2 cons dup print
 list? print
 dashed-line print

 'get-the-car print
 3 2 cons dup print
 car print
 dashed-line print
 
 'get-the-cdr print
 3 2 cons dup print
 cdr print
 dashed-line print

 'is-3=4? print
 (#false print) (#true print) 3 4 eq? if
 dashed-line print

 'is-1=1? print
 ,if (1 1 eq?)
 (#true print)
 (#false print)
 endif
 dashed-line print

 '1+2= print
 1 2 + print
 dashed-line print
 
 '2-1= print
 2 1 - print
 dashed-line print
 
 '2*2= print
 2 2 * print
 dashed-line print
 
 '2/2= print
 2 2 / print
 dashed-line print
 
 (nor not) `or
 (`x `y ,y not ,x not nor) `and
 (and not) `nand

 'false-or-false print
 #f #f or print
 dashed-line print
 
 'true-and-true print
 #t #t and print
 dashed-line print
 
 'false-nand-false print
 #f #f nand print
 dashed-line print
 
 (`self
  `n
  (,n 1 - self ,n *) 1 (0 ,n eq?) if)
 rec
 `factorial

 'factorial-5 print
 5 factorial print
 dashed-line print
 
 'factorial-7 print
 7 factorial print
 dashed-line print
 
 (`self
  `n `fn
  (fn ,fn ,n 1 - self) () (0 ,n eq?) if)
 rec
 `repeat

 1 (dup) 2 repeat
 'print-1-times-3 print
 (print) 3 repeat
 dashed-line print

 (stack nil?) `stack-nil?
 'is-the-stack-empty? print
 stack-nil? print
 dashed-line print
 
 '1-jumps-over-the-others print
 1 2 3 stack print
 over2
 stack print
 dashed-line print

 'rotate-3 print
 (rot stack print)
 3 repeat
 dashed-line print)

```

```scheme
'say-hello
"Hello, world!"
'-----------------------------
'make-a-list
'(1 2 3)
'-----------------------------
'is-this-a-list?
'(2 . 2)
#f
'-----------------------------
'get-the-car
'(2 . 3)
2
'-----------------------------
'get-the-cdr
'(2 . 3)
3
'-----------------------------
'is-3=4?
#f
'-----------------------------
'is-1=1?
#t
'-----------------------------
'1+2=
3
'-----------------------------
'2-1=
1
'-----------------------------
'2*2=
4
'-----------------------------
'2/2=
1
'-----------------------------
'false-or-false
#f
'-----------------------------
'true-and-true
#t
'-----------------------------
'false-nand-false
#t
'-----------------------------
'factorial-5
120
'-----------------------------
'factorial-7
5040
'-----------------------------
'print-1-times-3
1
1
1
'-----------------------------
'is-the-stack-empty?
#t
'-----------------------------
'1-jumps-over-the-others
'(3 2 1)
'(1 3 2 1)
'-----------------------------
'rotate-3
'(2 1 3 1)
'(3 2 1 1)
'(1 3 2 1)
'-----------------------------
'ok
> 

```

Have a good weekend everyone!

* * *

Edit: I thought of a cute way to incorporate keywords:

```scheme
20 'john #: man
21 'mary #: woman

#:woman `name `age
,name 'woman cons print
,age 'woman cons print

#:man `name `age
,name 'man cons print
,age 'man cons print

'flounder #: fish
#:bird `type

;=> '(woman . mary)
;=> '(woman . 21)
;=> '(man . john)
;=> '(man . 20)

;=> forsp: expected the keyword #:bird, found: #:fish

```

When the macro encounters the empty keyword, `#:`, it "quotes" the next identifier as a keyword, and pushes it onto the stack.

Then, when the macro encounters any other keyword, it pulls the next item from the stack, which must be a keyword equal to it. If it is not, an error is raised.

---

<div class="post-metadata">

**Author:** ![bakgatviooldoos](https://yyz2.discourse-cdn.com/free1/user_avatar/racket.discourse.group/bakgatviooldoos/32/1381_2.png) [@bakgatviooldoos](https://racket.discourse.group/u/bakgatviooldoos)\
**Post date:** [February 13, 2025, 6:12pm UTC](https://racket.discourse.group/t/forthy-friday-macro/3547/2 "2025-02-13T18:12:03Z")

</div>

Named stacks aren't a bad use for keywords, either:

```scheme
(sporklet
 (`_) `pop
 (`_,_₂) `dup
 [`_ ,@(abs _)] `abs ; I try to use square brackets for "foreign" functions
 ,+ `add
 [`y `x ,@(- x y)] `sub
 [`y `x ,@(* x y)] `*
 (dup *) `sqr
 
 (`#:x `#:y `#:z
  #:z pop
  #:y dup sqr `#:
  #:x sqr `#:
  #: add
  #:y abs `#:
  #: sub)
 `f

 3 2 1 f
 stack print)
;=> '(3)

```

I came across the idea from [this blog](https://www.dawn-lang.org/posts/introducing-dawn-(part-1)/#fn1), although it seems as though the author has been inactive on the project for a while (speculation).

P.S. aren't `let` and friends just grand?  
The above becomes:

```scheme
(let* ((out (→ (mk-clos (let* ((_ (←))) (void)))))
       (pop (←))
       (out (→ (mk-clos (let* ((_ (←)) (out (→ _)) (out (→ _))) (void)))))
       (dup (←))
       (out (→ (mk-clos (let* ((_ (←)) (out (→ (abs _)))) (void)))))
       (abs (←))
       (out (→ core:add))
       (add (←))
       (out (→ (mk-clos (let* ((y (←)) (x (←)) (out (→ (- x y)))) (void)))))
       (sub (←))
       (out (→ (mk-clos (let* ((y (←)) (x (←)) (out (→ (* x y)))) (void)))))
       (* (←))
       (out (→ (mk-clos (let* ((out (⇒ dup)) (out (⇒ *))) (void)))))
       (sqr (←))
       (out
        (→
         (mk-clos
          (let* ((pin (hosts))
                 (who (≫ '#:x))
                 (who (≫ '#:y))
                 (who (≫ '#:z))
                 (who (♯ '#:z))
                 (out (⇒ pop))
                 (who (♯ '#:y))
                 (out (⇒ dup))
                 (out (⇒ sqr))
                 (who (≫ '#:))
                 (who (♯ '#:x))
                 (out (⇒ sqr))
                 (who (≫ '#:))
                 (who (♯ '#:))
                 (out (⇒ add))
                 (who (♯ '#:y))
                 (out (⇒ abs))
                 (who (≫ '#:))
                 (who (♯ '#:))
                 (out (⇒ sub)))
            (∝ pin (hosts))))))
       (f (←))
       (out (→ '3))
       (out (→ '2))
       (out (→ '1))
       (out (⇒ f))
       (out (⇒ core:stack))
       (out (⇒ core:print)))
  (void))

```

where the repeated `out` identifier, for example, is created with `generate-temporary`.

* * *

Edit: one could also write the above without "pushing", and instead "pulling":

```scheme
(`#:x `#:y `#:z
  #:z pop
  #:y dup sqr swap
  #:x sqr
  #:y abs swap
  #: ,#:y ,#:x add ,#:y sub)

```

Although the uses of `swap` are kind of meh.