v23i056: Line oriented macro processor, Part06/09
Rich Salz
rsalz at bbn.com
Fri Nov 30 04:43:56 AEST 1990
Submitted-by: Darren New <new at ee.udel.edu>
Posting-number: Volume 23, Issue 56
Archive-name: lome/part06
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 5 (of 9)."
# Contents: LOME/Comp1.c LOME/LOME8.c LOME/Rubin.mac PPL/PPLAmiga.c
# TFS/TFSAmiga.c
# Wrapped by new at estelle.ee.udel.edu on Tue Aug 14 16:09:59 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'LOME/Comp1.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'LOME/Comp1.c'\"
else
echo shar: Extracting \"'LOME/Comp1.c'\" \(9022 characters\)
sed "s/^X//" >'LOME/Comp1.c' <<'END_OF_FILE'
X/*
X * Comp1.c
X * Macro Compiler code file
X * Copyright 1988, 1990 Darren New.
X * All rights reserved.
X */
X
X#include "PPL.h"
X#include "MacroIO.h"
X
X#define MacStream 1 /* stream where macros are stored */
X#define PrgStream 2 /* stream where program to be expanded is stored */
X#define ExpStream 3 /* stream where expansions written */
X#define ErrStream 4 /* stream where errors written */
X
X#define BUFSIZE 15000
X
Xint AssertExit()
X{
X MStopIO();
X PLExit(PLsev_bomb);
X return 0;
X }
X
Xint BombExit()
X{
X return AssertExit();
X }
X
Xint FaultExit()
X{
X return AssertExit();
X }
X
Xshort DoIt()
X{
X int status;
X short buf[BUFSIZE];
X short zero, HeadParm, HeadEOL, BodyParm, BodyEOL;
X short param[10];
X int symgen = 100;
X int FirstToUse = 0;
X int NextToUse = FirstToUse;
X char inpline[BIGLINE];
X
X /* DEBUG_SETDEFS("RAW:0/190/640/200/Debug window", "T:DBugOut"); */
X /* DEBUG_ENTER("DoIt", NULL); */
X
X MStartIO(PLargcnt, PLarglist);
X
X /* Read macro stream until a blank line is encountered */
X while (M_OK == (status = MGetBuff(MacStream)) && MGetChar() > 0)
X ;
X
X /* Read program stream until a blank line is encountered */
X while (M_OK == (status = MGetBuff(PrgStream)) && MGetChar() > 0)
X ;
X
X PLStatus(6, "Reading macros...");
X
X /* Read special character line from macro stream */
X if (M_OK != MGetBuff(MacStream)) {
X PLStatus(1, "Read of special character line failed");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X zero = MGetChar();
X HeadParm = MGetChar();
X HeadEOL = MGetChar();
X BodyParm = MGetChar();
X BodyEOL = MGetChar();
X if (zero == 0 || HeadParm == 0 || HeadEOL == 0 ||
X BodyParm == 0 || BodyEOL == 0 || MGetChar() != 0) {
X PLStatus(1, "Special character line malformed");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X /* DEBUGF(5, "z=%d, HP=%d, HE=%d, BP=%d, BE=%d" C zero C HeadParm C
X HeadEOL C BodyParm C BodyEOL); */
X
X /* read macros into buf[NextToUse]. Format:
X buf[k] = start of next macro def line.
X buf[k+1] = number of symgens used or -1 if none used.
X buf[k+2] ... buf[k+n] =
X text of macro template, terminate by 0.
X buf[k+n+1] ... =
X lines of macro bodies, each terminated by 0.
X A PrgParm followed by two digits is replaced by a PrgParam
X followed by two integers.
X */
X while (M_OK == (status = MGetBuff(MacStream))) {
X int k, c;
X bool donebody;
X /* check for enuf room to store line */
X if (NextToUse + BIGLINE + 10 > BUFSIZE) {
X PLStatus(1, "Out of memory for macros");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_oores);
X }
X /* Read template */
X k = NextToUse;
X buf[++k] = -1; /* adjusted when symgens found */
X while ((c = MGetChar()) != 0 && c != HeadEOL) {
X buf[++k] = c;
X }
X buf[++k] = 0;
X /* Read macro body */
X donebody = FALSE;
X while (! donebody && M_OK == (status = MGetBuff(MacStream))) {
X /* check for enuf room to store line */
X if (k + BIGLINE + 10 > BUFSIZE) {
X PLStatus(1, "Out of memory for macros");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_oores);
X }
X /* copy in body line */
X c = MGetChar();
X if (c == 0 || c == BodyEOL) {
X donebody = TRUE;
X }
X else {
X while (c != 0 && c != BodyEOL) {
X assert(-1 <= k && k < BUFSIZE);
X buf[++k] = c;
X if (c == BodyParm) {
X short parm, form;
X parm = MGetChar() - zero;
X form = MGetChar() - zero;
X if (parm == -zero || form == -zero) {
X PLStatus(1, "Unexpected EOL in macro body!");
X if (fault("Unexpected EOL in macro body!"))
X break;
X else
X bomb("Translation cancelled");
X }
X if (parm == 0 && buf[NextToUse + 1] < form)
X buf[NextToUse + 1] = form;
X buf[++k] = parm;
X buf[++k] = form;
X }
X c = MGetChar();
X }
X buf[++k] = 0;
X }
X }
X buf[NextToUse] = ++k;
X NextToUse = k;
X if (NextToUse + BIGLINE + 10 > BUFSIZE) {
X PLStatus(1, "Out of memory for macros");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_oores);
X }
X }
X
X if (status != M_EOF) {
X PLStatus(1, "I/O Error reading macros");
X MStopIO();
X /* DEBUG_RETURN("Status=%d" C status); */
X PLExit(PLsev_badform);
X }
X
X/* DEBUGF(7, "NextToUse=%d" C NextToUse); */
X/* for (status = 0; status < NextToUse; status++)
XDEBUGF(8, "buf[%4d] = %4d = %c" C status C buf[status] C buf[status]); */
X
X PLStatus(6, "Translating program...");
X
X while (M_OK == (status = MGetBuff(PrgStream))) {
X int offset, machead;
X int paraminx = 0; /* assigned to shut up GCC */
X bool found;
X
X /* Read a line to be expanded */
X offset = 0;
X do {
X inpline[offset] = MGetChar();
X if (inpline[offset] == HeadEOL)
X inpline[offset] = 0;
X } while (inpline[offset++] != 0);
X
X /* Search for matching template */
X machead = FirstToUse; found = FALSE;
X while (machead < NextToUse && ! found) {
X bool done;
X offset = 0; done = FALSE; paraminx = 1;
X while (!done) {
X if (buf[machead + 2 + offset] == HeadParm &&
X inpline[offset] != 0) {
X param[paraminx++] = inpline[offset++];
X }
X else if (inpline[offset] == buf[machead + 2 + offset]) {
X if (inpline[offset] == 0)
X done = found = TRUE;
X else
X offset += 1;
X }
X else if (inpline[offset] != buf[machead + 2 + offset]) {
X done = TRUE;
X }
X }
X if (! found)
X machead = buf[machead];
X }
X
X /* Make sure line was found */
X if (! found) {
X MPutChar(0); /* clear buffer */
X MPutChar(zero); /* error zero - not matched */
X for (offset = 0; inpline[offset]; offset++)
X MPutChar(inpline[offset]);
X MPutChar(0); /* terminate buffer */
X if (M_OK != MPutBuff(ErrStream) || M_OK != MPutBuff(ExpStream)) {
X PLStatus(1, "Error while writing error message");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X }
X else {
X /* Expand the line */
X offset += 1; /* skip past HeadEOL */
X MPutChar(0); /* clear output buffer */
X offset += machead + 2; /* let offset point directly to body */
X while (offset < buf[machead]) {
X if (buf[offset] == 0) { /* BodyEOL */
X MPutChar(0); /* terminate buffer */
X if (M_OK != MPutBuff(ExpStream)) {
X PLStatus(1, "Error while writing expansion");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X offset += 1;
X }
X else if (buf[offset] == BodyParm) {
X int parm, form, convnum;
X parm = buf[offset + 1];
X form = buf[offset + 2];
X offset += 3;
X if (parm < 0 || paraminx <= parm) {
X MPutChar(0); /* clear buffer */
X MPutChar(zero + 1); /* error 1 - bad param number */
X for (offset = 0; inpline[offset]; offset++)
X MPutChar(inpline[offset]);
X MPutChar(0); /* terminate buffer */
X if (M_OK != MPutBuff(ErrStream) ||
X M_OK != MPutBuff(ExpStream)) {
X PLStatus(1, "Error while writing error message");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X offset = BUFSIZE;
X }
X if (parm == 0) {
X if (form < 0 || 9 < form) {
X MPutChar(0); /* clear buffer */
X MPutChar(zero + 2); /* error 2 - bad digit */
X for (offset = 0; inpline[offset]; offset++)
X MPutChar(inpline[offset]);
X MPutChar(0); /* terminate buffer */
X if (M_OK != MPutBuff(ErrStream) ||
X M_OK != MPutBuff(ExpStream)) {
X PLStatus(1, "Error while writing error message");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X offset = BUFSIZE;
X }
X convnum = symgen + form;
X if (99 < convnum)
X MPutChar(((convnum / 100) % 10) + zero);
X if (9 < convnum)
X MPutChar(((convnum / 10) % 10) + zero);
X MPutChar((convnum % 10) + zero);
X }
X else {
X if (form == 0)
X MPutChar(param[parm]);
X else if (form == 1) {
X convnum = param[parm];
X if (99 < convnum)
X MPutChar(((convnum / 100) % 10) + zero);
X if (9 < convnum)
X MPutChar(((convnum / 10) % 10) + zero);
X MPutChar((convnum % 10) + zero);
X }
X else if (form == 2) {
X convnum = param[parm];
X MPutChar(((convnum / 100) % 10) + zero);
X MPutChar(((convnum / 10) % 10) + zero);
X MPutChar((convnum % 10) + zero);
X }
X else {
X MPutChar(0); /* clear buffer */
X MPutChar(zero + 3); /* error 3 - bad conv */
X for (offset = 0; inpline[offset]; offset++)
X MPutChar(inpline[offset]);
X MPutChar(0); /* terminate buffer */
X if (M_OK != MPutBuff(ErrStream) ||
X M_OK != MPutBuff(ExpStream)) {
X PLStatus(1, "Error while writing error message");
X MStopIO();
X /* DEBUG_RETURN(NULL); */
X PLExit(PLsev_badform);
X }
X offset = BUFSIZE;
X }
X }
X }
X else {
X MPutChar(buf[offset++]);
X }
X }
X
X /* expansion complete - bump symgen */
X symgen += 1 + buf[machead + 1];
X }
X }
X
X MStopIO();
X
X PLStatus(6, "Translation complete!");
X
X /* DEBUG_RETURN(NULL); */
X
X return 0;
X }
X
END_OF_FILE
if test 9022 -ne `wc -c <'LOME/Comp1.c'`; then
echo shar: \"'LOME/Comp1.c'\" unpacked with wrong size!
fi
# end of 'LOME/Comp1.c'
fi
if test -f 'LOME/LOME8.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'LOME/LOME8.c'\"
else
echo shar: Extracting \"'LOME/LOME8.c'\" \(7966 characters\)
sed "s/^X//" >'LOME/LOME8.c' <<'END_OF_FILE'
X/*
X * LOME8.c
X * Line Oriented Macro Expander - DoMath()
X * Copyright 1989 Darren New
X *
X */
X
X#include "LOME.h"
X
X#ifdef HIDPROTS
XHIDDEN void ConvErr ARGS((str expr));
XHIDDEN long ConvLetter ARGS((char ch));
XHIDDEN void StrSubs ARGS((str r, int from, int to, str new));
XHIDDEN bool GetToken ARGS((str r,int p,int* first,int* last));
XHIDDEN bool GetParams ARGS((str r, int p, long * p1, long * p2, int * first));
X#endif
X
XHIDDEN void ConvErr ARGS1(str,expr)
X{
X char * t = "Intermediate expression causing error:";
X
X Message("CONV");
X
X MPutChar(0);
X while (*t) MPutChar(*t++);
X MPutChar(0);
X MPutBuff(outstream);
X
X t = expr;
X while (*t) MPutChar(*t++);
X MPutChar(0);
X MPutBuff(outstream);
X
X TraceBack();
X /* quitting = TRUE; */
X }
X
XHIDDEN long ConvLetter ARGS1(char,ch)
X{
X long valch = -1L;
X if (0 <= ch - params[O_ZERO] &&
X ch - params[O_ZERO] <= 9)
X valch = ch - params[O_ZERO];
X else if (0 <= ch - params[O_LCA] &&
X ch - params[O_LCA] <= params[O_UCZ] - params[O_UCA] + 1)
X valch = 10 + ch - params[O_LCA];
X else if (0 <= ch - params[O_UCA] &&
X ch - params[O_UCA] <= params[O_UCZ] - params[O_UCA] + 1)
X valch = 10 + ch - params[O_UCA];
X return valch;
X }
X
XHIDDEN void StrSubs ARGS4(str,r,int,from,int,to,str,new)
X{
X /* This replaces the section of 'r' from 'r[from]' up to but not
X including 'r[to]' with 'new' */
X
X char newstr[BIGLINE];
X
X assert(r != NULL);
X assert(new != NULL);
X assert(0 <= from);
X assert(0 <= to);
X assert(from <= strlen(r));
X assert(to <= strlen(r));
X assert(from <= to);
X
X assert(strlen(r) - (to - from) + strlen(new) < BIGLINE);
X
X strcpy(newstr, r);
X newstr[from] = EOS;
X strcat(newstr, new);
X strcat(newstr, &r[to]);
X strcpy(r, newstr);
X }
X
XHIDDEN bool GetToken ARGS4(str,r,int,p,int*,first,int*,last)
X{
X /* This simply finds the token preceding r[p] and returns
X pointers to the first and one-past-the-last characters in
X *first and *last, respectively. returns TRUE if found, FALSE if not.
X */
X
X assert(r != NULL);
X assert(first != NULL);
X assert(last != NULL);
X assert(0 <= p);
X assert(p < strlen(r));
X
X if (p == 0)
X return FALSE;
X
X p--; /* back up to before operator */
X
X while (0 <= p && r[p] == params[O_SPACE])
X p--;
X
X *last = p + 1;
X if (*last == 0)
X return FALSE;
X
X while (0 < p && r[p] != params[O_SPACE])
X p--;
X
X *first = p + 1;
X
X return TRUE;
X }
X
X
X
XHIDDEN bool GetParams ARGS5(str,r,int,p,long*,p1,long*,p2,int*,first)
X{
X /* This finds the values of the immediately preceeding two
X tokens (as integers). It returns them in *p1 and *p2.
X It returns TRUE if both could be parsed as radix-10
X integers and FALSE if they could not be so parsed (or if
X there were not two tokens). It returns the index of the first
X character of the first token in *first (to allow the caller
X to replace the entire expression with the result).
X p must be the index of the operator within the string r.
X */
X
X char * paramend;
X int endofparam;
X long val;
X
X assert(p1 != NULL);
X assert(p2 != NULL);
X assert(r != NULL);
X assert(first != NULL);
X assert(0 <= p);
X assert(p < strlen(r));
X
X if (p == 0)
X return FALSE;
X
X p--; /* back up to before operator */
X
X while (0 <= p && r[p] == params[O_SPACE])
X p--;
X endofparam = p + 1;
X while (0 <= p && r[p] != params[O_SPACE])
X p--;
X if (p < 0)
X return FALSE; /* second param at start of line */
X val = StrToIntErr(&r[p+1], ¶mend);
X if (paramend != &r[endofparam])
X return FALSE;
X *p2 = val;
X
X while (0 <= p && r[p] == params[O_SPACE])
X p--;
X endofparam = p + 1;
X if (p < 0)
X return FALSE; /* no first parameter found */
X while (0 <= p && r[p] != params[O_SPACE])
X p--;
X val = StrToIntErr(&r[p+1], ¶mend);
X if (paramend != &r[endofparam])
X return FALSE;
X *p1 = val;
X
X *first = p+1;
X
X return TRUE;
X }
X
X
X
Xvoid DoMath ARGS1(int,p /* the parameter number */)
X{
X char r[BIGLINE+2];
X int i, j;
X
X assert(0 < tstacksize);
X assert(0 <= p && p <= 9);
X
X if (Sp[p] == NULL || *Sp[p] == 0) {
X return;
X }
X
X assert(strlen(Sp[p]) < BIGLINE);
X
X i = j = 0;
X r[i++] = ' ';
X while (Sp[p][j]) {
X if (Sp[p][j] != params[O_SPACE] || r[i-1] != params[O_SPACE])
X r[i++] = Sp[p][j];
X j++;
X }
X r[i] = EOS;
X while (0 < i && r[i-1] == params[O_SPACE])
X r[--i] = EOS;
X
X loop {
X for (i = 0; i < strlen(r); i++) {
X if ( (
X r[i] == params[O_PLUS] ||
X r[i] == params[O_MINUS] ||
X r[i] == params[O_MULT] ||
X r[i] == params[O_DIV] ||
X r[i] == params[O_FETCH] ||
X r[i] == params[O_RADIX]
X ) &&
X (r[i+1] == EOS || r[i+1] == params[O_SPACE]) ) {
X break;
X }
X }
X
X if (r[i] == EOS) {
X for (j = 1; r[j]; j++)
X ADDTOLINE(r[j]);
X ENDLINE();
X return;
X }
X else if (r[i] == params[O_PLUS] || r[i] == params[O_MINUS] ||
X r[i] == params[O_MULT] || r[i] == params[O_DIV]) {
X long p1, p2;
X long answer = 0; /* assign to shut up GCC */
X int first;
X bool good;
X char strbuf[BIGLINE];
X good = GetParams(r, i, &p1, &p2, &first);
X if (!good) {
X ConvErr(r);
X return;
X }
X else {
X if (r[i] == params[O_PLUS])
X answer = p1 + p2;
X
X if (r[i] == params[O_MINUS])
X answer = p1 - p2;
X
X if (r[i] == params[O_MULT])
X answer = p1 * p2;
X
X if (r[i] == params[O_DIV]) {
X if (p2 != 0)
X answer = p1 / p2;
X else {
X ConvErr(r);
X return;
X }
X }
X
X IntToStr(answer, strbuf);
X StrSubs(r, first, i+1, strbuf);
X }
X }
X else if (r[i] == params[O_FETCH]) {
X int first, last;
X char varname[BIGLINE];
X char * varvalue;
X bool good;
X good = GetToken(r, i, &first, &last);
X if (!good) {
X ConvErr(r);
X return;
X }
X else {
X for (j = first; j < last; j++)
X varname[j-first] = r[j];
X varname[last-first] = EOS;
X varvalue = VarLookup(varname);
X if (varvalue == NULL) {
X ConvErr(r);
X return;
X }
X else {
X StrSubs(r, first, i+1, varvalue);
X }
X }
X }
X else if (r[i] == params[O_RADIX]) {
X int f1, l1, f2, l2, f3, l3;
X int j, k;
X long sign, val, valch, from, to;
X bool good;
X char newstr[BIGLINE];
X char revstr[BIGLINE];
X
X good = GetToken(r, i, &f3, &l3);
X if (!good || f3 != l3 - 1) {
X ConvErr(r);
X return;
X }
X
X good = GetToken(r, f3, &f2, &l2);
X if (!good || f2 != l2 - 1) {
X ConvErr(r);
X return;
X }
X
X good = GetToken(r, f2, &f1, &l1);
X if (!good) {
X ConvErr(r);
X return;
X }
X
X from = ConvLetter(r[f2]);
X if (from < 1) {
X ConvErr(r);
X return;
X }
X
X to = ConvLetter(r[f3]);
X if (to < 1) {
X ConvErr(r);
X return;
X }
X
X sign = 1L; val = 0L;
X for (j = f1; j < l1; j++) {
X if (r[j] == params[O_MINUS] && j == f1) {
X sign = -1L;
X valch = 0;
X continue;
X }
X else if (r[j] == params[O_PLUS] && j == f1) {
X sign = 1L;
X valch = 0;
X continue;
X }
X else {
X valch = ConvLetter(r[j]);
X if (valch < 0 || from < valch) {
X ConvErr(r);
X return;
X }
X val = val * (from + 1) + valch;
X }
X }
X
X j = 0;
X if (sign < 0L) {
X newstr[0] = params[O_MINUS];
X newstr[j = 1] = EOS;
X }
X
X if (val == 0) {
X newstr[0] = params[O_ZERO];
X newstr[j = 1] = EOS;
X }
X else {
X while (val != 0) {
X valch = val % (to + 1);
X val /= (to + 1);
X if (valch < 10)
X newstr[j++] = valch + params[O_ZERO];
X else
X newstr[j++] = valch - 10 + params[O_UCA];
X }
X }
X newstr[j] = EOS;
X
X if (newstr[0] == params[O_MINUS]) {
X revstr[0] = newstr[0];
X for (k = 1, j--; 1 <= j; j--, k++)
X revstr[k] = newstr[j];
X }
X else {
X for (k = 0, j--; 0 <= j; j--, k++)
X revstr[k] = newstr[j];
X }
X revstr[k] = EOS;
X
X StrSubs(r, f1, i + 1, revstr);
X
X }
X else {
X bomb("You can't get there from here");
X }
X /* end of infinite loop */
X }
X }
X
END_OF_FILE
if test 7966 -ne `wc -c <'LOME/LOME8.c'`; then
echo shar: \"'LOME/LOME8.c'\" unpacked with wrong size!
fi
# end of 'LOME/LOME8.c'
fi
if test -f 'LOME/Rubin.mac' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'LOME/Rubin.mac'\"
else
echo shar: Extracting \"'LOME/Rubin.mac'\" \(8668 characters\)
sed "s/^X//" >'LOME/Rubin.mac' <<'END_OF_FILE'
XFILE: Rubin&.mac
XThe following message describes a fairly complex translation that is
Xdesired by the sender. This file contains my solution, along with a
Xdescription of how to use it. The basic operation is to recognise one
Xcomponent of the assember-like line, handle it, and remove it. Very
Xlittle complexity is present except for the large number of options,
Xso only a small number of different substitutions are used and no file
Xor control operations are needed.
X--------------------------------------------------------------
X>>From: Herman Rubin <cik at l.cc.purdue.edu>
X>>To: new at ee.udel.edu
X>>Date: Mon, 16 Jul 90 09:50:54 -0500
X>>Subject: Re: It looks like he's at it again!
X>>>I still cannot figure it out. Maybe if you can show me how to do one
X>>>example, it might help. The way I want to write the macro is
X>>>
X>>> c{'z} ={tc} {-}{|}{ta}a{'x} OP{mod} {|}{tb}b{'y} {/\{~}w}
X>>>
X>>>with the usual convention that fields in braces are optional. If knowing
X>>>what the fields mean will help, I will provide this information. It is
X>>>desired to write this either as an assembler instruction or a s CALLQ8
X>>>instruction to be inserted in a Fortran program. The types of the
X>>>a, b, and c are relevant.
X>>
X>>The code is for the CYBER 205/ETA 10. I will illustrate the conversion
X>>desired not to assembler, which I have not written, but to inserted
X>>instructions in Fortran, which is very similar. This does use symbolic
X>>names mostly, with a few exceptions. However, if I can manage this, I
X>>should be able to manage the assembler as well.
X>>
X>>The format of the output instruction is (I will use small letters, although
X>>Fortran normally uses capitals)
X>>
X>> callq8 mnemonic(g,x,a,y,b,w,c)
X>>
X>>A field omitted is the same as that field being 0, but the commas must still
X>>be there. A vector is indicated by its descriptor, which is a full word
X>>having the length and starting address. A length 0 vector is useful, as
X>>the offset can move before the start. The type of the vector (linguistic)
X>>is full or half, integer or float. There are also bit vectors. A scalar
X>>also has the same type possibilities. I may have some details wrong, but
X>>they can easily be fixed up. An offset value must be in a full word register.
X>>Fortran normally has all its descriptors and variables in registers, but not
X>>any of the vectors. The g field in this usage is given by a hex number, and
X>>the various bits will be explained.
X>>
X>>The a, b, and c fields are either the descriptors (vector) or the locations
X>>(scalar). The x, y, and z fields, if present, are full-word registers. The
X>>w field, if present, is the address of the beginning of a bit vector. If z
X>>is present, c must be in an even numbered register and z in the next register.
X>>Register 0 is unusable, and address 0 means not present.
X>>
X>>mnemonic refers to the operation and type. Given the type of c and the
X>>operation, this is translated normally (+ becomes add, etc.) except that
X>>the default modification of the instruction for the type of c can be changed
X>>by the mod field. For example, for add the mod fields are u,l,n, and x.
X>>For floats, n would be the default, and for integers, u.
X>>
X>>The bits of g are
X>>
X>> 80 half tc can be used to override the default.
X>> 40 complement the bit vector w (the ~)
X>> 20 use z for an offset to c and w ('z present)
X>> 10 a is scalar, not vector. ta overrides the default
X>> 08 b is scalar, not vector. tb overrides the default
X>> 04 the absolute value of a is taken (the | before a)
X>> 02 negate a (the -).
X>> 01 the absolute value of b is taken (the | before b)
X>>
X>>I hope this gives you a better idea of what I am trying to do. It is
X>>possible that if I can see how to do this, I might know how to handle
X>>other cases.
X--------------------------------------------------------------
XSince distinguishing between legal FORTRAN and this assembler-like
Xsyntax would be difficult, each assembler line must start with exactly
Xone asterisk followed by one space. Lines that start with two
Xasterisks are reserved for this use. This has the added benefit of
Xmaking such programs illegal to the FORTRAN compiler before being run
Xthrough LOME.
X------
XNote also that in Dr. Rubin's description, the "z" parameter is never
Xpassed to the FORTRAN function, no explaination of how to distinguish
Xhex addresses from variable names is given, and that results of the
Xoperation depend on the type of variables. The first is solved by
Xpassing "z" as the last argument. The second is "solved" by ignoring
Xthe possibility of hex numbers as arguments. The last is impossible to
Xsolve without either explicitly passing types as separate
Xassembler-like statements or parsing some of the FORTRAN source and is
Xhence ignored. This is, after all, tutorial.
X
X&@.@$0AaZFC`'()+-*/?!XXXX 000000000000
X* @. Match anything that starts with one star and a space
X$ This just sets up the variables to their default values.
X$ The arguments to the callq8 statement (g,x,y,w,z)
X$ are initialized here and set as they are matched in later productions.
X$ This is probably not the best way to do it, but it does illustrate
X$ some points.
XG at 970@98$ set variable G to zero
XX at 970@98$ set variable X to zero
XY at 970@98$ set variable Y to zero
XZ at 970@98$ set variable Z to zero
XW at 970@98$ set variable W to zero
XC @00$ output the original line as a comment
X**@00$ reparse the line without reinitializing
X$$
X***GenFormat(@,@,@).
X$ 0 1 2
X$ This generates the instruction from the LOME variables stored
X$ in G, X, Y, Z, W, and OP
XOP at 47G@57X at 67Y@77Z at 87W@97$ set up variable names
X at 53@57$ replace param 5 with contents of G
X at 52@57$ replace param 5 with contents of G evaluated as math
X CALLQ8 @43(@50, at 63, at 00, at 73, at 10, at 93, at 20, at 83)
X$ Z at F6$ Debugging dump if needed
X$$
X
X**@ =@ @ @ @ /\~@. see if ~w is present
X$ 0 1 2 3 4 5
XW at 97@50 at 98$ set variable W to the contents of parameter five
XG at 97@93 64 + at 98$ add 64 to G
X**@00 =@10 @20 @30 @40$ resubmit
X$$
X**@ =@ @ @ @ /\@. see if w is present
X$ 0 1 2 3 4 5
XW at 97@50 at 98$ set variable W to the contents of parameter five
X**@00 =@10 @20 @30 @40$ resubmit
X$$
X
X**@ =@ -@ @ @. see if "a" is negated
X$ 0 1 2 3 4
XG at 97@93 2 + at 98$ add 2 to G
X**@00 =@10 @20 @30 @40$ resubmit
X$$
X**@ =@ |@ @ @. see if "a" is abs'ed
X$ 0 1 2 3 4
XG at 97@93 4 + at 98$ add 2 to G
X**@00 =@10 @20 @30 @40$ resubmit
X$$
X**@ =@ @ @ |@. see if "b" is abs'ed
X$ 0 1 2 3 4
XG at 97@93 1 + at 98$ add 1 to G
X**@00 =@10 @20 @30 @40$ resubmit
X$$
X
X**@'@ =@ @ @ @. see if z is present
X$ 0 1 2 3 4 5
XZ at 97@10 at 98$ set variable Z to the contents of parameter one
XG at 97@93 32 + at 98$ add 32 to G
X**@00 =@20 @30 @40 @50$ resubmit
X$$
X**@ =@ @'@ @ @. see if x is present
X$ 0 1 2 3 4 5
XX at 97@30 at 98$ set variable X to the contents of parameter 3
X**@00 =@10 @20 @40 @50$ resubmit
X$$
X**@ =@ @ @'@. see if y is present
X$ 0 1 2 3 4
XY at 97@40 at 98$ set variable Y to the contents of parameter 4
X**@00 =@10 @20 @30$ resubmit
X$$
X
X**@ =(half) @ @ @. check if tc is half-length
X$ 0 1 2 3
X$ Since I can't really figure out what tc, ta, tb and mod are supposed
X$ to mean, this is kind of a guess.
XG at 97@93 128 + at 98$ add 128 to G
X**@00 = @10 @20 @30 @40$ resubmit
X$$
X**@ =(full) @ @ @. check if tc is full-length
X$ 0 1 2 3
X$ This is here for completeness.
X**@00 = @10 @20 @30 @40$ resubmit
X$$
X
X**@ = (scalar)@ @ @. check if a should be scalar
X$ 0 1 2 3
XG at 97@93 16 + at 98$ add 16 to G
X**@00 = @10 @20 @30$ resubmit
X$$
X**@ = (vector)@ @ @. check if a should be vector
X$ 0 1 2 3
X$ This is here for completeness
X**@00 = @10 @20 @30$ resubmit
X$$
X**@ = @ @ (scalar)@. check if b should be scalar
X$ 0 1 2 3
XG at 97@93 8 + at 98$ add 8 to G
X**@00 = @10 @20 @30$ resubmit
X$$
X**@ = @ @ (vector)@. check if b should be scalar
X$ 0 1 2 3
X$ This is here for completeness
X**@00 = @10 @20 @30$ resubmit
X$$
X
X**@ = @ +@ @. check for addition
X$ 0 1 2 3
XOP at 97ADD@20 at 98$ store "ADD" and modifier in OP
X***GenFormat(@00, at 10, at 30)$ output instruction
X$$
X**@ = @ -@ @. check for subtraction
X$ 0 1 2 3
XOP at 97SUB@20 at 98$ store "SUB" and modifier in OP
X***GenFormat(@00, at 10, at 30)$ output instruction
X$$
X**@ = @ *@ @. check for multiplication
X$ 0 1 2 3
XOP at 97MULT@20 at 98$ store "MULT" and modifier in OP
X***GenFormat(@00, at 10, at 30)$ output instruction
X$$
X**@ = @ /@ @. check for division
X$ 0 1 2 3
XOP at 97DIV@20 at 98$ store "DIV" and modifier in OP
X***GenFormat(@00, at 10, at 30)$ output instruction
X$$
X
X**@. check if I didn't reformat something correctly
XUnrecognised text: @00 at C0
X$$
END_OF_FILE
if test 8668 -ne `wc -c <'LOME/Rubin.mac'`; then
echo shar: \"'LOME/Rubin.mac'\" unpacked with wrong size!
fi
# end of 'LOME/Rubin.mac'
fi
if test -f 'PPL/PPLAmiga.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'PPL/PPLAmiga.c'\"
else
echo shar: Extracting \"'PPL/PPLAmiga.c'\" \(8753 characters\)
sed "s/^X//" >'PPL/PPLAmiga.c' <<'END_OF_FILE'
X/*
X * PPLAmiga.c
X * Portable Programmer's Library General Host Code
X * Amiga version
X * Copyright 1988, 1990 Darren New. All Rights Reserved.
X *
X * Started 19-Feb-88 DHN
X * LastMod 20-jul-90 DHN
X *
X */
X
X#include "PPL.h"
X
X#include "proto/dos.h"
X
X#define MAXARGC 20 /* max # args we are willing to remember */
X
X
XHIDDEN long memcount;
X
XHIDDEN long OutHand; /* file hand for PLPutChar() */
XHIDDEN long InHand; /* file hand for PLGetChar() */
X
Xvoid PLExit(severity)
X short severity;
X{
X /*
X if (memcount != 0)
X DEBUGF(1, "%ld blocks of allocated memory remain!" C memcount);
X DEBUG_EXIT();
X */
X
X exit((int) severity);
X }
X
Xptr PLAllocMem(size, flags)
X long size;
X int flags;
X{
X
X#ifdef CHECKALLOC
X
X /* Note that this has some debugging stuff in it */
X /**** OLD -- MUST BE CHECKED!! ****/
X ptr retval;
X inx i;
X assert(size < BIGMEM);
X retval = (ptr) malloc(size + sizeof(long) + sizeof(long) + (size & 1));
X if (retval == NULL) {
X if (flags & PLalloc_die) {
X bomb("Out of Memory");
X PLExit(PLsev_oores);
X }
X else
X return retval;
X }
X else {
X if (flags & PLalloc_zero)
X for (i = size + 2 * sizeof(long) + (size & 1) - 1; 0 <= i; i--)
X retval[i] = '\0';
X memcount += 1;
X (* (long *) retval) = 0xA5A55A5A;
X (* (long *) (retval + sizeof(long) + size + (size & 1))) = 0x5A5AA5A5;
X return retval + sizeof(long);
X }
X
X#else
X
X extern void * malloc(unsigned);
X char * retval;
X inx i;
X assert(size < BIGMEM);
X assert(size < 65530L);
X assert(0 < size);
X retval = malloc((unsigned) size);
X if (retval == NULL) {
X if (flags & PLalloc_die) {
X bomb("Out of Memory");
X PLExit(PLsev_oores);
X }
X else {
X return NULL;
X }
X }
X else {
X if (flags & PLalloc_zero) {
X for (i = 0; i < size; i++) {
X retval[i] = '\0';
X }
X }
X memcount += 1;
X return (ptr) retval;
X }
X
X#endif
X
X }
X
X
Xvoid PLFreeMem(where)
X ptr where;
X{
X
X#ifdef CHECKALLOC
X
X /* note that this has some debugging stuff in it */
X assert(where != NULL);
X where -= sizeof(long);
X if (* (long *) where == 0x19919119)
X bomb("Freed memory twice!");
X if (* (long *) where != 0xA5A55A5A)
X bomb("Freed non-malloced memory!");
X (* (long *) where) = 0x19919119;
X free(where);
X memcount -= 1;
X
X#else
X
X extern void free(void *);
X assert(where != NULL);
X free(where);
X memcount -= 1;
X
X#endif
X
X }
X
Xstr PLStrDup(s)
X str s;
X{
X str t;
X t = PLAllocMem(strlen(s)+1, PLalloc_die);
X strcpy((char *) t, (char *) s);
X return t;
X }
X
Xvoid PLCopyMem(to, from, siz)
X ptr to;
X ptr from;
X long siz;
X{
X /* be lazy and use lattice function here */
X extern void *memcpy(void *, void *, unsigned);
X assert(0 < siz);
X assert(siz < BIGMEM);
X assert(NULL != to);
X assert(NULL != from);
X (void) memcpy((char *) to, (char *) from, (unsigned) siz);
X }
X
Xvoid PLFillMem(where, siz, chr)
X ptr where;
X long siz;
X char chr;
X{
X char * whr = where;
X assert(whr != NULL);
X assert(0 < siz);
X assert(siz < 32760);
X assert(siz < BIGMEM);
X
X /* setmem((char *) where, (unsigned) siz, chr); */
X
X /* I don't trust Lattice at this point... */
X while (0 < siz--)
X *whr++ = chr;
X }
X
Xptr PLFindMem(where, siz, chr)
X ptr where;
X long siz;
X char chr;
X{
X extern void *memchr(void *, int, unsigned);
X assert(where != NULL);
X assert(0 < siz);
X assert(siz < BIGMEM);
X return (ptr) memchr((char *) where, chr, (unsigned) siz);
X }
X
X
X/* The error strings: */
XHIDDEN str PLerrstrs[] = {
X /* 0*/ "No Error",
X /* 1*/ "DOS error (retryable)",
X /* 2*/ "DOS error (wait/retry)",
X /* 3*/ "DOS error (please fix)",
X /* 4*/ "DOS error (failure)",
X /* 5*/ "Program fault",
X /* 6*/ "End of data during input",
X /* 7*/ "Out of resource during output",
X /* 8*/ "Multiple errors occured without being cleared",
X /* 9*/ "Item does not exist",
X /*10*/ "Item already exists",
X /*11*/ "You are not allowed to do that",
X /*12*/ "That opperation is not supported here",
X /*13*/ "Item is busy",
X /*14*/ "Item name missing or incorrectly formed",
X /*15*/ "Not Yet Implemented",
X /*16*/ "Cannot be Implemented",
X /*17*/ "Argument to internal function semantically invalid",
X /*18*/ "Overflow error",
X /*19*/ "Underflow error",
X /*20*/ "User break or interrupted system call",
X /*21*/ "Error number out of range",
X NULL
X };
X
XPLerr_enum PLerr;
X
XHIDDEN char * OSerrstrs[] = {
X "103: insufficient free store",
X "105: task table full",
X "120: argument line invalid or too long",
X "121: file is not an object module",
X "122: invalid resident library during load",
X "202: object in use",
X "203: object already exists",
X "204: directory not found",
X "205: object not found",
X "206: invalid window description",
X "209: packet request type unknown",
X "210: stream name component invalid",
X "211: invalid object lock",
X "212: object not of required type",
X "213: disk not validated",
X "214: disk write-protected",
X "215: rename across devices attempted",
X "216: directory not empty",
X "218: device (or volume) not mounted",
X "219: seek failure",
X "220: comment too big",
X "221: disk full",
X "222: file is protected from deletion",
X "223: file is write protected",
X "224: file is read protected",
X "225: not a valid DOS disk",
X "226: no disk in drive",
X "232: no more entries in directory",
X NULL
X };
X
Xint OSerr;
X
X/* The file and line of the last error (mainly for debugging) */
Xstr PLerr_file;
Xlong PLerr_line;
X
Xstr PLErrText()
X{
X if ( PLerr < 0 || PLerr_last < PLerr )
X PLerr = PLerr_last;
X return PLerrstrs[PLerr];
X }
X
Xstr PLOSErrText()
X{
X inx i;
X char t[4];
X static char buf[64];
X
X t[0] = (char) (OSerr / 100 % 10);
X t[1] = (char) (OSerr / 10 % 10);
X t[2] = (char) (OSerr / 1 % 10);
X t[3] = EOS;
X strcpy(buf, "Fault ");
X
X for (i = 0; OSerrstrs[i] != NULL; i++)
X if (t[0] == OSerrstrs[i][0] && t[1] == OSerrstrs[i][1] &&
X t[2] == OSerrstrs[i][2])
X break;
X
X if (OSerrstrs[i] != NULL) {
X strcat(buf, OSerrstrs[i]);
X }
X else {
X strcat(buf, t);
X }
X
X return buf;
X }
X
Xshort PLstatuslevel = 6;
X
Xvoid PLStatus(level, message)
X short level;
X str message;
X{
X /* char lev = PLtodig(level); */
X if (PLstatuslevel < level)
X return;
X if (PLcmdname && *PLcmdname) {
X Write(Output(), PLcmdname, strlen(PLcmdname));
X Write(Output(), ": ", 2);
X }
X /* Write(Output(), "(", 1);
X Write(Output(), &lev, 1);
X Write(Output(), ") ", 2);
X */
X Write(Output(), message, (long) strlen(message));
X Write(Output(), "\n", 1);
X }
X
Xvoid PLDelay(secs)
X short secs;
X{
X assert(0 <= secs);
X if (secs != 0)
X Delay((long) secs * 50L);
X }
X
Xvoid PLBeep(how)
X short how;
X{
X /* for now, always just flash */
X /* later, we will open the audio.device and so on... */
X
X /* extern void DisplayBeep(void); */
X /* DisplayBeep(); */
X Write(Output(), "\007", 1L);
X }
X
X/* get the next character from "standard input" */
X
Xshort PLGetChar()
X{
X char ch;
X int res;
X if (InHand)
X res = Read(InHand, &ch, 1);
X else
X res = -1;
X if (res == 0)
X return -1;
X else if (res < 0)
X return -2;
X else
X return (short) ch;
X }
X
X/* This should send the indicated character to the "standard output". */
Xvoid PLPutChar(short ch)
X{
X char chr = (char) ch;
X if (OutHand)
X Write(OutHand, &chr, 1);
X }
X
Xvoid PLResetInput()
X{
X InHand = Open("*", MODE_OLDFILE);
X }
X
Xvoid PLResetOutput()
X{
X OutHand = Open("*", MODE_OLDFILE);
X }
X
X
X
X
X/* This gives the name of the command, if available.
X */
Xstr PLcmdname;
X
X/* This gives the host-syntax filename for the executable file,
X * if available.
X */
Xstr PLcmdfile;
X
X/* This tells how many command-line arguments there were, excluding
X * the command name.
X */
Xshort PLargcnt;
X
X/* This is the array of command-line argument strings.
X */
Xstr PLarglist[MAXARGC];
X
X/* These are the flags describing the command-line parameters.
X */
Xlong PLargflags;
X
X/* Here is the main() that sets all this up, calls DoIt() and exits.
X */
X
X#if HIDPROTS
Xvoid main ARGS((int argc, char * argv[]));
X#endif
X
Xvoid main(argc, argv)
X int argc;
X char * argv[];
X{
X /* Eventually, we will want to init PLstatuslevel from an env var,
X or something similar. */
X
X OutHand = Output();
X InHand = Input();
X
X if (0 < argc) {
X char * cp;
X inx i;
X cp = argv[0] + strlen(argv[0]) - 1;
X while (argv[0] < cp && *cp != '/' && *cp != ':')
X cp -= 1;
X PLcmdname = cp;
X PLargcnt = argc - 1;
X for (i = 1; i < argc && i < MAXARGC; i++)
X PLarglist[i-1] = argv[i];
X }
X PLExit(DoIt());
X }
X
X
X/************* END OF FILE ***************/
X
X
X
END_OF_FILE
if test 8753 -ne `wc -c <'PPL/PPLAmiga.c'`; then
echo shar: \"'PPL/PPLAmiga.c'\" unpacked with wrong size!
fi
# end of 'PPL/PPLAmiga.c'
fi
if test -f 'TFS/TFSAmiga.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'TFS/TFSAmiga.c'\"
else
echo shar: Extracting \"'TFS/TFSAmiga.c'\" \(9122 characters\)
sed "s/^X//" >'TFS/TFSAmiga.c' <<'END_OF_FILE'
X/*
X * TFSAmiga.c
X * Portable Programmer's Library Text File Subsystem Code File
X * Copyright 1988 Darren New. All Rights Reserved.
X *
X * Started: 26-Feb-88 DHN
X * LastMod: 04-dec-88 DHN
X *
X * Version One for Amiga -- Simple, just to get running
X *
X */
X
X#include "PPL.h"
X#include "TFS.h"
X
X#include "libraries/dos.h"
X#include "proto/dos.h"
X
X#define MAXTFS 15 /* max # TFSfiles open at once */
X
XHIDDEN struct { /* one open file */
X str name;
X long fhand;
X str modes;
X } ftab[MAXTFS];
X
XHIDDEN bool TFShbi = FALSE; /* has been init */
XHIDDEN short TFSfree; /* number of free ftab entries */
X
XHIDDEN struct FileInfoBlock * fib; /* cuts down allocation overhead */
X
X
X
X#define HND (handle - 1) /* for convenience */
X
X
Xvoid TFSInit()
X{
X inx i;
X assert(TFShbi == FALSE);
X TFShbi = TRUE;
X for (i = 0; i < MAXTFS; i++)
X ftab[i].name = ftab[i].modes = NULL;
X /* fib = AllocMem(sizeof(struct FileInfoBlock), MEMF_PUBLIC);
X if (fib == NULL) bomb("Out of Memory!"); */
X fib = (struct FileInfoBlock *)
X PLAllocMem(sizeof(struct FileInfoBlock), PLalloc_die);
X assert((((long) fib) & 3) == 0);
X TFSfree = MAXTFS;
X PLErrClr();
X }
X
Xbool TFSHasBeenInit()
X{
X return TFShbi;
X }
X
Xvoid TFSTerm()
X{
X int i;
X assert(TFShbi);
X for (i = 0; i < MAXTFS; i++) {
X if (ftab[i].modes != NULL) {
X Close(ftab[i].fhand);
X PLFreeMem(ftab[i].modes);
X PLFreeMem(ftab[i].name);
X }
X }
X PLFreeMem((ptr) fib);
X TFSfree = 0;
X TFShbi = FALSE;
X PLErrClr();
X }
X
X
XTFSfile TFSOpen(fname, mode)
X str fname;
X str mode;
X{
X
X /**** NOTE THIS MUST BE CHANGED TO REMEMBER NAMES IN FULL LENGTH
X OR RELATIVE TO A LOCK! ****/
X
X BPTR flock;
X BPTR fhand;
X bool mL, mC, mT, mA, mR, mW, mP, mD;
X long t; /* temp value */
X inx i;
X
X#define setup(a,b) {a = (NULL != strchr(mode, b));}
X
X assert(TFShbi);
X#if CHKARGS
X if (fname == NULL || mode == NULL || *fname == EOS || *mode == EOS ||
X BIGFNAME <= strlen(fname) ) {
X PLErrSet(PLerr_badarg);
X return 0;
X }
X#endif
X
X setup(mL, 'L'); setup(mC, 'C'); setup(mT, 'T');
X setup(mA, 'A'); setup(mR, 'R'); setup(mW, 'W');
X setup(mP, 'P'); setup(mD, 'D');
X
X#if CHKARGS
X if ( (mR && mW) || (mP && !mR && !mC) || (mW && !mA && !mT) ||
X (mA && mT) || (mA && !mW) || (mT && !mW) ) {
X PLErrSet(PLerr_badarg);
X return 0;
X }
X#endif
X
X if (TFSfree == 0 && ! mL) {
X PLErrSet(PLerr_oores);
X return 0;
X }
X
X flock = Lock(fname, mR ? ACCESS_READ : ACCESS_WRITE);
X if (flock == 0 && !mC) {
X OSerr = IoErr();
X PLErrSet(PLerr_exist);
X return 0;
X }
X
X if (flock != 0) {
X /* file exists -- check it out */
X
X if (0 == Examine(flock, fib)) {
X OSerr = IoErr();
X UnLock(flock);
X PLErrSet(PLerr_opsysF);
X return 0;
X }
X
X t = fib->fib_Protection; /* bits indicate denied permisions */
X if ( ((t & FIBF_READ) && mR) || ((t & FIBF_WRITE) && mW) ||
X ((t & FIBF_DELETE) && mD) ) {
X PLErrSet(PLerr_permit);
X UnLock(flock);
X return 0;
X }
X
X if ((mR || mW) && (fib->fib_DirEntryType > 0)) {
X PLErrSet(PLerr_unsup);
X UnLock(flock);
X return 0;
X }
X
X UnLock(flock);
X fhand = Open(fname, mT ? MODE_NEWFILE : MODE_OLDFILE);
X if (fhand == 0) {
X OSerr = IoErr();
X PLErrSet(PLerr_opsysF);
X return 0;
X }
X if (IsInteractive(fhand) && mP) {
X Close(fhand);
X PLErrSet(PLerr_unsup);
X return 0;
X }
X
X if (mL) {
X Close(fhand);
X PLErrClr();
X return 1;
X }
X
X for (i = 0; i < MAXTFS && ftab[i].modes; i++)
X ;
X assert(i < MAXTFS);
X ftab[i].fhand = fhand;
X ftab[i].modes = PLStrDup(mode);
X ftab[i].name = PLStrDup(fname);
X
X if (mA) Seek(fhand, 0, OFFSET_END);
X
X return (TFSfile) (i + 1);
X }
X else {
X /* file does not exist -- create it */
X
X fhand = Open(fname, MODE_NEWFILE);
X if (fhand == 0) {
X OSerr = IoErr();
X PLErrSet(PLerr_opsysU);
X return 0;
X }
X
X if (mL) {
X Close(fhand);
X DeleteFile(fname);
X PLErrClr();
X return 1;
X }
X
X for (i = 0; i < MAXTFS && ftab[i].modes; i++)
X ;
X assert(i < MAXTFS);
X ftab[i].fhand = fhand;
X ftab[i].modes = PLStrDup(mode);
X ftab[i].name = PLStrDup(fname);
X
X return (TFSfile) (i + 1);
X }
X }
X
Xbool TFSClose(handle)
X TFSfile handle;
X{
X assert(TFShbi);
X#if CHKARGS
X if (HND < 0 || MAXTFS <= HND || ftab[HND].modes == NULL) {
X PLErrSet(PLerr_badarg);
X return FALSE;
X }
X#endif
X assert(ftab[HND].fhand != NULL);
X assert(ftab[HND].name != NULL);
X assert(ftab[HND].modes != NULL);
X
X Close(ftab[HND].fhand);
X PLFreeMem((ptr) ftab[HND].modes);
X PLFreeMem((ptr) ftab[HND].name);
X ftab[HND].name = ftab[HND].modes = NULL;
X PLErrClr();
X return TRUE;
X }
X
Xbool TFSDestroy(handle)
X TFSfile handle;
X{
X char fn[BIGLINE];
X bool flag;
X int err;
X
X assert(TFShbi);
X#if CHKARGS
X if (HND < 0 || MAXTFS <= HND || ftab[HND].modes == NULL) {
X PLErrSet(PLerr_badarg);
X return FALSE;
X }
X#endif
X strcpy(fn, ftab[HND].name);
X flag = (NULL != strchr(ftab[HND].modes, 'D'));
X
X Close(ftab[HND].fhand);
X PLFreeMem(ftab[HND].name);
X PLFreeMem(ftab[HND].modes);
X ftab[HND].modes = NULL;
X
X if (flag) {
X err = DeleteFile(fn); /* permission checked during open */
X if (err == 0) {
X OSerr = IoErr();
X PLErrSet(PLerr_opsysF);
X return FALSE;
X }
X else {
X PLErrClr();
X return TRUE;
X }
X }
X else {
X PLErrSet(PLerr_badarg);
X return FALSE;
X }
X }
X
X/* @$@$
XTFSInfo() - Determine file parameters. This may return various
Xparameters about the given file. The description of the information
Xreturned is given in the TFS.h file.
X*/
X
X
Xshort TFSRead(handle, buf)
X TFSfile handle;
X str buf;
X{
X long prevseek;
X long l;
X inx i;
X char c;
X
X /* see TFSUnix.c for character-by-character version */
X
X assert(TFShbi);
X assert(buf != NULL);
X#if CHKARGS
X /*
X printf("handle=%d\n", handle);
X printf("buf=%x\n", buf);
X printf("HND=%d\n", HND);
X printf("&ftab[HND]=%x\n", &ftab[HND]);
X printf("&ftab[HND].modes=%x\n", &ftab[HND].modes);
X printf("ftab[HND].modes=\"%s\"\n", ftab[HND].modes);
X */
X if (HND < 0 || MAXTFS <= HND || ftab[HND].modes == NULL) {
X PLErrSet(PLerr_badarg);
X buf[0] = EOS;
X return S -1;
X }
X if (NULL == strchr(ftab[HND].modes, 'R')) {
X PLErrSet(PLerr_badarg);
X buf[0] = EOS;
X return S -1;
X }
X#endif
X
X do {
X prevseek = Seek(ftab[HND].fhand, 0, OFFSET_CURRENT);
X } while (prevseek < 0 && fault("Could not seek text file!"));
X if (prevseek < 0)
X PLExit(PLsev_fault);
X l = Read(ftab[HND].fhand, buf, BIGLINE);
X if (l == -1) {
X PLErrSet(PLerr_opsysF);
X OSerr = IoErr();
X buf[0] = EOS;
X return S -1;
X }
X else if (l == 0) {
X PLErrSet(PLerr_eod);
X buf[0] = EOS;
X return S -1;
X }
X else {
X i = l;
X while (i < BIGLINE)
X buf[i++] = '\n';
X for (i = 0; buf[i] != '\n' && i < BIGLINE; i++)
X ;
X if (buf[i] == '\n') {
X buf[i] = EOS;
X Seek(ftab[HND].fhand, prevseek + i + 1, OFFSET_BEGINNING);
X while (0 < i && isspace(buf[i-1]))
X buf[--i] = EOS;
X assert(strlen(buf) < BIGLINE);
X return (short) i;
X }
X else {
X i = BIGLINE;
X buf[BIGLINE-1] = EOS;
X while (0 < i && isspace(buf[i-1]))
X buf[--i] = EOS;
X do {
X l = Read(ftab[HND].fhand, &c, 1);
X } while (l == 1 && c != '\n');
X PLErrClr();
X PLErrSet(PLerr_overflow);
X assert(strlen(buf) < BIGLINE);
X return (short) -1;
X }
X }
X }
X
X
Xbool TFSWrite(handle, buf)
X TFSfile handle;
X str buf;
X{
X int i; /* must be able to handle negative numbers */
X
X assert(buf != NULL);
X#if CHKARGS
X if (HND < 0 || MAXTFS <= HND || ftab[HND].modes == NULL) {
X PLErrSet(PLerr_badarg);
X return FALSE;
X }
X if (NULL == strchr(ftab[HND].modes, 'W')) {
X PLErrSet(PLerr_badarg);
X return FALSE;
X }
X#endif
X
X i = strlen(buf);
X while (0 < i && isspace(buf[i - 1]))
X i -= 1;
X if ( ( (0 < i) && (i != Write(ftab[HND].fhand, buf, i)) ) ||
X 1 != Write(ftab[HND].fhand, "\n", 1)) {
X OSerr = IoErr();
X PLErrSet(PLerr_opsysF);
X return FALSE;
X }
X PLErrClr();
X return TRUE;
X }
X
Xlong TFSNote(handle)
X TFSfile handle;
X{
X long retval;
X#if CHKARGS
X if (HND < 0 || MAXTFS <= HND || ftab[HND].modes == NULL) {
X PLErrSet(PLerr_badarg);
X return -1L;
X }
X if (NULL == strchr(ftab[HND].modes, 'P') ||
X NULL == strchr(ftab[HND].modes, 'R')) {
X PLErrSet(PLerr_badarg);
X return -1L;
X }
X#endif
X
X retval = Seek(ftab[HND].fhand, 0, OFFSET_CURRENT );
X if (retval == -1) {
X OSerr = IoErr();
X PLErrSet(PLerr_opsysF);
X OSerr = IoErr();
X return 0L;
X }
X else {
X PLErrClr();
X return retval + 1L;
X }
X }
X
Xbool TFSPoint(handle, pos)
X TFSfile handle;
X TFSnote pos;
X{
X long newpos;
X#if CHKARGS
X if (HND < 0 || MAXTFS <= HND || ftab[HND].modes == NULL) {
X PLErrSet(PLerr_badarg);
X return -1L;
X }
X if (pos <= 0L || NULL == strchr(ftab[HND].modes, 'P') ||
X NULL == strchr(ftab[HND].modes, 'R')) {
X PLErrSet(PLerr_badarg);
X return -1L;
X }
X#endif
X
X newpos = Seek(ftab[HND].fhand, pos - 1L, OFFSET_BEGINNING );
X if (newpos == -1L) {
X OSerr = IoErr();
X PLErrSet(PLerr_opsysF);
X OSerr = IoErr();
X return FALSE;
X }
X else {
X PLErrClr();
X return TRUE;
X }
X }
X
X
X
END_OF_FILE
if test 9122 -ne `wc -c <'TFS/TFSAmiga.c'`; then
echo shar: \"'TFS/TFSAmiga.c'\" unpacked with wrong size!
fi
# end of 'TFS/TFSAmiga.c'
fi
echo shar: End of archive 5 \(of 9\).
cp /dev/null ark5isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 9 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
--- Darren New --- Grad Student --- CIS --- Univ. of Delaware ---
exit 0 # Just in case...
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list