148 lines
3.9 KiB
Perl
148 lines
3.9 KiB
Perl
# *****************************************************************************
|
|
# * Copyright (c) 2004, 2008 IBM Corporation
|
|
# * All rights reserved.
|
|
# * This program and the accompanying materials
|
|
# * are made available under the terms of the BSD License
|
|
# * which accompanies this distribution, and is available at
|
|
# * http://www.opensource.org/licenses/bsd-license.php
|
|
# *
|
|
# * Contributors:
|
|
# * IBM Corporation - initial implementation
|
|
# ****************************************************************************/
|
|
#!/usr/bin/perl
|
|
|
|
#
|
|
# Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org>
|
|
#
|
|
|
|
|
|
use Getopt::Std;
|
|
use Data::Dumper;
|
|
|
|
$CELLSIZE = length(sprintf "%x", ~0) / 2;
|
|
$CELLSIZE = 8;
|
|
$DEBUG = 0;
|
|
|
|
sub usage
|
|
{
|
|
printf STDERR "Usage: ref.pl [ -s 32|64 ] [ -d ] \n";
|
|
printf STDERR " ref.pl -h\n";
|
|
exit 0;
|
|
}
|
|
|
|
sub string
|
|
{
|
|
my ($s, $extra) = @_;
|
|
|
|
$DEBUG and printf STDERR "\nstring:[%s][%02x]\n", $s, ord $extra;
|
|
$s = sprintf "%s%c%s", $extra, length($s), $s;
|
|
@s = ($s =~ /(.{1,$CELLSIZE})/gs);
|
|
do { s/([\x00-\x1f\x22\x5c\x7f-\xff])/sprintf "\\%03o", ord $1/egs } for @s;
|
|
my @reut = ("{ .c = \"" . (join "\" }, { .c = \"", @s) . "\" },", scalar @s);
|
|
# $DEBUG and print STDERR Dumper \@reut;
|
|
return @reut;
|
|
}
|
|
|
|
sub forth_to_c_name
|
|
{
|
|
($_, my $numeric) = @_;
|
|
s/([^a-zA-Z0-9])/sprintf("_X%02x_", ord($1))/ge;
|
|
s/__/_/g;
|
|
# s/^_//;
|
|
s/_$//;
|
|
s/^(\d)/_$1/ if $numeric;
|
|
return $_;
|
|
}
|
|
|
|
sub special_forth_to_c_name
|
|
{
|
|
($_, my $numeric) = @_;
|
|
|
|
$DEBUG and print STDERR "\tasked for $_ [[numeric is $numeric]]\n";
|
|
my ($name, $arg) = (/^([^(]+)(.*)$/);
|
|
# $DEBUG and print STDERR "\tname is $name -- arg is $arg\n";
|
|
if ($special{$name} == 1) {
|
|
$_ = forth_to_c_name($name, $numeric) . $arg;
|
|
} elsif ($special{$name} != 2) {
|
|
$_ = forth_to_c_name($_, $numeric);
|
|
}
|
|
# $DEBUG and print STDERR "\tmaking it $_\n";
|
|
return $_;
|
|
}
|
|
|
|
getopts('dhs:') or die "Invalid option!\n";
|
|
|
|
$opt_h and usage();
|
|
$opt_d and $DEBUG=1;
|
|
$opt_s and $opt_s != 32 and $opt_s != 64 and die("Only -s32 or -s64 allowed");
|
|
|
|
$opt_s and $opt_s == 32 and $CELLSIZE=4;
|
|
|
|
$DEBUG and printf STDERR "Cell size set to $CELLSIZE;\n";
|
|
|
|
$link = "0";
|
|
%special = ( _N => 2, _O => 2, _C => 2, _A => 2 );
|
|
|
|
$DEBUG and print STDERR "Compiling:";
|
|
while ($line = <>) {
|
|
if ($line =~ /^([a-z]{3})\(([^ ]+)./) {
|
|
$typ = $1;
|
|
$name = $2;
|
|
|
|
$DEBUG and print STDERR "\n\t\t$name###\n";
|
|
|
|
$name =~ s/\)$// if $line =~ /\)\s+_ADDING.*$/;
|
|
# $DEBUG and print STDERR " $name";
|
|
$cname = forth_to_c_name($name, 1);
|
|
$par = '';
|
|
$add = '';
|
|
$extra = "\0";
|
|
if ($typ eq "imm") {
|
|
$typ = "col";
|
|
$extra = "\1";
|
|
}
|
|
# if ($typ eq "com") {
|
|
# $typ = "col";
|
|
# $extra = "\3";
|
|
# }
|
|
($str, $strcells) = (string $name, $extra);
|
|
if ($line =~ /^str\([^"]*"([^"]*)"/) {
|
|
# $DEBUG and print STDERR "[[[$1]]]\n";
|
|
($s) = (string $1);
|
|
$line =~ s/"[^"]*"/$s/;
|
|
}
|
|
if ($line =~ /_ADDING +(.*)$/) {
|
|
$special{$name} = 1;
|
|
@typ = (split /\s+/, $1);
|
|
$count = 0;
|
|
$par = "(" . (join ", ", map { $count++; "_x$count" } @typ) . ")";
|
|
$count = 0;
|
|
$add = join " ", map { $count++; "$_(_x$count)" } @typ;
|
|
$line =~ s/\s+_ADDING.*$//;
|
|
}
|
|
# $DEBUG and print STDERR $line;
|
|
($body) = ($line =~ /^...\((.*)\)$/);
|
|
@body = split " ", $body;
|
|
# $DEBUG and print STDERR "\n";
|
|
# $DEBUG and print STDERR "BODY WAS: ", (join " ", @body), "\n";
|
|
if ($typ ne "str" and $typ ne "con") {
|
|
@body = map { special_forth_to_c_name($_, $typ eq "col") } @body;
|
|
} else {
|
|
$body[0] = special_forth_to_c_name($body[0]);
|
|
}
|
|
# $DEBUG and print STDERR "BODY IS: ", (join " ", @body), "\n";
|
|
$body = join " ", @body;
|
|
$body =~ s/ /, /;
|
|
# $DEBUG and print STDERR "===> $body\n";
|
|
|
|
print "header($cname, { .a = $link }, $str) ";
|
|
$link = "xt_$cname";
|
|
print "$typ($body)\n";
|
|
print "#define $cname$par ref($cname, $strcells+1) $add\n";
|
|
(my $xxcname) = ($cname =~ /^_?(.*)/);
|
|
$add and print "#define DO$xxcname ref($cname, $strcells+1)\n";
|
|
} else {
|
|
print $line;
|
|
}
|
|
}
|
|
$DEBUG and print STDERR "\n";
|