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 ;; TODO really in ast ?
  46 (define-type byte-cell
  47   adr
  48   (interferes-with unprintable:)
  49   (coalesceable-with unprintable:))
  50 (define (new-byte-cell)
  51   (make-byte-cell #f '() '()))
  52 (define (get-register n)
  53   (make-byte-cell n '() '()))
  54
  55 (define-type byte-lit
  56   val)
  57 (define (new-byte-lit x)
  58   (make-byte-lit x))
  59
  60 (define (nb-bytes type)
  61   (case type
  62     ((void)  0) ;; TODO have more types
  63     ((byte)  1)
  64     ((int8)  1)
  65     ((int16) 2)
  66     ((int32) 4)
  67     ((int)   4) ;; TODO should the default int be 32 bits ?
  68     (else (error "wrong number of bytes ?"))))
  69
  70 (define (int->value n type)
  71   (let ((len (nb-bytes type)))
  72     (let loop ((len len) (n n) (rev-bytes '()))
  73       (if (= len 0)
  74           (new-value (reverse rev-bytes))
  75           (loop (- len 1)
  76                 (arithmetic-shift n -8)
  77                 (cons (new-byte-lit (modulo n 256))
  78                       rev-bytes))))))
  79
  80 (define (extend value type)
  81   value);;;;;;;;;;;;;;;;;;;;;
  82
  83 (define (alloc-value type)
  84   (let ((len (nb-bytes type)))
  85     (let loop ((len len) (rev-bytes '()))
  86       (if (= len 0)
  87           (new-value (reverse rev-bytes)) ;; TODO why reverse, everything is empty
  88           (loop (- len 1)
  89                 (cons (new-byte-cell)
  90                       rev-bytes))))))
  91
  92 (define-type-of-def def-variable
  93   type
  94   value
  95   unprintable:
  96   sets)
  97 (define (new-def-variable subasts id refs type value sets)
  98   (multi-link-parent!
  99    subasts
 100    (make-def-variable #f subasts id refs type value sets)))
 101
 102 (define-type-of-def def-procedure
 103   type
 104   value
 105   params
 106   entry
 107   live-after-calls)
 108 (define (new-def-procedure subasts id refs type value params)
 109   (multi-link-parent!
 110    subasts
 111    (make-def-procedure #f subasts id refs type value params #f '())))
 112
 113
 114 (define-type-of-ast expr
 115   extender: define-type-of-expr
 116   type)
 117
 118 (define-type-of-expr literal
 119   val)
 120 (define (new-literal type val)
 121   (make-literal #f '() type val))
 122
 123 (define-type-of-expr ref
 124   def-var)
 125 (define (new-ref type def)
 126   (make-ref #f '() type def))
 127
 128 (define-type-of-expr oper
 129   op)
 130 (define (new-oper subasts type op)
 131   (multi-link-parent!
 132    subasts
 133    (make-oper #f subasts type op)))
 134
 135 (define-type-of-expr call
 136   def-proc)
 137 (define (new-call subasts type proc-def)
 138   (multi-link-parent!
 139    subasts
 140    (make-call #f subasts type proc-def)))
 141
 142 (define-type-of-ast block
 143   name) ; blocks that begin with a label have a name, the other have #f
 144 (define (new-block subasts)
 145   (multi-link-parent!
 146    subasts
 147    (make-block #f subasts #f)))
 148 (define (new-named-block name subasts)
 149   (multi-link-parent!
 150    subasts
 151    (make-block #f subasts name)))
 152
 153 (define-type-of-ast if)
 154 (define (new-if subasts)
 155   (multi-link-parent!
 156    subasts
 157    (make-if #f subasts)))
 158
 159 (define-type-of-ast switch)
 160 (define (new-switch subasts)
 161   (multi-link-parent!
 162    subasts
 163    (make-switch #f subasts)))
 164
 165 (define-type-of-ast while)
 166 (define (new-while subasts)
 167   (multi-link-parent!
 168    subasts
 169    (make-while #f subasts)))
 170
 171 (define-type-of-ast do-while)
 172 (define (new-do-while subasts)
 173   (multi-link-parent!
 174    subasts
 175    (make-do-while #f subasts)))
 176
 177 (define-type-of-ast for)
 178 (define (new-for subasts)
 179   (multi-link-parent!
 180    subasts
 181    (make-for #f subasts)))
 182
 183 (define-type-of-ast return)
 184 (define (new-return subasts)
 185   (multi-link-parent!
 186    subasts
 187    (make-return #f subasts)))
 188
 189 (define-type-of-ast break)
 190 (define (new-break)
 191   (make-break #f '()))
 192
 193 (define-type-of-ast continue)
 194 (define (new-continue)
 195   (make-continue #f '()))
 196
 197 (define-type-of-ast goto)
 198 (define (new-goto label)
 199   (make-goto #f (list label)))
 200
 201 (define-type-of-ast program)
 202 (define (new-program subasts) ;; TODO add suport for main
 203   (multi-link-parent!
 204    subasts
 205    (make-program #f subasts)))
 206
 207 (define-type op
 208   extender: define-type-of-op
 209   (six-id unprintable:)
 210   id
 211   unprintable:
 212   type-rule
 213   constant-fold
 214   code-gen)
 215
 216 (define-type-of-op op1)
 217 (define-type-of-op op2)