Last active
May 10, 2020 17:49
-
-
Save gatlin/d89ee5442c10ca59ac9a8b621392ed10 to your computer and use it in GitHub Desktop.
Oleg's CK machine macro system - ever so slightly easier to find cross device here
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#lang r5rs | |
; Composable syntax-rules macros via the CK abstract machine | |
; | |
; We demonstrate (mutually-) recursive, higher-order applicative | |
; macros with clausal definitions, defined in the style that looks very | |
; much like that of ML or (strict) Haskell. | |
; We write composable, call-by-value--like macros without | |
; resorting to the continuation-passing-style and thus requiring no | |
; macro-level lambda. The syntax remains direct-style, with | |
; nested applications. | |
; This project was the answer to the question posed by Dan Friedman | |
; on Mar 20, 2009: | |
; Write the macro 'permute' that takes any number of arguments and returns | |
; the list of their permutations | |
; | |
; (permute a b c) ==> ((a b c) (b a c) (b c a) (a c b) (c a b) (c b a)) | |
; The order of the entries in the list is immaterial. One should write | |
; permute without resorting to CPS. | |
; | |
; Our answer is the transliteration of the standard Haskell code | |
; implementing the straightforward algorithm for all permutations: | |
; perm :: [a] -> [[a]] | |
; perm [] = [[]] | |
; perm (h:t) = concatMap (ins h) (perm t) | |
; ins :: a -> [a] -> [[a]] | |
; ins x [] = [[x]] | |
; ins x (h:t) = (x:h:t) : map (h:) (ins x t) | |
; We shall see that our code looks pretty much like the above, | |
; but with more parentheses. | |
; Our macros should are written in a specific, CK style. | |
; Here is the first example. | |
; The macro may have an arbitrary number of arguments; the following c-cons | |
; macro has two arguments. In addition, every CK macro must take | |
; an argument, typically called 's', which it should not touch; | |
; This 's' argument is always the first argument. | |
; A CK macro should pass the received 's' argument to the ck macro below. | |
; All arguments except the 's' argument have the form | |
; (quote <exp>) | |
; meaning that they are _values_ of the CK machine. | |
; A CK macro always ends in a call to the macro ck passing | |
; it the s argument followed by the produced value or by an expression | |
; that will produce the resulting value. | |
; The macro c-cons produces a value, which is therefore quoted: | |
(define-syntax c-cons | |
(syntax-rules (quote) | |
((c-cons s 'h 't) (ck s '(h . t))))) | |
; We define a macro c-append, using the just defined c-cons. | |
; We demonstrate recursion, clausal definition, and | |
; functional composition, or nested application. | |
; The first clause yields a value, which is quoted. | |
; The second clause yields an expression that will produce the value. | |
; The expression is not quoted. Again, a CK-style macro must always | |
; expand into the call to the 'ck' macro. | |
(define-syntax c-append | |
(syntax-rules (quote) | |
((c-append s '() 'l2) (ck s 'l2)) ; return a value | |
((c-append s '(h . t) 'l2) (ck s (c-cons 'h (c-append 't 'l2)))) | |
)) | |
; The code does look like Haskell code | |
; append [] l2 = l2 | |
; append (h:t) l2 = h : (append t l2) | |
; The CK machine | |
; The machine does focusing and refocusing, relying on | |
; user-defined CK-style macros for (primitive) reductions. | |
; | |
; A stack frame (op va ... [] ea ...) is represented in the code as | |
; ((op va ...) ea ...) | |
; where op is the name of a CK-style macro that does the reduction. | |
; zero or more va must all be values | |
; zero or more ea are arbitrary expressions (could be applications or values) | |
(define-syntax ck | |
(syntax-rules (quote) | |
((ck () 'v) v) ; yield the value on empty stack | |
((ck (((op ...) ea ...) . s) 'v) ; re-focus on the other argument, ea | |
(ck s "arg" (op ... 'v) ea ...)) | |
((ck s "arg" (op va ...)) ; all arguments are evaluated, | |
(op s va ...)) ; do the redex | |
((ck s "arg" (op ...) 'v ea1 ...) ; optimization when the first ea | |
(ck s "arg" (op ... 'v) ea1 ...)) ; was already a value | |
((ck s "arg" (op ...) ea ea1 ...) ; focus on ea, to evaluate it | |
(ck (((op ...) ea1 ...) . s) ea)) | |
((ck s (op ea ...)) ; Focus: handling an application; | |
(ck s "arg" (op) ea ...)) ; check if args are values | |
)) | |
; We get the ball rolling by invoking | |
; (ck () exp) | |
; to expand the CK-expression given the empty initial stack. | |
; | |
; If we evaluate the following | |
; (ck () (c-append '(1 2 3) '(4 5))) | |
; the macro-expansion hopefully produces (1 2 3 4 5) | |
; Then the evaluator will try to evaluate the result of the macro-expansion, | |
; reporting the error since 1 is not a procedure. | |
; If we want to see the result of only the macro-expansion, without | |
; any further evaluation, we should quote it | |
(define-syntax c-quote | |
(syntax-rules (quote) | |
((c-quote s 'x) (ck s ''x)))) | |
(ck () (c-quote (c-append '(1 2 3) '(4 5)))) | |
; ==> (1 2 3 4 5) | |
; A higher-order macro: map | |
(define-syntax c-map | |
(syntax-rules (quote) | |
((c-map s 'f '()) (ck s '())) | |
((c-map s '(f ...) '(h . t)) | |
(ck s (c-cons (f ... 'h) (c-map '(f ...) 't)))) | |
)) | |
(ck () (c-quote (c-map '(c-cons '10) '((1) (2) (3) (4))))) | |
; ==> ((10 1) (10 2) (10 3) (10 4)) | |
(define-syntax c-concatMap | |
(syntax-rules (quote) | |
((c-concatMap s 'f '()) (ck s '())) | |
((c-concatMap s '(f ...) '(h . t)) | |
(ck s (c-append (f ... 'h) (c-concatMap '(f ...) 't)))) | |
)) | |
(ck () (c-quote (c-concatMap '(c-cons '10) '((1) (2) (3) (4))))) | |
; ==> (10 1 10 2 10 3 10 4) | |
; We now solve Dan Friedman's problem, by transliterating the Haskell | |
; code for all permutations. | |
(define-syntax c-perm | |
(syntax-rules (quote) | |
((c-perm s '()) (ck s '(()))) | |
((c-perm s '(h . t)) (ck s (c-concatMap '(c-ins 'h) (c-perm 't)))))) | |
(define-syntax c-ins | |
(syntax-rules (quote) | |
((c-ins s 'x '()) (ck s '((x)))) | |
((c-ins s 'x '(h . t)) | |
(ck s (c-cons '(x h . t) (c-map '(c-cons 'h) (c-ins 'x 't))))))) | |
; The following macro is a syntactic sugar to invoke c-perm | |
(define-syntax perm | |
(syntax-rules () | |
((perm . args) (ck () (c-quote (c-perm 'args)))))) | |
; Tests | |
(perm) | |
; (()) | |
(perm 1) | |
; ((1)) | |
(perm 1 2) | |
; ((1 2) (2 1)) | |
(perm 1 2 3) | |
; ((1 2 3) (2 1 3) (2 3 1) (1 3 2) (3 1 2) (3 2 1)) | |
(perm 1 2 3 4) | |
;; ((1 2 3 4) | |
;; (2 1 3 4) | |
;; (2 3 1 4) | |
;; (2 3 4 1) | |
;; (1 3 2 4) | |
;; (3 1 2 4) | |
;; (3 2 1 4) | |
;; (3 2 4 1) | |
;; (1 3 4 2) | |
;; (3 1 4 2) | |
;; (3 4 1 2) | |
;; (3 4 2 1) | |
;; (1 2 4 3) | |
;; (2 1 4 3) | |
;; (2 4 1 3) | |
;; (2 4 3 1) | |
;; (1 4 2 3) | |
;; (4 1 2 3) | |
;; (4 2 1 3) | |
;; (4 2 3 1) | |
;; (1 4 3 2) | |
;; (4 1 3 2) | |
;; (4 3 1 2) | |
;; (4 3 2 1)) | |
; ------------------------------------------------------------------------ | |
; No Computer Science paper is complete without a factorial | |
; The following computes the factorial of naturals encoded in unary: | |
; for example, (u u u u u) encodes the number 5. | |
; Compare the direct-style macro below with the CPS macro, | |
; Macros-talk.pdf, slide 17. | |
; adding unary numerals is appending the corresponding lists | |
(define-syntax c-add | |
(syntax-rules () | |
((c-add . args) (c-append . args)))) | |
(define-syntax c-mul | |
(syntax-rules (quote u) | |
((c-mul s '() 'y) (ck s '())) ; 0 * y = 0 | |
((c-mul s '(u) 'y) (ck s 'y)) ; 1 * y = y | |
((c-mul s '(u . x) 'y) ; (1+x) * y = y + x*y | |
(ck s (c-add 'y (c-mul 'x 'y)))))) | |
(ck () (c-quote (c-mul '(u u) '(u u u)))) | |
; ==> (u u u u u u) | |
(define-syntax c-fact | |
(syntax-rules (quote u) | |
((c-fact s '()) (ck s '(u))) | |
((c-fact s '(u)) (ck s '(u))) | |
((c-fact s '(u . n)) (ck s (c-mul '(u . n) (c-fact 'n)))))) | |
(ck () (c-quote (c-fact '(u u u u)))) | |
; ==> (u u u u u u u u u u u u u u u u u u u u u u u u) | |
; ------------------------------------------------------------------------ | |
; Systematic development of a complex DSL macro delete-assoc | |
; (a part of the SSAX:make-parser) | |
; | |
; (delete-assoc ALIST KEY) deletes an association with the name KEY from | |
; ALIST, a list of (name . value) pairs. The macro returns the list of | |
; the remaining associations. KEY not found => error | |
; | |
; Compare the direct-style macro below with the huge CPS-style macro | |
; on p20 of Macros-talk.pdf | |
; A symbol-eq? predicate at the macro-expand time | |
; symbol-eq? S1 S2 KT KF | |
; (where S1 must be a symbol) | |
; expands into KT if S1 and S2 are the same symbol (identifier); | |
; Otherwise, it expands into KF | |
(define-syntax symbol-eq? | |
(syntax-rules () | |
((symbol-eq? s1 s2 kt kf) | |
(let-syntax | |
((test | |
(syntax-rules (s1) | |
((test s1 _kt _kf) _kt) | |
((test otherwise _kt _kf) _kf)))) | |
(test s2 kt kf))))) | |
(define-syntax c-delete-assoc | |
(syntax-rules (quote) | |
((c-delete-assoc s '((h . e) . t) 'key) | |
(symbol-eq? key h | |
(ck s 't) | |
(ck s (c-cons '(h . e) (c-delete-assoc 't 'key))))))) | |
; convenience macro | |
(define-syntax delete-assoc | |
(syntax-rules () | |
((delete-assoc lst key) (ck () (c-quote (c-delete-assoc 'lst 'key)))))) | |
(delete-assoc | |
((NEW-LEVEL-SEED . nls-proc) | |
(FINISH-ELEMENT . fe-proc) | |
(UNDECL-ROOT . ur-proc)) | |
FINISH-ELEMENT) | |
; ==> ((NEW-LEVEL-SEED . nls-proc) | |
; (UNDECL-ROOT . ur-proc)) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment