cyclone/tests/debug/find-direct-rec-calls.scm

(import
  (scheme base)
  (scheme cyclone ast)
  (scheme cyclone util)
  (scheme cyclone pretty-print)
  (scheme write)
  (srfi 2)
)

  (define (find-direct-recursive-calls exp)
    ;; Verify the continuation is simple and there is no closure allocation
    (define (check-cont k)
      (cond
        ((ref? k) #t)
        (else #f)))

    (define (check-args args)
      (define (check exp)
        (cond
          ((quote? exp) #t)
          ((const? exp) #t)
          ((ref? exp) #t)
          ((app? exp)
           (and 
             ;; Very conservative right now
             (member (car exp) '(car cdr))
             (check-args (cdr exp))))
          (else #f)))
      (every check args))

    (define (scan exp def-sym)
      (write `(scan ,def-sym ,exp)) (newline)
      (cond
       ((ast:lambda? exp)
        ;; Reject if there are nested functions
        #f)
       ((quote? exp) exp)
       ((const? exp) exp)
       ((ref? exp) 
        exp)
       ((define? exp) #f)
       ((set!? exp) #f)
       ((if? exp)       
        ;;(scan (if->condition exp) def-sym) ;; Not a tail call
        (scan (if->then exp) def-sym)
        (scan (if->else exp) def-sym))
       ((app? exp)
        (when (equal? (car exp) def-sym)
          (if (and
                (check-args (cddr exp))
                (check-cont (cadr exp)))
            (write `(direct recursive call ,exp))
            (write `(not a direct recursive call ,exp))
         )
        )
       )
       (else #f)))
    (for-each
      (lambda (exp)
        (write exp) (newline)
        (and-let* (((define? exp))
                    (def-exps (define->exp exp))
                   ((vector? (car def-exps)))
                   ((ast:lambda? (car def-exps)))
                   )
         (scan (car (ast:lambda-body (car def-exps))) (define->var exp))
         ))
        exp)
  )

;; TEST code:
(define sexp '(
 (define l18 #f)
 (define l12 #f)
 (define l6 #f)
 (define mas
   (lambda
     (k$247 x$4$135 y$3$134 z$2$133)
     (shorterp
       (lambda
         (r$248)
         (if r$248
           (mas (lambda
                  (r$249)
                  (mas (lambda
                         (r$250)
                         (mas (lambda
                                (r$251)
                                (mas k$247 r$249 r$250 r$251))
                              (cdr z$2$133)
                              x$4$135
                              y$3$134))
                       (cdr y$3$134)
                       z$2$133
                       x$4$135))
                (cdr x$4$135)
                y$3$134
                z$2$133)
           (k$247 z$2$133)))
       y$3$134
       x$4$135)))
 (define foldr
   (lambda
     (k$6632 func$362$3486 end$361$3485 lst$360$3484)
     (if (null? lst$360$3484)
       (k$6632 end$361$3485)
       (foldr (lambda
                (r$6635)
                (func$362$3486 k$6632 (car lst$360$3484) r$6635))
              func$362$3486
              end$361$3485
              (cdr lst$360$3484)))))
 (define _list-index
   (lambda
     (k$3902 e$2456$2587 lst$2455$2586)
     (if (null? lst$2455$2586)
       (k$3902 -1)
       (if (eq? (car lst$2455$2586) e$2456$2587)
         (k$3902 0)
         (_list-index
           (lambda
             (r$3908)
             (if (Cyc-fast-eq r$3908 -1)
               (k$3902 -1)
               (_list-index
                 (lambda
                   (r$3906)
                   (k$3902 (Cyc-fast-plus 1 r$3906)))
                 e$2456$2587
                 (cdr lst$2455$2586))))
           e$2456$2587
           (cdr lst$2455$2586))))))
 (define *num-passed* 1)
 (define shorterp
   (lambda
     (k$240 x$6$131 y$5$130)
     (if (null? y$5$130)
       (k$240 #f)
       (if (null? x$6$131)
         (k$240 (null? x$6$131))
         (shorterp k$240 (cdr x$6$131) (cdr y$5$130))))))
))

(find-direct-recursive-calls
  (ast:sexp->ast sexp))