impc:ti:mark-returns   scheme

Defined in:


;; this is uggglly and needs to be redone!!!!!!!
;; adds ret tags
(define impc:ti:mark-returns
  (lambda (ast name in-body? last-pair? blocked?)
    (cond ((atom? ast)
           (if (and in-body? last-pair?)
               (if blocked? ast (list 'ret-> name ast))
          ((pair? ast)
           (cond ((equal? (car ast) 'if)
                  (if (or (< (length ast) 3) (> (length ast) 4))
                      (impc:compiler:print-compiler-error "Badly formed conditional" ast))
                  ;; if statement need special syntax adjustments for returns
                  (append (if blocked? (list 'if) (list 'ifret)) (list (cadr ast))
                          (list (impc:ti:mark-returns (caddr ast) name in-body? last-pair? blocked?))
                          (if (not (null? (cdddr ast)))
                              (list (impc:ti:mark-returns (cadddr ast) name in-body? last-pair? blocked?)))))
                 ((member (car ast) *impc:letslist*)
                  (append (list (car ast))
                          (list (map (lambda (a)
                                       ;; let assigns always block (lambda can override but nothing else)
                                       (list (car a) (impc:ti:mark-returns (cadr a) (car a) #f #f #t)))
                                     (cadr ast)))
                          (impc:ti:mark-returns (cddr ast) name #t #f blocked?)))
                 ((member (car ast) *impc:lambdaslist*)
                  (append (list (car ast)) (list (cadr ast))
                          ;; lambda always unblocks because lambdas always need a return
                          (impc:ti:mark-returns (cddr ast) name #t #f #f)))
                                        ;((equal? (car ast) 'dotimes)
                                        ; (append '(dotimes) (list (cadr ast)) (impc:ti:mark-returns (cddr ast) name #t #f blocked?)))
                 ((equal? (car ast) 'begin)
                  (if (null? (cdr ast))
                      (impc:compiler:print-no-retval-error ast))
                  (let* ((rev (reverse (cdr ast)))
                         (last (car rev))
                         (rest (reverse (cdr rev)))
                         (newast (append '(begin)
                                         (append (map (lambda (a)
                                                        ;; block everything except ...
                                                        (impc:ti:mark-returns a name in-body? #f #t))
                                                 ;; the last one which we let through
                                                 ;; ONLY if it hasn't been blocked higher up!
                                                 (list (impc:ti:mark-returns last name in-body?
                                                                             (if blocked? #f #t)
                 ((equal? (car ast) 'begin)
                  (append '(begin) (impc:ti:mark-returns (cdr ast) name in-body? #f blocked?)))
                 ((and in-body? last-pair? (not blocked?)) ;; if everything is good add a return!
                  (list 'ret-> name (cons (car ast) (impc:ti:mark-returns (cdr ast) name in-body? #f #t))))
                                        ;(list 'ret-> name ast))
                 (else (cons (impc:ti:mark-returns (car ast) name in-body? #f blocked?)
                             (impc:ti:mark-returns (cdr ast) name in-body? #f blocked?))))))))

Back to Index