(defun c2tagbody (tag-loc body)
  (declare (type var tag-loc))
  (if (null (var-kind tag-loc))
      ;; only local goto's
      (let ((label (next-label)))
	;; Allocate labels.
	(dolist (x body)
	  (when (and (tag-p x) (plusp (tag-ref x)))
	    (setf (tag-label x) (next-label*))
	    (setf (tag-unwind-exit x) label)))
	(let ((*unwind-exit* (cons label *unwind-exit*)))
	  (c2tagbody-body body)))
      ;; some tag used non locally or inside an unwind-protect
      (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
	    (label (next-label))
	    (*env* *env*) (*env-lvl* *env-lvl*)
	    (*closure-levels* *closure-levels*)
	    closure-block-id
	    (*lex* *lex*) (*lcl* *lcl*)
	    (env-grows (env-grows (var-ref-ccb tag-loc))))
	(when env-grows
	  (push 0 *closure-levels*)
	  (setq closure-block-id (incf *closure-block-id*) *cenv0-used* t)
	  (let ((env-lvl *env-lvl*))
	    (wt-nl "{") (incf *env-lvl*)
	    (wt-nl "mkcl_object cenv" *env-lvl* " = mkcl_alloc_clevel_block(env, "
		   (if *written-function* "this_func" "mk_cl_Cnil")
		   ", cenv" env-lvl ", "
		   (written-function-cname) "_cblock_" closure-block-id ");")
	    (when (>= *debug-fun* 2)
	      (wt-nl "mkcl_object syms_cenv" *env-lvl* " = mkcl_alloc_clevel_block(env, "
		     (if *written-function* "this_func" "mk_cl_Cnil")
		     ", syms_cenv" env-lvl ", "
		     (written-function-cname) "_cblock_" closure-block-id ");")
	      )
	    )
	  )
	(when (eq :OBJECT (var-kind tag-loc))
	  (setf (var-loc tag-loc) (next-lcl))
	  (wt-nl "{ mkcl_object " tag-loc ";")
	  (setq env-grows t))		; just to ensure closing the block
	(bind "MKCL_NEW_FRAME_ID(env)" tag-loc)
	(wt-nl "if (mkcl_frs_push(env," tag-loc ")) {")
	(wt-nl "  mkcl_maybe_reset_call_stack_overflow(env);") ;; JCB
	(wt-nl "  mkcl_set_interrupt_status(env, &env->frs_top->frs_intr);") ;; JCB
	;; Allocate labels.
	(dolist (tag body)
	  (when (and (tag-p tag) (plusp (tag-ref tag)))
	    (setf (tag-label tag) (next-label))
	    (setf (tag-unwind-exit tag) label)
	    (wt-nl "if (env->go_label_index==(" (tag-index tag) "))")
	    (wt-go (tag-label tag))))
	(when (var-ref-ccb tag-loc)
	  ;;(wt-nl "fprintf(stderr, \"\\nStray tag index: %ld\\n\", mkcl_fixnum_to_word(env->values[0]));") ;; debug JCB
	  ;;(wt-nl "fprintf(stderr, \"among %lu values.\\n\", env->nvalues);") ;; debug JCB
	  (wt-nl "mkcl_lose(env, \"GO found an inexistent tag\");"))
	(wt-nl "}")
	(let ((*unwind-exit* (cons label *unwind-exit*)))
	  (c2tagbody-body body))
	(when closure-block-id
	  (wt-nl-h "#define " (written-function-cname) "_cblock_" closure-block-id " "
		   (first *closure-levels*))
	  )
	(when env-grows (wt "}"))))
  )

(defun c2tagbody-body (body)
  ;;; INV: BODY is a list of tags and forms. We have processed the body
  ;;; so that the last element is always a form producing NIL.
  (do ((l body (cdr l)))
      ((null l))
    (let* ((this-form (first l)))
      (cond ((tag-p this-form)
	     (wt-label (tag-label this-form)))
	    ((endp (rest l))
	     ;; Last form, it is never a label!
	     (c2expr this-form))
	    (t
	     (let* ((next-form (second l))
		    (*exit* (if (tag-p next-form)
				(tag-label next-form)
				(next-label)))
		    (*unwind-exit* (cons *exit* *unwind-exit*))
		    (*destination* 'TRASH))
	       (c2expr this-form)
	       (unless (tag-p next-form)
		 (wt-label *exit*))))))))

(defun c1go (args &aux var)
  (check-args-number 'GO args 1 1)
  (let ((name (first args)))
    (unless (or (symbolp name) (integerp name))
      (cmperr "The tag name ~s is not a symbol nor an integer." name))
    (multiple-value-bind (tag ccb clb unw)
	(cmp-env-search-tag name)
      (unless tag
	(cmperr "Undefined tag ~A" name))
      (setq var (tag-var tag))
      (cond (ccb (setf (tag-ref-ccb tag) t
		       (var-ref-ccb var) T
		       (var-kind var) 'CLOSURE))
	    (clb (setf (tag-ref-clb tag) t
		       (var-ref-clb var) t
		       (var-kind var) 'LEXICAL))
	    (unw (unless (var-kind var)
		   (setf (var-kind var) :OBJECT))))
      (incf (var-ref var))
      (incf (tag-ref tag))
      (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw))))))

(defun c2go (tag nonlocal)
  (if nonlocal
      (let ((var (tag-var tag)))
	(wt-nl "mkcl_go(env, " var ", " (tag-index tag) ");")
	)
      ;; local go
      (progn
	(unwind-no-exit (tag-unwind-exit tag))
	(wt-nl) (wt-go (tag-label tag)))))

;;; ------------------------------------------------------------

(put-sysprop 'tagbody 'c1special 'c1tagbody)
(put-sysprop 'tagbody 'c2 'c2tagbody)

(put-sysprop 'go 'c1special 'c1go)
(put-sysprop 'go 'c2 'c2go)