NetNews Usenet Archive 1992 #31/NN_1992_31.iso/spool/alt/sources/2875

Text File | 1992-12-23 | 14.2 KB | 566 lines

Newsgroups: alt.sources
Path: sparky!uunet!spool.mu.edu!news.cs.indiana.edu!umn.edu!csus.edu!netcom.com!thinman
From: [e-mail] (Technically Sweet)
Subject: COOL: C Object-Oriented Library: part 4 of 4
Message-ID: <[e-mail]>
Organization: International Foundation for Internal Freedom
Date: Wed, 23 Dec 1992 19:16:19 GMT
Lines: 556

#!/bin/sh
# This is part 04 of a multipart archive
# ============= benchall ==============
if test -f 'benchall' -a X"$1" != X"-c"; then
    echo 'x - skipping benchall (File already exists)'
else
echo 'x - extracting benchall (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'benchall' &&
X# Compile COOL benchmark and run.
X# with & without GCC, optimization
X
X# Copyright 1991 by Lance Norskog
X
XBENCHFILES="bench.c timer.c class.c exception.c lookup.c msg.c util.c"
X
XSYS="-DUSG -Di386"
X
Xset -x
Xc() {
X    rm -f bench
X    $* $SYS $BENCHFILES -o bench
X    echo "CC=$*"
X    bench
X    echo
X}
Xc cc
Xc cc -O
Xc gcc -fwritable-strings
Xc gcc -fwritable-strings -O
SHAR_EOF
chmod 0644 benchall ||
echo 'restore of benchall failed'
Wc_c="`wc -c < 'benchall'`"
test 348 -eq "$Wc_c" ||
    echo 'benchall: original size 348, current size' "$Wc_c"
fi
# ============= out.unix386 ==============
if test -f 'out.unix386' -a X"$1" != X"-c"; then
    echo 'x - skipping out.unix386 (File already exists)'
else
echo 'x - extracting out.unix386 (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'out.unix386' &&
Xbench.c:
Xtimer.c:
Xclass.c:
Xexception.c:
Xlookup.c:
Xmsg.c:
Xutil.c:
XCC=cc
XObject:    34.05
XCoolt:    14.97
XTable:    6.57
XCase:    8.78
XCall:    5.65
XCode:    1.84
XObject: 3.9  Cool 1.7  Table 0.75  Case  1  Call 0.64  Code 0.21
X
Xbench.c:
Xtimer.c:
Xclass.c:
Xexception.c:
Xlookup.c:
Xmsg.c:
Xutil.c:
XCC=cc -O
XObject:    30.59
XCoolt:    13.65
XTable:    5.65
XCase:    4.01
XCall:    2.14
XCode:    1.38
XObject: 7.6  Cool 3.4  Table 1.4  Case  1  Call 0.53  Code 0.34
X
XCC=gcc -fwritable-strings
XObject:    27.5
XCoolt:    10.85
XTable:    5.81
XCase:    7.3
XCall:    4.74
XCode:    1.99
XObject: 3.8  Cool 1.5  Table 0.8  Case  1  Call 0.65  Code 0.27
X
XCC=gcc -fwritable-strings -O
XObject:    23.56
XCoolt:    7.65
XTable:    5.65
XCase:    4.89
XCall:    4.38
XCode:    1.36
XObject: 4.8  Cool 1.6  Table 1.2  Case  1  Call 0.9  Code 0.28
X
SHAR_EOF
chmod 0644 out.unix386 ||
echo 'restore of out.unix386 failed'
Wc_c="`wc -c < 'out.unix386'`"
test 745 -eq "$Wc_c" ||
    echo 'out.unix386: original size 745, current size' "$Wc_c"
fi
# ============= tstall.com ==============
if test -f 'tstall.com' -a X"$1" != X"-c"; then
    echo 'x - skipping tstall.com (File already exists)'
else
echo 'x - extracting tstall.com (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'tstall.com' &&
X$ set noon
X$ run tst1
X$ run tst2
X$ run tst3
X$ run tst4
X$ run tst5
X$ run tst6
X$ exit
SHAR_EOF
chmod 0644 tstall.com ||
echo 'restore of tstall.com failed'
Wc_c="`wc -c < 'tstall.com'`"
test 84 -eq "$Wc_c" ||
    echo 'tstall.com: original size 84, current size' "$Wc_c"
fi
# ============= patchlevel.h ==============
if test -f 'patchlevel.h' -a X"$1" != X"-c"; then
    echo 'x - skipping patchlevel.h (File already exists)'
else
echo 'x - extracting patchlevel.h (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'patchlevel.h' &&
X#define    PATCHLEVEL    3
X
SHAR_EOF
chmod 0644 patchlevel.h ||
echo 'restore of patchlevel.h failed'
Wc_c="`wc -c < 'patchlevel.h'`"
test 22 -eq "$Wc_c" ||
    echo 'patchlevel.h: original size 22, current size' "$Wc_c"
fi
# ============= cool_elk.c ==============
if test -f 'cool_elk.c' -a X"$1" != X"-c"; then
    echo 'x - skipping cool_elk.c (File already exists)'
else
echo 'x - extracting cool_elk.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'cool_elk.c' &&
X/*
X * ELK loader for my COOL library.
X *
X * Place this file in the lib/ directory in the ELK distribution.
X *
X * This was my first attempt at connecting COOL and a Scheme.
X * Pretty shakey but it works.  Try doing cool-msg-i with
X * the Counter class in the COOL test files.
X */
X#include <scheme.h>
X
Xextern char *getenv();
XObject V_Home;
X
Xtypedef void (*voidp)();
X
X#define    NARGS 8
X#define    MAXSTR 512
X#define BIGSTR(n)    (n >= MAXSTR)
X
X/* argv[0] is target method, argv[1] is message, other objects are args to it */
Xstatic GENERIC do_cool_msg (argc, argv)
XObject *argv;
X{
X    char *coolob, *coolmeth, *args[NARGS];
X    register i, n;
X    unsigned long ret;
X    voidp funcp;
X
X    Alloca_Begin;
X    Check_Type (argv[0], T_String);
X    n = STRING(argv[0])->size;
X    Alloca (coolob, char*, n + 1);
X    bcopy (STRING(argv[0])->data, coolob, n);
X    coolob[n] = '\0';
X    n = STRING(argv[1])->size;
X    Alloca (coolmeth, char*, n + 1);
X    bcopy (STRING(argv[1])->data, coolmeth, n);
X    coolmeth[n] = '\0';
X
X    for(i = 0; i < 8; i++)
X        args[i] = 0;
X
X    for(i = 0, n = argc - 2, argv += 2; n > 0; n--, i++) {
X    switch(TYPE(argv[i])) {
X        case T_Fixnum:
X            args[i] = (GENERIC) FIXNUM(argv[i]);
X            break;
X        case T_String:
X            n = STRING(argv[i])->size;
X            Alloca ((GENERIC) args[i], GENERIC, n+1);
X            bcopy (STRING(argv[i])->data, (GENERIC) args[i], n);
X            ((char *) args[i])[n] = '\0';
X            break;
X        default:
X            Primitive_Error ("Type ~d: ", TYPE(argv[i]));
X    }
X    }
X    /* This might make some machines happier.  I don't know. */
X    switch(argc - 2) {
X    case 0:        ret = cool_msg(coolob, coolmeth);
X            break;
X    case 1:        ret = cool_msg(coolob, coolmeth, args[0]);
X            break;
X    case 2:        ret = cool_msg(coolob, coolmeth, args[0], args[1]);
X            break;
X    case 3:        ret = cool_msg(coolob, coolmeth, args[0], args[1],
X              args[2], args[3]);
X            break;
X    case 4:        ret = cool_msg(coolob, coolmeth, args[0], args[1],
X              args[2], args[3], args[4]);
X            break;
X    case 5:        ret = cool_msg(coolob, coolmeth, args[0], args[1],
X              args[2], args[3], args[4], args[5]);
X            break;
X    case 6:        ret = cool_msg(coolob, coolmeth, args[0], args[1],
X              args[2], args[3], args[4], args[5], args[6]);
X            break;
X    case 7:        ret = cool_msg(coolob, coolmeth, args[0], args[1],
X              args[2], args[3], args[4], args[5], args[6], args[7]);
X            break;
X    case 8:        ret = cool_msg(coolob, coolmeth, args[0], args[1],
X              args[2], args[3], args[4], args[5],
X              args[6], args[7], args[8]);
X            break;
X    }
X    Alloca_End;
X    return (GENERIC) ret;
X}
X
Xstatic Object P_cool_msg_void (argc, argv) Object *argv; {
X    do_cool_msg(argc, argv);
X    return Void;
X}
X
Xstatic Object P_cool_msg_fixnum (argc, argv) Object *argv; {
X    int n;
X
X    n = (int) do_cool_msg(argc, argv);
X    return Make_Fixnum(n);
X}
X
Xstatic Object P_cool_msg_string (argc, argv) Object *argv; {
X    char *s;
X
X    s = (char *) do_cool_msg(argc, argv);
X    return Make_String(s);
X}
X
X/* how can I do this?  Pointers?
Xstatic Object P_cool_msg_float (argc, argv) Object *argv; {
X    n = do_cool_msg(argc, argv);
X    return Make_Fixnum(n);
X}
X*/
X
Xinit_lib_cool () {
X    cool_init();
X    /* it's the only way! */
X    Define_Primitive (P_cool_msg_void, "cool-msg", 2, 10, VARARGS);
X    Define_Primitive (P_cool_msg_fixnum, "cool-msg-i", 2, 10, VARARGS);
X    Define_Primitive (P_cool_msg_string, "cool-msg-s", 2, 10, VARARGS);
X    /* Define_Primitive (P_cool_msg_float, "cool-msg-f", 2, 10, VARARGS); */
X}
X
SHAR_EOF
chmod 0644 cool_elk.c ||
echo 'restore of cool_elk.c failed'
Wc_c="`wc -c < 'cool_elk.c'`"
test 3440 -eq "$Wc_c" ||
    echo 'cool_elk.c: original size 3440, current size' "$Wc_c"
fi
# ============= cool_scm.c ==============
if test -f 'cool_scm.c' -a X"$1" != X"-c"; then
    echo 'x - skipping cool_scm.c (File already exists)'
else
echo 'x - extracting cool_scm.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'cool_scm.c' &&
X
X/*
X * SCM interface for my COOL library.
X *
X * Based on a b-tree interface from Aubrey Jaffer, and much code pigging.
X *
X * Place this file in the src/ directory in the COOL distribution.
X *
X * You must configure the SCM makefile to use "-DINITS=" cool_init()
X * AND coolscm_init() AND your COOL classes.
X *
X */
X
X#include "scm.h"
X#include "cool.h"
X#include "coolint.h"
X
X/* assume nargs == 8 */
Xtypedef unsigned long u_long;
X
Xstatic unsigned long argval[9];
Xstatic char *scmtypes[9];
Xstatic char **ctypes;
X
Xint dubs = 0;
Xdouble dub[9][16];
X
Xstatic void getvalue();
X
X/* later: rip out as subroutine and do ret-void, ret-num, ret-str, ret-float */
Xstatic char s_cool_msg[] = "cool-msg";
X
XSCM cool_domsg(o, m, args)
X     SCM o, m, args;
X{
X    int i, j, nargs, foundargs, foundit;
X    object_t ob;
X    method_t msg, nmsg;
X    char name[20], *rtype, *s;
X    unsigned long ret32;
X    double retd;
X
X    ASSERT(INUMP(o) || STRINGP(o),o,ARG1,s_cool_msg);
X    ASSERT(INUMP(m) || STRINGP(m),m,ARG2,s_cool_msg);
X    getvalue(o, &ob, (char *) 0, 0);
X    getvalue(m, &msg, (char *) 0, 0);
X    strcpy(name, (char *) msg);
X
X    dubs = 0;    /* set up doubles marching */
X
X    /* copy argument list into argument area */
X    if NNULLP(args) {
X        SCM *lloc = &args;
X        /* args points to a list of arguments, each in the CAR */
X        for(foundargs = 0; NNULLP(*lloc); foundargs++) {
X            getvalue(CAR(*lloc), &argval[foundargs],
X                &scmtypes[foundargs], 1);
X            lloc = &CDR(*lloc);
X        }
X    }
X    ob = cool_object(ob);
X    msg = cool_method(ob, msg);
X
X    /* walkmethods test */
X    if (s = strchr(name, ':'))
X        *s = '\0';
X    if (s = strchr(name, '='))
X        *s = '\0';
X    if (s = strchr(name, ','))
X        *s = '\0';
X    foundit = 0;
X    nmsg = (method_t) -1;
X    while(cool_walkmethods(ob, name, &nmsg, &rtype, &nargs, &ctypes)) {
X/*
X        printf("walk %s", name);
X        if (rtype)
X            printf("=%s", (rtype > 100) : rtype ? itoa(rtype));
X        if (scmtypes[0])
X            for(i = 0; j = scmtype[i]; i++)
X                printf("%s%s", i ? "," : ":",
X                    (j > 100) : j ? itoa(j));
X        printf("\n");
X*/
X        if (nargs != foundargs)
X            continue;
X        /* No argument list to check.  Just take it and go. */
X        if (! scmtypes[0]) {
X            foundit = 1;
X            break;
X        }
X
X        for(i = 0; i < nargs; i++) {
X            /* do type-matching */
X            if (((scmtypes[i] == CINT) || (scmtypes[i] == CSTR))
X                    && (ctypes[i] == COBJ))
X                cool_object(argval[i]);    /* check */
X/* ??    else if ((scmtypes[i] == CINT) && (ctypes[i] == CBOOL))*/
X            /* there's more here, but... */
X            else if (scmtypes[i] != ctypes[i])
X                goto next;
X            /* without an object, we can't check a method */
X        }
X        foundit = 1;
X        break;
X
X        next:;
X    }
X
X    if (foundit)
X        msg = nmsg;
X
X    if (rtype == CDBL) {
X        retd = (double) cool_msg(ob, msg, argval[0], argval[1],
X                argval[2], argval[3], argval[4],
X                argval[5], argval[6], argval[7]);
X        return(makdbl(retd, 0.0));
X    }
X    ret32 = (u_long) cool_msg(ob, msg, argval[0], argval[1],
X            argval[2], argval[3], argval[4],
X            argval[5], argval[6], argval[7]);
X    switch ((int) rtype) {
X        case 0:
X            return BOOL_T;    /* no return type specified */
X        case (int) CVOID:
X            return EOL;    /* empty list */
X        case (int) CINT:
X            ASSERT(ret32 < 0xc0000000,ret32,"cool int",s_cool_msg);
X            return MAKINUM(ret32);
X        case (int) CBOOL:
X            return ret32 ? BOOL_T : BOOL_F;
X        case (int) CCHAR:
X            ASSERT(ret32 < 256, ret32,"cool char",s_cool_msg);
X            return MAKICHR(ret32);
X        case (int) CSTR:
X            return make_string((char *)ret32,strlen((char *)ret32));
X        case (int) COBJ:
X            return MAKINUM(cool_object(ret32));
X        case (int) CMSG:
X            return MAKINUM(ret32);    /* Can't check methods! */
X        case (int) CIVECT:
X            /* copy data structure */
X        case (int) CDVECT:
X            /* copy data structure */
X/* outlawed    case (int) CANY:     */
X        default:
X            break;
X            /* it's a string, so it's a class name? */
X            /* enforce that it be an object in that class */
X    }
X    return BOOL_T;
X}
X
Xstatic void
Xgetvalue(x, valp, typep, dup)
XSCM x;
Xunsigned long *valp;
Xchar **typep;
Xint dup;
X{
X    char *s, *t;
X    int i, j, l, l2;
X    double *dptr;
X    SCM *ptr, *ptr2, *nump;
X
X    if (!typep)
X        typep = &t;
X
X    if IMP(x) {
X        /* handle immediate cases */
X        if INUMP(x) {
X            *valp = (unsigned long) INUM(x);
X            *typep = CINT;
X        } else  if (x == BOOL_T) {
X            *valp = 1;
X            *typep = CINT;
X        } else  if (x == BOOL_F) {
X            *valp = 0;
X            *typep = CINT;
X        } else  if ICHRP(x) {
X            *valp = ICHR(x);
X            *typep = CCHAR;
X        } else
X            wta(x, "COOL doesn't grok this immediate type", s_cool_msg);
X    } else {
X        if STRINGP(x) {
X    /*
X            *valp = cool_malloc(LENGTH(x) + 1);
X            strcpy(*valp, CHARS(x), LENGTH(x));
X    */
X        /* not needed, but paranoid until COOL customized for SCM GC. */
X            if (dup)
X                *valp = (unsigned long) cool_strdup(CHARS(x));
X            else
X                *valp = (unsigned long) CHARS(x);
X            *typep = CSTR;
X        } else if VECTORP(x) {
X/* Only handles 3 or 4-value points and [34]x[34] matrices */
X            l = LENGTH(x);
X            ptr = VELTS(x);
X            /* translate ints or floats into vector of doubles */
X            dptr = dub[dubs++];
X            *valp = (unsigned long) dptr;
X            if (NVECTORP(ptr[0])) {
X                *typep = CDPOINT;
X                for(i = 0; i < l; i++) {
X                    if (INUMP(ptr[i])) {
X                        *dptr++ = (double) INUM(ptr[i]);
X                    } else if (REALP(ptr[i])) {
X                        *dptr++ = REALPART(ptr[i]);
X                    } else
Xwta(x, "COOL:vector must be of ints or floats", s_cool_msg);
X                }
X                if (l == 3) {
X                    *dptr++ = 0.0;
X                } else if (l != 4)
Xwta(x, "COOL:vector must be 4 items long", s_cool_msg);
X            } else  {
X                *typep = CDHOMOG;
X                for(i = 0; i < l; i++) {
X                    ptr2 = (SCM *) ptr[i];
X                    if (NVECTORP(ptr2))
Xwta(x, "COOL:matrix must be vectors of ints or floats", s_cool_msg);
X                    l2 = LENGTH(ptr2);
X                    nump = VELTS(ptr2);
X                    for(j = 0; j < l2; j++) {
X                        if (INUMP(nump[j])) {
X                          *dptr++=(double)INUM(nump[j]);
X                        } else if (REALP(nump[j])) {
X                          *dptr++ = REALPART(nump[j]);
X                        } else
Xwta(x, "COOL:matrix must be vectors of ints or floats", s_cool_msg);
X                    }
X                    if (l2 == 3) {
X                        *dptr++ = 0.0;
X                    }
X                    else if (l2 != 4)
Xwta(x, "COOL:vector must be 4 items long", s_cool_msg);
X                }
X                if (l == 3) {
X                    *dptr++ = 0.0;
X                    *dptr++ = 0.0;
X                    *dptr++ = 0.0;
X                    *dptr++ = 0.0;
X                } else if (l != 4)
Xwta(x, "COOL:vector must be 4 items long", s_cool_msg);
X            }
X    /* A matrix is a vector of 4 vectors of 3 or 4 ints/doubles */
X        } else
X            wta(x, "COOL doesn't (yet) grok this non-imm type",
X                s_cool_msg);
X    }
X}
X
Xstatic iproc lsubr2s[]={
X    {s_cool_msg,cool_domsg},
X    {0,0}};
X
Xvoid coolscm_init()
X{
X    init_iprocs(lsubr2s, tc7_lsubr_2);
X}
X
X
X
SHAR_EOF
chmod 0644 cool_scm.c ||
echo 'restore of cool_scm.c failed'
Wc_c="`wc -c < 'cool_scm.c'`"
test 6375 -eq "$Wc_c" ||
    echo 'cool_scm.c: original size 6375, current size' "$Wc_c"
fi
exit 0
--

Lance Norskog

Data is not information is not knowledge is not wisdom.