operators.scm

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