File Coverage

blib/lib/B/TypeCheck.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package B::TypeCheck;
2              
3 1     1   13153 use strict;
  1         3  
  1         42  
4 1     1   7 use B;
  1         2  
  1         54  
5 1     1   479 use B::Asmdata qw(@specialsv_name);
  0            
  0            
6             use Carp;
7             use Scalar::Util qw(blessed);
8             use English;
9             require 'opnames.ph';
10              
11             # Base of type checking
12             use Devel::TypeCheck::Type;
13             use Devel::TypeCheck::Util;
14              
15             # Include branch types
16             use Devel::TypeCheck::Type::Mu;
17             use Devel::TypeCheck::Type::Eta;
18             use Devel::TypeCheck::Type::Kappa;
19             use Devel::TypeCheck::Type::Nu;
20             use Devel::TypeCheck::Type::Rho;
21             use Devel::TypeCheck::Type::Omicron;
22             use Devel::TypeCheck::Type::Chi;
23             use Devel::TypeCheck::Type::Upsilon;
24             use Devel::TypeCheck::Type::Zeta;
25              
26             # Include terminal types
27             use Devel::TypeCheck::Type::Io;
28             use Devel::TypeCheck::Type::Pv;
29             use Devel::TypeCheck::Type::Iv;
30             use Devel::TypeCheck::Type::Dv;
31              
32             # Type variables
33             use Devel::TypeCheck::Type::Var;
34              
35             # The environment, GAMMA
36             use Devel::TypeCheck::Environment;
37             use Devel::TypeCheck::Glob2type;
38             use Devel::TypeCheck::Pad2type;
39              
40             # Names of CVs to type check
41             our @cvnames;
42             our @modules;
43              
44             # Set of CVs to type check
45             our %roots;
46              
47             # Whether or not to check the main body
48             our $mainRoot = FALSE;
49             our $all = FALSE;
50             our $ugly = FALSE;
51             our $continue = FALSE;
52              
53             # Whether logical operations require an Upsilon (TRUE) or a Nu (FALSE)
54             our $relax = FALSE;
55             our $inferLogop = undef;
56              
57             # Symbol to type lookup for global symbols
58             our $glob2type;
59              
60             # Position information for error reporting
61             our $globalLine = "";
62             our $globalFile = "";
63              
64             # For output
65             our $depth = 0;
66             our $depthIncrement = 4;
67             our $opcodes = 0;
68              
69             our @list;
70              
71             # Required function for O(3pm) use. Adapted from B::Concise
72             sub compile {
73             my $setModule = FALSE;
74             my $setCvname = FALSE;
75              
76             while (@_) {
77             my $o = shift(@_);
78            
79             if ($o eq "-verbose") {
80             setVerbose(TRUE);
81             } elsif ($o eq "-continue") {
82             $continue = TRUE;
83             } elsif ($o eq "-ugly") {
84             $ugly = TRUE;
85             } elsif ($o eq "-main") {
86             $mainRoot = TRUE;
87             } elsif ($o eq "-relax") {
88             $relax = TRUE;
89             } elsif ($o eq "-all") {
90             $continue = TRUE;
91             $all = TRUE;
92             } elsif ($o eq "-module") {
93             $setModule = TRUE;
94             my $m = shift(@_);
95             if (defined($m)) {
96             push(@modules, $m);
97             } else {
98             warn "Null argument to -module option";
99             }
100             } elsif ($o !~ /^-/) {
101             $setCvname = TRUE;
102             push(@cvnames, $o);
103             } else {
104             warn "Option $o unrecognized";
105             }
106              
107             }
108            
109             if (!($mainRoot || $all || $setModule || $setCvname)) {
110             warn "Defaulting to -main\n";
111             $mainRoot = TRUE;
112             }
113              
114             return \&callback;
115             }
116              
117             # Fully qualified terminal types
118             our $IO = Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Io->new());
119             our $PV = Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Upsilon->new(Devel::TypeCheck::Type::Pv->new())));
120             our $IV = Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Upsilon->new(Devel::TypeCheck::Type::Nu->new(Devel::TypeCheck::Type::Iv->new()))));
121             our $DV = Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Upsilon->new(Devel::TypeCheck::Type::Nu->new(Devel::TypeCheck::Type::Dv->new()))));
122              
123             # Special value, unique in references, for use in the *Proto functions
124             our $ANY = \0;
125              
126             # Typical tuple returns from the get*by* operators
127             sub GSBY {
128             my ($env) = @_;
129             return $env->genOmicronTuple($PV, $PV, $IV, $PV);
130             }
131              
132             sub GPW {
133             my ($env) = @_;
134             return $env->genOmicronTuple($PV, $PV, $IV, $IV, $IV, $PV, $PV, $PV, $PV, $IV);
135             }
136              
137             sub GGR {
138             my ($env) = @_;
139             return $env->genOmicronTuple($PV, $PV, $IV, $PV);
140             }
141              
142             sub GHBY {
143             my ($env) = @_;
144             return $env->genOmicronTuple($PV, $PV, $IV, $IV, $env->genOmicron($IV));
145             }
146              
147             sub GNBY {
148             my ($env) = @_;
149             return $env->genOmicronTuple($PV, $PV, $IV, $IV);
150             }
151              
152             sub GPBY {
153             my ($env) = @_;
154             return $env->genOmicronTuple($PV, $PV, $IV);
155             }
156              
157             # Sane wrapper around raw unify
158             sub myUnify {
159             my ($env, $var, @vars) = @_;
160              
161             if (defined($var)) {
162            
163             my $acc = $var;
164             for my $i (@vars) {
165             if (!defined($i)) {
166             confess("Tried to unify an undefined value");
167             }
168              
169             my $oldacc = $acc;
170              
171             if ($acc->is(Devel::TypeCheck::Type::H()) && $i->is(Devel::TypeCheck::Type::P())) {
172             verbose(" " x $depth, " Enacting MH ~= MKPMH rule");
173             $i = $i->deref;
174             }
175              
176             if ($i->is(Devel::TypeCheck::Type::H()) && $acc->is(Devel::TypeCheck::Type::P())) {
177             verbose(" " x $depth, " Enacting MH ~= MKPMH rule");
178             $acc = $acc->deref;
179             }
180              
181             verbose_(" " x $depth, " unify(", myPrint($oldacc, $env), ", ", myPrint($i, $env), ") = ");
182             $acc = $env->unify($acc, $i);
183             verbose($acc?myPrint($acc, $env):"FAIL");
184              
185             if (!$acc) {
186             my $msg = ("TYPE ERROR: Could not unify " . myPrint($env->find($oldacc), $env) . " and " . myPrint($env->find($i), $env) .
187             " at line " . $globalLine . ", file " . $globalFile . "\n");
188             if (getVerbose()) {
189             confess($msg);
190             } else {
191             die($msg);
192             }
193             }
194             }
195              
196             return $env->find($acc);
197             } else {
198             return undef;
199             }
200             }
201              
202             # Sane wrapper around print
203             sub myPrint {
204             my ($t, $env) = @_;
205              
206             if (!$ugly) {
207             return $t->pretty($env);
208             } else {
209             return $t->str($env);
210             }
211             }
212              
213             sub smash {
214             my ($r, $env) = @_;
215             my @results = @$r;
216              
217             my $result;
218              
219             if ($#results == 0) {
220             $results[0] = $env->find($results[0]);
221             }
222              
223             if ($#results == 0 && $results[0]->is(Devel::TypeCheck::Type::O())) {
224             # There's a single array in the results. Just pass it on.
225             $result = $results[0];
226             } elsif ($#results == 0 && $results[0]->isa("Devel::TypeCheck::Type::Var")) {
227             # There's a single array in the results. Just pass it on.
228             myUnify($env, $results[0], $env->genOmicron());
229             $result = $results[0];
230             } else {
231             # Mash everything in @results together and hope for the best.
232             $result = $env->genOmicron();
233             foreach my $i (@results) {
234             my $oldresult = $result;
235             $result = $result->append($i, $env);
236             die("TYPE ERROR: failure to unify " . myPrint($i, $env) . " with " . myPrint($oldresult, $env) .
237             " at line " . $globalLine . ", file " . $globalFile . "\n") if (!defined($result));
238             }
239             }
240              
241             return $result;
242             }
243              
244             # Type the children of a given operator
245             sub typeOpChildren {
246             my ($op, $pad2type, $env, $cv, $context) = @_;
247              
248             if (!defined($context)) {
249             $context = SCALAR();
250             }
251              
252             # If the operator has kids, the type of the NULL op is the type of the last kid
253             # Otherwise, this operator is untyped
254            
255             my $result;
256             my @returns;
257             my @results;
258            
259             if ($op->flags & B::OPf_KIDS()) {
260             for (my $kid = $op->first(); $$kid; $kid = $kid->sibling()) {
261             # Type the kid
262             my ($s, $r) = typeOp($kid, $pad2type, $env, $cv, $context);
263            
264             if (defined($s)) {
265             push(@results, $s);
266             $result = $s;
267             }
268            
269             # Set up unify of return values from down in the tree
270             if (defined($r)) {
271             push(@returns, $r);
272             }
273             }
274             }
275            
276             if ($context == LIST()) {
277             $result = smash(\@results, $env);
278             }
279              
280             return ($result, myUnify($env, @returns));
281             }
282              
283             sub typeOpChildren_ {
284             my ($op, $pad2type, $env, $cv, $context) = @_;
285              
286             if (!defined($context)) {
287             $context = SCALAR();
288             }
289              
290             # If the operator has kids, the type of the NULL op is the type of the last kid
291             # Otherwise, this operator is untyped
292            
293             my @results;
294             my @returns;
295            
296             if ($op->flags & B::OPf_KIDS()) {
297             for (my $kid = $op->first(); $$kid; $kid = $kid->sibling()) {
298             # Type the kid
299             my ($s, $r) = typeOp($kid, $pad2type, $env, $cv, $context);
300            
301             # Overwrite the result
302             push(@results, $s) if (defined($s));
303            
304             # Set up unify of return values from down in the tree
305             push(@returns, $r) if (defined($r));
306             }
307             }
308            
309             my $result;
310             if ($context == LIST()) {
311             $result = smash(\@results, $env);
312             } else {
313             $result = myUnify($env, @results);
314             }
315              
316             return ($result, myUnify($env, @returns));
317             }
318              
319             # Type the children of a given operator
320             sub typeOpChildrenSkip {
321             my ($op, $pad2type, $env, $cv, $context, $skip) = @_;
322              
323             if (!defined($context)) {
324             $context = SCALAR();
325             }
326              
327             # If the operator has kids, the type of the NULL op is the type of the last kid
328             # Otherwise, this operator is untyped
329            
330             my $result;
331             my @returns;
332             my @results;
333            
334             if ($op->flags & B::OPf_KIDS()) {
335             my $start = $op->first();
336             while ($skip != 0) {
337             $start = $start->sibling();
338             $skip--;
339             }
340              
341             for (my $kid = $start ; $$kid; $kid = $kid->sibling()) {
342             # Type the kid
343             my ($s, $r) = typeOp($kid, $pad2type, $env, $cv, $context);
344            
345             if (defined($s)) {
346             push(@results, $s);
347             $result = $s;
348             }
349            
350             # Set up unify of return values from down in the tree
351             if (defined($r)) {
352             push(@returns, $r);
353             }
354             }
355             }
356            
357             if ($context == LIST()) {
358             $result = smash(\@results, $env);
359             }
360              
361             return ($result, myUnify($env, @returns));
362             }
363              
364             sub typeRest {
365             my ($kid, $pad2type, $env, $cv) = @_;
366              
367             my @rets;
368              
369             for ( ; $$kid; $kid = $kid->sibling()) {
370             my ($t, $r) = typeOp($kid, $pad2type, $env, $cv, SCALAR());
371             push(@rets, $r) if ($r);
372             }
373              
374             return myUnify($env, @rets);
375             }
376              
377             sub typeProto {
378             my ($op, $pad2type, $env, $cv, @proto) = @_;
379            
380             my $index = 0;
381             my @rets;
382             if ($op->flags & B::OPf_KIDS()) {
383             my $type = $op->first()->type();
384             if ($type != OP_PUSHMARK() &&
385             $type != OP_NULL()) {
386             die("Operator is not a function-call type. Cannot use typeProto()");
387             }
388            
389             for (my $kid = $op->first()->sibling(); $$kid; $kid = $kid->sibling()) {
390             my ($t, $r);
391             if (($proto[$index]) == $ANY) {
392             $r = typeRest($kid, $pad2type, $env, $cv);
393             push(@rets, $r) if ($r);
394             last;
395             } elsif ($proto[$index]->is(Devel::TypeCheck::Type::O())) {
396             ($t, $r) = typeOp($kid, $pad2type, $env, $cv, LIST());
397             } else {
398             ($t, $r) = typeOp($kid, $pad2type, $env, $cv, SCALAR());
399             }
400             myUnify($env, $t, $proto[$index]);
401             push(@rets, $r) if ($r);
402             $index++;
403             die ("Too many arguments") if ($index > ($#proto + 1));
404             }
405             }
406              
407             return (myUnify($env, @rets), ($#proto + 1) - $index);
408             }
409              
410             sub typeProtoOp {
411             my ($op, $pad2type, $env, $cv, @proto) = @_;
412            
413             my $index = 0;
414             my @rets;
415             if ($op->flags & B::OPf_KIDS()) {
416             for (my $kid = $op->first(); $$kid; $kid = $kid->sibling()) {
417             #next if ($kid->type() == OP_NULL());
418              
419             my ($t, $r);
420             if (($proto[$index]) == $ANY) {
421             $r = typeRest($kid, $pad2type, $env, $cv);
422             push(@rets, $r) if ($r);
423             last;
424             } elsif ($proto[$index]->is(Devel::TypeCheck::Type::O())) {
425             ($t, $r) = typeOp($kid, $pad2type, $env, $cv, LIST());
426             } else {
427             ($t, $r) = typeOp($kid, $pad2type, $env, $cv, SCALAR());
428             }
429             myUnify($env, $t, $proto[$index]);
430             push(@rets, $r) if ($r);
431             $index++;
432             die ("Too many arguments") if ($index > ($#proto + 1));
433             }
434             }
435              
436             return (myUnify($env, @rets), ($#proto + 1) - $index);
437             }
438              
439             # Perl conflates the use of rv2XX operators for references, globs, and
440             # references to globs. This does it's best to disambiguate that.
441             sub rvConflate {
442             my ($env, $ref, $XX) = @_;
443              
444             $ref = $env->find($ref);
445              
446             if (!defined($ref)){
447             confess("Undefined parameter \$ref");
448             }
449              
450             # If $ref is a VAR, unify $ref and RHO($XX), and be done with the
451             # sordid business
452             if ($ref->type() == Devel::TypeCheck::Type::VAR()) {
453             myUnify($env, $ref, $env->genRho($XX));
454             return $XX;
455             }
456              
457             # If it's a glob
458             if ($ref->is(Devel::TypeCheck::Type::H())) {
459             RVC_ISETA:
460              
461             # If we're looking for the KAPPA part of the glob
462             if ($XX->is(Devel::TypeCheck::Type::K())) {
463             # Project the K from the H
464             $ref = $ref->derefKappa;
465             return $ref;
466             } elsif ($XX->is(Devel::TypeCheck::Type::O())) {
467             $ref = $ref->derefOmicron;
468             return $ref;
469             } elsif ($XX->is(Devel::TypeCheck::Type::X())) {
470             $ref = $ref->derefChi;
471             return $ref;
472             } elsif ($XX->is(Devel::TypeCheck::Type::Z())) {
473             $ref = $ref->derefZeta();
474             } else {
475             # $XX is the type we want, after all
476             return($XX);
477             }
478              
479             # Unify the newly dereferenced ref with the desired type
480             return myUnify($env, $ref, $XX);
481              
482             } elsif ($ref->is(Devel::TypeCheck::Type::K()) &&
483             $ref->is(Devel::TypeCheck::Type::VAR())) {
484              
485             # Garbage garbage garbage
486             myUnify($env, $ref, $env->genRho($env->fresh));
487             goto RVC_ISRHO;
488              
489             # If it's a reference
490             } elsif ($ref->is(Devel::TypeCheck::Type::P())) {
491             RVC_ISRHO:
492             $ref = $ref->deref;
493              
494             # Stupid hack alert: these operators do the same thing if $ref
495             # is a glob or a ref to a glob
496             goto RVC_ISETA if ($ref->is(Devel::TypeCheck::Type::H()));
497              
498             # Make sure whatever we dereferenced matches the type we want
499             myUnify($env, $ref, $XX);
500              
501             return($XX);
502             } else {
503             confess("Could not dereference through rvConflate: " . myPrint($ref, $env));
504             return undef;
505             }
506             }
507              
508             sub getPvConst {
509             my ($op, $cv) = @_;
510              
511             my $sv = $op->sv;
512              
513             RETRY_PVCONST:
514             my $class = B::class($sv);
515              
516             if ($class eq "PV") {
517             return $sv->PV;
518             } elsif ($class eq "SPECIAL") {
519             $sv = (($cv->PADLIST()->ARRAY())[1]->ARRAY)[$op->targ];
520             goto RETRY_PVCONST;
521             } else {
522             die("Can't get PV constant out of $class");
523             }
524              
525             }
526              
527             sub getIvConst {
528             my ($op, $cv) = @_;
529              
530             my $sv = $op->sv;
531              
532             RETRY_IVCONST:
533             my $class = B::class($sv);
534              
535             if ($class eq "IV") {
536             return $sv->int_value;
537             } elsif ($class eq "SPECIAL") {
538             $sv = (($cv->PADLIST()->ARRAY())[1]->ARRAY)[$op->targ];
539             goto RETRY_IVCONST;
540             } else {
541             die("Can't get IV constant out of $class");
542             }
543              
544             }
545              
546             sub getUpsilonConst {
547             my ($op, $cv) = @_;
548              
549             my $sv = $op->sv;
550              
551             RETRY_YCONST:
552             my $class = B::class($sv);
553              
554             if ($class eq "IV") {
555             return $sv->int_value;
556             } elsif ($class eq "PV") {
557             return $sv->PV;
558             } elsif ($class eq "NV") {
559             return $sv->NV;
560             } elsif ($class eq "SPECIAL") {
561             $sv = (($cv->PADLIST()->ARRAY())[1]->ARRAY)[$op->targ];
562             goto RETRY_YCONST;
563             } else {
564             die("Can't get Y constant out of $class");
565             }
566             }
567              
568             sub constructConst {
569             my ($sv, $cv, $op, $env) = @_;
570              
571             RETRY_CONST:
572             my $class = B::class($sv);
573              
574             if ($class eq "PV" || $class eq "BM") {
575             # BM seems to be the "substring" constant type. BM probably
576             # stands for Boyer-Moore, but it's not actually documented
577             # anywhere that I can find.
578             return $PV;
579              
580             } elsif ($class eq "IV") {
581             return $IV;
582              
583             } elsif ($class eq "NV") {
584             # Constants of type NV are always doubles
585             return $DV;
586              
587             } elsif ($class eq "RV") {
588             return $env->genRho(constructConst($sv->RV, $cv, $op, $env));
589              
590             } elsif ($class eq "PVMG") {
591             # We have no idea how this might be used, so punt, but make
592             # sure whatever uses it, uses it consistently.
593             verbose("Found magic, ignoring");
594             return $env->fresh();
595              
596             } elsif ($class eq "PVNV") {
597              
598             return $env->freshNu();
599            
600             } elsif ($class eq "SPECIAL") {
601             $sv = (($cv->PADLIST()->ARRAY())[1]->ARRAY)[$op->targ];
602             goto RETRY_CONST;
603              
604             } else {
605             confess("Cannot construct a type for referent type $class");
606             }
607             }
608              
609             # For comparing context
610             sub LIST { return 0 };
611             sub SCALAR { return 1 };
612              
613             sub contextPick {
614             my ($context, $list, $scalar) = @_;
615             if ($context == LIST()) {
616             return $list;
617             } else {
618             return $scalar;
619             }
620             }
621              
622             sub coerce {
623             my ($env, $result, $context) = @_;
624              
625             # If we can prove that the return is a 1-tuple and the context is scalar, promote to scalar
626             if ($context == SCALAR() &&
627             defined($result) &&
628             $result->is(Devel::TypeCheck::Type::O()) &&
629             $result->homogeneous == FALSE() &&
630             $result->arity == 1) {
631             $result = $result->derefIndex(0, $env);
632             }
633              
634             return $result;
635             }
636              
637             # This assumes that all children of $op have already been typed to IV
638             sub extractConstList {
639             my ($op, $cv) = @_;
640             my @ret;
641              
642             for (my $kid = $op->first(); $$kid; $kid = $kid->sibling()) {
643             next if ($kid->type() == OP_PUSHMARK());
644              
645             if ($kid->type() != OP_CONST()) {
646             return undef;
647             }
648              
649             push(@ret, getIvConst($kid, $cv));
650             }
651              
652             return(\@ret);
653             }
654              
655             # Invoked when the operator might be an operation-assignment operator (like +=)
656             sub opAssign {
657             my ($env, $op, $f, $a) = @_;
658              
659             # This is also an assignment operator
660             if (($op->first()->flags & B::OPf_REF()) &&
661             ($op->first()->flags & B::OPf_MOD())) {
662             myUnify($env, $a, $f);
663             }
664             }
665              
666             sub arithmetic {
667             my ($env, $ft, $lt) = @_;
668             # Bind both to an incomplete Nu value.
669             $ft = myUnify($env, $ft, $env->freshNu);
670             $lt = myUnify($env, $lt, $env->freshNu);
671              
672             if ($ft->is(Devel::TypeCheck::Type::DV()) ||
673             $lt->is(Devel::TypeCheck::Type::DV())) {
674              
675             # Bind up incomplete types to whatever we're going to
676             # return. No more than one is incomplete
677             if (! $ft->complete) {
678             # $ft is incomplete Nu
679             myUnify($env, $ft, $DV);
680             } elsif (! $lt->complete) {
681             # $lt is incomplete Nu
682             myUnify($env, $lt, $DV);
683             }
684              
685             return $DV;
686             } elsif ($ft->is(Devel::TypeCheck::Type::IV()) ||
687             $lt->is(Devel::TypeCheck::Type::IV())) {
688              
689             # Bind up incomplete types to whatever we're going to
690             # return. No more than one is incomplete
691             if (! $ft->complete) {
692             # $ft is incomplete Nu
693             myUnify($env, $ft, $IV);
694             } elsif (! $lt->complete) {
695             # $lt is incomplete Nu
696             myUnify($env, $lt, $IV);
697             }
698              
699             return $IV;
700             } else {
701             return myUnify($env, $ft, $lt);
702             }
703             }
704              
705             sub SVOP2SV {
706             my ($op, $cv) = @_;
707              
708             if (! $op->isa("B::SVOP")) {
709             die "operator is not a SVOP";
710             }
711              
712             my $sv = $op->sv;
713             my $class = B::class($sv);
714              
715             if ($class eq "SPECIAL") {
716             $sv = (($cv->PADLIST()->ARRAY())[1]->ARRAY)[$op->targ];
717             }
718              
719             return ${$sv->object_2svref()};
720             }
721              
722             sub inferNu {
723             my $env = $_[0];
724             return $env->freshNu();
725             }
726              
727             sub inferUpsilon {
728             my $env = $_[0];
729             return $env->freshUpsilon();
730             }
731              
732             sub typeOp {
733             my ($op, $pad2type, $env, $cv, $context) = @_;
734              
735             $opcodes++;
736              
737             $depth += $depthIncrement;
738              
739             verbose(" " x $depth, ($context)?"S":"L", ":", $op->name, " {");
740              
741             my ($realResult, $realReturn);
742              
743             confess("op is null") if (!defined($op));
744             confess("pad2type is null") if (!defined($pad2type));
745             confess("env is null") if (!defined($env));
746             confess("cv is null") if (!defined($cv));
747             confess("context is null") if (!defined($context));
748              
749             my $t = $op->type();
750              
751             RETRY:
752             if ($t == OP_LIST() || # This one almost always gets optimized out
753             $t == OP_LEAVELOOP()||
754             $t == OP_ENTERTRY() ||
755             $t == OP_ENTERLOOP()||
756             $t == OP_ENTER() ||
757             $t == OP_LINESEQ() ||
758             $t == OP_SCOPE()) {
759              
760             my $c = $context;
761             $c = LIST() if ($t == OP_LIST() && $op->first()->type() == OP_PUSHMARK());
762              
763             ($realResult, $realReturn) = typeOpChildren($op, $pad2type, $env, $cv, $c);
764              
765             $realResult = coerce($env, $realResult, $context);
766              
767             } elsif ($t == OP_NULL()) {
768              
769             no strict qw(subs);
770             if ($op->targ == OP_LIST()) {
771             # Hack for ex-list
772             $t = $op->targ;
773             goto RETRY;
774             } elsif ($op->can("first") && $op->first()->can("sibling") && ($op->first()->sibling()->can("type")) && ($op->first()->sibling()->type() == OP_READLINE())) {
775             # Hack for readline. Act like this is an sassign from the readline to the first argument
776             my ($t0, $r0) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
777             my ($t1, $r1) = typeOp($op->first()->sibling(), $pad2type, $env, $cv, SCALAR());
778              
779             ($realResult, $realReturn) = (myUnify($env, $t0, $t1), myUnify($env, $r0, $r1));
780             } else {
781             ($realResult, $realReturn) = typeOpChildren($op, $pad2type, $env, $cv, SCALAR());
782             }
783              
784             } elsif ($t == OP_LEAVESUB()) {
785              
786             ($realResult, $realReturn) = typeOpChildren($op, $pad2type, $env, $cv, $context);
787              
788             if (defined($realReturn)) {
789             if (defined($realResult)) {
790             # If the result is a plain scalar, promote it to be a 1-tuple of that scalar
791             if ($realResult->is(Devel::TypeCheck::Type::K())) {
792             $realResult = $env->genOmicronTuple($realResult);
793             }
794              
795             # Unify the return value (which is guaranteed to be an Omicron of some sort) with the result value.
796             $realReturn = myUnify($env, $realResult, $realReturn);
797              
798             my $tmpResult = coerce($env, $realResult, $context);
799             if ($tmpResult != $realResult) {
800             $realReturn = $realResult = $tmpResult;
801             }
802             }
803             } else {
804             if (defined($realResult)) {
805             $realReturn = $realResult;
806             }
807             }
808              
809             } elsif ($t == OP_LEAVE()) {
810            
811             ($realResult, $realReturn) = typeOpChildren($op, $pad2type, $env, $cv, $context);
812              
813             $realResult = coerce($env, $realResult, $context);
814             } elsif ($t == OP_LEAVETRY()) {
815              
816             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv, $context);
817             if (!$r) {
818             ($realResult, $realReturn) = ($t, undef);
819             } else {
820             ($realResult, $realReturn) = (myUnify($env, $t, $r), undef);
821             }
822              
823             } elsif ($t == OP_ENTERSUB()) {
824              
825             my @params;
826             my @rets;
827             my $root = $op;
828             my $first = undef;
829             my $last = undef;
830             if ($root->first()->type() == OP_NULL()) {
831             $root = $root->first();
832             }
833             if ($root->flags & B::OPf_KIDS()) {
834             for (my $kid = $root->first(); $$kid; $kid = $kid->sibling()) {
835             if ($kid->type() != OP_PUSHMARK()) {
836             $first = $kid if (!defined($first));
837             my ($s, $r) = typeOp($kid, $pad2type, $env, $cv, $context);
838              
839             push(@params, $s) if (defined($s));
840             push(@rets, $r) if (defined($r));
841             }
842             $last = $kid;
843             }
844             }
845              
846             # The function is always the last operator to the ENTERSUB operand
847             my $fnArg = pop(@params);
848              
849             # Null-reduce
850             while ($last->type() == OP_NULL()) {
851             $last = $last->first();
852             }
853              
854             # Figure out what kind of function call this is.
855             my $name = undef;
856             if ($last->type() == OP_GV()) {
857             my $class = B::class($last);
858              
859             my $gv;
860             if ($class eq "PADOP") {
861             $gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$last->padix];
862             } elsif ($class eq "SVOP") {
863             $gv = $op->gv;
864             }
865              
866             $name = $gv->STASH->NAME . "::" . $gv->NAME;
867             } elsif ($last->type() == OP_METHOD_NAMED()) {
868             if ($first->type() == OP_CONST()) {
869             my $ft = constructConst($first->sv, $cv, $first, $env);
870            
871             if ($ft == $PV) {
872             $name = SVOP2SV($first, $cv) . "::" . SVOP2SV($last, $cv);
873             } else {
874             die "OP_METHOD_NAMED used with a non-PV name";
875             }
876             } else {
877             verbose "OP_METHOD_NAMED used with a non-constant name";
878             }
879             } elsif ($last->type() == OP_METHOD()) {
880             die "can't deal with references to methods yet";
881             }
882            
883             if (defined($name)) {
884             verbose(" " x $depth, "function name is $name");
885             }
886              
887             # Use rvConflate to extract CV from a ref to a GV or a ref to a CV
888              
889             my $returnType;
890              
891             $returnType = $env->fresh;
892              
893             my $fnType = rvConflate($env, $fnArg, $env->genZeta(smash(\@params, $env), $returnType));
894            
895             ($realResult, $realReturn) = ($fnType->derefReturn, myUnify($env, @rets));
896            
897             } elsif ($t == OP_ENTEREVAL() ||
898             $t == OP_DOFILE()) {
899            
900             # Make sure we're passing it a PV
901             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
902             myUnify($env, $t, $PV);
903              
904             # Generate a new type variable, since the return might be anything
905             ($realResult, $realReturn) = ($env->fresh(), $t);
906              
907             } elsif ($t == OP_ENTERITER()) {
908              
909             # The first operand is a dead pushmark, so just ignore it
910              
911             # The second operand is the list
912             my ($t, $r) = typeOp($op->first()->sibling(), $pad2type, $env, $cv, LIST());
913              
914             # Promote $t to a homogeneous list
915             myUnify($env, $t, $env->genOmicron($env->freshKappa));
916              
917             # If the third argument is there, then it's a glob reference
918             # to the variable that we're iterating over.
919             my $targ = $op->targ;
920             if ($targ) {
921             # No third argument, iterator is a lexically scoped variable
922             my $pad = $pad2type->get($targ, $env);
923             myUnify($env, $pad, $t->derefHomogeneous);
924             } else {
925             my ($t0, $r0) = typeOp($op->first()->sibling()->sibling(), $pad2type, $env, $cv, SCALAR());
926            
927             # project the scalar for the reference
928              
929             $t0 = $t0->derefKappa();
930              
931             myUnify($env, $t0, $t->derefHomogeneous);
932             }
933              
934             ($realResult, $realReturn) = ($t->derefHomogeneous, undef);
935              
936             } elsif ($t == OP_ITER()) {
937            
938             ($realResult, $realReturn) = ($env->freshKappa, undef);
939              
940             } elsif ($t == OP_STUB()) {
941              
942             # YYY It puts a new SV on the stack in pp.c in a scalar
943             # context. I guess it gets a null array in a list context.
944             ($realResult, $realReturn) = (contextPick($context, $env->genOmicron(), $env->fresh), undef);
945              
946             } elsif ($t == OP_PRINT()) {
947              
948             # The children are the parameters of the operator
949             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv);
950              
951             ($realResult, $realReturn) = ($IV, $r);
952            
953             } elsif ($t == OP_INT()) {
954              
955             # Can be used as a coercion from DV to IV, so accept Nu
956             my ($ot, $or) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
957             myUnify($env, $ot, $env->freshNu);
958             ($realResult, $realReturn) = ($IV, $or);
959              
960             } elsif ($t == OP_PREINC() ||
961             $t == OP_PREDEC() ||
962             $t == OP_POSTINC()||
963             $t == OP_POSTDEC()) {
964             # Unary number operators
965              
966             my ($ot, $or) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
967             myUnify($env, $ot, $env->freshNu);
968             ($realResult, $realReturn) = ($ot, $or);
969              
970             } elsif ($t == OP_NOT()) {
971              
972             my ($ot, $or) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
973             myUnify($env, $ot, &$inferLogop($env));
974             ($realResult, $realReturn) = ($IV, $or);
975            
976             } elsif ($t == OP_NEGATE() ||
977             $t == OP_I_NEGATE() ||
978             $t == OP_I_PREINC() ||
979             $t == OP_I_PREDEC() ||
980             $t == OP_I_POSTINC()||
981             $t == OP_I_POSTDEC()||
982             $t == OP_COMPLEMENT()) {
983             # Unary number operators that are strict in IV
984              
985             my ($ot, $or) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
986             myUnify($env, $ot, $IV);
987             ($realResult, $realReturn) = ($IV, $or);
988              
989             } elsif ($t == OP_RAND()) {
990             # Operand is optional
991            
992             my $class = B::class($op);
993              
994             if ($class eq "UNOP") {
995             my ($ot, $or) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
996             myUnify($env, $ot, $env->freshNu)
997             }
998              
999             ($realResult, $realReturn) = ($DV, undef);
1000              
1001             } elsif ($t == OP_EQ() ||
1002             $t == OP_NE()) {
1003              
1004             # Have to be able to compare pointers
1005             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1006             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1007              
1008             if ((defined($ft) && $ft->is(Devel::TypeCheck::Type::PV())) || (defined($lt) && $lt->is(Devel::TypeCheck::Type::PV()))) {
1009             die("TYPE ERROR: Cannot use numeric comparison (== or !=) to compare strings");
1010             }
1011              
1012             ($realResult, $realReturn) = (myUnify($env, $ft, $lt), myUnify($env, $fr, $lr));
1013              
1014             } elsif ($t == OP_ADD() ||
1015             $t == OP_SUBTRACT() ||
1016             $t == OP_MULTIPLY() ||
1017             $t == OP_MODULO() ||
1018             $t == OP_LT() ||
1019             $t == OP_GT() ||
1020             $t == OP_LE() ||
1021             $t == OP_GE() ||
1022             $t == OP_NCMP() ||
1023             $t == OP_POW()) {
1024             # Binary number operators
1025              
1026             # Both sides should be unified with Nu, and resulting
1027             # expression type is Nu.
1028              
1029             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1030             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1031            
1032             ($realResult, $realReturn) = (arithmetic($env, $ft, $lt),
1033             myUnify($env, $fr, $lr));
1034              
1035             if ($t == OP_ADD() ||
1036             $t == OP_SUBTRACT() ||
1037             $t == OP_MULTIPLY() ||
1038             $t == OP_MODULO() ||
1039             $t == OP_POW()) {
1040             opAssign($env, $op, $ft, $realResult);
1041             }
1042              
1043             } elsif ($t == OP_DIVIDE()) {
1044              
1045             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1046             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1047            
1048             # Bind both to an incomplete Nu value.
1049             $ft = myUnify($env, $ft, $env->freshNu);
1050             $lt = myUnify($env, $lt, $env->freshNu);
1051              
1052             ($realResult, $realReturn) = ($DV, myUnify($env, $fr, $lr));
1053              
1054             opAssign($env, $op, $ft, $realResult);
1055              
1056             } elsif ($t == OP_ATAN2() ||
1057             $t == OP_SIN() ||
1058             $t == OP_COS() ||
1059             $t == OP_EXP() ||
1060             $t == OP_LOG() ||
1061             $t == OP_SQRT() ||
1062             $t == OP_HEX() ||
1063             $t == OP_OCT() ||
1064             $t == OP_ABS()) {
1065              
1066             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1067            
1068             # Bind to an incomplete Nu value.
1069             $t = myUnify($env, $t, $env->freshNu);
1070              
1071             ($realResult, $realReturn) = ($DV, $r);
1072              
1073             } elsif ($t == OP_I_ADD() ||
1074             $t == OP_I_SUBTRACT() ||
1075             $t == OP_I_MULTIPLY() ||
1076             $t == OP_I_DIVIDE() ||
1077             $t == OP_I_MODULO() ||
1078             $t == OP_I_LT() ||
1079             $t == OP_I_GT() ||
1080             $t == OP_I_LE() ||
1081             $t == OP_I_GE() ||
1082             $t == OP_I_EQ() ||
1083             $t == OP_I_NE() ||
1084             $t == OP_I_NCMP() ||
1085             $t == OP_BIT_AND() ||
1086             $t == OP_BIT_OR() ||
1087             $t == OP_BIT_XOR() ||
1088             $t == OP_SETPGRP() ||
1089             $t == OP_LEFT_SHIFT() ||
1090             $t == OP_RIGHT_SHIFT()) {
1091             # Binary number operators that are strict in IV
1092              
1093             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1094             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1095            
1096             myUnify($env, $ft, $IV);
1097             myUnify($env, $lt, $IV);
1098            
1099             ($realResult, $realReturn) = ($IV, myUnify($env, $fr, $lr));
1100              
1101             if ($t == OP_I_ADD() ||
1102             $t == OP_I_SUBTRACT() ||
1103             $t == OP_I_MULTIPLY() ||
1104             $t == OP_I_DIVIDE() ||
1105             $t == OP_I_MODULO() ||
1106             $t == OP_BIT_AND() ||
1107             $t == OP_BIT_OR() ||
1108             $t == OP_BIT_XOR() ||
1109             $t == OP_LEFT_SHIFT() ||
1110             $t == OP_RIGHT_SHIFT()) {
1111             opAssign($env, $op, $ft, $realResult);
1112             }
1113             } elsif ($t == OP_SEQ() ||
1114             $t == OP_SNE() ||
1115             $t == OP_SLT() ||
1116             $t == OP_SGT() ||
1117             $t == OP_SLE() ||
1118             $t == OP_SGE() ||
1119             $t == OP_SCMP()) {
1120             # Binary comparison operators
1121              
1122             # Both sides should be unified with PV, but resulting
1123             # expression type is NV.
1124              
1125             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1126             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1127            
1128             myUnify($env, $ft, $PV);
1129             myUnify($env, $lt, $PV);
1130            
1131             ($realResult, $realReturn) = ($IV, myUnify($env, $fr, $lr));
1132              
1133             } elsif ($t == OP_CONCAT()) {
1134              
1135             # Both sides should be unified with Ka, and resulting
1136             # expression type is PV.
1137              
1138             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1139             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1140            
1141             myUnify($env, $ft, $env->freshUpsilon);
1142             myUnify($env, $lt, $env->freshUpsilon);
1143            
1144             ($realResult, $realReturn) = ($PV, myUnify($env, $fr, $lr));
1145              
1146             opAssign($env, $op, $ft, $PV);
1147              
1148             } elsif ($t == OP_GELEM()) {
1149              
1150             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1151             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1152              
1153             myUnify($env, $ft, $env->freshEta($env));
1154             myUnify($env, $lt, $PV);
1155              
1156             my $const = getPvConst($op->last, $cv);
1157             my $r = myUnify($env, $fr, $lr);
1158              
1159             # Dereferencing typed elements as necessary
1160             if ($const eq "SCALAR") {
1161             ($realResult, $realReturn) = ($env->genRho($ft->derefKappa), $r);
1162             } elsif ($const eq "IO" ||
1163             $const eq "FILEHANDLE") {
1164             ($realResult, $realReturn) = ($env->genRho($IO), $r);
1165             } elsif ($const eq "ARRAY") {
1166             ($realResult, $realReturn) = ($env->genRho($ft->derefOmicron), $r);
1167             } elsif ($const eq "HASH") {
1168             ($realResult, $realReturn) = ($env->genRho($ft->derefChi), $r);
1169             } elsif ($const eq "CODE") {
1170             ($realResult, $realReturn) = ($env->genRho($ft->derefZeta), $r);
1171             } elsif ($const eq "GLOB") {
1172             # YYY I'm pretty sure a gelem(glob0) -> glob0
1173             ($realResult, $realReturn) = ($env->genRho($ft), $r);
1174             } else {
1175             die("Unknown *foo{THING} syntax on $const");
1176             }
1177              
1178             } elsif ($t == OP_GVSV()) {
1179              
1180             # Get the type of the referencing GV. I don't fully
1181             # understand the following line. It was borrowed from
1182             # B/Concise.pm.
1183             my $class = B::class($op);
1184              
1185             my $gv;
1186             if ($class eq "PADOP") {
1187             $gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
1188             } elsif ($class eq "SVOP") {
1189             $gv = $op->gv;
1190             } else {
1191             confess("unknown op type $class for GVSV");
1192             }
1193              
1194             my $tgv = $glob2type->get($gv->STASH()->NAME() . "::" . $gv->SAFENAME(), $env);
1195              
1196             # Project the type of the referent SV. $tgv is guaranteed to
1197             # be an instance of Devel::TypeCheck::Type::Eta.
1198             ($realResult, $realReturn) = ($tgv->derefKappa, undef);
1199              
1200             } elsif ($t == OP_GV()) {
1201              
1202             my $class = B::class($op);
1203              
1204             my $gv;
1205             if ($class eq "PADOP") {
1206             $gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
1207             } elsif ($class eq "SVOP") {
1208             $gv = $op->gv;
1209             } else {
1210             confess("unknown op type $class for GV");
1211             }
1212              
1213             my $tgv = $glob2type->get($gv->STASH()->NAME() . "::" . $gv->SAFENAME(), $env);
1214              
1215             ($realResult, $realReturn) = ($env->genRho($tgv), undef);
1216              
1217             } elsif ($t == OP_RV2GV()) {
1218              
1219             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1220            
1221             # Guarantee that we can dereference something
1222             myUnify($env, $t, $env->freshRho());
1223              
1224             my $d = $env->find($t)->deref;
1225              
1226             myUnify($env, $d, $env->freshEta($env));
1227             ($realResult, $realReturn) = ($d, $r);
1228              
1229             } elsif ($t == OP_RV2SV()) {
1230              
1231             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1232              
1233             # cheat
1234             myUnify($env, $t, $env->genRho($env->fresh)) if ($op->first()->type() == OP_PADSV());
1235              
1236             my $d = rvConflate($env, $t, $env->freshKappa());
1237             ($realResult, $realReturn) = ($d, $r);
1238              
1239             } elsif ($t == OP_RV2AV()) {
1240            
1241             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1242              
1243             # cheat
1244             myUnify($env, $t, $env->genRho($env->fresh)) if ($op->first()->type() == OP_PADSV());
1245              
1246             my $d = rvConflate($env, $t, $env->genOmicron);
1247             ($realResult, $realReturn) = ($d, $r);
1248              
1249             } elsif ($t == OP_RV2HV()) {
1250            
1251             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1252              
1253             # cheat
1254             myUnify($env, $t, $env->genRho($env->fresh)) if ($op->first()->type() == OP_PADSV());
1255              
1256             my $d = rvConflate($env, $t, $env->genChi);
1257             ($realResult, $realReturn) = ($d, $r);
1258              
1259             } elsif ($t == OP_RV2CV()) {
1260            
1261             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1262              
1263             # cheat
1264             myUnify($env, $t, $env->genRho($env->fresh)) if ($op->first()->type() == OP_PADSV());
1265              
1266             my $d = rvConflate($env, $t, $env->freshZeta);
1267             ($realResult, $realReturn) = ($d, $r);
1268              
1269             } elsif ($t == OP_ANONCODE()) {
1270            
1271             # my $class = B::class($op);
1272             # my $ttcv;
1273             # if ($class eq "PADOP") {
1274             # $ttcv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
1275             # } elsif ($class eq "SVOP") {
1276             # $ttcv = $op->gv;
1277             # }
1278             # verbose("class is " . $ttcv);
1279             # my $tcv = $glob2type->get($ttcv->STASH()->NAME() . "::" . $ttcv->SAFENAME(), $env)->derefZeta;
1280             # my $op = $tcv->ROOT;
1281             # my %cur;
1282              
1283             # $cur{'cv'} = $tcv;
1284             # $cur{'op'} = $op;
1285             # $roots{'anon'} = \%cur;
1286              
1287             # push(@list, 'anon');
1288            
1289             # XXX revisit this
1290             ($realResult, $realReturn) = ($env->freshZeta, undef);
1291              
1292             } elsif ($t == OP_PROTOTYPE()) {
1293              
1294             # XXX revisit this
1295             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1296             myUnify($env, $t, $env->freshZeta);
1297              
1298             ($realResult, $realReturn) = ($PV, $r);
1299              
1300             } elsif ($t == OP_REFGEN()) {
1301              
1302             my $newType = $env->genOmicron();
1303              
1304             my @returns;
1305              
1306             for (my $kid = $op->first()->first()->sibling;
1307             $$kid;
1308             $kid = $kid->sibling()) {
1309             my ($type, $return) = typeOp($kid, $pad2type, $env, $cv, LIST());
1310              
1311             push(@returns, $return);
1312              
1313             $type = $env->find($type);
1314              
1315             verbose("found type ", myPrint($type, $env));
1316              
1317             if ($type->isa("Devel::TypeCheck::Type::Var")) {
1318             $type = $env->genOmicron();
1319             }
1320              
1321             my $optype = $kid->type();
1322              
1323             # If the incoming type is an array or hash and not an
1324             # actual reference...
1325             if (($type->is(Devel::TypeCheck::Type::O()) ||
1326             $type->is(Devel::TypeCheck::Type::H())) &&
1327             !($optype == OP_RV2AV() ||
1328             $optype == OP_RV2HV() ||
1329             $optype == OP_PADAV() ||
1330             $optype == OP_PADHV())) {
1331             my $tmptype = $type->referize($env);
1332              
1333             if (!$tmptype->homogeneous() &&
1334             $tmptype->arity == 0) {
1335             $tmptype = $env->genOmicron($env->genRho($env->fresh));
1336             }
1337              
1338             $newType = $newType->append($tmptype, $env);
1339             verbose("referizing to ", myPrint($newType, $env));
1340             } else {
1341             $newType = $newType->append($env->genRho($type), $env);
1342             verbose("generating reference ", myPrint($newType, $env));
1343             }
1344             }
1345              
1346             if (!$newType->homogeneous() &&
1347             $newType->arity == 1) {
1348             verbose("dereferencing");
1349             $newType = $newType->derefIndex(0, $env);
1350             }
1351              
1352             verbose("realResult is ", myPrint($newType, $env));
1353             $realResult = $newType;
1354             $realReturn = myUnify($env, @returns);
1355              
1356             } elsif ($t == OP_SREFGEN()) {
1357              
1358             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1359             ($realResult, $realReturn) = ($env->genRho($t), $r);
1360              
1361             } elsif ($t == OP_REF()) {
1362              
1363             # Can be passed anything
1364             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1365            
1366             # Returns a string
1367             ($realResult, $realReturn) = ($PV, $r);
1368              
1369             } elsif ($t == OP_BLESS()) {
1370              
1371             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1372            
1373             if (${$op->first()->sibling()}) {
1374             my ($st, $sr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1375             myUnify($env, $st, $PV);
1376             $r = myUnify($env, $r, $sr);
1377             }
1378              
1379             ($realResult, $realReturn) = ($t, $r);
1380              
1381             } elsif ($t == OP_ANONLIST()) {
1382              
1383             ($realResult, $realReturn) = typeOpChildren($op->first(), $pad2type, $env, $cv, LIST());
1384              
1385             } elsif ($t == OP_AELEMFAST()) {
1386              
1387             my $elt = $op->private;
1388              
1389             my $ary;
1390             if ($op->flags & B::OPf_REF) {
1391             # This is a pad aelemfast
1392             $ary = $pad2type->get($op->targ, $env);
1393             $ary = $env->find($ary);
1394             } else {
1395             # This is a glob aelemfast
1396             my $gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
1397             my $tgv = $glob2type->get($gv->STASH()->NAME() . "::" . $gv->SAFENAME(), $env);
1398             $ary = $tgv->derefOmicron();
1399             }
1400              
1401             # Negative index indicates a homogeneous array.
1402             if ($elt < 0) {
1403             myUnify($env, $ary, $env->genOmicron($env->freshKappa));
1404             }
1405              
1406             ($realResult, $realReturn) = ($ary->derefIndex($elt, $env), undef);
1407            
1408             } elsif ($t == OP_AELEM()) {
1409             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1410             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1411              
1412             # Last must be an IV
1413             myUnify($env, $lt, $IV);
1414              
1415             my $t;
1416              
1417             # If last is a constant:
1418             if ($op->last->type() == OP_CONST()) {
1419             # First must be an undistinguished Omicron.
1420             my $list = $env->genOmicron();
1421             myUnify($env, $ft, $list);
1422              
1423             # Assuming $ft is an Omicron, if it's a list, the type is
1424             # just the homogeneous type.
1425             if ($list->homogeneous) {
1426             $t = $list->derefHomogeneous;
1427             } else {
1428             my $const = getIvConst($op->last, $cv);
1429              
1430             # Negative index indicates a homogeneous array, since
1431             # we don't know where the end of the tuple is until
1432             # the type has been completely determined.
1433             if ($const < 0) {
1434             myUnify($env, $list, $env->genOmicron($env->freshKappa));
1435             }
1436              
1437             $t = $list->derefIndex(getIvConst($op->last, $cv), $env);
1438             }
1439              
1440             } else {
1441             # If last is not a constant:
1442             # First must be a list
1443             my $list = $env->genOmicron($env->freshKappa);
1444             myUnify($env, $ft, $list);
1445              
1446             # The type then is just the homogeneous type
1447             $t = $list->derefHomogeneous;
1448             }
1449              
1450             # Resulting type is a generic KAPPA
1451             ($realResult, $realReturn) = ($t, undef);
1452              
1453             } elsif ($t == OP_HELEM()) {
1454              
1455             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1456             my ($lt, $lr) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
1457              
1458             # Last must be a non-reference scalar
1459             myUnify($env, $lt, $env->freshUpsilon);
1460            
1461             my $t;
1462              
1463             if ($op->last->type() == OP_CONST()) {
1464             my $hash = $env->genChi();
1465              
1466             myUnify($env, $ft, $hash);
1467              
1468             if ($hash->homogeneous) {
1469             $t = $hash->derefHomogeneous;
1470             } else {
1471             $t = $hash->derefIndex(getUpsilonConst($op->last, $cv), $env);
1472             }
1473             } else {
1474             my $hash = $env->genChi($env->freshKappa);
1475             myUnify($env, $ft, $hash);
1476             $t = $hash->derefHomogeneous;
1477             }
1478              
1479             # Resulting type is a generic KAPPA
1480             ($realResult, $realReturn) = ($t, undef);
1481            
1482             } elsif ($t == OP_SASSIGN()) {
1483            
1484             if (B::class($op) ne "UNOP") {
1485            
1486             # At this point the type check is flow insensitive, and we're
1487             # not doing any subtyping. Thus, all we have to do is unify
1488             # both sides with each other.
1489              
1490             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1491             my ($lt, $lr) = typeOp($op->last(), $pad2type, $env, $cv, SCALAR());
1492              
1493             ($realResult, $realReturn) =
1494             (myUnify($env, $ft, $lt),
1495             myUnify($env, $fr, $lr));
1496             } else {
1497              
1498             # Unless SASSIGN is a UNOP because of an ORASSIGN or an
1499             # ANDASSIGN higher up in the tree. This, of course, makes
1500             # no sense and the SASSIGN isn't even used.
1501              
1502             ($realResult, $realReturn) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1503              
1504             }
1505              
1506             } elsif ($t == OP_AASSIGN()) {
1507              
1508             # Infer array for lhs
1509             my ($lt, $lr) = typeOp($op->first(), $pad2type, $env, $cv, LIST());
1510             #myUnify($env, $lt, $env->genOmicron());
1511              
1512             # Infer array for rhs
1513             my ($rt, $rr) = typeOp($op->last, $pad2type, $env, $cv, LIST());
1514             #myUnify($env, $rt, $env->genOmicron());
1515              
1516             # Unify lhs and rhs
1517             myUnify($env, $lt, $rt);
1518              
1519             # Unify the return values
1520             myUnify($env, $lr, $rr);
1521              
1522             ($realResult, $realReturn) = ($lt, $lr);
1523              
1524             } elsif ($t == OP_CONST()) {
1525              
1526             my $sv = $op->sv;
1527             ($realResult, $realReturn) = constructConst($sv, $cv, $op, $env);
1528              
1529             } elsif ($t == OP_SPLIT()) {
1530              
1531             # First is always the pushre pmop, second is the string, and
1532             # third is the count.
1533             if ($context == SCALAR() &&
1534             !defined($op->first()->pmreplroot())) {
1535             warn("split in a scalar context is deprecated");
1536             }
1537              
1538             my $pmreplroot = $op->first()->pmreplroot();
1539              
1540             # To simplify things, just make the return a homogeneous list of non-reference scalars.
1541             my $result = $env->genOmicron($env->freshUpsilon);
1542              
1543             # Do something if the target of the split is stored in the PMOP
1544             if (ref($pmreplroot) eq "B::GV") {
1545             my $tgv = $glob2type->get($pmreplroot->STASH()->NAME() . "::" . $pmreplroot->SAFENAME(), $env);
1546             myUnify($env, $result, $tgv->derefOmicron);
1547             } elsif (!ref($pmreplroot) and $pmreplroot) {
1548             my $gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
1549             my $tgv = $glob2type->get($gv->STASH()->NAME() . "::" . $gv->SAFENAME(), $env);
1550             myUnify($env, $result, $tgv->derefOmicron);
1551             }
1552              
1553             # Make sure the string getting split up is a PV or number, not a ref.
1554             my ($st, $sr) = typeOp($op->first()->sibling(), $pad2type, $env, $cv, SCALAR());
1555             myUnify($env, $st, $env->freshUpsilon);
1556              
1557             # This last thing will always be an integer.
1558             my ($ct, $cr) = typeOp($op->first()->sibling()->sibling(), $pad2type, $env, $cv, SCALAR());
1559             myUnify($env, $ct, $IV);
1560            
1561             ($realResult, $realReturn) = ($result, myUnify($env, $sr, $cr));
1562              
1563             } elsif ($t == OP_JOIN()) {
1564              
1565             # First is a pushmark, second is a PV, rest are type checked
1566             # in a list context but not unified. There is potential for
1567             # loss of precision here.
1568             my ($t, $r) = typeOp($op->first()->sibling(), $pad2type, $env, $cv, SCALAR());
1569             myUnify($env, $t, $PV);
1570              
1571             my @rets;
1572             push(@rets, $r) if ($r);
1573              
1574             for (my $kid = $op->first()->sibling()->sibling(); $$kid; $kid = $kid->sibling()) {
1575             ($t, $r) = typeOp($kid, $pad2type, $env, $cv, LIST());
1576             push(@rets, $r) if ($r);
1577             }
1578              
1579             ($realResult, $realReturn) = ($PV, myUnify($env, @rets));
1580              
1581             } elsif ($t == OP_MATCH()) {
1582              
1583             my ($t, $r) = (undef, undef);
1584              
1585             if ($op->flags & B::OPf_KIDS()) {
1586             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1587             myUnify($env, $t, $PV);
1588             }
1589              
1590             if ($context == SCALAR()) {
1591             ($realResult, $realReturn) = ($IV, $r);
1592             } else {
1593             ($realResult, $realReturn) = ($env->genOmicron($env->freshUpsilon()), $r);
1594             }
1595             } elsif ($t == OP_SUBST()) {
1596              
1597             my ($t, $r);
1598             my @rets;
1599              
1600             if (${$op->pmreplstart}) {
1601             ($t, $r) = typeOp($op->pmreplstart, $pad2type, $env, $cv, SCALAR());
1602             } else {
1603             my $cur = $op->first();
1604             if ($op->flags & B::OPf_STACKED()) {
1605             ($t, $r) = typeOp($cur, $pad2type, $env, $cv, SCALAR());
1606             myUnify($env, $t, $PV);
1607             push(@rets, $r) if ($r);
1608             $cur = $op->last;
1609             }
1610            
1611             ($t, $r) = typeOp($cur, $pad2type, $env, $cv, SCALAR());
1612             }
1613              
1614             push(@rets, $r) if ($r);
1615              
1616             ($realResult, $realReturn) = ($IV, myUnify($env, @rets));
1617              
1618             } elsif ($t == OP_SUBSTCONT()) {
1619              
1620             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1621             myUnify($env, $t, $PV);
1622            
1623             ($realResult, $realReturn) = ($PV, $r);
1624              
1625             } elsif ($t == OP_NEXTSTATE() ||
1626             $t == OP_DBSTATE() ||
1627             $t == OP_SETSTATE()) {
1628              
1629             # Has no effect on typing
1630              
1631             verbose(" " x $depth, " line ", $op->line, ", file ", $op->file);
1632             # Set some globals for error reporting purposes
1633             $globalLine = $op->line;
1634             $globalFile = $op->file;
1635              
1636             ($realResult, $realReturn) = (undef, undef);
1637              
1638             } elsif ($t == OP_COND_EXPR() ||
1639             $t == OP_AND() ||
1640             $t == OP_OR()) {
1641              
1642             # All LOGOPs
1643             my @types;
1644             my @rets;
1645              
1646             my ($ft, $fr) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1647              
1648             if (!($ft->is(Devel::TypeCheck::Type::O()) ||
1649             $ft->is(Devel::TypeCheck::Type::X()))) {
1650             myUnify($env, $ft, &$inferLogop($env));
1651             }
1652              
1653             push(@rets, $fr) if (defined($fr));
1654              
1655             # Remaining operands should unify together if the result wants something
1656             my $test = $op->flags & 3;
1657            
1658             if ($t == OP_AND() || $t == OP_OR()) {
1659             push(@types, &$inferLogop($env));
1660             }
1661              
1662             my $ctx = $context;
1663              
1664             $ctx = SCALAR() if ($test == 2);
1665             $ctx = LIST() if ($test == 3);
1666              
1667             for (my $kid = $op->first()->sibling(); $$kid; $kid = $kid->sibling()) {
1668             my ($t, $r) = typeOp($kid, $pad2type, $env, $cv, $ctx);
1669             push(@types, $t) if (defined($t));
1670             push(@rets, $r) if (defined($r));
1671             }
1672              
1673             my $s = undef;
1674             if ($test != 1) {
1675             $s = myUnify($env, @types);
1676             }
1677            
1678             my $r = myUnify($env, @rets);
1679             ($realResult, $realReturn) = ($s, $r);
1680              
1681             } elsif ($t == OP_XOR()) {
1682              
1683             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($env->freshKappa, $env->freshKappa));
1684             ($realResult, $realReturn) = ($IV, $r);
1685              
1686             } elsif ($t == OP_ORASSIGN() ||
1687             $t == OP_ANDASSIGN()) {
1688              
1689             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($IV, $IV));
1690             ($realResult, $realReturn) = ($IV, $r);
1691              
1692             } elsif ($t == OP_SCALAR()) {
1693              
1694             # Get ready for an ugly hack
1695             my $cur = $op->first();
1696              
1697             $cur = $cur->sibling() if (($cur->type() == 0) && (${$cur->sibling()}));
1698              
1699             my ($t, $r) = typeOp($cur, $pad2type, $env, $cv, SCALAR());
1700              
1701             # If the operand has some scalar type, return that scalar
1702             # type. Otherwise, return a fresh scalar type.
1703             if ($t->is(Devel::TypeCheck::Type::K())) {
1704             ($realResult, $realReturn) = ($t, $r);
1705             } else {
1706             ($realResult, $realReturn) = ($env->freshKappa, $r);
1707             }
1708              
1709             } elsif ($t == OP_WANTARRAY()) {
1710              
1711             # Always generate an IV
1712             ($realResult, $realReturn) = ($IV, undef);
1713              
1714             } elsif ($t == OP_AV2ARYLEN()) {
1715            
1716             # Infer undistinguished AV type for operand
1717             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1718             myUnify($env, $t, $env->genOmicron());
1719              
1720             # Return IV type
1721             ($realResult, $realReturn) = ($IV, $r);
1722              
1723             } elsif ($t == OP_SHIFT() ||
1724             $t == OP_POP()) {
1725            
1726             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1727             myUnify($env, $t, $env->genOmicron($env->freshKappa));
1728              
1729             # Return the homogeneous type of $t.
1730             ($realResult, $realReturn) = ($t->derefHomogeneous, $r);
1731              
1732             } elsif ($t == OP_UNSHIFT() ||
1733             $t == OP_PUSH()) {
1734              
1735             my ($t, $r) = typeOp($op->first()->sibling(), $pad2type, $env, $cv, SCALAR());
1736             myUnify($env, $t, $env->genOmicron($env->freshKappa));
1737              
1738             my @returns = ($r);
1739             my @results = ();
1740             for (my $kid = $op->first()->sibling()->sibling(); $$kid; $kid = $kid->sibling()) {
1741             my ($t, $r) = typeOp($kid, $pad2type, $env, $cv, LIST());
1742             push(@results, $t) if (defined($t));
1743             push(@returns, $r) if (defined($r));
1744             }
1745              
1746             my $tt = smash(\@results, $env);
1747             $r = myUnify($env, @returns);
1748              
1749             ($realResult, $realReturn) = ($IV, $r);
1750              
1751             } elsif ($t == OP_PADSV()) {
1752              
1753             # Make sure it's a scalar value of some sort
1754             my $pad = $pad2type->get($op->targ, $env);
1755             myUnify($env, $pad, $env->freshKappa);
1756             ($realResult, $realReturn) = ($pad, undef);
1757              
1758             } elsif ($t == OP_PADAV()) {
1759              
1760             my $pad = $pad2type->get($op->targ, $env);
1761             my $list = $env->genOmicron();
1762             myUnify($env, $pad, $list);
1763             ($realResult, $realReturn) = ($pad, undef);
1764              
1765             } elsif ($t == OP_PADHV()) {
1766            
1767             my $pad = $pad2type->get($op->targ, $env);
1768             my $hash = $env->genChi();
1769             myUnify($env, $pad, $hash);
1770             ($realResult, $realReturn) = ($pad, undef);
1771              
1772             } elsif ($t == OP_PADANY()) {
1773              
1774             # It's not implemented. It shouldn't show up.
1775             die("PADANY not implemented");
1776             ($realResult, $realReturn) = (undef, undef);
1777              
1778             } elsif ($t == OP_SYSTEM()) {
1779              
1780             my ($t, $r) = typeOpChildren_($op, $pad2type, $env, $cv);
1781             myUnify($env, $t, $PV);
1782             ($realResult, $realReturn) = ($IV, $r);
1783              
1784             } elsif ($t == OP_PUSHMARK()) {
1785              
1786             # Operators that are completely ignored
1787             ($realResult, $realReturn) = (undef, undef);
1788              
1789             } elsif ($t == OP_REQUIRE()) {
1790            
1791             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($env->freshKappa()));
1792             ($realResult, $realReturn) = ($IV, $r);
1793              
1794             } elsif ($t == OP_CHDIR() ||
1795             $t == OP_CHROOT() ||
1796             $t == OP_QUOTEMETA() ||
1797             $t == OP_UNLINK()) {
1798            
1799             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1800             ($realResult, $realReturn) = ($IV, $r);
1801              
1802             } elsif ($t == OP_GSBYNAME()) {
1803             # IV|AV = op(PV [, PV])
1804             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV, $PV));
1805             ($realResult, $realReturn) = (contextPick($context, GSBY($env), $IV), $r);
1806              
1807             } elsif ($t == OP_GSBYPORT()) {
1808              
1809             # PV|AV = op(IV [, PV])
1810             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($IV, $PV));
1811             ($realResult, $realReturn) = (contextPick($context, GSBY($env), $PV), $r);
1812              
1813             } elsif ($t == OP_BACKTICK()) {
1814              
1815             # List of printables
1816             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1817             ($realResult, $realReturn) = (contextPick($context, $env->genOmicron($env->freshUpsilon), $env->freshUpsilon), $r);
1818             } elsif ($t == OP_GHBYNAME()) {
1819              
1820             # GHBY
1821             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1822             ($realResult, $realReturn) = (contextPick($context, GHBY($env), $IV), $r);
1823              
1824             } elsif ($t == OP_GPBYNAME()) {
1825              
1826             # GPBY
1827             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1828             ($realResult, $realReturn) = (contextPick($context, GPBY($env), $IV), $r);
1829              
1830             } elsif ($t == OP_GNBYNAME()) {
1831              
1832             # GNBY
1833             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1834             ($realResult, $realReturn) = (contextPick($context, GNBY($env), $IV), $r);
1835              
1836             } elsif ($t == OP_GPWNAM()) {
1837              
1838             # GPW
1839             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1840             ($realResult, $realReturn) = (contextPick($context, GPW($env), $IV), $r);
1841              
1842             } elsif ($t == OP_GGRNAM()) {
1843              
1844             # GGR
1845             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($PV));
1846             ($realResult, $realReturn) = (contextPick($context, GGR($env), $IV), $r);
1847              
1848             } elsif ($t == OP_GHBYADDR()) {
1849              
1850             # GHBY
1851             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV));
1852             ($realResult, $realReturn) = (contextPick($context, GHBY($env), $IV), $r);
1853              
1854             } elsif ($t == OP_GNBYADDR()) {
1855              
1856             # GNBY
1857             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV));
1858             ($realResult, $realReturn) = (contextPick($context, GNBY($env), $IV), $r);
1859              
1860             } elsif ($t == OP_GPBYNUMBER()) {
1861              
1862             # GPBY
1863             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($IV));
1864             ($realResult, $realReturn) = (contextPick($context, GPBY($env), $IV), $r);
1865              
1866             } elsif ($t == OP_GPWUID()) {
1867              
1868             # GPW
1869             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($IV));
1870             ($realResult, $realReturn) = (contextPick($context, GPW($env), $IV), $r);
1871              
1872             } elsif ($t == OP_GGRGID()) {
1873              
1874             # GGR
1875             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($IV));
1876             ($realResult, $realReturn) = (contextPick($context, GGR($env), $IV), $r);
1877              
1878             } elsif ($t == OP_GHOSTENT()) {
1879              
1880             # GHBY
1881             ($realResult, $realReturn) = (contextPick($context, GHBY($env), $IV), undef);
1882            
1883             } elsif ($t == OP_GNETENT()) {
1884              
1885             # GNBY
1886             ($realResult, $realReturn) = (contextPick($context, GNBY($env), $IV), undef);
1887            
1888             } elsif ($t == OP_GPROTOENT()) {
1889              
1890             # GPBY
1891             ($realResult, $realReturn) = (contextPick($context, GPBY($env), $IV), undef);
1892            
1893             } elsif ($t == OP_GSERVENT()) {
1894              
1895             # GSBY
1896             ($realResult, $realReturn) = (contextPick($context, GSBY($env), $IV), undef);
1897            
1898             } elsif ($t == OP_GPWENT()) {
1899              
1900             # GPW
1901             ($realResult, $realReturn) = (contextPick($context, GPW($env), $IV), undef);
1902            
1903             } elsif ($t == OP_GGRENT()) {
1904              
1905             # GGR
1906             ($realResult, $realReturn) = (contextPick($context, GGR($env), $IV), undef);
1907            
1908             } elsif ($t == OP_EHOSTENT() ||
1909             $t == OP_ENETENT() ||
1910             $t == OP_EPROTOENT() ||
1911             $t == OP_ESERVENT() ||
1912             $t == OP_SPWENT() ||
1913             $t == OP_EPWENT() ||
1914             $t == OP_SGRENT() ||
1915             $t == OP_EGRENT()) {
1916             # IV = op()
1917            
1918             ($realResult, $realReturn) = ($IV, undef);
1919            
1920             } elsif ($t == OP_SHOSTENT() ||
1921             $t == OP_SNETENT() ||
1922             $t == OP_SPROTOENT() ||
1923             $t == OP_SSERVENT()) {
1924             # IV = op(MKa)
1925              
1926             my ($r, $missed) = typeProto($op, $pad2type, $env, $cv, ($env->freshKappa));
1927             ($realResult, $realReturn) = ($IV, $r);
1928              
1929             } elsif ($t == OP_FTRREAD() ||
1930             $t == OP_FTRWRITE() ||
1931             $t == OP_FTREXEC() ||
1932             $t == OP_FTEREAD() ||
1933             $t == OP_FTEWRITE() ||
1934             $t == OP_FTEEXEC() ||
1935             $t == OP_FTIS() ||
1936             $t == OP_FTEOWNED() ||
1937             $t == OP_FTROWNED() ||
1938             $t == OP_FTZERO() ||
1939             $t == OP_FTSIZE() ||
1940             $t == OP_FTMTIME() ||
1941             $t == OP_FTATIME() ||
1942             $t == OP_FTCTIME() ||
1943             $t == OP_FTSOCK() ||
1944             $t == OP_FTCHR() ||
1945             $t == OP_FTBLK() ||
1946             $t == OP_FTFILE() ||
1947             $t == OP_FTDIR() ||
1948             $t == OP_FTPIPE() ||
1949             $t == OP_FTLINK() ||
1950             $t == OP_FTSUID() ||
1951             $t == OP_FTSGID() ||
1952             $t == OP_FTSVTX() ||
1953             $t == OP_FTTTY() ||
1954             $t == OP_FTTEXT() ||
1955             $t == OP_FTBINARY()) {
1956              
1957             # If we're doing it to an IO handle, then this is a PADOP
1958             # instead of a UNOP, and there aren't really any operands to
1959             # check.
1960             my ($t, $r) = (undef, undef);
1961             if ($op->flags & B::OPf_KIDS) {
1962             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
1963             myUnify($env, $t, $PV);
1964             }
1965              
1966             ($realResult, $realReturn) = ($IV, $r);
1967              
1968             } elsif ($t == OP_STAT() ||
1969             $t == OP_LSTAT()) {
1970              
1971             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($PV));
1972             ($realResult, $realReturn) = ($env->genOmicronTuple($IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV), $r);
1973            
1974             } elsif ($t == OP_REGCMAYBE() ||
1975             $t == OP_REGCRESET() ||
1976             $t == OP_REGCOMP() ||
1977             $t == OP_QR() ||
1978             $t == OP_SCHOP() ||
1979             $t == OP_SCHOMP() ||
1980             $t == OP_UCFIRST() ||
1981             $t == OP_LCFIRST() ||
1982             $t == OP_UC() ||
1983             $t == OP_LC() ||
1984             $t == OP_READLINK()) {
1985              
1986             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($PV));
1987             ($realResult, $realReturn) = ($PV, $r);
1988            
1989             } elsif ($t == OP_STUDY() ||
1990             $t == OP_POS() ||
1991             $t == OP_RMDIR()) {
1992              
1993             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($PV));
1994             ($realResult, $realReturn) = ($IV, $r);
1995            
1996             } elsif ($t == OP_SRAND() ||
1997             $t == OP_ALARM()) {
1998              
1999             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($IV));
2000             ($realResult, $realReturn) = ($IV, $r);
2001            
2002             } elsif ($t == OP_CHR()) {
2003              
2004             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($IV));
2005             ($realResult, $realReturn) = ($PV, $r);
2006            
2007             } elsif ($t == OP_LOCALTIME() ||
2008             $t == OP_GMTIME()) {
2009              
2010             my ($r, $missed) = typeProtoOp($op, $pad2type, $env, $cv, ($IV));
2011             ($realResult, $realReturn) = (contextPick($context, $env->genOmicronTuple($IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV, $IV), $PV), $r);
2012              
2013             } elsif ($t == OP_DELETE()) {
2014              
2015             # homogenize aggregate data types, sort of like push, pop, shift, and unshift.
2016             my ($t, $r);
2017             if ($op->first()->targ == OP_AELEM()) {
2018             my $list = $env->genOmicron($env->freshKappa);
2019             ($t, $r) = typeOp($op->first()->first(), $pad2type, $env, $cv, SCALAR());
2020             myUnify($env, $t, $list);
2021              
2022             my ($t0, $r0) = typeOp($op->first()->sibling(), $pad2type, $env, $cv, SCALAR());
2023             myUnify($env, $t0, $IV);
2024             myUnify($env, $r0, $r);
2025             } elsif ($op->first()->targ == OP_HELEM()) {
2026             my $list = $env->genChi($env->freshKappa);
2027             ($t, $r) = typeOp($op->first()->first(), $pad2type, $env, $cv, SCALAR());
2028             myUnify($env, $t, $list);
2029              
2030             my ($t0, $r0) = typeOp($op->first()->first()->sibling(), $pad2type, $env, $cv, SCALAR());
2031             myUnify($env, $t0, $env->freshUpsilon);
2032             myUnify($env, $r0, $r);
2033             } else {
2034             confess("unknown invocation of OP_DELETE, expected an ex-aelem or ex-helem as operand");
2035             }
2036              
2037             ($realResult, $realReturn) = ($IV, $r);
2038            
2039             } elsif ($t == OP_EXISTS()) {
2040              
2041             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv);
2042             ($realResult, $realReturn) = ($IV, $r);
2043              
2044             } elsif ($t == OP_FORK() ||
2045             $t == OP_WAIT() ||
2046             $t == OP_TIME()) {
2047              
2048             ($realResult, $realReturn) = ($IV, undef);
2049              
2050             } elsif ($t == OP_TMS()) {
2051              
2052             ($realResult, $realReturn) = (contextPick($context, $env->genOmicronTuple($IV, $IV, $IV, $IV), $DV), undef);
2053              
2054             } elsif ($t == OP_TRANS()) {
2055              
2056             ($realResult, $realReturn) = ($PV, undef);
2057              
2058             } elsif ($t == OP_GLOB() ||
2059             $t == OP_RCATLINE()) {
2060              
2061             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv);
2062             ($realResult, $realReturn) = ($env->fresh, $r);
2063            
2064             } elsif ($t == OP_READLINE()) {
2065            
2066             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv);
2067              
2068             if ($context == SCALAR()) {
2069             ($realResult, $realReturn) = ($env->freshUpsilon(), $r);
2070             } else {
2071             ($realResult, $realReturn) = ($env->genOmicron($env->freshUpsilon()), $r);
2072             }
2073              
2074             } elsif ($t == OP_UNDEF()) {
2075              
2076             # Can't infer type here, since undef may legitimately be used
2077             # to vacate variables of any sort. Still, we should typecheck
2078             # the argument, if there is one.
2079             my ($t, $r) = (undef, undef);
2080             if ($op->flags & B::OPf_KIDS()) {
2081             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2082             }
2083              
2084             # Generate a type of ref to var
2085             ($realResult, $realReturn) = ($env->freshKappa(), $r);
2086              
2087             } elsif ($t == OP_GOTO() ||
2088             $t == OP_DUMP()) {
2089              
2090             # Make sure the argument to goto (if there is one) is at least
2091             # internally consistent.
2092             my ($t, $r) = (undef, undef);
2093             if ($op->flags & B::OPf_KIDS()) {
2094             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2095             }
2096              
2097             ($realResult, $realReturn) = (undef, $r);
2098            
2099             } elsif ($t == OP_UNSTACK() ||
2100             $t == OP_LAST() ||
2101             $t == OP_NEXT() ||
2102             $t == OP_REDO()) {
2103              
2104             ($realResult, $realReturn) = (undef, undef);
2105              
2106             } elsif ($t == OP_DIE() ||
2107             $t == OP_WARN()) {
2108              
2109             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($ANY));
2110             ($realResult, $realReturn) = (undef, myUnify($env, $r));
2111              
2112             } elsif ($t == OP_EXIT()) {
2113              
2114             my ($t, $r);
2115             if ($op->flags & B::OPf_KIDS()) {
2116             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2117             }
2118              
2119             ($realResult, $realReturn) = (undef, $r);
2120              
2121             } elsif ($t == OP_RETURN()) {
2122            
2123             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv, LIST());
2124              
2125             ($realResult, $realReturn) = ($t, $t);
2126              
2127             } elsif ($t == OP_METHOD() ||
2128             $t == OP_METHOD_NAMED()) {
2129              
2130             ($realResult, $realReturn) = ($env->genRho($env->freshZeta), undef);
2131              
2132             } elsif ($t == OP_GREPWHILE() ||
2133             $t == OP_MAPWHILE()) {
2134            
2135             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2136             ($realResult, $realReturn) = (contextPick($context, $t, $env->freshKappa), $r);
2137              
2138             } elsif ($t == OP_CUSTOM()) {
2139            
2140             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2141             ($realResult, $realReturn) = ($env->fresh, $r);
2142              
2143             } elsif ($t == OP_FLIP() ||
2144             $t == OP_FLOP()) {
2145              
2146             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, $context);
2147             myUnify($env, ,$t, $env->genOmicron());
2148             ($realResult, $realReturn) = ($t, $r);
2149              
2150             } elsif ($t == OP_DEFINED() ||
2151             $t == OP_UNTIE() ||
2152             $t == OP_LOCK()) {
2153              
2154             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2155             ($realResult, $realReturn) = ($IV, $r);
2156              
2157             } elsif ($t == OP_CHOP() ||
2158             $t == OP_CHOMP()) {
2159              
2160             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, LIST());
2161             ($realResult, $realReturn) = ($env->genOmicron($env->freshUpsilon), $r);
2162              
2163             } elsif ($t == OP_SORT()) {
2164              
2165             my ($t, $r);
2166              
2167             # If the first argument is a scope or a bareword
2168             if ($op->first()->sibling()->type() == OP_NULL() &&
2169             ($op->first()->sibling()->first()->type() == OP_SCOPE() ||
2170             ($op->first()->sibling()->first()->type() == OP_CONST() &&
2171             $op->first()->sibling()->first()->private & 64) ||
2172             ($op->first()->sibling()->first()->type() == OP_NULL() &&
2173             $op->first()->sibling()->first()->first()->type() == OP_ENTER()))) {
2174             # Type it but don't do anything
2175             typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2176             typeOp($op->first()->sibling(), $pad2type, $env, $cv, SCALAR());
2177              
2178             # Type the rest
2179             ($t, $r) = typeOpChildrenSkip($op, $pad2type, $env, $cv, LIST(), 2);
2180              
2181             } else {
2182             # Otherwise type everything
2183             ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv, LIST());
2184             }
2185              
2186             my $list = $env->genOmicron($env->freshKappa);
2187              
2188             myUnify($env, $list, $t);
2189              
2190             ($realResult, $realReturn) = ($list, $r);
2191              
2192             } elsif ($t == OP_REVERSE()) {
2193              
2194             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv, LIST());
2195             my $list;
2196              
2197             if ($context == SCALAR()) {
2198             $list = $env->genOmicron($PV);
2199             myUnify($env, $list, $t);
2200             ($realResult, $realReturn) = ($PV, $r);
2201             } else {
2202             $list = $env->genOmicron($env->freshKappa);
2203             myUnify($env, $list, $t);
2204             ($realResult, $realReturn) = ($list, $r);
2205             }
2206            
2207             } elsif ($t == OP_EXEC() ||
2208             $t == OP_KILL() ||
2209             $t == OP_SYSCALL()) {
2210            
2211             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv);
2212             ($realResult, $realReturn) = ($IV, $r);
2213            
2214             } elsif ($t == OP_SETPRIORITY() ||
2215             $t == OP_SHMGET() ||
2216             $t == OP_SHMCTL() ||
2217             $t == OP_MSGCTL() ||
2218             $t == OP_SEMGET()){
2219              
2220             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV, $IV));
2221             ($realResult, $realReturn) = ($IV, $r);
2222              
2223             } elsif ($t == OP_VALUES()) {
2224              
2225             # All values must be able to unify if values() is used.
2226             my $list = $env->genChi($env->freshKappa);
2227             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($list));
2228             ($realResult, $realReturn) = ($list, $r);
2229              
2230             } elsif ($t == OP_KEYS()) {
2231              
2232             # All keys are of type Upsilon
2233             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($env->genChi()));
2234             ($realResult, $realReturn) = ($env->genOmicron($env->freshUpsilon), $r);
2235              
2236             } elsif ($t == OP_EACH()) {
2237              
2238             my $hash = $env->genChi($env->freshKappa);
2239             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($hash));
2240             ($realResult, $realReturn) = ($hash->subtype, $r);
2241              
2242             } elsif ($t == OP_LSLICE()) {
2243              
2244             # lslice is what you get when you do ("a", "b")[2, 3]
2245              
2246             my $list = $env->genOmicron();
2247             my $selection = $env->genOmicron($IV);
2248              
2249             # This should
2250             # Typecheck as (list, undistinguished)
2251             # return the list type
2252             my ($realReturn, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($selection, $list));
2253            
2254             my $consts = extractConstList($op->first(), $cv);
2255              
2256             # If the slice is an array of constants
2257             if (defined($consts)) {
2258             # Project a tuple
2259             $realResult = $env->genOmicron();
2260             foreach my $i (@$consts) {
2261             $realResult = $realResult->append($list->derefIndex($i, $env), $env);
2262             }
2263             } else {
2264             # Project a list
2265             $realResult = $env->genOmicron($env->freshKappa);
2266             myUnify($env, $realResult, $list);
2267             }
2268              
2269             # If we're in a scalar context and there is only one operand
2270             # describing the projection, dereference the type for the
2271             # zeroth index. This works if it's a tuple, since the
2272             # assertion about $op->first()->first()->sibling()->sibling() ensures
2273             # that there is only one element in the $realResult. The type
2274             # at the zeroth index may also be the homogeneous type.
2275             if ($context == SCALAR() &&
2276             $op->first()->first()->sibling()->sibling()->isa("B::NULL")) {
2277             $realResult = $realResult->derefIndex(0, $env);
2278             }
2279            
2280             } elsif ($t == OP_TIED()) {
2281              
2282             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($env->fresh));
2283             ($realResult, $realReturn) = ($env->fresh, $r);
2284              
2285             } elsif ($t == OP_REPEAT()) {
2286             my ($t, $r, $t0, $r0);
2287              
2288             my @rets;
2289              
2290             # List repeat
2291             if ($op->private & 64) {
2292             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, LIST());
2293              
2294             @rets = ($r);
2295             if (${$op->last}) {
2296             ($t0, $r0) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
2297             myUnify($env, $t0, $IV);
2298             push(@rets, $r0) if ($r0);
2299             }
2300              
2301             # Turn the type in to a list, if possible.
2302             myUnify($env, $t, $env->genOmicron($env->freshKappa));
2303              
2304             ($realResult, $realReturn) = ($t, myUnify($env, @rets));
2305             } else {
2306             # PV repeat
2307             ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2308             myUnify($env, $t, $PV);
2309             push(@rets, $r0) if ($r);
2310              
2311             ($t0, $r0) = typeOp($op->last, $pad2type, $env, $cv, SCALAR());
2312             myUnify($env, $t0, $IV);
2313             push(@rets, $r0) if ($r0);
2314              
2315             ($realResult, $realReturn) = ($PV, myUnify($env, @rets));
2316             }
2317              
2318             } elsif ($t == OP_CALLER()) {
2319              
2320             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($IV));
2321             ($realResult, $realReturn) = (contextPick($context, $env->genOmicronTuple($PV, $PV, $IV, $PV, $IV, $IV, $PV, $IV, $IV, $IV), $PV), $r);
2322              
2323             } elsif ($t == OP_RANGE()) {
2324              
2325             my $scalar = $env->freshUpsilon();
2326             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($scalar, $scalar));
2327             ($realResult, $realReturn) = ($env->genOmicron($scalar), $r);
2328              
2329             } elsif ($t == OP_RESET()) {
2330              
2331             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($PV));
2332             ($realResult, $realReturn) = ($IV, $r);
2333              
2334             } elsif ($t == OP_CLOSE() ||
2335             $t == OP_FILENO() ||
2336             $t == OP_EOF() ||
2337             $t == OP_TELL() ||
2338             $t == OP_TELLDIR() ||
2339             $t == OP_REWINDDIR() ||
2340             $t == OP_CLOSEDIR()) {
2341            
2342             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($env->freshEta));
2343             ($realResult, $realReturn) = ($IV, $r);
2344              
2345             } elsif ($t == OP_UMASK()) {
2346              
2347             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($PV));
2348             ($realResult, $realReturn) = ($IV, $r);
2349              
2350             } elsif ($t == OP_DBMCLOSE()) {
2351              
2352             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($env->genChi()));
2353             ($realResult, $realReturn) = ($IV, $r);
2354              
2355             } elsif ($t == OP_MKDIR()) {
2356              
2357             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $IV));
2358             ($realResult, $realReturn) = ($IV, $r);
2359              
2360             } elsif ($t == OP_READDIR()) {
2361            
2362             my ($r, $missing) = typeProtoOp($op, $pad2type, $env, $cv, ($env->freshEta));
2363             ($realResult, $realReturn) = (contextPick($context, $env->genOmicron($PV), $PV), $r);
2364              
2365             } elsif ($t == OP_INDEX() ||
2366             $t == OP_RINDEX()) {
2367              
2368             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $PV, $IV));
2369             ($realResult, $realReturn) = ($IV, $r);
2370              
2371             } elsif ($t == OP_RENAME() ||
2372             $t == OP_LINK() ||
2373             $t == OP_SYMLINK()) {
2374              
2375             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $PV));
2376             ($realResult, $realReturn) = ($IV, $r);
2377              
2378             } elsif ($t == OP_CRYPT()) {
2379              
2380             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $PV));
2381             ($realResult, $realReturn) = ($PV, $r);
2382              
2383             } elsif ($t == OP_FLOCK() ||
2384             $t == OP_BIND() ||
2385             $t == OP_CONNECT() ||
2386             $t == OP_SHUTDOWN() ||
2387             $t == OP_SEEKDIR()) {
2388              
2389             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $IV));
2390             ($realResult, $realReturn) = ($IV, $r);
2391              
2392             } elsif ($t == OP_SYSSEEK() ||
2393             $t == OP_SEEK() ||
2394             $t == OP_FCNTL() ||
2395             $t == OP_IOCTL() ||
2396             $t == OP_GSOCKOPT()) {
2397              
2398             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $IV, $IV));
2399             ($realResult, $realReturn) = ($IV, $r);
2400              
2401             } elsif ($t == OP_SYSREAD() ||
2402             $t == OP_SYSWRITE() ||
2403             $t == OP_READ() ||
2404             $t == OP_SEND() ||
2405             $t == OP_RECV()) {
2406              
2407             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $env->freshKappa, $IV, $IV));
2408             ($realResult, $realReturn) = ($IV, $r);
2409              
2410             } elsif ($t == OP_PIPE_OP() ||
2411             $t == OP_ACCEPT()) {
2412              
2413             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $env->freshEta));
2414             ($realResult, $realReturn) = ($IV, $r);
2415              
2416             } elsif ($t == OP_BINMODE() ||
2417             $t == OP_OPEN_DIR()) {
2418              
2419             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $PV));
2420             ($realResult, $realReturn) = ($IV, $r);
2421              
2422             } elsif ($t == OP_SOCKET()) {
2423              
2424             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $IV, $IV, $IV));
2425             ($realResult, $realReturn) = ($IV, $r);
2426              
2427             } elsif ($t == OP_OPEN() ||
2428             $t == OP_UTIME()) {
2429              
2430             # This operator is way too overloaded:
2431             # OP_OPEN IV = fop(MKPMH(a, ...) [, PV [, PV|MKPMH(b, ...) [, ...]]]) | op()
2432              
2433             my ($t, $r) = typeOpChildren($op, $pad2type, $env, $cv);
2434             ($realResult, $realReturn) = ($IV, $r);
2435              
2436             } elsif ($t == OP_SYSOPEN()) {
2437              
2438             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $PV, $IV, $IV));
2439             ($realResult, $realReturn) = ($IV, $r);
2440              
2441             } elsif ($t == OP_SOCKPAIR()) {
2442              
2443             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $env->freshEta, $IV ,$IV, $IV));
2444             ($realResult, $realReturn) = ($IV, $r);
2445              
2446             } elsif ($t == OP_SSOCKOPT()) {
2447              
2448             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshEta, $IV, $IV, $env->freshKappa));
2449             ($realResult, $realReturn) = ($IV, $r);
2450              
2451             } elsif ($t == OP_SPRINTF() ||
2452             $t == OP_FORMLINE()) {
2453              
2454             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $ANY));
2455             ($realResult, $realReturn) = ($PV, $r);
2456              
2457             } elsif ($t == OP_PACK()) {
2458              
2459             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $ANY));
2460             ($realResult, $realReturn) = ($IV, $r);
2461              
2462             } elsif ($t == OP_UNPACK()) {
2463             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $IV));
2464             ($realResult, $realReturn) = ($env->genOmicron($env->freshUpsilon), $r);
2465              
2466             } elsif ($t == OP_MSGGET() ||
2467             $t == OP_SEMOP()) {
2468              
2469             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV));
2470             ($realResult, $realReturn) = ($IV, $r);
2471              
2472             } elsif ($t == OP_SHMREAD() ||
2473             $t == OP_SHMWRITE()) {
2474              
2475             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $PV, $IV, $IV));
2476             ($realResult, $realReturn) = ($IV, $r);
2477              
2478             } elsif ($t == OP_MSGSND()) {
2479              
2480             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $PV, $IV, $IV, $IV));
2481             ($realResult, $realReturn) = ($IV, $r);
2482              
2483             } elsif ($t == OP_SEMCTL()) {
2484              
2485             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV, $IV, $IV));
2486             ($realResult, $realReturn) = ($IV, $r);
2487              
2488             } elsif ($t == OP_MSGRCV()) {
2489              
2490             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $PV, $IV));
2491             ($realResult, $realReturn) = ($IV, $r);
2492              
2493             } elsif ($t == OP_TRUNCATE()) {
2494              
2495             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $IV));
2496             ($realResult, $realReturn) = ($IV, $r);
2497              
2498             } elsif ($t == OP_CHOWN()) {
2499              
2500             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV, $ANY));
2501             ($realResult, $realReturn) = ($IV, $r);
2502              
2503             } elsif ($t == OP_CHMOD()) {
2504              
2505             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $ANY));
2506             ($realResult, $realReturn) = ($IV, $r);
2507              
2508             } elsif ($t == OP_PRTF()) {
2509              
2510             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($ANY));
2511             ($realResult, $realReturn) = ($IV, $r);
2512              
2513             } elsif ($t == OP_SSELECT()) {
2514              
2515             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($IV, $IV, $IV, $env->freshKappa));
2516             ($realResult, $realReturn) = (contextPick($context, $env->genOmicronTuple($IV, $DV), $IV), $r);
2517              
2518             } elsif ($t == OP_SELECT()) {
2519              
2520             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->fresh));
2521             ($realResult, $realReturn) = ($PV, $r);
2522              
2523             } elsif ($t == OP_TIE()) {
2524              
2525             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->fresh, $PV, $ANY));
2526             ($realResult, $realReturn) = (undef, $r);
2527              
2528             } elsif ($t == OP_STRINGIFY()) {
2529              
2530             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshKappa));
2531             ($realResult, $realReturn) = ($PV, $r);
2532              
2533             } elsif ($t == OP_SUBSTR()) {
2534              
2535             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($PV, $IV, $IV, $IV));
2536             ($realResult, $realReturn) = ($PV, $r);
2537              
2538             } elsif ($t == OP_VEC()) {
2539              
2540             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->freshKappa, $IV, $IV));
2541             ($realResult, $realReturn) = ($IV, $r);
2542              
2543             } elsif ($t == OP_ASLICE()) {
2544              
2545             my $list = $env->genOmicron($env->freshKappa);
2546             my $select = $env->genOmicron($IV);
2547             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($select, $list));
2548             ($realResult, $realReturn) = ($list, $r);
2549              
2550             } elsif ($t == OP_HSLICE()) {
2551              
2552             my $hash = $env->genChi($env->freshKappa);
2553             my $select = $env->genOmicron($PV);
2554             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($select, $hash));
2555             ($realResult, $realReturn) = ($env->genOmicron($hash->derefHomogeneous()), $r);
2556              
2557             } elsif ($t == OP_ANONHASH()) {
2558              
2559             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($ANY));
2560             ($realResult, $realReturn) = ($env->genChi(), $r);
2561              
2562             } elsif ($t == OP_SPLICE()) {
2563              
2564             my $ary = $env->genOmicron($env->freshKappa);
2565             my $list = $env->genOmicron($env->freshKappa);
2566             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($ary, $IV, $IV, $list));
2567              
2568             # Unify the two, to make sure we're not inserting incompatible junk in to the array
2569             myUnify($env, $ary, $list);
2570              
2571             ($realResult, $realReturn) = ($ary, $r);
2572              
2573             } elsif ($t == OP_GREPSTART()) {
2574              
2575             my $type = $env->genOmicron($env->freshKappa);
2576             my @results;
2577             my @returns;
2578              
2579             my $subop = $op->first()->sibling();
2580              
2581             # Type the first as an integer
2582             my ($t, $r) = typeOp($subop, $pad2type, $env, $cv, SCALAR());
2583             myUnify($env, $t, $IV);
2584              
2585             # Smash the rest in to a list
2586             for (my $kid = $subop->sibling(); $$kid; $kid = $kid->sibling()) {
2587             # Type the kid
2588             my ($s, $r) = typeOp($kid, $pad2type, $env, $cv, LIST());
2589            
2590             if (defined($s)) {
2591             push(@results, $s);
2592             }
2593            
2594             # Set up unify of return values from down in the tree
2595             if (defined($r)) {
2596             push(@returns, $r);
2597             }
2598             }
2599             my $result = smash(\@results, $env);
2600             myUnify($env, $result, $type);
2601             myUnify($env, @returns, $r);
2602              
2603             ($realResult, $realReturn) = ($type, $r);
2604              
2605             } elsif ($t == OP_MAPSTART()) {
2606              
2607             my $type = $env->freshKappa;
2608             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($type, $env->genOmicron($type)));
2609             ($realResult, $realReturn) = ($env->genOmicron($type), $r);
2610              
2611             } elsif ($t == OP_DBMOPEN()) {
2612              
2613             my ($r, $missing) = typeProto($op, $pad2type, $env, $cv, ($env->genChi(), $PV, $IV));
2614             ($realResult, $realReturn) = ($IV, $r);
2615              
2616             } elsif ($t == OP_LENGTH()) {
2617              
2618             my ($t, $r) = typeOp($op->first(), $pad2type, $env, $cv, SCALAR());
2619             myUnify($env, $t, $PV);
2620             ($realResult, $realReturn) = ($IV, $r);
2621              
2622             } else {
2623              
2624             # OP_LEAVEEVAL() is here implicitly
2625             # OP_THREADSV() is here implicitly
2626            
2627             verbose("Typing for OP ", $t, " is unimplemented\n");
2628              
2629             # Try to do something sane depending on context
2630             if ($context == SCALAR()) {
2631             ($realResult, $realReturn) = ($env->fresh, undef);
2632             } else {
2633             ($realResult, $realReturn) = ($env->genOmicron(), undef);
2634             }
2635              
2636             }
2637              
2638             if (defined($realReturn)) {
2639             verbose(" " x $depth, " ", "non-null return value ", myPrint($env->find($realReturn), $env));
2640             }
2641              
2642             verbose(" " x $depth, "} = ", $realResult?myPrint($env->find($realResult), $env):"void");
2643             $depth -= $depthIncrement;
2644              
2645             return ($realResult, $realReturn);
2646             }
2647              
2648             sub typecheck {
2649             my ($op, $cv, $env) = @_;
2650              
2651             my $pad2type = Devel::TypeCheck::Pad2type->new();
2652              
2653             my ($resType, $retType) = typeOp($op, $pad2type, $env, $cv, SCALAR());
2654              
2655             $resType = $resType?($env->find($resType)):undef;
2656             $retType = $retType?($env->find($retType)):undef;
2657              
2658             $pad2type->print(\*STDOUT, $cv, $env);
2659              
2660             return ($resType, $retType);
2661             }
2662              
2663             sub B::GV::subscribe {
2664             my ($this) = @_;
2665              
2666             no strict 'refs';
2667             my $refname = $this->STASH->NAME . "::" . $this->NAME;
2668             if (*{$refname}{CODE}) {
2669             my %cur;
2670             my $ref = \&{$refname};
2671             my $cv = B::svref_2object($ref);
2672             my $op = $cv->ROOT;
2673             if (!$op->isa("B::NULL")) {
2674             $cur{'op'} = $op;
2675             $cur{'cv'} = $cv;
2676             my $name = $this->STASH->NAME . "::" . $this->SAFENAME;
2677             $roots{$name} = \%cur;
2678             }
2679             }
2680             }
2681              
2682             sub checkCV {
2683             my ($env, $op, $cv, $name) = @_;
2684              
2685             my $storedDepth = $depth;
2686             $depth = 0;
2687              
2688             # Ad-hoc change to localize *_
2689             $glob2type->del("main::_");
2690              
2691             eval {
2692             $depth = 0;
2693             my ($t, $r) = typecheck($op, $cv, $env);
2694             # glob->get always returns an Eta
2695             my $p = $glob2type->get("main::_", $env)->derefOmicron();
2696              
2697             if (defined($p)) {
2698             print(" Parameter type of $name is ", myPrint($p, $env), "\n");
2699             } else {
2700             print(" Parameter type of $name is undefined\n");
2701             }
2702              
2703             if (defined($t)) {
2704             print(" Result type of $name is ", myPrint($t, $env), "\n");
2705             } else {
2706             print(" Result type of $name is undefined\n");
2707             }
2708             if (defined($r)) {
2709             print(" Return type of $name is ", myPrint($r, $env), "\n");
2710              
2711             # Assign type to the current CV
2712             my $iType = $glob2type->get($name, $env)->derefZeta();
2713             my $infType = $env->genZeta($p, $r);
2714             myUnify($env, $iType, $infType);
2715             } else {
2716             print(" Return type of $name is undefined\n");
2717             }
2718             print("\n");
2719             };
2720            
2721             if ($@) {
2722             if ($@ =~ /^TYPE ERROR:/ && $continue) {
2723             print($@, "\n");
2724             } else {
2725             die($@);
2726             }
2727             }
2728              
2729             # Ad-hoc change to localize *_
2730             $glob2type->del("main::_");
2731              
2732             $depth = $storedDepth;
2733             }
2734              
2735             sub callback {
2736             if ($relax) {
2737             $inferLogop = \&inferUpsilon;
2738             } else {
2739             $inferLogop = \&inferNu;
2740             }
2741              
2742             for my $name (@modules) {
2743             no strict 'refs';
2744             B::walksymtable(\%{$name}, 'subscribe', sub { return FALSE() }, $name);
2745             }
2746              
2747             for my $name (@cvnames) {
2748             # From B::Concise::compile
2749             $name = "main::" . $name unless $name =~ /::/;
2750              
2751             no strict 'refs';
2752             die "err: unknown function ($name)\n"
2753             unless *{$name}{CODE};
2754             my $ref = \&$name;
2755              
2756             # &From B::Concise::concise_subref
2757             my $cv = B::svref_2object($ref);
2758             die "err: not a coderef: $ref\n" unless ref $cv eq 'B::CV';#CODE';
2759              
2760             my $op = $cv->ROOT;
2761              
2762             my %cur;
2763             $cur{'op'} = $op;
2764             $cur{'cv'} = $cv;
2765             $roots{$name} = \%cur;
2766             }
2767              
2768             if ($all) {
2769             no strict 'refs';
2770             B::walksymtable(\%{"main::"}, 'subscribe', sub { return TRUE() }, undef);
2771             }
2772              
2773             if ($mainRoot) {
2774             my %cur;
2775             $cur{'op'} = B::main_root();
2776             $cur{'cv'} = B::main_cv();
2777             $roots{'main::MAIN'} = \%cur;
2778             }
2779              
2780             $glob2type = Devel::TypeCheck::Glob2type->new();
2781              
2782             my $env = Devel::TypeCheck::Environment->new();
2783              
2784             print("Type checking CVs:\n");
2785             @list = keys(%roots);
2786             while ($#list >= 0) {
2787             # next unless (blessed($i));
2788             my $i = shift(@list);
2789             print(" $i\n");
2790             checkCV($env, $roots{$i}->{'op'}, $roots{$i}->{'cv'}, $i)
2791             }
2792              
2793             my ($i, $t);
2794              
2795             print STDOUT ("Global Symbol Table Types:\n");
2796             print STDOUT ("Name Type\n");
2797             print STDOUT ("------------------------------------------------------------------------------\n");
2798              
2799             format STDOUT =
2800             @<<<<<<<<<<<<<<<<<< @*
2801             $i, $t
2802             .
2803            
2804             for $i (sort($glob2type->symbols)) {
2805             $t = myPrint($glob2type->get($i, $env), $env);
2806             write STDOUT;
2807             }
2808              
2809             print("Total opcodes processed: $opcodes\n");
2810             }
2811              
2812             1;