Last active
April 3, 2018 06:52
-
-
Save arucil/3f308b943487da793d9e9a4f24e659c5 to your computer and use it in GitHub Desktop.
A simple basic CPS transformer in Scheme
This file contains hidden or 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
| ;;; This library is described at https://www.cs.indiana.edu/chezscheme/match/ | |
| (load "match.ss") | |
| (define (id x) x) | |
| (define (cps exp) | |
| (letrec ([cps | |
| (lambda (exp k) | |
| (match exp | |
| [,v | |
| (guard (or (number? v) | |
| (symbol? v) | |
| (boolean? v) | |
| (string? v))) | |
| (k v)] | |
| [(if ,test ,conseq ,alt) | |
| (cps test | |
| (lambda (v) | |
| `(if ,v | |
| ,(cps conseq k) | |
| ,(cps alt k))))] | |
| [(,rator ,rands ...) | |
| (guard (memq rator '(cons car cdr null? + - * / > < = >= <= not))) | |
| (cps* rands | |
| (lambda (args) | |
| (k `(,rator ,@args))))] | |
| [(lambda (,params ...) ,body1 ,body* ...) | |
| (let ([k1 (gen-sym 'k)]) | |
| (k `(lambda (,k1 ,@params) | |
| ,(cps-body (cons body1 body*) | |
| (lambda (v) | |
| `(,k1 ,v))))))] | |
| [(set! ,var ,exp1) | |
| (cps exp1 | |
| (lambda (v) | |
| (k `(set! ,var ,v))))] | |
| [(begin ,exp1 ,exps ...) | |
| (cps-body (cons exp1 exps) k)] | |
| [(,rator ,rands ...) | |
| (cps* (cons rator rands) | |
| (lambda (args) | |
| (let ([v1 (gen-sym 'v)]) | |
| `(,(car args) | |
| (lambda (,v1) | |
| ,(k v1)) | |
| ,@(cdr args)))))] | |
| [,x (error 'cps "Invalid expression" x)]))] | |
| [cps* | |
| (lambda (exp* k) | |
| (cond | |
| [(null? exp*) | |
| (k '())] | |
| [else | |
| (cps (car exp*) | |
| (lambda (v1) | |
| (cps* (cdr exp*) | |
| (lambda (v*) | |
| (k (cons v1 v*))))))]))] | |
| [cps-body | |
| (lambda (exp* k) | |
| (cond | |
| [(null? (cdr exp*)) | |
| (cps (car exp*) k)] | |
| [else | |
| (cps (car exp*) | |
| (lambda (v1) | |
| `(begin | |
| ,v1 | |
| ,(cps-body (cdr exp*) | |
| k))))]))]) | |
| (init-gen!) | |
| (cps exp id))) | |
| (define *counter* '()) | |
| (define (init-gen!) | |
| (set! *counter* '())) | |
| (define (gen-sym prefix) | |
| (let ([p (assq prefix *counter*)]) | |
| (if p | |
| (begin | |
| (set-cdr! p (+ 1 (cdr p))) | |
| (string->symbol | |
| (string-append | |
| (symbol->string prefix) | |
| "." | |
| (number->string (cdr p))))) | |
| (begin | |
| (set! *counter* | |
| (cons (cons prefix 0) | |
| *counter*)) | |
| (gen-sym prefix))))) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment