Extract more symbolic information from the tree.
[panamaz] / src / generate-api
1 #!/usr/bin/perl
2
3 # replace a datatype with another, do not generate any code for it
4 # -r name=new
5
6 @matchStruct = ();
7 $meta = "";
8 # @classes = ( { name => 'class', match => [ func-pattern, ... ], match_file => [ file, ... ], enum => [ enum-pattern, ... ], enum_file => [ file, ...] } )
9 @classes = ();
10 %class = ();
11 $output = ".";
12 # map call signatures to a class name
13 %callMap = ();
14 $package = "";
15 %replace = ();
16 # calls take raw types and throw Throwable
17 $rawCalls = 0;
18
19 while (@ARGV) {
20     my $cmd = shift(@ARGV);
21
22     if ($cmd eq "-f") {
23         my $v = shift(@ARGV);
24         push @{$class{match}}, qr/$v/;
25     } elsif ($cmd eq "--func-file") {
26         my $file = shift(@ARGV);
27
28         push @{$class{match_file}}, $file;
29         push @{$class{match}}, readMatchFile($file);
30     } elsif ($cmd eq "-e") {
31         my $v = shift(@ARGV);
32         push @{$class{enum}}, qr/$v/;
33     } elsif ($cmd eq "--enum-file") {
34         my $file = shift(@ARGV);
35         push @{$class{enum_file}}, $file;
36         push @{$class{enum}}, readMatchFile($file);
37     } elsif ($cmd eq "-s") {
38         my $v = shift(@ARGV);
39         push @matchStruct, qr/$v/;
40     } elsif ($cmd eq "--struct-file") {
41         my $file = shift(@ARGV);
42         push @matchStruct, readMatchFile($file);
43     } elsif ($cmd eq "-r") {
44         my $v = shift(@ARGV);
45
46         $v =~ m/(.*)=(.*)/;
47         $replace{$1} = $2;
48     } elsif ($cmd eq "--raw-calls") {
49         $rawCalls = 1;
50     } elsif ($cmd eq "-t") {
51         $package = shift(@ARGV);
52     } elsif ($cmd eq "-c") {
53         my %new = (
54             name => shift(@ARGV),
55             match => [],
56             match_file => [],
57             enum => [],
58             enum_file => [],
59             libs => []);
60         push @classes, \%new;
61         %class = %new;
62         print "new:\n".Dumper(\%class);
63     } elsif ($cmd =~ m/^-l(.*)/) {
64         push @{$class{libs}}, $1;
65     } elsif ($cmd eq "-d") {
66         $output = shift(@ARGV);
67     } elsif ($cmd eq "--enclosing-type") {
68         $enclosingType = shift(@ARGV);
69     } else {
70         $meta = $cmd;
71     }
72 }
73
74 $importPointer = "import api.Native.Pointer;" if (!$rawCalls);
75
76 print "import poirnter: $importPointer\n";
77 use Data::Dumper;
78
79 require $meta;
80
81 # box types for primitives
82 %map_box = (
83     "long" => "Long",
84     "int" => "Integer",
85     "short" => "Short",
86     "char" => "Character",
87     "float" => "Float",
88     "double" => "Double",
89     "byte" => "Byte",
90     "void" => "Void"
91     );
92
93 sub readMatchFile {
94     my $path = shift @_;
95     my @lines = ();
96
97     open(my $f,"<$path");
98     while (<$f>) {
99         chop;
100         next if m/^#/;
101
102         #push @lines, qr/\^$_\$/;
103         push @lines, $_;
104     }
105     close($f);
106
107     my $all = join ('|', @lines);
108
109     return qr/^($all)$/;
110 }
111
112 sub camelCase {
113     my $name = shift @_;
114
115     $name =~ s/_(.)/uc($1)/eg;
116
117     return $name;
118 }
119
120 sub StudlyCaps {
121     my $name = shift @_;
122
123     # hack, or good spot for it?
124     return $replace{$name} if $replace{$name};
125
126     $name =~ s/^(.)/uc($1)/e;
127     $name =~ s/_(.)/uc($1)/eg;
128
129     return $name;
130 }
131
132
133 sub structSignature {
134     my %struct = %{shift(@_)};
135     my $union = shift(@_);
136     my $sig = "";
137     my @fields = @{$struct{fields}};
138     my $offset = 0;
139
140     my $inbf = 0;
141     my $bfoffset = 0;
142     my $bfstart = 0;
143     my $bfsig = "";
144
145     for $fi (@fields) {
146         my %field = %{$fi};
147         my $off = $field{offset};
148
149         # bitfields, this only handles 1x u64 bitfield section
150         #  They need to: align to u32/u64
151         #  Group fields into one full u32/u64
152         # TODO: check alignment @ start?
153         # TODO: clean up and complete
154         # TODO: bitfields in unions are probably broken
155         if ($field{ctype} eq 'bitfield') {
156             if ($inbf) {
157                 if ($off - $offset) {
158                     $bfsig .= "x";
159                     $bfsig .= ($off - $offset);
160                 }
161                 $bfsig .= $field{type};
162                 $bfsig .= "($field{name})";
163                 $offset = $off + $field{size};
164             } else {
165                 $inbf = 1;
166                 $bfsig = $field{type};
167                 $bfsig .= "($field{name})";
168                 $offset = $off + $field{size};
169                 $bfstart = $field{offset};
170             }
171
172             if ($union) {
173                 $inbf = 0;
174
175                 if (($offset - $bfstart) == 32) {
176                     $bfsig = "u32=[$bfsig]";
177                 } elsif (($offset - $bfstart) < 32) {
178                     $bfsig .= "x";
179                     $bfsig .= 32 - ($offset - $bfstart);
180                     $offset = $bfstart + 32;
181                     $bfsig = "u32=[$bfsig]";
182                 } elsif (($offset - $bfstart) == 64) {
183                     $bfsig = "u64=[$bfsig]";
184                 } elsif (($offset - $bfstart) < 64) {
185                     $bfsig .= "x";
186                     $bfsig .= 64 - ($offset - $bfstart);
187                     $offset = $bfstart + 64;
188                     $bfsig = "u64=[$bfsig]";
189                 }
190
191                 $sig .= $bfsig;
192                 $sig .= "|" if ($union && $fi != @fields[$#fields]);
193             }
194             next;
195         } elsif ($inbf) {
196             if (($offset - $bfstart) == 32) {
197                 $bfsig = "u32=[$bfsig]";
198             } elsif (($offset - $bfstart) < 32) {
199                 $bfsig .= "x";
200                 $bfsig .= 32 - ($offset - $bfstart);
201                 $offset = $bfstart + 32;
202                 $bfsig = "u32=[$bfsig]";
203             } elsif (($offset - $bfstart) == 64) {
204                 $bfsig = "u64=[$bfsig]";
205             } elsif (($offset - $bfstart) < 64) {
206                 $bfsig .= "x";
207                 $bfsig .= 64 - ($offset - $bfstart);
208                 $offset = $bfstart + 64;
209                 $bfsig = "u64=[$bfsig]";
210             }
211             $sig .= $bfsig;
212             $inbf = 0;
213         }
214
215         # skip to next offset if necessary
216         if ($off > $offset) {
217             $sig .= "x";
218             $sig .= ($off - $offset);
219         }
220         $offset = $off + $field{size};
221
222         # normal field processing
223         if ($field{deref}) {
224             my $deref = $field{deref};
225
226             # HACK: function -> Void
227         #   if ($field{debug} eq 'function') {
228         #       $sig .= "u64($field{name}):v";
229         #    } els
230                 if ($deref =~ m/^(u\d\d)(:.*)/) {
231                 $sig .= "$1($field{name})$2";
232             } else {
233                 $sig .= "$deref($field{name})";
234             }
235         } else {
236             if ($field{type} =~ m/(struct|union):(.*)/) {
237                 $sig .= "\${$2}";
238             } elsif ($field{type} =~ m/([iuf])(\d+)/) {
239                 $sig .= $1;
240                 $sig .= $2;
241             } elsif ($field{type} eq 'void') {
242                 $sig .= "v";
243             } elsif ($field{type} eq 'enum') {
244                 # FIXME: set type in compiler
245                 $sig .= "u32";
246             }
247
248             $sig .= "($field{name})";
249         }
250
251         $sig .= "|" if ($union && $fi != @fields[$#fields]);
252     }
253
254     # finish any trailing bitfield
255     # TODO: cleanup
256     if ($inbf) {
257         if (($offset - $bfstart) == 32) {
258             $bfsig = "u32=[$bfsig]";
259         } elsif (($offset - $bfstart) < 32) {
260             $bfsig .= "x";
261             $bfsig .= 32 - ($offset - $bfstart);
262             $offset = $bfstart + 32;
263             $bfsig = "u32=[$bfsig]";
264         } elsif (($offset - $bfstart) == 64) {
265             $bfsig = "u64=[$bfsig]";
266         } elsif (($offset - $bfstart) < 64) {
267             $bfsig .= "x";
268             $bfsig .= 64 - ($offset - $bfstart);
269             $offset = $bfstart + 64;
270             $bfsig = "u64=[$bfsig]";
271         }
272         #$bfsig .= "]";
273         $sig .= $bfsig;
274     }
275
276     return "[".$sig."]";
277 }
278
279 sub funcSignature {
280     my %func = %{shift(@_)};
281     my $sig = "";
282     my @params = @{$func{arguments}};
283
284     for $pi (@params) {
285         my %param = %{$pi};
286
287         if ($param{deref}) {
288             # HACK: function to void
289             if ($param{debug} eq "function") {
290                 $sig .= "u64:v";
291             } else {
292                 $sig .= $param{deref};
293             }
294         } else {
295             if ($param{type} =~ m/struct:(.*)/) {
296                 $sig .= "\${$1}";
297             } elsif ($param{type} =~ m/([iuf])(\d*)/) {
298                 $sig .= $1;
299                 $sig .= $2;
300             } elsif ($param{type} eq "void") {
301                 $sig .= "v";
302             }
303         }
304     }
305
306     my %result = %{$func{result}};
307     my $ret = "";
308
309     if ($result{deref}) {
310         $ret .= $result{deref};
311     } else {
312         if ($result{type} =~ m/^struct:(.*)/) {
313             $ret .= "\${$1}";
314         } elsif ($result{type} =~ m/^([iuf])(\d+)/) {
315             $ret .= $1;
316             $ret .= $2;
317         } elsif ($result{type} eq "void") {
318             $ret .= "v";
319         }
320     }
321
322     return "($sig)$ret";
323 }
324
325 sub deref {
326     my $type = shift @_;
327     my $ref = shift @_;
328
329     while ($ref) {
330         if ($ref =~ m/\[\d*(.*)\]/) {
331             my $sub = deref($type, $1);
332
333             return "Array<$sub>";
334         } elsif ($ref =~ m/^u64:\$/) {
335             # ignore penultimate pointer?
336             last;
337         } elsif ($ref =~ m/^u64:(.*)/) {
338             $type = "Pointer<$type>";
339             $ref = $1;
340         } else {
341             last;
342         }
343     }
344     return $type;
345 }
346
347 sub typeToJava {
348     my %param = %{shift(@_)};
349     my $type = $param{type};
350     my $ref = $param{deref};
351
352     if ($type =~ m/^struct:(.*)/) {
353         $type = $replace{$1} ? $replace{$1} : StudlyCaps($1);
354     } elsif ($type =~ m/call:/) {
355         # this re-writes ref to remove one pointer-to as the Callback absorbs it.
356         $type = "Callback<".$callMap{$type}.">";
357         $type || die ("No mapping for type ".Dumper(\%param));
358         $ref =~ s/^u(32|64)://;
359     } elsif ($type =~ m/^enum:(.*)/) {
360         # TODO: other enum options
361         $type = "int";
362     } elsif ($type eq "void") {
363         $type = "void";
364     } elsif ($type =~ m/^([iu])(\d*)/) {
365         my $sign = $1;
366         my $size = $2;
367
368         if ($size <= 8) {
369             $type = "byte";
370         } elsif ($size <= 16) {
371             if ($sign eq "i") {
372                 $type = "short";
373             } else {
374                 $type = "char";
375             }
376         } elsif ($size <= 32) {
377             $type = "int";
378         } else {
379             $type = "long";
380         }
381     } elsif ($type =~ m/^[f](\d*)$/) {
382         my $size = $1;
383
384         if ($size == 32) {
385             $type = "float";
386         } elsif ($size == 64) {
387             $type = "double";
388         }
389     }
390
391     if ($ref) {
392         $type = $map_box{$type} if ($map_box{$type});
393         $type = deref($type, $ref);
394     }
395
396     return $type;
397 }
398
399 sub typeToRaw {
400     my %param = %{shift(@_)};
401     my $type = $param{type};
402     my $ref = $param{deref};
403
404     my $type = typeToJava(\%param);
405
406     if ($ref =~ m/^u64:/) {
407         return "MemoryAddress";
408     } elsif ($type =~ m/^(struct|union):/) {
409         return "MemorySegment";
410     } else {
411         return $type;
412     }
413
414     # hackity hack
415 #    if ($type =~ "(Pointer|Array|Callback)") {
416 #       return "MemoryAddress";
417 #    } elsif ($type =~ m/^[A-Z]/) {
418 #       return "MemorySegment";
419 #    } else {
420 #       return $type;
421 #    }
422 }
423
424 sub testMatch {
425     my $name = shift @_;
426
427     if (@_) {
428         for $pat (@_) {
429             if ($name =~ /$pat/) {
430                 return 1;
431             }
432         }
433         return 0;
434     } else {
435         return 1;
436     }
437 }
438
439 # find all matching structures and then all that they require
440 sub findStructs {
441     my %all = %{shift @_};
442     my @match = @_;
443     my @stack = grep {
444         my %e = %{$all{$_}};
445         $e{type} =~ m/(struct|union)/ && !$replace{$e{name}} && testMatch($e{name}, @match);
446     } keys %all;
447     my %visit = ();
448
449     while (@stack) {
450         my $test = shift @stack;
451
452         if (!$visit{$test}) {
453             my %struct = %{$all{$test}};
454
455             $visit{$test} = 1;
456
457             if (%struct) {
458                 print "class: $struct{name}\n";
459                 # find all types this one uses
460                 for $f (@{$struct{fields}}) {
461                     my %field = %{$f};
462
463                     if ($field{type} =~ m/^(struct|union):(.*)/) {
464                         if (!$replace{$1} && !$set{$field{type}}) {
465                             $set{$field{type}} = $all{$field{type}};
466                             push @stack, $field{type};
467                         }
468                     }
469                 }
470             } else {
471                 # this is an anon type, typically used for handles
472                 $test =~ m/^(struct|union):(.*)/;
473                 if (!$replace{$2}) {
474                     print " anon: $2\n";
475                     my %rec = (
476                         type => 'struct',
477                         name => $2,
478                         size => 0
479                         );
480                     $data{$test} = \%rec;
481                 }
482             }
483         }
484     }
485     return grep { !$replace{$_} } keys(%visit);
486 }
487
488 sub findDefinition {
489     my %all = %{shift @_};
490     my $type = shift @_;
491     my @match = @_;
492     my @stack = grep {
493         my %e = %{$all{$_}};
494         $e{type} eq $type && testMatch($e{name}, @match);
495     } keys %all;
496
497     return @stack;
498 }
499
500 sub arrayInfo {
501     my $ref = shift @_;
502     my %info = (
503         dims => [],
504         );
505
506     print "array $ref\n";
507     while ($ref =~ m/^\[(\d*)(.*)\]$/) {
508         push @{$info{dims}}, $1;
509         $ref = $2;
510         print "dim $1 -, '$2'\n";
511     }
512     $info{deref} = $ref;
513
514     return %info;
515 }
516
517 # ######################################################################
518
519 # setup section
520
521 # find all classes used by functions
522 my %roots = ();
523 for $c (@classes) {
524     my %class = %{$c};
525     my @libs = @{$class{libs}};
526     my @match = @{$class{match}};
527
528     for $k (findDefinition(\%data, 'func', @match)) {
529         my %func = %{$data{$k}};
530         my @params = @{$func{arguments}};
531
532         for $pi (@params) {
533             my %param = %{$pi};
534
535             if ($param{type} =~ m/^(struct|union):(.*)/) {
536                 $roots{$2} = 1;
537             }
538         }
539
540         my %result = %{$func{result}};
541
542         if ($result{type} =~ m/^(struct|union):(.*)/) {
543             $roots{$2} = 1;
544         }
545     }
546 }
547
548 # add roots for any types used by calls
549 # FIXME: only include ones used elsewhere
550 for $k (grep { $_ =~ m/^call:/n } keys %data) {
551     my %func = %{$data{$k}};
552     my @params = @{$func{arguments}};
553
554     for $pi (@params) {
555         my %param = %{$pi};
556
557         if ($param{type} =~ m/^(struct|union):(.*)/) {
558             $roots{$2} = 1;
559         }
560     }
561
562     my %result = %{$func{result}};
563
564     if ($result{type} =~ m/^(struct|union):(.*)/) {
565         $roots{$2} = 1;
566     }
567 }
568
569 # Create anonymous structs for anything missing
570 for $k (keys %roots) {
571     my $s = 'struct:'.$k;
572     my $u = 'union:'.$k;
573
574     if (!$data{$u} && !$data{$s} && !$replace{$k}) {
575         print " xanon: $s\n";
576         my %rec = (
577             type => 'struct',
578             name => $k,
579             size => 0
580             );
581         $data{$s} = \%rec;
582     }
583 }
584
585 $all = join ('|', keys %roots);
586 if ($all) {
587     push @matchStruct, qr/^($all)$/;
588 }
589 print "structures:\n";
590 print Dumper(@matchStruct);
591
592 # make a map for all callbacks (call: type) to generated names
593 for $c (grep { $_ =~ m/^call:/n } keys %data) {
594     my $name = $c;
595
596     print "$c\n";
597     # enum maybe to int?
598
599     $name =~ s/^call:/Call/;
600     if ($rawCalls) {
601         $name =~ s/\$\{([^\}]*)\}/L/g;
602     } else {
603         while ($name =~ m/\$\{([^\}]*)\}/) {
604             my $x = $1;
605             if ($replace{$x}) {
606                 $x = $replace{$x};
607             } else {
608                 $x = StudlyCaps($x);
609             }
610             $name =~ s/\$\{([^\}]*)\}/L$x/;
611         }
612     }
613     $name =~ s/[ui](64|32):/p/g;
614     $name =~ s/[ui]64/J/g;
615     $name =~ s/[ui]32/I/g;
616     $name =~ s/[ui]8/B/g;
617     $name =~ s/f32/F/g;
618     $name =~ s/f64/D/g;
619     $name =~ s/[\[\]\(\)]/_/g;
620
621     $callMap{$c} = "$name";
622 }
623
624 print "call mappings\n";
625 print Dumper(\%callMap);
626
627 # ######################################################################
628 # Start output
629 my $dst;
630
631 use File::Basename;
632 use File::Path qw(make_path);
633
634 if ($package ne "") {
635     $packagePrefix = $package.".";
636 }
637
638 if ($enclosingType) {
639     my $classname = $packagePrefix.$enclosingType;
640
641     $classname =~ s@\.@/@g;
642
643     my $path = $output."/".$classname.".java";
644     my $dir = dirname($path);
645     my $class = basename($path, ".java");
646
647     print "path $path\n";
648     print "dirname $dir\n";
649
650     make_path($dir);
651     open ($dst, ">$path");
652
653     if ($package ne "") {
654         print $dst "package $package;\n";
655     }
656
657     print $dst <<END;
658 import java.foreign.Libraries;
659 import java.lang.invoke.MethodHandles;
660 import jdk.incubator.foreign.*;
661 import api.Native;
662 $importPointer
663 END
664     print $dst "public class $class {\n";
665 }
666
667 # ######################################################################
668 # This is work in progress, aka a total fucking mess
669 # Dump structures
670 for $k (findStructs(\%data, @matchStruct)) {
671     my %struct = %{$data{$k}};
672     my @fields = @{$struct{fields}};
673     my $signature = structSignature(\%struct, ($struct{type} eq "union"));
674     my $name = StudlyCaps($struct{name});
675
676     if (!$enclosingType) {
677         my $classname = $packagePrefix.$name;
678
679         open ($dst, ">$path");
680         $classname =~ s@\.@/@g;
681
682         my $path = $output."/".$classname.".java";
683         my $dir = dirname($path);
684         my $class = basename($path, ".java");
685         make_path($dir);
686         open ($dst, ">$path");
687
688         if ($package ne "") {
689             print $dst "package $package;\n";
690         }
691         print $dst <<END;
692 import jdk.incubator.foreign.*;
693 import api.Native;
694 $importPointer
695
696 END
697     }
698
699     print $dst "public class $name extends Native {\n";
700
701     print $dst "\tpublic $name(MemoryAddress p) {\n";
702     print $dst "\t\tsuper(p);\n";
703     print $dst "\t}\n";
704
705     for $fi (@fields) {
706         my %field = %{$fi};
707         my $type = typeToJava(\%field);
708         my $cc = StudlyCaps($field{name});
709
710         if ($field{deref} =~ m/^\[/) {
711             # array
712             my %info = arrayInfo($field{deref});
713             my @dims = @{$info{dims}};
714             $info{type} = $field{type};
715             my $atype = typeToJava(\%info);
716             my @strides = ();
717
718             my $stride = 1;
719             for $dim (reverse(0 .. $#dims)) {
720                 push @strides,$stride;
721                 $stride *= $dims[$dim];
722             }
723
724             if ($field{type} =~ m/^(struct|union):(.*)/) {
725                 for $dim (0 .. $#dims) {
726                     print $dst "// $dims[$dim]\n";
727                     }
728
729                 print $dst "public $atype get$cc(";
730                 for $dim (0 .. $#dims) {
731                     print $dst ", " if ($dim != 0);
732                     print $dst "int i$dim";
733                 }
734                 print $dst ") {\n";
735                 print $dst "\tint i=";
736                 for $dim (0 .. $#dims) {
737                     print $dst " + " if ($dim != 0);
738                     print $dst "(i$dim * $strides[$#dims - $dim])";
739                 }
740                 print $dst ";\n";
741                 print $dst "return Native.Pointer.ofAddress(addr().addOffset(i * 8), 32, Data::new);\n";
742                 print $dst "}\n";
743             } elsif ($field{type} =~ m/^call:/) {
744             } else {
745             }
746         } elsif ($field{deref} =~ m/^u64:\$/) {
747             # pointer-to-struct
748             if ($field{type} =~ m/^(struct|union):(.*)/) {
749                 my $ltype = StudlyCaps($2);
750                 my $offset = $field{offset} >> 3;
751                 my $addr = $offset ? "addr().addOffset($offset)" : 'addr()';
752
753                 my $size = %{$data{$field{type}}}{size} >> 3;
754
755                 print $dst "\tpublic $ltype get$cc() {\n";
756                 print $dst "\t\treturn $ltype.create(Native.getAddr($addr, $size));\n";
757                 print $dst "\t}\n";
758
759                 print $dst "\tpublic void set$cc($ltype v) {\n";
760                 print $dst "\t\tNative.setAddr($addr, v.addr());\n";
761                 print $dst "\t}\n";
762             }
763         } elsif ($field{deref} =~ m/^u64:u64:\$/) {
764             # pointer-to-pointer-to?
765             if ($field{type} =~ m/^(struct|union):(.*)/) {
766                 my $ltype = StudlyCaps($2);
767                 my $offset = $field{offset} >> 3;
768                 my $addr = $offset ? "addr().addOffset($offset)" : 'addr()';
769
770                 my $size = %{$data{$field{type}}}{size} >> 3;
771
772                 print $dst "\tpublic $type get$cc() {\n";
773                 print $dst "\t\treturn Native.Pointer.ofAddress($addr, $size, $ltype"."::new);\n";
774                 print $dst "\t}\n";
775
776                 print $dst "\tpublic void set$cc($type v) {\n";
777                 print $dst "\t\tNative.setAddr($addr, v.addr());\n";
778                 print $dst "\t}\n";
779             }
780         } elsif ($field{ctype} eq 'bitfield') {
781             my $alsr = $field{type} =~ m/^u/ ? '>>>' : '>>';
782             my $lshift = $field{size} <= 32 ? 5 : 6;
783             my $lbits = 1 << $lshift;
784             my $type = $lbits == 32 ? 'int' : 'long';
785             my $ltype = $lbits == 32 ? 'Int' : 'Long';
786
787             my $offset = ($field{offset} >> ($lshift)) * ($lbits / 8);
788             my $addr = $offset ? "addr().addOffset($offset)" : 'addr()';
789             my $shift = $field{offset} & ($lbits-1);
790             my $width = $field{size};
791             my $upshift = ($lbits-$width-$shift);
792             my $downshift = ($lbits-$width);
793             my $mask = sprintf("0x%x", ((1 << $width) - 1) << $shift);
794
795             print $dst "\tpublic $type get$cc() {\n";
796             print $dst "\t\treturn (($type)Native.get$ltype($addr)) << $upshift $alsr $downshift;\n";
797             print $dst "\t}\n";
798
799             print $dst "\tpublic void set$cc($type v) {\n";
800             print $dst "\t\tMemoryAddress addr = $addr;\n";
801             print $dst "\t\tNative.set$ltype(addr, ((($type)Native.get$ltype(addr)) & ~$mask) | ((v << $shift) & $mask));\n";
802             print $dst "\t}\n";
803         } elsif ($field{type} =~ m/^(struct|union):/) {
804             # embedded struct
805         } elsif ($field{type} =~ m/^call:/) {
806             # call, function?
807             print $dst "// call? $type $cc\n";
808             my $offset = $field{offset} >> 3;
809             my $addr = $offset ? "addr().addOffset($offset)" : 'addr()';
810             my $ltype = $type;
811
812             $type =~ s/Callback<(.*)>/$1/;
813
814             print $dst "\tprivate Pointer<$type> $cc;\n";
815
816             print $dst "\tpublic void set$cc($type v) {\n";
817             print $dst "\t\tif ($cc != null) $cc.close();\n";
818             print $dst "\t\tNative.setAddr($addr, ($cc = $type.call(v)).addr());\n";
819             print $dst "\t}\n";
820         } else {
821             my $offset = $field{offset} >> 3;
822             my $addr = $offset ? "addr().addOffset($offset)" : 'addr()';
823             my $ltype = $type;
824
825             $ltype =~ s/^(.)/uc($1)/e;
826
827             die("non-byte offset=$offset ".Dumper(\%field)) if ($field{offset} & 7);
828
829             print $dst "\tpublic $type get$cc() {\n";
830             print $dst "\t\treturn Native.get$ltype($addr);\n";
831             print $dst "\t}\n";
832
833             print $dst "\tpublic void set$cc($type v) {\n";
834             print $dst "\t\tNative.set$ltype($addr, v);\n";
835             print $dst "\t}\n";
836         }
837     }
838
839     my $byteSize = $struct{size} >> 3;
840     print $dst "\tpublic static final long sizeof = $byteSize;\n";
841
842     # TODO: optional just call new()
843     print $dst "\tpublic static $name create(MemoryAddress p) {\n";
844     print $dst "\t\treturn Native.resolve(p, $name"."::new);\n";
845     print $dst "\t}\n";
846
847     print $dst "\tpublic static $name alloc() {\n";
848     print $dst "\t\treturn $name.create(MemorySegment.allocateNative(sizeof).baseAddress());\n";
849     print $dst "\t}\n";
850     print $dst "\tpublic static Pointer<$name> alloc(int n) {\n";
851     print $dst "\t\treturn Pointer.alloc(n, sizeof, $name"."::new);\n";
852     print $dst "\t}\n";
853
854     if ($struct{type} eq "union") {
855         print $dst "\tpublic static MemoryLayout layout() { return Native.parseUnion(\"$signature\"); }\n";
856     } else {
857         print $dst "\tpublic static MemoryLayout layout() { return Native.parseStruct(\"$signature\"); }\n";
858         }
859
860     print $dst "}\n";
861
862     if (!$enclosingType) {
863         close($dst);
864     }
865 }
866
867 # ######################################################################
868 # Dump classes for library linkage
869 for $c (@classes) {
870     my %class = %{$c};
871     my @libs = @{$class{libs}};
872     my @match = @{$class{match}};
873
874     if (!$enclosingType) {
875         my $classname = $packagePrefix.$class{name};
876
877         open ($dst, ">$path");
878         $classname =~ s@\.@/@g;
879
880         my $path = $output."/".$classname.".java";
881         my $dir = dirname($path);
882         my $class = basename($path, ".java");
883         make_path($dir);
884         open ($dst, ">$path");
885
886         if ($package ne "") {
887             print $dst "package $package;\n";
888         }
889         print $dst <<END;
890 import jdk.incubator.foreign.*;
891 import java.lang.invoke.MethodHandle;
892 import api.Native;
893 $importPointer
894 END
895     }
896
897     print $dst "public class $class{name} {\n";
898
899     print $dst "\tstatic final String[] libraries = {";
900     print $dst join(",", map { "\"$_\"" } @libs);
901     print $dst "};\n";
902
903     # enums to ints
904     # TODO: interfaces?
905     # TODO: static lib class?
906     # typedef enums might appear twice in the data, so ignore duplicates
907     # also, some api's have multiple definitions (?)
908     my %visited = ();
909     my @match_enum = @{$class{enum}};
910     for $k (sort(findDefinition(\%data, 'enum', @match_enum))) {
911         my %enum = %{$data{$k}};
912         my @values = @{$enum{values}};
913         my $type = "int";
914
915         if ($enum{value_type} =~ m/^[ui](\d+)/) {
916             $type = "long" if ($1 > 32)
917         }
918
919         print $dst "\n\t// enum $enum{name}\n";
920         for $vi (@values) {
921             my %value = %{$vi};
922
923             if (!$visited{$value{label}}) {
924                 #print $dst "\tpublic static final $type $value{label} = ($type)$value{value};\n";
925                 print $dst "\tpublic static final $type $value{label} = $value{value};\n";
926                 $visited{$value{label}} = 1;
927             }
928         }
929     }
930
931     # function handles
932     print "class $class{name} -> match:\n".Dumper(\@match);
933
934     for $k (sort(findDefinition(\%data, 'func', @match))) {
935         my %func = %{$data{$k}};
936         my @params = @{$func{arguments}};
937         my $signature = funcSignature(\%func);
938         my $name = ($func{name});
939
940         print $dst "\tfinal static MethodHandle $name;\n";
941     }
942
943     # function handle init
944     print $dst "\tstatic {\n";
945     print $dst "\t\tLibraryLookup[] libs = Native.loadLibraries(libraries);\n";
946
947     for $k (sort(findDefinition(\%data, 'func', @match))) {
948         my %func = %{$data{$k}};
949         my @params = @{$func{arguments}};
950         my $signature = funcSignature(\%func);
951         my $name = ($func{name});
952
953         print $dst "\t\t$name = Native.downcallHandle(libs, \"$name\", \"$signature\");\n";
954     }
955     print $dst "\t}\n";
956
957     # function handle invocation
958     if ($rawCalls) {
959         for $k (sort(findDefinition(\%data, 'func', @match))) {
960             my %func = %{$data{$k}};
961             my @params = @{$func{arguments}};
962             my $signature = funcSignature(\%func);
963             my $name = ($func{name});
964             my %res = %{$func{result}};
965             my $result = typeToRaw(\%res);
966
967             print $dst "\tpublic static $result $name(";
968
969             for $pi (@params) {
970                 my %param = %{$pi};
971                 my $type = typeToRaw($pi);
972
973                 print $dst "$type $param{name}";
974                 print $dst ", " if ($pi != $params[$#params]);
975             }
976
977             print $dst ") throws Throwable {\n";
978             if ($result ne "void") {
979                 print $dst "return ($result)";
980             }
981             print $dst "$name.invokeExact(";
982             for $pi (@params) {
983                 my %param = %{$pi};
984
985                 print $dst "$param{name}";
986                 print $dst ", " if ($pi != $params[$#params]);
987             }
988             print $dst ");\n";
989             print $dst "\t}\n\n";
990         }
991         print $dst "}\n";
992     } else {
993         for $k (sort(findDefinition(\%data, 'func', @match))) {
994             my %func = %{$data{$k}};
995             my @params = @{$func{arguments}};
996             my $signature = funcSignature(\%func);
997             my $name = ($func{name});
998             my %res = %{$func{result}};
999             my $result = typeToJava(\%{$func{result}});
1000
1001             print $dst "\tpublic static $result $name(";
1002
1003             for $pi (@params) {
1004                 my %param = %{$pi};
1005                 my $type = typeToJava($pi);
1006
1007                 $type =~ s/Callback/Pointer/;
1008
1009                 # HACK
1010                 $type =~ s/Pointer<Void>/Pointer<?>/;
1011
1012                 print $dst "$type $param{name}";
1013                 print $dst ", " if ($pi != $params[$#params]);
1014             }
1015
1016             print $dst ") {\n";
1017             # see also call below
1018             print $dst "\t\ttry {\n";
1019             print $dst "\t\t\t";
1020             if ($res{type} =~ m/(struct|union)/n) {
1021                 if ($res{deref}) {
1022                     print $dst "MemoryAddress add = (MemoryAddress)";
1023                 } else {
1024                     print $dst "MemorySegment seg = (MemorySegment)";
1025                 }
1026             } elsif ($result ne "void") {
1027                 print $dst "return ($result)";
1028             }
1029             print $dst "$name.invokeExact(";
1030             for $pi (@params) {
1031                 my %param = %{$pi};
1032
1033                 print $dst "$param{name}";
1034                 if ($param{deref}) {
1035                     print $dst ".addr()";
1036                 } elsif ($param{type} =~ m/^struct|union/) {
1037                     print $dst ".addr().segment()";
1038                 }
1039                 print $dst ", " if ($pi != $params[$#params]);
1040             }
1041             print $dst ");\n";
1042             if ($res{type} =~ m/(struct|union)/n) {
1043                 if ($res{deref}) {
1044                     print $dst "\t\t\treturn $result.create(add);\n";
1045                 } else {
1046                     print $dst "\t\t\treturn $result.create(seg.baseAddress());\n";
1047                 }
1048             }
1049             print $dst "\t\t}\n";
1050             print $dst "\t\tcatch (Throwable t) { throw new RuntimeException(t); }\n";
1051             print $dst "\t}\n\n";
1052         }
1053
1054         print $dst "}\n";
1055     }
1056
1057     if (!$enclosingType) {
1058         close($dst);
1059     }
1060 }
1061
1062 # ######################################################################
1063 # Dump callbacks
1064 # TODO: only those used by classes and functions that were exported
1065 # TODO: yeah this is a total total fucking shitshow
1066
1067 if ($rawCalls) {
1068     for $c (keys %callMap) {
1069         my %call = %{$data{$c}};
1070         my $name = $callMap{$c};
1071         my @params = @{$call{arguments}};
1072         my %res = %{$call{result}};
1073         my $result = typeToRaw(\%res);
1074         my $signature = funcSignature(\%call);
1075
1076         if (!$enclosingType) {
1077             my $classname = $packagePrefix.$name;
1078
1079             open ($dst, ">$path");
1080             $classname =~ s@\.@/@g;
1081
1082             my $path = $output."/".$classname.".java";
1083             my $dir = dirname($path);
1084             my $class = basename($path, ".java");
1085             make_path($dir);
1086             open ($dst, ">$path");
1087
1088             if ($package ne "") {
1089                 print $dst "package $package;\n";
1090             }
1091             print $dst <<END;
1092 import jdk.incubator.foreign.*;
1093 import java.lang.invoke.MethodHandle;
1094 import java.lang.invoke.MethodHandles;
1095 import java.lang.reflect.Method;
1096 import api.Callback;
1097 import api.Native;
1098 $importPointer
1099 END
1100         }
1101
1102         print $dst "\@FunctionalInterface\n";
1103         print $dst "public interface $name {\n";
1104         print $dst "\tpublic $result fn(";
1105
1106         for $pi (@params) {
1107             my %param = %{$pi};
1108             my $type = typeToRaw($pi);
1109
1110             print $dst "$type $param{name}";
1111             print $dst ", " if ($pi != $params[$#params]);
1112         }
1113
1114         print $dst ") throws Throwable;\n";
1115
1116         # downcall
1117         print $dst "\tstatic public $name of(MemoryAddress addr) {\n";
1118         print $dst "\t\tMethodHandle func = Native.downcallHandle(addr, \"$signature\");\n";
1119         print $dst "\t\treturn (";
1120         for $pi (@params) {
1121             my %param = %{$pi};
1122             my $type = typeToRaw($pi);
1123
1124             print $dst "$type $param{name}";
1125             print $dst ", " if ($pi != $params[$#params]);
1126         }
1127         print $dst ") -> ";
1128         if ($result ne "void") {
1129             print $dst "($result)";
1130         }
1131         print $dst "func.invokeExact(";
1132         for $pi (@params) {
1133             my %param = %{$pi};
1134
1135             print $dst "$param{name}";
1136             print $dst ", " if ($pi != $params[$#params]);
1137         }
1138         print $dst ");\n";
1139         print $dst "\t}\n";
1140
1141         # upcall ##############################################################
1142         # ??
1143
1144         print $dst "\tstatic MemoryAddress stub($name call) {\n";
1145         print $dst "\t\treturn Native.upcallStub(MethodHandles.lookup(), call, \"$signature\");\n";
1146         print $dst "\t}\n";
1147
1148         # # the raw interface as expected by the native code
1149         # my $rawresult = typeToRaw(\%res);
1150         # print $dst "\tpublic interface $rawName {\n";
1151         # # fixme raw result
1152         # print $dst "\t\tpublic $rawresult fn(";
1153
1154         # for $pi (@params) {
1155         #     my %param = %{$pi};
1156         #     my $type = typeToRaw($pi);
1157
1158         #     print $dst "$type $param{name}";
1159         #     print $dst ", " if ($pi != $params[$#params]);
1160         # }
1161
1162         # print $dst ");\n";
1163         # print $dst "\t}\n";
1164
1165         # print $dst "\tstatic public Pointer<$name> call($name v) {\n";
1166         # print $dst "\t\t$rawName func = (";
1167         # for $pi (@params) {
1168         #     my %param = %{$pi};
1169         #     my $type = typeToRaw($pi);
1170
1171         #     print $dst "$type $param{name}";
1172         #     print $dst ", " if ($pi != $params[$#params]);
1173         # }
1174         # print $dst ") -> {\n";
1175         # print $dst "\t\t\t";
1176         # if ($rawresult ne "void") {
1177         #     print $dst "return ";
1178         # }
1179         # print $dst "v.fn(";
1180         # for $pi (@params) {
1181         #     my %param = %{$pi};
1182         #     my $type = typeToJava($pi);
1183         #     my $rawtype = typeToRaw($pi);
1184
1185         #     print "type ='$type'\n";
1186         #     if ($type =~ m/^Pointer<[^>]*>$/) {
1187         #       print $dst "Pointer.ofAddress($param{name})";
1188         #     } elsif ($type eq "Pointer<Pointer<Void>>") {
1189         #       print $dst "Pointer.ofAddressP($param{name})";
1190         #     } elsif ($rawtype eq "MemoryAddress") {
1191         #       print $dst "$type.create($param{name})";
1192         #     } elsif ($rawtype eq "MemorySegment") {
1193         #       print $dst "$type.create($param{name}.baseAddress())";
1194         #     } else {
1195         #       print $dst "$param{name}";
1196         #     }
1197         #     print $dst ", " if ($pi != $params[$#params]);
1198         # }
1199         # print $dst ")";
1200         # if ($rawresult eq "MemoryAddress") {
1201         #     print $dst ".addr()";
1202         # } elsif ($rawresult eq "MemorySegment") {
1203         #     print $dst ".addr().segment()";
1204         # }
1205         # print $dst ";\n";
1206
1207         # print $dst "\t\t};\n";
1208         # print $dst "\t\treturn Native.Pointer.ofCallback(MethodHandles.lookup(), v, func, \"$signature\");\n";
1209         # print $dst "\t}\n";
1210
1211         print $dst "}\n";
1212
1213         if (!$enclosingType) {
1214             close($dst);
1215         }
1216     }
1217 } else {
1218     for $c (keys %callMap) {
1219         my %call = %{$data{$c}};
1220         my $name = $callMap{$c};
1221         my @params = @{$call{arguments}};
1222         my %res = %{$call{result}};
1223         my $result = typeToJava(\%{$call{result}});
1224         my $signature = funcSignature(\%call);
1225
1226         if (!$enclosingType) {
1227             my $classname = $packagePrefix.$name;
1228
1229             open ($dst, ">$path");
1230             $classname =~ s@\.@/@g;
1231
1232             my $path = $output."/".$classname.".java";
1233             my $dir = dirname($path);
1234             my $class = basename($path, ".java");
1235             make_path($dir);
1236             open ($dst, ">$path");
1237
1238             if ($package ne "") {
1239                 print $dst "package $package;\n";
1240             }
1241             print $dst <<END;
1242 import jdk.incubator.foreign.*;
1243 import java.lang.invoke.MethodHandle;
1244 import java.lang.invoke.MethodHandles;
1245 import java.lang.reflect.Method;
1246 import api.Native;
1247 $importPointer
1248 END
1249         }
1250
1251         # any in-line structures need to be added to the resolutionContext
1252         # TODO: only include actual inline, not pointers
1253         #my %resolve = ();
1254         #my @list = @params;
1255         #unshift(@list,$call{result});
1256         #for $pi (@list) {
1257         #       my %param = %{$pi};
1258         #
1259         #       if ($param{type} =~ m/^(struct|union):(.*)/) {
1260         #           $resolve{StudlyCaps($2).".class"} = 1;
1261         #       }
1262         #    }
1263         #my $resolve = join (",", keys %resolve);
1264
1265         print $dst "\@FunctionalInterface\n";
1266         print $dst "public interface $name {\n";
1267         print $dst "\tpublic $result fn(";
1268
1269         for $pi (@params) {
1270             my %param = %{$pi};
1271             my $type = typeToJava($pi);
1272
1273             print $dst "$type $param{name}";
1274             print $dst ", " if ($pi != $params[$#params]);
1275         }
1276
1277         print $dst ");\n";
1278
1279         # downcall
1280         print $dst "\tstatic public $name of(MemoryAddress addr) {\n";
1281         print $dst "\t\tMethodHandle func = Native.downcallHandle(addr, \"$signature\");\n";
1282         print $dst "\t\treturn (";
1283         for $pi (@params) {
1284             my %param = %{$pi};
1285             my $type = typeToJava($pi);
1286
1287             print $dst "$type $param{name}";
1288             print $dst ", " if ($pi != $params[$#params]);
1289         }
1290         print $dst ") -> {\n";
1291         print $dst "\t\t\ttry {\n";
1292         print $dst "\t\t\t\t";
1293         if (!$res{deref} && $res{type} =~ m/(struct|union)/n) {
1294             print $dst "MemorySegment seg = (MemorySegment)";
1295         } elsif ($result ne "void") {
1296             print $dst "return ($result)";
1297         }
1298         print $dst "func.invokeExact(";
1299         for $pi (@params) {
1300             my %param = %{$pi};
1301
1302             print $dst "$param{name}";
1303             if ($param{deref}) {
1304                 print $dst ".addr()";
1305             } elsif ($param{type} =~ m/^struct|union/) {
1306                 print $dst ".addr().segment()";
1307             }
1308             print $dst ", " if ($pi != $params[$#params]);
1309         }
1310         print $dst ");\n";
1311         if (!$res{deref} && $res{type} =~ m/(struct|union)/n) {
1312             print $dst "\t\t\t\treturn $result.create(seg.baseAddress());\n";
1313         }
1314         print $dst "\t\t\t} catch (Throwable t) { throw new RuntimeException(t); }\n";
1315         print $dst "\t\t};\n";
1316         print $dst "\t}\n";
1317
1318         # upcall ##############################################################
1319         # the raw interface as expected by the native code
1320         my $rawName = $name.'Raw';
1321         my $rawresult = typeToRaw(\%res);
1322         print $dst "\tpublic interface $rawName {\n";
1323         # fixme raw result
1324         print $dst "\t\tpublic $rawresult fn(";
1325
1326         for $pi (@params) {
1327             my %param = %{$pi};
1328             my $type = typeToRaw($pi);
1329
1330             print $dst "$type $param{name}";
1331             print $dst ", " if ($pi != $params[$#params]);
1332         }
1333
1334         print $dst ");\n";
1335         print $dst "\t}\n";
1336
1337         print $dst "\tstatic public Pointer<$name> call($name v) {\n";
1338         print $dst "\t\t$rawName func = (";
1339         for $pi (@params) {
1340             my %param = %{$pi};
1341             my $type = typeToRaw($pi);
1342
1343             print $dst "$type $param{name}";
1344             print $dst ", " if ($pi != $params[$#params]);
1345         }
1346         print $dst ") -> {\n";
1347         print $dst "\t\t\t";
1348         if ($rawresult ne "void") {
1349             print $dst "return ";
1350         }
1351         print $dst "v.fn(";
1352         for $pi (@params) {
1353             my %param = %{$pi};
1354             my $type = typeToJava($pi);
1355             my $rawtype = typeToRaw($pi);
1356
1357             print "type ='$type'\n";
1358             if ($type =~ m/^Pointer<[^>]*>$/) {
1359                 print $dst "Pointer.ofAddress($param{name})";
1360             } elsif ($type eq "Pointer<Pointer<Void>>") {
1361                 print $dst "Pointer.ofAddressP($param{name})";
1362             } elsif ($rawtype eq "MemoryAddress") {
1363                 print $dst "$type.create($param{name})";
1364             } elsif ($rawtype eq "MemorySegment") {
1365                 print $dst "$type.create($param{name}.baseAddress())";
1366             } else {
1367                 print $dst "$param{name}";
1368             }
1369             print $dst ", " if ($pi != $params[$#params]);
1370         }
1371         print $dst ")";
1372         if ($rawresult eq "MemoryAddress") {
1373             print $dst ".addr()";
1374         } elsif ($rawresult eq "MemorySegment") {
1375             print $dst ".addr().segment()";
1376         }
1377         print $dst ";\n";
1378
1379         print $dst "\t\t};\n";
1380         print $dst "\t\treturn Native.Pointer.ofCallback(MethodHandles.lookup(), v, func, \"$signature\");\n";
1381         print $dst "\t}\n";
1382
1383         print $dst "}\n";
1384
1385         if (!$enclosingType) {
1386             close($dst);
1387         }
1388     }
1389 }
1390
1391 # Finish off
1392 if ($enclosingType) {
1393     print $dst "}\n";
1394     close($dst);
1395 }