Add CK-macros for composable higher-order macros (#30)
ober
24921fed6a1681a2480a57ba58f50be6b00e3454
new file mode 100644 --- /dev/null +++ b/lib/std/misc/ck-macros.sls @@ -0,0 +1,268 @@ +#!chezscheme +;;; (std misc ck-macros) — CK abstract machine for composable higher-order macros +;;; +;;; Based on Oleg Kiselyov's CK machine: composable macros built entirely +;;; with syntax-rules, no syntax-case needed. CK macros pass their results +;;; to a continuation stack, enabling composition at macro-expansion time. +;;; +;;; Usage: +;;; (ck () (c-cons '1 '(2 3))) => (1 2 3) +;;; (ck () (c-map (c-cons 'x) '(1 2 3))) => ((x . 1) (x . 2) (x . 3)) +;;; (ck () (c-reverse '(a b c))) => (c b a) +;;; +;;; All CK macro arguments must be either: +;;; - Quoted values: '(datum) or 'atom +;;; - CK expressions: (c-op args ...) +;;; The ck machine evaluates nested CK expressions automatically. + +(library (std misc ck-macros) + (export ck c-quote c-cons c-car c-cdr c-null? c-if + c-map c-filter c-foldr c-append c-reverse c-length) + (import (chezscheme)) + + ;; --------------------------------------------------------------------------- + ;; The CK machine + ;; + ;; Stack frames are lists (op saved-arg ...). When a value 'v is produced, + ;; the machine calls (op s 'v saved-arg ...) where s is the remaining stack. + ;; --------------------------------------------------------------------------- + + (define-syntax ck + (syntax-rules (quote) + ;; Value with empty stack: done + [(ck () 'v) 'v] + ;; Value with stack: apply top frame + ;; Frame = (op saved ...), call as (op remaining-stack 'v saved ...) + [(ck ((op saved ...) . s) 'v) + (op s 'v saved ...)] + ;; CK expression: dispatch to operator + [(ck s (op arg ...)) + (op s arg ...)])) + + ;; --------------------------------------------------------------------------- + ;; c-quote + ;; --------------------------------------------------------------------------- + + (define-syntax c-quote + (syntax-rules () + [(c-quote s v) (ck s 'v)])) + + ;; --------------------------------------------------------------------------- + ;; c-cons + ;; --------------------------------------------------------------------------- + + (define-syntax c-cons + (syntax-rules (quote) + [(c-cons s 'a 'b) (ck s '(a . b))] + ;; Second arg needs evaluation + [(c-cons s 'a b) + (ck ((c-cons-k 'a) . s) b)] + ;; First arg needs evaluation + [(c-cons s a b) + (ck ((c-cons-k2 b) . s) a)])) + + ;; Called as (c-cons-k s 'v 'a) — v is evaluated second arg, a is saved first + (define-syntax c-cons-k + (syntax-rules (quote) + [(c-cons-k s 'b 'a) (ck s '(a . b))])) + + ;; Called as (c-cons-k2 s 'v b) — v is evaluated first arg, b still needs eval + (define-syntax c-cons-k2 + (syntax-rules (quote) + [(c-cons-k2 s 'a b) (c-cons s 'a b)])) + + ;; --------------------------------------------------------------------------- + ;; c-car / c-cdr + ;; --------------------------------------------------------------------------- + + (define-syntax c-car + (syntax-rules (quote) + [(c-car s '(h . t)) (ck s 'h)] + [(c-car s e) (ck ((c-car-k) . s) e)])) + + (define-syntax c-car-k + (syntax-rules (quote) + [(c-car-k s 'v) (c-car s 'v)])) + + (define-syntax c-cdr + (syntax-rules (quote) + [(c-cdr s '(h . t)) (ck s 't)] + [(c-cdr s e) (ck ((c-cdr-k) . s) e)])) + + (define-syntax c-cdr-k + (syntax-rules (quote) + [(c-cdr-k s 'v) (c-cdr s 'v)])) + + ;; --------------------------------------------------------------------------- + ;; c-null? + ;; --------------------------------------------------------------------------- + + (define-syntax c-null? + (syntax-rules (quote) + [(c-null? s '()) (ck s '#t)] + [(c-null? s '(h . t)) (ck s '#f)] + [(c-null? s 'v) (ck s '#f)] + [(c-null? s e) (ck ((c-null?-k) . s) e)])) + + (define-syntax c-null?-k + (syntax-rules (quote) + [(c-null?-k s 'v) (c-null? s 'v)])) + + ;; --------------------------------------------------------------------------- + ;; c-if + ;; --------------------------------------------------------------------------- + + (define-syntax c-if + (syntax-rules (quote) + [(c-if s '#f then else) (ck s else)] + [(c-if s '#t then else) (ck s then)] + [(c-if s 'other then else) (ck s then)] + [(c-if s test then else) + (ck ((c-if-k then else) . s) test)])) + + ;; Called as (c-if-k s 'v then else) + (define-syntax c-if-k + (syntax-rules (quote) + [(c-if-k s 'v then else) (c-if s 'v then else)])) + + ;; --------------------------------------------------------------------------- + ;; c-map + ;; --------------------------------------------------------------------------- + + (define-syntax c-map + (syntax-rules (quote) + [(c-map s (f ...) '()) (ck s '())] + [(c-map s (f ...) '(h . t)) + (ck ((c-map-k (f ...) 't) . s) (f ... 'h))] + [(c-map s f e) (ck ((c-map-k2 f) . s) e)])) + + ;; Head mapped to 'v; now map tail + ;; Called as (c-map-k s 'v (f ...) 't) + (define-syntax c-map-k + (syntax-rules (quote) + [(c-map-k s 'v (f ...) 'tail) + (ck ((c-map-k3 'v) . s) (c-map (f ...) 'tail))])) + + ;; Tail mapped to 'rest; cons with head + ;; Called as (c-map-k3 s 'rest 'head) + (define-syntax c-map-k3 + (syntax-rules (quote) + [(c-map-k3 s 'rest 'head) (ck s '(head . rest))])) + + ;; List evaluated to 'v; now map + (define-syntax c-map-k2 + (syntax-rules (quote) + [(c-map-k2 s 'v f) (c-map s f 'v)])) + + ;; --------------------------------------------------------------------------- + ;; c-filter + ;; --------------------------------------------------------------------------- + + (define-syntax c-filter + (syntax-rules (quote) + [(c-filter s (p ...) '()) (ck s '())] + [(c-filter s (p ...) '(h . t)) + (ck ((c-filter-k (p ...) 'h 't) . s) (p ... 'h))] + [(c-filter s p e) (ck ((c-filter-k2 p) . s) e)])) + + ;; Predicate result: (c-filter-k s 'v (p ...) 'h 't) + (define-syntax c-filter-k + (syntax-rules (quote) + [(c-filter-k s '#f (p ...) 'h 't) + (ck s (c-filter (p ...) 't))] + [(c-filter-k s 'v (p ...) 'h 't) + (ck ((c-filter-k3 'h) . s) (c-filter (p ...) 't))])) + + ;; Filtered tail ready; cons head + (define-syntax c-filter-k3 + (syntax-rules (quote) + [(c-filter-k3 s 'rest 'h) (ck s '(h . rest))])) + + (define-syntax c-filter-k2 + (syntax-rules (quote) + [(c-filter-k2 s 'v p) (c-filter s p 'v)])) + + ;; --------------------------------------------------------------------------- + ;; c-foldr + ;; --------------------------------------------------------------------------- + + (define-syntax c-foldr + (syntax-rules (quote) + [(c-foldr s (f ...) 'init '()) (ck s 'init)] + [(c-foldr s (f ...) 'init '(h . t)) + (ck ((c-foldr-k (f ...) 'h) . s) (c-foldr (f ...) 'init 't))] + [(c-foldr s f init e) (ck ((c-foldr-k2 f init) . s) e)])) + + ;; Tail folded to 'v; apply f to h and v + (define-syntax c-foldr-k + (syntax-rules (quote) + [(c-foldr-k s 'v (f ...) 'h) (ck s (f ... 'h 'v))])) + + (define-syntax c-foldr-k2 + (syntax-rules (quote) + [(c-foldr-k2 s 'v f init) (c-foldr s f init 'v)])) + + ;; --------------------------------------------------------------------------- + ;; c-append + ;; --------------------------------------------------------------------------- + + (define-syntax c-append + (syntax-rules (quote) + [(c-append s '() 'b) (ck s 'b)] + [(c-append s '(h . t) 'b) + (ck ((c-append-k 'h) . s) (c-append 't 'b))] + [(c-append s 'a b) (ck ((c-append-k2 'a) . s) b)] + [(c-append s a b) (ck ((c-append-k3 b) . s) a)])) + + (define-syntax c-append-k + (syntax-rules (quote) + [(c-append-k s 'rest 'h) (ck s '(h . rest))])) + + (define-syntax c-append-k2 + (syntax-rules (quote) + [(c-append-k2 s 'b 'a) (c-append s 'a 'b)])) + + (define-syntax c-append-k3 + (syntax-rules (quote) + [(c-append-k3 s 'a b) (c-append s 'a b)])) + + ;; --------------------------------------------------------------------------- + ;; c-reverse (accumulator-based, O(n)) + ;; --------------------------------------------------------------------------- + + (define-syntax c-reverse + (syntax-rules (quote) + [(c-reverse s 'lst) (c-reverse* s '() 'lst)] + [(c-reverse s e) (ck ((c-reverse-k) . s) e)])) + + (define-syntax c-reverse-k + (syntax-rules (quote) + [(c-reverse-k s 'v) (c-reverse s 'v)])) + + (define-syntax c-reverse* + (syntax-rules (quote) + [(c-reverse* s 'acc '()) (ck s 'acc)] + [(c-reverse* s 'acc '(h . t)) (c-reverse* s '(h . acc) 't)])) + + ;; --------------------------------------------------------------------------- + ;; c-length + ;; + ;; Returns length as a Peano-encoded list: '() = 0, '(s) = 1, '(s s) = 2. + ;; Use (length (ck () (c-length ...))) to get a runtime number. + ;; --------------------------------------------------------------------------- + + (define-syntax c-length + (syntax-rules (quote) + [(c-length s 'lst) (c-length* s '() 'lst)] + [(c-length s e) (ck ((c-length-k) . s) e)])) + + (define-syntax c-length-k + (syntax-rules (quote) + [(c-length-k s 'v) (c-length s 'v)])) + + (define-syntax c-length* + (syntax-rules (quote) + [(c-length* s 'acc '()) (ck s 'acc)] + [(c-length* s 'acc '(h . t)) (c-length* s '(s . acc) 't)])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-ck-macros.ss @@ -0,0 +1,270 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc ck-macros)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +;; --------------------------------------------------------------------------- +;; c-quote +;; --------------------------------------------------------------------------- + +(test "c-quote returns a value" + (lambda () + (assert-equal (ck () (c-quote hello)) 'hello "quote atom") + (assert-equal (ck () (c-quote (a b c))) '(a b c) "quote list"))) + +;; --------------------------------------------------------------------------- +;; c-cons +;; --------------------------------------------------------------------------- + +(test "c-cons builds a pair" + (lambda () + (assert-equal (ck () (c-cons '1 '2)) '(1 . 2) "pair") + (assert-equal (ck () (c-cons 'a '(b c))) '(a b c) "cons onto list"))) + +(test "c-cons with nested CK expression" + (lambda () + (assert-equal (ck () (c-cons 'a (c-cons 'b '()))) '(a b) "nested cons"))) + +;; --------------------------------------------------------------------------- +;; c-car / c-cdr +;; --------------------------------------------------------------------------- + +(test "c-car extracts head" + (lambda () + (assert-equal (ck () (c-car '(x y z))) 'x "car"))) + +(test "c-cdr extracts tail" + (lambda () + (assert-equal (ck () (c-cdr '(x y z))) '(y z) "cdr"))) + +(test "c-car of c-cons" + (lambda () + (assert-equal (ck () (c-car (c-cons 'a '(b)))) 'a "car of cons"))) + +(test "c-cdr of c-cons" + (lambda () + (assert-equal (ck () (c-cdr (c-cons 'a '(b)))) '(b) "cdr of cons"))) + +;; --------------------------------------------------------------------------- +;; c-null? +;; --------------------------------------------------------------------------- + +(test "c-null? on empty list" + (lambda () + (assert-equal (ck () (c-null? '())) #t "null? of ()"))) + +(test "c-null? on non-empty list" + (lambda () + (assert-equal (ck () (c-null? '(a b))) #f "null? of (a b)"))) + +(test "c-null? on atom" + (lambda () + (assert-equal (ck () (c-null? 'x)) #f "null? of atom"))) + +;; --------------------------------------------------------------------------- +;; c-if +;; --------------------------------------------------------------------------- + +(test "c-if true branch" + (lambda () + (assert-equal (ck () (c-if '#t 'yes 'no)) 'yes "if true"))) + +(test "c-if false branch" + (lambda () + (assert-equal (ck () (c-if '#f 'yes 'no)) 'no "if false"))) + +(test "c-if with CK condition" + (lambda () + (assert-equal (ck () (c-if (c-null? '()) 'empty 'notempty)) + 'empty "if null? empty"))) + +(test "c-if with CK condition false" + (lambda () + (assert-equal (ck () (c-if (c-null? '(a)) 'empty 'notempty)) + 'notempty "if null? non-empty"))) + +;; --------------------------------------------------------------------------- +;; c-map +;; --------------------------------------------------------------------------- + +(test "c-map empty list" + (lambda () + (assert-equal (ck () (c-map (c-car) '())) '() "map empty"))) + +(test "c-map c-car over list of pairs" + (lambda () + (assert-equal (ck () (c-map (c-car) '((a 1) (b 2) (c 3)))) + '(a b c) "map car"))) + +(test "c-map c-cdr over list of pairs" + (lambda () + (assert-equal (ck () (c-map (c-cdr) '((a 1) (b 2) (c 3)))) + '((1) (2) (3)) "map cdr"))) + +(test "c-map c-cons with partial application" + (lambda () + (assert-equal (ck () (c-map (c-cons 'x) '(1 2 3))) + '((x . 1) (x . 2) (x . 3)) "map cons"))) + +;; --------------------------------------------------------------------------- +;; c-filter +;; --------------------------------------------------------------------------- + +;; Define a CK predicate: c-pair? returns #t for pairs, #f for atoms +(define-syntax c-pair? + (syntax-rules (quote) + [(c-pair? s '(a . d)) (ck s '#t)] + [(c-pair? s 'v) (ck s '#f)])) + +(test "c-filter selects matching elements" + (lambda () + (assert-equal (ck () (c-filter (c-pair?) '((a 1) b (c 2) d))) + '((a 1) (c 2)) "filter pairs"))) + +(test "c-filter empty list" + (lambda () + (assert-equal (ck () (c-filter (c-pair?) '())) '() "filter empty"))) + +(test "c-filter keeps all" + (lambda () + (assert-equal (ck () (c-filter (c-pair?) '((a) (b) (c)))) + '((a) (b) (c)) "filter all match"))) + +(test "c-filter keeps none" + (lambda () + (assert-equal (ck () (c-filter (c-pair?) '(a b c))) + '() "filter none match"))) + +;; --------------------------------------------------------------------------- +;; c-foldr +;; --------------------------------------------------------------------------- + +(test "c-foldr with c-cons reconstructs list" + (lambda () + (assert-equal (ck () (c-foldr (c-cons) '() '(a b c))) + '(a b c) "foldr cons"))) + +(test "c-foldr empty list returns init" + (lambda () + (assert-equal (ck () (c-foldr (c-cons) '(x) '())) + '(x) "foldr empty"))) + +;; --------------------------------------------------------------------------- +;; c-append +;; --------------------------------------------------------------------------- + +(test "c-append two lists" + (lambda () + (assert-equal (ck () (c-append '(a b) '(c d))) + '(a b c d) "append"))) + +(test "c-append empty first" + (lambda () + (assert-equal (ck () (c-append '() '(x y))) + '(x y) "append empty first"))) + +(test "c-append empty second" + (lambda () + (assert-equal (ck () (c-append '(x y) '())) + '(x y) "append empty second"))) + +(test "c-append both empty" + (lambda () + (assert-equal (ck () (c-append '() '())) + '() "append both empty"))) + +;; --------------------------------------------------------------------------- +;; c-reverse +;; --------------------------------------------------------------------------- + +(test "c-reverse a list" + (lambda () + (assert-equal (ck () (c-reverse '(a b c))) + '(c b a) "reverse"))) + +(test "c-reverse empty" + (lambda () + (assert-equal (ck () (c-reverse '())) + '() "reverse empty"))) + +(test "c-reverse singleton" + (lambda () + (assert-equal (ck () (c-reverse '(x))) + '(x) "reverse singleton"))) + +;; --------------------------------------------------------------------------- +;; c-length +;; --------------------------------------------------------------------------- + +(test "c-length of empty list" + (lambda () + (assert-equal (ck () (c-length '())) '() "length 0"))) + +(test "c-length of 3-element list" + (lambda () + (assert-equal (length (ck () (c-length '(a b c)))) 3 "length 3"))) + +(test "c-length of singleton" + (lambda () + (assert-equal (length (ck () (c-length '(x)))) 1 "length 1"))) + +;; --------------------------------------------------------------------------- +;; Composition tests +;; --------------------------------------------------------------------------- + +(test "composition: c-map inside c-append" + (lambda () + (assert-equal (ck () (c-append (c-map (c-car) '((a 1) (b 2))) + '(c d))) + '(a b c d) "map then append"))) + +(test "composition: c-reverse of c-map" + (lambda () + (assert-equal (ck () (c-reverse (c-map (c-car) '((a 1) (b 2) (c 3))))) + '(c b a) "reverse of map"))) + +(test "composition: c-filter then c-map" + (lambda () + ;; Filter pairs, then extract cars + (assert-equal (ck () (c-map (c-car) (c-filter (c-pair?) '((a 1) b (c 2) d)))) + '(a c) "map car of filtered pairs"))) + +(test "composition: c-foldr with c-cons and c-reverse" + (lambda () + (assert-equal (ck () (c-reverse (c-foldr (c-cons) '() '(a b c)))) + '(c b a) "reverse of foldr cons"))) + +(test "composition: nested c-if with CK operations" + (lambda () + (assert-equal (ck () (c-if (c-null? '()) + (c-cons 'was-empty '()) + (c-cons 'was-notempty '()))) + '(was-empty) "if-then with CK branches"))) + +;; --------------------------------------------------------------------------- +;; Results +;; --------------------------------------------------------------------------- + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))