#! /usr/local/bin/perl

# $Id: make-xs.pl,v 3.3 2003-03-22 16:10:05 stolpmann Exp $
# ----------------------------------------------------------------------
#

use strict;

sub read_definition {
    my ($filename) = @_;

    my @def = ();
    open F, $filename or die "Cannot open $filename";

    while (my $line = <F>) {
	my @fields = split /[ \t\r\n]+/, $line;

	my $n = scalar(@fields);

	# Skip blank lines:
	next if ($n == 0);

	if ($n < 3) {
	    die "In line:\n$line:\nLine too short";
	};

	if ($fields[0] ne '$' && $fields[0] ne '@') {
	    die ("In line:\n$line:\n" . 'First field must be either $ or @');
        };

        if ($fields[0] eq '@') {
	    die ("In line:\n$line:\n" . '@ return value not supported yet');
        }

        for (my $k=2; $k < $n; ++$k) {
            if ($fields[$k] ne '$' && $fields[$k] ne '@') {
	        die ("In line:\n$line:\n" . "Field $k " .
		     'must be either $ or @');
	    };
	    if ($fields[$k] eq '@') {
		die "In line:\n$line:\n '\@' parameters not supported yet";
	    };
        };

        push(@def, \@fields);
    };
    return @def;
}


sub make_callback {
    my ($fields) = @_;

    my $return_type = $fields->[0];
    my $function_name = $fields->[1];
    # Argument types begin at index 2
    my $n = scalar(@$fields);

    if ($return_type eq '$') {
        print "SV *\n";
    } else {
        print "AV *\n";
    };

    print $function_name, "(";
    for (my $k=2; $k < $n; ++$k) {
        print ", " if ($k > 2);
        print "expr", $k-1;
    };
    print ")\n";

    for (my $k=2; $k < $n; ++$k) {
        print "\t";
        if ($fields->[$k] eq '$') {
            print "SV * ";
        } else {
            print "AV * ";
        };
        print "expr", $k-1, "\n";
    };

    print "\n";

    if ($fields->[2] ne '@') {
        # prototypes do not work in this case
	print "\tPROTOTYPE: ";

	for (my $k=2; $k < $n; ++$k) {
	    print ";" if ($k > 2);
	    print $fields->[$k];
	};
    };

    print "\n";

    print "\tPREINIT:\n\n";

    print "\tvalue args[", $n-2, "];\n";
    print "\tvalue result;\n";
    print "\tvalue *f;\n";

    print "\tCODE:\n\n";

    print "\tf = caml_named_value(\"perl_$function_name\");\n";
    print "\tif (f == NULL) {\n";
    print "\t\tcroak(\"Ocaml function not found: perl_$function_name\");\n";
    print "\t};\n";

    for (my $k=0; $k < $n-2; ++$k) {
	my $j = $k+1;
	print "\targs[$k] = c2ml_perlvalues_scalar_value(&expr$j, NULL);\n";
    };

    print "\tresult = callbackN_exn(*f, ", $n-2, ", args);\n";

    print "\tif (Is_exception_result(result)) {\n";
   print "\t\tcroak(\"Uncaught Ocaml exception: \%s\", String_val(callback(*(caml_named_value(\"Printexc.to_string\")), Extract_exception(result))));\n";
    print "\t} else {\n";
    print "\t\tml2c_perlvalues_scalar_value(result, &RETVAL, NULL);\n";
    print "\t};\n";

    print "\n";
    print "\tOUTPUT: RETVAL\n\n";
}


if (scalar(@ARGV) == 0 || $ARGV[0] eq '-h') {
    print <<'EOF';
Usage: perl make-xs.pl Module

Reads a function description from the file 'functions' and prints
an xs file to stdout. The functions belong to Module.

Function description: Every line describes a function with the
format:

returntype functionname arg1type arg2type ...

Type literals are $ (for scalars) and @ (for arrays).
EOF
    exit(1);
};


print <<'EOF';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "caml/mlvalues.h"
#include "caml/callback.h"

EOF

my $m = $ARGV[0];

print "MODULE = $m   PACKAGE = $m\n";


my @def = read_definition("functions");
foreach my $d (@def) {
    make_callback($d);
}

print <<'EOF';
void
caml_startup(program)
    SV * program;

    PROTOTYPE: $
    PREINIT:
    char **argv;
    char *prog;
    int proglen;
    STRLEN dummylen;

    CODE:
    prog = SvPV(program,dummylen);
    proglen = strlen(prog);
    argv = malloc(3*sizeof(char *));
    argv[0] = "/bin/false";
    argv[1] = malloc(proglen+1);
    argv[2] = NULL;
    strcpy(argv[1],prog);
    caml_main(argv);
EOF

#print <<'EOF';
#
#BOOT:
#{
#    char **a;
#
#    /* Fake the command-line arguments: */
#
#    a = malloc(2*sizeof(char *));
#    a[0] = malloc(1);
#    a[0][0] = 0;
#    a[1] = NULL;
#    caml_startup(a);
#}
#EOF

# ======================================================================
# History:
#
# $Log: make-xs.pl,v $
# Revision 3.3  2003-03-22 16:10:05  stolpmann
# 	Fix: The bytecode file is passed to caml_main as first argument
# instead of as zeroth argument. Fixes a problem with Linux.
#
# Revision 3.2  2002/02/27 22:21:48  stolpmann
# 	Compat Perl 5.004: avoid SvPV_nolen
#
# Revision 3.1  2002/02/13 00:16:50  stolpmann
# 	Initial revision at sourceforge
#
# Revision 1.3  2002/01/15 16:10:24  gerd
# 	Updated (O'Caml 3.04 + dynlink)
#
# Revision 1.2  2000/03/02 20:54:54  gerd
# 	Uncaught exceptions are converted to strings by
# Printexc.to_string, not by the C function.
#
# Revision 1.1  2000/02/19 15:04:17  gerd
#     Initial revision.
#
#
