Less verbose CPS debug printing

cyclone.scm

@@ -405,23 +405,23 @@
            ;; No need for call/cc yet
            (set! input-program cps))))
       (trace:info "---------------- after CPS:")
-      (trace:info input-program) ;pretty-print
+      (trace:info (ast:ast->pp-sexp input-program))
 
       (when (> *optimization-level* 0)
         (set! input-program
           (optimize-cps input-program))
         (trace:info "---------------- after cps optimizations (1):")
-        (trace:info input-program)
+        (trace:info (ast:ast->pp-sexp input-program))
 
         (set! input-program
           (optimize-cps input-program))
         (trace:info "---------------- after cps optimizations (2):")
-        (trace:info input-program)
+        (trace:info (ast:ast->pp-sexp input-program))
         
         (set! input-program
           (optimize-cps input-program))
         (trace:info "---------------- after cps optimizations (3):")
-        (trace:info input-program)
+        (trace:info (ast:ast->pp-sexp input-program))
       )
     
       (set! input-program

scheme/cyclone/ast.sld

@@ -24,12 +24,15 @@
      ast:lambda-has-cont 
      ast:set-lambda-has-cont!
      ast:get-next-lambda-id!
+     ast:ast->pp-sexp
   )
   (begin
     (define *lambda-id* 0)
+
     (define (ast:get-next-lambda-id!)
       (set! *lambda-id* (+ 1 *lambda-id*))
       *lambda-id*)
+
     (define-record-type <lambda-ast>
      (ast:%make-lambda id args body has-cont)
      ast:lambda?
@@ -38,8 +41,41 @@
      (body ast:lambda-body ast:set-lambda-body!)
      (has-cont ast:lambda-has-cont ast:set-lambda-has-cont!)
     )
+
     (define (ast:make-lambda args body . opts)
       (let ((has-cont (if (pair? opts) (car opts) #f)))
         (set! *lambda-id* (+ 1 *lambda-id*))
         (ast:%make-lambda *lambda-id* args body has-cont)))
+
+    ;; Transform a SEXP in AST form to one that prints more cleanly
+    (define (ast:ast->pp-sexp exp)
+      (cond
+       ((ast:lambda? exp)
+        (let* ((id (ast:lambda-id exp))
+               (has-cont (ast:lambda-has-cont exp))
+               (sym (string->symbol 
+                      (string-append
+                         "lambda-"
+                         (number->string id)
+                         (if has-cont "-cont" ""))))
+              )
+          `(,sym ,(ast:lambda-args exp)
+             ,@(map ast:ast->pp-sexp (ast:lambda-body exp))))
+       )
+       ((quote? exp) exp)
+       ((const? exp) exp)
+       ((ref? exp) exp)
+       ((define? exp)
+        `(define ,(define->var exp)
+                 ,@(ast:ast->pp-sexp (define->exp exp))))
+       ((set!? exp)
+        `(set! ,(set!->var exp)
+               ,(ast:ast->pp-sexp (set!->exp exp))))
+       ((if? exp)       
+        `(if ,(ast:ast->pp-sexp (if->condition exp))
+             ,(ast:ast->pp-sexp (if->then exp))
+             ,(ast:ast->pp-sexp (if->else exp))))
+       ((app? exp)
+        (map ast:ast->pp-sexp exp))
+       (else exp)))
 ))