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