ast.scm

   1 ;;; definition of ast types
   2
   3 (define-type ast
   4   extender: define-type-of-ast
   5   (parent unprintable:)
   6   subasts)
   7
   8 (define (link-parent! subast parent)
   9   (ast-parent-set! subast parent)
  10   parent)
  11
  12 (define (multi-link-parent! subasts parent)
  13   (for-each (lambda (subast) (link-parent! subast parent))
  14             subasts)
  15   parent)
  16
  17 (define (unlink-parent! subast)
  18   (let ((parent (ast-parent subast)))
  19     (if (and (def-variable? subast) (def-procedure? parent))
  20         (def-procedure-params-set!
  21           parent
  22           (remove subast (def-procedure-params parent)))
  23         (ast-subasts-set!
  24          parent
  25          (remove subast (ast-subasts parent))))
  26     (ast-parent-set! subast #f)
  27     subast))
  28
  29 (define (subast1 ast) (car (ast-subasts ast)))
  30 (define (subast2 ast) (cadr (ast-subasts ast)))
  31 (define (subast3 ast) (caddr (ast-subasts ast)))
  32 (define (subast4 ast) (cadddr (ast-subasts ast)))
  33
  34 (define-type-of-ast def
  35   extender: define-type-of-def
  36   id
  37   unprintable:
  38   refs)
  39
  40 (define-type value
  41   bytes)
  42 (define (new-value bytes)
  43   (make-value bytes))
  44
  45 (define-type byte-cell
  46   adr
  47   (interferes-with unprintable:)
  48   (coalesceable-with unprintable:))
  49 (define (new-byte-cell)
  50   (make-byte-cell #f '() '()))
  51 (define (get-register n)
  52   (make-byte-cell n '() '()))
  53
  54 (define-type byte-lit
  55   val)
  56 (define (new-byte-lit x)
  57   (make-byte-lit x))
  58
  59 (define types-bytes
  60   '((void  . 0)
  61     (bool  . 1)
  62     (byte  . 1)
  63     (int8  . 1)
  64     (int16 . 2)
  65     (int24 . 3)
  66     (int32 . 4)
  67     (int   . 4))) ;; TODO should the default int be 32 bits ?
  68
  69 (define (type->bytes type)
  70   (cond ((assq type types-bytes)
  71          => (lambda (x) (cdr x)))
  72         (else (error "wrong number of bytes ?"))))
  73
  74 (define (bytes->type n)
  75   (let loop ((l types-bytes))
  76     (cond ((null? l)     (error (string-append "no type contains "
  77                                                (number->string n)
  78                                                " bytes")))
  79           ((= n (cdar l)) (caar l))
  80           (else (loop (cdr l))))))
  81
  82 (define (int->value n type)
  83   (let ((len (type->bytes type)))
  84     (let loop ((len len) (n n) (rev-bytes '()))
  85       (if (= len 0)
  86           (new-value (reverse rev-bytes))
  87           (loop (- len 1)
  88                 (arithmetic-shift n -8)
  89                 (cons (new-byte-lit (modulo n 256))
  90                       rev-bytes))))))
  91 (define (value->int val)
  92   (let loop ((bytes (reverse (value-bytes val)))
  93              (n     0))
  94     (if (null? bytes)
  95         n
  96         (loop (cdr bytes)
  97               (+ (* 256 n) (byte-lit-val (car bytes)))))))
  98
  99 (define (extend value type) ;; TODO instead of carrying types around, use the length instead
 100   ;; literals must be extended with literal 0s, while variables must be
 101   ;; extended with byte cells
 102   (let* ((bytes (value-bytes value))
 103          (lit?  (byte-lit? (car bytes))))
 104     (let loop ((rev-bytes (reverse bytes)) ;; TODO put in cfg.scm ?
 105                (n         (max 0 (- (type->bytes type) (length bytes)))))
 106       (if (= n 0)
 107           (new-value (reverse rev-bytes))
 108           (loop (cons (if lit? (new-byte-lit 0) (new-byte-cell))
 109                       rev-bytes)
 110                 (- n 1)))))) ;; TODO would need to move 0 in the new byte ?
 111
 112 (define (alloc-value type)
 113   (let ((len (type->bytes type)))
 114     (let loop ((len len) (rev-bytes '()))
 115       (if (= len 0)
 116           (new-value (reverse rev-bytes)) ;; TODO why reverse, everything is empty
 117           (loop (- len 1)
 118                 (cons (new-byte-cell)
 119                       rev-bytes))))))
 120
 121 (define-type-of-def def-variable
 122   type
 123   value
 124   unprintable:
 125   sets)
 126 (define (new-def-variable subasts id refs type value sets)
 127   (multi-link-parent!
 128    subasts
 129    (make-def-variable #f subasts id refs type value sets)))
 130
 131 (define-type-of-def def-procedure
 132   type
 133   value
 134   params
 135   entry
 136   live-after-calls)
 137 (define (new-def-procedure subasts id refs type value params)
 138   (multi-link-parent!
 139    subasts
 140    (make-def-procedure #f subasts id refs type value params #f '())))
 141
 142
 143 (define-type-of-ast expr
 144   extender: define-type-of-expr
 145   type)
 146
 147 (define-type-of-expr literal
 148   val)
 149 (define (new-literal type val)
 150   (make-literal #f '() type val))
 151
 152 (define-type-of-expr ref
 153   def-var)
 154 (define (new-ref type def)
 155   (make-ref #f '() type def))
 156
 157 (define-type-of-expr oper
 158   op)
 159 (define (new-oper subasts type op)
 160   (multi-link-parent!
 161    subasts
 162    (make-oper #f subasts type op)))
 163
 164 (define-type-of-expr call
 165   (def-proc unprintable:))
 166 (define (new-call subasts type proc-def)
 167   (multi-link-parent!
 168    subasts
 169    (make-call #f subasts type proc-def)))
 170
 171 (define-type-of-ast block
 172   name) ; blocks that begin with a label have a name, the other have #f
 173 (define (new-block subasts)
 174   (multi-link-parent!
 175    subasts
 176    (make-block #f subasts #f)))
 177 (define (new-named-block name subasts)
 178   (multi-link-parent!
 179    subasts
 180    (make-block #f subasts name)))
 181
 182 (define-type-of-ast if)
 183 (define (new-if subasts)
 184   (multi-link-parent!
 185    subasts
 186    (make-if #f subasts)))
 187
 188 (define-type-of-ast switch)
 189 (define (new-switch subasts)
 190   (multi-link-parent!
 191    subasts
 192    (make-switch #f subasts)))
 193
 194 (define-type-of-ast while)
 195 (define (new-while subasts)
 196   (multi-link-parent!
 197    subasts
 198    (make-while #f subasts)))
 199
 200 (define-type-of-ast do-while)
 201 (define (new-do-while subasts)
 202   (multi-link-parent!
 203    subasts
 204    (make-do-while #f subasts)))
 205
 206 (define-type-of-ast for)
 207 (define (new-for subasts)
 208   (multi-link-parent!
 209    subasts
 210    (make-for #f subasts)))
 211
 212 (define-type-of-ast return)
 213 (define (new-return subasts)
 214   (multi-link-parent!
 215    subasts
 216    (make-return #f subasts)))
 217
 218 (define-type-of-ast break)
 219 (define (new-break)
 220   (make-break #f '()))
 221
 222 (define-type-of-ast continue)
 223 (define (new-continue)
 224   (make-continue #f '()))
 225
 226 (define-type-of-ast goto)
 227 (define (new-goto label)
 228   (make-goto #f (list label)))
 229
 230 (define-type-of-ast program)
 231 (define (new-program subasts) ;; TODO add suport for main
 232   (multi-link-parent!
 233    subasts
 234    (make-program #f subasts)))
 235
 236 (define-type op
 237   extender: define-type-of-op
 238   (six-id unprintable:)
 239   id
 240   unprintable:
 241   type-rule
 242   constant-fold
 243   code-gen)
 244
 245 (define-type-of-op op1)
 246 (define-type-of-op op2)
 247 (define-type-of-op op3)