rs@uunet.UU.NET (Rich Salz) (06/24/87)
Submitted by: Brian Harvey <bh@mit-amt>
Mod.Sources: Volume 10, Number 23
Archive-Name: logo/Part03
#! /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 3 (of 6)."
# Contents: logoaux.c logoop.c logoproc.c turtle.c
# Wrapped by rsalz@pineapple.bbn.com on Wed Jun 24 14:26:57 1987
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f logoaux.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"logoaux.c\"
else
echo shar: Extracting \"logoaux.c\" \(11138 characters\)
sed "s/^X//" >logoaux.c <<'END_OF_logoaux.c'
X
X/* This file contains a miscellany of functions for LOGO, both
X * primary implementation of LOGO operations and commands, and also various
X * other functions for maintaining the overhead of the interpreter (variable
X * storage, function calls, etc.)
X *
X * Copyright (C) 1979, The Children's Museum, Boston, Mass.
X * Written by Douglas B. Klunder
X */
X
X#include "logo.h"
X#include <sgtty.h>
X#include <setjmp.h>
Xextern jmp_buf yerrbuf;
Xint tvec[2] ={0,0};
Xextern int yychar,yylval,yyline;
Xextern int topf,errtold,flagquit;
Xextern FILE *ofile;
Xextern char *ostring;
Xextern char *getbpt;
Xextern char charib;
Xextern int pflag,letflag;
Xextern int currtest;
Xstruct runblock *thisrun = NULL;
Xextern struct plist *pcell; /* for PAUSE */
Xextern struct stkframe *fbr;
X#ifdef PAUSE
Xextern int pauselev,psigflag;
X#endif
X
Xtyobj(text)
Xregister struct object *text;
X{
X register struct object *temp;
X char str[30];
X
X if (text==0) return;
X switch (text->obtype) {
X case CONS:
X for (temp = text; temp; temp = temp->obcdr) {
X fty1(temp->obcar);
X if(temp->obcdr) putc1(' ');
X }
X break;
X case STRING:
X sputs(text->obstr);
X break;
X case INT:
X sprintf(str,FIXFMT,text->obint);
X sputs(str);
X break;
X case DUB:
X sprintf(str,"%g",text->obdub);
X if (!index(str,'.')) strcat(str,".0");
X sputs(str);
X break;
X }
X}
X
Xfty1(text)
Xregister struct object *text;
X{
X if (listp(text)) {
X putc1('[');
X tyobj(text);
X putc1(']');
X } else tyobj(text);
X}
X
Xfillbuf(text) /* Logo TYPE */
Xregister struct object *text;
X{
X tyobj(text);
X mfree(text);
X}
X
Xstruct object *cmprint(arg)
Xstruct object *arg;
X{
X fillbuf(arg);
X putchar('\n');
X return ((struct object *)(-1));
X}
X
Xstruct object *cmtype(arg)
Xstruct object *arg;
X{
X fillbuf(arg);
X return ((struct object *)(-1));
X}
X
Xstruct object *cmfprint(arg)
Xstruct object *arg;
X{
X fty1(arg);
X putchar('\n');
X mfree(arg);
X return ((struct object *)(-1));
X}
X
Xstruct object *cmftype(arg)
Xstruct object *arg;
X{
X fty1(arg);
X mfree(arg);
X return ((struct object *)(-1));
X}
X
Xsetfile(file)
Xregister struct object *file;
X{
X file = numconv(file,"File command");
X if (!intp(file)) ungood("File command",file);
X ofile = (FILE *)((int)(file->obint));
X mfree(file);
X}
X
Xfileprint(file,text)
Xregister struct object *file,*text;
X{
X setfile(file);
X fillbuf(text);
X fputc('\n',ofile);
X ofile = NULL;
X}
X
Xfilefprint(file,text)
Xregister struct object *file,*text;
X{
X setfile(file);
X fty1(text);
X mfree(text);
X fputc('\n',ofile);
X ofile = NULL;
X}
X
Xfiletype(file,text)
Xregister struct object *file,*text;
X{
X setfile(file);
X fillbuf(text);
X ofile = NULL;
X}
X
Xfileftype(file,text)
Xstruct object *file,*text;
X{
X setfile(file);
X fty1(text);
X mfree(text);
X ofile = NULL;
X}
X
Xstruct object *openfile(name,type)
Xregister struct object *name;
Xregister char *type;
X{
X FILE *fildes;
X
X if (!stringp(name)) ungood("Open file",name);
X fildes = fopen(name->obstr,type);
X if (!fildes) {
X pf1("Can't open file %l.\n",name);
X errhand();
X }
X mfree(name);
X return(localize(objint((FIXNUM)((int)fildes))));
X}
X
Xstruct object *loread(arg)
Xstruct object *arg;
X{
X return(openfile(arg,"r"));
X}
X
Xstruct object *lowrite(arg)
Xstruct object *arg;
X{
X return(openfile(arg,"w"));
X}
X
Xstruct object *callunix(cmd)
Xregister struct object *cmd;
X{
X register struct object *str;
X
X str = stringform(cmd);
X system(str->obstr);
X mfree(str);
X mfree(cmd);
X return ((struct object *)(-1));
X}
X
Xstruct object *fileclose(file)
Xregister struct object *file;
X{
X setfile(file);
X fclose(ofile);
X ofile = NULL;
X return ((struct object *)(-1));
X}
X
Xstruct object *fileread(file,how)
Xregister struct object *file;
Xint how; /* 0 for fileread (returns list), 1 for fileword (returns str) */
X{
X char str[200];
X register struct object *x;
X char *svgbpt;
X char c;
X
X setfile(file);
X fgets(str,200,ofile);
X if (feof(ofile)) {
X ofile = NULL;
X if (how) return((struct object *)0);
X return(localize(objcpstr("")));
X }
X ofile = NULL;
X if (how) {
X str[strlen(str)-1] = '\0';
X return(localize(objcpstr(str)));
X }
X str[strlen(str)-1] = ']';
X c = charib;
X charib = 0;
X svgbpt = getbpt;
X getbpt = str;
X x = makelist();
X getbpt = svgbpt;
X charib = c;
X return(x);
X}
X
Xstruct object *lfread(arg)
Xstruct object *arg;
X{
X return(fileread(arg,0));
X}
X
Xstruct object *lfword(arg)
Xstruct object *arg;
X{
X return(fileread(arg,1));
X}
X
Xstruct object *lsleep(tim) /* wait */
Xregister struct object *tim;
X{
X int itim;
X
X tim = numconv(tim,"Wait");
X if (intp(tim)) itim = tim->obint;
X else itim = tim->obdub;
X mfree(tim);
X sleep(itim);
X return ((struct object *)(-1));
X}
X
Xstruct object *input(flag)
Xint flag; /* 0 for readlist, 1 for request */
X{
X int len;
X char s[512];
X register struct object *x;
X char *svgbpt;
X char c;
X
X if (flag) putchar('?');
X fflush(stdout);
X len = read(0,s,512);
X if (len <= 0) len = 1;
X s[len-1]=']';
X c = charib;
X charib = 0;
X svgbpt = getbpt;
X getbpt = s;
X x = makelist();
X getbpt = svgbpt;
X charib = c;
X return (x);
X}
X
Xstruct object *readlist() {
X return(input(0));
X}
X
Xstruct object *request() {
X return(input(1));
X}
X
Xstruct object *ltime() /* LOGO time */
X{
X char ctim[50];
X register struct object *x;
X char *svgbpt;
X char c;
X
X time(tvec);
X strcpy(ctim,ctime(tvec));
X ctim[strlen(ctim)-1]=']';
X c = charib;
X charib = 0;
X svgbpt = getbpt;
X getbpt = ctim;
X x = makelist();
X getbpt = svgbpt;
X charib = c;
X return(x);
X}
X
Xdorun(arg,num)
Xstruct object *arg;
XFIXNUM num;
X{
X register struct object *str;
X register struct runblock *rtemp;
X
X rtemp = (struct runblock *)ckmalloc(sizeof(struct runblock));
X if (num != 0) {
X rtemp->rcount = num;
X rtemp->rupcount = 0;
X } else {
X rtemp->rcount = 1; /* run or if, not repeat */
X if (thisrun)
X rtemp->rupcount = thisrun->rupcount - 1;
X else
X rtemp->rupcount = 0;
X }
X rtemp->roldyyc = yychar;
X rtemp->roldyyl = yylval;
X rtemp->roldline = yyline;
X rtemp->svbpt = getbpt;
X rtemp->svpflag = pflag;
X rtemp->svletflag = letflag;
X rtemp->svch = charib;
X if (arg == (struct object *)(-1)) { /* PAUSE */
X rtemp->str = (struct object *)(-1);
X } else {
X str = stringform(arg);
X mfree(arg);
X strcat(str->obstr,"\n");
X rtemp->str = globcopy(str);
X mfree(str);
X }
X rtemp->rprev = thisrun;
X thisrun = rtemp;
X rerun();
X}
X
Xrerun() {
X yychar = -1;
X pflag = 0;
X letflag = 0;
X charib = '\0';
X thisrun->rupcount++;
X if (thisrun->str == (struct object *)(-1)) /* PAUSE */
X getbpt = 0;
X else
X getbpt = thisrun->str->obstr;
X}
X
Xunrun() {
X register struct runblock *rtemp;
X
X yychar = thisrun->roldyyc;
X yylval = thisrun->roldyyl;
X yyline = thisrun->roldline;
X getbpt = thisrun->svbpt;
X pflag = thisrun->svpflag;
X letflag = thisrun->svletflag;
X charib = thisrun->svch;
X if (thisrun->str != (struct object *)(-1)) /* PAUSE */
X lfree(thisrun->str);
X rtemp = thisrun;
X thisrun = thisrun->rprev;
X JFREE(rtemp);
X}
X
Xdorep(count,cmd)
Xstruct object *count,*cmd;
X{
X FIXNUM icount;
X
X count = numconv(count,"Repeat");
X if (intp(count)) icount = count->obint;
X else icount = count->obdub;
X if (icount < (FIXNUM)0) ungood("Repeat",count);
X if (icount == (FIXNUM)0) {
X mfree(cmd);
X cmd = 0;
X icount++;
X }
X dorun(cmd,icount);
X mfree(count);
X}
X
Xstruct object *repcount() {
X if (!thisrun) {
X puts("Repcount outside repeat.");
X errhand();
X }
X return(localize(objint(thisrun->rupcount)));
X}
X
X#ifdef PAUSE
Xdopause() {
X register struct plist *opc;
X
X if (pflag || getbpt) {
X printf("Pausing");
X opc = pcell;
X if (fbr && fbr->oldline==-1) {
X opc=fbr->prevpcell;
X }
X if (opc&&!topf) printf(" at line %d in procedure %s",yyline,
X opc->procname->obstr);
X printf("\n");
X pauselev++;
X }
X if (psigflag) {
X psigflag = 0;
X#ifdef EUNICE
X yyprompt();
X#endif
X }
X if (pflag || getbpt)
X dorun((struct object *)(-1),(FIXNUM)0);
X}
X
Xunpause() {
X if (pauselev > 0) {
X pauselev--;
X unrun();
X }
X}
X#endif
X
Xerrhand() /* do error recovery, then pop out to outer level */
X{
X errtold++;
X flagquit = 0;
X onintr(errrec,1);
X#ifdef PAUSE
X longjmp(yerrbuf,9);
X#else
X ltopl();
X#endif
X}
X
Xnullfn()
X{
X}
X
Xreadlin(fd,buf) /* read a line from file */
Xregister FILDES fd;
Xregister char *buf;
X{
X register char *i;
X
X for (i = buf; *(i-1) != '\n'; i++) read(fd,i,1);
X}
X
Xmakeup(str)
Xregister char *str;
X{
X register char ch;
X
X while (ch = *str) {
X if (ch >= 'a' && ch <= 'z') *str = ch-040;
X str++;
X }
X}
X
Xstruct object *cbreak(ostr)
Xregister struct object *ostr;
X{
X struct sgttyb sgt;
X register char *str;
X
X#ifdef CBREAK
X if (!stringp(ostr)) ungood("Cbreak",ostr);
X str = ostr->obstr;
X makeup(str);
X if (strcmp(str,"ON") && strcmp(str,"OFF")) {
X puts("cbreak input must be \"on or \"off");
X errhand();
X }
X gtty(0,&sgt);
X if (!strcmp(str,"ON")) {
X sgt.sg_flags |= CBREAK;
X sgt.sg_flags &= ~ECHO;
X } else {
X sgt.sg_flags &= ~CBREAK;
X sgt.sg_flags |= ECHO;
X }
X stty(0,&sgt);
X mfree(ostr);
X return ((struct object *)(-1));
X#else
X printf("No CBREAK on this system.\n");
X errhand(); /* Such as V6 or Idris */
X#endif
X}
X
Xcboff()
X{
X struct sgttyb sgt;
X
X#ifdef CBREAK
X gtty(0,&sgt);
X sgt.sg_flags &= ~CBREAK;
X sgt.sg_flags |= ECHO;
X stty(0,&sgt);
X#endif
X}
X
Xstruct object *readchar()
X{
X char s[2];
X
X fflush(stdout);
X read(0,s,1);
X s[1] = '\0';
X return(localize(objcpstr(s)));
X}
X
Xstruct object *keyp()
X{
X#ifdef TIOCEMPTY
X int i;
X
X fflush(stdout);
X ioctl(0,TIOCEMPTY,&i);
X if (i)
X return(true());
X else
X#else
X#ifdef FIONREAD
X long i;
X
X fflush(stdout);
X ioctl(0,FIONREAD,&i);
X if (i)
X return(true());
X else
X#endif
X#endif
X return(false());
X}
X
Xstruct object *settest(val)
Xstruct object *val;
X{
X if (obstrcmp(val,"true") && obstrcmp(val,"false")) ungood("Test",val);
X currtest = !obstrcmp(val,"true");
X mfree(val);
X return ((struct object *)(-1));
X}
X
Xloflush() {
X fflush(stdout);
X}
X
Xstruct object *cmoutput(arg)
Xstruct object *arg;
X{
X extern int endflag;
X
X#ifdef PAUSE
X if (!pflag && thisrun && thisrun->str==(struct object *)(-1))
X unpause();
X#endif
X endflag = 1;
X return(arg);
X}
X
X#ifdef SETCURSOR
X
Xint gotterm = 0;
X
X/* Termcap definitions */
X
Xchar *UP,
X *CS,
X *CM,
X *CL,
X *BC,
X *padchar;
X
Xchar PC = '\0';
X
Xshort ospeed;
X
Xchar tspace[128];
X
Xchar **meas[] = {
X &CS, &CM, &CL, &UP, &BC, &padchar, 0
X};
X
Xchar tbuff[1024];
X
XgetTERM()
X{
X char *getenv();
X struct sgttyb tty;
X char *ts="cscmclupbcpc";
X char *termname = 0,
X *termp = tspace;
X int i;
X
X if (gotterm) return(gotterm);
X
X if (gtty(1, &tty)) {
X ospeed = B1200;
X } else {
X tty.sg_flags &= ~ XTABS;
X ospeed = tty.sg_ospeed;
X stty(1,&tty);
X }
X
X termname = getenv("TERM");
X if (termname == 0) {
X puts("No terminal in environment.");
X gotterm = -1;
X return(gotterm);
X }
X
X if (tgetent(tbuff, termname) < 1) {
X pf1("No termcap entry for %s\n",termname);
X gotterm = -1;
X return(gotterm);
X }
X
X for (i = 0; meas[i]; i++) {
X *(meas[i]) = (char *) tgetstr(ts, &termp);
X ts += 2;
X }
X
X if (padchar) PC = *padchar;
X
X gotterm = 1;
X return(gotterm);
X}
X
Xextern int putch();
X
Xstruct object *clrtxt()
X{
X if (getTERM() < 0) return;
X tputs(CL,24,putch);
X return ((struct object *)(-1));
X}
X
Xstruct object *setcur(x,y)
Xstruct object *x,*y;
X{
X int ix,iy;
X
X x=numconv(x,"Setcursorxy");
X y=numconv(y,"Setcursorxy");
X if (!intp(x)) ungood("Setcursorxy",x);
X if (!intp(y)) ungood("Setcursorxy",y);
X if (getTERM() > 0) {
X ix = x->obint;
X iy = y->obint;
X tputs(tgoto(CM,ix,iy),1,putch);
X }
X mfree(x);
X mfree(y);
X return ((struct object *)(-1));
X}
X
X#endif SETCURSOR
X
END_OF_logoaux.c
if test 11138 -ne `wc -c <logoaux.c`; then
echo shar: \"logoaux.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logoop.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"logoop.c\"
else
echo shar: Extracting \"logoop.c\" \(10685 characters\)
sed "s/^X//" >logoop.c <<'END_OF_logoop.c'
X
X/* Miscellaneous operations in LOGO.
X * Copyright (C) 1979, The Children's Museum, Boston, Mass.
X * Written by Douglas B. Klunder.
X */
X
X#include "logo.h"
X
Xstruct object *true()
X{
X return(localize(objcpstr("true")));
X}
X
Xstruct object *false()
X{
X return(localize(objcpstr("false")));
X}
X
Xobstrcmp(obj,str)
Xregister struct object *obj;
Xchar *str;
X{
X if (!stringp(obj)) return(1);
X return(strcmp(obj->obstr,str));
X}
X
Xint truth(x) /* used by if handler in logo.y */
Xregister struct object *x;
X{
X if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("If",x);
X if (!obstrcmp(x,"true")) {
X mfree(x);
X return(1);
X } else {
X mfree(x);
X return(0);
X }
X}
X
Xchar *mkstring(obj)
Xregister struct object *obj;
X{
X /* subroutine for several operations which treat numbers as words,
X * turn number into character string.
X * Note: obj must be known to be nonempty; result is ptr to static.
X */
X
X register char *cp;
X static char str[30];
X
X switch(obj->obtype) {
X case STRING:
X cp = obj->obstr;
X break;
X case INT:
X sprintf(str,FIXFMT,obj->obint);
X cp = str;
X break;
X case DUB:
X sprintf(str,"%g",obj->obdub);
X if (!index(str,'.')) strcat(str,".0");
X cp = str;
X break;
X default: /* case CONS */
X return(0); /* not a string, handle uplevel */
X }
X return(cp);
X}
X
Xstruct object *and(x,y) /* both */
Xregister struct object *x,*y;
X{
X if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Both",x);
X if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Both",y);
X if (!obstrcmp(x,"true")) {
X mfree(x);
X return(y);
X } else {
X mfree(y);
X return(x);
X }
X}
X
Xstruct object *or(x,y) /* either */
Xregister struct object *x,*y;
X{
X if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Either",x);
X if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Either",y);
X if (!obstrcmp(x,"true")) {
X mfree(y);
X return(x);
X } else {
X mfree(x);
X return(y);
X }
X}
X
Xemptyp(x) /* non-LOGO emptyp, returning 1 if empty, 0 if not. */
Xregister struct object *x;
X{
X if (x==0) return(1);
X switch (x->obtype) {
X case STRING:
X if (*(x->obstr)=='\0') /* check for character */
X return(1);
X default:
X return(0);
X }
X}
X
Xstruct object *lemp(x) /* LOGO emptyp */
Xregister struct object *x;
X{
X if (emptyp(x)) {
X mfree(x);
X return(true());
X } else {
X mfree(x);
X return(false());
X }
X}
X
Xstruct object *comp(x) /* not */
Xregister struct object *x;
X{
X if (!obstrcmp(x,"true")) {
X mfree(x);
X return(false());
X } else if (!obstrcmp(x,"false")) {
X mfree(x);
X return(true());
X } else ungood("Not",x);
X}
X
Xstruct object *lsentp(x) /* LOGO sentencep */
Xregister struct object *x;
X{
X register struct object *y;
X
X if (x==0) return(true());
X if (listp(x)) {
X /* BH 4/30/81 true only for a flat sentence,
X not a list of lists */
X for (y = x; y; y = y->obcdr)
X if (listp(y->obcar)) {
X mfree(x);
X return(false());
X }
X mfree(x);
X return(true());
X } else {
X mfree(x);
X return(false());
X }
X}
X
Xstruct object *lwordp(x) /* LOGO wordp */
Xregister struct object *x;
X{
X if (!listp(x)) {
X mfree(x);
X return(true());
X } else {
X mfree(x);
X return(false());
X }
X}
X
Xstruct object *first(x) /* first */
Xregister struct object *x;
X{
X register struct object *temp;
X register char *cp;
X char str[2];
X
X if (emptyp(x)) ungood("First",x);
X if (cp = mkstring(x)) {
X str[0] = *cp;
X str[1] = '\0';
X mfree(x);
X return(localize(objcpstr(str)));
X } else {
X temp = x->obcar;
X localize(temp);
X mfree(x);
X return(temp);
X }
X}
X
Xstruct object *butfir(x) /* butfirst */
Xregister struct object *x;
X{
X register struct object *temp;
X register char *cp;
X
X if (emptyp(x)) ungood("Butfirst",x);
X if (cp = mkstring(x)) {
X cp++; /* skip first char */
X mfree(x);
X return(localize(objcpstr(cp)));
X } else {
X temp = x->obcdr;
X localize(temp);
X mfree(x);
X return(temp);
X }
X}
X
Xstruct object *last(x) /* last */
Xregister struct object *x;
X{
X register struct object *temp;
X register char *cp;
X
X if (emptyp(x)) ungood("Last",x);
X if (cp = mkstring(x)) {
X mfree(x);
X return(localize(objcpstr(&cp[strlen(cp)-1])));
X } else {
X for(temp=x; temp->obcdr; temp=temp->obcdr) ;
X temp = temp->obcar;
X localize(temp);
X mfree(x);
X return(temp);
X }
X}
X
Xstruct object *butlas(x) /* butlast */
Xregister struct object *x;
X{
X register struct object *temp,*temp2,*ans;
X register char *cp;
X
X if (emptyp(x)) ungood("Butlast",x);
X if (cp = mkstring(x)) {
X mfree(x);
X temp = objstr(ckmalloc(strlen(cp)));
X strncpy(temp->obstr,cp,strlen(cp)-1);
X (temp->obstr)[strlen(cp)-1] = '\0';
X return(localize(temp));
X } else {
X if ((x->obcdr)==0) {
X mfree(x);
X return(0);
X }
X temp2 = ans = globcons(0,0);
X for(temp=x; temp->obcdr->obcdr; temp=temp->obcdr) {
X temp2->obcar = globcopy(temp->obcar);
X temp2->obcdr = globcopy(globcons(0,0));
X temp2 = temp2->obcdr;
X }
X temp2->obcar = globcopy(temp->obcar);
X localize(ans);
X mfree(x);
X return(ans);
X }
X}
X
Xstruct object *fput(x,y)
Xregister struct object *x,*y;
X{
X register struct object *z;
X
X if(!listp(y)) {
X printf("Second input of fput must be a list.\n");
X errhand();
X }
X z = loccons(x,y);
X mfree(x);
X mfree(y);
X return(z);
X}
X
Xstruct object *lput(x,y)
Xstruct object *x,*y;
X{
X register struct object *a,*b,*ans;
X
X if (!listp(y)) {
X printf("Second input of lput must be a list.\n");
X errhand();
X }
X if (y == 0) { /* 2nd input is empty list */
X b = loccons(x,0);
X mfree(x);
X return(b);
X }
X ans = a = loccons(0,0);
X for (b=y; b; b=b->obcdr) {
X a->obcar = globcopy(b->obcar);
X a->obcdr = globcopy(globcons(0,0));
X a = a->obcdr;
X }
X a->obcar = globcopy(x);
X mfree(x);
X mfree(y);
X return(ans);
X}
X
Xstruct object *list(x,y)
Xstruct object *x,*y;
X{
X register struct object *a,*b;
X
X b = globcons(y,0);
X a = loccons(x,b);
X mfree(x);
X mfree(y);
X return(a);
X}
X
Xstruct object *length(x) /* count */
Xregister struct object *x;
X{
X register struct object *temp;
X register char *cp;
X register int i;
X
X if (x==0) return(localize(objint((FIXNUM)0)));
X if (cp = mkstring(x)) {
X i = strlen(cp);
X mfree(x);
X return(localize(objint((FIXNUM)i)));
X } else {
X i = 0;
X for (temp=x; temp; temp = temp->obcdr)
X i++;
X mfree(x);
X return(localize(objint((FIXNUM)i)));
X }
X}
X
Xlogois(x,y) /* non-Logo is, despite the name */
Xregister struct object *x,*y;
X{
X if (listp(x)) {
X if (listp(y)) {
X if (x==0) return(y==0);
X if (y==0) return(0);
X return(logois(x->obcar,y->obcar) &&
X logois(x->obcdr,y->obcdr) );
X }
X return(0);
X }
X if (listp(y)) return(0);
X if (x->obtype != y->obtype) return(0);
X switch (x->obtype) {
X case INT:
X return(x->obint == y->obint);
X case DUB:
X return(x->obdub == y->obdub);
X default: /* case STRING */
X return(!strcmp(x->obstr,y->obstr));
X }
X}
X
Xstruct object *lis(x,y)
Xregister struct object *x,*y;
X{
X register z;
X
X z = logois(x,y);
X mfree(x);
X mfree(y);
X return(z ? true() : false());
X}
X
Xleq(x,y) /* non-Logo numeric equal */
Xregister struct object *x,*y;
X{
X NUMBER dx,dy;
X FIXNUM ix,iy;
X int xint,yint;
X
X if (listp(x) || listp(y)) return(logois(x,y));
X if (stringp(x) && !nump(x)) return(logois(x,y));
X if (stringp(y) && !nump(y)) return(logois(x,y));
X xint = yint = 0;
X if (stringp(x)) {
X if (isint(x)) {
X xint++;
X sscanf(x->obstr,FIXFMT,&ix);
X } else {
X sscanf(x->obstr,EFMT,&dx);
X }
X } else {
X if (intp(x)) {
X xint++;
X ix = x->obint;
X } else {
X dx = x->obdub;
X }
X }
X if (stringp(y)) {
X if (isint(y)) {
X yint++;
X sscanf(y->obstr,FIXFMT,&iy);
X } else {
X sscanf(y->obstr,EFMT,&dy);
X }
X } else {
X if (intp(y)) {
X yint++;
X iy = y->obint;
X } else {
X dy = y->obdub;
X }
X }
X if (xint != yint) {
X if (xint) dx = ix;
X else dy = iy;
X xint = 0;
X }
X if (xint)
X return (ix == iy);
X else
X return (dx == dy);
X}
X
Xstruct object *equal(x,y) /* Logo equalp */
Xregister struct object *x,*y;
X{
X register z;
X
X z = leq(x,y);
X mfree(x);
X mfree(y);
X return(z ? true() : false());
X}
X
Xstruct object *worcat(x,y) /* word */
Xregister struct object *x,*y;
X{
X char *val,*xp,*yp;
X char xstr[30],ystr[30];
X
X if (listp(x)) ungood("Word",x);
X if (listp(y)) ungood("Word",y);
X switch(x->obtype) {
X case INT:
X sprintf(xstr,FIXFMT,x->obint);
X xp = xstr;
X break;
X case DUB:
X sprintf(xstr,"%g",x->obdub);
X if (!index(xstr,'.')) strcat(xstr,".0");
X xp = xstr;
X break;
X default: /* case STRING */
X xp = x->obstr;
X }
X switch(y->obtype) {
X case INT:
X sprintf(ystr,FIXFMT,y->obint);
X yp = ystr;
X break;
X case DUB:
X sprintf(ystr,"%g",y->obdub);
X if (!index(ystr,'.')) strcat(ystr,".0");
X yp = ystr;
X break;
X default: /* case STRING */
X yp = y->obstr;
X }
X val=ckmalloc(strlen(xp)+strlen(yp)+1);
X cpystr(val,xp,yp,NULL);
X mfree(x);
X mfree(y);
X return(localize(objstr(val)));
X}
X
Xstruct object *sencat(x,y) /* sentence */
Xstruct object *x,*y;
X{
X register struct object *a,*b,*c;
X
X if (x==0) {
X if (listp(y)) return(y);
X a = loccons(y,0);
X mfree(y);
X return(a);
X }
X if (listp(x)) {
X c = a = globcons(0,0);
X for (b=x; b->obcdr; b = b->obcdr) {
X a->obcar = globcopy(b->obcar);
X a->obcdr = globcopy(globcons(0,0));
X a = a->obcdr;
X }
X a->obcar = globcopy(b->obcar);
X }
X else c = a = globcons(x,0);
X
X if (listp(y)) b = y;
X else b = globcons(y,0);
X
X a->obcdr = globcopy(b);
X mfree(x);
X mfree(y);
X return(localize(c));
X}
X
Xstruct object *memberp(thing,group)
Xstruct object *thing,*group;
X{
X register char *cp;
X register struct object *rest;
X int i;
X
X if (group==0) {
X mfree(thing);
X return(false());
X }
X if (cp = mkstring(group)) {
X if (thing==0) {
X mfree(group);
X return(false());
X }
X switch (thing->obtype) {
X case INT:
X if((thing->obint >= 0)&&(thing->obint < 10)) {
X i = memb('0'+thing->obint,cp);
X break;
X }
X case CONS:
X case DUB:
X i = 0;
X break;
X default: /* STRING */
X if (strlen(thing->obstr) == 1) {
X i = memb(*(thing->obstr),cp);
X } else i = 0;
X }
X } else {
X i = 0;
X for (rest=group; rest; rest=rest->obcdr) {
X if (leq(rest->obcar,thing)) {
X i++;
X break;
X }
X }
X }
X mfree(thing);
X mfree(group);
X return(torf(i));
X}
X
Xstruct object *item(num,group)
Xstruct object *num,*group;
X{
X int inum,ernum;
X register char *cp;
X register struct object *rest;
X char str[2];
X
X num = numconv(num,"Item");
X if (intp(num)) inum = num->obint;
X else inum = num->obdub;
X if (inum <= 0) ungood("Item",num);
X if (group == 0) ungood("Item",group);
X if (cp = mkstring(group)) {
X if (inum > strlen(cp)) {
X pf1("%p has fewer than %d items.\n",group,inum);
X errhand();
X }
X str[0] = cp[inum-1];
X str[1] = '\0';
X mfree(num);
X mfree(group);
X return(localize(objcpstr(str)));
X } else {
X ernum = inum;
X for (rest = group; --inum; rest = rest->obcdr) {
X if (rest==0) break;
X }
X if (rest==0) {
X pf1("%p has fewer than %d items.\n",
X group,ernum);
X errhand();
X }
X mfree(num);
X rest = localize(rest->obcar);
X mfree(group);
X return(rest);
X }
X}
X
END_OF_logoop.c
if test 10685 -ne `wc -c <logoop.c`; then
echo shar: \"logoop.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logoproc.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"logoproc.c\"
else
echo shar: Extracting \"logoproc.c\" \(11517 characters\)
sed "s/^X//" >logoproc.c <<'END_OF_logoproc.c'
X
X#include <stdio.h>
X#include "logo.h"
X
Xint errrec();
Xint ehand2();
Xint ehand3();
Xint leave();
X
Xextern char popname[];
Xextern int letflag, pflag, argno, yyline, rendflag, currtest;
Xextern int traceflag, *stkbase, stkbi, yychar, endflag, topf;
X#ifdef PAUSE
Xextern int pauselev, errpause, catching, flagquit;
X#endif
X#ifndef NOTURTLE
Xextern int turtdes;
X#endif
Xextern char charib, *getbpt, *ibufptr;
Xextern char titlebuf[];
Xextern struct lexstruct keywords[];
Xextern struct stkframe *fbr;
Xextern struct plist *proclist;
Xextern struct object *multarg;
Xextern struct runblock *thisrun;
X#ifndef YYSTYPE
X#define YYSTYPE int
X#endif
Xextern YYSTYPE yylval;
X
Xint doprep = 0;
Xint *newstk =NULL;
Xint newsti =0;
XFILE *pbuf =0;
Xstruct plist *pcell =NULL;
Xstruct alist *locptr =NULL, *newloc =NULL;
Xstruct object *allocstk[MAXALLOC] ={0};
X
Xint memb(ch,str)
Xregister char ch,*str;
X{
X register char ch1;
X
X while (ch1 = *str++)
X if (ch == ch1) return(1);
X return(0);
X}
X
Xchar *token(str)
Xregister char *str;
X{
X static char output[NAMELEN+5];
X register char ch,*op;
X
X op = output;
X while((op < &output[19]) && (ch = *str++) && !memb(ch," \t\"[\r\n:")){
X if (ch >= 'A' && ch <= 'Z') ch += 'a'-'A';
X *op++ = ch;
X }
X *op = '\0';
X return(output);
X}
X
X#ifdef DEBUG
Xjfree(block)
Xchar *block;
X{
X if (memtrace)
X printf("Jfree loc=0%o\n",block);
X if (block==0) printf("Trying to jfree zero.\n");
X else free(block);
X}
X#endif
X
Xnewproc(nameob)
Xstruct object *nameob;
X{
X register char *name;
X register struct stkframe *stemp;
X register struct lincell *ltemp;
X struct plist *pptr;
X int linlab;
X int itemp;
X char *temp,*tstr;
X struct object *title;
X char s[100];
X int olp;
X int oldlet;
X int olc,c;
X int pc;
X extern struct plist *proclook();
X
X name = nameob->obstr;
X stemp=(struct stkframe *)ckzmalloc(sizeof(*stemp));
X stemp->prevframe=fbr;
X stemp->oldyyc= -2;
X stemp->oldline= -1;
X stemp->oldnewstk=newstk;
X newstk = NULL;
X stemp->oldnloc=newloc;
X newloc=NULL;
X stemp->argtord=argno;
X stemp->prevpcell=pcell;
X pcell = NULL;
X stemp->loclist = NULL;
X fbr=stemp;
X doprep++;
X argno=0;
X if (pptr=proclook(name)) {
X mfree(nameob);
X newstk=pptr->realbase;
X (pptr->recdepth)++;
X title=pptr->ptitle;
X pcell=pptr;
X } else {
X onintr(ehand2,&pbuf);
X cpystr (s,name,EXTEN,NULL);
X if (!(pbuf=fopen(s,"r"))) {
X extern int errno;
X
X if (errno != 2) /* ENOENT */ {
X onintr(errrec,1);
X#ifdef SMALL
X printf("%s: error %d\n",s,errno);
X#else
X perror(s);
X#endif
X errhand();
X }
X cpystr(s,LIBLOGO,name,EXTEN,NULL);
X if (!(pbuf = fopen(s,"r"))) {
X onintr(errrec,1);
X printf("You haven't told me how to %s.\n",name);
X errhand();
X }
X }
X pptr=(struct plist *)ckzmalloc(sizeof(*pptr));
X pptr->plines=NULL;
X pptr->procname=globcopy(nameob);
X mfree(nameob);
X temp=s;
X while ( ((c=getc(pbuf)) != EOF) && (c!='\n') ) *temp++=c;
X if (c==EOF) {
X printf("Bad format in %s title line.\n",
X pptr->procname->obstr);
X errhand();
X }
X *temp++='\n';
X *temp='\0';
X title=globcopy(objcpstr(s));
X pptr->after=proclist;
X pptr->recdepth=1;
X pptr->ptitle=title;
X pptr->before=NULL;
X if (proclist) proclist->before = pptr;
X proclist=pptr;
X pcell=pptr;
X }
X tstr = title->obstr;
Xnextarg: while((c= *tstr++)!=':' && c!='\n')
X ;
X if (c==':') {
X temp=s;
X while ((c= *tstr++)!=' ' && c!='\n') *temp++=c;
X *temp='\0';
X tstr--;
X loccreate(globcopy(objcpstr(s)),&newloc);
X argno++;
X goto nextarg;
X }
X if (pptr->recdepth!=1) return;
X olp=pflag;
X pflag=1;
X oldlet=letflag;
X letflag=0;
X olc=charib;
X charib=0;
X newstk=(int *)ckmalloc(PSTKSIZ*sizeof(int));
X *newstk=0;
X newsti=1;
X *(newstk+newsti) = -1; /* BH 6/25/82 in case yylex blows up */
X itemp = '\n';
X while ((pc = yylex()) != -1) {
X if (pc==1) return;
X if ((itemp == '\n') && isuint(pc)) {
X linlab=((struct object *)yylval)->obint;
X ltemp=(struct lincell *)ckmalloc(sizeof(*ltemp));
X ltemp->linenum=linlab;
X ltemp->base=newstk;
X ltemp->index=newsti;
X ltemp->nextline=pptr->plines;
X pptr->plines=ltemp;
X }
X *(newstk+newsti++)=pc;
X if (newsti==PSTKSIZ-1) newfr();
X *(newstk+newsti++)=yylval;
X if (isstored(pc)) {
X yylval = (YYSTYPE)globcopy(yylval);
X mfree(yylval);
X }
X if (newsti==PSTKSIZ-1) newfr();
X *(newstk+newsti) = -1;
X itemp = pc;
X }
X *(newstk+newsti)= -1;
X *(newstk+PSTKSIZ-1)=0;
X pflag=olp;
X letflag=oldlet;
X charib=olc;
X fclose(pbuf);
X onintr(errrec,1);
X while (*newstk!=0) newstk= (int *)*newstk;
X pptr->realbase=newstk;
X}
X
Xprocprep()
X{
X doprep=0;
X fbr->oldline=yyline;
X fbr->oldbpt=getbpt;
X getbpt=0;
X fbr->loclist=locptr;
X locptr=newloc;
X newloc=NULL;
X fbr->stk=stkbase;
X stkbase=newstk;
X newstk=NULL;
X fbr->ind=stkbi;
X stkbi=1;
X newsti=0;
X argno= -1;
X fbr->oldpfg = pflag;
X pflag=2;
X fbr->iftest = currtest;
X if (traceflag) intrace();
X}
X
Xfrmpop(val)
Xregister struct object *val;
X{
X struct alist *atemp0,*atemp1,*atemp2;
X register struct stkframe *ftemp;
X struct lincell *ltemp,*ltemp2;
X register i;
X int *stemp;
X int stval;
X
X if (traceflag) outtrace(val);
X if (!pcell) goto nopcell;
X strcpy(popname,pcell->procname->obstr);
X (pcell->recdepth)--;
X if (pcell->recdepth==0) {
X lfree(pcell->procname);
X lfree(pcell->ptitle);
X if (pcell->before) (pcell->before)->after=pcell->after;
X else proclist=pcell->after;
X if (pcell->after) (pcell->after)->before=pcell->before;
X for(ltemp=pcell->plines;ltemp;ltemp=ltemp2) {
X ltemp2=ltemp->nextline;
X JFREE(ltemp);
X }
X if ((stemp=stkbase) == 0) goto nostack;
X while (*stemp!=0) stemp= (int *)*stemp;
X for (i=1;;i++) {
X stval= *(stemp+i);
X if (isstored(stval))
X {
X if (i==PSTKSIZ-2) {
X stkbase= (int *)*(stemp+PSTKSIZ-1);
X JFREE(stemp);
X stemp=stkbase;
X i=0;
X }
X lfree(*(stemp+ (++i)));
X } else if (stval== -1) {
X JFREE(stemp);
X break;
X } else {
X if (i==PSTKSIZ-2) {
X stkbase= (int *)*(stemp+PSTKSIZ-1);
X JFREE(stemp);
X stemp=stkbase;
X i=1;
X } else i++;
X }
X if (i==PSTKSIZ-2) {
X stkbase= (int *)*(stemp+PSTKSIZ-1);
X JFREE(stemp);
X stemp=stkbase;
X i=0;
X }
X }
X nostack:
X JFREE(pcell);
X }
Xnopcell:
X ftemp=fbr;
X stkbase=ftemp->stk;
X stkbi=ftemp->ind;
X newstk=ftemp->oldnewstk;
X atemp0=newloc; /* BH 6/20/82 maybe never did procprep */
X newloc=ftemp->oldnloc;
X pflag = fbr->oldpfg;
X atemp1=locptr;
X locptr=ftemp->loclist;
X argno=ftemp->argtord;
X pcell=ftemp->prevpcell;
X yychar=ftemp->oldyyc;
X yylval=ftemp->oldyyl;
X yyline=ftemp->oldline;
X getbpt=ftemp->oldbpt;
X currtest=ftemp->iftest;
X fbr=ftemp->prevframe;
X JFREE(ftemp);
X while (atemp1) {
X atemp2=atemp1->next;
X if (atemp1->name) lfree(atemp1->name);
X if (atemp1->val!=(struct object *)-1) /* BH 2/28/80 was NULL instead of -1 */
X lfree(atemp1->val);
X JFREE(atemp1);
X atemp1=atemp2;
X }
X while (atemp0) {
X atemp2=atemp0->next;
X if (atemp0->name) lfree(atemp0->name);
X if (atemp0->val!=(struct object *)-1)
X lfree(atemp0->val);
X JFREE(atemp0);
X atemp0=atemp2;
X }
X}
X
Xproccreate(nameob)
Xregister struct object *nameob;
X{
X register char *name;
X char temp[16];
X register FILDES edfd;
X int pid;
X
X#ifndef NOTURTLE
X if (turtdes<0) textscreen();
X#endif
X name = token(nameob->obstr);
X if (strlen(name)>NAMELEN) {
X pf1("Procedure name must be no more than %d letters.",NAMELEN);
X errhand();
X }
X cpystr(temp,name,EXTEN,NULL);
X if ((edfd=open(temp,READ,0))>=0) {
X close(edfd);
X nputs(name);
X puts(" is already defined.");
X errhand();
X }
X if ((edfd = creat(temp,0666)) < 0) {
X printf("Can't write %s.\n",name);
X errhand();
X }
X onintr(ehand3,edfd);
X mfree(nameob);
X write(edfd,titlebuf,strlen(titlebuf));
X addlines(edfd);
X onintr(errrec,1);
X}
X
Xhelp()
X{
X FILE *sbuf;
X
X sbuf=fopen(HELPFILE,"r");
X if (sbuf == NULL) {
X printf("? Help file missing, sorry.\n");
X return;
X }
X onintr(ehand2,sbuf);
X while(putch(getc(sbuf))!=EOF)
X ;
X fclose(sbuf);
X onintr(errrec,1);
X}
X
Xstruct object *describe(arg)
Xstruct object *arg;
X{
X register char *argstr;
X register struct lexstruct *lexp;
X FILE *sbuf;
X char fname[30];
X
X if (!stringp(arg)) ungood("Describe",arg);
X argstr = token(arg->obstr);
X for (lexp = keywords; lexp->word; lexp++)
X if (!strcmp(argstr,lexp->word) ||
X (lexp->abbr && !strcmp(argstr,lexp->abbr)))
X break;
X if (!lexp->word) {
X pf1("%p isn't a primitive.\n",arg);
X errhand();
X }
X if (strlen(lexp->word) > 9) /* kludge for Eunice */
X cpystr(fname,DOCLOGO,lexp->abbr,NULL);
X else
X cpystr(fname,DOCLOGO,lexp->word,NULL);
X if (!(sbuf=fopen(fname,"r"))) {
X printf("Sorry, I have no information about %s\n",lexp->word);
X errhand();
X } else {
X onintr(ehand2,sbuf);
X while (putch(getc(sbuf))!=EOF)
X ;
X fclose(sbuf);
X }
X onintr(errrec,1);
X mfree(arg);
X return ((struct object *)(-1));
X}
X
Xerrwhere()
X{
X register i =0;
X register struct object **astk;
X register struct plist *opc;
X
X cboff(); /* BH 12/13/81 */
X ibufptr=NULL;
X if (doprep) {
X procprep();
X frmpop(-1);
X }
X
X for (astk=allocstk;i<MAXALLOC;i++)
X if (astk[i]!=0)
X mfree(astk[i]);
X
X if (multarg) {
X lfree(multarg);
X multarg = 0;
X } /* BH 10/31/81 multarg isn't on astk, isn't mfreed. */
X
X#ifdef PAUSE
X if ((errpause||pauselev) && fbr && !topf) {
X /* I hope this pauses on error */
X if (!pflag && !getbpt) charib=0;
X dopause();
X }
X else
X#endif
X {
X opc = pcell;
X if (fbr && fbr->oldline==-1) {
X opc=fbr->prevpcell;
X }
X if (opc&&!topf)
X printf("You were at line %d in procedure %s\n",
X yyline,opc->procname->obstr);
X }
X}
X
Xerrzap() {
X while (thisrun)
X unrun();
X
X while (fbr)
X frmpop(-1);
X
X charib=0;
X if(traceflag)traceflag=1;
X topf=0;
X yyline=0;
X letflag=0;
X pflag=0;
X endflag=0;
X rendflag=0;
X argno= -1;
X newstk=NULL;
X newsti=0;
X stkbase=NULL;
X stkbi=0;
X fbr=NULL;
X locptr=NULL;
X newloc=NULL;
X proclist=NULL;
X pcell=NULL;
X#ifdef PAUSE
X pauselev = 0;
X#endif
X}
X
Xerrrec()
X{
X /* Here on SIGQUIT */
X#ifdef PAUSE
X if (catching)
X#endif
X errhand();
X#ifdef PAUSE
X flagquit++; /* We'll catch this later */
X#endif
X}
X
Xehand2(fle)
Xregister FILE *fle;
X{
X fclose(fle);
X errhand();
X}
X
Xehand3(fle)
Xregister FILDES fle;
X{
X close(fle);
X errhand();
X}
X
Xstruct object *tracefuns = 0;
X
Xltrace() { /* trace everything */
X lfree(tracefuns);
X tracefuns = (struct object *)0;
X traceflag = 1;
X}
X
Xluntrace() { /* trace nothing */
X lfree(tracefuns);
X tracefuns = (struct object *)0;
X traceflag = 0;
X}
X
Xstruct object *sometrace(funs)
Xstruct object *funs;
X{
X if (funs==0) {
X luntrace();
X } else if (!listp(funs)) {
X ungood("Trace",funs);
X } else {
X tracefuns = globcopy(funs);
X mfree(funs);
X traceflag = 1;
X }
X return ((struct object *)(-1));
X}
X
Xint chktrace(procname)
Xchar *procname;
X{
X struct object *rest;
X
X if (tracefuns == 0) return(1);
X for (rest=tracefuns; rest; rest=rest->obcdr) {
X if (!stringp(rest->obcar)) continue;
X if (!strcmp(token(rest->obcar->obstr),procname)) return(1);
X }
X return(0);
X}
X
Xintrace()
X{
X register struct alist *aptr;
X
X if (!pcell) return;
X if (!chktrace(pcell->procname->obstr)) return;
X indent(traceflag-1);
X nputs(pcell->procname->obstr);
X if (locptr && (locptr->val != (struct object *)-1)) {
X pf1(" of %l",locptr->val); /* BH locptr->val was inval */
X for (aptr=locptr->next;aptr;aptr=aptr->next) {
X if (aptr->val == (struct object *)-1) break;
X pf1(" and %l",aptr->val); /* was inval */
X }
X putchar('\n');
X }
X else puts(" called.");
X fflush(stdout);
X traceflag++;
X}
X
Xouttrace(retval)
Xregister struct object *retval;
X{
X if (!pcell) return;
X if (!chktrace(pcell->procname->obstr)) return;
X if (traceflag>1) traceflag--;
X indent(traceflag-1);
X nputs(pcell->procname->obstr);
X if (retval != (struct object *)-1) pf1(" outputs %l\n",retval);
X else puts(" stops.");
X fflush(stdout);
X}
X
Xindent(no)
Xregister int no;
X{
X while (no--)putchar(' ');
X}
X
END_OF_logoproc.c
if test 11517 -ne `wc -c <logoproc.c`; then
echo shar: \"logoproc.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f turtle.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"turtle.c\"
else
echo shar: Extracting \"turtle.c\" \(9873 characters\)
sed "s/^X//" >turtle.c <<'END_OF_turtle.c'
X
X#include "logo.h"
X
X#ifndef NOTURTLE
X
X#include <math.h>
X
Xextern char *getenv();
Xint turtdes; /* file descriptor for open turtle */
Xint color; /* pen color */
Xint pendown = 0; /* nonzero with pen down */
Xint penerase = 0; /* 0=pd, 1=pe, 2=px, pendown must be nonzero */
Xint shown = 1; /* nonzero if turtle is visible */
Xint textmode = 0; /* not turtle off */
XNUMBER yscrunch; /* scale factor for y */
Xstruct display *mydpy;
X
X#ifdef ATARI
X#include "atari.i"
X#endif
X
X#ifdef GIGI
X#include "gigi.i"
X#endif
X
X#ifdef ADM
X#include "admtek.i"
X#include "adm.i"
X#endif
X
X#ifdef TEK
X#ifndef ADM
X#include "admtek.i"
X#endif
X#include "tek.i"
X#endif
X
X#ifdef SUN
X#include "sun.i"
X#endif
X
XNUMBER ncheck(arg)
Xstruct object *arg;
X{
X NUMBER val;
X
X arg = numconv(arg,"Turtle command");
X arg = dubconv(arg);
X val = arg->obdub;
X mfree(arg);
X return(val);
X}
X
Xdpyinit() {
X char *ttytype;
X
X ttytype = getenv("TERM");
X#ifdef GIGI
X if (!strcmp(ttytype,"gigi"))
X mydpy = &gigi;
X else
X#endif
X#ifdef ATARI
X if (!strcmp(ttytype,"atari"))
X mydpy = &bwatari;
X else
X#endif
X#ifdef ADM
X if (!strncmp(ttytype,"adm",3))
X mydpy = &adm;
X else
X#endif
X#ifdef TEK
X if (!strncmp(ttytype,"tek",3))
X mydpy = &tek;
X else
X#endif
X#ifdef SUN
X if (1 || !strcmp(ttytype,"sun")) /* Sun is always a sun */
X mydpy = &sun;
X else
X#endif
X {
X printf("I don't recognize your terminal type!\n");
X errhand();
X }
X pendown = 1; penerase = 0; shown = 1;
X textmode = 0;
X mydpy->turtx = mydpy->turty = mydpy->turth = 0.0;
X printf(mydpy->init);
X if (!(mydpy->cleared)) {
X printf(mydpy->clear);
X (*mydpy->state)('c');
X mydpy->cleared++;
X yscrunch = mydpy->stdscrunch;
X }
X turtdes = -1;
X (*mydpy->infn)();
X (*mydpy->drawturt)(0);
X}
X
Xstruct object *getturtle(arg)
Xregister struct object *arg;
X{
X int lsflag[2]; /* BH 1/4/81 */
X register char *temp,*argc;
X char c[100];
X char astr[20];
X
X if (stringp(arg)) argc = arg->obstr;
X else argc = "";
X if (!strcmp(argc,"off")) {
X#ifdef FLOOR
X if (turtdes>0) {
X close (turtdes);
X printf("Please\007 unplug the turtle\007 and put it\007 away!\n");
X }
X#endif /* FLOOR */
X if (turtdes<0) {
X printf(mydpy->finish);
X (*mydpy->outfn)();
X }
X turtdes = 0;
X mfree(arg);
X return((struct object *)(-1));
X }
X if (!strcmp(argc,"dpy")||!strcmp(argc,"display")) {
X
X#ifdef FLOOR
X if (turtdes>0) {
X close (turtdes);
X printf("Please\007 unplug the turtle\007 and put it\007 away!\n");
X }
X#endif /* FLOOR */
X
X dpyinit();
X mfree(arg);
X return ((struct object *)(-1));
X }
X#ifdef FLOOR
X if (intp(arg)) {
X sprintf(astr,FIXFMT,arg->obint);
X argc = astr;
X }
X temp = c;
X cpystr(temp,"/dev/turtle",argc,NULL);
X if (turtdes>0) close(turtdes);
X if((turtdes = open(c,2)) < 0) {
X turtdes = 0;
X pf1("Turtle %l not available.\n",arg);
X } else printf("Please put the turtle away when you're done!\n");
X mfree(arg);
X return ((struct object *)(-1));
X#else
X ungood("Turtle",arg);
X#endif /* FLOOR */
X}
X
Xdpysxy(newx,newy)
XNUMBER newx,newy;
X{
X if ((newx < mydpy->xlow) || (newx > mydpy->xhigh) ||
X (newy < mydpy->ylow) || (newy > mydpy->yhigh)) {
X puts("Out of bounds!");
X errhand();
X }
X if (shown) (*mydpy->drawturt)(1);
X if (fabs(newx) < 0.01) newx = 0.0;
X if (fabs(newy) < 0.01) newy = 0.0;
X if (pendown)
X (*mydpy->drawfrom)(mydpy->turtx,yscrunch*mydpy->turty);
X mydpy->turtx = newx;
X mydpy->turty = newy;
X if (pendown)
X (*mydpy->drawto)(newx,yscrunch*newy);
X (*mydpy->state)('G');
X if (shown) (*mydpy->drawturt)(0);
X}
X
Xdpyforw(dist)
XNUMBER dist;
X{
X NUMBER newx,newy,deltax,deltay;
X
X tcheck();
X (*mydpy->txtchk)();
X deltax = dist * sin((mydpy->turth)*3.141592654/180.0);
X if (fabs(deltax) < 1.0e-5) deltax = 0.0;
X deltay = dist * cos((mydpy->turth)*3.141592654/180.0);
X if (fabs(deltay) < 1.0e-5) deltay = 0.0;
X newx = mydpy->turtx + deltax;
X newy = mydpy->turty + deltay;
X dpysxy(newx,newy);
X}
X
Xstruct object *forward(arg)
Xregister struct object *arg;
X{
X NUMBER dist;
X
X dist = ncheck(arg);
X#ifdef FLOOR
X if (turtdes > 0) {
X if (dist < 0.0)
X moveturtle('b',-6*(int)dist);
X else
X moveturtle('f',6*(int)dist);
X return ((struct object *)(-1));
X }
X#endif /* FLOOR */
X dpyforw(dist);
X return ((struct object *)(-1));
X}
X
Xstruct object *back(arg)
Xregister struct object *arg;
X{
X NUMBER dist;
X
X dist = ncheck(arg);
X#ifdef FLOOR
X if (turtdes > 0) {
X if (dist < 0.0)
X moveturtle('f',-6*(int)dist);
X else
X moveturtle('b',6*(int)dist);
X return ((struct object *)(-1));
X }
X#endif /* FLOOR */
X dpyforw(-dist);
X return ((struct object *)(-1));
X}
X
Xdpysh(angle)
XNUMBER angle;
X{
X (*mydpy->txtchk)();
X if (shown) (*mydpy->drawturt)(1);
X mydpy->turth = angle;
X while (mydpy->turth+11.0 < 0.0) mydpy->turth += 360.0;
X while (mydpy->turth+11.0 >= 360.0) mydpy->turth -= 360.0;
X if (shown) (*mydpy->drawturt)(0);
X (*mydpy->turnturt)();
X}
X
Xdpyturn(angle)
XNUMBER angle;
X{
X tcheck();
X dpysh(mydpy->turth + angle);
X}
X
Xstruct object *left(arg)
Xregister struct object *arg;
X{
X NUMBER dist;
X
X dist = ncheck(arg);
X#ifdef FLOOR
X if (turtdes > 0) {
X if (dist < 0.0)
X moveturtle('r',(-2*(int)dist)/5);
X else
X moveturtle('l',(2*(int)dist)/5);
X return ((struct object *)(-1));
X }
X#endif /* FLOOR */
X dpyturn(-dist);
X return ((struct object *)(-1));
X}
X
Xstruct object *right(arg)
Xregister struct object *arg;
X{
X NUMBER dist;
X
X dist = ncheck(arg);
X#ifdef FLOOR
X if (turtdes > 0) {
X if (dist < 0.0)
X moveturtle('l',(-2*(int)dist)/5);
X else
X moveturtle('r',(2*(int)dist)/5);
X return ((struct object *)(-1));
X }
X#endif /* FLOOR */
X dpyturn(dist);
X return ((struct object *)(-1));
X}
X
X#ifdef FLOOR
Xfcheck() {
X if (turtdes <= 0) {
X puts("You don't have a floor turtle!");
X errhand();
X }
X}
X
Xstruct object *hitoot(arg)
Xregister struct object *arg;
X{
X NUMBER dist;
X
X fcheck();
X dist = ncheck(arg);
X moveturtle('H',(15*(int)dist)/2);
X return ((struct object *)(-1));
X}
X
Xstruct object *lotoot(arg)
Xregister struct object *arg;
X{
X NUMBER dist;
X
X fcheck();
X dist = ncheck(arg);
X moveturtle('L',(15*(int)dist)/2);
X return ((struct object *)(-1));
X}
X
Xmoveturtle(where,arg)
Xregister int arg;
X{
X char buff[2];
X
X buff[0] = where;
X while (arg >= 0400) {
X buff[1] = 0377;
X write(turtdes,buff,2);
X arg -= 0377;
X }
X buff[1] = arg;
X write(turtdes,buff,2);
X}
X
Xlampon() {
X int i;
X
X fcheck();
X i = 'B';
X write(turtdes,&i,2);
X}
X
Xlampoff() {
X int i;
X
X fcheck();
X i = 'B'+0400;
X write(turtdes,&i,2);
X}
X
Xstruct object *touchsense(which)
X{
X char x;
X
X fcheck();
X read (turtdes,&x,1);
X if ( (0200>>which) & x) return (true());
X else return (false());
X}
X
Xstruct object *ftouch() {
X return(touchsense(0));
X}
X
Xstruct object *btouch() {
X return(touchsense(1));
X}
X
Xstruct object *ltouch() {
X return(touchsense(2));
X}
X
Xstruct object *rtouch() {
X return(touchsense(3));
X}
X#endif
X
Xint tcheck() {
X if (turtdes > 0) {
X puts("You don't have a display turtle!");
X errhand();
X }
X if (turtdes == 0) dpyinit(); /* free turtle "display */
X}
X
XNUMBER posangle(angle)
XNUMBER angle;
X{
X if (angle < 0.0) return(angle+360.0);
X return(angle);
X}
X
Xstruct object *pencolor(pen)
Xstruct object *pen;
X{
X NUMBER dpen;
X
X tcheck();
X (*mydpy->txtchk)();
X dpen = ncheck(pen);
X (*mydpy->penc)((int)dpen);
X color = dpen;
X return ((struct object *)(-1));
X}
X
Xint setcolor(pen,colorlist)
Xstruct object *pen,*colorlist;
X{
X NUMBER number;
X register int ipen;
X
X tcheck();
X (*mydpy->txtchk)();
X number = ncheck(pen);
X ipen = number;
X (*mydpy->setc)(ipen,colorlist);
X}
X
Xint setxy(strx,stry)
Xstruct object *strx,*stry;
X{
X NUMBER x,y;
X
X tcheck();
X (*mydpy->txtchk)();
X x = ncheck(strx);
X y = ncheck(stry);
X dpysxy(x,y);
X}
X
Xstruct object *setheading(arg)
Xstruct object *arg;
X{
X NUMBER heading;
X
X tcheck();
X (*mydpy->txtchk)();
X heading = ncheck(arg);
X dpysh(heading);
X return ((struct object *)(-1));
X}
X
Xstruct object *xcor()
X{
X tcheck();
X return(localize(objdub(mydpy->turtx)));
X}
X
Xstruct object *ycor()
X{
X tcheck();
X return(localize(objdub(mydpy->turty)));
X}
X
Xstruct object *heading()
X{
X tcheck();
X return(localize(objdub(posangle(mydpy->turth))));
X}
X
Xstruct object *getpen()
X{
X tcheck();
X return(localize(objint(color)));
X}
X
Xstruct object *setscrunch(new)
Xstruct object *new;
X{
X tcheck();
X yscrunch = ncheck(new);
X return ((struct object *)(-1));
X}
X
Xstruct object *scrunch() {
X tcheck();
X return(localize(objdub(yscrunch)));
X}
X
Xpenup() {
X#ifdef FLOOR
X int i;
X
X if (turtdes>0) {
X i = 'P'+0400;
X write(turtdes,&i,2);
X return;
X }
X#endif FLOOR
X tcheck();
X pendown = 0;
X (*mydpy->state)('U');
X}
X
Xcmpendown() {
X#ifdef FLOOR
X int i;
X
X if (turtdes>0) {
X i = 'P';
X write(turtdes,&i,2);
X return;
X }
X#endif FLOOR
X tcheck();
X pendown = 1;
X penerase = 0;
X (*mydpy->state)('D');
X}
X
Xcmpenerase() {
X tcheck();
X pendown = penerase = 1;
X (*mydpy->state)('E');
X}
X
Xpenreverse() {
X tcheck();
X pendown = 1;
X penerase = 2;
X (*mydpy->state)('R');
X}
X
Xclearscreen() {
X tcheck();
X (*mydpy->txtchk)();
X printf(mydpy->clear);
X mydpy->turtx = mydpy->turty = mydpy->turth = 0.0;
X (*mydpy->state)('c');
X if (shown) (*mydpy->drawturt)(0);
X}
X
Xwipeclean() {
X tcheck();
X (*mydpy->txtchk)();
X printf(mydpy->clear);
X (*mydpy->state)('w');
X if (shown) (*mydpy->drawturt)(0);
X}
X
Xfullscreen() {
X tcheck();
X (*mydpy->state)('f');
X textmode = 0;
X}
X
Xsplitscreen() {
X tcheck();
X (*mydpy->state)('s');
X textmode = 0;
X}
X
Xtextscreen() {
X tcheck();
X (*mydpy->state)('t');
X textmode++;
X}
X
Xshowturtle() {
X tcheck();
X (*mydpy->txtchk)();
X if (!shown) (*mydpy->drawturt)(0);
X shown = 1;
X (*mydpy->state)('S');
X}
X
Xhideturtle() {
X tcheck();
X (*mydpy->txtchk)();
X if (shown) (*mydpy->drawturt)(1);
X shown = 0;
X (*mydpy->state)('H');
X}
X
Xstruct object *penmode() {
X static char *pens[] = {"pendown","penerase","penreverse"};
X
X tcheck();
X if (pendown) return(localize(objcpstr(pens[penerase])));
X return(localize(objcpstr("penup")));
X}
X
Xstruct object *shownp() {
X tcheck();
X return(torf(shown));
X}
X
Xstruct object *towardsxy(x,y)
Xstruct object *x,*y;
X{
X NUMBER dx,dy;
X
X tcheck();
X dx = ncheck(x);
X dy = ncheck(y);
X return(localize(objdub(posangle((double)180.0*
X atan2(dx-(mydpy->turtx),dy-(mydpy->turty))/3.141592654))));
X}
X
X#endif
X
END_OF_turtle.c
if test 9873 -ne `wc -c <turtle.c`; then
echo shar: \"turtle.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 3 \(of 6\).
cp /dev/null ark3isdone
MISSING=""
for I in 1 2 3 4 5 6 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 6 archives.
echo "Now see the README"
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0