v6/Mildew-Setting-SMOP/MildewCORE.setting

   1 my module MildewCORE;
   2
   3 use adhoc-signatures;
   4
   5
   6 ##HACK
   7 $LexicalPrelude{'&True'} := sub {::True}
   8 $LexicalPrelude{'&False'} := sub {::False}
   9
  10 my knowhow int {
  11     method ACCEPTS($thing) {
  12         PRIMITIVES::ritest((|$thing),PRIMITIVES::SMOP_RI(2));
  13     }
  14 }
  15
  16 my sub return(|$capture) {
  17     my $e = ::ControlExceptionReturn.new();
  18     $e.capture = $capture;
  19     $e.routine = CALLER::<&?ROUTINE>;
  20     $e.throw;
  21 }
  22
  23
  24
  25
  26 ############## Operators ##############
  27
  28 # TODO change binds to sub definitions
  29
  30 $LexicalPrelude{'&infix:+:(int,int)'} := sub ($a,$b) {
  31     PRIMITIVES::int_add($a.FETCH,$b.FETCH);
  32 }
  33
  34 $LexicalPrelude{'&infix:<:(int,int)'} := sub ($a,$b) {
  35     PRIMITIVES::int_less($a.FETCH,$b.FETCH);
  36 }
  37
  38 $LexicalPrelude{'&infix:-:(int,int)'} := sub ($a,$b) {
  39     PRIMITIVES::int_substract($a.FETCH,$b.FETCH);
  40 }
  41
  42 $LexicalPrelude{'&infix:==:(int,int)'} := sub ($a,$b) {
  43     PRIMITIVES::int_equal($a.FETCH,$b.FETCH);
  44 }
  45
  46 $LexicalPrelude{'&infix:~'} := sub (|$capture) {
  47     my $i = 0;
  48     my $str = '';
  49     loop {
  50         if &infix:<==>:(int,int)($i.FETCH,$capture.elems) {
  51             return $str.FETCH;
  52         } else {
  53            $str = PRIMITIVES::idconst_concat($str.FETCH,$capture.positional($i.FETCH).FETCH.Str);
  54            $i = &infix:<+>:(int,int)($i.FETCH,1);
  55         }
  56     }
  57 }
  58 $LexicalPrelude{'&infix:eq'} := sub ($a,$b) {
  59     PRIMITIVES::idconst_eq($a.Str,$b.Str);
  60 }
  61 $LexicalPrelude{'&infix:ne'} := sub ($a,$b) {
  62     if PRIMITIVES::idconst_eq($a.Str,$b.Str) {
  63         False;
  64     } else {
  65         True;
  66     }
  67 }
  68 $LexicalPrelude{'&postfix:++'} := sub ($a) {
  69     $a = &infix:<+>:(int,int)($a,1);
  70 }
  71 $LexicalPrelude{'&prefix:++'} := sub ($a) {
  72     my $old = $a;
  73     $a = &infix:<+>:(int,int)($a,1);
  74     $old;
  75 }
  76
  77 ############## RoleHOW ##############
  78
  79 my sub copy_methods($dst,$src) {
  80     map(sub ($key) {
  81         $dst.^!methods{$key.FETCH} = $src.^!methods{$key.FETCH};
  82     },$src.^!methods.keys);
  83 }
  84 my sub copy_does($dst,$src) {
  85     my $i = 0;
  86     loop {
  87         if &infix:<==>:(int,int)($i,$src.^!does.elems) {
  88             return;
  89         } else {
  90             $dst.^!does[$i.FETCH] = $src.^!does[$i.FETCH];
  91             $i = &infix:<+>:(int,int)($i.FETCH,1);
  92         }
  93     }
  94 }
  95 my sub compose_role($obj,$role) {
  96     $obj.^!does.push((|$role));
  97     map(sub ($key) {
  98         if $obj.^!methods{$key.FETCH} {
  99             ::Exception.new.throw;
 100         }
 101         $obj.^add_method($key.FETCH,$role.^!methods{$key.FETCH}.FETCH);
 102     },$role.^!methods.keys);
 103 }
 104 my knowhow RoleHOW {
 105     method add_attribute($object, $privname, $attribute) {
 106         $object.^!attributes{$privname.FETCH} = $attribute;
 107     }
 108     method compose_role($object, $role) {
 109         compose_role($object,$role);
 110     }
 111     method add_method($object, $name, $code) {
 112         $object.^!methods{$name.FETCH} = $code
 113     }
 114     method dispatch($object, $identifier, \$capture) {
 115         if PRIMITIVES::idconst_eq($identifier.FETCH,'FETCH') {
 116             # in item context, returns itself.
 117             (|$object);
 118         } else {
 119             # Roles are not classes! so we're going to delegate this to a
 120             # punned class that does this role. For now, we're going to pun a
 121             # new class every time, then we'll think in some sort of caching.
 122             my $punned;
 123             if $object.^!instance_storage.exists('CACHED_PUNNED_CLASS') {
 124                 $punned = $object.^!instance_storage{'CACHED_PUNNED_CLASS'};
 125             } else {
 126                 my $class = ::p6opaque.^!CREATE;
 127                 $class.^!how = ::PrototypeHOW;
 128
 129                 #XXX is it right?
 130                 $class.^!who = $object.^!who;
 131
 132                 $class.^!does.push((|$object));
 133     #            $class.^compose_role(::LowObject);
 134     #            $class.^compose_role($object);
 135                 copy_methods($class,::LowObject);
 136                 copy_methods($class,$object);
 137                 $punned = $class;
 138                 $object.^!instance_storage{'CACHED_PUNNED_CLASS'} = $class;
 139             }
 140             my $delegated = ::Scalar.new($capture.delegate($punned.FETCH));
 141             return $punned.^dispatch($identifier.FETCH, (|$delegated));
 142         }
 143     }
 144 }
 145 my role LowObject {
 146     method new() {
 147         my $obj = ::p6opaque.^!CREATE;
 148         $obj.^!how = self.^!how;
 149         $obj.^!who = self.^!who;
 150         copy_methods($obj,self);
 151         copy_does($obj,self);
 152         if $obj.^!methods{'BUILDALL'} {
 153             $obj.BUILDALL;
 154         }
 155         $obj;
 156     }
 157     method ACCEPTS($obj) {
 158         my $role = self.^!does[0];
 159         my $does = False;
 160         map(sub ($r) {
 161             if PRIMITIVES::pointer_equal((|$role),(|$r)) {
 162                 $does = True;
 163             } elsif self.ACCEPTS($r) {
 164                 $does = True;
 165             }
 166         },$obj.^!does);
 167         $does;
 168     }
 169 }
 170
 171 ############## basic subroutines ##############
 172
 173 my sub map($expression,$values) {
 174     my $i = 0;
 175     my $ret = ::Array.new;
 176     loop {
 177         if &infix:<==>:(int,int)($i,$values.elems) {
 178             return $ret;
 179         } else {
 180            $ret.push((|$expression($values[$i.FETCH])));
 181            $i = &infix:<+>:(int,int)($i.FETCH,1);
 182         }
 183     }
 184 }
 185
 186 my sub grep($expression,$values) {
 187     my $i = 0;
 188     my $ret = ::Array.new;
 189     loop {
 190         if &infix:<==>:(int,int)($i,$values.elems) {
 191             return $ret;
 192         } else {
 193            if ($expression($values[$i.FETCH])) {
 194               $ret.push($values[$i.FETCH].FETCH);
 195            } else {
 196            }
 197            $i = &infix:<+>:(int,int)($i.FETCH,1);
 198         }
 199     }
 200 }
 201
 202 my sub say(|$capture) {
 203     my $i = 0;
 204     loop {
 205         if &infix:<==>:(int,int)($i,$capture.elems) {
 206             $OUT.print("\n");
 207             return;
 208         } else {
 209            $OUT.print($capture.positional($i.FETCH).Str);
 210            $i = &infix:<+>:(int,int)($i.FETCH,1);
 211         }
 212     }
 213 }
 214
 215 my sub print(|$capture) {
 216     my $i = 0;
 217     loop {
 218         if &infix:<==>:(int,int)($i,$capture.elems) {
 219             return;
 220         } else {
 221            $OUT.print($capture.positional($i.FETCH).Str);
 222            $i = &infix:<+>:(int,int)($i.FETCH,1);
 223         }
 224     }
 225 }
 226
 227 my sub not($thing) {
 228     if $thing {
 229         ::False;
 230     } else {
 231         ::True;
 232     }
 233 }
 234 $LexicalPrelude{'&prefix:not'} := &not;
 235 $LexicalPrelude{'&prefix:!'} := &not;
 236
 237 ############## Signatures ##############
 238
 239 my role ReadonlyWrapper {
 240     has $.value;
 241     method FETCH() {
 242         (|$!value);
 243     }
 244     method STORE($value) {
 245         ::Exception.new.throw;
 246     }
 247 }
 248
 249 my role Signature {
 250     has $.params is rw;
 251     method ACCEPTS(\$capture) {
 252         my $i = 0;
 253         my $named = 0;
 254         my $ok = True;
 255         {
 256             map(sub ($param) {
 257                 if $param.ACCEPTS_param($capture,$i,$named) {
 258                 } else {
 259                     ::Exception.new.throw;
 260                 }
 261             },self.params);
 262             CATCH {
 263                 $ok = False;
 264             }
 265         }
 266
 267         if &infix:<==>:(int,int)($i,$capture.elems) {
 268             if &infix:<==>:(int,int)($named,$capture.named_count) {
 269                 $ok;
 270             } else {
 271                 False;
 272             }
 273         } else {
 274             False;
 275         }
 276     }
 277     method BIND(\$capture,$scope) {
 278         my $i = 0;
 279         map(sub ($param) {
 280             $param.BIND($scope,$capture,$i);
 281         },self.params);
 282     }
 283     method BUILDALL() {
 284         self.params = ::Array.new;
 285     }
 286     method compare($other) {
 287         my $i = 0;
 288
 289         my $pos_self = grep(sub ($param) {::Positional.ACCEPTS($param.FETCH)},self.params);
 290
 291         my $pos_other = grep(sub ($param) {::Positional.ACCEPTS($param.FETCH)},$other.params);
 292
 293         if &infix:<==>:(int,int)($pos_self.elems,$pos_other.elems) {
 294         } else {
 295             return 0;
 296         }
 297         loop {
 298             if &infix:<==>:(int,int)($i,$pos_self.elems) {
 299                 return 0;
 300             } else {
 301                 my $cmp = $pos_self[$i.FETCH].compare($pos_other[$i.FETCH]);
 302                 if &infix:<==>:(int,int)($cmp,0) {
 303                 } else {
 304                     return $cmp;
 305                 }
 306                 $i = &infix:<+>:(int,int)($i,1);
 307             }
 308         }
 309     }
 310     method perl() {
 311         ":(" ~ self.params[0].perl ~ "...)";
 312     }
 313 }
 314
 315
 316 my role Param {
 317     has $.variable;
 318     has $.default_value;
 319     has $.type;
 320     method BUILDALL() {
 321         $.type = ::Any.new;
 322     }
 323     method register($sig) {
 324         $sig.params.push((|self));
 325     }
 326 }
 327 my role Positional {
 328     Positional.^compose_role(::Param);
 329     has $.name;
 330     method BIND($scope,$capture,$i is ref) {
 331         if $capture.named($.name.FETCH) {
 332             if self.variable {
 333                 $scope{self.variable.FETCH} := self.wrap($capture.named($.name.FETCH));
 334             }
 335         } elsif &infix:<<<>>:(int,int)($i,$capture.elems) {
 336             if self.variable {
 337                 $scope{self.variable.FETCH} := self.wrap($capture.positional($i.FETCH));
 338             }
 339             $i = &infix:<+>:(int,int)($i.FETCH,1);
 340         } elsif self.default_value {
 341             my $default_value = self.default_value;
 342             if self.variable {
 343                 $scope{self.variable.FETCH} := self.wrap($default_value());
 344             }
 345         } else {
 346             return False;
 347         }
 348         True;
 349     }
 350     method ACCEPTS_param($capture,$i is ref,$named is ref) {
 351         if $capture.named($.name.FETCH) {
 352             $named = &infix:<+>:(int,int)($named.FETCH,1);
 353         } elsif &infix:<<<>>:(int,int)($i,$capture.elems) {
 354             if $.type.ACCEPTS($capture.positional($i.FETCH)) {
 355                 $i = &infix:<+>:(int,int)($i,1);
 356             } else {
 357                 return False;
 358             }
 359         } elsif self.default_value {
 360             return True;
 361         } else {
 362             return False;
 363         }
 364         True;
 365     }
 366     method compare($other) {
 367         if $other.type.ACCEPTS(self.type) {
 368             if self.type.ACCEPTS($other.type) {
 369                 return 0;
 370             } else {
 371                 return &infix:<->:(int,int)(0,1);
 372             }
 373         } else {
 374             if self.type.ACCEPTS($other.type) {
 375                 return 1;
 376             } else {
 377                 return 0;
 378             }
 379         }
 380     }
 381 }
 382 my role RefParam {
 383     RefParam.^compose_role(::Positional);
 384     method wrap($arg) {
 385         $arg;
 386     }
 387 }
 388 my role ReadonlyParam {
 389     ReadonlyParam.^compose_role(::Positional);
 390     method wrap($arg) {
 391         my $wrapper = ReadonlyWrapper.new;
 392         $wrapper.value = $arg;
 393         $wrapper.^!is_container = 1;
 394         $wrapper.FETCH;
 395         (|$wrapper);
 396     }
 397     method perl() {
 398         self.variable
 399     }
 400 }
 401
 402 my role NamedReadonlyParam {
 403     NamedReadonlyParam.^compose_role(::Param);
 404     has $.name;
 405     method BIND($scope,$capture,$i) {
 406         my $arg = $capture.named(self.name.FETCH);
 407         my $wrapper = ReadonlyWrapper.new;
 408         $wrapper.value = $arg;
 409         $wrapper.^!is_container = 1;
 410         $wrapper.FETCH;
 411         $scope{self.variable.FETCH} := (|$wrapper);
 412     }
 413     method ACCEPTS_param($capture,$i is ref,$named is ref) {
 414         if $capture.named($.name.FETCH) {
 415             $named = &infix:<+>:(int,int)($named.FETCH,1);
 416         }
 417         True;
 418     }
 419 }
 420 my role WholeCaptureParam {
 421     has $.name;
 422     WholeCaptureParam.^compose_role(::Param);
 423     method ACCEPTS_param($capture,$i is ref,$named is ref) {
 424         $i = $capture.elems;
 425         $named = $capture.named_count;
 426     }
 427     method BIND($scope,$capture,$i) {
 428         $scope{self.variable.FETCH} = $capture;
 429     }
 430 }
 431 ############## Exception ##############
 432 my role Exception {
 433     method throw() {
 434         my $interpreter = PRIMITIVES::get_interpreter;
 435         my $current = $interpreter.continuation;
 436         loop {
 437             if ($current.back) {
 438                 $current = $current.back;
 439                 if ($current.catch) {
 440                     $current.catch.postcircumfix:<( )>(::capture.new(self),:cc($current.back));
 441                 } else {
 442                 }
 443             } else {
 444                 say "uncaught exception";
 445                 return;
 446             }
 447         }
 448     }
 449 }
 450
 451 ############## Any ##############
 452
 453 my role Any {
 454     method ACCEPTS() {
 455         True;
 456     }
 457 }
 458
 459 ############## Multi ##############
 460
 461 my role Multi {
 462     has $.candidates;
 463     has $.sorted_candidates is rw;
 464
 465     my sub qsort($array) {
 466         if &infix:<==>:(int,int)($array.elems,0) {
 467             ::Array.new;
 468         } else {
 469             my $partition = $array[0].signature;
 470
 471             my $left  = qsort(grep sub ($elem) {&infix:<==>:(int,int)($elem.signature.compare($partition),&infix:<->:(int,int)(0,1))},$array);
 472             my $equal = grep(sub ($elem) {&infix:<==>:(int,int)($elem.signature.compare($partition),0)},$array);
 473             my $right = qsort(grep sub ($elem) {&infix:<==>:(int,int)($elem.signature.compare($partition),1)},$array);
 474
 475             my $result = ::Array.new;
 476             map(sub ($x) {$result.push($x.FETCH)},$left);
 477             map(sub ($x) {$result.push($x.FETCH)},$equal);
 478             map(sub ($x) {$result.push($x.FETCH)},$right);
 479             $result;
 480         }
 481     }
 482     method postcircumfix:<( )>(\$capture, :$cc) {
 483         my sub ACCEPTS($candidate) {
 484             $candidate.signature.ACCEPTS((|$capture));
 485         }
 486         if self.sorted_candidates {
 487         } else {
 488
 489             self.sorted_candidates = qsort(self.candidates);
 490         }
 491
 492         my $candidates = grep &ACCEPTS,self.sorted_candidates;
 493
 494         if &infix:<==>:(int,int)($candidates.elems,1) {
 495             $candidates[0].postcircumfix:<( )>((|$capture), :cc($cc.FETCH));
 496         } elsif &infix:<==>:(int,int)($candidates.elems,0) {
 497             say "signature mismatch failure";
 498            ::Exception.new.throw;
 499            #my $e = ::SignatureMismatchFailure.new();
 500            #$e.multi = self;
 501            #$e.capture = $capture;
 502            #$e.throw;
 503 #
 504         } elsif &infix:<==>:(int,int)($candidates[0].signature.compare($candidates[1].signature),&infix:<->:(int,int)(0,1)) {
 505             $candidates[0].postcircumfix:<( )>((|$capture), :cc($cc.FETCH));
 506         } else {
 507             say "ambiguous dispatch";
 508             say $candidates[0].signature.compare($candidates[1].signature);
 509             ::Exception.new.throw;
 510             #my $e = ::AmbiguousDispatchFailure.new();
 511             #$e.multi = self;
 512             #$e.capture = $capture;
 513             #$e.candidates = $candidates;
 514             #$e.throw;
 515         }
 516     }
 517     method BUILDALL() {
 518         self.candidates = ::Array.new;
 519     }
 520     method get_outer_candidates($name,$scope) {
 521         my $outer = $scope.outer;
 522         loop {
 523             if not($outer) {
 524                 return
 525             }
 526             if $outer.exists((|$name)) {
 527                 my $i = 0;
 528                 my $multi = $outer.lookup((|$name));
 529                 map(sub ($candidate) {self.candidates.push((|$candidate))},$multi.candidates);
 530                 return;
 531             } else {
 532                 if $outer.outer {
 533                     $outer = $outer.outer;
 534                 } else {
 535                     return;
 536                 }
 537             }
 538         }
 539     }
 540 }
 541
 542 ############## fail ##############
 543 my role Failure {
 544     has $.handled;
 545     has $.exception;
 546     method true() {
 547         $.handled = True;
 548         False;
 549     }
 550     method defined() {
 551         $.handled = True;
 552         False;
 553     }
 554     method FETCH() {
 555         self;
 556     }
 557     method throw() {
 558         $.exception.throw;
 559     }
 560     # UNKNOWN_METHOD is a spec def
 561     method UNKNOWN_METHOD($identifier) {
 562         $.exception.throw;
 563     }
 564 }
 565 my role DollarBang {
 566     has @.failures;
 567     method cleanup() {
 568         map(sub ($failure) {
 569             if ($failure.handled) {
 570             } else {
 571                 $failure.throw;
 572             }
 573         },self.failures);
 574     }
 575 }
 576 my sub fail {
 577     my $failure = Failure.new;
 578     $failure.exception = ::Exception.new;
 579     $failure;
 580     my $e = ::ControlExceptionReturn.new();
 581     $e.capture = $failure;
 582     $e.routine = CALLER::<&?ROUTINE>;
 583     $e.throw;
 584 }
 585
 586 ############## ModuleLoader ##############
 587
 588 my role ModuleLoader {
 589     has $.cache;
 590     my $loader = ::MildewSOLoader.new;
 591     method load($module) {
 592         my $filename = self.resolve_filename($module);
 593         if $.cache{$filename.FETCH} {
 594         } else {
 595             $.cache{$filename.FETCH} = $loader.load($filename.FETCH,$LexicalPrelude.FETCH);
 596         }
 597         $.cache{$filename.FETCH};
 598     }
 599     method resolve_filename($module) {
 600         $module ~ '.mildew.so'
 601     }
 602     method BUILDALL() {
 603         $.cache = ::Hash.new;
 604     }
 605 }
 606
 607
 608 ############## Perl5 interop ##############
 609 my knowhow EXTERNAL {
 610     my $p5;
 611     sub use_from_perl5($module) {
 612         unless $p5 {
 613             $p5 := ::P5Interpreter.new;
 614         }
 615         $p5.eval(PRIMITIVES::idconst_concat('use ',$module.FETCH));
 616         $p5.eval(PRIMITIVES::idconst_concat(PRIMITIVES::idconst_concat("'",$module.FETCH),"'"));
 617     }
 618     sub eval_perl5($code) {
 619         unless $p5 {
 620             $p5 := ::P5Interpreter.new;
 621         }
 622         $p5.eval($code.FETCH.FETCH);
 623     }
 624 }
 625
 626 ############## int ##############
 627 no adhoc-signatures;
 628
 629 my role int {
 630     method ACCEPTS($thing) {
 631         PRIMITIVES::ritest((|$thing),PRIMITIVES::SMOP_RI(2));
 632     }
 633 }
 634
 635 my multi infix:<==>(int $a,int $b) {
 636     &infix:<==>:(int,int)($a,$b);
 637 }
 638
 639 my multi infix:<!=>(int $a,int $b) {
 640     if &infix:<==>:(int,int)($a,$b) {
 641         False;
 642     } else {
 643         True;
 644     }
 645 }
 646 my multi infix:<+>(int $a,int $b) {
 647     &infix:<+>:(int,int)($a,$b);
 648 }
 649 my multi infix:<->(int $a,int $b) {
 650     &infix:<->:(int,int)($a,$b);
 651 }
 652 my multi prefix:<->(int $a) {
 653     &infix:<->:(int,int)(0,$a);
 654 }
 655
 656 #HACK we don't support such fancy multi names so we bind to $LexicalPrelude
 657 {
 658 #TODO fix multi infix:<\<> {...}
 659 my multi less(int $a,int $b) {
 660     &infix:<<<>>:(int,int)($a,$b);
 661 }
 662 my multi more(int $a,int $b) {
 663     if &infix:<<<>>:(int,int)($a,$b) {
 664         False;
 665     } elsif &infix:<==>:(int,int)($a,$b) {
 666         False;
 667     } else {
 668         True;
 669     }
 670 }
 671 #TODO fix multi infix:<\<> {...}
 672 my multi less_or_equal(int $a,int $b) {
 673     &infix:<<<>>:(int,int)($a,$b) || &infix:<==>:(int,int)($a,$b);
 674 }
 675 my multi more_or_equal(int $a,int $b) {
 676     not(&infix:<<<>>:(int,int)($a,$b));
 677 }
 678
 679 $LexicalPrelude{'&infix:<='} := &less_or_equal;
 680 $LexicalPrelude{'&infix:>='} := &more_or_equal;
 681 $LexicalPrelude{'&infix:<'} := &less;
 682 $LexicalPrelude{'&infix:>'} := &more;
 683
 684 }
 685
 686 {YOU_ARE_HERE};