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           (new-literal (expr-type ast) (op lx))
  60           ast))))
  61
  62 (define (constant-fold-op2 op)
  63   (lambda (ast)
  64     (let* ((x  (subast1   ast))
  65            (y  (subast2   ast))
  66            (lx (cond ((literal? x)
  67                       (literal-val x))
  68                      ((operation? x) =>
  69                       (lambda (op)
  70                         (let ((val ((op-constant-fold op) x)))
  71                           (if (literal? val) val #f))))
  72                      (else #f)))
  73            (ly (cond ((literal? y)
  74                       (literal-val y))
  75                      ((operation? y) =>
  76                       (lambda (op)
  77                         (let ((val ((op-constant-fold op) y)))
  78                           (if (literal? val) val #f))))
  79                      (else #f))))
  80       (if (and lx ly)
  81           (new-literal (expr-type ast) (op lx ly))
  82           ast))))
  83
  84 (define-op1 'six.!x '!x
  85   type-rule-int-op1
  86   (lambda (ast)
  87     ast)
  88   (lambda (ast)
  89     ...))
  90
  91
  92 (define-op1 'six.++x '++x
  93   type-rule-int-op1
  94   (lambda (ast)
  95     ast) ;; TODO
  96   (lambda (ast)
  97     ...))
  98
  99 (define-op1 'six.x++ 'x++
 100   type-rule-int-op1
 101   (lambda (ast)
 102     ast) ;; TODO
 103   (lambda (ast)
 104     ...))
 105
 106 (define-op1 'six.--x '--x
 107   type-rule-int-op1
 108   (lambda (ast)
 109     ast) ;; TODO
 110   (lambda (ast)
 111     ...))
 112
 113 (define-op1 'six.x-- 'x--
 114   type-rule-int-op1
 115   (lambda (ast)
 116     ast) ;; TODO
 117   (lambda (ast)
 118     ...))
 119
 120 (define-op1 'six.~x '~x
 121   type-rule-int-op1
 122   (lambda (ast)
 123     ast) ;; TODO
 124   (lambda (ast)
 125     ...))
 126
 127 (define-op2 'six.x%y 'x%y
 128   type-rule-int-op2
 129   (constant-fold-op2 modulo)
 130   (lambda (ast)
 131     ...))
 132
 133 (define-op2 'six.x*y 'x*y
 134   type-rule-int-op2
 135   (constant-fold-op2 *)
 136   (lambda (ast)
 137     ...))
 138
 139 (define-op1 'six.*x '*x
 140   (lambda (ast)
 141     'byte) ; we only have byte arrays
 142   (lambda (ast)
 143     ast)
 144   (lambda (ast)
 145     ...))
 146
 147 (define-op2 'six.index 'index
 148   (lambda (ast)
 149     'byte) ; we only have byte arrays
 150   (lambda (ast)
 151     ast)
 152   (lambda (asr)
 153     ...))
 154
 155 (define-op2 'six.x/y 'x/y
 156   type-rule-int-op2
 157   (constant-fold-op2 /)
 158   (lambda (ast)
 159     ...))
 160
 161 (define-op2 'six.x+y 'x+y
 162   type-rule-int-op2
 163   (constant-fold-op2 +)
 164   (lambda (ast)
 165     ...))
 166
 167 (define-op1 'six.+x '+x
 168   type-rule-int-op1
 169   (lambda (ast)
 170     (subast1 ast))
 171   (lambda (ast)
 172     ...))
 173
 174 (define-op2 'six.x-y 'x-y
 175   type-rule-int-op2
 176   (constant-fold-op2 -)
 177   (lambda (ast)
 178     ...))
 179
 180 (define-op1 'six.-x '-x
 181   type-rule-int-op1
 182   (constant-fold-op1 (lambda (x) (- x)))
 183   (lambda (ast)
 184     ...))
 185
 186 (define-op2 'six.x<<y 'x<<y
 187   type-rule-int-op2
 188   (constant-fold-op2 arithmetic-shift)
 189   (lambda (ast)
 190     ...))
 191
 192 (define-op2 'six.x>>y 'x>>y
 193   type-rule-int-op2
 194   (constant-fold-op2 (lambda (x y) (arithmetic-shift x (- y))))
 195   (lambda (ast)
 196     ...))
 197
 198 (define-op2 'six.x<y 'x<y
 199   type-rule-int-comp-op2
 200   (constant-fold-op2 (lambda (x y) (if (< x y) 1 0)))
 201   (lambda (ast)
 202     ...))
 203
 204 (define-op2 'six.x<=y 'x<=y
 205   type-rule-int-comp-op2
 206   (constant-fold-op2 (lambda (x y) (if (<= x y) 1 0)))
 207   (lambda (ast)
 208     ...))
 209
 210 (define-op2 'six.x>y 'x>y
 211   type-rule-int-comp-op2
 212   (constant-fold-op2 (lambda (x y) (if (> x y) 1 0)))
 213   (lambda (ast)
 214     ...))
 215
 216 (define-op2 'six.x>=y 'x>=y
 217   type-rule-int-comp-op2
 218   (constant-fold-op2 (lambda (x y) (if (>= x y) 1 0)))
 219   (lambda (ast)
 220     ...))
 221
 222 (define-op2 'six.x!=y 'x!=y
 223   type-rule-int-comp-op2
 224   (constant-fold-op2 (lambda (x y) (if (not (= x y)) 1 0)))
 225   (lambda (ast)
 226     ...))
 227
 228 (define-op2 'six.x==y 'x==y
 229   type-rule-int-comp-op2
 230   (constant-fold-op2 (lambda (x y) (if (= x y) 1 0)))
 231   (lambda (ast)
 232     ...))
 233
 234 (define-op2 'six.x&y 'x&y
 235   type-rule-int-op2
 236   (constant-fold-op2 bitwise-and)
 237   (lambda (ast)
 238     ...))
 239
 240 (define-op1 'six.&x '&x
 241   (lambda (ast)
 242     ...)
 243   (lambda (ast)
 244     ast) ;; TODO
 245   (lambda (ast)
 246     ...))
 247
 248 (define-op2 'six.x^y 'x^y
 249   type-rule-int-op2
 250   (constant-fold-op2 bitwise-xor)
 251   (lambda (ast)
 252     ...))
 253
 254 (define-op2 '|six.x\|y| '|x\|y|
 255   type-rule-int-op2
 256   (constant-fold-op2 bitwise-ior)
 257   (lambda (ast)
 258     ...))
 259
 260 (define-op2 'six.x&&y 'x&&y
 261   type-rule-bool-op2
 262   (constant-fold-op2 (lambda (x y) (if (and (not (= x 0)) (not (= y 0))) 1 0)))
 263   (lambda (ast)
 264     ...))
 265
 266 (define-op2 '|six.x\|\|y| '|x\|\|y|
 267   type-rule-bool-op2
 268   (constant-fold-op2 (lambda (x y) (if (or (not (= x 0)) (not (= y 0))) 1 0)))
 269   (lambda (ast)
 270     ...))
 271
 272 (define-op3 'six.x?y:z 'x?y:z
 273   (lambda (ast)
 274     ;; largest of the 2 branches
 275     (let ((t1 (expr-type (subast2 ast)))
 276           (t2 (expr-type (subast3 ast))))
 277     (largest t1 t2)))
 278   (lambda (ast)
 279     ast) ;; TODO
 280   (lambda (ast)
 281     ...))
 282
 283 (define-op2 'six.x:y 'x:y
 284   (lambda (ast)
 285     ...)
 286   (lambda (ast)
 287     ast)
 288   (lambda (ast)
 289     ...))
 290
 291 (define-op2 'six.x%=y 'x%=y
 292   type-rule-assign
 293   (lambda (ast)
 294     ast)
 295   (lambda (ast)
 296     ...))
 297
 298 (define-op2 'six.x&=y 'x&=y
 299   type-rule-assign
 300   (lambda (ast)
 301     ast)
 302   (lambda (ast)
 303     ...))
 304
 305 (define-op2 'six.x*=y 'x*=y
 306   type-rule-assign
 307   (lambda (ast)
 308     ast)
 309   (lambda (ast)
 310     ...))
 311
 312 (define-op2 'six.x+=y 'x+=y
 313   type-rule-assign
 314   (lambda (ast)
 315     ast)
 316   (lambda (ast)
 317     ...))
 318
 319 (define-op2 'six.x-=y 'x-=y
 320   type-rule-assign
 321   (lambda (ast)
 322     ast)
 323   (lambda (ast)
 324     ...))
 325
 326 (define-op2 'six.x/=y 'x/=y
 327   type-rule-assign
 328   (lambda (ast)
 329     ast)
 330   (lambda (ast)
 331     ...))
 332
 333 (define-op2 'six.x<<=y 'x<<=y
 334   type-rule-assign
 335   (lambda (ast)
 336     ast)
 337   (lambda (ast)
 338     ...))
 339
 340 (define-op2 'six.x=y 'x=y
 341   type-rule-assign
 342   (lambda (ast)
 343     ast)
 344   (lambda (ast)
 345     ...))
 346
 347 (define-op2 'six.x>>=y 'x>>=y
 348   type-rule-assign
 349   (lambda (ast)
 350     ast)
 351   (lambda (ast)
 352     ...))
 353
 354 (define-op2 'six.x^=y 'x^=y
 355   type-rule-assign
 356   (lambda (ast)
 357     ast)
 358   (lambda (ast)
 359     ...))
 360
 361 (define-op2 '|six.x\|=y| '|x\|=y|
 362   type-rule-assign
 363   (lambda (ast)
 364     ast)
 365   (lambda (ast)
 366     ...))
 367
 368 (define-op2 'six.x:=y 'x:=y
 369   (lambda (ast)
 370     ...)
 371   (lambda (ast)
 372     ...)
 373   (lambda (ast)
 374     ...))
 375
 376 (define-op2 '|six.x,y| '|x,y|
 377   (lambda (ast)
 378     ...)
 379   (lambda (ast)
 380     ...)
 381   (lambda (ast)
 382     ...))
 383
 384 (define-op2 'six.x:-y 'x:-y
 385   (lambda (ast)
 386     ...)
 387   (lambda (ast)
 388     ...)
 389   (lambda (ast)
 390     ...))
 391
 392 (define (operation? source)
 393   (and (pair? source)
 394        (let ((x (car source)))
 395          (let loop ((lst operators))
 396            (cond ((null? lst)
 397                   #f)
 398                  ((eq? (op-six-id (car lst)) x)
 399                   (car lst))
 400                  (else
 401                   (loop (cdr lst))))))))