operators.scm

   1 ;;; operators
   2
   3 (define operators '())
   4
   5 (define (define-op constructor six-id id type-rule constant-fold code-gen)
   6   (set! operators
   7         (cons (constructor six-id id type-rule constant-fold code-gen)
   8               operators)))
   9 (define (define-op1 six-id id type-rule constant-fold code-gen)
  10   (define-op make-op1 six-id id type-rule constant-fold code-gen))
  11 (define (define-op2 six-id id type-rule constant-fold code-gen)
  12   (define-op make-op2 six-id id type-rule constant-fold code-gen))
  13 (define (define-op3 six-id id type-rule constant-fold code-gen)
  14   (define-op make-op3 six-id id type-rule constant-fold code-gen))
  15
  16 ;; no need for type checks, every type sixpic supports can be casted to / from
  17 ;; ints (except void, but this is a non-issue) and promotion (by padding) and
  18 ;; truncation is done at the cfg level
  19 (define (type-rule-int-op1 ast)
  20   (expr-type (subast1 ast)))
  21
  22 (define (largest t1 t2)
  23   (if (> (type->bytes t1) (type->bytes t2))
  24       t1
  25       t2))
  26
  27 (define (type-rule-int-op2 ast)
  28   ;; used for any binary operation involving two integers where the result is
  29   ;; of the size of the biggest operand (subtraction, bitwise operations, ...)
  30   (let ((t1 (expr-type (subast1 ast)))
  31         (t2 (expr-type (subast2 ast))))
  32     (largest t1 t2)))
  33
  34 (define (type-rule-assign ast)
  35   (let ((t1 (expr-type (subast1 ast))))
  36     ;; the type of the rhs is irrelevant, since it will be promoted
  37     ;; or truncated at the cfg level
  38     t1))
  39
  40 ;; the standard says it should be int
  41 (define (type-rule-int-comp-op2 ast)
  42   'int)
  43
  44 (define (type-rule-bool-op2 ast)
  45   'int)
  46
  47
  48 (define (constant-fold-op1 op)
  49   (lambda (ast)
  50     (let* ((x  (subast1   ast))
  51            (lx (cond ((literal? x)
  52                       (literal-val x))
  53                      ((operation? x) =>
  54                       (lambda (op)
  55                         (let ((val ((op-constant-fold op) x)))
  56                           (if (literal? val) val #f))))
  57                      (else #f))))
  58       (if lx
  59           (let ((res (op lx)))
  60             (new-literal (val->type res) res))
  61           ast))))
  62
  63 (define (constant-fold-op2 op)
  64   (lambda (ast)
  65     (let* ((x  (subast1   ast))
  66            (y  (subast2   ast))
  67            (lx (cond ((literal? x)
  68                       (literal-val x))
  69                      ((operation? x) =>
  70                       (lambda (op)
  71                         (let ((val ((op-constant-fold op) x)))
  72                           (if (literal? val) val #f))))
  73                      (else #f)))
  74            (ly (cond ((literal? y)
  75                       (literal-val y))
  76                      ((operation? y) =>
  77                       (lambda (op)
  78                         (let ((val ((op-constant-fold op) y)))
  79                           (if (literal? val) val #f))))
  80                      (else #f))))
  81       (if (and lx ly)
  82           (let ((res (op lx ly)))
  83             (new-literal (val->type res) res))
  84           ast))))
  85
  86 (define-op1 'six.!x '!x
  87   type-rule-int-op1
  88   (lambda (ast)
  89     ast)
  90   (lambda (ast)
  91     ...))
  92
  93
  94 (define-op1 'six.++x '++x
  95   type-rule-int-op1
  96   (lambda (ast)
  97     ast) ;; TODO
  98   (lambda (ast)
  99     ...))
 100
 101 (define-op1 'six.x++ 'x++
 102   type-rule-int-op1
 103   (lambda (ast)
 104     ast) ;; TODO
 105   (lambda (ast)
 106     ...))
 107
 108 (define-op1 'six.--x '--x
 109   type-rule-int-op1
 110   (lambda (ast)
 111     ast) ;; TODO
 112   (lambda (ast)
 113     ...))
 114
 115 (define-op1 'six.x-- 'x--
 116   type-rule-int-op1
 117   (lambda (ast)
 118     ast) ;; TODO
 119   (lambda (ast)
 120     ...))
 121
 122 (define-op1 'six.~x '~x
 123   type-rule-int-op1
 124   (lambda (ast)
 125     ast) ;; TODO
 126   (lambda (ast)
 127     ...))
 128
 129 (define-op2 'six.x%y 'x%y
 130   type-rule-int-op2
 131   (constant-fold-op2 modulo)
 132   (lambda (ast)
 133     ...))
 134
 135 (define-op2 'six.x*y 'x*y
 136   type-rule-int-op2
 137   (constant-fold-op2 *)
 138   (lambda (ast)
 139     ...))
 140
 141 (define-op1 'six.*x '*x
 142   (lambda (ast)
 143     'byte) ; we only have byte arrays
 144   (lambda (ast)
 145     ast)
 146   (lambda (ast)
 147     ...))
 148
 149 (define-op2 'six.index 'index
 150   (lambda (ast)
 151     'byte) ; we only have byte arrays
 152   (lambda (ast)
 153     ast)
 154   (lambda (asr)
 155     ...))
 156
 157 (define-op2 'six.x/y 'x/y
 158   type-rule-int-op2
 159   (constant-fold-op2 /)
 160   (lambda (ast)
 161     ...))
 162
 163 (define-op2 'six.x+y 'x+y
 164   type-rule-int-op2
 165   (constant-fold-op2 +)
 166   (lambda (ast)
 167     ...))
 168
 169 (define-op1 'six.+x '+x
 170   type-rule-int-op1
 171   (lambda (ast)
 172     (subast1 ast))
 173   (lambda (ast)
 174     ...))
 175
 176 (define-op2 'six.x-y 'x-y
 177   type-rule-int-op2
 178   (constant-fold-op2 -)
 179   (lambda (ast)
 180     ...))
 181
 182 (define-op1 'six.-x '-x
 183   type-rule-int-op1
 184   (constant-fold-op1 (lambda (x) (- x)))
 185   (lambda (ast)
 186     ...))
 187
 188 (define-op2 'six.x<<y 'x<<y
 189   type-rule-int-op2
 190   (constant-fold-op2 arithmetic-shift)
 191   (lambda (ast)
 192     ...))
 193
 194 (define-op2 'six.x>>y 'x>>y
 195   type-rule-int-op2
 196   (constant-fold-op2 (lambda (x y) (arithmetic-shift x (- y))))
 197   (lambda (ast)
 198     ...))
 199
 200 (define-op2 'six.x<y 'x<y
 201   type-rule-int-comp-op2
 202   (constant-fold-op2 (lambda (x y) (if (< x y) 1 0)))
 203   (lambda (ast)
 204     ...))
 205
 206 (define-op2 'six.x<=y 'x<=y
 207   type-rule-int-comp-op2
 208   (constant-fold-op2 (lambda (x y) (if (<= x y) 1 0)))
 209   (lambda (ast)
 210     ...))
 211
 212 (define-op2 'six.x>y 'x>y
 213   type-rule-int-comp-op2
 214   (constant-fold-op2 (lambda (x y) (if (> x y) 1 0)))
 215   (lambda (ast)
 216     ...))
 217
 218 (define-op2 'six.x>=y 'x>=y
 219   type-rule-int-comp-op2
 220   (constant-fold-op2 (lambda (x y) (if (>= x y) 1 0)))
 221   (lambda (ast)
 222     ...))
 223
 224 (define-op2 'six.x!=y 'x!=y
 225   type-rule-int-comp-op2
 226   (constant-fold-op2 (lambda (x y) (if (not (= x y)) 1 0)))
 227   (lambda (ast)
 228     ...))
 229
 230 (define-op2 'six.x==y 'x==y
 231   type-rule-int-comp-op2
 232   (constant-fold-op2 (lambda (x y) (if (= x y) 1 0)))
 233   (lambda (ast)
 234     ...))
 235
 236 (define-op2 'six.x&y 'x&y
 237   type-rule-int-op2
 238   (constant-fold-op2 bitwise-and)
 239   (lambda (ast)
 240     ...))
 241
 242 (define-op1 'six.&x '&x
 243   (lambda (ast)
 244     ...)
 245   (lambda (ast)
 246     ast) ;; TODO
 247   (lambda (ast)
 248     ...))
 249
 250 (define-op2 'six.x^y 'x^y
 251   type-rule-int-op2
 252   (constant-fold-op2 bitwise-xor)
 253   (lambda (ast)
 254     ...))
 255
 256 (define-op2 '|six.x\|y| '|x\|y|
 257   type-rule-int-op2
 258   (constant-fold-op2 bitwise-ior)
 259   (lambda (ast)
 260     ...))
 261
 262 (define-op2 'six.x&&y 'x&&y
 263   type-rule-bool-op2
 264   (constant-fold-op2 (lambda (x y) (if (and (not (= x 0)) (not (= y 0))) 1 0)))
 265   (lambda (ast)
 266     ...))
 267
 268 (define-op2 '|six.x\|\|y| '|x\|\|y|
 269   type-rule-bool-op2
 270   (constant-fold-op2 (lambda (x y) (if (or (not (= x 0)) (not (= y 0))) 1 0)))
 271   (lambda (ast)
 272     ...))
 273
 274 (define-op3 'six.x?y:z 'x?y:z
 275   (lambda (ast)
 276     ;; largest of the 2 branches
 277     (let ((t1 (expr-type (subast2 ast)))
 278           (t2 (expr-type (subast3 ast))))
 279     (largest t1 t2)))
 280   (lambda (ast)
 281     ast) ;; TODO
 282   (lambda (ast)
 283     ...))
 284
 285 (define-op2 'six.x:y 'x:y
 286   (lambda (ast)
 287     ...)
 288   (lambda (ast)
 289     ast)
 290   (lambda (ast)
 291     ...))
 292
 293 (define-op2 'six.x%=y 'x%=y
 294   type-rule-assign
 295   (lambda (ast)
 296     ast)
 297   (lambda (ast)
 298     ...))
 299
 300 (define-op2 'six.x&=y 'x&=y
 301   type-rule-assign
 302   (lambda (ast)
 303     ast)
 304   (lambda (ast)
 305     ...))
 306
 307 (define-op2 'six.x*=y 'x*=y
 308   type-rule-assign
 309   (lambda (ast)
 310     ast)
 311   (lambda (ast)
 312     ...))
 313
 314 (define-op2 'six.x+=y 'x+=y
 315   type-rule-assign
 316   (lambda (ast)
 317     ast)
 318   (lambda (ast)
 319     ...))
 320
 321 (define-op2 'six.x-=y 'x-=y
 322   type-rule-assign
 323   (lambda (ast)
 324     ast)
 325   (lambda (ast)
 326     ...))
 327
 328 (define-op2 'six.x/=y 'x/=y
 329   type-rule-assign
 330   (lambda (ast)
 331     ast)
 332   (lambda (ast)
 333     ...))
 334
 335 (define-op2 'six.x<<=y 'x<<=y
 336   type-rule-assign
 337   (lambda (ast)
 338     ast)
 339   (lambda (ast)
 340     ...))
 341
 342 (define-op2 'six.x=y 'x=y
 343   type-rule-assign
 344   (lambda (ast)
 345     ast)
 346   (lambda (ast)
 347     ...))
 348
 349 (define-op2 'six.x>>=y 'x>>=y
 350   type-rule-assign
 351   (lambda (ast)
 352     ast)
 353   (lambda (ast)
 354     ...))
 355
 356 (define-op2 'six.x^=y 'x^=y
 357   type-rule-assign
 358   (lambda (ast)
 359     ast)
 360   (lambda (ast)
 361     ...))
 362
 363 (define-op2 '|six.x\|=y| '|x\|=y|
 364   type-rule-assign
 365   (lambda (ast)
 366     ast)
 367   (lambda (ast)
 368     ...))
 369
 370 (define-op2 'six.x:=y 'x:=y
 371   (lambda (ast)
 372     ...)
 373   (lambda (ast)
 374     ...)
 375   (lambda (ast)
 376     ...))
 377
 378 (define-op2 '|six.x,y| '|x,y|
 379   (lambda (ast)
 380     ...)
 381   (lambda (ast)
 382     ...)
 383   (lambda (ast)
 384     ...))
 385
 386 (define-op2 'six.x:-y 'x:-y
 387   (lambda (ast)
 388     ...)
 389   (lambda (ast)
 390     ...)
 391   (lambda (ast)
 392     ...))
 393
 394 (define (operation? source)
 395   (and (pair? source)
 396        (let ((x (car source)))
 397          (let loop ((lst operators))
 398            (cond ((null? lst)
 399                   #f)
 400                  ((eq? (op-six-id (car lst)) x)
 401                   (car lst))
 402                  (else
 403                   (loop (cdr lst))))))))