rs@uunet.UU.NET (Rich Salz) (07/07/87)
Mod.sources: Volume 10, Number 36
Submitted by: robison@b.cs.uiuc.edu (Arch Robison)
Archive-name: ifp/Part03
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh.
# The following files will be created:
# interp/F_arith.c
# interp/F_misc.c
# interp/F_pred.c
# interp/F_seq.c
# interp/F_ss.c
# interp/F_string.c
# interp/F_subseq.c
export PATH; PATH=/bin:$PATH
mkdir interp
if test -f 'interp/F_arith.c'
then
echo shar: over-writing existing file "'interp/F_arith.c'"
fi
cat << \SHAR_EOF > 'interp/F_arith.c'
/****** F_arith.c *****************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: June 4, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#include <stdio.h>
#include <math.h>
#include <errno.h>
#include "struct.h"
#include "node.h"
#if OPSYS!=CTSS
extern int errno; /* exists somewhere in UNIX */
#endif
/* NOTE - function Dyadic assumes integers are in two's complement form! */
private F_Minus (), F_AddN (), Monadic (), Dyadic (), F_Sum ();
private OpDef OpArith [] = {
#if OPSYS!=CTSS
{"ln", 0, Monadic},
{"exp", 1, Monadic},
{"sqrt", 2, Monadic},
{"sin", 3, Monadic},
{"cos", 4, Monadic},
{"tan", 5, Monadic},
{"arcsin", 6, Monadic},
{"arccos", 7, Monadic},
{"arctan", 8, Monadic},
#endif
{"minus", -1, F_Minus},
{"add1", 1, F_AddN},
{"sub1", -1, F_AddN},
{"+", 0, Dyadic},
{"-", 1, Dyadic},
{"*", 2, Dyadic},
{"%", 3, Dyadic},
#if OPSYS!=CTSS
{"mod", 4, Dyadic},
{"div", 5, Dyadic},
#endif
{"min", 6, Dyadic},
{"max", 7, Dyadic},
#if OPSYS!=CTSS
{"power", 8, Dyadic},
#endif
{"sum", -1, F_Sum}
};
/*
* Monadic
*
* Evaluate a monadic function
*
* Input
* InOut = argument to apply function
* Op = operation - see array F_Name in code for values
*
* Output
* InOut = result of applying function
*/
private Monadic (InOut,Op)
ObjectPtr InOut;
int Op;
{
double X,Z;
register int E;
if (GetDouble (InOut,&X)) FunError ("not numeric",InOut);
else {
E = 0;
switch (Op) {
#if OPSYS!=CTSS
case 0: /* base e log */
if (X <= 0) E = EDOM;
else Z = log (X);
break;
case 1: /* base e power */
if (X >= LNMAXFLOAT) E = ERANGE;
else Z = exp (X);
break;
case 2: /* square root */
if (X < 0) E = EDOM;
else Z = sqrt (X);
break;
case 3: /* sin */
Z = sin (X);
break;
case 4: /* cos */
Z = cos (X);
break;
case 5: /* tan */
Z = tan (X);
break;
case 6: /* arcsin */
Z = asin (X);
E = errno;
break;
case 7: /* arccos */
Z = acos (X);
E = errno;
break;
case 8: /* arctan */
Z = atan (X);
E = errno;
break;
#endif /* OPSYS!=CTSS */
case 9: /* minus */
Z = -X;
E = 0;
break;
}
switch (E) {
#if OPSYS!=CTSS
case EDOM:
FunError ("domain error",InOut);
break;
case ERANGE:
FunError ("range error",InOut);
break;
#endif
default:
InOut->Tag = FLOAT;
InOut->Float = Z;
break;
}
}
}
private F_Minus (InOut)
register ObjectPtr InOut;
{
if (InOut->Tag == INT && InOut->Int != FPMaxInt+1)
InOut->Int = - InOut->Int;
else Monadic (InOut,9);
}
/*
* F_Sum
*/
private F_Sum (InOut)
ObjectPtr InOut;
{
Object S;
register ListPtr P;
switch (InOut->Tag) {
default:
FunError (ArgNotSeq,InOut);
return;
case LIST:
S.Tag = INT;
S.Int = 0;
for (P=InOut->List; P!=NULL; P=P->Next) {
if (P->Val.Tag != INT && P->Val.Tag != FLOAT) {
FunError ("non-numeric sequence",InOut);
return;
}
if (S.Tag == INT) {
if (P->Val.Tag == INT) {
/* Both arguments are integers. See if we can avoid */
/* floating arithmetic. */
FPint Zi = S.Int + P->Val.Int;
if ((S.Int ^ P->Val.Int) < 0 || (S.Int^Zi))
/* arithmetic overflow occured - float result */;
else {
S.Int = Zi;
continue;
}
}
S.Float = S.Int;
S.Tag = FLOAT;
}
S.Float += P->Val.Tag==INT ? P->Val.Int : P->Val.Float;
}
break;
}
RepObject (InOut,&S);
}
/*
* Dyadic
*
* Evaluate a dyadic function
*
* Input
* InOut = argument to apply function
* Op = operation - see case statement in code for possibilities
*
* Output
* InOut = result of applying function
*
* The author sold his anti-GOTO morals for speed.
*/
private Dyadic (InOut,Op)
register ObjectPtr InOut;
register int Op;
{
double X,Y,Z;
register FPint Xi,Yi,Zi;
register ListPtr P,Q;
static char *DivZero = "division by zero";
if (InOut->Tag != LIST ||
NULL == (P=InOut->List) ||
NULL == (Q=P->Next) ||
Q->Next != NULL ||
NotNumPair (P->Val.Tag,Q->Val.Tag)) {
FunError ("not a numeric pair",InOut);
return;
}
if (IntPair (P->Val.Tag,Q->Val.Tag)) {
/* Both arguments are integers. See if we can avoid floating point */
/* arithmetic. */
Xi = P->Val.Int;
Yi = Q->Val.Int;
switch (Op) {
case 0:
/* assume two's complement arithmetic */
Zi = Xi+Yi;
if (((Xi ^ Yi) | ~(Xi ^ Zi)) < 0) goto RetInt;
break;
/* else arithmetic overflow occured */
case 1:
/* assume two's complement arithmetic */
Zi = Xi - Yi;
if (((Xi ^ Yi) & (Xi ^ Zi)) >= 0) goto RetInt;
/* else arithmetic overflow occured */
break;
case 2:
Zi = Xi * Yi;
if (Yi==0 || Zi/Yi == Xi) goto RetInt;
/* else arithmetic overflow occured */
break;
/* case 3: division result always FLOAT */
#if OPSYS!=CTSS
case 4: /* mod */
if (Xi >= 0 && Yi > 0) {
Zi = Xi % Yi;
goto RetInt;
}
break;
case 5: /* div */
if (Xi >= 0 && Yi > 0) {
Zi = Xi / Yi;
goto RetInt;
}
break;
#endif /* OPSYS!=CTSS */
case 6:
Zi = Xi > Yi ? Yi : Xi;
goto RetInt;
case 7:
Zi = Xi < Yi ? Yi : Xi;
goto RetInt;
/* case 8: power result always FLOAT */
}
}
X = P->Val.Tag==INT ? P->Val.Int : P->Val.Float;
Y = Q->Val.Tag==INT ? Q->Val.Int : Q->Val.Float;
switch (Op) {
case 0: Z = X + Y; break;
case 1: Z = X - Y; break;
case 2: Z = X * Y; break;
case 3:
if (Y==0.0) {
FunError (DivZero,InOut);
return;
}
Z = X / Y;
break;
#if OPSYS!=CTSS
case 4:
Z = Y==0.0 ? 0.0 : X - floor (X / Y) * Y; /* mod */
break;
case 5:
if (Y==0.0) { /* div */
FunError (DivZero,InOut);
return;
}
Z = floor (X / Y);
break;
#endif
case 6: Z = X > Y ? Y:X; break;
case 7: Z = X > Y ? X:Y; break;
#if OPSYS!=CTSS
case 8: Z = pow (X,Y); break;
#endif
}
InOut->Tag = FLOAT;
InOut->Float = Z;
Return:
DelLPtr (P);
return;
RetInt:
InOut->Tag = INT;
InOut->Int = Zi;
goto Return;
}
/*
* F_Add1
*/
private F_AddN (InOut,N)
register ObjectPtr InOut;
int N;
{
register FPint K;
switch (InOut->Tag) {
case INT:
K = InOut->Int + N;
if (N >= 0 ? InOut->Int <= K : InOut->Int > K) {
InOut->Int = K;
return;
}
/* else integer overflow - convert and drop down */
InOut->Float = ((FPfloat) InOut->Int);
InOut->Tag = FLOAT;
case FLOAT:
InOut->Float = InOut->Float + N;
break;
default:
FunError ("not a number",InOut);
break;
}
}
void D_arith ()
{
GroupDef (OpArith,OpCount (OpArith), ArithNode);
}
/************************** end of F_arith.c **************************/
SHAR_EOF
if test -f 'interp/F_misc.c'
then
echo shar: over-writing existing file "'interp/F_misc.c'"
fi
cat << \SHAR_EOF > 'interp/F_misc.c'
/****** F_misc.c ******************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: Nov 24, 1985 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#include "struct.h"
#include <stdio.h>
#include "node.h"
#include "string.h"
/************************** miscellaneous functions *********************/
/*
* NodeExpand
*
* Replace object with equivalent object not containing nodes or bottoms.
*
* Nodes are converted to equivalent path lists.
* Bottoms are converted to "?".
*/
void NodeExpand (InOut)
register ObjectPtr InOut;
{
register ListPtr P;
register NodePtr N;
switch (InOut->Tag) {
case LIST:
CopyTop (&InOut->List);
for (P=InOut->List; P!=NULL; P=P->Next) NodeExpand (&P->Val);
break;
case NODE:
N = InOut->Node;
RepTag (InOut,LIST);
InOut->List = MakePath (N);
break;
}
}
/*
* F_Def
*
* Return the object representation of a function definition.
*
* Input
* *InOut = pathname list
*
* Output
* *InOut = function definition representation
*/
int F_Def (InOut) /* imported by Compile in C_comp.c */
register ObjectPtr InOut;
{
extern void ReadDef (), RepBool ();
register DefPtr D;
if (InOut->Tag != LIST) FunError (ArgNotSeq,InOut);
else {
LinkPath (InOut,DEF);
if (InOut->Tag==NODE && InOut->Node->NodeType==DEF) {
D = &InOut->Node->NodeData.NodeDef;
if (D->DefCode.Tag != CODE) {
if (D->DefCode.Tag == BOTTOM) ReadDef ((NodePtr) NULL,InOut);
if (D->DefCode.Tag != BOTTOM) {
RepObject (InOut,&D->DefCode);
NodeExpand (InOut);
return;
}
}
}
}
RepBool (InOut,0); /* function not defined */
}
/*
* F_Apply
*
* Apply a function to an object.
*
* Input
* InOut = <X F> where F is a function
*
* Output
* InOut = X : F
*/
private int F_Apply (InOut)
ObjectPtr InOut;
{
register ListPtr P;
/*
* We don't want to use PairTest test here, since it would expand
* the function if its a node. This would not affect the behavior
* at all, but would slow things down since the function must be
* converted to its node representation anyway.
*/
if (InOut->Tag != LIST || 2 != ListLength (InOut->List))
FunError ("not a pair",InOut);
else {
CopyTop (&InOut->List);
P = InOut->List;
if (ApplyCheck (&P->Next->Val)) {
Apply (&P->Val,&P->Next->Val);
RepObject (InOut,&P->Val);
} else
FunError ("invalid function",InOut);
}
}
void D_misc ()
{
(void) PrimDef (F_Apply,"apply",SysNode);
(void) PrimDef (F_Def,"def",SysNode);
}
/**************************** end of F_misc ****************************/
SHAR_EOF
if test -f 'interp/F_pred.c'
then
echo shar: over-writing existing file "'interp/F_pred.c'"
fi
cat << \SHAR_EOF > 'interp/F_pred.c'
/****** F_pred.c ******************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: Dec 1, 1985 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#include <stdio.h>
#include <math.h>
#include "struct.h"
#include "node.h"
/************************** boolean functions **************************/
/*
* PairTest
*
* Check if object is a pair of <type1,type2>
*
* Input
* X = object to test
* Mask1,Mask2 = masks representing type1 and type2 respectively.
* E.g 1<<INT is type INT, (1<<INT)|(1<<FLOAT) is numeric.
*
* Output
* result = 1 if true, 0 if false
*/
boolean PairTest (X,Mask1,Mask2)
ObjectPtr X;
int Mask1,Mask2;
{
register ListPtr P,Q;
if (X->Tag != LIST)
if (X->Tag == NODE) NodeExpand (X);
else return 0;
if ((P=X->List) == NULL || (Q=P->Next) == NULL || Q->Next!=NULL) return 0;
if (P->Val.Tag == NODE) NodeExpand (&P->Val);
if (Q->Val.Tag == NODE) NodeExpand (&Q->Val);
return Mask1 >> P->Val.Tag & Mask2 >> Q->Val.Tag & 1;
}
/*
* Anytime two objects are found to be equal, we can replace one with
* the other to save memory. Clearly the memory savings is offset by
* a little more time, program complexity, and bringing obscure bugs
* out of the woodwork! Therefore the replacing action is enabled if
* MERGE=1, disabled if MERGE=0.
*
* P.S. Someone should check if the merging is really worth the cost.
*/
#define MERGE 0
/*
* BoolOp
*
* Boolean operation
*
* Input
* InOut = argument
* Op = boolean op (4-bit vector representing truth table)
*
* Output
* *A = first element of pair if result is true, undefined otherwise
* *B = second ...
*/
private BoolOp (InOut,Op)
ObjectPtr InOut;
int Op;
{
extern void RepBool ();
register ListPtr P;
if (PairTest (InOut,1<<BOOLEAN,1<<BOOLEAN)) {
P = InOut->List;
RepBool (InOut, (Op >> (P->Next->Val.Bool << 1) + P->Val.Bool) & 1);
} else
FunError ("not a boolean pair",InOut);
}
/*
* F_Not
*
* Boolean negation
*/
private F_Not (InOut)
ObjectPtr InOut;
{
if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
else FunError ("not boolean",InOut);
}
/*
* F_L2
*/
private F_L2 (InOut)
ObjectPtr InOut;
{
switch (InOut->Tag) {
case INT: RepBool (InOut,InOut->Int < 2); break;
case FLOAT: RepBool (InOut,InOut->Float < 2); break;
default: FunError ("not numeric",InOut); break;
}
}
/*
* F_False
*
* Check if argument is boolean false (#f).
*/
private F_False (InOut)
ObjectPtr InOut;
{
if (InOut->Tag == BOTTOM)
FunError (ArgBottom,InOut);
else
if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
else RepBool (InOut,0);
}
/*
* F_Odd
*
* Check if integral argument is odd.
*/
private F_Odd (InOut)
ObjectPtr InOut;
{
FPint N;
switch (GetFPInt (InOut,&N)) {
case 0:
RepBool (InOut,(int)N & 1);
return;
case 2:
FunError ("not enough precision",InOut);
return;
default:
FunError ("not an integer",InOut);
return;
}
}
/*
* BoolSeq
*
* Evaluate "any" or "all" predicate.
*
* Input
* *InOut = argument
* Op = identity element of operation
*
* Output
* *InOut = result
*/
private BoolSeq (InOut,Op)
ObjectPtr InOut;
int Op;
{
register boolean R;
register ListPtr P;
if (InOut->Tag != LIST) FunError (ArgNotSeq,InOut);
else {
R = 0;
for (P = InOut->List; P != NULL; P=P->Next)
if (P->Val.Tag == BOOLEAN) R |= P->Val.Bool ^ Op;
else {
FunError ("non-boolean element",InOut);
return;
}
RepBool (InOut, R ^ Op);
}
}
#if MERGE
/*
* StrMerge
*
* Compare two strings. Merge together if they are equal.
*
* Output
* result = 1 if equal, 0 otherwise
*/
static int StrMerge (S,T)
register StrPtr *S,*T;
{
if (*S == *T) return 2; /* strings are identical */
else if (StrComp (*S,*T)) return 0; /* strings are different */
else {
register StrPtr *U; /* equal and not identical */
if ((*S)->SRef < (*T)->SRef)
U=S, S=T, T=U;
if ((*S)->SRef + 1) { /* S has larger SRef */
DelSPtr (*T);
*T = *S;
(*S)->SRef++;
}
return 1;
}
}
#endif
/*
* ObEqual
*
* Compare two objects. A comparison tolerance is used for floating point
* comparisons.
*
* Output
* result = 0 if objects are not equal
* 1 if objects are equal within comparison tolerance
*/
boolean ObEqual (X,Y)
ObjectPtr X,Y;
{
if (X->Tag != Y->Tag) {
switch (X->Tag) {
case INT:
return Y->Tag==FLOAT &&
!FloatComp ((double) X->Int,(double) Y->Float);
case FLOAT:
return Y->Tag==INT &&
!FloatComp ((double) X->Float,(double) Y->Int);
case NODE:
NodeExpand (X);
break;
case LIST:
if (Y->Tag==NODE) NodeExpand (Y);
break;
default: return 0;
}
}
switch (X->Tag) {
case BOTTOM: return 1;
case BOOLEAN: return X->Bool == Y->Bool;
case INT: return X->Int == Y->Int;
case FLOAT: return !FloatComp ((double) X->Float, (double) Y->Float);
case STRING:
#if MERGE
return StrMerge (&X->String,&Y->String);
#else
return !StrComp (X->String,Y->String);
#endif
case LIST: {
register ListPtr P=X->List, Q=Y->List;
while (1) {
if (P == NULL) return Q == NULL;
if (Q == NULL || !ObEqual (&P->Val,&Q->Val)) return 0;
P = P->Next; Q = Q->Next;
}
}
case NODE: return X->Node == Y->Node;
default: return 0; /* Tag error */
}
}
#define max(A,B) ((A) > (B) ? (A) : (B))
/*
* FloatComp
*
* X ~= Y if abs(X-Y) / max(abs(X),abs(Y)) <= comparison tolerance.
*
* Output
* result = -1 if X < Y
* 0 if X ~= Y
* 1 if X > Y
*/
int FloatComp (X,Y)
double X,Y;
{
double Xm,Ym,D;
Xm = fabs (X);
Ym = fabs (Y);
D = X-Y;
if (fabs (D) <= CompTol*max(Xm,Ym)) return 0;
else return D>0 ? 1 : -1;
}
/*
* F_Equal
*
* Object comparison for equality or inequality
*/
private F_Equal (InOut,Not)
ObjectPtr InOut;
int Not;
{
if (!PairTest (InOut,~0,~0))
FunError ("argument not a pair",InOut);
else
RepBool (InOut, Not ^ (0 < ObEqual (&InOut->List->Val,
&InOut->List->Next->Val)));
}
/*
* F_Null
*
* Null sequence test
*/
private F_Null (InOut)
ObjectPtr InOut;
{
switch (InOut->Tag) {
case LIST:
RepBool (InOut, InOut->List == NULL);
break;
default:
FunError (ArgNotSeq,InOut);
break;
}
}
/*
* F_Pair
*
* Check if argument is a pair.
*/
private F_Pair (InOut)
ObjectPtr InOut;
{
RepBool (InOut, PairTest (InOut,~0,~0));
}
/*
* F_Tag
*
* Check for specified tag
*/
private F_Tag (InOut,TagSet)
ObjectPtr InOut;
{
if (InOut->Tag)
RepBool (InOut,TagSet >> InOut->Tag & 1);
else
FunError (ArgBottom,InOut);
}
/*
* CompAtom
*
* Compare two atoms for <,<=,=>, or >
*
* Strings are ordered lexigraphically.
* Numbers are ordered in increasing value.
*
* Input
* *InOut = <X,Y>
* Op = comparison bit vector [>,=,<]
*
* Output
* *InOut = sign (X - Y) or BOTTOM
*/
private CompAtom (InOut,Op)
ObjectPtr InOut;
int Op;
{
register ObjectPtr X,Y;
int D,E;
static char *ErrMessage [3] = {
"not an atomic pair",
"booleans not comparable",
"strings and numbers not comparable"
};
E = 0;
if (!PairTest (InOut,ATOMIC,ATOMIC)) E = 1;
else {
X = &InOut->List->Val;
Y = &InOut->List->Next->Val;
if (X->Tag == BOOLEAN || Y->Tag == BOOLEAN) E = 2;
else if (X->Tag == STRING || Y->Tag == STRING) {
if (X->Tag != Y->Tag) E = 3;
else {
D = StrComp (X->String,Y->String);
if (D) D = (D>0) ? 1 : -1;
}
} else
if (X->Tag == INT)
if (Y->Tag == INT)
D = (X->Int > Y->Int) - (X->Int < Y->Int);
else
D = FloatComp ((double) X->Int,(double) Y->Float);
else
if (Y->Tag == INT)
D = FloatComp ((double) X->Float,(double) Y->Int);
else
D = FloatComp ((double) X->Float,(double) Y->Float);
}
if (E) FunError (ErrMessage [E-1],InOut);
else RepBool (InOut, (Op >> (D+1)) & 1);
}
/*
* CompLength
*
* Compare the length of two sequences.
*
* Input
* InOut = argument
* Shorter = if 0 then "longer" comparison, "shorter" otherwise.
*/
private CompLength (InOut,Shorter)
ObjectPtr InOut;
int Shorter;
{
register ListPtr P,Q;
if (!PairTest (InOut,1<<LIST,1<<LIST))
FunError ("not a pair of sequences",InOut);
else {
P = InOut->List;
Q = P->Next->Val.List;
P = P->Val.List;
while (P != NULL && Q != NULL) {
P = P->Next;
Q = Q->Next;
}
RepBool (InOut, (Shorter ? Q : P) != NULL);
}
}
/*
* F_Member
*/
private F_Member (InOut)
ObjectPtr InOut;
{
register ListPtr P;
register ObjectPtr X;
if (! PairTest (InOut,1 << LIST,~0))
FunError (ArgSeqOb,InOut);
else {
P = InOut->List;
X = & P->Next->Val;
for (P = P->Val.List; P!=NULL; P=P->Next)
if (ObEqual (& P->Val,X)) break;
RepBool (InOut, P != NULL);
}
}
private OpDef LogicOps [] = {
{"all", 1, BoolSeq},
{"and", 0x8, BoolOp},
{"any", 0, BoolSeq},
{"atom", ATOMIC, F_Tag},
{"boolean", 1<<BOOLEAN, F_Tag},
{"false", -1, F_False},
{"imply", 0xD, BoolOp},
{"longer", 0, CompLength},
{"member", -1, F_Member},
{"null", -1, F_Null},
{"numeric", NUMERIC,F_Tag},
{"odd", -1, F_Odd},
{"or", 0xE, BoolOp},
{"pair", -1, F_Pair},
{"shorter", 1, CompLength},
{"xor", 0x6, BoolOp},
{"=", 0, F_Equal},
{"~=", 1, F_Equal},
{"~", -1, F_Not},
{">", 0x4, CompAtom},
{"<", 0x1, CompAtom},
{">=", 0x6, CompAtom},
{"<=", 0x3, CompAtom},
{"l2", 0, F_L2}
};
void D_pred ()
{
GroupDef (LogicOps, OpCount (LogicOps), LogicNode);
}
/******************************* end of F_pred *******************************/
SHAR_EOF
if test -f 'interp/F_seq.c'
then
echo shar: over-writing existing file "'interp/F_seq.c'"
fi
cat << \SHAR_EOF > 'interp/F_seq.c'
/****** F_seq.c *******************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: Aug 5, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
/******************* sequence (structural) functions ******************/
#include <stdio.h>
#include "struct.h"
#include "node.h"
/*
* F_Cat
*
* Sequence catenation
*/
private F_Cat (InOut)
register ObjectPtr InOut;
{
register MetaPtr E;
register ListPtr P;
if (InOut->Tag != LIST) {
FunError (ArgNotSeq,InOut);
return;
}
P = InOut->List;
if (P == NULL) return;
do
if (P->Val.Tag != LIST) {
FunError ("elements not sequences",InOut);
return;
}
while ((P=P->Next)!=NULL);
Copy2Top (& InOut->List);
if (SysError) return;
P = InOut->List;
E = &P->Val.List;
for (P=P->Next; P!=NULL; P=P->Next) {
while (*E!=NULL) E = &(*E)->Next;
*E = P->Val.List;
P->Val.Tag = BOTTOM;
}
E = &InOut->List;
RepLPtr (E,(*E)->Val.List);
}
/*
* F_Iota
*
* Generate <1...id>
*/
private F_Iota (InOut)
register ObjectPtr InOut;
{
FPint N;
register FPint K;
register ListPtr Pr;
switch (GetFPInt (InOut,&N)) {
case 1: FunError ("not an integer",InOut); return;
case 2: FunError ("too big" ,InOut); return;
case 0:
if (N < 0) FunError ("negative",InOut);
else {
InOut->Tag = LIST;
InOut->List = NULL;
NewList (&InOut->List,N);
if (SysError) return;
for (Pr=InOut->List,K=0; Pr!=NULL; Pr=Pr->Next)
Pr->Val.Tag = INT,
Pr->Val.Int = ++K;
}
return;
}
}
/*
* F_Id
*/
private F_Id ()
{
return; /* do nothing */;
}
/*
* F_Length
*
* Find sequence length
*/
private F_Length (InOut)
ObjectPtr InOut;
{
register FPint N;
switch (InOut->Tag) {
default:
FunError (ArgNotSeq,InOut);
return;
case LIST:
N = ListLength (InOut->List);
break;
}
RepTag (InOut,INT);
InOut->Int = N;
}
/*
* F_LApnd
*
* +--------+
* InOut --->| list |
* +----+---+ A
* | |
* V V
* +------------+ +------------+
* | object | o-+----->| list |///|
* +------------+ +---+--------+
* |
* V
* ...
*/
private F_LApnd (InOut)
ObjectPtr InOut;
{
MetaPtr A;
if (! PairTest (InOut, ~0, SEQUENCE))
FunError (ArgObSeq,InOut);
else {
CopyTop (&InOut->List);
A = & InOut->List->Next;
RepLPtr (A,(*A)->Val.List);
}
}
/*
* F_RApnd
*
* +--------+
* InOut --->| list |
* +----+---+
* |
* V
* +------------+ +------------+
* | list | o-+----->| object |///|
* +------------+ +------------+
* |
* V
* ...
*
*/
private F_RApnd (InOut)
ObjectPtr InOut;
{
register MetaPtr E;
ListPtr P;
if (! PairTest (InOut,1 << LIST,~0))
FunError (ArgSeqOb,InOut);
else {
Copy2Top (& InOut->List);
if (SysError) return;
P = InOut->List;
for (E = &P->Val.List; (*E)!=NULL; E = &(*E)->Next) continue;
*E = P->Next;
P->Next=NULL;
RepLPtr (&InOut->List,P->Val.List);
/* No system error possible since source is fresh list */
}
}
/*
* F_LDist
*
* Distribute from left
*/
private F_LDist (InOut)
ObjectPtr InOut;
{
ListPtr R=NULL;
register ListPtr P1,P2,P3,PT;
long N;
if (!PairTest (InOut, ~0, SEQUENCE))
FunError (ArgObSeq,InOut);
else {
Copy2Top (&InOut->List);
if (SysError) return;
P1 = InOut->List; /* P1 = pointer to arg list */
P2 = P1->Next;
P3 = P2->Val.List; /* P3 = pointer to 2nd arg list */
P2->Val.List = NULL;
N = ListLength (P3);
NewList (&R,N); /* R = pointer to result list */
if (SysError) return;
P2 = Repeat (&P1->Val,N); /* P2 = pointer to 1st arg list */
if (SysError) {DelLPtr (R); return;}
for (P1=R; P1!=NULL; P1=P1->Next) {
P1->Val.Tag = LIST;
P1->Val.List = P2;
PT = P2;
P2 = P2->Next;
PT->Next = P3;
PT = P3;
P3 = P3->Next;
PT->Next = NULL;
}
DelLPtr (InOut->List);
InOut->List = R;
}
}
/*
* F_RDist
*
* Distribute from right
*/
private F_RDist (InOut)
ObjectPtr InOut;
{
ListPtr R,P,P1,P2;
long N;
if (! PairTest (InOut, SEQUENCE, ~0))
FunError (ArgSeqOb,InOut);
else {
Copy2Top (&InOut->List);
if (SysError) return;
P = InOut->List; /* P = pointer to arg list */
P2 = P->Val.List; /* P2 = pointer to first arg list */
P->Val.Tag = BOTTOM;
P = P->Next; /* P = pointer to 2nd arg */
N = ListLength (P2);
R = NULL; NewList (&R,N); /* R = pointer to result list */
if (SysError) return;
for (P1=R; P1!=NULL; P1=P1->Next) {
P1->Val.Tag = LIST;
P1->Val.List = CopyLPtr (P);
if (SysError) {DelLPtr (R); return;}
Rot3 (&P1->Val.List,&P2,&P2->Next);
}
RepLPtr (&InOut->List,R);
DelLPtr (R);
}
}
/*
* F_Reverse
*
* Reverse a list
*/
F_Reverse (InOut) /* Imported by F_RInsert in forms.c */
ObjectPtr InOut;
{
ListPtr P,Q;
switch (InOut->Tag) {
default:
FunError (ArgNotSeq,InOut);
break;
case LIST:
P = InOut->List;
CopyTop (&P);
if (SysError) return;
for (Q=NULL; P!=NULL; Rot3 (&P,&P->Next,&Q)) continue;
InOut->List = Q;
break;
}
}
/*
* TransCheck
*
* Check that InOut is matrix
*
* Input
* InOut = pointer to object
*
* Output
* result = NULL iff a matrix, error code otherwise.
* *Cols = number of columns
*/
private char *TransCheck (InOut,Cols)
ObjectPtr InOut;
long *Cols;
{
register ListPtr V,VR;
if (InOut->Tag != LIST)
return "argument not a sequence.";
else if (NULL == (VR = InOut->List))
return "argument is empty sequence.";
else
for (V = VR; V !=NULL; V = V->Next)
if (V->Val.Tag != LIST)
return "argument subelements must be sequences.";
else if (V==VR) *Cols = ListLength (V->Val.List);
else if (*Cols != ListLength (V->Val.List))
return "argument not rectangular.";
else continue;
return NULL;
}
/*
* F_Trans
*
* Transpose a matrix (sequence of sequences)
*/
private F_Trans (InOut)
ObjectPtr InOut;
{
char *E; long Cols;
ListPtr VR,HR,H;
register ListPtr U,V;
register MetaPtr A;
/* Check for rectangularness */
if (NULL != (E = TransCheck (InOut,&Cols))) {
FunError (E,InOut);
return;
}
/* Make fresh copy of vertical top level and rows */
Copy2Top (&InOut->List);
if (SysError) return;
else VR = InOut->List;
/* Make horizontal top level */
HR = NULL;
NewList (&HR,Cols);
/* Transpose matrix column by column */
for (H=HR; H!=NULL; H=H->Next) {
H->Val.Tag = LIST;
H->Val.List = VR->Val.List;
/* Relink the column and advance the VR list to the next column */
for (V=VR; V!=NULL; V=U) {
U = V->Next;
A = &V->Val.List->Next;
V->Val.List = *A;
*A = U==NULL ? NULL : U->Val.List;
}
}
/* Delete the old vertical top level and return new matrix */
DelLPtr (VR); InOut->List = HR;
}
/*
* F_Tail
*/
private F_Tail (InOut)
ObjectPtr InOut;
{
register ListPtr P;
switch (InOut->Tag) {
default:
FunError (ArgNotSeq,InOut);
break;
case LIST:
if (NULL == (P = InOut->List)) FunError (ArgNull,InOut);
else RepLPtr (&InOut->List,P->Next);
break;
}
}
/*
* F_RTail
*
* Drop last element
*/
private F_RTail (InOut)
ObjectPtr InOut;
{
register MetaPtr A;
if (InOut->Tag != LIST)
FunError (ArgNotSeq,InOut);
else if (NULL == InOut->List)
FunError (ArgNull,InOut);
else {
CopyTop (A = &InOut->List);
if (SysError) return;
while ((*A)->Next != NULL) A = &(*A)->Next;
RepLPtr (A,(ListPtr) NULL);
}
}
OpDef SeqOps [] = {
{"apndl", -1, F_LApnd},
{"apndr", -1, F_RApnd},
{"cat", -1, F_Cat},
{"distl", -1, F_LDist},
{"distr", -1, F_RDist},
{"id", -1, F_Id},
{"iota", -1, F_Iota},
{"length", -1, F_Length},
{"reverse", -1, F_Reverse},
{"tl", -1, F_Tail},
{"tlr", -1, F_RTail},
{"trans", -1, F_Trans}
};
void D_seq ()
{
GroupDef (SeqOps, OpCount (SeqOps), SysNode);
}
/************************** end of F_seq **************************/
SHAR_EOF
if test -f 'interp/F_ss.c'
then
echo shar: over-writing existing file "'interp/F_ss.c'"
fi
cat << \SHAR_EOF > 'interp/F_ss.c'
/****** F_ss.c ********************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: July 4, 1985 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#include <stdio.h>
#include "struct.h"
#include "node.h"
/*************************** Searching and Sorting ***************************/
/*
* F_Assoc
*
* Just like LISP assoc, except that #f is returned if the key is not found.
*
* [association-list,key] | assoc == element of association list or #f
*/
private F_Assoc (InOut)
ObjectPtr InOut;
{
register ListPtr P;
register ObjectPtr Key;
if (!PairTest (InOut,1<<LIST,~0))
FunError (ArgSeqOb,InOut);
else {
P = InOut->List;
Key = &P->Next->Val;
for (P = P->Val.List; P != NULL; P=P->Next)
if (P->Val.Tag != LIST) {
FunError ("element not sequence",InOut);
return;
} else
if (ObEqual (&P->Val.List->Val,Key)) {
RepObject (InOut,&P->Val);
return;
}
RepBool (InOut,0); /* key not found, return #f */
}
}
void D_ss ()
{
(void) PrimDef (F_Assoc,"assoc",SysNode);
}
/******************************* end of F_ss.c *******************************/
SHAR_EOF
if test -f 'interp/F_string.c'
then
echo shar: over-writing existing file "'interp/F_string.c'"
fi
cat << \SHAR_EOF > 'interp/F_string.c'
/****** F_string.c ****************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: July 5, 1985 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#include <stdio.h>
#include "struct.h"
#include "string.h"
#include "node.h"
/*
* F_Patom
*
* Convert an atom to it's string representation.
*/
private F_Patom (InOut)
register ObjectPtr InOut;
{
CharPtr U;
char Buf[255];
StrPtr S;
register char *T;
extern char *sprintf();
T = Buf;
switch (InOut->Tag) {
case INT:
(void) sprintf (T,"%d",InOut->Int);
break;
case FLOAT:
(void) sprintf (T,"%g",InOut->Float);
break;
case BOOLEAN:
(void) sprintf (T,InOut->Bool ? "t":"f");
break;
case STRING:
return;
default:
FunError ("not atomic",InOut);
return;
}
S = NULL;
CPInit (&U,&S);
do CPAppend (&U,*T); while (*T++);
RepTag (InOut,STRING);
InOut->String = S;
}
/*
* F_Explode
*
* Convert a string to a list of characters
*/
private F_Explode (InOut)
ObjectPtr InOut;
{
ListPtr Result = NULL;
MetaPtr A = &Result;
CharPtr U;
char C[2];
if (InOut->Tag != STRING)
FunError ("not a string",InOut);
else {
CPInit (&U,&InOut->String);
while (CPRead (&U,C,2)) {
NewList (A,1L);
if (SysError) {DelLPtr (Result); return;}
(*A)->Val.Tag = STRING;
(*A)->Val.String = CopySPtr (CharString [C[0] & 0x7F]);
A = &(*A)->Next;
}
RepTag (InOut,LIST);
InOut->List = Result;
}
}
/*
* F_Implode
*
* Catenate a list of strings into a single string.
*/
private F_Implode (InOut)
ObjectPtr InOut;
{
CharPtr U,V;
char C[2];
ListPtr P;
StrPtr S;
if (InOut->Tag != LIST)
FunError ("not a sequence",InOut);
else {
S = NULL;
CPInit (&U,&S);
for (P = InOut->List; P != NULL; P=P->Next) {
if (P->Val.Tag != STRING) {
FunError ("non-string in sequence",InOut);
CPAppend (&U,'\0');
DelSPtr (S);
return;
} else {
CPInit (&V,&P->Val.String);
while (CPRead (&V,C,2)) CPAppend (&U,C[0]);
}
}
CPAppend (&U,'\0');
RepTag (InOut,STRING);
InOut->String = S;
}
}
void D_string ()
{
(void) PrimDef (F_Explode,"explode",SysNode);
(void) PrimDef (F_Implode,"implode",SysNode);
(void) PrimDef (F_Patom,"patom",SysNode);
}
/************************** end of F_string **************************/
SHAR_EOF
if test -f 'interp/F_subseq.c'
then
echo shar: over-writing existing file "'interp/F_subseq.c'"
fi
cat << \SHAR_EOF > 'interp/F_subseq.c'
/****** F_subseq.c ****************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.5 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: Apr 28, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#include <stdio.h> /* defines NULL */
#include "struct.h"
#include "node.h"
/*
* ListIndex
*
* Check an argument to make sure it is of the form <sequence integer>
*
* Input
* InOut = argument
*
* Output
* *L = sequence or array if no error
* result = -1 if error occurred, index otherwise
*/
private long ListIndex (InOut,L)
ObjectPtr InOut;
ListPtr *L;
{
register ListPtr P;
FPint N;
if (!PairTest (InOut, SEQUENCE, NUMERIC)) {
FunError ("not <sequence number>",InOut);
return -1;
} else {
P = InOut->List;
*L = P->Val.List;
P = P->Next;
switch (GetFPInt (&P->Val,&N)) {
default: /* actually case 0, but we need to keep lint happy */
if (N >= 0) return N;
else {
FunError ("negative index",InOut);
return -1;
}
case 1:
FunError ("index not integral",InOut);
return -1;
case 2:
FunError ("index too big",InOut);
return -1;
}
}
}
#define SCATTER_STORE 0
#if SCATTER_STORE
/*
* F_Scatter
*
* Scatter store function
*
* Input
* <<D1 D2 ... Dn> <<V1 I1> <V2 I2> ... <Vm Im>>>
*
* Output
* <E1 E2 ... En>
*
* Ek = Dk if there is no Ij == k
* Vj if Ij == k
*
* Result is BOTTOM if Ij==Ik for j!=k or Ij < 1 or Ij > n
*
* Perversions: uses LRef field for markers
*/
private F_Scatter (InOut)
ObjectPtr InOut;
{
register ListPtr P1,P2,Q,R;
register long N;
FPint M;
if (!PairTest (InOut,1<<LIST,1<<LIST))
FunError ("not <sequence sequence>",InOut);
else {
Copy2Top (&InOut->List); /* only need fresh first element */
P1 = InOut->List;
R = P1->Val.List;
N = ListLength (R);
for (P1 = P1->Next->Val.List; P1!=NULL; P1=P1->Next) {
if (!PairTest (&P1->Val,~0,NUMERIC)) {
FunError ("invalid store pair",InOut);
return;
}
P2 = P1->Val.List;
if (GetFPInt (&P2->Next->Val,&M) || M < 1 || M > N) {
FunError ("invalid index",InOut);
return;
}
for (Q=R; --M; Q=Q->Next) continue;
if (++Q->LRef > 2) {
for (Q=R; Q!=NULL; Q=Q->Next) Q->LRef = 1;
FunError ("duplicate index",InOut);
return;
}
RepObject (&Q->Val,&P2->Val);
}
for (Q=R; Q!=NULL; Q=Q->Next) Q->LRef = 1;
RepObject (InOut,&InOut->List->Val);
}
}
#endif
/*
* F_Pick
*
* Pick the nth element of a sequence
*
* Input
* InOut = pointer to <sequence number>
*/
private F_Pick (InOut)
ObjectPtr InOut;
{
register FPint N;
ListPtr P;
if ((N = ListIndex (InOut,&P)) >= 0) {
if (N <= 0) {
FunError ("non-positive index",InOut);
} else if (P == NULL) FunError ("empty sequence",InOut);
else {
while (--N > 0)
if ((P = P->Next) == NULL) {
FunError ("index out of bounds",InOut);
return;
}
RepObject (InOut,&P->Val);
}
}
}
/*
* F_Repeat
*
* Create a repetition of an item.
*
* E.g. <x 8> == <x x x x x x x x>
*/
private F_Repeat (InOut)
register ObjectPtr InOut;
{
FPint N;
register ListPtr P;
if (!PairTest (InOut,~0,NUMERIC))
FunError ("not <object number>",InOut);
else {
P = InOut->List;
switch (GetFPInt (&P->Next->Val,&N)) {
case 1:
FunError ("repetition value not integer",InOut);
break;
case 2:
FunError ("repetition value too big",InOut);
break;
case 0:
if (N < 0) FunError ("negative repetition",InOut);
else {
P = Repeat (&P->Val,(long) N);
DelLPtr (InOut->List);
InOut->List = P;
}
break;
}
}
}
/*
* F_RDrop
*
* Drop the last n elements from a sequence
*
* Input
* InOut = pointer to <sequence number>
*/
private F_RDrop (InOut)
ObjectPtr InOut;
{
register FPint N;
ListPtr P,Result;
register ListPtr R;
if ((N = ListIndex (InOut,&P)) >= 0)
if ((N = ListLength (P) - N) < 0)
FunError ("sequence too short",InOut);
else {
Result = NULL;
NewList (&Result,N);
for (R = Result; R!=NULL; P=P->Next,R=R->Next)
CopyObject (&R->Val,&P->Val);
DelLPtr (InOut->List);
InOut->List = Result;
}
}
/*
* F_LDrop
*
* Drop the first n elements from a sequence
*
* Input
* InOut = pointer to <sequence number>
*/
private F_LDrop (InOut)
ObjectPtr InOut;
{
register FPint N;
ListPtr P;
if ((N = ListIndex (InOut,&P)) >= 0) {
for (; --N >= 0; P = P->Next)
if (P == NULL) {
FunError ("sequence too short",InOut);
return;
}
RepLPtr (&InOut->List,P);
}
}
/*
* F_LTake
*
* Take the first n elements from a sequence
*
* Input
* InOut = pointer to <sequence number>
*/
private F_LTake (InOut)
ObjectPtr InOut;
{
register long N;
ListPtr P,Result;
register ListPtr R;
if ((N = ListIndex (InOut,&P)) >= 0) {
Result = NULL;
NewList (&Result,N);
for (R = Result; R!=NULL; P=P->Next, R=R->Next)
if (P != NULL)
CopyObject (&R->Val,&P->Val);
else {
FunError ("sequence too short",InOut);
DelLPtr (Result);
return;
}
DelLPtr (InOut->List);
InOut->List = Result;
}
}
/*
* F_RTake
*
* Take the last n elements from a sequence
*
* Input
* InOut = pointer to <sequence number>
*/
private F_RTake (InOut)
ObjectPtr InOut;
{
register FPint N;
ListPtr P;
if ((N = ListIndex (InOut,&P)) >= 0)
if ((N = ListLength (P) - N) < 0)
FunError ("sequence too short",InOut);
else {
while (--N >=0) P = P->Next;
RepLPtr (&InOut->List,P);
}
}
private OpDef SubSeqOps [] = {
{"dropl", -1, F_LDrop},
{"dropr", -1, F_RDrop},
{"pick", -1, F_Pick},
{"repeat", -1, F_Repeat},
{"takel", -1, F_LTake},
{"taker", -1, F_RTake}
#if SCATTER_STORE
{"scatter", -1, F_Scatter},
#endif
};
void D_subseq ()
{
GroupDef (SubSeqOps, OpCount (SubSeqOps), SysNode);
}
/************************** end of F_subseq **************************/
SHAR_EOF
# End of shell archive
exit 0
--
Rich $alz "Anger is an energy"
Cronus Project, BBN Labs rsalz@pineapple.bbn.com
Moderator, comp.sources.unix sources@uunet.unctunc