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