qemu/roms/SLOF/slof/ref.pl

   1 # *****************************************************************************
   2 # * Copyright (c) 2004, 2008 IBM Corporation
   3 # * All rights reserved.
   4 # * This program and the accompanying materials
   5 # * are made available under the terms of the BSD License
   6 # * which accompanies this distribution, and is available at
   7 # * http://www.opensource.org/licenses/bsd-license.php
   8 # *
   9 # * Contributors:
  10 # *     IBM Corporation - initial implementation
  11 # ****************************************************************************/
  12 #!/usr/bin/perl
  13
  14 #
  15 # Copyright 2002,2003,2004  Segher Boessenkool  <segher@kernel.crashing.org>
  16 #
  17
  18
  19 use Getopt::Std;
  20 use Data::Dumper;
  21
  22 $CELLSIZE = length(sprintf "%x", ~0) / 2;
  23 $CELLSIZE = 8;
  24 $DEBUG = 0;
  25
  26 sub usage
  27 {
  28         printf STDERR "Usage: ref.pl [ -s 32|64 ] [ -d ] \n";
  29         printf STDERR "       ref.pl -h\n";
  30         exit 0;
  31 }
  32
  33 sub string
  34 {
  35         my ($s, $extra) = @_;
  36
  37         $DEBUG and printf STDERR "\nstring:[%s][%02x]\n", $s, ord $extra;
  38         $s = sprintf "%s%c%s", $extra, length($s), $s;
  39         @s = ($s =~ /(.{1,$CELLSIZE})/gs);
  40         do { s/([\x00-\x1f\x22\x5c\x7f-\xff])/sprintf "\\%03o", ord $1/egs } for @s;
  41         my @reut = ("{ .c = \"" . (join "\" }, { .c = \"", @s) . "\" },", scalar @s);
  42         # $DEBUG and print STDERR Dumper \@reut;
  43         return @reut;
  44 }
  45
  46 sub forth_to_c_name
  47 {
  48         ($_, my $numeric) = @_;
  49         s/([^a-zA-Z0-9])/sprintf("_X%02x_", ord($1))/ge;
  50         s/__/_/g;
  51 #       s/^_//;
  52         s/_$//;
  53         s/^(\d)/_$1/ if $numeric;
  54         return $_;
  55 }
  56
  57 sub special_forth_to_c_name
  58 {
  59         ($_, my $numeric) = @_;
  60
  61         $DEBUG and print STDERR "\tasked for $_ [[numeric is $numeric]]\n";
  62         my ($name, $arg) = (/^([^(]+)(.*)$/);
  63         # $DEBUG and print STDERR "\tname is $name -- arg is $arg\n";
  64         if ($special{$name} == 1) {
  65                 $_ = forth_to_c_name($name, $numeric) . $arg;
  66         } elsif ($special{$name} != 2) {
  67                 $_ = forth_to_c_name($_, $numeric);
  68         }
  69         # $DEBUG and print STDERR "\tmaking it $_\n";
  70         return $_;
  71 }
  72
  73 getopts('dhs:') or die "Invalid option!\n";
  74
  75 $opt_h and usage();
  76 $opt_d and $DEBUG=1;
  77 $opt_s and $opt_s != 32 and $opt_s != 64 and die("Only -s32 or -s64 allowed");
  78
  79 $opt_s and $opt_s == 32 and $CELLSIZE=4;
  80
  81 $DEBUG and printf STDERR "Cell size set to $CELLSIZE;\n";
  82
  83 $link = "0";
  84 %special = ( _N => 2, _O => 2, _C => 2, _A => 2 );
  85
  86 $DEBUG and print STDERR "Compiling:";
  87 while ($line = <>) {
  88         if ($line =~ /^([a-z]{3})\(([^ ]+)./) {
  89                 $typ = $1;
  90                 $name = $2;
  91
  92                 $DEBUG and print STDERR "\n\t\t$name###\n";
  93
  94                 $name =~ s/\)$// if $line =~ /\)\s+_ADDING.*$/;
  95                 # $DEBUG and print STDERR " $name";
  96                 $cname = forth_to_c_name($name, 1);
  97                 $par = '';
  98                 $add = '';
  99                 $extra = "\0";
 100                 if ($typ eq "imm") {
 101                         $typ = "col";
 102                         $extra = "\1";
 103                 }
 104 #               if ($typ eq "com") {
 105 #                       $typ = "col";
 106 #                       $extra = "\3";
 107 #               }
 108                 ($str, $strcells) = (string $name, $extra);
 109                 if ($line =~ /^str\([^"]*"([^"]*)"/) {
 110                 # $DEBUG and print STDERR "[[[$1]]]\n";
 111                         ($s) = (string $1);
 112                         $line =~ s/"[^"]*"/$s/;
 113                 }
 114                 if ($line =~ /_ADDING +(.*)$/) {
 115                         $special{$name} = 1;
 116                         @typ = (split /\s+/, $1);
 117                         $count = 0;
 118                         $par = "(" . (join ", ", map { $count++; "_x$count" } @typ) . ")";
 119                         $count = 0;
 120                         $add = join " ", map { $count++; "$_(_x$count)" } @typ;
 121                         $line =~ s/\s+_ADDING.*$//;
 122                 }
 123                 # $DEBUG and print STDERR $line;
 124                 ($body) = ($line =~ /^...\((.*)\)$/);
 125                 @body = split " ", $body;
 126                 # $DEBUG and print STDERR "\n";
 127                 # $DEBUG and print STDERR "BODY WAS: ", (join " ", @body), "\n";
 128                 if ($typ ne "str" and $typ ne "con") {
 129                         @body = map { special_forth_to_c_name($_, $typ eq "col") } @body;
 130                 } else {
 131                         $body[0] = special_forth_to_c_name($body[0]);
 132                 }
 133                 # $DEBUG and print STDERR "BODY IS: ", (join " ", @body), "\n";
 134                 $body = join " ", @body;
 135                 $body =~ s/ /, /;
 136                 # $DEBUG and print STDERR "===> $body\n";
 137
 138                 print "header($cname, { .a = $link }, $str) ";
 139                 $link = "xt_$cname";
 140                 print "$typ($body)\n";
 141                 print "#define $cname$par ref($cname, $strcells+1) $add\n";
 142                 (my $xxcname) = ($cname =~ /^_?(.*)/);
 143                 $add and print "#define DO$xxcname ref($cname, $strcells+1)\n";
 144         } else {
 145                 print $line;
 146         }
 147 }
 148 $DEBUG and print STDERR "\n";