1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 module GenExp ( 37 gen_exps 38 ) where 39 40 import Config 41 import Types 42 import Env 43 import Utils 44 import GenVal 45 46 47 48 49 50 51 52 53 54 gen_exps :: Int -> Xscont (Val_name, Expression) -> Cont 55 gen_exps dp vnesc 56 = get_all_val_decls 57 (\vds -> cmap [gen_exp dp v . c1 vn | (vn,v) <- vds] vnesc) 58 where 59 c1 vn vnec e = vnec (vn,e) 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 type Genfn x = Int -> x -> Econt -> Cont 78 type Fnlist x = [(Int, (Genfn x, x -> Bool))] 79 80 81 82 83 84 85 86 87 88 gen_exp :: Genfn Value 89 gen_exp dp v ec | dp <= one = ec (Val_exp v) 90 | otherwise = pick_exp general_fns dp v ec 91 92 93 94 95 96 97 98 99 100 101 general_fns :: Fnlist Value 102 general_fns = [(1, (gen_exp',ok)), (1, (gen_lambda_exp,ok))] 103 104 105 106 107 108 109 110 111 112 113 114 gen_exp' :: Genfn Value 115 gen_exp' dp n@(Num_val Int_type _) ec = pick_exp intfns dp n ec 116 gen_exp' dp n@(Num_val Integer_type _) ec = pick_exp integerfns dp n ec 117 gen_exp' dp n@(Num_val Float_type _) ec = pick_exp floatfns dp n ec 118 gen_exp' dp n@(Num_val Double_type _) ec = pick_exp doublefns dp n ec 119 gen_exp' dp (Bool_val b) ec = pick_exp boolfns dp b ec 120 gen_exp' dp (Char_val c) ec = pick_exp charfns dp c ec 121 gen_exp' dp (List_val vs) ec = pick_exp listfns dp vs ec 122 gen_exp' dp (Tuple_val vs) ec = pick_exp tuplefns dp vs ec 123 gen_exp' dp (Tagged_val c vs) ec = pick_exp taggedfns dp (c,vs) ec 124 gen_exp' dp (Array_val vp avs) ec = pick_exp arrayfns dp (vp,avs) ec 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 gen_plus_exp :: Genfn Value 141 gen_plus_exp dp (Num_val k n) 142 = binary_exp plus_name (dp-one) (Num_val k 1) (Num_val k (n-one)) 143 144 145 146 147 148 149 150 gen_minus_exp :: Genfn Value 151 gen_minus_exp dp (Num_val k n) 152 = binary_exp minus_name (dp-one) (Num_val k (n+one)) (Num_val k 1) 153 154 155 156 157 158 159 160 gen_mult_exp :: Genfn Value 161 gen_mult_exp dp n'@(Num_val k n) 162 = binary_exp mult_name (dp-one) n' (Num_val k 1) 163 164 165 166 167 168 169 170 171 172 173 gen_div_exp :: Genfn Value 174 gen_div_exp dp n'@(Num_val k n) 175 = binary_exp div_name (dp-one) n' (Num_val k 1) 176 177 div_filter :: Value -> Bool 178 div_filter (Num_val _ n) = n /= 0 179 180 181 182 183 184 185 186 gen_neg_exp :: Genfn Value 187 gen_neg_exp dp (Num_val k n) 188 = unary_exp negate_name (dp-one) (Num_val k (negate n)) 189 190 191 192 193 194 195 196 197 198 199 gen_int_id_exp :: Genfn Value 200 gen_int_id_exp dp n'@(Num_val k n) ec 201 = get_all_lambdas (\vvs -> 202 case vvs of 203 [] -> gen_plus_exp dp n' ec 204 (_:_) -> choose vvs (\(vn, Num_val Int_type n'') -> 205 gen_exp (dp-one) (int_val (n-n'')) (\e -> 206 ec (Apply_exp (Apply_exp (Id_exp plus_name) (Id_exp vn)) 207 e)))) 208 209 210 211 212 213 214 215 intfns :: Fnlist Value 216 intfns = [(1, (gen_plus_exp,ok)), (1, (gen_minus_exp,ok)), 217 (1, (gen_mult_exp,ok)), (1, (gen_div_exp,div_filter)), 218 (1, (gen_neg_exp,ok)), (1, (gen_int_id_exp,ok))] 219 220 221 222 223 224 225 226 integerfns :: Fnlist Value 227 integerfns = intfns 228 229 230 231 232 233 234 235 floatfns :: Fnlist Value 236 floatfns = [(1, (gen_plus_exp,ok)), (1, (gen_minus_exp,ok)), 237 (1, (gen_mult_exp,ok)), (1, (gen_neg_exp,ok)), 238 (1, (gen_int_id_exp,ok))] 239 240 241 242 243 244 245 246 doublefns :: Fnlist Value 247 doublefns = floatfns 248 249 250 251 252 253 254 255 256 gen_not_exp :: Genfn Bool 257 gen_not_exp dp b = unary_exp not_name (dp-one) (Bool_val (not b)) 258 259 260 261 262 263 264 265 gen_and_exp :: Genfn Bool 266 gen_and_exp dp b = bool_binary_exp and_name (dp-one) True b 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 gen_or_exp :: Genfn Bool 282 gen_or_exp dp b = bool_binary_exp or_name (dp-one) False b 283 284 285 286 287 288 289 290 291 292 gen_less_exp :: Genfn Bool 293 gen_less_exp dp True = int_binary_exp less_name (dp-one) 0 1 294 gen_less_exp dp False = int_binary_exp less_name (dp-one) 1 1 295 296 297 298 299 300 301 302 boolfns :: Fnlist Bool 303 boolfns = [(1, (gen_not_exp,ok)), (1, (gen_and_exp,ok)), 304 (1, (gen_or_exp,ok)), (1, (gen_less_exp,ok))] 305 306 307 308 309 310 311 312 313 gen_decode_exp :: Genfn Char 314 gen_decode_exp dp c = unary_exp int_to_char_name (dp-one) (int_val (fromEnum c)) 315 316 317 318 319 320 321 322 charfns :: Fnlist Char 323 charfns = [(1, (gen_decode_exp,ok))] 324 325 326 327 328 329 330 331 332 333 334 gen_list_exp :: Genfn [Value] 335 gen_list_exp dp vs ec = cmap (map (gen_exp (dp-one)) vs) 336 (\es -> ec (List_exp es)) 337 338 339 340 341 342 343 344 345 gen_drop_exp :: Genfn [Value] 346 gen_drop_exp dp vs 347 = binary_exp drop_name (dp-one) (int_val (length vs)) (List_val (vs++vs)) 348 349 350 351 352 353 354 355 356 gen_take_exp :: Genfn [Value] 357 gen_take_exp dp vs 358 = binary_exp take_name (dp-one) (int_val (length vs)) (List_val (vs++vs)) 359 360 361 362 363 364 365 366 367 368 369 370 371 listfns :: Fnlist [Value] 372 listfns = [(8, (gen_list_exp,ok)), (1, (gen_drop_exp,ok)), 373 (1, (gen_take_exp,ok))] 374 375 376 377 378 379 380 381 382 383 384 gen_tuple_exp :: Genfn [Value] 385 gen_tuple_exp dp vs ec = cmap (map (gen_exp dp) vs) 386 (\es -> ec (Tuple_exp es)) 387 388 389 390 391 392 393 394 tuplefns :: Fnlist [Value] 395 tuplefns = [(1, (gen_tuple_exp,ok))] 396 397 398 399 400 401 402 403 404 405 gen_tagged_exp :: Genfn (Constructor, [Value]) 406 gen_tagged_exp dp (c,vs) ec = cmap (map (gen_exp dp) vs) 407 (\es -> ec (Tagged_exp c es)) 408 409 410 411 412 413 414 415 taggedfns :: Fnlist (Constructor, [Value]) 416 taggedfns = [(1, (gen_tagged_exp,ok))] 417 418 419 420 421 422 423 424 425 426 427 428 type Assoc a b = (a,b) 429 430 gen_array_exp :: Genfn ((Value,Value), [Assoc Value Value]) 431 gen_array_exp dp ((v,v'), avs) ec 432 = gen_exp (dp-one) (Tuple_val [v,v']) 433 (\e -> cmap [binary_exp assoc_name (dp-one) v1 v2 434 | (v1, v2) <- avs] 435 (\es -> ec (Array_exp e (List_exp es)))) 436 437 438 439 440 441 442 443 arrayfns :: Fnlist ((Value,Value), [Assoc Value Value]) 444 arrayfns = [(1, (gen_array_exp,ok))] 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 gen_lambda_exp :: Genfn Value 464 gen_lambda_exp dp v ec 465 = get_val_names one (\[vn] -> 466 gen_id_val (dp-one) (Basic_type (Num_type Int_type)) (\v' -> 467 push_lambda (vn, v') ( 468 gen_exp (dp-one) v (\e -> 469 pop_lambda (\ _ -> 470 choose [extend_val_env [(vn,v')] (ec (Apply_exp (Lambda_exp vn e) 471 (Id_exp vn))), 472 gen_exp (dp-one) v' 473 (\e' -> ec (Apply_exp (Lambda_exp vn e) e'))] 474 id))))) 475 476 477 478 479 480 481 482 483 484 485 486 487 pick_exp :: [(Int, (Genfn x, x -> Bool))] -> Genfn x 488 pick_exp fs dp x ec 489 = choosew fs (\(f,p) -> 490 if p x then f dp x ec else pick_exp fs dp x ec) 491 492 493 494 495 496 497 498 499 500 unary_exp :: Val_name -> Genfn Value 501 unary_exp vn dp v ec = gen_exp dp v (\e -> ec (Apply_exp (Id_exp vn) e)) 502 503 504 505 506 507 508 509 510 511 512 513 binary_exp :: Val_name -> Int -> Value -> Value -> Econt -> Cont 514 binary_exp vn dp v v' ec 515 = unary_exp vn dp v 516 (\e -> gen_exp dp v' 517 (\e' -> ec (Apply_exp e e'))) 518 519 520 521 522 523 524 525 526 int_binary_exp :: Val_name -> Int -> Int -> Int -> Econt -> Cont 527 int_binary_exp vn dp n n' = binary_exp vn dp (int_val n) (int_val n') 528 529 bool_binary_exp :: Val_name -> Int -> Bool -> Bool -> Econt -> Cont 530 bool_binary_exp vn dp b b' = binary_exp vn dp (Bool_val b) (Bool_val b') 531 532 533 534 535 536 537 ok :: x -> Bool 538 ok x = True 539 540