Create a gist now

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Embeds a higher-order stack language in Racket using call-with-values and variadic functions
#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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment