ftp.nice.ch/pub/next/developer/languages/cows/COWS.1.4.s.tar.gz#/COWS/Other Files/Michal Jaegermann/mkmath.pl

This is mkmath.pl in view mode; [Download] [Up]

$indent = 4;
$addlist='';
$opening = q!

#import <stdio.h>
#import <math.h>
#import "COWSMathLibrary.h"

@implementation COWSMathLibrary

#define ERRBFLEN 128

char *needs1 = "needs exactly one parameter";
char *needs2 = "needs exactly two parameters";

static id
COWSMathErr(id result, const char *fname, const char *errmes)
{
    char buf[ERRBFLEN];

    if (NULL == errmes)
        sprintf(buf, "%s: %s", fname, strerror(errno));
    else 
        sprintf(buf, "%s %s", fname, errmes);
    [result setString: buf];
    [result setError: YES];
    return result;
}

!;

$closing = q!
@end
!;

print $opening;
while (<>) {
    next if /^\#/;		# skip comments
    next if /^\s*$/;		# skip blank lines
    &make_funcs(split(' ', $_));
}
&make_lfunc;
print $closing;


sub make_lfunc {
    local($depth) = 0;
    local($blanks);

    $depth++;
    $blanks = ' ' x ($indent * $depth);
    print "\n- loadLibrary:sender {\n",
          $blanks, "id result = [super loadLibrary:sender];\n\n";
    print $blanks,
             'if (![sender conformsTo:@protocol(LibraryControl)]) {', "\n";
    $depth++;
    $blanks = ' ' x ($indent * $depth);
    print $blanks, 'puts ("MathLibrary error: "', "\n", $blanks,
         (' ' x $indent), '  "Interpreter doesn',
         "'", 't conform to LibraryControl!");',
         "\n", $blanks, "return NULL;\n";

    $depth--;
    $blanks = ' ' x ($indent * $depth);
    print $blanks, "}\n\n";
    print $addlist;
    print $blanks, "\n", $blanks, "return result;\n}\n";
}

sub make_funcs {
    local($cowsname, $lname, @types) = @_;
    local(@argl, $blanks, $test, $nargs);
    local($depth) = 0;

    $nargs = @types;		# $nargs is always 1 or 2
    @argl = (1 == $nargs ? ('arg') : ('arg1', 'arg2'));
    print "\n- math_", $lname, ": arg_list {\n";
    $depth++;
    $blanks = ' ' x ($indent * $depth);

    $addlist .= $blanks;
    $addlist .= '[sender addLibraryFunction: "' . $cowsname . '"';
    $addlist .= "\n" . '                        selector:@selector(math_';
    $addlist .= $lname . ":)\n                        target:self];\n";

    print $blanks, 'id result=[[COWSStringNode alloc] init];', "\n\n";

    grep((print $blanks, 'id ', $_, ' = [arg_list pop];', "\n") && 0, @argl);
    $test = '';
    grep(($test .= $_ . ' && ') && 0, @argl);
    $test .= '![arg_list top]';
    print "\n", $blanks, 'if(', $test, ') {', "\n";
    print $blanks, '  // arg_list should be empty after first ',
                  (1 == $nargs ? 'parameter' : $nargs . ' parameters'), "\n";
    $depth++;
    $blanks = ' ' x ($indent * $depth);
    print $blanks, "errno = 0;\n";
    $test = '';
    grep(($test .= '[' . $_ .' XVal], ') && 0, @argl);
    grep(($test =~ s/X/$_/) && 0, @types);
    chop($test); chop($test);
    print $blanks, '[result setDoubleVal:', $lname, '(', $test, ")];\n";
    print $blanks,
            'if (errno) {    // set by ', $lname, " if error occurred\n";
    $depth++;
    $blanks = ' ' x ($indent * $depth);
    print $blanks,
            'result = COWSMathErr(result, "', $cowsname, '", NULL);', "\n";
    $depth--;
    $blanks = ' ' x ($indent * $depth);
    print $blanks, "}\n";
    $depth--;
    $blanks = ' ' x ($indent * $depth);
    print $blanks, "}\n", $blanks, "else {\n";
    $depth++;
    $blanks = ' ' x ($indent * $depth);
    print $blanks,
       'result = COWSMathErr(result, "', $cowsname, '", needs', $nargs, ");\n";
    $depth--;
    $blanks = ' ' x ($indent * $depth);
    print $blanks, "}\n";
    grep((print $blanks, 'if (NULL != ', $_, ")\n", $blanks, (' ' x $indent),
	  '[', $_, ' free];', "\n") && 0, @argl);
    print $blanks, "return result;\n}\n";
}

exit 0;

These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.