- (then-block (make-empty-bblock))
- (else-block (make-empty-bblock))
- (join-block (make-empty-bblock)))
- ;; Convert the test into the current basic block.
- (ir-convert test next test-lvar)
- (setq next (bblock-exit *bblock*))
- (let ((cond (make-conditional :test test-lvar :consequent then-block :alternative else-block)))
- (insert-node-before next cond))
- ;; If we are not at the end of the content block, split it.
- (unless (block-exit-p next)
- (setq join-block (split-basic-block-before next *bblock*)))
- (dolist (succ (bblock-succ *bblock*))
- (setf (bblock-pred succ) (substitute join-block *bblock* (bblock-pred succ))))
- (psetf (bblock-succ *bblock*) (list else-block then-block)
- (bblock-pred else-block) (list *bblock*)
- (bblock-pred then-block) (list *bblock*)
- (bblock-succ then-block) (list join-block)
- (bblock-succ else-block) (list join-block)
- (bblock-pred join-block) (list else-block then-block)
- (bblock-succ join-block) (bblock-succ *bblock*))
- (let ((*bblock* then-block))
- (ir-convert then (bblock-exit then-block) result))
- (let ((*bblock* else-block))
- (ir-convert else (bblock-exit else-block) result))
- (setq *bblock* join-block)))
-
-
-(defun ir-convert-var (form next result)
- (let* ((leaf (make-var :name form))
- (ref (make-ref :leaf leaf :lvar result)))
- (insert-node-before next ref)))
-
-(defun ir-convert-call (form next result)
+ (then-block (make-empty-block))
+ (else-block (make-empty-block))
+ (join-block (make-empty-block)))
+ (ir-convert test test-lvar)
+ (insert-node (make-conditional :test test-lvar :consequent then-block :alternative else-block))
+ (let* ((block (current-block))
+ (tail-block (next-block)))
+ ;; Link together the different created basic blocks.
+ (setf (block-succ block) (list else-block then-block)
+ (block-pred else-block) (list block)
+ (block-pred then-block) (list block)
+ (block-succ then-block) (list join-block)
+ (block-succ else-block) (list join-block)
+ (block-pred join-block) (list else-block then-block)
+ (block-succ join-block) (list tail-block)
+ (block-pred tail-block) (substitute join-block block (block-pred tail-block))))
+ ;; Convert he consequent and alternative forms and update cursor.
+ (ir-convert then (result-lvar) (cursor :block then-block))
+ (ir-convert else (result-lvar) (cursor :block else-block))
+ (set-cursor :block join-block)))
+
+(define-ir-translator block (name &body body)
+ (let ((new (split-block)))
+ (push-binding name 'block (cons (next-block) (result-lvar)))
+ (ir-convert `(progn ,@body) (result-lvar))
+ (set-cursor :block new)))
+
+(define-ir-translator return-from (name &optional value)
+ (let ((binding
+ (or (find-binding name 'block)
+ (error "Tried to return from unknown block `~S' name" name))))
+ (destructuring-bind (jump-block . lvar)
+ (binding-value binding)
+ (ir-convert value lvar)
+ (setf (next-block) jump-block)
+ ;; This block is really unreachable, even if the following code
+ ;; is labelled in a tagbody, as tagbody will create a new block
+ ;; for each label. However, we have to leave the cursor
+ ;; somewhere to convert new input.
+ (let ((dummy (make-empty-block)))
+ (set-cursor :block dummy)))))
+
+(define-ir-translator tagbody (&rest statements)
+ (flet ((go-tag-p (x)
+ (or (integerp x) (symbolp x))))
+ (let* ((tags (remove-if-not #'go-tag-p statements))
+ (tag-blocks nil))
+ ;; Create a chain of basic blocks for the tags, recording each
+ ;; block in a alist in TAG-BLOCKS.
+ (let ((*cursor* *cursor*))
+ (dolist (tag tags)
+ (setq *cursor* (cursor :block (split-block)))
+ (push-binding tag 'tag (current-block))
+ (if (assoc tag tag-blocks)
+ (error "Duplicated tag `~S' in tagbody." tag)
+ (push (cons tag (current-block)) tag-blocks))))
+ ;; Convert the statements into the correct block.
+ (dolist (stmt statements)
+ (if (go-tag-p stmt)
+ (set-cursor :block (cdr (assoc stmt tag-blocks)))
+ (ir-convert stmt))))))
+
+(define-ir-translator go (label)
+ (let ((tag-binding
+ (or (find-binding label 'tag)
+ (error "Unable to jump to the label `~S'" label))))
+ (setf (next-block) (binding-value tag-binding))
+ ;; Unreachable block.
+ (let ((dummy (make-empty-block)))
+ (set-cursor :block dummy))))
+
+
+(defun ir-convert-functoid (result name arguments &rest body)
+ (let ((component)
+ (return-lvar (make-lvar)))
+ (with-component-compilation
+ (ir-convert `(progn ,@body) return-lvar)
+ (setq component *component*))
+ (let ((functional
+ (make-functional
+ :name name
+ :arguments arguments
+ :entry-point component
+ :return-lvar return-lvar)))
+ (insert-node (make-ref :leaf functional :lvar result)))))
+
+(define-ir-translator function (name)
+ (if (atom name)
+ (ir-convert `(symbol-function ,name) (result-lvar))
+ (ecase (car name)
+ ((lambda named-lambda)
+ (let ((desc (cdr name)))
+ (when (eq 'lambda (car name))
+ (push nil desc))
+ (apply #'ir-convert-functoid (result-lvar) desc)))
+ (setf))))
+
+(defun ir-convert-var (form result)
+ (let ((binds (find-binding form 'variable)))
+ (if binds
+ (insert-node (make-ref :leaf (binding-value binds) :lvar result))
+ (ir-convert `(symbol-value ',form) result))))
+
+(defun ir-convert-call (form result)