rs@uunet.UUCP (07/08/87)
Mod.sources: Volume 10, Number 38
Submitted by: robison@b.cs.uiuc.edu (Arch Robison)
Archive-name: ifp/Part05
#! /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/cache.c
# interp/cache.h
# interp/command.c
# interp/convert.c
# interp/debug.c
# interp/dos.s
# interp/error.c
# interp/except.c
# interp/file.c
# interp/forms.c
export PATH; PATH=/bin:$PATH
mkdir interp
if test -f 'interp/cache.c'
then
echo shar: over-writing existing file "'interp/cache.c'"
fi
cat << \SHAR_EOF > 'interp/cache.c'
/****** cache.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 29, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
/*
* NOTE: Function HashOb assumes a FPfloat is either 1x or 2x the size
* of a long.
*/
#include "struct.h"
#include "cache.h"
#include <stdio.h>
#if ECACHE
CacheEntry ECache[CACHE_SIZE];
CacheRec Cache [4] = {
{0,0,0,0,"Prim"},
{0,0,0,0,"User"},
{0,0,0,0,"PFO"},
{0,0,0,0,"Total"},
};
#define ArraySize(A) (sizeof(A)/sizeof(A[0]))
/*
* Print the cache statistics on stdout and clear the cache statistics tallies.
*/
void ShowCache ()
{
CacheRec *C,*T= &Cache[CacheTotal];
CacheEntry *E;
int Tally=0;
for (E=ECache; E < ArrayEnd(ECache); E++)
if (E->EC_Fun != NULL) Tally++;
printf ("%d/%d = %g full cache\n",
Tally, ArraySize (ECache), (double) Tally / ArraySize (ECache));
T->Enable = 0;
for (C= &Cache[0]; C<&Cache[4]; C++) {
if (C->Enable) {
Cache[CacheTotal].Enable=1;
printf ("%s:\t%d hits in %d looks = %g%% hit rate [%d evictions]\n",
C->Name,C->Hits,C->Looks,
100.0 * C->Hits / (C->Looks ? C->Looks : 1), C->Evictions);
T->Hits += C->Hits;
T->Looks += C->Looks;
T->Evictions += C->Evictions;
C->Hits = C->Looks = C->Evictions = 0;
}
}
if (!T->Enable) printf ("The cache is disabled\n");
}
#if DEBUG
void PrintCache (Message,E)
char *Message;
CacheEntry *E;
{
printf ("ECache %s ",Message); OutObject (&E->EC_In);
printf (" : "); OutNode (E->EC_Fun);
printf (" -> "); OutObject (&E->EC_Out);
printf ("\n");
}
#endif /* DEBUG */
/*
* HashOb
*
* HashOb computes an integer function (hash code) of an object.
*
* Input
* X = object
* Output
* result = hash code
*/
int HashOb (X)
ObjectPtr X;
{
register long H;
register ListPtr P;
switch (X->Tag) {
case BOTTOM: H = 2305; break;
case BOOLEAN: H = X->Bool; break;
case INT: H = X->Int * 9; break;
case FLOAT:
if (sizeof (FPfloat) == 2*sizeof (long))
H = ((long *)&(X->Float))[0] + ((long *)&(X->Float))[1];
else if (sizeof (FPfloat) == sizeof (long))
H = ((long *)&(X->Float))[0];
else
fprintf (stderr,"HashOb: can't hash floats on this machine!\n");
break;
case STRING: H = (long) X->String; break;
case LIST:
H = 5298;
for (P=X->List; P!=NULL; P=P->Next)
H = H * 0x1243 + HashOb (&P->Val);
break;
case NODE: H = (long) X->Node * 5; break;
case CODE: H = (long) X->Code.CodePtr +
(long) X->Code.CodeParam; break;
default:
fprintf (stderr,"HashOb: invalid tag (%d)\n",X->Tag);
break;
}
return H;
}
ClearCache () /* Clear all entries from the cache. */
{
CacheEntry *C;
for (C=ECache+CACHE_SIZE; --C >= ECache; ) {
RepTag (&C->EC_In, BOTTOM);
C->EC_Fun = NULL;
RepTag (&C->EC_Out,BOTTOM);
}
}
InitCache () /* Initialize the cache */
{
register CacheEntry *E;
CacheRec *C;
printf (" (cache");
for (C=Cache; C<&Cache[3]; C++)
if (C->Enable) printf (" %s",C->Name);
printf (")");
for (E=ECache+CACHE_SIZE; --E >= ECache; ) {
E->EC_In. Tag = BOTTOM;
E->EC_Fun = NULL;
E->EC_Out.Tag = BOTTOM;
}
}
#endif /* ECACHE */
SHAR_EOF
if test -f 'interp/cache.h'
then
echo shar: over-writing existing file "'interp/cache.h'"
fi
cat << \SHAR_EOF > 'interp/cache.h'
/****** cache.h *******************************************************/
/** **/
/** University of Illinois **/
/** **/
/** Department of Computer Science **/
/** **/
/** Tool: IFP Version: 0.1 **/
/** **/
/** Author: Arch D. Robison Date: May 1, 1985 **/
/** **/
/** Revised by: Arch D. Robison Date: July 29, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
#define ECACHE 0 /* Implement expression cache if defined */
#if ECACHE
/*
* The expression cache can be turned on selectively for expressions with
* primitive functions, user-defined functions, or PFOs.
*
* Cache[i].Enable = 0/1 to turn off/on cache for expression type i in [0..2].
*/
#define CachePrim 0
#define CacheUser 1
#define CachePFO 2
#define CacheTotal 3
typedef struct {
boolean Enable;
int Looks; /* Number of looks into cache */
int Hits; /* Number of successful looks */
int Evictions; /* Number of evictions */
char *Name; /* "Prim", "User", "PFO", etc.*/
} CacheRec;
extern CacheRec Cache[];
#if DEBUG
extern void PrintCache ();
#endif
/*
* The expression cache is implemented as a hash table. It
* associates outputs with <input,function> pairs.
*/
#define CACHE_SIZE 1024 /* Must be power of 2 */
/*
* EC_Fun.Tag = BOTTOM iff that cache entry is empty
*/
typedef struct {
Object EC_In, EC_Out;
NodePtr EC_Fun;
} CacheEntry;
extern CacheEntry ECache[];
extern int HashOb ();
extern void ShowCache (); /* Show cache statistics */
/*
* CheckCache
*
* Parameter
* T = &Cache[i] where i is type of function to be cached.
* A = call to "apply" with appropriate arguments.
*/
#define CheckCache(T,A) \
if ((T)->Enable) { \
CacheEntry *C; \
extern int TraceDepth; \
\
(T)->Looks++; \
C = &ECache [(HashOb(InOut) + (long) F->Node) * 0x9B & CACHE_SIZE-1]; \
if (ApplyFun == C->EC_Fun && ObEqual (InOut,&C->EC_In)) { \
if (Debug & DebugCache) PrintCache ("Hit!",C); \
(T)->Hits++; \
if (Trace|SaveTrace) printf ("IBID\n"); \
RepObject (InOut,&C->EC_Out); \
} else { \
if (C->EC_Fun != NULL) { \
(T)->Evictions++; \
if (Debug & DebugCache) PrintCache ("Evict",C); \
} \
C->EC_Fun = NULL; \
RepObject (&C->EC_In,InOut); \
{A;} \
C->EC_Fun = F->Node; \
RepObject (&C->EC_Out,InOut); \
if (Debug & DebugCache) PrintCache ("Load",C); \
} \
} else {A;}
#else
#define CheckCache(T,A) {A;}
#define ClearCache()
#endif
/***************************** end of cache.h ****************************/
SHAR_EOF
if test -f 'interp/command.c'
then
echo shar: over-writing existing file "'interp/command.c'"
fi
cat << \SHAR_EOF > 'interp/command.c'
/****** command.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: Jan 28, 1987 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
/*************************** Command Interpreter **************************/
#include <stdio.h>
#include <errno.h>
#include "struct.h"
#include "node.h"
#include "umax.h"
#include "inob.h"
#include "cache.h"
#include "stats.h"
#if OPSYS==UNIX
#include <strings.h>
#include <sys/wait.h>
#endif
#if OPSYS==MSDOS
#include "/usr/include/dos/spawn.h" /* Full name so lint can find it */
#include "/usr/include/dos/string.h"
#endif
extern char EditorPath [],*EdCommand;
extern char *getenv ();
extern boolean RefCheck (); /* from apply.c */
#if OPSYS==UNIX
extern fork (),execl ();
#endif
InDesc UserIn;
/*
* ReadNode
*/
private NodePtr ReadNode (U)
InDesc *U;
{
Object S;
if (!InNode (U,&S,NIL)) return NULL;
LinkPath (&S,DEF);
if (S.Tag == NODE) return S.Node;
else {
printf ("Error: ");
OutString (S.String);
printf (" not defined\n");
return NULL;
}
}
#if REFCHECK
/*
* ShowRefCheck
*/
void ShowRefCheck ()
{
Object F;
register InDesc *U;
U = &UserIn;
F.Tag = BOTTOM;
(void) InComp (U,&F,NIL);
(void) RefCheck ((NodePtr) NULL,&F);
RepTag (&F,BOTTOM);
}
#endif
/*
* ShowApply
*/
private void ShowApply (OutGraph)
int OutGraph;
{
Object X,F;
register InDesc *U;
U = &UserIn;
X.Tag = BOTTOM;
F.Tag = BOTTOM;
if (InObject (U,&X)) {
if (!IsTok (U,":")) (void) InError (U,"colon expected");
else {
(void) InComp (U,&F,NIL);
if (Debug & DebugFile) {
printf ("Object = "); OutObject (&X); printf ("\n");
printf ("Function = "); OutFun (&F,MaxInt); printf ("\n");
}
if (*U->InPtr) (void) InError (U,"extra character on line");
else {
U->InPtr++;
ClearCache ();
Apply (&X,&F);
#ifdef GRAPHICS
if (OutGraph) DrawObject (&X);
else OutPretty (&X,0);
#else
OutPretty (&X,0);
printf ("\n");
#endif
}
}
}
RepTag (&X,BOTTOM);
RepTag (&F,BOTTOM);
}
/*
* ExecFile
*
* Execute a file
*
* Input
* Prog = program to be executed
* Arg = argument string
*/
void ExecFile (Prog,Arg)
char *Prog,*Arg;
{
if (Debug & DebugFile) printf ("ExecFile (%s,%s)\n",Prog,Arg);
#if OPSYS==UNIX
if (fork ()) (void) wait ((union wait *)NULL);
else {
if (Debug & DebugFile) printf ("prepare to flush\n");
(void) fflush (stdout);
execl (Prog,Prog,Arg,(char *)NULL);
perror (Prog);
exit (1);
}
#endif
#if OPSYS==MSDOS
if (spawnl (P_WAIT,Prog,Prog,Arg,(char *)NULL)) perror (Prog);
#endif
}
void ExecEdit (FileName)
char *FileName;
{
if (Debug & DebugFile) printf ("ExecEdit (%s)\n",FileName);
#if OPSYS==UNIX
ExecFile (EditorPath,FileName);
#endif
#if OPSYS==MSDOS
{
extern char *PathSplit ();
char *T;
T = PathSplit (FileName);
if (T != NULL) ExecFile (EditorPath,T);
}
#endif
}
/*
* EditRm
*
* Action depends on ``Edit'' flag:
*
* Edit
* Apply the user's editor to a function or import file. If a function,
* delete the function definition from memory. If %IMPORT file, reread it.
*
* !Edit
* Remove a function definition or %IMPORT file.
*/
private void EditRm (U,Edit)
register InDesc *U;
boolean Edit;
{
Object N;
char Buf[MAXPATH+1];
static char *Import = "%IMPORT";
if (Debug & DebugFile) printf ("EditRm (%s,%d)\n",U->InPtr,Edit);
if (IsTok (U,Import)) {
if (Edit) ExecFile (EditorPath,Import);
else
if (unlink (Import)) perror (Import);
DelImport (U->InDefMod);
ReadImport (U->InDefMod);
} else {
N.Tag = BOTTOM;
(void) InNode (U,&N,NIL);
LinkPath (&N,DEF);
/* Kill old source code definition */
if (N.Tag == NODE)
switch (N.Node->NodeType) {
case DEF:
RepTag (&N.Node->NodeData.NodeDef.DefCode,BOTTOM);
break;
case MODULE:
break;
}
FormPath (&N,Buf,&Buf[MAXPATH]);
RepTag (&N,BOTTOM);
if (Edit) ExecEdit (Buf);
else
if (unlink (Buf)) perror (Buf);
}
}
#if OPSYS==UNIX
/*
* Shell
*
* Execute a shell command
*/
void Shell (U)
register InDesc *U;
{
if (Debug & DebugFile) printf ("Shell: '%s'\n",U->InPtr);
if (fork ()) (void) wait ((union wait *)NULL);
else {
(void) fflush (stdout);
execl ("/bin/sh","sh","-c",U->InPtr,(char *)NULL);
}
}
#endif
#if OPSYS==MSDOS
/*
* ChDirToCWD
*
* Set DOS current working directory to IFP current working directory.
*
* This procedure is a necessary KLUDGE because the current directory
* cache mechanism changes the current working directory all over the place.
*/
void ChDirToCWD ()
{
char Buf[MAXPATH];
extern char *FormNPath ();
(void) FormPath (CurWorkDir,Buf,&Buf[MAXPATH]);
chdir (Buf);
}
/*
* Directory
*
* Show the current directory
*/
void Directory (U)
register InDesc *U;
{
extern char DirPath[];
ChDirToCWD ();
ExecFile (DirPath,U->InPtr);
}
#endif
/*
* SetDepth
*
* Set function printing depth used for printing.
*/
SetDepth (U)
register InDesc *U;
{
Object X;
FPint N;
extern int TraceDepth;
X.Tag = BOTTOM;
(void) InObject (U,&X);
if (GetFPInt (&X,&N) || N < 0 || N > MaxInt)
printf ("Error: depth must be integer in range 0..%d\n",MaxInt);
else TraceDepth = N;
}
/*
* SetTrace
*
* Set or reset function trace flags.
*/
private void SetTrace (U)
register InDesc *U;
{
NodePtr N;
int T; /* phone home */
if (IsTok (U,"on")) T=1;
else if (IsTok (U,"off")) T=0;
else {
printf ("trace [on|off] f1 f2 f3 ... \n");
return;
}
while (*U->InPtr) {
N = ReadNode (U);
if (N != NULL) {
if (T) N->NodeData.NodeDef.DefFlags |= TRACE;
else N->NodeData.NodeDef.DefFlags &= ~TRACE;
} else break;
}
}
#if DUMP
extern void DumpNode();
#endif
void UserLoop ()
{
register InDesc *U;
int N;
U = &UserIn;
while (1) {
extern char FPprompt [], *gets();
extern void ResetExcept();
#if OPSYS==MSDOS
extern char CWDCache [];
CWDCache [0] = '\0'; /* Clear current directory cache */
#endif
ResetExcept ();
if (Debug & DebugAlloc) {
extern ListPtr FreeList;
printf ("length (FreeList) = %ld\n",ListLength (FreeList));
}
printf ("%s",FPprompt);
(void) fflush (stdout);
InitIn (U,CurWorkDir,stdin,-1);
/* Copy prompt so that error message '^' will point correctly. */
U->InPtr += N = strlen (strcpy (U->InPtr,FPprompt));
(void) fgets (U->InPtr, INBUFSIZE-N, stdin);
if (!*U->InPtr || IsTok (U,"exit")) {
#if OPSYS==MSDOS
ChDirToCWD ();
#endif
return;
}
else if (IsTok (U,"depth")) SetDepth (U);
else if (IsTok (U,"show")) ShowApply (0);
#if HYPERCUBE
else if (IsTok (U,"send")) {
Object X;
ForkFP ();
InObject (U,&X);
OutBinObject (&X);
}
#endif
#if COMPILE
else if (CompilerFlag && IsTok (U,"c")) Compile (U);
#endif
#if REFCHECK
else if (IsTok (U,"check")) ShowRefCheck ();
#endif
#if ECACHE
else if (IsTok (U,"cache")) ShowCache ();
#endif
#if STATS
else if (IsTok (U,"stats")) ShowStats ();
#endif
else if (IsTok (U,"trace")) SetTrace (U);
else if (IsTok (U,EdCommand)) EditRm (U,1);
#if DUMP
else if (IsTok (U,"dump")) DumpNode (CurWorkDir,0);
#endif
#ifdef GRAPHICS
else if (IsTok (U,"graph")) ShowApply (1);
#endif
/* else if (IsTok (U,"test")) Test (U); */
#if OPSYS==UNIX
else if (IsTok (U,"rm")) EditRm (U,0);
else Shell (U);
#endif
#if OPSYS==MSDOS
else if (IsTok (U,"del")) EditRm (U,0);
else if (IsTok (U,"dir")) Directory (U);
#endif
#if OPSYS==MSDOS || OPSYS==CTSS
else printf ("Unknown command: %s\n",U->InPtr);
#endif
}
}
/************************** end of command.c **************************/
SHAR_EOF
if test -f 'interp/convert.c'
then
echo shar: over-writing existing file "'interp/convert.c'"
fi
cat << \SHAR_EOF > 'interp/convert.c'
/****** convert.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 2, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
/* Type conversion functions */
#include <stdio.h>
#include <ctype.h>
#include "struct.h"
#include "string.h"
#include <math.h>
#define BUFSIZE 80 /* Maximum length of numeric string */
/*
* GetFPInt
*
* Get value of FP integer.
*
* Input
* X = FP object
*
* Output
* *K = FPint value of X
* result = error code: 0 = X was converted to integer *K
* 1 = X not an integer
* 2 = X too big
*/
int GetFPInt (X,K)
ObjectPtr X;
FPint *K;
{
switch (X->Tag) {
default: return 1;
case INT: *K = X->Int; return 0;
case FLOAT: {
double F;
F = X->Float;
if (fabs (F) <= (double) FPMaxInt) {
*K = (FPint) F;
F -= (double) *K;
return fabs (F) >= CompTol;
} else return 2;
}
}
}
#if OPSYS==CTSS
/*
* IsFloat
*
* Determine if a string represents floating point number as defined
* by C's atof function. This function is necessary for the CRAY
* since there is a bug in sscanf for the CRAY.
*
* Input
* S = string
*
* Output
* result = true iff string represents number.
*/
int IsFloat (S)
register char *S;
{
int Digits = 0;
if (*S == '+' || *S == '-') S++;
while (isdigit (*S)) {
S++;
Digits++;
}
if (*S == '.')
while (isdigit (*++S)) Digits++;
if (!Digits) return 0;
if (*S == '\0') return 1;
if (*S++ != 'e') return 0;
if (*S == '+' || *S == '-') S++;
while (isdigit (*S)) S++;
return *S == '\0';
}
#endif /* OPSYS==CTSS */
/*
* StrToFloat
*
* Convert object to float representation if possible.
*
* Input
* *X = object
*
* Output
* *X = new representation of object
* result = 1 if *X is float, 0 otherwise.
*/
boolean StrToFloat (X)
ObjectPtr X;
{
CharPtr U;
char Buf[BUFSIZE+1];
double F;
#if OPSYS!=CTSS
char Term;
#endif
CPInit (&U,&X->String);
(void) CPRead (&U,Buf,BUFSIZE);
#if OPSYS==CTSS
if (!IsFloat (Buf)) return 0;
F = atof (Buf);
#else
Buf [strlen (Buf)] = '\1';
if (2 != sscanf (Buf,"%lf%c",&F,&Term) || Term != '\1') return 0;
#endif
RepTag (X,FLOAT);
X->Float = (FPfloat) F;
return 1;
}
/*
* GetDouble
*
* Output
* result = 0 if *D is valid, 1 otherwise.
*/
int GetDouble (X,D)
ObjectPtr X;
double *D;
{
switch (X->Tag) {
case INT: *D = X->Int; return 0;
case FLOAT: *D = X->Float; return 0;
default: return 1;
}
}
/****************************** end of convert.c *****************************/
SHAR_EOF
if test -f 'interp/debug.c'
then
echo shar: over-writing existing file "'interp/debug.c'"
fi
cat << \SHAR_EOF > 'interp/debug.c'
/****** debug.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 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"
#if DEBUG
int Debug = 0; /* Print debugging statements if true */
#endif
#if DUMP
/*
* DumpNode
*
* Print out node N and all its decendants.
*/
void DumpNode (N,Indent)
register NodePtr N;
int Indent;
{
extern void OutIndent ();
OutIndent (3*Indent);
if (N == NULL) printf ("DumpNode: N = NULL\n");
else {
OutString (N->NodeName);
switch (N->NodeType) {
case NEWNODE: printf ("(new) "); break;
case MODULE:
printf (" module\n");
for (N = N->NodeData.NodeMod.FirstChild; N!=NULL; N=N->NodeSib)
DumpNode (N,Indent+1);
break;
case DEF:
printf (" function");
if (N->NodeData.NodeDef.DefFlags & TRACE)
printf ("(trace) ");
OutObject (&N->NodeData.NodeDef.DefCode);
printf ("\n");
break;
case IMPORT:
printf (" import");
OutObject (&N->NodeData.NodeImp.ImpDef);
printf ("\n");
break;
default:
printf (" invalid NodeType (%x)\n",N->NodeType);
break;
}
}
}
#endif /* DUMP */
/*************************** end of debug.c *********************************/
SHAR_EOF
if test -f 'interp/dos.s'
then
echo shar: over-writing existing file "'interp/dos.s'"
fi
cat << \SHAR_EOF > 'interp/dos.s'
;
;/****** dos.s**********************************************************/
;/** **/
;/** 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: Sept 28, 1985 **/
;/** **/
;/** Principal Investigators: Prof. R. H. Campbell **/
;/** Prof. W. J. Kubitz **/
;/** **/
;/** **/
;/**------------------------------------------------------------------**/
;/** (C) Copyright 1987 University of Illinois Board of Trustees **/
;/** All Rights Reserved. **/
;/**********************************************************************/
;/***** Assembly Language Routines for MS-DOS Implementation of IFP *****/
TITLE dos
PUBLIC _StackCheck, _SetCBrk
EXTRN __chkstk:FAR
DOS_TEXT SEGMENT BYTE PUBLIC 'CODE'
ASSUME CS: DOS_TEXT
;
; SetCBrk
;
; Set control-C trapping for any DOS call.
;
_SetCBrk PROC FAR
mov ax,3301H
mov dl,01H
int 21H
ret
_SetCBrk ENDP
;
; StackCheck
;
; Check if there is enough room on the stack and check for break signal
;
_StackCheck PROC FAR
push bp
mov bp,sp
mov ax,64H
call FAR PTR __chkstk
push es
mov ah,2FH
int 21H ; Dummy GET_DTA to look for control-C
pop es
mov sp,bp
pop bp
ret
_StackCheck ENDP
DOS_TEXT ENDS
END
;/************************** end of dos.s **************************/
SHAR_EOF
if test -f 'interp/error.c'
then
echo shar: over-writing existing file "'interp/error.c'"
fi
cat << \SHAR_EOF > 'interp/error.c'
/****** error.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: Sept 8, 1986 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
/************************ Error Message Routines **********************/
#include <stdio.h>
#include <ctype.h>
#include "struct.h"
#include "node.h"
#include "umax.h"
#include "inob.h"
/* Some common error messages */
char ArgNotSeq[] = "not a sequence",
ArgSeqOb [] = "must be <sequence object>",
ArgObSeq [] = "must be <object sequence>",
ArgNull [] = "empty sequence",
ArgBottom[] = "argument is ?";
/*
* PrintErr
*
* Check if error message should be printed. Error messages are not printed if
* the argument is BOTTOM (in which case the error has already been noted), or
* SysStop is set (the user has interrupted execution).
*
* Input
* InOut = argument to function
*
* Output
* result = true iff error message should be printed
*/
boolean PrintErr (InOut)
ObjectPtr InOut;
{
return InOut->Tag != BOTTOM && !SysStop;
}
/*
* FormError
*
* Print PFO error message.
*
* Input
* InOut = input to form
* Message = error message
* N = offended form's index in FormTable
* P = form parameter list
*/
void FormError (InOut,Message,N,P)
ObjectPtr InOut;
char *Message;
int N;
ListPtr P;
{
extern int TraceDepth;
if (PrintErr (InOut)) {
LineWait ();
OutForm (FormTable[N].FormNode,P,TraceDepth);
printf (": %s\n",Message);
OutObject (InOut);
printf ("\n");
LineSignal ();
}
RepTag (InOut,BOTTOM);
}
/*
* FunError
*
* Print primitive function error.
*
* Input
* Message = error message
* InOut = offending object
* ApplyFun {global} = offended function
*/
void FunError (Message,InOut)
char *Message;
ObjectPtr InOut;
{
if (PrintErr (InOut)) {
LineWait ();
printf ("\n");
OutNode (ApplyFun);
printf (": %s\n",Message);
OutObject (InOut);
printf ("\n");
LineSignal ();
}
RepTag (InOut,BOTTOM);
}
/*
* DefError
*
* Print definition error display.
*
* Input
* Caller = calling node
* F = name of erroneous function
* Message = error message to print
*/
void DefError (Caller,F,Message)
NodePtr Caller;
ObjectPtr F;
char *Message;
{
LineWait ();
OutObject (F);
if (Caller != NULL) {
printf (" (from ");
OutNode (Caller);
printf (")");
}
printf (": %s\n",Message);
LineSignal ();
}
/*
* IntError
*
* Print internal error message.
*
* Input
* Message = error message
*/
void IntError (Message)
char *Message;
{
fprintf (stderr,"\nINTERNAL ERROR (%s)\n",Message);
if (Debug) abort ();
SysError = INTERNAL;
}
/*
* InError
*
* Print input error message.
*
* Input
* F = input descriptor
* Message = error message
*
* Output
* result = 0
*/
int InError (F,Message)
InDesc *F;
char *Message;
{
char *S;
if (F->ComLevel > 0) Message = "open comment";
printf ("Input error");
if (F->InLineNum >= 0) {
printf (" in ");
OutNode (F->InDefMod);
printf ("/");
if (F->InDefFun != NULL) OutString (F->InDefFun);
else printf ("%IMPORT");
printf (" on line %d:\n%s",F->InLineNum,F->InBuf);
if (F->InBuf[strlen (F->InBuf)-1] != '\n') printf ("\n");
} else printf ("\n");
for (S=F->InBuf; S<F->InPtr; S++)
printf ("%c", isspace (*S) ? *S : ' ');
printf ("^\n%s\n",Message);
return F->ComLevel = 0;
}
/****************************** end of error.c *******************************/
SHAR_EOF
if test -f 'interp/except.c'
then
echo shar: over-writing existing file "'interp/except.c'"
fi
cat << \SHAR_EOF > 'interp/except.c'
/****** except.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 5, 1985 **/
/** **/
/** Principal Investigators: Prof. R. H. Campbell **/
/** Prof. W. J. Kubitz **/
/** **/
/** **/
/**------------------------------------------------------------------**/
/** (C) Copyright 1987 University of Illinois Board of Trustees **/
/** All Rights Reserved. **/
/**********************************************************************/
/************************* Exception Handlers *************************/
#include <stdio.h>
#include "struct.h"
#include "umax.h"
#if OPSYS!=CTSS
#include <signal.h>
#endif
/*
* There are currently two exceptions which must be dealt with.
*
* 1. Interpreter (system) errors, e.g. out of memory
* These are indicated by setting the variable 'SysError' to the
* appropriate non-zero value. The values are listed in struct.h
*
* 2. User interrupts, i.e. ctrl-C.
* These are counted by the variable SysStop.
*
* 0 = process normally
* 1 = stop processing and print back trace
* 2 = return to top level without printing back trace
*/
short SysError = 0; /* An error occurred if SysError != 0 */
short SysStop = 0;
#if OPSYS!=CTSS
private int SetStop ()
{
SysStop++;
(void) signal (SIGINT,SetStop);
}
#endif OPSYS!=CTSS
/*
* ResetExcept
*
* Reset exception handling to normal state.
*/
void ResetExcept ()
{
extern int UDump();
SysError = 0;
SysStop = 0;
#if OPSYS!=CTSS
(void) signal (SIGINT,SetStop);
#endif
#if OPSYS==DOS
SetCBrk ();
#endif
}
SHAR_EOF
if test -f 'interp/file.c'
then
echo shar: over-writing existing file "'interp/file.c'"
fi
cat << \SHAR_EOF > 'interp/file.c'
/****** file.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 22, 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 "struct.h"
#include "string.h"
#include "node.h"
#include "umax.h"
#include "inob.h"
extern char *strcpy (),*strcat (),*getenv ();
/*------------------------- Operating System Constants --------------------*
*
* Operating System Constants
*
* PATH_SEPARATOR = separator used for file names
* EDITOR = path to editor
* EdCommand = IFP command to invoke EDITOR
*
* Even operating systems without hierarchical file systems must
* define a PATH_SEPARATOR, which is used still used internally.
*
* In the case of CTSS, we also have a constant USER_PATH. This
* a fictious path to the user's current directory.
*/
#if OPSYS==UNIX
#define PATH_SEPARATOR '/'
#define EDITOR "/bin/vi"
char *EdCommand;
#endif
#if OPSYS==MSDOS
#define PATH_SEPARATOR '\\'
#define EDITOR "c:ed.exe"
char *EdCommand = "ed";
char DirPath [MAXPATH+1] = "c:dir.exe";
#endif
#if OPSYS==CTSS
#define PATH_SEPARATOR '/'
#define EDITOR "fred"
char *EdCommand = "fred";
#define USER_PATH "/usr"
#endif
/*-------------------- end of Operating System Constants --------------------*/
char RootPath [MAXPATH+1] = ""; /* Path to IFP's root */
char EditorPath [MAXPATH+1] = EDITOR; /* value is default */
char FPprompt[16] = "ifp> "; /* value is default */
NodePtr CurWorkDir = NULL; /* Current working directory node */
/********************** Operating system file interface ***********************/
/*
* PathTail
*
* Return the last component in a path name.
* Returns pointer to "" if error occurs.
*/
private char *PathTail (Path)
char *Path;
{
register char *T;
if (*Path == PATH_SEPARATOR) Path++;
while (*Path) {
for (T = Path; *T++ != PATH_SEPARATOR; )
if (!*T) return Path;
Path = T;
}
return Path;
}
/*------------------------------ fopen hacks ------------------------------
*
* Both MSDOS and CTSS have problems with hierarchical file structure.
* Thus we have to redefine the standard UNIX function "fopen" to allow
* for these operating system's quirks.
*/
#if OPSYS==MSDOS
/*
* We try to keep track of the current directory in CWDCache so we can avoid
* superfluous calls to chdir. Set the 0th character to '\0' to empty the
* cache.
*/
char CWDCache [MAXPATH] = "";
/*
* PathSplit
*
* Split a pathname into its directory and file parts.
* Change directory to directory part.
*
* Input
* PathName = pathname
*
* Output
* NULL if error occurs, pointer to file name otherwise.
*/
char *PathSplit (PathName) /* also used by command.c */
char *PathName;
{
register char *S,*T;
register int R;
T = PathTail (PathName);
if (T != &PathName [1]) {
T[-1] = '\0';
S = PathName; /* Break string at path separator */
} else S = "\\";
if (strcmp (S,CWDCache)) {
R = chdir (S);
if (Debug & DebugFile) printf ("cache load: %d = ChDir (%s) for %s\n",R,S,T);
(void) strcpy (CWDCache,S);
} else {
if (Debug & DebugFile) printf ("cache HIT!\n");
R = 0;
}
T[-1] = PATH_SEPARATOR; /* Replace path separator */
return R ? NULL : T;
}
/*
* DOSfopen
*
* Works as =`fopen' should. The old Lattice C `fopen' would not take
* pathnames. Even though the new compiler's will allow long names,
* the fake fopen can take advantage of the current directory cache.
*/
private FILE *DOSfopen (FileName,Mode)
char *FileName,*Mode;
{
char *T;
return (T = PathSplit (FileName)) != NULL ? fopen (T,Mode) : NULL;
}
#define fopen DOSfopen
#endif /* OPSYS==MSDOS */
#if OPSYS==CTSS
/*
* CTSSfopen
*
* Tries for fake a real fopen. CTSS does not support hierarchical file
* structures, so CTSSfopen takes the tail of the path as the file name.
*/
private FILE *CTSSfopen (FileName,Mode)
char *FileName,*Mode;
{
register char *T;
if (Debug & DebugFile) printf ("CTSSfopen (%s,%s)\n",FileName,Mode);
T = PathTail (FileName);
if (T == &FileName[1]) return NULL;
else {
T[-1] = '\0';
if (strcmp (FileName,USER_PATH)) return NULL;
else {
if (Debug & DebugFile) printf ("fopen (%s,%s)\n",T,Mode);
return fopen (T,Mode);
}
}
}
#define fopen CTSSfopen
#endif /* OPSYS==CTSS */
/*---------------------------- end of fopen hacks ----------------------------*/
/*
* FormNPath
*
* Create the pathname for a given node.
*
* Input
* N = pointer to node
* PathLim = pointer to end of PathName buffer
*
* Output
* Pathname for node
*/
char *FormNPath (N,PathName,PathLim)
register NodePtr N;
char PathName[];
register char *PathLim;
{
CharPtr U;
register char *T;
if (N->NodeParent == NULL) {
(void) strcpy (PathName,RootPath);
return &PathName [strlen (PathName)];
} else {
T = FormNPath (N->NodeParent,PathName,PathLim);
if (T==NULL) return NULL;
else {
*T++ = PATH_SEPARATOR;
CPInit (&U,&N->NodeName);
(void) CPRead (&U,T,PathLim-T);
#if OPSYS==UNIX
T += strlen (T);
#endif
#if OPSYS==MSDOS || OPSYS==CTSS
/* DOS and CTSS names limited to 8 characters */
{
int L;
if ((L = strlen (T)) > 8) L = 8;
*(T += L) = '\0';
}
#endif
if (!CPRead (&U,T,PathLim-T)) return T;
else return NULL; /* U should be empty */
}
}
}
/*
* FormPath
*
* Make UNIX or DOS pathname for node
*
* Input
* N = node or path list
* PathName = buffer to put pathname in.
* PathLim = pointer to end of buffer
*
* Output
* PathName = pathname if successful
*/
void FormPath (N,PathName,PathLim)
register ObjectPtr N;
char PathName[];
char *PathLim;
{
register char *T;
CharPtr U;
register ListPtr P;
register int K;
switch (N->Tag) {
case LIST:
(void) strcpy (PathName,RootPath);
K = strlen (PathName);
PathLim -= K;
T = &PathName [K];
for (P = N->List; P!=NULL; P=P->Next) {
if (P->Val.Tag != STRING) return;
else {
CPInit (&U,&P->Val.String);
(void) CPRead (&U,T,PathLim-PathName);
#if OPSYS==UNIX
T += strlen (T);
#endif
#if OPSYS==MSDOS || OPSYS==CTSS
/* DOS names are limited to 8 characters */
if ((K = strlen (T)) > 8) K = 8;
*(T += K) = '\0';
#endif
/* T should always be <= PathLim */
if (T >= PathLim) return;
}
}
break;
case NODE:
(void) FormNPath (N->Node,PathName,PathLim);
break;
default:
break;
}
}
/*
* ReadDef
*
* Read a definition node. The definition node tag must be BOTTOM upon entry
* when running UMAX.
*
* Input
* Caller = pointer to DEF node of caller
* Fun = object with tag NODE.
*/
void ReadDef (Caller,Fun)
NodePtr Caller;
ObjectPtr Fun;
{
NodePtr N;
char FileName[MAXPATH];
FILE *DefFile;
InDesc F;
int C;
if (NULL == FormNPath (N=Fun->Node,FileName,&FileName[MAXPATH]))
DefError (Caller,Fun,"invalid name for function");
else
while (NULL != (DefFile = fopen (FileName,"r"))) {
InitIn (&F,N->NodeParent,DefFile,0);
C = InDef (&F,N->NodeName,&N->NodeData.NodeDef.DefCode);
(void) fclose (F.InFile);
if (C) goto exit;
printf ("Do you wish to edit %s ? ",FileName + strlen (RootPath));
while (1) {
for (C = getchar (); getchar ()!='\n';) continue;
if (C == 'y') {
ExecEdit (FileName);
break;
}
if (C == 'n') goto exit;
printf ("Respond with y or n\n");
}
}
exit:;
}
/*
* ReadImport
*
* Read the import file for a module node.
*
* Input
* M = pointer to module node
*/
void ReadImport (M)
NodePtr M;
{
char *T;
char FileName[MAXPATH];
FILE *ImpFile;
InDesc F;
if (NULL != (T = FormNPath (M,FileName,&FileName[MAXPATH]))) {
*T++ = PATH_SEPARATOR;
(void) strcpy (T,"%IMPORT");
if (NULL != (ImpFile = fopen (FileName,"r"))) {
InitIn (&F,M,ImpFile,0);
InImport (&F,M);
(void) fclose (ImpFile);
}
}
}
#if OPSYS!=CTSS
/*
* EnvGet
*
* Get value for environment variable.
*
* Input
* Key = enviroment variable name
* Value = default value for variable
* ValLim = length of Value buffer
*
* Output
* Value = value of enviroment variable, or default if not found.
*/
void EnvGet (Key,Value,ValLim)
char *Key,*Value;
int ValLim;
{
char *V;
V = getenv (Key);
if (V != NULL)
if (strlen (V) < ValLim) (void) strcpy (Value,V);
else fprintf (stderr,"Error: %s in enviroment is longer than %d\n",
Key,MAXPATH-3);
}
/*
* CWDGet
*
* Find pathname of current working directory (relative to FP root).
*
* Input
* PathLim = length of Path buffer (used by PCAT versions only)
*
* Output
* result = 1 if valid FP path, 0 otherwise
* Path = FP pathname if valid, undefined otherwise
*/
boolean CWDGet (Path,PathLim)
register char *Path;
int PathLim;
{
#ifdef PCAT
extern char *getcwd ();
if (!getcwd (Path,PathLim-2)) return 0;
#else
#if S9000
extern FILE *popen ();
FILE *F; /* S9000 Xenix has no getwd! */
F = popen ("/bin/pwd","r");
fscanf (F,"%s",Path);
pclose (F);
#else
extern char *getwd();
if (!getwd (Path)) return 0;
#endif /* S9000 */
#endif /* PCAT */
#if OPSYS==MSDOS
(void) strcpy (Path,Path+2); /* Delete drive name */
if (Debug & DebugFile) printf ("CWD = '%s'\n",Path);
return 1;
#endif
#if OPSYS==UNIX
{
register int K;
K = strlen (RootPath);
if (strncmp (Path,RootPath,K)) return 0;
else {
(void) strcpy (Path,&Path[K]); /* Remove FP root path prefix */
return 1;
}
}
#endif
}
#endif /* OPSYS != CTSS */
/*
* InitFile
*
* The DOS version is kludgy. The problem is that DOSfopen changes
* the current directory, thus munging it before CWDGet is called.
*/
#if OPSYS==UNIX || OPSYS==CTSS
void InitFile ()
#endif
#if OPSYS==MSDOS
void InitFile (CWD)
char *CWD;
#endif
{
Object X;
InDesc F;
if (Debug & DebugFile) printf ("enter InitFile\n");
#if OPSYS!=CTSS
EnvGet ("EDITOR",EditorPath,MAXPATH);
#endif
if (Debug & DebugFile) printf ("EditorPath = `%s'\n",EditorPath);
#if OPSYS==UNIX
EdCommand = PathTail (EditorPath);
if (!*EdCommand) {
fprintf (stderr,"\n * EDITOR environment variable not a full path.");
fprintf (stderr,"\n Setting editor to '%s'.\n",EDITOR);
EdCommand = PathTail (strcpy (EditorPath,EDITOR));
}
EnvGet ("IFPprompt",FPprompt,sizeof (FPprompt));
#endif
#if OPSYS==MSDOS
EnvGet ("IFPDIR",DirPath,MAXPATH);
if (Debug & DebugFile) printf ("IFPDIR = '%s'\n",DirPath);
#endif
/* Create dummy descriptor for scanning environment info */
InitIn (&F,(NodePtr) NULL,(FILE *) NULL, -1);
#if OPSYS==UNIX
if (!CWDGet (F.InBuf,INBUFSIZE-1)) {
fprintf (stderr,"\n\n * Current directory not a IFP subdirectory.");
fprintf (stderr, "\n Setting current directory to IFP root.\n");
if (chdir (RootPath)) {
extern int errno;
perror (RootPath);
exit (errno);
} else F.InBuf[0] = '\0';
}
#endif
#if OPSYS==MSDOS
{
register char *T;
(void) strcpy (F.InBuf,CWD);
for (T=F.InBuf; *T; T++)
if (*T == PATH_SEPARATOR) *T = '/';
}
#endif
#if OPSYS==CTSS
(void) strcpy (F.InBuf,USER_PATH);
#endif
if (F.InBuf[0]) {
(void) strcat (F.InPtr,"\n");
(void) InNode (&F,&X,NIL);
CurWorkDir = MakeNode (X.List,1);
} else
CurWorkDir = RootNode;
if (Debug & DebugFile) printf ("exit InitFile\n");
}
/************************* end of file.c *******************************/
SHAR_EOF
if test -f 'interp/forms.c'
then
echo shar: over-writing existing file "'interp/forms.c'"
fi
cat << \SHAR_EOF > 'interp/forms.c'
/****** forms.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 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 "struct.h"
#include "node.h"
#include "umax.h"
#include "stats.h"
#include <stdio.h>
/*
* FF_Each
*
* Apply function F to each element of list InOut
*
* Input
* InOut = list of elements to apply function
* Funs = singleton list of function to be applied
*
* Output
* InOut = result
*/
private FF_Each (InOut,Funs)
ObjectPtr InOut;
register ListPtr Funs;
{
register ListPtr P;
switch (InOut->Tag) {
default:
FormError (InOut,ArgNotSeq,NODE_Each,Funs);
return;
case LIST:
CopyTop (&InOut->List);
break;
}
for (P = InOut->List; P!=NULL; P=P->Next) {
Apply (&P->Val,&Funs->Val);
if (P->Val.Tag == BOTTOM) {
RepTag (InOut,BOTTOM); /* Error already reported */
return;
}
}
}
/*
* FF_Filter
*
* Input
* InOut = list of elements to apply predicate
* Funs = singleton list of function to be applied
*
* Output
* InOut = result - list of element for which predicate is true.
*/
private FF_Filter (InOut,Funs)
register ObjectPtr InOut;
register ListPtr Funs;
{
register ListPtr P;
register MetaPtr E;
ListPtr Result;
Object X;
if (InOut->Tag != LIST)
FormError (InOut,ArgNotSeq,NODE_Filter,Funs);
else {
Result = NULL;
E = &Result;
for (P = InOut->List; P!=NULL; P=P->Next) {
CopyObject (&X,&P->Val);
Apply (&X,&Funs->Val);
if (X.Tag != BOOLEAN) {
FormError (&X,"non-boolean predicate",NODE_Filter,Funs);
RepTag (InOut,BOTTOM);
DelLPtr (Result);
return;
} else if (X.Bool) { /* append element to result list */
NewList (E,1L);
CopyObject (&(*E)->Val,&P->Val);
E = &(*E)->Next;
}
}
DelLPtr (InOut->List);
InOut->List = Result;
}
}
/*
* FF_Compose
*
* Function composition
*
* Input
* InOut = object to apply composition
* Funs = list of functions to compose in reverse order
*
* Output
* InOut = result of composition
*/
private FF_Compose (InOut,Funs)
register ObjectPtr InOut;
register ListPtr Funs;
{
for (; Funs != NULL && InOut->Tag != BOTTOM; Funs = Funs->Next)
Apply (InOut,&Funs->Val);
}
/*
* FF_RInsert
*
* Function right insert
*/
private FF_RInsert (InOut,Funs)
register ObjectPtr InOut;
register ListPtr Funs;
{
ListPtr Terms;
if (InOut->Tag != LIST)
FormError (InOut,ArgNotSeq,NODE_RInsert,Funs);
else if (InOut->List == NULL)
FormError (InOut,"empty sequence",NODE_RInsert,Funs);
else {
F_Reverse (InOut); /* Copy top and reverse */
Terms = InOut->List->Next;
InOut->List->Next = NULL;
RepObject (InOut,&InOut->List->Val);
while (Terms != NULL) {
/* form pair and apply function */
NewList (&Terms->Next,1L);
Terms->Next->Val.Tag = InOut->Tag;
Terms->Next->Val.Data = InOut->Data;
InOut->Tag = LIST;
InOut->List = NULL;
Rot3 (&InOut->List,&Terms,&Terms->Next->Next);
Apply (InOut,&Funs->Val);
if (InOut->Tag == BOTTOM) {
DelLPtr (Terms);
break;
}
}
}
}
/*
* FF_C
*
* Constant function
*/
private FF_C (InOut,Funs)
ObjectPtr InOut;
register ListPtr Funs;
{
Stat (StatConstant (InOut));
if (Funs == NULL)
FormError (InOut,"(constant bottom)",NODE_C,Funs);
else
RepObject (InOut,&Funs->Val);
}
/*
* FF_Out
*
* Print debugging message
*/
private FF_Out (InOut,Funs)
ObjectPtr InOut;
register ListPtr Funs;
{
LineWait ();
OutObject (&Funs->Val),
printf (": "),
OutObject (InOut),
printf ("\n");
LineSignal ();
}
#if FETCH
/*
* FF_Fetch
*
* Fetch form
*/
private FF_Fetch (InOut,Funs)
ObjectPtr InOut;
register ListPtr Funs;
{
register ListPtr P,Q,R;
if (InOut->Tag != LIST)
FormError (InOut,ArgNotSeq,NODE_Fetch,Funs);
else {
R = NULL;
for (P = InOut->List; P != NULL; P=P->Next)
if (P->Val.Tag != LIST || (Q=P->Val.List) == NULL ||
Q->Next == NULL || Q->Next->Next != NULL) {
FormError (InOut,"element not a pair",NODE_Fetch,Funs);
return;
} else
if (R == NULL && ObEqual (&Q->Val,&Funs->Val)) R = Q;
if (R!=NULL) RepObject (InOut,&R->Next->Val);
else FormError (InOut,"key not found",NODE_Fetch,Funs);
return;
}
}
#endif FETCH
/*
* FF_If
*
* Conditional p->f;g
*
* Input
* InOut = object to apply conditional
* Funs = <p f g>
*
* Output
* InOut = result of conditional
*/
private FF_If (InOut,Funs)
ObjectPtr InOut;
ListPtr Funs;
{
Object P;
CopyObject (&P,InOut);
Apply (&P,&Funs->Val);
if (P.Tag == BOOLEAN)
Apply (InOut, & (P.Bool ? Funs : Funs->Next)->Next->Val);
else {
FormError (&P,"non-boolean predicate",NODE_If,Funs);
RepTag (InOut,BOTTOM);
}
}
/*
* FF_Construct
*
* Function construction
*
* Input
* InOut = object to apply construction
* Funs = list of functions to construct
*
* Output
* InOut = result
*/
private FF_Construct (InOut,Funs)
register ObjectPtr InOut;
ListPtr Funs;
{
register ListPtr P,F;
Stat (StatConstruct (Funs));
P = Repeat (InOut, ListLength (F = Funs));
if (SysError) return;
RepTag (InOut,LIST);
for (InOut->List = P; F != NULL; P=P->Next,F=F->Next) {
Apply (& P->Val,& F->Val);
if (P->Val.Tag == BOTTOM) {
RepTag (InOut,BOTTOM); /* Error was already reported */
return;
}
}
}
/*
* FF_Select
*
* Selector form (e.g. 1,2r)
*
* Input
* InOut = object
* Funs = index parameter list - positive values are left selectors
* negative values are right selectors
*/
private FF_Select (InOut,Funs)
ObjectPtr InOut;
ListPtr Funs;
{
register ListPtr P;
register long N;
char *E;
N = Funs->Val.Int;
switch (InOut->Tag) {
default:
E = ArgNotSeq;
break;
case NODE:
NodeExpand (InOut);
case LIST:
P = InOut->List;
if (N < 0) N += ListLength (P) + 1;
if (--N >= 0) {
for (; P!=NULL; P=P->Next)
if (--N < 0) {
RepObject (InOut,&P->Val);
return;
}
E = "index off right end";
} else
E = "index off left end";
break;
}
FormError (InOut,E,NODE_Sel,Funs);
}
/*
* FF_While
*
* While P is true, apply F to X
*
* Input
* InOut = X
* Funs = pair <P F>
*
* Output
* InOut = result
*/
private FF_While (InOut,Funs)
register ObjectPtr InOut;
register ListPtr Funs;
{
Object P;
P.Tag = BOTTOM;
while (InOut->Tag!=BOTTOM) {
CopyObject (&P,InOut); /* old P was element of {?,f,t} */
Apply (&P,&Funs->Val);
if (P.Tag != BOOLEAN) {
FormError (&P,"non-boolean predicate",NODE_While,Funs);
RepTag (InOut,BOTTOM);
} else
if (P.Bool) Apply (InOut,&Funs->Next->Val);
else break;
}
}
#if XDEF
extern FF_XDef();
#endif
/*
* FormTable
*
* These entries must be ordered to correspond with the #defines in "node.h".
*/
FormEntry FormTable[] = {
{NULL, "#", {"constant" ,-1,FF_C }, "#c"},
{NULL, "", {"compose" ,-1,FF_Compose }, ""},
{NULL, "[", {"construct",-1,FF_Construct}, "[...]"},
{NULL, "EACH", {"each" , 1,FF_Each }, "EACH g END"},
#if FETCH
{NULL, "^", {"fetch" , 1,FF_Fetch }, "^c"},
#endif
{NULL, "FILTER", {"filter" , 1,FF_Filter }, "FILTER p END"},
{NULL, "IF", {"if" , 3,FF_If }, "IF p THEN g ELSE h END"},
{NULL, "INSERT", {"insertr" , 1,FF_RInsert }, "INSERT g END"},
{NULL, "@", {"out" , 1,FF_Out }, "@message"},
{NULL, "", {"select" , 1,FF_Select }, "digit"},
{NULL, "WHILE", {"while" , 2,FF_While }, "WHILE p DO g END"}
#if XDEF
,{NULL, "{", {"xdef" , 3,FF_XDef }, "{...}"},
#endif
};
void D_form ()
{
FormEntry *N;
for (N=FormTable; N<ArrayEnd (FormTable); N++)
N->FormNode = PrimDef (N->FormOp.OpPtr,
N->FormOp.OpName,
SysNode,
N->FormOp.OpParam);
}
/******************************* end of forms.c *******************************/
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.uu.net