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	sub	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 getby 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;