diff options
Diffstat (limited to 'lib/csc/macros.scheme')
| -rw-r--r-- | lib/csc/macros.scheme | 346 |
1 files changed, 346 insertions, 0 deletions
diff --git a/lib/csc/macros.scheme b/lib/csc/macros.scheme new file mode 100644 index 0000000..2d6b790 --- /dev/null +++ b/lib/csc/macros.scheme @@ -0,0 +1,346 @@ +; https://web.cs.ucdavis.edu/~devanbu/teaching/260/kohlbecker.pdf + +(define-library (csc macros) + (export + expand-program + list-builtins) + (import (scheme base) + (only (scheme case-lambda) case-lambda) + (prefix (csc gensym) gensym.) + (prefix (csc ir) ir.) + (prefix (csc list) list.) + (prefix (csc map) map.)) + (import (scheme write)) + (begin + + + ; Macro expansion is a function on an stree, to a simplified form called + ; the lambda-term. An stree is one of: + ; - symbol + ; - constant (null, boolean, char, bytevector, number, string, or vector) + ; - list of stree (function call or macro application) + ; + ; A lambda-term is one of: + ; - symbol + ; - constant + ; - list of stree (only function call this time) + ; - or one of a number of special forms defined in ir.scheme. + ; + ; A lambda-term is the same as an stree, except there are no remaining + ; macro applications. In other words, we are expanding the macros. + + + (define-record-type <toplevel-define> + (make-toplevel-define var body) + toplevel-define? + (var toplevel-define-var) + (body toplevel-define-body)) + + + (define-record-type <tsvar> + (make-tsvar var timestamp) + tsvar? + (var tsvar-var) + (timestamp tsvar-ts)) + + + (define (stamper ts) + (lambda (var) + (make-tsvar var ts))) + + + (define (constant? x) + (or (boolean? x) + (char? x) + (bytevector? x) + (number? x) + (string? x) + (vector? x))) + + + ; timestamp stamps all unstamped symbols. + (define (timestamp tree stamp) + (cond + ((ir.libvar? tree) + (stamp tree)) + ((list? tree) + (map (lambda (x) (timestamp x stamp)) tree)) + ((constant? tree) tree) + (else (error "unexpected form in timestamp" tree)))) + + + (define (lookup-macro env var) + (define binding1 (map.lookup env var #f)) + (if (procedure? binding1) + binding1 + ; Check for var in the global namespace. + (let ((binding2 (map.lookup env (make-tsvar (tsvar-var var) 0) #f))) + (and (procedure? binding2) + binding2)))) + + + ; expand expands all macros in a timestamped stree. + (define (expand tree env time) + (cond + ((and (pair? tree) + (tsvar? (car tree)) + (lookup-macro env (car tree))) => + (lambda (transformer) + (transformer tree env time))) + ((null? tree) + (error "nil by itself is an error")) + ((list? tree) + (ir.make-apply + (expand (car tree) env time) + (list + (list.foldr + (lambda (x acc) + (ir.make-call-builtin 'cons + (list + (expand x env time) + acc))) + (ir.make-const '()) + (cdr tree))))) + ((tsvar? tree) + (or (map.lookup env tree #f) + tree)) ; Global variables are still unresolved. + ((constant? tree) + (ir.make-const tree)) + (else (error "unexpected form in expand" tree)))) + + + (define (map-ir1 f expr) + (cond + ((toplevel-define? expr) + (make-toplevel-define (f (toplevel-define-var expr)) (f (toplevel-define-body expr)))) + ((ir.lambda? expr) + (ir.make-lambda (map f (ir.lambda-vars expr)) (f (ir.lambda-body expr)))) + ((ir.letrec? expr) + (ir.make-letrec (map (lambda (func) (cons (f (car func)) (f (cdr func)))) (ir.letrec-funcs expr)) (f (ir.letrec-body expr)))) + ((ir.apply? expr) + (ir.make-apply (f (ir.apply-func expr)) (map f (ir.apply-args expr)))) + ((ir.sequence? expr) + (ir.make-sequence (f (ir.sequence-head expr)) (f (ir.sequence-tail expr)))) + ((ir.set? expr) + (ir.make-set (f (ir.set-var expr)) (f (ir.set-body expr)))) + ((ir.call-builtin? expr) + (ir.make-call-builtin (ir.call-builtin-name expr) (map f (ir.call-builtin-args expr)))) + ((or (tsvar? expr) + (gensym.gensym? expr) + (ir.const? expr)) + expr) + ((ir.void? expr) ir.*void*) + (else (error "unexpected form in map-ir1")))) + + + (define (fold-ir1 f acc expr) + (cond + ((toplevel-define? expr) + (f (f acc (toplevel-define-var expr)) (toplevel-define-body expr))) + ((ir.lambda? expr) + (f (list.foldl f acc (ir.lambda-vars expr)) (ir.lambda-body expr))) + ((ir.letrec? expr) + (f (list.foldl (lambda (acc x) (f (f acc (car x)) (cdr x))) acc (ir.letrec-funcs expr)) (ir.letrec-body expr))) + ((ir.apply? expr) + (list.foldl f (f acc (ir.apply-func expr)) (ir.apply-args expr))) + ((ir.sequence? expr) + (f (f acc (ir.sequence-head expr)) (ir.sequence-tail expr))) + ((ir.set? expr) + (f (f acc (ir.set-var expr)) (ir.set-body expr))) + ((ir.call-builtin? expr) + (list.foldl f acc (ir.call-builtin-args expr))) + ((or (tsvar? expr) + (gensym.gensym? expr) + (ir.const? expr) + (ir.void? expr)) + acc) + (else (error "unexpected form in fold-ir1" expr)))) + + + (define (cmp-strings s1 s2) + (cond + ((string=? s1 s2) + 0) + ((string<? s1 s2) + -1) + (else 1))) + + + (define (cmp-libvar x y) + (define d (cmp-strings (ir.libvar-lib x) + (ir.libvar-lib y))) + (if (zero? d) + (cmp-strings (ir.libvar-var x) (ir.libvar-var y)) + d)) + + + (define *empty-libvar-map* (map.empty cmp-libvar)) + + + (define (cmp-tsvar v1 v2) + (define d (- (tsvar-ts v1) (tsvar-ts v2))) + (if (zero? d) + (cmp-libvar (tsvar-var v1) (tsvar-var v2)) + d)) + + + (define *empty-tsvar-map* (map.empty cmp-tsvar)) + + + (define (expand-body prog env time) + (let loop ((prog prog) + (env env) + (time time)) + (if (null? prog) + '() + (let ((expanded (expand (car prog) env time))) + (cond + ((and (toplevel-define? expanded) + (procedure? (toplevel-define-body expanded))) + (loop (cdr prog) + (map.insert env (toplevel-define-var expanded) (toplevel-define-body expanded)) + (+ 1 time))) + (else + (cons expanded + (loop (cdr prog) env (+ 1 time))))))))) + + + (define (remaining-defines? expr) + (or (toplevel-define? expr) + (fold-ir1 (lambda (acc x) (or acc (remaining-defines? x))) #f expr))) + + + (define (rewrite-body body) + (define funcs + (list.map-maybe + (lambda (x) + (and (toplevel-define? x) + (ir.lambda? (toplevel-define-body x)) + (cons (toplevel-define-var x) (toplevel-define-body x)))) + body)) + (define exprs + (list.filter + (lambda (x) + (not (and (toplevel-define? x) + (ir.lambda? (toplevel-define-body x))))) + body)) + (define new-body + (list.foldr + (lambda (x acc) + (if (toplevel-define? x) + (ir.make-apply (ir.make-lambda (list (toplevel-define-var x)) acc) (list ir.*void*)) + acc)) + (ir.make-letrec funcs + (list.foldl + (lambda (acc x) + (ir.make-sequence acc + (if (toplevel-define? x) + (ir.make-set (toplevel-define-var x) (toplevel-define-body x)) + x))) + ir.*void* + exprs)) + exprs)) + (when (remaining-defines? new-body) + (error "definition in expression context")) + new-body) + + + ; remaining-symbols returns the timestamped symbols in tree. + (define (remaining-symbols tree) + (cond + ((tsvar? tree) + ; These free variables should be unstamped, since they refer to + ; toplevel bindings. + (map.singleton cmp-strings (tsvar-var tree) (gensym.gen))) + (else + (fold-ir1 + (lambda (acc x) + (map.union acc (remaining-symbols x))) + *empty-libvar-map* + tree)))) + + + (define (unstamp-tree tree symbols) + (cond + ((tsvar? tree) + (map.lookup symbols (tsvar-var tree))) + (else (map-ir1 (lambda (x) (unstamp-tree x symbols)) tree)))) + + + ; unstamp changes the timestamped symbols in expr into gensyms. + (define (unstamp expr) + (unstamp-tree expr (remaining-symbols expr))) + + + (define (builtin-define expr env time) + (unless (and (list? expr) + (= (length expr) 3) + (tsvar? (cadr expr))) + (error "invalid form in builtin-define")) + (let-values (((var body) (apply values (cdr expr)))) + (make-toplevel-define var (expand body env (+ 1 time))))) + + + (define (builtin-lambda expr env time) + (unless (and (list? expr) + (>= (length expr) 3) + (tsvar? (cadr expr))) + (error "invalid form in builtin-lambda")) + (let ((var (cadr expr)) + (body (cddr expr)) + (new-var (gensym.gen))) + (define env* (map.insert env var new-var)) + (define expanded-body (expand-body body env* (+ 1 time))) + (define exprs + (let loop ((body expanded-body)) + (if (or (null? body) + (not (toplevel-define? (car body)))) + body + (loop (cdr body))))) + (when (list.any remaining-defines? exprs) + (error "out of order define")) + (ir.make-lambda (list new-var) (rewrite-body expanded-body)))) + + + (define (builtin-call-builtin expr env time) + (unless (and (list? expr) + (>= (length expr) 2) + (tsvar? (cadr expr))) + (error "invalid form in builtin-call-builtin")) + (let ((builtin-name (tsvar-var (cadr expr))) + (args (cddr expr))) + (ir.make-call-builtin (string->symbol (ir.libvar-var builtin-name)) + (map + (lambda (arg) + (expand arg env (+ 1 time))) + args)))) + + + (define *builtins-environment* + (list.foldl + (lambda (acc x) + (map.insert acc (make-tsvar (ir.make-libvar "(csc builtins)" (car x)) 0) (cdr x))) + *empty-tsvar-map* + (list (cons "define" builtin-define) + (cons "lambda" builtin-lambda) + (cons "call-builtin" builtin-call-builtin)))) + ; Damn I can't believe we didn't actually implement syntax-rules. + + + (define (list-builtins) + (map + (lambda (x) + (string->symbol (ir.libvar-var (tsvar-var (car x))))) + (map.map->list *builtins-environment*))) + + + (define (expand-program prog) + (unstamp + (rewrite-body + (expand-body + (map + (lambda (x) + (timestamp x (stamper 0))) + prog) + *builtins-environment* + 1)))))) |