forked from lix-project/lix
56af8e86e3
an ATprotect call, these could be garbage collected, leading to weird crashes or wrong results.
180 lines
5.7 KiB
Perl
Executable file
180 lines
5.7 KiB
Perl
Executable file
#! /usr/bin/perl -w
|
|
|
|
# This program generates C/C++ code for efficiently manipulating
|
|
# ATerms. It generates functions to build and match ATerms according
|
|
# to a set of constructor definitions defined in a file read from
|
|
# standard input. A constructor is defined by a line with the
|
|
# following format:
|
|
#
|
|
# SYM | ARGS | TYPE | FUN?
|
|
#
|
|
# where SYM is the name of the constructor, ARGS is a
|
|
# whitespace-separated list of argument types, TYPE is the type of the
|
|
# resulting ATerm (which should be `ATerm' or a type synonym for
|
|
# `ATerm'), and the optional FUN is used to construct the names of the
|
|
# build and match functions (it defaults to SYM; overriding it is
|
|
# useful if there are overloaded constructors, e.g., with different
|
|
# arities). Note that SYM may be empty.
|
|
#
|
|
# A line of the form
|
|
#
|
|
# VAR = EXPR
|
|
#
|
|
# causes a ATerm variable to be generated that is initialised to the
|
|
# value EXPR.
|
|
#
|
|
# Finally, a line of the form
|
|
#
|
|
# init NAME
|
|
#
|
|
# causes the initialisation function to be called `NAME'. This
|
|
# function must be called before any of the build/match functions or
|
|
# the generated variables are used.
|
|
|
|
die if scalar @ARGV != 2;
|
|
|
|
my $syms = "";
|
|
my $init = "";
|
|
my $initFun = "init";
|
|
|
|
open HEADER, ">$ARGV[0]";
|
|
open IMPL, ">$ARGV[1]";
|
|
|
|
print HEADER "#include <aterm2.h>\n";
|
|
print HEADER "#ifdef __cplusplus\n";
|
|
print HEADER "namespace nix {\n";
|
|
print HEADER "#endif\n\n\n";
|
|
print IMPL "namespace nix {\n";
|
|
|
|
while (<STDIN>) {
|
|
s/\#.*//;
|
|
next if (/^\s*$/);
|
|
|
|
if (/^\s*(\w*)\s*\|([^\|]*)\|\s*(\w+)\s*\|\s*(\w+)?/) {
|
|
my $const = $1;
|
|
my @types = split ' ', $2;
|
|
my $result = $3;
|
|
my $funname = $4;
|
|
$funname = $const unless defined $funname;
|
|
|
|
my $formals = "";
|
|
my $formals2 = "";
|
|
my $args = "";
|
|
my $unpack = "";
|
|
my $n = 1;
|
|
foreach my $type (@types) {
|
|
my $realType = $type;
|
|
$args .= ", ";
|
|
if ($type eq "string") {
|
|
# $args .= "(ATerm) ATmakeAppl0(ATmakeAFun((char *) e$n, 0, ATtrue))";
|
|
# $type = "const char *";
|
|
$type = "ATerm";
|
|
$args .= "e$n";
|
|
# !!! in the matcher, we should check that the
|
|
# argument is a string (i.e., a nullary application).
|
|
} elsif ($type eq "int") {
|
|
$args .= "(ATerm) ATmakeInt(e$n)";
|
|
} elsif ($type eq "ATermList" || $type eq "ATermBlob") {
|
|
$args .= "(ATerm) e$n";
|
|
} else {
|
|
$args .= "e$n";
|
|
}
|
|
$formals .= ", " if $formals ne "";
|
|
$formals .= "$type e$n";
|
|
$formals2 .= ", ";
|
|
$formals2 .= "$type & e$n";
|
|
my $m = $n - 1;
|
|
# !!! more checks here
|
|
if ($type eq "int") {
|
|
$unpack .= " e$n = ATgetInt((ATermInt) ATgetArgument(e, $m));\n";
|
|
} elsif ($type eq "ATermList") {
|
|
$unpack .= " e$n = (ATermList) ATgetArgument(e, $m);\n";
|
|
} elsif ($type eq "ATermBlob") {
|
|
$unpack .= " e$n = (ATermBlob) ATgetArgument(e, $m);\n";
|
|
} elsif ($realType eq "string") {
|
|
$unpack .= " e$n = ATgetArgument(e, $m);\n";
|
|
$unpack .= " if (ATgetType(e$n) != AT_APPL) return false;\n";
|
|
} else {
|
|
$unpack .= " e$n = ATgetArgument(e, $m);\n";
|
|
}
|
|
$n++;
|
|
}
|
|
|
|
my $arity = scalar @types;
|
|
|
|
print HEADER "extern AFun sym$funname;\n\n";
|
|
|
|
print IMPL "AFun sym$funname = 0;\n";
|
|
|
|
if ($arity == 0) {
|
|
print HEADER "extern ATerm const$funname;\n\n";
|
|
print IMPL "ATerm const$funname = 0;\n";
|
|
}
|
|
|
|
print HEADER "static inline $result make$funname($formals) __attribute__ ((pure, nothrow));\n";
|
|
print HEADER "static inline $result make$funname($formals) {\n";
|
|
if ($arity == 0) {
|
|
print HEADER " return const$funname;\n";
|
|
}
|
|
elsif ($arity <= 6) {
|
|
print HEADER " return (ATerm) ATmakeAppl$arity(sym$funname$args);\n";
|
|
} else {
|
|
$args =~ s/^,//;
|
|
print HEADER " ATerm array[$arity] = {$args};\n";
|
|
print HEADER " return (ATerm) ATmakeApplArray(sym$funname, array);\n";
|
|
}
|
|
print HEADER "}\n\n";
|
|
|
|
print HEADER "#ifdef __cplusplus\n";
|
|
print HEADER "static inline bool match$funname(ATerm e$formals2) {\n";
|
|
print HEADER " if (ATgetType(e) != AT_APPL || (AFun) ATgetAFun(e) != sym$funname) return false;\n";
|
|
print HEADER "$unpack";
|
|
print HEADER " return true;\n";
|
|
print HEADER "}\n";
|
|
print HEADER "#endif\n\n\n";
|
|
|
|
$init .= " sym$funname = ATmakeAFun(\"$const\", $arity, ATfalse);\n";
|
|
$init .= " ATprotectAFun(sym$funname);\n";
|
|
if ($arity == 0) {
|
|
$init .= " const$funname = (ATerm) ATmakeAppl0(sym$funname);\n";
|
|
$init .= " ATprotect(&const$funname);\n";
|
|
}
|
|
}
|
|
|
|
elsif (/^\s*(\w+)\s*=\s*(.*)$/) {
|
|
my $name = $1;
|
|
my $value = $2;
|
|
print HEADER "extern ATerm $name;\n";
|
|
print IMPL "ATerm $name = 0;\n";
|
|
$init .= " $name = $value;\n";
|
|
$init .= " ATprotect(&$name);\n";
|
|
}
|
|
|
|
elsif (/^\s*init\s+(\w+)\s*$/) {
|
|
$initFun = $1;
|
|
}
|
|
|
|
else {
|
|
die "bad line: `$_'";
|
|
}
|
|
}
|
|
|
|
print HEADER "void $initFun();\n\n";
|
|
|
|
print HEADER "static inline const char * aterm2String(ATerm t) {\n";
|
|
print HEADER " return (const char *) ATgetName(ATgetAFun(t));\n";
|
|
print HEADER "}\n\n";
|
|
|
|
print IMPL "\n";
|
|
print IMPL "void $initFun() {\n";
|
|
print IMPL "$init";
|
|
print IMPL "}\n";
|
|
|
|
print HEADER "#ifdef __cplusplus\n";
|
|
print HEADER "}\n";
|
|
print HEADER "#endif\n\n\n";
|
|
print IMPL "}\n";
|
|
|
|
close HEADER;
|
|
close IMPL;
|