impc:ti:memzone   scheme

(define impc:ti:memzone
  (lambda (ast)
    (define zone_returns_void? (impc:ti:check-memzone-void? ast))
    (if zone_returns_void?
        `(begin (push_new_zone ,(cadr ast))
                ,(if (= (length ast) 3) (caddr ast) (cadddr ast))
                (let ((zonename (pop_zone))
                      (hook:<i64,i8*,i8*>* (cast (tref zonename 4)))
                      (f:[void]* null))
                  (while (not (null? hook))
                    (set! f (cast (tref hook 1) [void]*))
                    (f)
                    (set! hook (cast (tref hook 2) <i64,i8*,i8*>*)))
                  (llvm_zone_destroy zonename)
                  )
                void)
        (begin
          (define resname (string->symbol (string-append "res" (number->string (modulo *xtm_mz_num* 100)))))
          (define zonename (string->symbol (string-append "zone" (number->string (modulo *xtm_mz_num* 100)))))
          (define newzname (string->symbol (string-append "newz" (number->string (modulo *xtm_mz_num* 100)))))
          (define rescopyname (string->symbol (string-append "rescopy" (number->string (modulo *xtm_mz_num* 100)))))
          (set! *xtm_mz_num* (+ *xtm_mz_num* 1))
          (if (or (> (length ast) 4)
                  (< (length ast) 3))
              (impc:compiler:print-bad-arity-error ast))
          `(begin (push_new_zone ,(cadr ast))
                  (let ((,resname ,(if (= (length ast) 3) (caddr ast) (cadddr ast)))
                        (,zonename (pop_zone))
                        (,newzname (llvm_peek_zone_stack)))
                    ;; this extra let seems reduentant! BUT is needed
                    ;; because rescopyname should go in newzone not zonename
                    ;; i.e. needs to go into a *new* let after pop_zone is called
                    (let ((,rescopyname (zcopy ,resname ,zonename ,newzname))
                          (hook:<i64,i8*,i8*>* (cast (tref ,zonename 4)))
                          (f:[void]* null))
                      ,(if (= (length ast) 3)
                           `(begin
                              (while (not (null? hook))
                                (set! f (cast (tref hook 1) [void]*))
                                (f)
                                (set! hook (cast (tref hook 2) <i64,i8*,i8*>*))
                                1)
                              (llvm_zone_destroy ,zonename)
                              )
                           `(llvm_destroy_zone_after_delay ,zonename ,(caddr ast)))
                      ,rescopyname)))))))