; Copyright (c) 2004-2006 by Juliusz Chroboczek.
; Experimental; do not redistribute.

(in-package cpc)

(defvar *fresh-counter*)
(declaim (type (unsigned-byte 28) *fresh-counter*))

(defvar *cpc-debug* nil)

(defvar *cpc-check* t)

(defvar *cpc-tail-recurse* nil)

(eval-when (:load-toplevel :execute :compile-toplevel)
  (defmacro cpc-assert (form)
    "Like ASSERT, but only when *CPC-CHECK*."
    `(when *cpc-check*
      (assert ,form)))
  )

(defun voidp (type)
  (declare (list type))
  (assert (not (null type)))
  (equal type '((void) nil)))

(defun canonicalise-arglist (arglist)
  "Map (void) to just ()."
  (if (equal arglist '(((void) nil)))
      '()
      arglist))

(defun append-arglist (a1 a2)
  "Append two arglists, canonicalising in the process."
  (append (canonicalise-arglist a1) (canonicalise-arglist a2)))

(defun cpc-prefix-p (name)
  "Return t if NAME starts with cpc__."
  (declare (string name))
  (and (>= (length name) 5)
       (equal "cpc__" (subseq name 0 5))))

(defun maybe-cpc-prefix (name)
  "Return NAME with the prefix cpc__ added if needed."
  (declare (string name))
  (if (cpc-prefix-p name) name
      (the string (format nil "cpc__~A" name))))

(defun environment-cps-p (name env)
  "Return true if NAME is bound to a CPS function in ENV."
  (declare (string name) (list env))
  (dolist (e env)
    (when (and (member 'cps (cadr e))
               (equal name (car e)))
      (return-from environment-cps-p t)))
  nil)

(defun cps-p (name env)
  "Return true if NAME is the name of a CPS function."
  (declare (string name))
  (or
   (cpc-prefix-p name)
   (environment-cps-p name env)))

(defun fresh-name (&optional (prefix "fresh"))
  "Generate a fresh variable name."
  (declare (string prefix))
  (prog1
      (the string (format nil "~A_~D"
                          (maybe-cpc-prefix prefix)
                          *fresh-counter*))
    (incf *fresh-counter*)))

(defun arglist-struct-name (name)
  (declare (string name))
  (the string (format nil "~A_arglist" (maybe-cpc-prefix name))))

(defun arglist-constructor-name (name)
  (declare (string name))
  (the string (format nil "~A_new_arglist" (maybe-cpc-prefix name))))

(defvar *null* '(cast 0 ((void) ((*) nil))))

(defun construct-arglist (name args continuation)
  (declare (string name) (list args))
  `(statement (expression
               (= ,continuation
                (apply ,(arglist-constructor-name name)
                       ,(append args (list continuation)))))))

(defun block-item-p (x)
  (and (consp x) (member (car x) '(statement definition declaration))))

(defun make-block (list)
  "Make a block out of a block-item list."
  (declare (list list))
  (assert (or (null list)
              (block-item-p (car list))))
  (when *cpc-check*
    (dolist (item list) (check-block-item item)))
  (cons 'block list))

(defun ensure-block (s &optional terminate)
  "Make sure that a statement-no-head is a block."
  (if (eql 'block (car s))
      (if (or (not terminate)
              (equal '(statement (return nil)) (car (last s))))
          s
          (make-block (append (cdr s) (list '(statement (return nil))))))
      (make-block (if terminate
                      (list `(statement ,s) '(statement (return nil)))
                      (list `(statement ,s))))))

(defun maybe-deconstruct-block (s &optional return-okay)
  "Transform a block of a single statement into a statement.
Works on snh."
  (if (and (eql 'block (car s))
           (eql 'statement (car (cadr s)))
           (or (null (cddr s))
               (and return-okay
                    (return-p (caddr s))
                    (null (cdddr s)))))
      (cadr (cadr s))
      s))

(defun terminate-block-item-list (b)
  "Ensure that a block-item-list is terminated with return."
  (when *cpc-check*
    (dolist (item b) (check-block-item item)))
  (let ((last (last b)))
    (if (return-p (car last))
        b
        (append b (list '(statement (return nil)))))))

(defun block-prepend-label (name b)
  (when *cpc-check*
    (dolist (item b) (check-block-item item)))
  (if (eql (caar b) 'statement)
      `((statement (label ,name ,(car b)))
        ,@(cdr b))
      `((statement (label ,name (statement (expression nil))))
        ,@b)))

(defun check-block-item (item)
  (assert (block-item-p item))
  (when *cpc-check*
    (when (eql 'statement (car item))
      (check-snh (cadr item))))
  item)

(defun check-statement (s)
  (assert (eql 'statement (car s)))
  (check-snh (cadr s))
  s)

(defun check-snh (snh)
  (when *cpc-check*
    (when (eql 'block (car snh))
      (dolist (item (cdr snh))
        (check-block-item item)))
    (when (and (eql 'expression (car snh))
               (listp (cadr snh))
               (member (car (cadr snh)) '(apply cps-apply)))
      (let ((e (cadr snh)))
        (assert (listp (caddr e)))
        (assert (not (member 'nil (caddr e)))))))
  snh)

(defun check-block-item-list (list)
  (declare (list list))
  (when *cpc-check*
    (dolist (item list)
      (check-block-item item)))
  list)

(defun statement-append (s list)
  "Append a block-item list to a statement."
  (assert (eql (car s) 'statement))
  (list 'statement (snh-append (cadr s) list)))

(defun snh-append (snh list)
  "Append a block-item list to a statement-no-head."
  (if (eql (car snh) 'block)
      (make-block (append (cdr snh) list))
      (make-block (cons `(statement ,snh) list))))

(defun statement-member (list s)
  "Return t if the block-item list LIST is a tail of statement S."
  (assert (eql (car s) 'statement))
  (snh-member list (cadr s)))

(defun snh-member (list snh)
  "Return t if the block-item list LIST is a tail of SNH."
  (check-snh snh)
  (and (eql (car snh) 'block)
       (tailp list (cdr snh))))

(defun direct-declarator-name (x)
  "Return the name declared by a direct-declarator."
  (the string
    (cond
      ((null x) (error "Abstract declarator where declarator expected"))
      ((atom x) (the string x))
      ((eql 'declarator (car x)) (declarator-name (cadr x)))
      (t (direct-declarator-name (cadr x))))))

(defun declarator-name (x)
  "Return the name declared by a declarator."
  (assert (null (cdddr x)))
  (assert (or (null (caddr x)) (eql 'asm (caaddr x))))
  (the string (direct-declarator-name (cadr x))))

(defun init-declarator-name (x)
  "Return the name declared by an init-declarator."
  (the string (declarator-name (car x))))

(defun arglist-names (arglist)
  (mapcar #'(lambda (arg) (declarator-name (cadr arg))) arglist))

(defun declaration-names (x)
  "Return the list of names declared by a declaration."
  (declare (cons x))
  (assert (eql (car x) 'declaration))
  (mapcar #'init-declarator-name (caddr x)))

(defun make-qlist-declarator (type name)
  "Make a pair of a s-q-list and a declarator given a type and a name."
  (assert (null (cddr type)))
  (list (car type) (make-declarator (cadr type) name)))

(defun make-declarator (a-declarator name)
  "Make a declarator out of an abstract declarator and a name."
  (cond
    ((null a-declarator) (list nil name))
    (t (list (car a-declarator)
             (make-direct-declarator (cadr a-declarator) name)))))

(defun make-direct-declarator (a-dd name)
  (cond
    ((atom a-dd) name)
    (t
     (ecase (car a-dd)
       ((declarator) `(declarator ,(make-declarator (cadr a-dd) name)))
       ((array function)
        `(,(car a-dd)
           ,(make-direct-declarator (cadr a-dd) name) ,(caddr a-dd)))))))

(defun rename-arglist (arglist names)
  (declare (list arglist names))
  (assert (= (length arglist) (length names)))
  (mapcar
   #'(lambda (arg name)
       (list (car arg) (make-declarator (cadr arg) name)))
   arglist names))

(defun make-pointer (tn)
  (let* ((ad (cadr tn))
         (ad*
          (if ad
              (list (cons '* (car ad)) (cadr ad))
              '((*) nil))))
    (list (car tn) ad*)))

(defun function-definition-name (x)
  "Return the name defined by a function definition."
  (declare (cons x))
  (assert (eql (car x) 'definition))
  (declarator-name (caddr x)))

(defun function-declarator-p (declarator)
  "Return t if DECLARATOR declares a function."
  (declare (list declarator))
  (if (null declarator)
      'nil
      (let ((direct-declarator (cadr declarator)))
        (and (listp direct-declarator)
             (ecase (car direct-declarator)
               ((function) t)
               ((declarator) (function-declarator-p (cadr direct-declarator)))
               ((array) nil))))))

(defun function-return-type (specifiers declarator)
  (assert (eq 'function (car (cadr declarator))))
  (list (function-return-type* specifiers) nil))

(defun function-return-type* (l)
  (cond
    ((null l) '())
    ((member (car l) '(typedef extern static auto register))
     ;; storage class specifier
     (function-return-type* (cdr l)))
    ((member (car l) '(const __const restrict __restrict volatile))
     ;; type qualifier
     (function-return-type* (cdr l)))
    ((member (car l) '(inline __inline __inline__ cps))
     ;; function specifier
     (function-return-type* (cdr l)))
    (t
     (cons (car l) (function-return-type* (cdr l))))))

(defun environment-return-type (name env)
  (declare (string name))
  (let ((sd (cdr (assoc name env :test #'equal))))
    (when (null sd)
      (error "Couldn't find ~S in current environment" name))
    (function-return-type (car sd) (cadr sd))))

(defun function-declarator-argument-names (declarator)
  "Return the argument names of a function declarator."
  (declare (cons declarator))
  (let ((direct-declarator (cadr declarator)))
    (ecase (car direct-declarator)
      ((function)
       (let ((parameter-type-list
              (canonicalise-arglist (caddr direct-declarator))))
         (reduce #'append
                 (mapcar #'parameter-declaration-names parameter-type-list))))
      ((declarator)
       (function-declarator-argument-names (cadr direct-declarator))))))

(defun function-declarator-arglist (declarator)
  "Return the arglist of a function declarator."
  (declare (cons declarator))
  (let ((direct-declarator (cadr declarator)))
    (ecase (car direct-declarator)
      ((function) (canonicalise-arglist (caddr direct-declarator)))
      ((declarator) (function-declarator-arglist (cadr direct-declarator))))))

(defun statement-apply-deconstruct (s)
  (declare (cons s))
  (and (eql 'statement (car s))
       (let ((snh (cadr s)))
         (and (eql 'expression (car snh))
              (let ((sex (cadr snh)))
                (cond
                  ((member (car sex) '(apply cps-apply))
                   (values (car sex) (cadr sex) (caddr sex)))
                  (t nil)))))))

(defun parameter-declaration-names (p)
  "Return the list of names bound by a parameter declaration."
  (if (or (eql '|...| p) (equal '(((void) nil)) p))
      '()
      (and (cadr p)
           (list (declarator-name (cadr p))))))

(defun free-names (form)
  "Return the list of names free in a given form (block item)."
  (the list
    (ecase (car form)
      ((declaration) (declaration-free-names form))
      ((statement) (statement-free-names form))
      ((definition) (function-definition-free-names form)))))

(defun declaration-free-names (form)
  "Return the list of names free in a declaration."
  (assert (eql 'declaration (car form)))
  (let* ((init-declarators (cadr form)))
    (the list
      (apply #'union-string (mapcar #'init-declarator-free-names init-declarators)))))

(defun init-declarator-free-names (i)
  "Return the list of names free in an init-declarator."
  (let ((init (cadr i)))
    (when (eql 'initializer-list (car init))
      (error "Initializer list not implemented yet"))
    (expression-free-names (list 'expression i))))

(defun statement-free-names (form)
  "Return the list of names free in a statement."
  (assert (eql (car form) 'statement))
  (let ((no-head (cadr form)))
    (ecase (car no-head)
      ((label) (statement-free-names (caddr no-head)))
      ((block) (block-free-names (cdr no-head)))
      ((expression) (expression-free-names (cadr no-head)))
      ((while) (union-string
                (expression-free-names (cadr no-head))
                (statement-free-names (caddr no-head))))
      ((do-while) (union-string
                   (statement-free-names (cadr no-head))
                   (expression-free-names (caddr no-head))))
      ((for) (union-string
              (expression-free-names (cadr no-head))
              (expression-free-names (caddr no-head))
              (expression-free-names (fourth no-head))
              (statement-free-names (fifth no-head))))
      ((if) (union-string
             (expression-free-names (cadr no-head))
             (statement-free-names (caddr no-head))
             (and (fourth no-head) (statement-free-names (fourth no-head)))))
      ((goto continue break cpc_yield cps-yield cpc_done cps-done) '())
      ((return cpc_wait cps-wait)
       (and (cadr no-head)
            (expression-free-names (cadr no-head))))
      ((cpc_sleep cps-sleep cpc_io_wait cps-io-wait)
       (union-string
        (expression-free-names (cadr no-head))
        (and (caddr no-head) (expression-free-names (caddr no-head)))
        (and (cadddr no-head) (expression-free-names (cadddr no-head)))))
      ((cpc_spawn cpc_fork)
       (statement-free-names (cadr no-head)))
      ((cps-fork)
       (adjoin-string
        (cadr no-head)
        (expression-free-names (caddr no-head)))))))

(defun function-definition-free-names (d)
  "Return the list of names free in a function definition."
  (assert (eql 'definition (car d)))
  (let ((declarator (caddr d))
        (body (fifth d)))
    (assert (eql 'block (car body)))
    (set-difference
     (block-free-names (cdr body)
                       (function-declarator-argument-names declarator))
     (function-declarator-argument-names (caddr d))
     :test #'equal)))

(defun block-free-names (l &optional (bound-names nil))
  "Return the list of names free in a block-item-list."
  (cond
    ((null l) '())
    (t (ecase (caar l)
         ((declaration)
          (block-free-names (cdr l)
                            (union-string bound-names
                                          (declaration-names (car l)))))
         ((statement)
          (union-string
           (set-difference (statement-free-names (car l))
                           bound-names :test #'equal)
           (block-free-names (cdr l) bound-names)))
         ((definition)
          (union-string
           (set-difference (function-definition-free-names (car l))
                           bound-names :test #'equal)
           (block-free-names (cdr l) bound-names)))))))

(defun expression-free-names (e)
  "Return the list of names free in an expression."
  (cond
    ((stringp e)
     (if (member (aref e 0) '(#\' #\"))
         '()
         (list e)))
    ((or (symbolp e) (numberp e)) '())
    ((not (listp e)) (error "Unexpected expression ~S" e))
    ((member (car e) '(apply cps-apply))
     (adjoin-string
      (cadr e)
      (apply #'union-string (mapcar #'expression-free-names (caddr e)))))
    ((eql (car e) 'sizeof-type) '())
    ((eql (car e) 'cast)
     (expression-free-names (cadr e)))
    (t
     (apply #'union-string (mapcar #'expression-free-names (cdr e))))))

;; Environments are a-lists with elements of the form
;;  (name . (specifier-list declarator)

(defun check-environment (env)
  (declare (list env))
  (when *cpc-check*
    (mapc #'(lambda (e)
              (assert (string (car e)))
              (assert (list (cadr e)))
              (assert (not (null (caddr e))))
              (assert (null (cdddr e))))
          env)))

(defun declaration-environment (declaration)
  "Return the environment induced by a declaration."
  (assert (eql 'declaration (car declaration)))
  (let ((specifiers (cadr declaration))
        (init-declarator-list (caddr declaration)))
    (mapcar
     #'(lambda (init-declarator)
         (cons (init-declarator-name init-declarator)
               (list specifiers (car init-declarator))))
     init-declarator-list)))

(defun definition-environment (definition)
  "Return the environment created by a definition."
  (cons (function-definition-name definition)
        (list (cadr definition) (caddr definition))))

(defun definition-arglist-environment (definition)
  "Return the environment induced by the arglist of a function definition."
  (assert (eql 'definition (car definition)))
  (let* ((declarator (caddr definition))
         (arglist (function-declarator-arglist declarator)))
    (reduce #'append
            (mapcar #'declaration-environment
                    (arglist-to-declaration-list arglist)))))

(defun environment-names (env)
  "Return the list of names bound in an environment."
  (check-environment env)
  (mapcar #'car env))

(defun environment-nonfunction-names (env)
  "Return the list of variable names bound in an environment."
  (environment-names
   (remove-if #'(lambda (x) (function-declarator-p (caddr x))) env)))

(defun environment-arglist (names env)
  (mapcar
   #'(lambda (n)
       (let ((e (assoc n env :test #'equal)))
         (assert e () "Couldn't find ~S in environment" n)
         (cdr e)))
   names))
  
(defun environment-cps-names (env)
  "Return the list of CPS function names bound in an environment."
  (environment-names
   (remove-if #'(lambda (x) (not (member 'cps (cadr x)))) env)))

(defun compute-sizeof (type)
  (cond
    ((voidp type) 0)
    (t (error "Sizeof ~S not implemented" type))))

(defparameter *function-ignorables* 
  '(const __const restrict __restrict volatile ; type qualifiers
    inline __inline __inline__ cps      ; function specifiers
    typedef extern static auto register ; storage class specifiers
    ))

(defun function-ignorable-p (sq)
  (declare (atom sq))
  (member sq *function-ignorables*))

(defun environment-result-size (name env)
  (declare (simple-string name))
  (let ((s-d (cdr (assoc name env :test #'equal))))
    (unless s-d (error "Couldn't find function ~S in environment" name))
    (let ((specifier-list (remove-if #'function-ignorable-p (car s-d)))
          (declarator (cadr s-d)))
      (unless (function-declarator-p declarator)
        (error "~S is not a function" name))
      (compute-sizeof (list specifier-list (car declarator))))))

(defvar *new-definitions*)
(defvar *return-type*)

(declaim (list *new-definitions*))

(defun block-item-find-break (s)
  (ecase (car s)
    ((statement) (snh-find-break (cadr s)))
    ((declaration definition) nil)))

(defun block-find-break (l)
  (and l
       (or (block-item-find-break (car l))
           (block-find-break (cdr l)))))

(defun snh-find-break (s)
  (case (car s)
    ((break continue) s)
    ((block) (block-find-break (cdr s)))
    ((label case) (block-item-find-break (caddr s)))
    ((default) (block-item-find-break (cadr s)))
    ((if) (or (block-item-find-break (caddr s))
              (and (fourth s) (block-item-find-break (fourth s)))))
    (t nil)))

(defun block-item-gotoify-break (s b c)
  (ecase (car s)
    ((statement) `(statement ,(snh-gotoify-break (cadr s) b c)))
    ((declaration definition) s)))

(defun block-gotoify-break (l b c)
  (and l
       (cons (block-item-gotoify-break (car l) b c)
             (block-gotoify-break (cdr l) b c))))

(defun snh-gotoify-break (s b c)
  (case (car s)
    ((break) `(goto ,b))
    ((continue) `(goto ,c))
    ((block) (make-block (block-gotoify-break (cdr s) b c)))
    ((label case)
     `(,(car s) ,(cadr s) ,(block-item-gotoify-break (caddr s) b c)))
    ((default) `(,(car s) ,(block-item-gotoify-break (cadr s) b c)))
    ((if) `(,(car s) ,(cadr s)
            ,(block-item-gotoify-break (caddr s) b c)
            ,(and (fourth s) (block-item-gotoify-break (fourth s) b c))))
    (t s)))

(defun loop-gotoify-break (form)
  (ecase (car form)
    ((while switch)
     (cond
       ((block-item-find-break (caddr form))
        (let* ((b (fresh-name "break"))
               (c (fresh-name "continue"))
               (body (block-item-gotoify-break (caddr form) b c)))
          (make-block
           `((statement
              (,(car form) ,(cadr form)
               (statement
                ,(make-block
                  `(,body
                    (statement (label ,c (statement (expression nil)))))))))
             (statement (label ,b (statement (expression nil))))))))
       (t form)))
    ((do-while)
     (cond
       ((block-item-find-break (cadr form))
        (let* ((b (fresh-name "break"))
               (c (fresh-name "continue"))
               (body (block-item-gotoify-break (cadr form) b c)))
          (make-block
           `((statement
              (do-while
               (statement
                ,(make-block
                  `(,body
                    (statement (label ,c (statement (expression nil)))))))))
             (statement (label ,b (statement (expression nil))))))))))
    ((for)
     (cond
       ((block-item-find-break (fifth form))
        (let* ((b (fresh-name "break"))
               (c (fresh-name "continue"))
               (body (block-item-gotoify-break (fifth form) b c)))
          (make-block
           `((statement
              (for ,(cadr form) ,(caddr form) ,(fourth form)
               (statement
                ,(make-block
                  `(,body
                    (statement (label ,c (statement (expression nil)))))))))
             (statement (label ,b (statement (expression nil))))))))
       (t form)))))

(defun gotoify-for (form)
  "Convert a for into a bunch of gotos."
  (assert (eql 'for (car form)))
  (let ((new-form (loop-gotoify-break form)))
    (unless (eq form new-form)
      (return-from gotoify-for new-form)))
  (make-block
   (list
    `(statement (expression ,(cadr form)))
    `(statement
      ,(gotoify-while
        `(while ,(caddr form)
          (statement
           (block ,(fifth form)
             (statement (expression ,(fourth form)))))))))))

(defun gotoify-while (form)
  "Convert a while into a block and a goto (doesn't deal with return yet)."
  (assert (eql 'while (car form)))
  (let ((new-form (loop-gotoify-break form)))
    (unless (eq form new-form)
      (return-from gotoify-while new-form)))
  (let ((l (fresh-name "while")))
    `(label ,l
      (statement
       (if ,(cadr form)
           (statement (block ,(caddr form) (statement (goto ,l)))))))))

(defun gotoify-do-while (form)
  "Convert a do-while into a block and a goto (doesn't deal with return yet)."
  (assert (eql 'do-while (car form)))
  (let ((new-form (loop-gotoify-break form)))
    (unless (eq form new-form)
      (return-from gotoify-do-while new-form)))
  (let ((l (fresh-name "do")))
    `(label ,l
      (statement
       (block
         ,(cadr form)
         (statement
          (if ,(caddr form) 
              (statement (expression nil))
              (statement (goto ,l)))))))))

(defun collect-cases (l)
  (let ((s (car l)))
    (cond
      ((null l) '())
      ((and (eq 'statement (car s))
            (eq 'block (car (cadr s))))
       (append
        (collect-cases (cdr (cadr s)))
        (collect-cases (cdr l))))
      ((and (eq 'statement (car s))
            (eq 'case (car (cadr s))))
       (acons (cadr (cadr s))
              (fresh-name "case")
              (collect-cases (cdr l))))
      ((and (eq 'statement (car s))
            (eq 'default (car (cadr s))))
       (acons nil
              (fresh-name "default")
              (collect-cases (cdr l))))
      (t (collect-cases (cdr l))))))

(defun gotoify-cases (l labels)
  (let ((s (car l)))
    (cond
      ((null l) '())
      ((and (eq 'statement (car s))
            (eq 'block (car (cadr s))))
       (cons
        `(statement ,(make-block (gotoify-cases (cdr (cadr s)) labels)))
        (gotoify-cases (cdr l) labels)))
      ((and (eq 'statement (car s))
            (eq 'case (car (cadr s))))
       (let ((label (cdr (assoc (cadr (cadr s)) labels :test #'equal))))
         (assert (not (null label)))
         (cons
          `(statement (label ,label ,(caddr (cadr s))))
          (gotoify-cases (cdr l) labels))))
      ((and (eq 'statement (car s))
            (eq 'default (car (cadr s))))
       (let ((label (cdr (assoc nil labels))))
         (assert (not (null label)))
         (cons
          `(statement (label ,label ,(cadr (cadr s))))
          (gotoify-cases (cdr l) labels))))
      (t (cons s (gotoify-cases (cdr l) labels))))))

(defun iffify-switch (var labels default)
  (declare (list labels) (string default))
  (cond
    ((null labels) `(statement (goto ,default)))
    (t
     (let ((value (caar labels)) (label (cdar labels)))
       `(statement
         (if (== ,var ,value)
             (statement (goto ,label))
             ,(iffify-switch var (cdr labels) default)))))))

(defun gotoify-switch (form)
  (assert (eql 'switch (car form)))
  (let ((new-form (loop-gotoify-break form)))
    (unless (eq form new-form)
      (return-from gotoify-switch new-form)))
  (let* ((expression (cadr form))
         (body (cdr (cadr (caddr form))))
         (labels (collect-cases body))
         (block-end (fresh-name "switch_end"))
         (cases (remove nil labels :key #'car))
         (default (or (cdr (assoc nil labels)) block-end))
         (new-body (gotoify-cases body labels))
         (var (fresh-name "case")))
    `(block
      (declaration (int) (((nil ,var))))
      (statement (expression (= ,var ,expression)))
      ,(iffify-switch var cases default)
      ,@new-body
      (statement (label ,block-end (statement (expression nil)))))))

(defun gotoify-statement (s)
  "Convert a loop or a switch SNH into gotos."
  (ecase (car s)
    ((for) (gotoify-for s))
    ((while) (gotoify-while s))
    ((do-while) (gotoify-do-while s))
    ((switch) (gotoify-switch s))))

(defun return-p (s)
  "Return true if S is a return."
  (and (eql (car s) 'statement)
       (eql (car (cadr s)) 'return)))

(defun void-return-p (s)
  (and (return-p s)
       (null (cadr (cadr s)))))

(defun goto-p (s)
  "Return true if S is a goto."
  (and (eql 'statement (car s))
       (eql 'goto (caadr s))))

(defun trivial-statement-p (s)
  "Return true if S is a return or a goto."
  (or (return-p s) (goto-p s)))

(defun explicit-continuation (l &optional explicit)
  "Return the explicit and nonexplicit parts of the block-item-list l."
  (declare (list l explicit))
  (cond
    ((not (eql 'statement (caar l))) (values (nreverse explicit) l))
    ((return-p (car l)) (values (nreverse explicit) l))
    ((statement-cps-apply-p (car l))
     (explicit-continuation (cdr l) (cons (car l) explicit)))
    (t (values (nreverse explicit) l))))

(defun block-functionalise-goto (block label f)
  "Convert label LABEL into a function F."
  (declare (string label f))
  (check-block-item-list
   (let ((s (car block)))
     (cond
       ((null block) '())
       ((and (eql (car s) 'statement)
             (eql (car (cadr s)) 'label)
             (equal (cadr (cadr s)) label))
        (let ((trivial (member-if #'trivial-statement-p (cdr block))))
          (unless trivial
            (throw 'transform (list :trivialise-block block)))
          (append
           `((definition
              ,(cons 'cps (car *return-type*))
              (,(cadr *return-type*) (function ,f nil))
              ()
              ,(make-block
                (append
                 (functionalise-goto (caddr (cadr s)) label f)
                 (block-functionalise-goto
                  (append (copy-until (cdr block) trivial)
                          (list (car trivial)))
                  label f)))))
           (if (voidp *return-type*)
               `((statement (expression (cps-apply ,f ())))
                 (statement (return nil)))
               `((statement (return (cps-apply ,f ())))))
           (block-functionalise-goto (cdr trivial) label f))))
       ((and (eql (car s) 'statement)
             (eql (car (cadr s)) 'label)
             (eql (car (caddr (cadr s))) 'statement)
             (eql (car (cadr (caddr (cadr s)))) 'label)
             ;; embedded labels
             (block-functionalise-goto
              `((statement (label ,(cadr (cadr s)) 
                            (statement (expression nil))))
                ,(caddr (cadr s))
                ,@(cdr block))
              label f)))
       ((and (eql (car s) 'statement)
             (eql (car (cadr s)) 'block))
        `((statement
           ,(make-block
             (block-functionalise-goto (cdr (cadr s)) label f)))
          ,@(block-functionalise-goto (cdr block) label f)))
       (t (append (functionalise-goto s label f)
                  (block-functionalise-goto (cdr block) label f)))))))

(defun functionalise-goto (x label f)
  "Convert label LABEL into a function F, return a list of statements."
  (declare (string label f))
  (check-block-item-list
   (ecase (car x)
     ((declaration) (list x))
     ((definition) (list (function-definition-functionalise-goto x label f)))
     ((statement)
      (let ((s (cadr x)))
        (case (car s)
          ((goto)
           (if (equal (cadr s) label)
               (if (voidp *return-type*)
                   `((statement (expression (cps-apply ,f ())))
                     (statement (return nil)))
                   `((statement (return (cps-apply ,f ())))))
               (list x)))
          ((block)
           (list
            (list 'statement
                  (make-block (block-functionalise-goto (cdr s) label f)))))
          ((if)
           (list
            `(statement (,(car s)
                         ,(cadr s)
                         ,(functionalise-goto-statement (caddr s) label f)
                         ,(and (fourth s)
                               (functionalise-goto-statement
                                (fourth s) label f))))))
          ((while)
           (list
            `(statement (while ,(cadr s)
                          ,(functionalise-goto-statement (caddr s) label f)))))
          ((for)
           (list
            `(statement (for ,(cadr s)
                             ,(caddr s)
                             ,(fourth s)
                             ,(functionalise-goto-statement
                               (fifth s) label f)))))
          ((label)
           (if (equal (cadr s) label)
               (error "Impossible")
               (list
                `(statement
                  (label ,(cadr s)
                   ,(functionalise-goto-statement (caddr s) label f))))))
          (t (list x))))))))

(defun functionalise-goto-statement (x label f)
  "Convert label LABEL into a function F, return a statement."
  (declare (string label f))
  (let ((l (functionalise-goto x label f)))
    (if (null (cdr l))
        (car l)
        `(statement ,(make-block l)))))

(defun function-definition-functionalise-goto (d label
                                               &optional
                                               (f (fresh-name label)))
  "Convert label LABEL into a function F."
  (declare (string label f))
  (assert (eql 'definition (car d)))
  (let ((*return-type* (function-return-type (cadr d) (caddr d))))
    (list
     (car d) (cadr d) (caddr d) (fourth d)
     (make-block (block-functionalise-goto (cdr (fifth d)) label f)))))

(defun function-definition-trivialise-block (d block)
  "Make the continuation of BLOCK explicit."
  (assert (eql 'definition (car d)))
  (let ((*return-type* (function-return-type (cadr d) (caddr d))))
    (list
     (car d)
     (cadr d)
     (caddr d)
     (fourth d)
     (if (snh-member block (fifth d))
         (snh-append
          (fifth d)
          (if (voidp *return-type*)
              `((statement (return nil)))
              `((statement (return (cast 42 ,*return-type*))))))
         (make-block (block-trivialise-block (cdr (fifth d)) block))))))

(defun block-trivialise-block (l block)
  "Make the continuation of BLOCK explicit."
  (declare (list l block))
  (cond
    ((null l) '())
    ((eql l block) (error "Impossible"))
    (t
     (ecase (caar l)
       ((declaration) (cons (car l) (block-trivialise-block (cdr l) block)))
       ((definition)
        (cons (function-definition-trivialise-block (car l) block)
              (block-trivialise-block (cdr l) block)))
       ((statement)
        (or (block-statement-trivialise-block (car l) (cdr l) block)
            (cons (statement-trivialise-block (car l) block)
                  (block-trivialise-block (cdr l) block))))))))

(defun block-statement-trivialise-block (s rest block)
  "Make the continuation of BLOCK in S followed with REST,
return NIL on failure."
  (assert (eql 'statement (car s)))
  (multiple-value-bind (snh* name)
      (snh-trivialise-block (cadr s) block)
    (and snh*
         (progn
           (assert name)
           (cons `(statement ,snh*)
                 (block-prepend-label name rest))))))

(defun snh-trivialise-block (s block)
  "The real work of BLOCK-STATEMENT-TRIVIALISE-BLOCK.
Returns a new SNH and a label to stick at the end."
  (case (car s)
    ((block)
     (and (snh-member block s)
          (let ((name (fresh-name "trivial_block")))
            (values
             (snh-append s `((statement (goto ,name))))
             name))))
    ((label)
     (and (statement-member block (caddr s))
          (let ((name (fresh-name "trivial_label")))
            (values
             `(label ,(cadr s)
               ,(statement-append (caddr s)
                                  `((statement (goto ,name)))))
             name))))
    ((if)
     (and (or (statement-member block (caddr s))
              (and (fourth s) (statement-member block (fourth s))))
          (let ((name (fresh-name "trivial_if")))
            (values
             (list 'if (cadr s)
                   (statement-append (caddr s) `((statement (goto ,name))))
                   (and (fourth s)
                        (statement-append (fourth s)
                                          `((statement (goto ,name))))))
             name))))
    (t nil)))
     

(defun statement-trivialise-block (s block)
  "Make the continuation of BLOCK explicit."
  (assert (eql 'statement (car s)))
  (list 'statement (statement-no-head-trivialise-block (cadr s) block)))

(defun statement-no-head-trivialise-block (s block)
  "Make the continuation of BLOCK explicit."
  (flet ((ts (s) (statement-trivialise-block s block)))
    (ecase (car s)
      ((label case)
       (assert (eql 'statement (car (caddr s))))
       (multiple-value-bind (snh* name)
           (snh-trivialise-block (cadr (caddr s)) block)
         (if snh*
             (list (car s) (cadr s)
                   (list 'statement
                         (make-block
                          (list `(statement ,snh*)
                                `(statement (label ,name
                                             (statement (expression nil))))))))
             (list (car s) (cadr s) (ts (caddr s))))))
      ((default) (list (car s) (ts (cadr s))))
      ((block) (make-block (block-trivialise-block (cdr s) block)))
      ((if)
       (list (car s) (cadr s) (ts (caddr s)) (and (fourth s) (ts (fourth s)))))
      ((switch while)
       (list (car s) (cadr s) (ts (caddr s))))
      ((do-while) (list (car s) (ts (cadr s)) (caddr s)))
      ((for) (list (car s) (cadr s) (caddr s) (fourth s) (ts (fifth s))))
      ((goto continue break return expression
        cpc_yield cps-yield cpc_done cps-done cpc_wait cps-wait
        cpc_sleep cps-sleep cpc_io_wait cps-io-wait cps-fork)
       s)
      ((cpc_spawn cpc_fork)
       (let ((*return-type* '((void) nil)))
         (list (car s) (ts (cadr s))))))))

(defun make-continuation-explicit (l env)
  "Make l into an explicit continuation."
  (declare (cons l))
  (multiple-value-bind (explicit nonexplicit) (explicit-continuation l)
    (cond
      ((return-p (car nonexplicit)) l)
      ((null nonexplicit) (throw 'transform (list :trivialise-block l)))
      ((goto-p (car nonexplicit))
       (throw 'transform
         (list :functionalise-goto (cadadr (car nonexplicit)))))
      ((statement-cps-known-apply-p (car nonexplicit) env)
       `(,@explicit
         ,@(functionalise-cpc nonexplicit env)))
      (t
       (let ((name (fresh-name "explicit")))
         `(,@explicit
           (statement (goto ,name))
           ,@(block-prepend-label name nonexplicit)))))))

(defparameter *functionalise-cpc-alist*
  '((cpc_yield . cps-yield)
    (cpc_done . cps-done)
    (cpc_wait . cps-wait)
    (cpc_sleep . cps-sleep)
    (cpc_io_wait . cps-io-wait)
    (cpc_fork . cps-fork)))

(defun cpc-to-cps (s)
  (declare (symbol s))
  (the symbol (cdr (assoc s *functionalise-cpc-alist*))))

(defun functionalise-cpc (l env)
  "Convert a CPC construct at the head of L."
  (check-environment env)
  (let* ((s (car l))
         (snh (cadr s)))
    (assert (eql 'statement (car s)))
    (when (null (cdr l))
      (throw 'transform (list :trivialise-block l)))
    (let ((l* (make-continuation-explicit (cdr l) env)))
      (unless (eq l* (cdr l))
        (return-from functionalise-cpc (cons (car l) l*))))
    (cond
      ((eql (car snh) 'cpc_fork)
       (let ((s* (maybe-deconstruct-block (cadr snh) nil)))
         (multiple-value-bind (op name arglist)
             (statement-apply-deconstruct `(statement ,s*))
           (if (and op (or (eql 'cps-apply op) (cps-p name env)))
               `((statement (cps-fork ,name ,arglist))
                 ,@(cdr l))
               (let ((name (fresh-name "fork")))
                 `((definition
                       (cps void) (nil (function ,name nil)) ()
                       ,(ensure-block (cadr s*) t))
                   (statement (cps-fork ,name ()))
                   ,@(cdr l)))))))
      ((cpc-to-cps (car snh))
       `((statement (,(cpc-to-cps (car snh)) ,@(cdr snh)))
         ,@(cdr l)))
      ((eql (car snh) 'expression)
       (let ((e (cadr snh)))
         (ecase (car e)
           ((apply)
            (let ((name (cadr e)) (arglist (caddr e)))
              `((statement (expression (cps-apply ,name ,arglist)))
                ,@(cdr l))))
           ((=)
            (ecase (car (caddr e))
              ((apply)
               (let* ((e* (caddr e))
                      (name (cadr e*)) (arglist (caddr e*)))
                 `((statement
                    (expression (= ,(cadr e)
                                   (cps-apply ,name ,arglist))))
                   ,@(cdr l)))))))))
      (t
       (error "Unexpected cpc construct ~S" snh)))))

(defun make-function-declarator (declarator arglist)
  "Build a function declarator from an arglist"
  (declare (list declarator arglist))
  (let ((direct-declarator (cadr declarator)))
    (ecase (car direct-declarator)
      ((function)
       (list (car declarator) (list 'function (cadadr declarator) arglist)))
      ((declarator)
       (list (car declarator)
             (list 'declarator
                   (make-function-declarator (cadr direct-declarator)
                                             arglist)))))))
  
(defun augment-function-declarator (declarator arglist)
  (declare (list declarator arglist))
  (let ((direct-declarator (cadr declarator)))
    (ecase (car direct-declarator)
      ((function)
       (list (car declarator)
             (list 'function (cadr direct-declarator)
                   ;; old arglist at end
                   (append-arglist arglist (caddr direct-declarator)))))
      ((declarator)
       (list (car declarator)
             (list 'declarator
                   (augment-function-declarator (cadr direct-declarator)
                                                arglist)))))))

(defun augment-function-definition (definition arglist
                                       &optional new-specifiers)
  (declare (list definition arglist))
  (assert (eql 'definition (car definition)))
  (let* ((specifiers (cadr definition))
         (declarator (caddr definition))
         (declaration-list (cadddr definition))
         (statement (fifth definition)))
    (assert (null declaration-list) nil
            "K&R function definition not supported")
    (list 'definition (append new-specifiers specifiers)
          (augment-function-declarator declarator arglist)
          declaration-list statement)))

(defun merge-block (outer-block path)
  (declare (list outer-block path))
  (assert (eql 'block (car outer-block)))
  (let ((inner-block (cadr (member outer-block path))))
    (assert (eql 'block (car inner-block)))
    (let ((outer-names (block-bound-names (cdr outer-block)))
          (inner-names (block-bound-names (cdr inner-block))))
      (unless (null (intersection inner-names outer-names :test #'equal))
        (error "Name collision"))
      (make-block
       (mapcan
        #'(lambda (s)
            (declare (cons s))
            (if (eql s inner-block)
                (copy-list (cdr inner-block))
                (list s)))
        (cdr outer-block))))))

(defun function-definition-escaping-gotos (definition)
  (assert (eql 'definition (car definition)))
  (let* ((lb (statement-no-head-find-gotos (fifth definition) nil :label))
         (gt (statement-no-head-find-gotos (fifth definition) nil :goto)))
    (set-difference gt lb :test #'equal)))

(defun function-definition-incoming-gotos (inner outer)
  (assert (eql 'definition (car inner)))
  (assert (eql 'definition (car outer)))
  (let ((lb (statement-no-head-find-gotos (fifth inner) nil :label))
        (gt (statement-no-head-find-gotos (fifth outer) inner :goto)))
    (intersection gt lb :test #'equal)))

(defun lift-function (definition)
  "Lift all functions in a function definition."
  (assert (eql 'definition (car definition)))
  (let* ((fe (car (last (function-definition-find definition
                                                  :definition-nonclosed))))
         (f (car fe)) (e (cdr fe)))
    (cond
      (f
       (let ((u (function-definition-escaping-gotos f)))
         (when u
           (throw 'transform (list :functionalise-goto (car u)))))
       (let ((u (function-definition-incoming-gotos f definition)))
         (when u
           (throw 'transform (list :functionalise-goto (car u)))))
       (let* ((free-names (free-names f))
              (arglist
               (remove-if
                #'(lambda (x) (function-declarator-p (cadr x)))
                (mapcan
                 #'(lambda (name)
                     (maybe-list
                      (cdr (assoc name e :test #'equal))))
                 free-names))))
          (lift-function (lift-function-1 definition f arglist))))
      (t
       (dolist (d (function-definition-find-all-definitions definition))
         (let ((u (function-definition-escaping-gotos d)))
           (when u
             (throw 'transform (list :functionalise-goto (car u)))))
         (let ((u (function-definition-incoming-gotos d definition)))
           (when u
             (throw 'transform (list :functionalise-goto (car u))))))
       (let ((*new-definitions* '()))
         (let ((new-definition (really-lift-function definition)))
           (append *new-definitions* (list new-definition))))))))


(defun lift-function-1 (definition function arglist)
  (assert (eql 'definition (car definition)))
  (list 'definition
        (cadr definition)
        (caddr definition)
        (cadddr definition)
        (lift-statement-no-head (fifth definition) function arglist)))

(defun lift-statement (s function arglist)
  "Lift a given function in a statement."
  (assert (eql 'statement (car s)))
  (list 'statement (lift-statement-no-head (cadr s) function arglist)))

(defun lift-statement-no-head (s function arglist)
  (flet ((le (e) (lift-expression e function arglist))
         (ls (s) (lift-statement s function arglist)))
    (ecase (car s)
      ((label case)
       (list (car s) (cadr s) (ls (caddr s))))
      ((default)
       (list (car s) (ls (cadr s))))
      ((block)
       (make-block
        (lift-block (cdr s) function arglist)))
      ((if)
       (list (car s)
             (le (cadr s)) (ls (caddr s)) (and (fourth s) (ls (fourth s)))))
      ((switch while)
       (list (car s) (le (cadr s)) (ls (caddr s))))
      ((do-while)
       (list 'do-while (ls (cadr s)) (le (caddr s))))
      ((for)
       (list 'for (le (cadr s)) (le (caddr s)) (le (fourth s)) (ls (fifth s))))
      ((goto continue break cpc_yield cps-yield cpc_done cps-done) s)
      ((return cpc_wait cps-wait)
       (list (car s) (and (cadr s) (le (cadr s)))))
      ((cpc_sleep cps-sleep)
       (list (car s) (le (cadr s))
             (and (caddr s) (le (caddr s))) (and (fourth s) (le (fourth s)))))
      ((cpc_io_wait cps-io-wait)
       (list (car s) (le (cadr s)) (le (caddr s))
             (and (fourth s) (le (fourth s)))))
      ((cpc_spawn cpc_fork)
       (let ((*return-type* '((void) nil)))
         (list (car s) (ls (cadr s)))))
      ((cps-fork)
       (list (car s) (cadr s) (le (caddr s))))
      ((expression)
       (list 'expression (and (cadr s) (le (cadr s))))))))
           
(defun lift-block (l function arglist)
  (declare (list l function arglist))
  "Lift a given function in a block-item list."
  (cond
    ((null l) '())
    (t
     (let ((s (car l)))
       (ecase (car s)
         ((declaration)
          (cond
            ((member-equal (function-definition-name function)
                           (declaration-names s))
             (error "Not implemented yet."))
            (t (cons s (lift-block (cdr l) function arglist)))))
         ((statement)
          (cons (check-statement (lift-statement s function arglist))
                (lift-block (cdr l) function arglist)))
         ((definition)
          (if (eql s function)
              (cons
               (lift-function-definition
                (augment-function-definition s arglist '())
                function arglist)
               (lift-block (cdr l) function arglist))
              (cons
               (lift-function-definition s function arglist)
               (lift-block (cdr l) function arglist)))))))))

(defun lift-function-definition (d function arglist)
  (declare (list d function arglist))
  (list
   (car d)
   (cadr d)
   (caddr d)
   (fourth d)
   (cons 'block (lift-block (cdr (fifth d)) function arglist))))


(defun lift-expression (e function arglist)
  (if arglist
      (lift-expression-1 e (function-definition-name function) arglist)
      e))

(defun lift-expression-1 (e name arglist)
  (declare (list arglist) (string name))
  (cond
    ((not (listp e)) e)
    ((member (car e) '(apply cps-apply cps-apply-later))
     (let ((new-arglist
            (if (equal name (cadr e))
                (mapcar #'declarator-name
                        (canonicalise-arglist arglist))
                '())))
       (list (car e)
             (lift-expression-1 (cadr e) name arglist)
             (append new-arglist
                     (mapcar
                      #'(lambda (e)
                          (lift-expression-1 e name new-arglist))
                      (caddr e))))))
    ((eql (car e) 'sizeof-type) e)
    ((eql (car e) 'cast)
     (list (car e) 
           (lift-expression-1 (cadr e) name arglist)
           (caddr e)))
    (t
     (cons (car e)
           (mapcar
            #'(lambda (e) (lift-expression-1 e name arglist))
            (cdr e))))))

(defun really-lift-function (definition)
  (assert (eql (car definition) 'definition))
  (list
   (car definition)
   (cadr definition)
   (caddr definition)
   (fourth definition)
   (make-block
    (really-lift-block (cdr (fifth definition))))))

(defun really-lift-block (l)
  (declare (list l))
  (if (null l)
      '()
      (ecase (caar l)
        ((statement) (cons (really-lift-statement (car l))
                           (really-lift-block (cdr l))))
        ((declaration) (cons (car l) (really-lift-block (cdr l))))
        ((definition)
         (let ((new-definition
                (if (member 'static (cadr (car l)))
                    (car l)
                    (list* (car (car l))
                           (cons 'static (cadr (car l)))
                           (cddr (car l))))))
           (push (really-lift-function new-definition) *new-definitions*))
         (really-lift-block (cdr l))))))

(defun really-lift-statement (s)
  (assert (eql (car s) 'statement))
  (list 'statement (really-lift-statement-no-head (cadr s))))

(defun really-lift-statement-no-head (s)
  (ecase (car s)
    ((label case)
     (list (car s) (cadr s) (really-lift-statement (caddr s))))
    ((default) (list (car s) (really-lift-statement (cadr s))))
    ((block) (make-block (really-lift-block (cdr s))))
    ((if)
     (list (car s)
           (cadr s)
           (really-lift-statement (caddr s))
           (and (fourth s) (really-lift-statement (fourth s)))))
    ((switch while) (list (car s) (cadr s) (really-lift-statement (caddr s))))
    ((do-while) (list 'do-while (really-lift-statement (cadr s)) (caddr s)))
    ((cpc_spawn cpc_fork)
     (let ((*return-type* '((void) nil)))
       (list (car s) (really-lift-statement (cadr s)))))
    ((for) (list 'for (cadr s) (caddr s) (fourth s)
                 (really-lift-statement (fifth s))))
    ((goto continue break return expression
      cpc_yield cps-yield cpc_done cps-done cpc_wait cps-wait
      cpc_sleep cps-sleep cpc_io_wait cps-io-wait cps-fork)
     s)))

(defun statement-function-definition (s name)
  "Find a given function definition in a statement."
  (declare (string name))
  (cond
    ((null s) nil)
    ((eql 'block (car s)) (block-function-definition (cdr s) name))
    ((eql 'for (car s)) nil)
    ((eql 'while (car s)) nil)
    (t nil)))

(defun block-function-definition (l name)
  "Find a given function definition in a block-item list."
  (declare (string name))
  (if (null l) nil
      (let ((s (car l)))
        (ecase (car s)
          ((declaration) (block-function-definition (cdr l) name))
          ((statement)
           (or (statement-function-definition s name)
               (block-function-definition (cdr l) name)))
          ((definition)
           (if (equal (function-definition-name s) name)
               s
               (block-function-definition (cdr l) name)))))))

(defun block-environment (l)
  (declare (list l))
  (if (null l) nil
      (let ((s (car l)))
        (ecase (car s)
          ((declaration) (append (declaration-environment s)
                                 (block-environment (cdr l))))
          ((definition)
           (cons (definition-environment s) (block-environment (cdr l))))
          ((statement) (block-environment (cdr l)))))))

(defun statement-find (s what &optional env)
  (declare (symbol what) (list env))
  (assert (eql 'statement (car s)))
  (maybe-cons s (statement-no-head-find (cadr s) what env)))

(defun statement-no-head-find (s what &optional env)
  (declare (symbol what) (list env))
  "Find the first non-C feature in a statement."
  (flet ((ef (e) (maybe-cons s (expression-find e what env)))
         (sf (s*) (maybe-cons s (statement-find s* what env))))
    (ecase (car s)
      ((block)
       (maybe-cons s (block-find (cdr s) what
                                 (append (block-environment (cdr s)) env))))
      ((label case) (sf (caddr s)))
      ((default) (sf (cadr s)))
      ((expression return) (ef (cadr s)))
      ((goto continue break cps-yield cps-done) nil)
      ((if)
       (or (ef (cadr s))
           (sf (caddr s))
           (and (fourth s) (sf (fourth s)))))
      ((while)
       (or (ef (cadr s)) (sf (caddr s))))
      ((do-while)
       (or (sf (cadr s)) (ef (caddr s))))
      ((for)
       (or (ef (cadr s))
           (ef (caddr s))
           (ef (fourth s))
           (sf (fifth s))))
      ((switch)
       (or (ef (cadr s)) (sf (caddr s))))
      ((cpc_yield cpc_done) (and (eql what :cpc) (list s)))
      ((cpc_spawn cpc_fork) (or (and (eql what :cpc) (list s))
                                (sf (cadr s))))
      ((cps-fork) (or (ef (cadr s)) (expression-list-find (caddr s) what env)))
      ((cpc_wait) (or (and (eql what :cpc) (list s))
                      (ef (cadr s))))
      ((cps-wait) (ef (cadr s)))
      ((cpc_sleep) (or (and (eql what :cpc) (list s))
                       (ef (cadr s))
                       (and (caddr s) (ef (caddr s)))
                       (and (fourth s) (ef (fourth s)))))
      ((cps-sleep) (or (ef (cadr s))
                       (and (caddr s) (ef (caddr s)))
                       (and (fourth s) (ef (fourth s)))))
      ((cpc_io_wait) (or (and (eql what :cpc) (list s))
                         (ef (cadr s))
                         (ef (caddr s))
                         (and (fourth s) (ef (fourth s)))))
      ((cps-io-wait) (or (ef (cadr s)) (ef (caddr s))))
      )))


(defun expression-find (e what &optional env)
  "Find the first non-C feature in an expression."
  (declare (symbol what) (list env))
  (if (atom e)
      nil
      (case (car e)
        ((apply) (if (and (eql what :cpc)
                          (cps-p (cadr e) env))
                     (list e)
                     (maybe-cons e (expression-list-find
                                    (caddr e) what env))))
        ((= *= /= %= += -= <<= >>= |&=| |^=| ++ -- post-++ post---
          aref |,|)
         (maybe-cons e (expression-find (caddr e) what env)))
        ((+ - * / % & \| |&&| \|\| |~| |!| < > <= >= == !=)
         (maybe-cons e (expression-list-find (cdr e) what env)))
        ((|.| |->|) (maybe-cons e (expression-find (cadr e) what env)))
        (t nil))))

(defun expression-list-find (l what &optional env)
  "Find the first non-C feature in an expression list."
  (declare (symbol what) (list env))
  (and l
       (or (expression-find (car l) what env)
           (expression-list-find (cdr l) what env))))

(defun block-find (l what &optional env)
  "Find the first non-C feature in a block-item sequence."
  (declare (symbol what) (list env))
  (if (null l) nil
      (ecase (caar l)
        ((statement)
         (or (statement-find (car l) what env)
             (block-find (cdr l) what env)))
        ((declaration)
         (block-find (cdr l) what
                     (append (declaration-environment (car l)) env)))
        ((definition)
         (cond
           ((eql what :definition) (list (cons (car l) env)))
           ((and (eql what :definition-nonclosed)
                 (intersection
                  (function-definition-free-names (car l))
                  (environment-nonfunction-names env)
                  :test #'equal))
            (list (cons (car l) env)))
           (t
            (or
             (function-definition-find (car l) what env)
             (block-find (cdr l) what
                         (cons (definition-environment (car l)) env)))))))))

(defun function-definition-find (d what &optional env)
  (declare (symbol what) (list env))
  (assert (eql 'definition (car d)))
  (let ((body (fifth d)))
    (assert (eql 'block (car body)))
    (maybe-cons
     d
     (maybe-cons body
                 (block-find (cdr body) what
                             (cons
                              (definition-environment d)
                              (append (definition-arglist-environment d)
                                      env)))))))

(defun block-find-all-definitions (b)
  (the list
    (if (null b) '()
        (let ((item (car b)))
          (ecase (car item)
            ((declaration) (block-find-all-definitions (cdr b)))
            ((definition) (append
                           (list item)
                           (function-definition-find-all-definitions item)
                           (block-find-all-definitions (cdr b))))
            ((statement)
             (append
              (statement-find-all-definitions item)
              (block-find-all-definitions (cdr b)))))))))

(defun statement-find-all-definitions (s)
  (assert (eql 'statement (car s)))
  (the list
    (snh-find-all-definitions (cadr s))))

(defun snh-find-all-definitions (s)
  (ecase (car s)
    ((block) (block-find-all-definitions (cdr s)))
    ((label case) (statement-find-all-definitions (caddr s)))
    ((default) (statement-find-all-definitions (cadr s)))
    ((if)
     (append (statement-find-all-definitions (caddr s))
             (and (fourth s) (statement-find-all-definitions (fourth s)))))
    ((while switch) (statement-find-all-definitions (caddr s)))
    ((do-while cpc_spawn cpc_fork)
     (statement-find-all-definitions (cadr s)))
    ((for) (statement-find-all-definitions (fifth s)))
    ((expression return goto continue break
      cpc_yield cps-yield cpc_done cps-done cpc_wait cps-wait cpc_sleep
      cps-sleep cpc_io_wait cps-io-wait cps-fork) '())))

(defun function-definition-find-all-definitions (d)
  (assert (eql 'definition (car d)))
  (the list
    (block-find-all-definitions (cdr (fifth d)))))

(defun statement-find-gotos (s exclude what)
  (assert (eql 'statement (car s)))
  (the list
    (and (not (eql s exclude))
         (statement-no-head-find-gotos (cadr s) exclude what))))

(defun statement-no-head-find-gotos (s exclude what)
  (and (not (eql s exclude))
       (case (car s)
         ((block) (block-find-gotos (cdr s) exclude what))
         ((if)
          (append
           (statement-find-gotos (caddr s) exclude what)
           (and (fourth s) (statement-find-gotos (fourth s)
                                                 exclude what))))
         ((while switch) (statement-find-gotos (caddr s) exclude what))
         ((do-while) (statement-find-gotos (cadr s) exclude what))
         ((for) (statement-find-gotos (fifth s) exclude what))
         ((goto) (and (not (eql what :label)) (list (cadr s))))
         ((label)
          (let ((g (statement-find-gotos (caddr s) exclude what)))
            (if (eql what :goto) g (cons (cadr s) g))))
         (t '()))))

(defun block-find-gotos (l exclude what)
  (and (not (or (null l) (eql l exclude)))
       (let ((s (car l)))
         (ecase (car s)
           ((declaration) (block-find-gotos (cdr l) exclude what))
           ((definition)
            (append
             (and (not (eql exclude what))
                  (statement-no-head-find-gotos (fifth s) exclude what))
             (block-find-gotos (cdr l) exclude what)))
           ((statement)
            (append
             (statement-find-gotos (car l) exclude what)
             (block-find-gotos (cdr l) exclude what)))))))

(defun block-bound-names (l)
  (if (null l) '()
      (ecase (caar l)
        ((declaration) (union-string (declaration-names (car l))
                                     (block-bound-names (cdr l))))
        ((definition) (adjoin-string (function-definition-name (car l))
                                     (block-bound-names (cdr l)))))))

(defun arglist-to-struct-declaration-list (list)
  (declare (list list))
  (cond ((null list) '())
        ((eql '|...| (car list)) (error "Variadic CPS function"))
        (t (cons (list (caar list) (list (cadar list)))
                 (arglist-to-struct-declaration-list (cdr list))))))

(defun arglist-to-declaration-list (list)
  (declare (list list))
  (cond ((null list) '())
        ((eql '|...| (car list)) (error "Variadic CPS function"))
        (t (cons (list
                  'declaration
                  (caar list)
                  (list (list (cadar list) nil)))
                 (arglist-to-declaration-list (cdr list))))))

(defun arglist-struct-definition (name arglist)
  "Build a struct definition from an arglist."
  (declare (string name) (list arglist))
  (let ((name (arglist-struct-name name)))
    `(declaration
      ((struct ,name
        ,(if (null arglist)
             '(((int) ((nil "dummy"))))
             (arglist-to-struct-declaration-list arglist)))))))

(defun arglist-struct-constructor (name arglist)
  (declare (string name) (list arglist))
  (let* ((arglist (canonicalise-arglist arglist))
         (struct-name (arglist-struct-name name))
         (constructor-name (arglist-constructor-name name))
         (name-list (mapcar #'declarator-name arglist))
         (cont-name (fresh-name "continuation"))
         (s-name (fresh-name "arglist")))
    (list
     (arglist-struct-definition name arglist)
     `(definition
       (static inline (struct "cpc_continuation"))
       ((*) (function ,constructor-name
             ,(append arglist `((((struct "cpc_continuation"))
                                 ((*) ,cont-name))))))
       nil
       (block
           (declaration ((struct ,struct-name)) ((((*) ,s-name))))
         (statement
          (expression
           (= ,s-name
              (apply "cpc_alloc"
                     ((& ,cont-name)
                      (sizeof-type (((struct ,struct-name)) nil)))))))
         ,@(mapcar
            #'(lambda (name)
                `(statement (expression (= (-> ,s-name ,name)
                                         ,name))))
            name-list)
         (statement (return ,cont-name)))))))

(eval-when (load compile eval)
(defmacro with-transform-handler (i &body body)
  `(call-with-transform-handler ,i #'(lambda () ,@body)))
)

(defun call-with-transform-handler (i thunk)
  (declare (type (function () *) thunk) (dynamic-extent thunk))
  (let ((trans (catch 'transform
                 (return-from call-with-transform-handler
                   (funcall thunk)))))
    (ecase (car trans)
      ((:trivialise-block)
       (with-transform-handler i
         (function-definition-trivialise-block
          i
          (the cons (cadr trans)))))
      ((:functionalise-goto)
       (with-transform-handler i
         (function-definition-functionalise-goto 
          i 
          (the string (cadr trans))))))))

(defun convert-translation-unit (tu env)
  (declare (list tu env))
  (cond
    ((null tu) '())
    (t (when *cpc-debug*
         (format t "~&~S~%" (car tu)))
       (multiple-value-bind (d e)
           (convert-external-declaration (car tu) env)
         (if (equal d (car tu))
             (cons d (convert-translation-unit (cdr tu) (append e env)))
             (convert-translation-unit (cons d (cdr tu)) (append e env)))))))

(defun convert-external-declaration (i env)
  (declare (cons i) (list env))
  (ecase (car i)
    ((declaration) (convert-declaration i env))
    ((definition)
     (with-transform-handler i
       (let ((*return-type* (function-return-type (cadr i) (caddr i))))
         (convert-function-definition i env))))))

(defun convert-declaration (d env)
  (declare (cons d) (list env) (ignore env))
  (assert (eql 'declaration (car d)))
  (values d (declaration-environment d)))

(defun convert-function-definition (d env)
  (declare (cons d) (list env))
  (assert (eql 'definition (car d)))
  (let ((path (function-definition-find d :cpc env)))
    (if path
        (convert-function-definition-1 path env)
        (values d (list (definition-environment d))))))

(defun convert-function-definition-1 (path env)
  (declare (list path env))
  (assert (eql 'definition (caar path)))
  (let* ((d (car path))
         (declaration-specifiers (cadr d))
         (declarator (caddr d))
         (declaration-list (fourth d))
         (compound-statement (fifth d)))
    (declare (cons compound-statement))
    (assert (null declaration-list) () "K&R function definition not supported")
    (assert (eql 'block (car compound-statement)))
    (assert (eql compound-statement (cadr path)))
    (let* ((cps (member 'cps declaration-specifiers))
           (new-specifiers declaration-specifiers)
           (function-name (function-definition-name d))
           (new-declarator declarator)
           (new-statement (convert-statement-no-head-1 (cdr path) env)))
      (when (not cps)
        (assert (not (cps-p function-name env))))
      (let((new-definition
            (list 'definition new-specifiers new-declarator '()
                  new-statement)))
        (values new-definition
                (list (definition-environment new-definition)))))))

(defun convert-statement-no-head (s env)
  (declare (list s env))
  (let ((path (statement-no-head-find s :cpc env)))
    (if path
        (convert-statement-no-head-1 path env)
        s)))

(defun convert-statement-no-head-1 (path env)
  (declare (list path env))
  (let ((s (car path)))
    (declare (cons s))
    (flet ((cs1 (s)
             (if (member s path)
                 (convert-statement-1 (member s path) env)
                 s))
           (ce1 (e)
             (if (member e path)
                 (convert-expression-1 (member e path) env)
                 e)))
      (ecase (car s)
        ((block)
         (make-block
          (convert-block-1 (cdr s) (cdr path) env)))
        ((label case)
         (list (car s) (cadr s) (cs1 (caddr s))))
        ((expression)
         (if (and (member (cadr s) path)
                  (snh-cps-known-apply-p s env))
             ;; make it into a block so that c-b-1 can do the right thing.
             (make-block (list `(statement ,s)))
             (list (car s) (ce1 (cadr s)))))
        ((cpc_yield cpc_done cpc_wait cpc_sleep cpc_io_wait cpc_fork)
         (make-block (list `(statement ,s))))
        ((return default)
         (list (car s) (ce1 (cadr s))))
        ((if)
         (list 'if (ce1 (cadr s)) (cs1 (caddr s))
               (and (fourth s) (cs1 (fourth s)))))
        ((for while do-while switch) (gotoify-statement s))
        ((cpc_spawn)
         (let ((s* (maybe-deconstruct-block (cadr (cadr s)) t)))
           (multiple-value-bind (op name arglist)
               (statement-apply-deconstruct `(statement ,s*))
             (if (and op (or (eql 'cps-apply op) (cps-p name env)))
                 `(expression (cps-apply-later ,name ,arglist))
                 (let ((name (fresh-name "spawn")))
                   (make-block
                    (list
                     `(definition
                       (cps void) (nil (function ,name nil)) ()
                       ,(ensure-block s* t))
                     `(statement (expression (cps-apply-later ,name ())))))
                   )))))
        ))))

(defun convert-block-1 (l path env)
  (declare (list l path env))
  (cond
    ((null l) (error "Convert-1 declined"))
    ((and (eql (car l) (car path))
          (eql (caar l) 'statement)
          (assoc (caadr (car l)) *functionalise-cpc-alist*))
     (functionalise-cpc l env))
    ((and (member (car l) path)
          (statement-cps-known-apply-p (car l) env))
     (functionalise-cpc l env))
    ((eql (car l) (car path))
     (ecase (caar l)
       ((statement)
        (cons (convert-statement-1 path env)
              (cdr l)))
       ((definition)
        (let ((*return-type*
               (function-return-type (cadr (car l)) (caddr (car l)))))
          (cons
           (convert-function-definition-1
            path
            (cons
             (definition-environment (car l))
             (append (definition-arglist-environment (car l)) env)))
           (cdr l))))))
    ((eql (caar l) 'definition)
     (cons (car l)
           (convert-block-1 (cdr l) path
                            (cons (definition-environment (car l)) env))))
    (t (cons (car l)
             (convert-block-1 (cdr l) path env)))))
  
(defun convert-statement-1 (path env)
  (declare (list path env))
  (assert (eql 'statement (caar path)))
  (list 'statement
        (convert-statement-no-head-1 (cdr path) env)))

(defun convert-expression-1 (path env)
  (declare (list path env) (ignore env))
  (let ((e (car path)))
    (error "Convert-1 declined on expression ~S" e)))

(defun item-declarations (item)
  (declare (cons item))
  (ecase (car item)
    ((declaration)
     (let ((names (declaration-names item)))
       (cond
         (names (list item))
         (t
          (if (and (eql 'struct (caar (cadr item)))
                   (cpc-prefix-p (cadar (cadr item))))
              (list
               `(declaration ((,(caar (cadr item))
                               ,(cadar (cadr item))))))
              '())))))
    ((definition)
     (list
      `(declaration
        ,(cadr item) ,(list (list (caddr item))))))))

(defun collect-declarations (block)
  (declare (list block))
  (sort 
   (reduce #'append (mapcar #'item-declarations block))
   #'(lambda (a b) 
       (declare (cons a b) (ignore a))
       (function-declarator-p (car (car (caddr b)))))))

(defun append-declarations (block)
  (declare (list block))
  (append (collect-declarations block) block))

(defun lift-external-declaration (item)
  "Lift all functions in an external-declaration."
  (declare (cons item))
  (ecase (car item)
    ((declaration) (list item))
    ((definition)
     (lift-external-declaration
      (with-transform-handler item
        (let ((*return-type* (function-return-type (cadr item) (caddr item))))
          (return-from lift-external-declaration
            (append-declarations (lift-function item)))))))))

(defun lift-translation-unit (tu)
  (declare (list tu))
  (the list 
    (reduce #'append (mapcar #'lift-external-declaration tu))))

(defvar *linearisation-functions*)

(defstruct linearisation-entry
  (fn (required-argument) :type string)
  (target (required-argument) :type (or null string))
  (args nil :type list)
  (arglist nil :type list)
  (return-type nil :type list)
  discard
  )

(defun make-linearisation-function (target name args env
                                    &optional return-type)
  (declare (type (or null string) target)
           (string name) (list args env))
  (when (voidp return-type)
    (setq return-type nil))
  (let* ((mapping (mapcar #'(lambda (x) (cons x (fresh-name x))) args))
         (fn (fresh-name (format nil "linear~@[_~A~]_~A" target name))))
    (flet ((remap (l)
             (mapcar #'(lambda (n) (cdr (assoc n mapping :test #'equal)))
                     l)))
      (let ((new-args (append (remove name args :test #'equal) (list name))))
        (push
         (make-linearisation-entry
          :fn fn
          :target target
          :args (remap args)
          :arglist (rename-arglist (environment-arglist new-args env)
                                   (remap new-args))
          :return-type return-type
          :discard (and target
                        (null return-type)
                        (not (voidp (environment-return-type target env)))
                        (environment-return-type target env)))
         *linearisation-functions*)
        fn))))

(defun emit-linearisation-functions (functions)
  (mapcar
   #'(lambda (e)
       (let* ((fn (linearisation-entry-fn e))
              (target (linearisation-entry-target e))
              (args (linearisation-entry-args e))
              (arglist (linearisation-entry-arglist e))
              (return-type (linearisation-entry-return-type e))
              (discard (linearisation-entry-discard e))
              (return-type* (or return-type '((void) nil)))
              (return-type** (list (cons 'cps (car return-type*))
                                   (cadr return-type*))))
         `(definition
            ,(car return-type**)
            ,(make-declarator (cadr return-type**)
                              `(function ,fn ,arglist))
            nil
            ,(cond
              ((null target)
               (assert (<= (length args) 1))
               `(block (statement
                        (return ,(if return-type (car args) nil)))))
              (t
               (cond
                 (discard
                  (assert (null return-type))
                  (let* ((disc (fresh-name "discard"))
                         (ql (make-qlist-declarator discard disc)))
                    `(block (declaration ,(car ql) ((,(cadr ql))))
                       (statement
                        (expression
                         (=
                          ,disc
                          (cps-apply ,target ,args))))
                       (statement (return nil)))))
                 ((null return-type)
                  `(block (statement (expression
                                      (cps-apply ,target ,args)))
                     (statement (return nil))))
                 (t
                  `(block (statement
                           (return (cps-apply ,target ,args)))))))))))
   functions))

(defun linearise-translation-unit (tu env)
  (declare (list tu env))
  (cond
    ((null tu) '())
    (t (let ((ed (car tu)))
         (ecase (car ed)
           ((declaration)
            (cons ed
                  (linearise-translation-unit
                   (cdr tu)
                   (append env (declaration-environment ed)))))
           ((definition)
            (append (linearise-definition ed env)
                    (linearise-translation-unit
                     (cdr tu)
                     (cons (definition-environment ed) env)))))))))

(defun linearise-definition (d env)
  (let ((*linearisation-functions* '()))
    (let* ((d* (linearise-definition* d env))
           (e (emit-linearisation-functions
               (reverse *linearisation-functions*))))
      (if (null e)
          (list d*)
          (linearise-translation-unit
           (append
            (collect-declarations e)
            (list d*)
            e)
           env)))))

(defun linearise-definition* (d env)
  (declare (cons d) (list env))
  (assert (eql 'definition (car d)))
  (let ((declaration-specifiers (cadr d))
        (declarator (caddr d))
        (declaration-list (fourth d))
        (compound-statement (fifth d)))
    (if (not (member 'cps declaration-specifiers))
        d
        (list 'definition declaration-specifiers declarator declaration-list
              (linearise-statement-no-head
               compound-statement
               (append (definition-arglist-environment d) env)
               (function-return-type declaration-specifiers declarator))))))

(defun linearise-statement (s env return-type)
  (assert (eq 'statement (car s)))
  (list 'statement (linearise-statement-no-head (cadr s) env return-type)))

(defun linearise-statement-no-head (s env return-type)
  (flet ((ls (s) (linearise-statement s env return-type)))
    (case (car s)
      ((block)
       (make-block (linearise-block (cdr s) env return-type)))
      ((if)
       (list (car s) (cadr s) (ls (caddr s))
             (and (fourth s) (ls (fourth s)))))
      (t s))))

(defun linearise-block (l env return-type)
  (cond
    ((null l) '())
    (t
     (let ((s (car l)))
       (cond
         ((eql 'declaration (car s))
          (cons s (linearise-block (cdr l)
                                   (append
                                    env
                                    (declaration-environment s))
                                   return-type)))
         ((and
           (eql 'statement (car s))
           (eql 'expression (car (cadr s)))
           (listp (cadr (cadr s)))
           (eql '= (car (cadr (cadr s))))
           (listp (caddr (cadr (cadr s))))
           (eql 'cps-apply (car (caddr (cadr (cadr s))))))
          (let ((name (cadr (cadr (cadr s))))
                (s2 (cadr l)))
            (assert (eql 'statement (car s2)) ()
                    "Cannot linearise before a declaration")
            (let ((snh (cadr s2)))
              (cond
                ((eql 'return (car snh))
                 (assert (or (null (cadr snh)) (stringp (cadr snh))))
                 (cond
                   ((equal (cadr snh) name)
                    (cons s (linearise-block (cdr l) env return-type)))
                   ((or (null (cadr snh))
                        (not (member-equal
                              name
                              (expression-free-names (cadr snh)))))
                    (list*
                     s
                     `(statement
                       (expression
                        (cps-apply
                         ,(make-linearisation-function
                           nil name (list name) env return-type)
                         (,name))))
                     (linearise-block (cddr l) env return-type)))
                   (t (error "Cannot linearise ~S against ~S" s s2))))
                ((statement-cps-apply-p s2)
                 (let* ((e (cadr (cadr s2)))
                        (target
                         (cond ((eql 'cps-apply (car e)) (cadr e))
                               ((eql '= (car e)) (cadr (caddr e)))
                               (t (error "Unexpected cps-apply ~S" e))))
                        (args
                         (cond ((eql 'cps-apply (car e)) (caddr e))
                               ((eql '= (car e)) (caddr (caddr e)))
                               (t (error "Unexpected cps-apply ~S" e))))
                        (written
                         (cond ((eql 'cps-apply (car e)) nil)
                               ((eql '= (car e)) (cadr e))
                               (t (error "Unexpected cps-apply ~S" e)))))
                   (assert (every #'stringp args))
                   (cond
                     ((and (equal name (car (last args)))
                           (not (member-equal name (butlast args))))
                      (cons s (linearise-block (cdr l) env return-type)))
                     (t
                      (let* ((target-return-type
                              (environment-return-type target env))
                             (fn (make-linearisation-function
                                  target name args env target-return-type))
                             (call `(cps-apply
                                     ,fn
                                     ,(append (remove name args :test #'equal)
                                              (list name)))))
                        (list*
                         s
                         (if written
                             `(statement (expression (= ,written ,call)))
                             `(statement (expression ,call)))
                         (linearise-block (cddr l) env return-type)))))))
                (t (error "Cannot linearise ~S against ~S" s s2))))))
         ((eql 'statement (car s))
          (cons (linearise-statement s env return-type)
                (linearise-block (cdr l) env return-type)))
         (t (cons s (linearise-block (cdr l) env return-type))))))))

(defun convert2-translation-unit (tu env emitted)
  (declare (list tu env emitted))
  (the list (convert2-block tu nil env emitted)))

(defun convert2-block-item (item cps env emitted)
  (declare (list item env emitted))
  (the (values list list list)
    (ecase (car item)
      ((declaration) (convert2-declaration item cps env emitted))
      ((definition) (convert2-definition item cps env emitted))
      ((statement) (list (convert2-statement item cps env emitted))))))

(defun convert2-declaration (d cps env emitted)
  (declare (list env emitted) (ignore env cps))
  (assert (eql 'declaration (car d)))
  (let ((specifiers (cadr d))
        (init-declarator-list (caddr d)))
    (if (not (member 'cps specifiers))
        (values (list d) '() '())
        (progn
          (unless (and (not (null init-declarator-list))
                       (null (cdr init-declarator-list)))
            (error "Declaration not split"))
          (unless (null (cadr (car init-declarator-list)))
            (error "CPS declaration contains initialiser"))
          (unless (function-declarator-p (car (car init-declarator-list)))
            (error "CPS declaration not function"))
          (let* ((declarator (caar init-declarator-list))
                 (name (declarator-name declarator))
                 (arglist (function-declarator-arglist declarator)))
            (values
             (append
              (and (not (member-equal name emitted))
                   (arglist-struct-constructor name arglist))
              (list
               `(declaration
                 (void)
                 ((,(make-function-declarator
                     declarator
                     `((((struct "cpc_continuation"))
                        ((*) "cpc_current_continuation")))) nil)))))
             (list (cons name (list specifiers declarator)))
             (and (not (member-equal name emitted))
                  (list name))))))))

(defun convert2-definition (d cps env emitted)
  (declare (list d env emitted))
  (assert (eql 'definition (car d)))
  (when cps
    (error "Convert2 of definition in CPS context"))
  (let* ((specifiers (cadr d))
         (declarator (caddr d))
         (dlo (fourth d))
         (statement (fifth d))
         (name (declarator-name declarator))
         (arglist (canonicalise-arglist
                   (function-declarator-arglist declarator)))
         (args-struct `(struct ,(arglist-struct-name name)))
         (body (if (and (member 'cps specifiers) (member 'void specifiers))
                   (terminate-block-item-list (cdr statement))
                   (cdr statement))))
    (assert (null dlo))
    (values
     (if (not (member 'cps specifiers))
         (list
          (list (car d) specifiers declarator dlo
                (convert2-snh statement nil env emitted)))
         (append
          (and (not (member-equal name emitted))
               (arglist-struct-constructor name arglist))
          (list
           (list (car d)
                 '(void)
                 (make-function-declarator
                  declarator
                  `((((struct "cpc_continuation"))
                     ((*) "cpc_current_continuation"))))
                 dlo
                 (make-block
                  (append
                   `((declaration
                      (,args-struct) ((((*) "cpc_arguments") nil))))
                   (arglist-to-declaration-list arglist)
                   `((statement
                      (expression
                       (= "cpc_arguments"
                          (apply "cpc_dealloc"
                                 ("cpc_current_continuation"
                                  (sizeof-type ((,args-struct) nil))))))))
                   (mapcar
                    #'(lambda (arg)
                        (let ((name (declarator-name arg)))
                          `(statement (expression
                                       (= ,name (-> "cpc_arguments" ,name))))))
                    arglist)
                   (convert2-block 
                    body
                    (function-return-type specifiers declarator)
                    env emitted)))))))
     (list (cons name (list specifiers declarator)))
     (and (member 'cps specifiers)
          (not (member-equal name emitted))
          (list name)))))

(defun convert2-statement (s cps env emitted)
  (declare (list env emitted))
  (assert (eql 'statement (car s)))
  (values
   (list 'statement (convert2-snh (cadr s) cps env emitted))
   '() '()))

(defun convert2-snh (s cps env emitted)
  (declare (list env emitted))
  (flet ((cs (s) (convert2-statement s cps env emitted))
         (ce (e) (convert2-expression e cps env emitted)))
    (ecase (car s)
      ((label)
       (list (car s) (cadr s) (cs (caddr s))))
      ((case switch while)
       (list (car s) (ce (cadr s)) (cs (caddr s))))
      ((default)
       (list (car s) (ce (cadr s))))
      ((return)
       (cond
         ((not cps) (list (car s) (and (cadr s) (ce (cadr s)))))
         (t
          (make-block
           (convert2-block (list `(statement ,s)) cps env emitted)))))
      ((block)
       (make-block (convert2-block (cdr s) cps env emitted)))
      ((expression)
       (list (car s) (and (cadr s) (ce (cadr s)))))
      ((if)
       (list (car s) (ce (cadr s)) (cs (caddr s))
             (and (fourth s) (cs (fourth s)))))
      ((do-while)
       (list (car s) (cs (cadr s)) (ce (caddr s))))
      ((for)
       (list (car s) (ce (cadr s)) (ce (caddr s)) (ce (fourth s))
             (cs (fifth s))))
      ((goto break) s))))

(defun convert2-expression (e cps env emitted)
  (declare (list env emitted) (ignore emitted))
  (if (not (listp e))
      e
      (case (car e)
        ((apply)
         (if (and (stringp (cadr e))
                  (member 'cps (cadr (assoc (cadr e) env :test #'equal))))
             (progn
               (unless cps (error "Calling CPS function in non-CPS context"))
               (error "Unconverted apply of CPS function."))
             e))
        ((cps-apply)
         (if (and (stringp (cadr e))
                  (member 'cps (cadr (assoc (cadr e) env :test #'equal))))
             (error "Cps-apply in non-toplevel context")
             (progn
               (unless cps (error "Calling CPS function in non-CPS context"))
               (error "Cps-apply of non-CPS function"))))
        (t e))))

(defun statement-cps-apply-p (s)
  (and (eql 'statement (car s))
       (snh-cps-apply-p (cadr s))))

(defun snh-cps-apply-p (s)
  (and (eql 'expression (car s))
       (expression-cps-apply-p (cadr s))))

(defun expression-cps-apply-p (e)
  (and (listp e)
       (or (eql 'cps-apply (car e))
           (and (eql '= (car e))
                (expression-cps-apply-p (caddr e))))))

(defun statement-void-cps-apply-p (s)
  (and (statement-cps-apply-p s)
       (eql 'cps-apply (car (cadr (cadr s))))))

(defun statement-cps-known-apply-p (s &optional env)
  (and (eql 'statement (car s))
       (snh-cps-known-apply-p (cadr s) env)))

(defun snh-cps-known-apply-p (s &optional env)
  (and (eql 'expression (car s))
       (expression-cps-known-apply-p (cadr s) env)))

(defun expression-cps-known-apply-p (e &optional env)
  (and (listp e)
       (or
        (and (eql 'apply (car e)) (cps-p (cadr e) env))
        (and (eql '= (car e))
             (expression-cps-known-apply-p (caddr e) env)))))

(defun statement-cps-apply-later-p (s)
  (and (eql 'statement (car s))
       (let ((snh (cadr s)))
         (and (eql 'expression (car snh))
              (listp (cadr snh))
              (eql 'cps-apply-later (car (cadr snh)))))))

(defun build-continuation (l c env return-type)
  (declare (list l) (string c))
  (assert (not (null return-type)))
  (let ((s (car l)))
    (cond
      ((return-p s)
       (let ((e (cadr (cadr s))))
         (cond
           ((null e)
            (assert (voidp return-type))
            '())
           ((and (listp e) (eql 'cps-apply (car e)))
            (assert (not (voidp return-type)))
            (let* ((fn (cadr e))
                   (arglist (caddr e))
                   (fn-return-type (environment-return-type fn env)))
              (unless (equal return-type fn-return-type)
                (warn "Return types don't match -- ~S and ~S"
                      return-type fn-return-type))
            `(,(construct-arglist fn arglist c)
               (statement
                (expression
                 (= ,c (apply "cpc_continuation_push"
                              (,c
                               (cast ,fn (("cpc_function") ((*) nil)))))))))))
           (t
            (assert (not (voidp return-type)))
            (let* ((temp (fresh-name "temp"))
                   (qlist-declarator (make-qlist-declarator return-type temp))
                   (qlist (car qlist-declarator))
                   (declarator (cadr qlist-declarator)))
              `((declaration ,qlist ((,declarator
                                      (expression ,e))))
                (statement
                 (expression
                  (apply "cpc_continuation_patch"
                         (,c (sizeof-type ,return-type) ,temp))))))))))
      ((statement-void-cps-apply-p s)
       (let* ((e (cadr (cadr s)))
              (fn (cadr e))
              (arglist (caddr e))
              (fn-return-type (environment-return-type fn env)))
         (assert (voidp fn-return-type))
         (assert (eql 'cps-apply (car e)))
         `(,@(build-continuation (cdr l) c env return-type)
           ,(construct-arglist fn arglist c)
           (statement
            (expression
             (= ,c
                (apply "cpc_continuation_push"
                       (,c (cast ,fn
                                 (("cpc_function") ((*) nil)))))))))))
      ((statement-cps-apply-p s)
       (let* ((e (cadr (cadr s)))
              (lvalue (cadr e))
              (rvalue (caddr e))
              (fn (cadr rvalue))
              (arglist (caddr rvalue))
              (fn-return-type (environment-return-type fn env)))
         (assert (eql '= (car e)))
         (assert (eql 'cps-apply (car rvalue)))
         (assert (stringp fn))
         (assert (stringp lvalue))
         (assert (not (voidp fn-return-type)))
         (let* ((next (cadr l)))
           (let ((binder
                  (cond
                    ((return-p next) (cadr (cadr next)))
                    ((statement-void-cps-apply-p next)
                     (car (last (caddr (cadr (cadr next))))))
                    ((statement-cps-apply-p next)
                     (car (last (caddr (caddr (cadr (cadr next)))))))
                    (t (error "Next has unexpected shape ~S" next)))))
             (assert (equal binder lvalue) (binder lvalue))))
         `(,@(build-continuation (cdr l) c env return-type)
           ,(construct-arglist fn arglist c)
           (statement
            (expression
             (= ,c
                (apply "cpc_continuation_push"
                       (,c (cast ,fn
                                 (("cpc_function") ((*) nil)))))))))))
      (t (error "Build-continuation never found return")))))

(defun convert2-block (l cps env emitted)
  (declare (list l env emitted))
  (cond
    ((null l) '())
    ((and cps (or (return-p (car l)) (statement-cps-apply-p (car l))))
     (let* ((cont "cpc_current_continuation")
            (new-continuation (build-continuation l cont env cps)))
       `(,@new-continuation
         (statement
          (expression (apply "cpc_invoke_continuation" (,cont))))
         (statement (return nil)))))
    ((and (eql 'statement (caar l))
          (rassoc (car (cadr (car l))) *functionalise-cpc-alist*))
     (let* ((s (car l))
            (snh (cadr s))
            (cont "cpc_current_continuation")
            (new-continuation
             (build-continuation (cdr l) cont env cps)))
       (append
        new-continuation
        (cond
          ((eql 'cps-yield (car snh))
           `((statement (expression (apply "cpc_schedule" (,cont))))))
          ((eql 'cps-done (car snh))
           `((statement
              (block
               (statement
                (expression
                 (apply "cpc_continuation_free" (,cont))))
                (statement (return nil))))))
          ((eql 'cps-wait (car snh))
           `((statement
              (expression
               (apply "cpc_prim_wait" (,(cadr snh) ,cont))))))
          ((eql 'cps-sleep (car snh))
           `((statement
              (expression
               (apply "cpc_prim_sleep"
                      (,(cadr snh) ,(or (caddr snh) 0)
                        ,(or (fourth snh) *null*)
                        ,cont))))))
          ((eql 'cps-io-wait (car snh))
           `((statement
              (expression
               (apply "cpc_prim_io_wait"
                      (,(cadr snh) ,(caddr snh)
                        ,(or (fourth snh) *null*)
                        ,cont))))))
          ((eql 'cps-fork (car snh))
           (let ((copy (fresh-name "fork")))
             `((statement
                (block
                    (declaration ((struct "cpc_continuation")) ((((*) ,copy))))
                  (statement 
                   (expression 
                    (= ,copy (apply "cpc_continuation_copy" (,cont)))))
                  ,(construct-arglist (cadr snh) (caddr snh) copy)
                  (statement
                   (expression
                    (= ,copy (apply "cpc_continuation_push" 
                                    (,copy
                                     (cast ,(cadr snh) (("cpc_function") 
                                                        ((*) nil))))))))
                  (statement
                   (expression
                    (apply "cpc_schedule" (,copy))))
                  (statement
                   (expression
                    (apply "cpc_invoke_continuation" (,cont)))))))))
          (t (error "Unexpected statement ~S" (car (cadr (car l))))))
        `((statement (return nil)))
        (convert2-block (cddr l) cps env emitted))))
    ((statement-cps-apply-later-p (car l))
     (let* ((a (car l))
            (e (cadr (cadr a)))
            (cont (fresh-name "apply_later"))
            (new-arglist
             (construct-arglist (cadr e) (caddr e) cont)))
       `((statement
          (block
            (declaration ((struct "cpc_continuation")) ((((*) ,cont))))
            (statement (expression (= ,cont ,*null*)))
            ,new-arglist
            (statement
             (expression
              (= ,cont
                 (apply "cpc_continuation_push"
                        (,cont (cast ,(cadr e)
                                     (("cpc_function") ((*) nil))))))))
            (statement (expression
                        (apply "cpc_schedule" (,cont))))))
         ,@(convert2-block (cdr l) cps env emitted))))
    (t
     (multiple-value-bind (d e em)
         (convert2-block-item (car l) cps env emitted)
       (append d (convert2-block (cdr l)
                                 cps
                                 (append e env)
                                 (append em emitted)))))))