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
10 # * IBM Corporation - initial implementation
11 # ****************************************************************************/
15 # Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org>
22 $CELLSIZE = length(sprintf "%x", ~0) / 2;
28 printf STDERR "Usage: ref.pl [ -s 32|64 ] [ -d ] \n";
29 printf STDERR " ref.pl -h\n";
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;
48 ($_, my $numeric) = @_;
49 s/([^a-zA-Z0-9])/sprintf("_X%02x_", ord($1))/ge;
53 s/^(\d)/_$1/ if $numeric;
57 sub special_forth_to_c_name
59 ($_, my $numeric) = @_;
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);
69 # $DEBUG and print STDERR "\tmaking it $_\n";
73 getopts('dhs:') or die "Invalid option!\n";
77 $opt_s and $opt_s != 32 and $opt_s != 64 and die("Only -s32 or -s64 allowed");
79 $opt_s and $opt_s == 32 and $CELLSIZE=4;
81 $DEBUG and printf STDERR "Cell size set to $CELLSIZE;\n";
84 %special = ( _N => 2, _O => 2, _C => 2, _A => 2 );
86 $DEBUG and print STDERR "Compiling:";
88 if ($line =~ /^([a-z]{3})\(([^ ]+)./) {
92 $DEBUG and print STDERR "\n\t\t$name###\n";
94 $name =~ s/\)$// if $line =~ /\)\s+_ADDING.*$/;
95 # $DEBUG and print STDERR " $name";
96 $cname = forth_to_c_name($name, 1);
104 # if ($typ eq "com") {
108 ($str, $strcells) = (string $name, $extra);
109 if ($line =~ /^str\([^"]*"([^"]*)"/) {
110 # $DEBUG and print STDERR "[[[$1]]]\n";
112 $line =~ s/"[^"]*"/$s/;
114 if ($line =~ /_ADDING +(.*)$/) {
116 @typ = (split /\s+/, $1);
118 $par = "(" . (join ", ", map { $count++; "_x$count" } @typ) . ")";
120 $add = join " ", map { $count++; "$_(_x$count)" } @typ;
121 $line =~ s/\s+_ADDING.*$//;
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;
131 $body[0] = special_forth_to_c_name($body[0]);
133 # $DEBUG and print STDERR "BODY IS: ", (join " ", @body), "\n";
134 $body = join " ", @body;
136 # $DEBUG and print STDERR "===> $body\n";
138 print "header($cname, { .a = $link }, $str) ";
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";
148 $DEBUG and print STDERR "\n";