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 ;; TODO should we handle array index operator this way instead of a special case
 133 (define-op1 'six.*x '*x
 134   (lambda (ast)
 135     'byte) ; we only have byte arrays
 136   (lambda (ast)
 137     ast)
 138   (lambda (ast)
 139     ...))
 140
 141 (define-op2 'six.x/y 'x/y
 142   type-rule-int-op2
 143   (lambda (ast)
 144     ast)
 145   (lambda (ast)
 146     ...))
 147
 148 (define-op2 'six.x+y 'x+y
 149   type-rule-int-op2
 150   (lambda (ast)
 151     ast)
 152   (lambda (ast)
 153     ...))
 154
 155 (define-op1 'six.+x '+x
 156   type-rule-int-op1
 157   (lambda (ast)
 158     (subast1 ast))
 159   (lambda (ast)
 160     ...))
 161
 162 (define-op2 'six.x-y 'x-y
 163   type-rule-int-op2
 164   (lambda (ast)
 165     ast)
 166   (lambda (ast)
 167     ...))
 168
 169 (define-op1 'six.-x '-x
 170   type-rule-int-op1
 171   (lambda (ast)
 172     ast)
 173   (lambda (ast)
 174     ...))
 175
 176 (define-op2 'six.x<<y 'x<<y
 177   type-rule-int-op2
 178   (lambda (ast)
 179     ast)
 180   (lambda (ast)
 181     ...))
 182
 183 (define-op2 'six.x>>y 'x>>y
 184   type-rule-int-op2
 185   (lambda (ast)
 186     ast)
 187   (lambda (ast)
 188     ...))
 189
 190 (define-op2 'six.x<y 'x<y
 191   type-rule-int-comp-op2
 192   (lambda (ast)
 193     ast)
 194   (lambda (ast)
 195     ...))
 196
 197 (define-op2 'six.x<=y 'x<=y
 198   type-rule-int-comp-op2
 199   (lambda (ast)
 200     ast)
 201   (lambda (ast)
 202     ...))
 203
 204 (define-op2 'six.x>y 'x>y
 205   type-rule-int-comp-op2
 206   (lambda (ast)
 207     ast)
 208   (lambda (ast)
 209     ...))
 210
 211 (define-op2 'six.x>=y 'x>=y
 212   type-rule-int-comp-op2
 213   (lambda (ast)
 214     ast)
 215   (lambda (ast)
 216     ...))
 217
 218 (define-op2 'six.x!=y 'x!=y
 219   type-rule-int-comp-op2
 220   (lambda (ast)
 221     ast)
 222   (lambda (ast)
 223     ...))
 224
 225 (define-op2 'six.x==y 'x==y
 226   type-rule-int-comp-op2
 227   (lambda (ast)
 228     ast)
 229   (lambda (ast)
 230     ...))
 231
 232 (define-op2 'six.x&y 'x&y
 233   type-rule-int-op2
 234   (lambda (ast)
 235     ast)
 236   (lambda (ast)
 237     ...))
 238
 239 (define-op1 'six.&x '&x
 240   (lambda (ast)
 241     ...)
 242   (lambda (ast)
 243     ast)
 244   (lambda (ast)
 245     ...))
 246
 247 (define-op2 'six.x^y 'x^y
 248   type-rule-int-op2
 249   (lambda (ast)
 250     ast)
 251   (lambda (ast)
 252     ...))
 253
 254 (define-op2 '|six.x\|y| '|x\|y|
 255   type-rule-int-op2
 256   (lambda (ast)
 257     ast)
 258   (lambda (ast)
 259     ...))
 260
 261 (define-op2 'six.x&&y 'x&&y
 262   type-rule-bool-op2
 263   (lambda (ast)
 264     ast)
 265   (lambda (ast)
 266     ...))
 267
 268 (define-op2 '|six.x\|\|y| '|x\|\|y|
 269   type-rule-bool-op2
 270   (lambda (ast)
 271     ast)
 272   (lambda (ast)
 273     ...))
 274
 275 (define-op2 'six.x?y:z 'x?y:z
 276   (lambda (ast)
 277     ...)
 278   (lambda (ast)
 279     ast)
 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-int-assign
 293   (lambda (ast)
 294     ast)
 295   (lambda (ast)
 296     ...))
 297
 298 (define-op2 'six.x&=y 'x&=y
 299   type-rule-int-assign
 300   (lambda (ast)
 301     ast)
 302   (lambda (ast)
 303     ...))
 304
 305 (define-op2 'six.x*=y 'x*=y
 306   type-rule-int-assign
 307   (lambda (ast)
 308     ast)
 309   (lambda (ast)
 310     ...))
 311
 312 (define-op2 'six.x+=y 'x+=y
 313   type-rule-int-assign
 314   (lambda (ast)
 315     ast)
 316   (lambda (ast)
 317     ...))
 318
 319 (define-op2 'six.x-=y 'x-=y
 320   type-rule-int-assign
 321   (lambda (ast)
 322     ast)
 323   (lambda (ast)
 324     ...))
 325
 326 (define-op2 'six.x/=y 'x/=y
 327   type-rule-int-assign
 328   (lambda (ast)
 329     ast)
 330   (lambda (ast)
 331     ...))
 332
 333 (define-op2 'six.x<<=y 'x<<=y
 334   type-rule-int-assign
 335   (lambda (ast)
 336     ast)
 337   (lambda (ast)
 338     ...))
 339
 340 (define-op2 'six.x=y 'x=y
 341   type-rule-int-assign
 342   (lambda (ast)
 343     ast)
 344   (lambda (ast)
 345     ...))
 346
 347 (define-op2 'six.x>>=y 'x>>=y
 348   type-rule-int-assign
 349   (lambda (ast)
 350     ast)
 351   (lambda (ast)
 352     ...))
 353
 354 (define-op2 'six.x^=y 'x^=y
 355   type-rule-int-assign
 356   (lambda (ast)
 357     ast)
 358   (lambda (ast)
 359     ...))
 360
 361 (define-op2 '|six.x\|=y| '|x\|=y|
 362   type-rule-int-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))))))))