1  (define-module (llvm block)
 2    #:use-module ((rnrs base) #:select (assert))
 3    #:use-module (llvm module)
 4    #:use-module (system foreign)
 5    #:use-module (oop goops)
 6    #:use-module (llvm types)
 7    #:use-module (llvm type)
 8    #:use-module (llvm context)
 9    #:use-module (llvm raw)
10    #:export (append-block
11              create-block))
12  
13  (define* (create-block name #:key (context (current-llvm-context)))
14    (let* ((o (LLVMCreateBasicBlockInContext (unwrap-llvm-context context)
15                                             (string->pointer name)))
16           (block (wrap-llvm-block o)))
17      block))
18  
19  (define* (append-block/create fn name #:key (context (current-llvm-context)))
20    (let* ((o (LLVMAppendBasicBlockInContext (unwrap-llvm-context context)
21                                             (unwrap-llvm-value fn)
22                                             (string->pointer name)))
23           (block (wrap-llvm-block o #:function fn)))
24      (slot-set! fn 'blocks (cons block (slot-ref fn 'blocks)))
25      block))
26  
27  (define (append-block/existing fn block)
28    (LLVMAppendExistingBasicBlock (unwrap-llvm-function fn)
29                                  (unwrap-llvm-block block))
30    (slot-set! block 'function fn)
31    (slot-set! fn 'blocks (cons block (slot-ref fn 'blocks))))
32  
33  (define* (append-block fn block #:key (context (current-llvm-context)))
34    (if (llvm-block? block)
35        (append-block/existing fn block)
36        (append-block/create fn block #:context context)))
37  
38  (define* (delete-block block)
39    (assert (llvm-block? block))
40    (let ((p (unwrap-llvm-block block))
41          (func (slot-ref block 'function)))
42      (LLVMDeleteBasicBlock p)
43      (slot-set! func 'block
44                 (delete
45                  block
46                  (slot-ref func 'block)))
47      (change-class block <llvm-freed>)))
48  
49  (define (remove-block block)
50    (let ((p (unwrap-llvm-block block))
51          (func (slot-ref block 'function)))
52      (LLVMRemoveBasicBlockFromParent p)
53      (slot-set! func 'block
54                 (delete
55                  block
56                  (slot-ref func 'block)))
57      block))
58  
59  (define-public (first-instruction block)
60    (let* ((b-p (unwrap-llvm-block block))
61           (inst-p (LLVMGetFirstInstruction b-p)))
62      (wrap-llvm-value inst-p)))