Embeds a higher-order stack language in Racket using call-with-values and variadic functions

stack-values.rkt

#lang racket

(require rackunit)

;; Syntax for combining concatenative combinators
;; Isolates the key 'compositional' semantics of concatenative languages
(define (cat f g)
  (lambda xs
    (call-with-values
      (lambda () (call-with-values
                  (lambda () (apply values xs)) f)) g)))

;; Numeric 'combinators'
(define one (lambda xs (apply values 1 xs)))
(define two (lambda xs (apply values 2 xs)))
(define tre (lambda xs (apply values 3 xs)))
(define add (lambda (a b . xs) (apply values (+ a b) xs)))

;; Generic stack effect combinators
(define dup (lambda (a . xs) (apply values a a xs)))
(define zap (lambda (a . xs) (apply values xs)))
(define swap (lambda (a b . xs) (apply values b a xs)))

;; Quoting combinators
(define unit
  (lambda (f . xs)
    (apply values (lambda ys (apply values f ys)) xs)))

(define cons
  (lambda (f b . xs)
    (apply values
           (lambda ys (call-with-values (lambda () (apply values b ys)) f))
           xs)))

;; Higher-order 'dequotation'/'function call' operators
(define call (lambda (f . xs) (apply f xs)))

(define dip
  (lambda (f x . xs)
    (apply values x (list (apply f xs)))))

;; Construct for generating 'quotations'/'anonymous functions'
(define quot
  (lambda (f)
    (lambda xs
      (apply values
             (lambda ys (apply f ys))
             xs))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMBINATOR TESTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 2 [1] cons call == 2 1
(check-equal?
 (call-with-values (cat (cat (cat two (quot one)) cons) call) list)
 (list 1 2))

;; 1 2 3 swap == 1 3 2
(check-equal?
 (call-with-values (cat (cat (cat one two) tre) swap) list)
 (list 2 3 1))

;; 1 dup == 1 1
(check-equal?
 (call-with-values (cat one dup) list)
 (list 1 1))

;; 1 zap ==
(check-equal?
 (call-with-values (cat one zap) list)
 (list))

;; 1 unit call == 1
(check-equal?
 (call-with-values (cat (cat one unit) call) list)
 (list 1))

;; [1 1] call == 1 1
(check-equal?
 (call-with-values (cat (quot (cat one one)) call) list)
 (list 1 1))

;; 2 [1] dip == 1 2
(check-equal?
 (call-with-values (cat (cat two (quot one)) dip) list)
 (list 2 1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MORE TESTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 1 [2] call == 1 2
(check-equal?
 (call-with-values (cat (cat one (quot two)) call) list)
 (list 2 1))

;; [2] [1] cons call swap call == 1 2
(check-equal?
 (call-with-values
  (cat (cat (cat (cat (cat (quot two) (quot one)) cons) call) swap) call) list)
 (list 2 1))

;; 1 2 swap dup == 1 2 [swap dup] call
(check-equal?
 (call-with-values (cat (cat (cat one two) swap) dup) list)
 (call-with-values (cat (cat (cat one two) (quot (cat swap dup))) call) list))

;; 1 2 3 swap add == 1 2 3 [swap add] call
(check-equal?
 (call-with-values (cat (cat (cat (cat one two) tre) swap) add) list)
 (call-with-values
  (cat (cat (cat (cat one two) tre) (quot (cat swap add))) call) list))

;; The concatenative equivalent of `compose` in the Kerby calculus
;; [1] [2] [[call] dip call] cons cons call == 1 2
(check-equal?
 (call-with-values
  (cat (cat (cat
             (cat (cat (quot one) (quot two))
                  (quot (cat (cat (quot call) dip) call))) cons) cons) call)
  list)
 (list 2 1))