[svn:parrot] r33510 - trunk/compilers/ncigen

Author: tewk
Date: Fri Dec  5 07:18:08 2008
New Revision: 33510

Added:
   trunk/compilers/ncigen/NCIGENP6.pm   (contents, props changed)
      - copied, changed from r33506, /trunk/compilers/ncigen/sqlite_interface_generator.pl
   trunk/compilers/ncigen/gen_sqlite3.pl   (contents, props changed)
Removed:
   trunk/compilers/ncigen/sqlite_interface_generator.pl

Log:
[ncigen] programmatic control via perl6


Copied: trunk/compilers/ncigen/NCIGENP6.pm (from r33506, /trunk/compilers/ncigen/sqlite_interface_generator.pl)
==============================================================================
--- /trunk/compilers/ncigen/sqlite_interface_generator.pl	(original)
+++ trunk/compilers/ncigen/NCIGENP6.pm	Fri Dec  5 07:18:08 2008
@@ -7,37 +7,28 @@
 
 evalfile('./ncigen.pbc', lang => 'Parrot');
 
-my $fn = @*ARGS[0];
-my $pp_fn = mktempfile('ptemp');
+sub parse_ast($fn) {
+    my $pp_fn = mktempfile('ptemp');
 
-run("gcc -x c -E $fn > $pp_fn");
-my $compiler = compreg('NCIGEN');
-my $ast = $compiler.parse(slurp($pp_fn));
-
-my $b = $ast.item();
-
-for ($ast.item().kv) -> $k,$v {
-  say "====================================================";
-  say $k;
-  say $v.perl;
-  for ($v.list) -> $x {
-    say $x.perl;
-  }
-  say pir($v);
+    run("gcc -x c -E $fn > $pp_fn");
+    my $compiler = compreg('NCIGEN');
+    my $ast = $compiler.parse(slurp($pp_fn));
+    unlink $pp_fn;
+    $ast.item();
 }
 
 sub compreg {
-  my $a = q:PIR { %r = compreg 'NCIGEN' };
-  return $a;
+    my $a = q:PIR { %r = compreg 'NCIGEN' };
+    return $a;
 }
 
 sub mktempfile($prefix) {
-  sub nonce() { ".{$*PID}." ~ int 1000.rand }
-  $prefix ~ nonce;
+    sub nonce() { ".{$*PID}." ~ int 1000.rand }
+    $prefix ~ nonce;
 }
 
 sub gen_preamble($nsname, $libname) {
-    my $fmt = ".namespace [$nsname]\n";
+    my $fmt = ".namespace ['$nsname']\n";
     $fmt ~= ".sub __load_lib_dlfunc_init__ :anon :init :load\n";
 
     if $libname {
@@ -47,85 +38,90 @@
         $fmt ~= "\$P1 = null\ngoto has_lib\n";
     }
 
-    $fmt ~= "\$P2 = new 'Exception'";
-    $fmt ~= "\$P2[0] = 'error loading $libname - loadlib failed'";
-    $fmt ~= "throw \$P2";
-    $fmt ~= "has_lib:";
+    $fmt ~= 
+        qq{{\$P2 = new 'Exception'
+\$P2[0] = 'error loading $libname - loadlib failed'
+throw \$P2
+has_lib:
+}};
 
     return $fmt;
 }
 
+sub gen_postamble() {
+    return ".end\n";
+}
+
+sub dump_node($node) {
+    say "====================================================";
+    say $node.perl;
+    for ($node.list) -> $x {
+        say $x.perl;
+    }
+}
+
+=begin
 multi sub pir($node) {
+    say $node.WHAT;
     return  pir_children($node);
 }
-multi sub pir(NCIGENAST::TypeDef $node) { return ""; }
-multi sub pir(NCIGENAST::VarDecl $node) { return ""; } 
-multi sub pir(NCIGENAST::FuncDecl $node) {
-    ##  get list of arguments to operation
-    my $arglist = $node.list();
+=end
 
+#multi sub pir(NCIGENAST::TypeDef $node) { return ""; }
+#multi sub pir(NCIGENAST::VarDecl $node) { return ""; } 
+multi sub pir(NCIGENAST::FuncDecl $node) {
+## return type
     my $type = param_to_code($node, 1);
 
-    for @($arglist) -> $x {
+##  get list of arguments to operation
+    for ($node.list()) -> $x {
         $type ~= param_to_code($x);
     }
+    return ($node.name, $type);
+}
 
-    my $name = $node.name();
-    my $fmt = "dlfunc \$P2, \$P1, '$name', '$type'\nstore_global '$name', \$P2";
-
-    return $fmt;
+sub format_func_decl($pirname, $cname, $type) {
+    return qq{{dlfunc \$P2, \$P1, '$cname', '$type'
+store_global '$pirname', \$P2}};
 }
 
-sub param_to_code($node, $returncode) {
-    my $I0 = $node.'pointer'();
-    my $I2 = $node.'pointer_cnt'();
+sub param_to_code($node, $returncode = 0) {
     my $pt = $node.'primitive_type'();
 
     if ($node.pointer()) {
-        if ($pt ~~ 'void' ) {
-            if ($returncode) { return ""; }
-            else { return "v"; }
-        }
-        elsif ($pt ~~ 'int') { return "i"; }
-        elsif ($pt ~~ 'long') { return "l"; }
-        elsif ($pt ~~ 'char') { return "c"; }
-        elsif ($pt ~~ 'short') { return "s"; }
-        else { return "p"; }
-    }
-    else {
-        if ($node.pointer_cnt() > 1 ) {
-            return "V";
-        }
-        if ($pt ~~ 'void' ) {
+        if ($node.pointer_cnt() > 1 ) { return "V"; } #out params
+        given $pt {
+          when 'void' {
             if ($returncode) { return "p"; } #probably should be "V"
             else { return "p"; } 
-        }
-        elsif ($pt ~~ 'int') { return "V"; }
-        elsif ($pt ~~ 'long') { return "V"; }
-        elsif ($pt ~~ 'char') { return "t"; }
-        elsif ($pt ~~ 'short') { return "V"; }
-        else { 
+          }
+          when 'int'    { return "V"; }
+          when 'long'   { return "V"; }
+          when 'char'   { return "t"; }
+          when 'short'  { return "V"; }
+          default { 
+=begin
             say "ERROR";
-            say $pt;
+            say $node.perl;
             say "what is this";
-            return "p"; }
+=end
+              return "p";
+          }
+        }
     }
-}
-
-sub to_pir($ast, $adverbs) {
-#    .param pmc ast
-#    .param pmc adverbs         :slurpy :named
-    
-    my $code = "";
-    my $raw = $adverbs['raw'];
-    unless ($raw) {
-        $code = gen_preamble($adverbs);
+    else {
+        given $pt {
+            when 'void' {
+                if ($returncode) { return ""; } # void return code
+                else { return "v"; }
+            }
+            when 'int'      { return "i"; }
+            when 'long'     { return "l"; }
+            when 'char'     { return "c"; }
+            when 'short'    { return "s"; }
+            default         { return "p"; }
+        }
     }
-
-    ##  now generate the pir
-    $code = pir(ast);
-
-    return $code;
 }
 
 sub pir_children($node) {
@@ -140,5 +136,6 @@
 #   mode: pir
 #   fill-column: 100
 # End:
-# vim: expandtab shiftwidth=4 ft=perl6:
+# vim: expandtab ft=perl6 shiftwidth=2 
+
 

Added: trunk/compilers/ncigen/gen_sqlite3.pl
==============================================================================
--- (empty file)
+++ trunk/compilers/ncigen/gen_sqlite3.pl	Fri Dec  5 07:18:08 2008
@@ -0,0 +1,38 @@
+#!/home/tewk/srcs/parrot/perl6
+
+# $Id: sqlite_interface_generator.pl 33506 2008-12-05 12:39:55Z tewk $
+# Copyright (C) 2008, The Perl Foundation.
+
+use v6;
+use NCIGENP6;
+
+my $fn = @*ARGS[0];
+
+print gen_preamble("SQLite3", "sqlite3");
+
+my %rename_table = (
+    'open'          => 'open_raw',
+    'prepare_v2'    => 'prepare_raw',
+);
+
+for (parse_ast($fn).kv) -> $k,$v {
+    #dump_node($v);
+    if ($v.WHAT eq "FuncDecl") {
+        my @result = pir($v);
+        my $suffix_name = @result[0];
+        my $suffix_name .= subst( /sqlite3_/, '' );
+
+        my $pirname = %rename_table{$suffix_name} || $suffix_name;
+        
+        say format_func_decl($pirname, |@result);
+    }
+}
+
+say gen_postamble();
+
+# Local Variables:
+#   mode: pir
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=perl6:
+

• [svn:parrot] r33510 - trunk/compilers/ncigen by tewk