;; 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))
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))
rest)
;; 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)
blocked?))))))
newast))
((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?))))))))