;;; pp-syntax.scm -- Jens Axel Soegaard -- 27th july 2005 ;; PURPOSE ;; This file contains functions that pretty prints the ;; output of EXPAND. The pretty printer attempts to present ;; the output of EXPAND using simple expression. E.g. ;; EXPAND will expand (let ((x 1)) 2) into (let-values (((x) 1)) 2), ;; which the pretty printer will "unexpand" into (let ((x 1)) 2). ;; FUNCTIONS ; unexpand : fully-expanded-syntax -> syntax ; Unexpand a piece of fully expanded syntax. ; E.g. simple occurences of let-values are rewritten to use let. ; unexpand-to-datum : fully-expanded-syntax -> datum ; Unexpand a piece of fully expanded syntax, and return ; the result as a datum. ; pp-syntax : fully-expanded-syntax -> ; Pretty-prints the unexpanded piece of syntax ;; EXAMPLE ;> (pp-syntax (expand ; '(begin ; (letrec ((f (lambda (n) ; (if (= n 0) ; 1 ; (* n (f (- n 1))))))) ; (begin0 (f 5) ; (set! x 1))) ; (define y (let ((z 3)) 2))))) ;; [prints] ; (begin ; (letrec ((f (lambda (n) (if (= n 0) 1 (* n (f (- n 1))))))) ; (begin0 (f 5) (set! x 1))) ; (define y (let ((z 3)) 2))) ;; For comparison ; (pretty-print (syntax-object->datum (expand ))) ; prints ; (begin ; (letrec-values (((f) ; (lambda (n) ; (if (#%app (#%top . =) n (#%datum . 0)) ; (#%datum . 1) ; (#%app ; (#%top . *) ; n ; (#%app ; f ; (#%app (#%top . -) n (#%datum . 1)))))))) ; (begin0 (#%app f (#%datum . 5)) (set! x (#%datum . 1)))) ; (define-values ; (y) ; (let-values (((z) (#%datum . 3))) (#%datum . 2)))) (require (lib "pretty.ss")) (pretty-print-columns 70) (define (self-evaluating? o) (or (boolean? o) (number? o) (string? o) (char? o))) (define (smap f . sl) (define (->list o) (if (syntax? o) (syntax->list o) o)) (apply map f (map ->list sl))) ;expr is one of ; variable ; (lambda formals expr ···1) ; (case-lambda (formals expr ···1) ···) ; (if expr expr) ; (if expr expr expr) ; (begin expr ···1) ; (begin0 expr expr ···) ; (let-values (((variable ···) expr) ···) expr ···1) ; (letrec-values (((variable ···) expr) ···) expr ···1) ; (set! variable expr) ; (quote datum) ; (quote-syntax datum) ; (with-continuation-mark expr expr expr) ; (#%app expr ···1) ; (#%datum . datum) ; (#%top . variable) ; pp-expr : syntax-object -> syntax-object (define (pp-expr so) (define pe pp-expr) (define (pe* sl) (smap pe sl)) (syntax-case so (lambda if begin begin0 let-values letrec-values set! with-continuation-mark #%datum #%app #%top and or) ; AND [(if e1 e2 (#%datum . #f)) (pe #`(and #,(pe #'e1) #,(pe #'e2)))] [(and e1 ... (and e2 ...)) (pe #'(and e1 ... e2 ...))] [(and (and e1 ...) e2 ...) (pe #'(and e1 ... e2 ...))] [(and expr ...) #`(and #,@(pe* #'(expr ...)))] ; OR [(let-values (((or-part1) x)) (if or-part2 or-part3 y)) (and (and (identifier? #'or-part2) (identifier? #'or-part3)) (eq? (syntax-e #'or-part1) (syntax-e #'or-part2)) (eq? (syntax-e #'or-part2) (syntax-e #'or-part3))) (pe #`(or #,(pe #'x) #,(pe #'y)))] [(or expr1 ... (or expr2 ...)) (pe #'(or expr1 ... expr2 ...))] [(or (or expr1 ...) expr2 ...) (pe #'(or expr1 ... expr2 ...))] [(or expr ...) #`(or #,@(pe* #'(expr ...)))] ; OTHER [(lambda formals expr ...) #`(lambda formals #,@(pe* #'(expr ...)))] [(if expr1 expr2) #`(if #,(pe #'expr1) #,(pe #'expr2))] [(if expr1 expr2 expr3) #`(if #,(pe #'expr1) #,(pe #'expr2) #,(pe #'expr3))] [(begin expr ...) #`(begin #,@(pe* #'(expr ...)))] [(begin0 expr ...) #`(begin0 #,@(pe* #'(expr ...)))] [(let-values (((id) expr) ...) body ...) #`(let #,(smap list #'(id ...) (pe* #'(expr ...))) #,@(pe* #'(body ...)))] [(letrec-values (((id) expr) ...) body ...) #`(letrec #,(smap list #'(id ...) (pe* #'(expr ...))) #,@(pe* #'(body ...)))] [(set! var expr) #`(set! var #,(pe #'expr))] [(with-continuation-mark expr1 expr2 expr3) #`(with-continuation-mark #,(pe #'expr1) #,(pe #'expr2) #,(pe #'expr3))] [(#%datum . o) (self-evaluating? (syntax-object->datum #'o)) #'o] [(#%app expr ...) (smap pe #'(expr ...))] [(#%top . id) #'id] [_ so])) ;general-top-level-expr is one of ; expr ; (define-values (variable ···) expr) ; (define-syntaxes (identifier ···) expr) ; (define-values-for-syntax (variable ···) expr) ; (require require-spec ···) ; (require-for-syntax require-spec ···) ; (require-for-template require-spec ···) ; pp-general-top-level-expr : syntax-object -> syntax-object (define (pp-general-top-level-expr so) (syntax-case so (define-values define-syntaxes define-values-for-syntax require require-for-syntax require-for-template) [(define-values (var) expr) #`(define var #,(pp-expr #'expr))] [(define-values (var ...) expr) #`(define-values (var ...) #,(pp-expr #'expr))] [(define-syntaxes id expr) #`(define-syntax id #,(pp-expr #'expr))] [(define-syntaxes (id ...) expr) #`(define-syntaxes (id ...) #,(pp-expr #'expr))] [(define-values-for-syntax (var ...) expr) #`(define-values-for-syntax (var ...) #,(pp-expr #'expr))] [(require require-spec ...) #'(require require-spec ...)] [(require-for-syntax require-spec ...) #'(require-for-syntax require-spec ...)] [(require-for-template require-spec ...) #'(require-for-template require-spec ...)] [_ (pp-expr so)])) ;top-level-expr is one of ; general-top-level-expr ; (module identifier name (#%plain-module-begin module-level-expr ···)) ; (begin top-level-expr ···) ; pp-top-level-expr : syntax-object -> syntax-object (define (pp-top-level-expr so) (syntax-case so (module begin #%plain-module-begin) [(module id name (#%plain-module-begin module-level-expr ...)) #`(module id name (#%plain-module-begin #,@(smap pp-module-level-exp #'(module-level-expr ...))))] [(begin top-level-expr ...) #`(begin #,@(pp-top-level-expr* #'(top-level-expr ...)))] [_ (pp-general-top-level-expr so)])) ;module-level-expr is one of ; general-top-level-expr ; (provide provide-spec ...) ; (begin module-level-expr ···) ; pp-module-level-expr : syntax-object -> syntax-object (define (pp-module-level-expr so) (syntax-case so (provide begin) [(provide provide-spec ...) #'(provide provide-spec ...)] [(begin module-level-expr ...) #`(begin #,@(smap pp-module-level-expr #'(module-level-expr ...)))] [_ (pp-general-top-level-expr so)])) ; unexpand : fully-expanded-syntax -> syntax (define (unexpand so) (pp-module-level-expr (expand so))) ; unexpand-to-datum : fully-expanded-syntax -> datum (define (unexpand-to-datum so) (syntax-object->datum #`#,(unexpand so))) ; pp-syntax : fully-expanded-syntax -> (define (pp-syntax so) (pretty-display (unexpand-to-datum so)))