rs@uunet.UU.NET (Rich Salz) (06/24/87)
Submitted by: Brian Harvey <bh@mit-amt>
Mod.Sources: Volume 10, Number 22
Archive-Name: logo/Part02
#! /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 2 (of 6)."
# Contents: applediff logo.h logonum.c logoparse.c olddiff procedit.c
# procvars.c storage.c
# Wrapped by rsalz@pineapple.bbn.com on Wed Jun 24 14:26:54 1987
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f applediff -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"applediff\"
else
echo shar: Extracting \"applediff\" \(4650 characters\)
sed "s/^X//" >applediff <<'END_OF_applediff'
X
XA Guide to LSRHS Logo for people who know Apple Logo
X
XAlthough the two versions of Logo are very different internally, they
Xare fairly similar in the way you use them. This guide assumes that
Xyou know all about Apple Logo, and explains the differences. There are
Xenough differences that you can't just run your Apple Logo programs
Xunchanged, but what you know of Apple Logo will help you understand
XLSRHS Logo. Read this along with the LSRHS Logo Manual.
X
X1. Multi-instruction lines. If you put more than one Logo instruction on
Xa line, you may use a semicolon between instructions for better readability:
X print "foo; print "baz
X
X2. Comments can be used, starting with exclamation point:
X print "foo ! This is a comment
X
X3. There is no built-in procedure editor; your favorite text editor is run
Xin a separate process instead. There is no edns primitive.
X
X4. Differences in graphics: LSRHS doesn't have background, dot,
Xfence, pen, setbg, setpen, window, or wrap. Instead of pencolor and
Xsetpc, there are somewhat different primitives setcolor and pencolor. There
Xis also setxy, which is like setpos but takes two scalar inputs instead
Xof one vector. Similarly, towardsxy takes two scalar inputs. (Library
Xprocedures setpos and towards are provided.)
X
X5. Differences in words and lists: In addition to the Apple Logo primitives,
XLSRHS Logo has sentencep (true only if the input is a list of words, not a
Xlist of lists); is (like equalp, but true for numbers only if they are string
Xequal, so "is 3.0 3" outputs false); memberp and item for words as well as
Xlists.
X
X6. Differences in use of variables: LSRHS local takes only one input.
XThere is no name, only make.
X
X7. Differences in arithmetic operations: There is no rerandom. Quotient
Xand / are equivalent. Additional arithmetic operations are difference
X(prefix -), greaterp (prefix >), lessp (prefix <), maximum, minimum, zerop,
Xpow (two inputs, x to the y power).
X
X8. Differences in conditionals and flow of control: LSRHS Logo has trace
X(with no input, traces all procedures; can take a LIST of procedure names to
Xtrace only those) and untrace (no inputs, affects all procedures). Pausing
Xworks somewhat differently. Your Unix interrupt character pauses; your quit
Xcharacter stops all procedures. The equivalent of ERRACT is the procedure
Xerrpause. See the manual.
X
X9. Differences in reading and printing: There is no buttonp or paddle.
XIn order to use readchar and keyp, you must first use cbreak. (See the
XLSRHS Logo Manual.) Apple show is called fprint in LSRHS. There is also
Xftype for full type without newline.
X
X10. Differences in screen commands: LSRHS Logo cleartext clears the
Xentire screen. There is no 'cursor' operation. Setcursor is a library
Xprocedure using the primitive setcursorxy with two scalar inputs.
X
X11. Workspace management: There is no concept of a workspace in LSRHS
XLogo. Procedures are saved in individual files, and variables are not
Xsaved at all. Therefore, none of bury, erall, ern, erns, erps, package,
Xpkgall, poall, pons, pops, or unbury exist. The Apple Logo po is called
Xshow (note that Apple Logo uses show with a different meaning), but po
Xis accepted as an abbreviation. Erase exists, and pots exists with no input.
X
X12. Differences in files: None of catalog, disk, erasefile, load,
Xsave, and setdisk exist in LSRHS Logo. But there is a facility for
Xreading and writing arbitrary text files, using the primitives
Xopenread, openwrite, fileread, fileword, fileprint, filefprint, filetype,
Xfileftype, and close. See the LSRHS Logo Manual. Other file directory
Xmanipulation can be done using the unix command:
X unix [ls -la]
X
X13. Error handling: The primitives catch, throw, and error do not
Xexist in LSRHS Logo. The special name erract is not used.
XThere is a command toplevel which is equivalent to throw "toplevel.
X
X14. Procedure redefinition: None of copydef, define, definedp,
Xprimitivep, or text exist. The special name redefp is not used.
X
X15. Miscellany: There are no label, nodes, recycle, reparse, .bpt,
X.contents, .deposit, .examine, or .printer primitives. The go primitive
Xtakes a numeric input; a procedure line can start with a number which is
Xignored except to serve as a label for go. The LSRHS time primitive
Xoutputs the current date and time. The command goodbye is used to exit
Xfrom Logo. The command help prints a help message, and describe with
Xone input, the name of a primitive, prints a description of that
Xprimitive.
X
X16. Floor turtles: LSRHS has the primitives turtle, hitoot, lotoot,
Xlampon, lampoff, ftouch, btouch, ltouch, and rtouch applicable to
Xfloor turtles.
X
END_OF_applediff
if test 4650 -ne `wc -c <applediff`; then
echo shar: \"applediff\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logo.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"logo.h\"
else
echo shar: Extracting \"logo.h\" \(5336 characters\)
sed "s/^X//" >logo.h <<'END_OF_logo.h'
X
X/* Unix Logo, release 3 */
X
X/* Installation-dependent parameters */
X
X#define EDT "/u/bh/bin/jove" /* default editor for procedure editing */
X
X/* Turn on the graphics devices you have. */
X/* #define ATARI /* L-S and Atari */
X#define GIGI /* L-S */
X/* #define ADM /* COM */
X/* #define TEK /* COM */
X/* #define SUN /* Lucasfilm */
X/* #define FLOOR /* L-S */
X/* #define NOTURTLE /* turn on for no graphics at all */
X
X/* #define EUNICE /* turn on for inferior Eunice */
X
X/* #define SMALL /* turn on for non-split-I/D PDP-11. */
X
X/* #define EXTLOGO /* Turn on for .logo instead of .lg */
X
X#ifdef SMALL
X#define NAMELEN 11
X#else
X#define NAMELEN 100 /* max length of procedure name, must fit
X into xxxxxxx.lg filename format */
X /* Should be 11 for pre-4.2 Unix unless EXTLOGO is on,
X 9 for Eunice or EXTLOGO. */
X#endif SMALL
X
X/* Initial values for which signal pauses and which aborts */
X#define PAUSESIG SIGINT
X#define OTHERSIG SIGQUIT
X
X/* Following for 4.2BSD */
X#define RAND random
X#define SRAND srandom
X
X/* Following for non-4.2
X#define RAND rand
X#define SRAND srand
X */
X
X#ifdef SMALL
X#define MAXALLOC 30
X#define YYMAXDEPTH 150
X#else
X
X/* Memory allocation tuning. Adjust these numbers if you run out of space. */
X#define MAXALLOC 100
X/* Increase MAXALLOC for "I can't remember everything you have told me." */
X#define YYMAXDEPTH 2200
X/* Increase YYMAXDEPTH if you see "Too many levels of recursion." */
X/* Decrease something if you see "No more memory, sorry." */
X#endif
X
X#ifndef SMALL
X#define DEBUG /* enable debugging code */
X#define PAUSE /* enable pause feature */
X#define SETCURSOR /* enable termcap stuff */
X#endif
X
X#define LIBLOGO "/usr/lib/logo/"
X#define LIBNL "cat /usr/lib/logo/nl >> %s"
X#define HELPFILE "/usr/doc/logo/helpfile"
X#define DOCLOGO "/usr/doc/logo/"
X
X#ifdef EXTLOGO
X#define EXTEN ".logo"
X#define POTSCMD "/usr/lib/logo/logohead *.logo"
X#else
X#define EXTEN ".lg"
X#define POTSCMD "/usr/lib/logo/logohead *.lg"
X#endif
X
X/* --------- End of installation-dependent parameters --------- */
X
X#ifdef SMALL
X#define NUMBER float
X#define FIXNUM int
X#define EFMT "%e"
X#define FIXFMT "%d"
X#define IBUFSIZ 200
X#define PSTKSIZ 64
X#else
X#define NUMBER double
X#define FIXNUM long
X#define EFMT "%E"
X#define FIXFMT "%D"
X#define IBUFSIZ 1000
X#define PSTKSIZ 128
X#endif
X
X#ifdef DEBUG
X#define YYDEBUG
X#define JFREE jfree
X#else
X#define JFREE free
X#endif
X
X#define GLOBAL extern
X#define READ 0
X#define WRITE 1
X#define NULL 0
X#define FAST register
X#define FOREVER for(;;)
X#define FILDES int
X#define BUFSIZE 512
X#include <stdio.h>
X#undef getchar
X
Xstruct cons {
X struct object *car;
X struct object *cdr;
X};
X
Xstruct object {
X#ifdef SMALL
X char obtype;
X char refcnt;
X#else
X int obtype;
X int refcnt;
X#endif
X union {
X struct cons ob_cons;
X char *ob_str;
X FIXNUM ob_int;
X NUMBER ob_dub;
X } obob;
X};
X
X#define obcons obob.ob_cons
X#define obstr obob.ob_str
X#define obint obob.ob_int
X#define obdub obob.ob_dub
X#define obcar obob.ob_cons.car
X#define obcdr obob.ob_cons.cdr
X
X#define CONS 0
X#define STRING 1
X#define INT 2
X#define DUB 3
X
Xextern int memtrace;
X
X#define listp(x) (((x)==0) || (((x)->obtype)==CONS))
X#define stringp(x) ((x) && (((x)->obtype)==STRING))
X#define intp(x) ((x) && (((x)->obtype)==INT))
X#define dubp(x) ((x) && (((x)->obtype)==DUB))
X
Xextern char *ckmalloc();
Xextern struct object *localize(),*globcopy(),*globcons(),*loccons();
Xextern struct object *objstr(),*objcpstr(),*objint(),*objdub();
Xextern struct object *numconv(),*dubconv(),*true(),*false();
Xextern struct object *makelist(),*stringform(),*torf();
Xextern int errrec();
X
Xstruct stkframe
X{
X struct alist *loclist;
X char argtord;
X char iftest;
X int *stk;
X int ind;
X int *oldnewstk;
X struct alist *oldnloc;
X struct plist *prevpcell;
X int oldyyc;
X int oldyyl;
X char *oldbpt;
X struct stkframe *prevframe;
X#ifdef SMALL
X char oldline;
X char oldpfg;
X#else
X int oldline;
X int oldpfg;
X#endif
X};
X
Xstruct plist
X{
X struct plist *before;
X struct object *procname;
X int recdepth;
X struct object *ptitle;
X int *realbase;
X struct lincell *plines;
X struct plist *after;
X};
X
Xstruct lincell
X{
X int linenum;
X int *base;
X int index;
X struct lincell *nextline;
X};
X
Xstruct alist
X{
X struct object *name;
X struct object *val;
X struct alist *next;
X};
X
Xstruct lexstruct
X{
X char *word;
X int lexret;
X struct object *(*lexval)();
X char *abbr;
X};
X
Xstruct runblock
X{
X struct runblock *rprev;
X struct object *str;
X char *svbpt;
X int roldyyc;
X int roldyyl;
X int roldline;
X FIXNUM rcount;
X FIXNUM rupcount;
X int svpflag;
X int svletflag;
X char svch;
X};
X
Xstruct display {
X NUMBER turtx,turty,turth; /* current values */
X NUMBER xlow,xhigh,ylow,yhigh; /* limits for this dpy */
X NUMBER stdscrunch; /* standard aspect ratio */
X int cleared; /* nonzero after first use */
X char *init,*finish; /* printed to enable, disable gfx */
X char *totext; /* printed for temporary textscreen */
X char *clear; /* printed for cs, and after init */
X int (*drawturt)(); /* one arg, 0 to show, 1 to erase */
X int (*drawfrom)(), (*drawto)(); /* 2 args, x and y, draw vector */
X int (*txtchk)(); /* make error if can't gfx in txtmode */
X int (*infn)(), (*outfn)(); /* no args, called to enable, disable */
X int (*turnturt)(); /* no args, tell Atari turtle heading */
X int (*penc)(), (*setc)(); /* color map routines */
X int (*state)(); /* one arg, state change flag */
X};
X
Xextern int nullfn();
X
END_OF_logo.h
if test 5336 -ne `wc -c <logo.h`; then
echo shar: \"logo.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logonum.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"logonum.c\"
else
echo shar: Extracting \"logonum.c\" \(9811 characters\)
sed "s/^X//" >logonum.c <<'END_OF_logonum.c'
X
X/* Numeric operations in LOGO.
X * In arithmetic operations, the input, which is a character, is
X * converted to numeric, the operations are done, and the result is
X * converted back to character.
X * In all cases, the inputs are freed, and a new output is created.
X *
X * Copyright (C) 1979, The Children's Museum, Boston, Mass.
X * Written by Douglas B. Klunder.
X */
X
X#include <math.h>
X#include "logo.h"
X
Xnump(x) /* non-LOGO numberp, just for strings */
Xregister struct object *x;
X{ /* a number is a series of at least one digit, with an optional
X * starting + or -. */
X register char ch,*cp;
X
X cp = x->obstr;
X if (*cp=='\0') return(0);
X if (*cp!='-' && *cp!='+' && (*cp<'0' || *cp>'9') && *cp!='.') return(0);
X if ((*cp=='-' || *cp=='+' || *cp=='.') && *(cp+1)=='\0') return(0);
X if(*cp=='.' && index(cp+1,'.')) return(0);
X cp++;
X while ((ch = *cp)!='\0') {
X if ((ch<'0'||ch>'9')&&(ch!='e')&&(ch!='E')&&(ch!='.'))
X return(0);
X if ((ch == 'e') || (ch == 'E')) {
X if (index(cp+1,'e') || index(cp+1,'E')
X || index(cp+1,'.')) return(0);
X if (((ch = *(cp+1))=='+') || (ch=='-')) cp++;
X }
X else if (ch == '.') {
X if (index(cp+1,'e') || index(cp+1,'E')
X || index(cp+1,'.')) return(0);
X }
X cp++;
X }
X return(1);
X}
X
X/* Check a STRING object to see if it's an integer string */
Xisint(x)
Xregister struct object *x;
X{
X register char ch,*cp;
X
X cp = x->obstr;
X while (ch = *cp++)
X if ((ch == '.') || (ch == 'e') || (ch == 'E'))
X return(0);
X return(1);
X}
X
X/* convert object (which might be a word of digits) to a number */
Xstruct object *numconv(thing,op)
Xregister struct object *thing;
Xchar *op;
X{
X register struct object *newthing;
X FIXNUM ithing;
X NUMBER dthing;
X
X if (thing == 0) ungood(op,thing);
X switch (thing->obtype) {
X case CONS:
X ungood(op,thing);
X case INT:
X case DUB:
X return(thing);
X default:
X if (!nump(thing)) ungood(op,thing);
X if (isint(thing)) {
X sscanf(thing->obstr,FIXFMT,&ithing);
X newthing = localize(objint(ithing));
X } else {
X sscanf(thing->obstr,EFMT,&dthing);
X newthing = localize(objdub(dthing));
X }
X }
X mfree(thing);
X return(newthing);
X}
X
X/* convert integer to double */
Xstruct object *dubconv(num)
Xregister struct object *num;
X{
X NUMBER d;
X
X if (dubp(num)) return(num);
X d = num->obint;
X mfree(num);
X return(localize(objdub(d)));
X}
X
Xstruct object *opp(x) /* Unary - */
Xregister struct object *x;
X{
X register struct object *ans;
X
X x = numconv(x,"Minus");
X if (intp(x)) {
X ans = objint(-(x->obint));
X } else {
X ans = objdub(-(x->obdub));
X }
X mfree(x);
X return(localize(ans));
X}
X
Xstruct object *add(x,y) /* sum */
Xregister struct object *x,*y;
X{
X FIXNUM iz;
X NUMBER dz;
X register struct object *z;
X
X x = numconv(x,"Sum");
X y = numconv(y,"Sum");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X iz = (x->obint)+(y->obint);
X z = objint(iz);
X } else {
X dz = (x->obdub)+(y->obdub);
X z = objdub(dz);
X }
X mfree(x);
X mfree(y);
X return(localize(z));
X}
X
Xstruct object *sub(x,y) /* difference */
Xregister struct object *x,*y;
X{
X FIXNUM iz;
X NUMBER dz;
X register struct object *z;
X
X x = numconv(x,"Difference");
X y = numconv(y,"Difference");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X iz = (x->obint)-(y->obint);
X z = objint(iz);
X } else {
X dz = (x->obdub)-(y->obdub);
X z = objdub(dz);
X }
X mfree(x);
X mfree(y);
X return(localize(z));
X}
X
Xstruct object *mult(x,y) /* product */
Xregister struct object *x,*y;
X{
X FIXNUM iz;
X NUMBER dz;
X register struct object *z;
X
X x = numconv(x,"Product");
X y = numconv(y,"Product");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X iz = (x->obint)*(y->obint);
X z = objint(iz);
X } else {
X dz = (x->obdub)*(y->obdub);
X z = objdub(dz);
X }
X mfree(x);
X mfree(y);
X return(localize(z));
X}
X
Xdivzero(name)
Xchar *name;
X{
X pf1("%s can't divide by zero.\n",name);
X errhand();
X}
X
Xstruct object *div(x,y) /* quotient */
Xregister struct object *x,*y;
X{
X NUMBER dz;
X
X x = numconv(x,"Quotient");
X y = numconv(y,"Quotient");
X x = dubconv(x);
X y = dubconv(y);
X if (y->obdub == 0.0) divzero("Quotient");
X dz = (x->obdub)/(y->obdub);
X mfree(x);
X mfree(y);
X if (dz == (NUMBER)(FIXNUM)dz) {
X return(localize(objint((FIXNUM)dz)));
X } else {
X return(localize(objdub(dz)));
X }
X}
X
Xstruct object *rem(x,y) /* remainder */
Xregister struct object *x,*y;
X{
X FIXNUM iz;
X register struct object *z;
X
X x = numconv(x,"Remainder");
X y = numconv(y,"Remainder");
X if (!intp(x)) ungood("Remainder",x);
X if (!intp(y)) ungood("Remainder",y);
X if (y->obint == 0) divzero("Remainder");
X iz = (x->obint)%(y->obint);
X z = objint(iz);
X mfree(x);
X mfree(y);
X return(localize(z));
X}
X
Xstruct object *torf(pred)
Xint pred;
X{
X if (pred) return(true());
X return(false());
X}
X
Xstruct object *greatp(x,y) /* greaterp */
Xregister struct object *x,*y;
X{
X int iz;
X
X x = numconv(x,"Greaterp");
X y = numconv(y,"Greaterp");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X iz = ((x->obint)>(y->obint));
X } else {
X iz = ((x->obdub)>(y->obdub));
X }
X mfree(x);
X mfree(y);
X return torf(iz);
X}
X
Xstruct object *lessp(x,y) /* lessp */
Xregister struct object *x,*y;
X{
X int iz;
X
X x = numconv(x,"Lessp");
X y = numconv(y,"Lessp");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X iz = ((x->obint)<(y->obint));
X } else {
X iz = ((x->obdub)<(y->obdub));
X }
X mfree(x);
X mfree(y);
X return torf(iz);
X}
X
Xstruct object *lmax(x,y) /* maximum */
Xregister struct object *x,*y;
X{
X x = numconv(x,"Maximum");
X y = numconv(y,"Maximum");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X if ((x->obint) > (y->obint)) {
X mfree(y);
X return(x);
X } else {
X mfree(x);
X return(y);
X }
X } else {
X if ((x->obdub) > (y->obdub)) {
X mfree(y);
X return(x);
X } else {
X mfree(x);
X return(y);
X }
X }
X}
X
Xstruct object *lmin(x,y) /* minimum */
Xregister struct object *x,*y;
X{
X x = numconv(x,"Minimum");
X y = numconv(y,"Minimum");
X if (!intp(x) || !intp(y)) {
X x = dubconv(x);
X y = dubconv(y);
X }
X if (intp(x)) {
X if ((x->obint) < (y->obint)) {
X mfree(y);
X return(x);
X } else {
X mfree(x);
X return(y);
X }
X } else {
X if ((x->obdub) < (y->obdub)) {
X mfree(y);
X return(x);
X } else {
X mfree(x);
X return(y);
X }
X }
X}
X
Xstruct object *lnump(x) /* LOGO numberp */
Xregister struct object *x;
X{
X if (x == 0) return(false());
X switch (x->obtype) {
X case CONS:
X mfree(x);
X return(false());
X case INT:
X case DUB:
X mfree(x);
X return(true());
X default: /* case STRING */
X if (nump(x)) {
X mfree(x);
X return(true());
X } else {
X mfree(x);
X return(false());
X }
X }
X}
X
Xstruct object *lrandd() /* random */
X{
X register struct object *val;
X register temp;
X
X temp=(RAND()/100)%10;
X val = objint((FIXNUM)temp);
X return(localize(val));
X}
X
Xstruct object *rnd(arg)
Xregister struct object *arg;
X{
X register temp;
X
X arg = numconv(arg,"Rnd");
X if(!intp(arg)) ungood("Rnd",arg);
X if ((arg->obint) <= 0) ungood("Rnd",arg);
X temp=RAND() % (int)(arg->obint);
X mfree(arg);
X return(localize(objint((FIXNUM)temp)));
X}
X
Xstruct object *sq(arg)
Xregister struct object *arg;
X{
X NUMBER temp;
X
X arg = numconv(arg,"Sqrt");
X arg = dubconv(arg);
X temp = sqrt(arg->obdub);
X mfree(arg);
X return(localize(objdub(temp)));
X}
X
Xstruct object *lsin(arg)
Xregister struct object *arg;
X{
X NUMBER temp;
X
X arg = numconv(arg,"Sin");
X arg = dubconv(arg);
X temp = sin((3.1415926/180.0)*(arg->obdub));
X mfree(arg);
X return(localize(objdub(temp)));
X}
X
Xstruct object *lcos(arg)
Xregister struct object *arg;
X{
X NUMBER temp;
X
X arg = numconv(arg,"Cos");
X arg = dubconv(arg);
X temp = cos((3.1415926/180.0)*(arg->obdub));
X mfree(arg);
X return(localize(objdub(temp)));
X}
X
Xstruct object *lpow(x,y)
Xregister struct object *x,*y;
X{
X FIXNUM iz;
X NUMBER dz;
X register struct object *z;
X
X x = numconv(x,"Pow");
X y = numconv(y,"Pow");
X x = dubconv(x);
X y = dubconv(y);
X dz = pow((x->obdub),(y->obdub));
X iz = dz; /* convert to integer for integerness test */
X if (dz == (NUMBER)iz)
X z = objint(iz);
X else
X z = objdub(dz);
X mfree(x);
X mfree(y);
X return(localize(z));
X}
X
Xstruct object *latan(arg)
Xregister struct object *arg;
X{
X NUMBER temp;
X
X arg = numconv(arg,"Atan");
X arg = dubconv(arg);
X temp = (180.0/3.1415926)*atan(arg->obdub);
X mfree(arg);
X return(localize(objdub(temp)));
X}
X
Xstruct object *zerop(x) /* zerop */
Xregister struct object *x;
X{
X register int iz;
X
X x = numconv(x,"Zerop");
X if (intp(x))
X iz = ((x->obint)==0);
X else
X iz = ((x->obdub)==0.0);
X mfree(x);
X return(torf(iz));
X}
X
Xstruct object *intpart(arg)
Xregister struct object *arg;
X{
X register FIXNUM result;
X
X arg = numconv(arg,"Int");
X if (intp(arg)) return(arg);
X result = arg->obdub;
X mfree(arg);
X return(localize(objint(result)));
X}
X
Xstruct object *round(arg)
Xregister struct object *arg;
X{
X register FIXNUM result;
X
X arg = numconv(arg,"Round");
X if (intp(arg)) return(arg);
X if (arg->obdub >= 0.0)
X result = arg->obdub + 0.5;
X else
X result = arg->obdub - 0.5;
X mfree(arg);
X return(localize(objint(result)));
X}
X
Xstruct object *toascii(arg)
Xregister struct object *arg;
X{
X register char *cp;
X char str[50];
X
X if (arg==0) ungood("Ascii",arg);
X switch(arg->obtype) {
X case CONS:
X ungood("Ascii",arg);
X case STRING:
X cp = arg->obstr;
X break;
X case INT:
X sprintf(str,FIXFMT,arg->obint);
X cp = str;
X break;
X case DUB:
X sprintf(str,"%g",arg->obdub);
X cp = str;
X break;
X }
X if (strlen(cp) != 1) ungood("Ascii",arg);
X mfree(arg);
X return(localize(objint((FIXNUM)((*cp)&0377))));
X}
X
Xstruct object *tochar(arg)
Xregister struct object *arg;
X{
X register int ichar;
X char str[2];
X
X arg = numconv(arg,"Char");
X if (intp(arg)) ichar = arg->obint;
X else ichar = arg->obdub;
X if ((ichar < 0) || (ichar > 255)) ungood("Char",arg);
X mfree(arg);
X str[0] = ichar;
X str[1] = '\0';
X return(localize(objcpstr(str)));
X}
X
END_OF_logonum.c
if test 9811 -ne `wc -c <logonum.c`; then
echo shar: \"logonum.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f logoparse.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"logoparse.c\"
else
echo shar: Extracting \"logoparse.c\" \(4959 characters\)
sed "s/^X//" >logoparse.c <<'END_OF_logoparse.c'
X
X#include "logo.h"
Xextern int multnum,endflag,rendflag,topf;
Xextern char ibuf[];
Xextern char *ibufptr, *getbpt, charib;
Xextern int letflag,pflag;
X#ifdef PAUSE
Xextern int pauselev;
X#endif
Xextern FILE *pbuf;
Xextern struct lexstruct keywords[];
Xextern struct alist *locptr;
Xextern struct runblock *thisrun;
X
Xstruct object *makeword(c)
Xint c;
X{
X register struct object* obj;
X register char *s;
X char str[100];
X
X s=str;
X do {
X if (c == '\\') c = getchar()|0200;
X else if (c == '%') c = ' '|0200;
X *s++ = c;
X } while((c=getchar())>0 && !index(" \t\n[]",c));
X if (c<=0) {
X printf("Unmatched [ in procedure.\n");
X errhand();
X }
X charib = c;
X *s = '\0';
X obj = objcpstr(str);
X if (nump(obj)) {
X obj = numconv(localize(obj),"!makeword");
X mfree(globcopy(obj)); /* unlocalize */
X return(obj);
X }
X return(globcopy(obj));
X}
X
Xstruct object *makel1()
X{
X register struct object *head,*tail;
X register c,cnt;
X
X while ((c=getchar())==' ' || c=='\t' || c=='\n') ;
X if(c==']') {
X charib = c;
X return ((struct object *)0);
X }
X if (c<=0) {
X printf("Unmatched [ in procedure.\n");
X errhand();
X }
X head = (struct object*)ckmalloc(sizeof(struct object));
X tail = head;
X cnt = 0;
X head->obtype = CONS;
X head->refcnt = 0;
X head->obcdr = 0;
Xloop:
X if (c=='[') {
X tail->obcar = globcopy(makel1());
X getchar(); /* gobble the peeked close bracket */
X } else {
X tail->obcar = makeword(c);
X /* This used to use charib instead of passing the char as
X * an argument, but that loses if the first char of a word
X * is backslash, in which case something is already in
X * charib from getchr1. */
X }
X while ((c=getchar())==' ' || c=='\t' || c=='\n') ;
X if (c==']') {
X charib = c;
X return (head);
X }
X if (c<=0) {
X printf("Unmatched [ in procedure.\n");
X errhand();
X }
X
X tail->obcdr = (struct object*)ckmalloc(sizeof(struct object));
X tail = tail->obcdr;
X tail->obtype = CONS;
X tail->refcnt = 1;
X tail->obcdr = 0;
X
X goto loop;
X}
X
Xstruct object *makelist()
X{
X return(localize(makel1()));
X}
X
X#ifdef DEBUG
Xgetchr1()
X#else
Xgetchar()
X#endif
X{
X FAST c;
X
X if (charib) {
X c=charib;
X charib=0;
X return(c);
X }
X else if (pflag==1) {
X while ((c=getc(pbuf))=='\r')
X ;
X if (c=='\\' && letflag!=1) { /* continuation line feature */
X c=getc(pbuf);
X if (c=='\n') c=getc(pbuf);
X else {
X charib = c;
X c = '\\';
X }
X }
X if (!letflag && c>='A' && c<='Z') c+= 32;
X return(c);
X }
X else if (getbpt) { /* BH 5/19/81 moved down below pflag test */
X c = *getbpt++;
X if (c) return (c);
X if (!thisrun) {
X getbpt = 0;
X return('\n');
X } /* startup file feature */
X --getbpt;
X if (--(thisrun->rcount) <= 0) {
X if (!rendflag) rendflag = 1; /* BH 3/17/83 */
X return(0);
X } else {
X rerun();
X return('\n');
X }
X }
X else if (ibufptr==NULL) {
X rebuff:
X if ((c=read(0,ibuf,IBUFSIZ))==IBUFSIZ)
X if (ibuf[IBUFSIZ-1]!='\n') {
X while (read(0,ibuf,IBUFSIZ)==IBUFSIZ)
X if (ibuf[IBUFSIZ-1]=='\n') break;
X puts("Your line is too long.");
X errhand();
X }
X if (c<0) {
X /* Error return from read. Probably signal. */
X return ('\n');
X }
X if (c==0) {
X /* Not clear what's right for EOF. I'd just ignore it
X only what if stdin is a file, we'll loop forever.
X Compromise: if we're paused, don't lose the valuable
X context with a keystroke, otherwise, exit. */
X#ifdef PAUSE
X if (pauselev) return('\n');
X#endif
X leave(3);
X }
X ibufptr=ibuf;
X }
X c= *ibufptr++;
X if (c=='\\' && letflag!=1) { /* continuation line feature */
X c = *ibufptr++;
X if (c=='\n') {
X ibufptr=NULL;
X goto rebuff; /* sorry, Jay */
X } else {
X charib = c;
X c = '\\';
X }
X }
X if (!letflag && c>='A' && c<='Z') c+=32;
X if (c=='\n') ibufptr=NULL;
X return(c);
X}
X
X#ifdef DEBUG
Xgetchar()
X{ /* BH 3/23/80 debugging echo output */
X register c;
X
X c = getchr1();
X if (memtrace) putchar(c);
X return(c);
X}
X#endif
X
Xstruct object *multiop(op,args)
Xregister op;
Xregister struct object *args;
X{
X extern struct object *list();
X
X if (keywords[op].lexval==list) return (localize(args));
X else if (multnum<2) {
X nputs(keywords[op].word);
X puts(" needs at least two inputs.");
X errhand();
X } else if (multnum==2)
X return ((*keywords[op].lexval)(localize(args->obcar),
X localize(args->obcdr->obcar)));
X else {
X multnum--;
X return ((*keywords[op].lexval)(localize(args->obcar),
X multiop(op,args->obcdr)));
X }
X}
X
Xstruct object *pots()
X{
X register f;
X
X if (f=fork()) while (wait(0)!=f) ;
X else {
X execl ("/bin/sh","sh","-c",POTSCMD,0);
X exit();
X }
X return((struct object *)-1);
X}
X
Xlbreak() {
X#ifdef PAUSE
X if (!pflag && thisrun && thisrun->str==(struct object *)(-1))
X unpause();
X#endif
X if (!pflag && thisrun) {
X rendflag = 1; /* BH 3/17/83 */
X if (thisrun->rprev && !(thisrun->svpflag)) rendflag++;
X }
X}
X
Xlstop() {
X endflag = 1;
X#ifdef PAUSE
X if (!pflag && thisrun && thisrun->str==(struct object *)(-1))
X unpause();
X#endif
X if (!pflag && thisrun) rendflag = 3; /* BH 3/17/83 */
X}
X
Xltopl() {
X topf=1;
X errwhere();
X errzap();
X leave(1);
X}
X
Xlbyecom() {
X leave(3);
X}
X
END_OF_logoparse.c
if test 4959 -ne `wc -c <logoparse.c`; then
echo shar: \"logoparse.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f olddiff -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"olddiff\"
else
echo shar: Extracting \"olddiff\" \(6638 characters\)
sed "s/^X//" >olddiff <<'END_OF_olddiff'
X
XA Guide to LSRHS Logo Release 3, for people who knew Release 1
X
XLSRHS Logo has been changed to be much faster and more robust. It also
Xis different in its user interface from the previous version, so that it
Xmore closely resembles Apple Logo. Here are the most important changes:
X
X1. The line number editor no longer exists. There are two ways to define
Xa procedure. The "to" command lets you type in the procedure, somewhat as
Xbefore, but without line numbers and with no correction facility. The
X"edit" command runs edt so you can use the power of display editing. You
Xcan use "edit" even if the procedure did not previously exist.
X
X2. Most Logo procedures evaluate their inputs: if you want to use a
Xparticular word as an input you must quote it. In old LSRHS Logo there
Xwere several exceptions: edit, erase, show, and describe all took as inputs
Xan unquoted name of a procedure. These procedures are no longer exceptional.
XYou must say
X edit "foo
Xto edit the procedure foo, for example. You can also give edit, erase, or
Xshow a list of procedures as inputs, which will apply them to all of the
Xprocedures you name at once. It is particularly convenient sometimes to be
Xable to edit two procedures at the same time.
X
XNote: The "to" command is still exceptional in that it doesn't evaluate
Xits inputs.
X
X3. The "edit" command with no input at all will re-edit whatever you edited
Xlast time. It remembers the buffer file as long as you stay in Logo.
X
X4. If you are editing with "edit" and change your mind, so you don't want to
Xredefine any procedures, leave edt with ESC ^Z instead of just ^Z. This will
Xtell Logo not to change the procedure definitions. (This is only true at
XLSRHS, or wherever the text editor cooperates by setting a nonzero exit
Xstatus.)
X
X5. You can put comments on a Logo instruction line by starting the comment
Xwith an exclamation point:
X print "foo ! This is a comment.
XThe exclamation point must not be part of a word or list, which is why there
Xis a space before it in the example.
X
X6. The "if" command syntax is completely different. It, too, used to be an
Xexception to the rule about quoting inputs. It now takes either two or three
Xinputs. The first is a predicate, as before. The second and third are lists
Xof instructions, as in the repeat command:
X if 2=3 [print "yes] [print "no]
XThe second input is executed if the predicat is true, the (optional) third
Xif it's false. If the things in the second and third inputs are expressions
Xrather than complete instructions, "if" can be used as an operation:
X print if 2=3 ["yes] ["no]
XThe third input is required in that case.
X
XThe difference in "if" is likely to be the biggest headache to people used to
Xthe old way. Your Logo procedures must be changed like this:
X old: if :num=0 stop
X new: if :num=0 [stop]
X
X7. Many abbreviations are removed or changed:
X sentence s -> se
X print p -> pr
X goodbye g -> bye
X
X gone completely: ei, gp, lp, rq, pro, q, w, eq, ep, np, wp,
X c, th, na, lo, m, sp, zp, ti, d, t, ut.
X
X8. Some synonyms are added to be like Apple Logo:
X full fullscreen
X split splitscreen
X text textscreen
X atan arctan
X either or
X both and
XThe old names still work also.
X
X9. The procedures repeat, nth (synonym item), and memberp, which were
Xlibrary procedures written in Logo before, are now primitives, so they're
Xfaster. NOTE: The order of the inputs to repeat has been reversed:
X repeat 4 [fd 40; rt 90]
X
X10. Lots of bugs have been fixed. In particular, several limitations on
Xrepeat (and run) have been removed: You can have a repeat within a repeat,
Xmultiple instructions within a repeat, etc.
X
XNew in Release 3 (compared to Release 2):
X
X11. There is now a pause facility, which allows you to enter interactive
Xcommands in the context of a running procedure, to examine or modify local
Xvariables. This happens, among other things, when you type the system
Xinterrupt character (^C at LSRHS). Typing the quit character (^G at LSRHS)
Xdoes what it always did, namely stop all procedures.
X
X12. Turtle commands like forward do an automatic turtle "display if
Xyou don't already have a turtle.
X
X13. New primitives:
X
X(Already in release 2):
X
Xreadlist (abbrev rl)--
X Like request but doesn't print a "?" prompt.
X
Xint--
X Takes one numeric input, gives integer part (truncates).
X
Xround--
X Takes one numeric input, gives nearest integer (rounds).
X
Xascii--
X Takes a single-character word, gives the numeric code for that char.
X
Xchar--
X Takes a number, gives the corresponding character.
X
Xoflush--
X Command, no inputs. Use this to make stuff you've printed actually
X get printed right away. Normally, what you print is buffered until
X you have to type in something.
X
Xpprop, gprop, remprop, plist, pps--
X Property lists. Named properties can be associated with a word.
X Examples:
X
X pprop "bh "firstname "Brian
X pprop "bh "lastname "Harvey
X print gprop "bh "firstname
X -> Brian
X fprint plist "bh
X -> [firstname Brian lastname Harvey]
X pps
X -> bh's firstname is Brian
X bh's lastname is Harvey
X remprop "bh "lastname
X
Xtest, iftrue (abbrev ift), iffalse (abbrev iff)--
X An alternate form of "if":
X
X test 2=3
X iftrue [print "foo]
X iffalse [print "baz]
X
X These are most useful if you have several instructions all conditional
X on the same test. You can use any number of iftrue and iffalse
X commands, in any order. The result of "test" is remembered locally
X for each procedure.
X
XNew in Release 3 (compared to Release 2):
X
Xsetscrunch, scrunch--
X Set and get the aspect ratio, a number by which the vertical
X component of turtle motion is multiplied. Make squares really square.
X
Xwipeclean (clean)--
X Like clearscreen, but don't move the turtle.
X
Xpenreverse (px)--
X A pen mode in which each dot in the turtle's path is turned on if
X it was ff and vice versa.
X
Xpenmode--
X Outputs one of the words penup, pendown, penerase, or penreverse.
X
Xshownp--
X Outputs true if the turtle is visible.
X
Xtowardsxy--
X Outputs the heading to which to turn the turtle in order for it
X to face the point specified by the two inputs.
X
Xrepcount--
X Outputs how many times through the repeat we've done. Try
X repeat 10 [print repcount]
X repeat 50 [fd 20+2*repcount; rt 90]
X
Xpause--
X In a procedure, pause. Accept commands from the terminal, but with
X local variables available.
X
Xcontinue (co)--
X Continue the procedure from which Logo paused.
X
Xerrpause--
X From now on, pause instead of stopping if an error happens inside
X a procedure.
X
Xerrquit--
X From now on, quit on errors.
X
Xsetipause--
X From now on, interrupt (^C) pauses and quit (^G) stops.
X
Xsetqpause--
X From now on, quit (^G) pauses and interrupt (^C) stops.
X
END_OF_olddiff
if test 6638 -ne `wc -c <olddiff`; then
echo shar: \"olddiff\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f procedit.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"procedit.c\"
else
echo shar: Extracting \"procedit.c\" \(6263 characters\)
sed "s/^X//" >procedit.c <<'END_OF_procedit.c'
X
X#include "logo.h"
X#include <signal.h>
X
Xextern int nullfn();
Xextern int errrec();
Xextern int ehand2(),ehand3();
Xextern char *token();
Xextern char *getenv();
Xextern char titlebuf[],editfile[];
Xextern int letflag;
X#ifndef NOTURTLE
Xextern int turtdes,textmode;
Xextern struct display *mydpy;
X#endif
X
Xchkproc(str,prim,obj)
Xregister char *str;
Xchar *prim;
Xstruct object *obj;
X{
X register char ch;
X
X if (((ch = *str)<'a') || (ch>'z')) ungood(prim,obj);
X if (memb('/',str)) ungood(prim,obj);
X if (strlen(str)>NAMELEN) ungood(prim,obj);
X}
X
Xstedit(ednobj,flag)
Xstruct object *ednobj;
Xint flag;
X{
X register char *edname;
X register struct object *rest;
X char fnam[40];
X char edline[100];
X FILDES edfd;
X
X if (ednobj==0) ungood("Edit",ednobj);
X if (flag==0) unlink(editfile);
X switch (ednobj->obtype) {
X case INT:
X case DUB:
X ungood("Edit",ednobj);
X case CONS:
X for (rest=ednobj; rest; rest=rest->obcdr)
X stedit(localize(rest->obcar),1);
X break;
X default: /* STRING */
X edname = token(ednobj->obstr);
X chkproc(edname,"Edit",ednobj);
X cpystr(fnam,edname,EXTEN,NULL);
X if ((edfd=open(fnam,READ,0))<0) {
X cpystr(fnam,LIBLOGO,edname,EXTEN,NULL);
X if ((edfd=open(fnam,READ,0)) < 0) {
X cpystr(fnam,edname,EXTEN,NULL);
X edfd = creat(fnam,0666);
X if (edfd < 0) {
X printf("Can't write %s.\n",edname);
X mfree(ednobj);
X errhand();
X }
X onintr(ehand3,edfd);
X write(edfd,"to ",3);
X write(edfd,edname,strlen(edname));
X write(edfd,"\n\nend\n",6);
X }
X }
X close(edfd);
X onintr(errrec,1);
X sprintf(edline,"cat %s >> %s",fnam,editfile);
X system(edline);
X sprintf(edline,LIBNL,editfile);
X system(edline);
X }
X mfree(ednobj);
X if (flag==0) doedit();
X}
X
Xdoedit() {
X register char ch,*cp;
X FILE *fd,*ofd;
X int pid,status;
X char *name,*envedit;
X char fname[30];
X char line[200];
X static char binname[25] = "";
X static char usrbinname[30];
X static char editname[20];
X static char *editor;
X
X if (binname[0] == '\0') {
X editor = getenv("EDITOR");
X envedit = editor ? editor : EDT; /* default editor */
X strcpy(binname,"/bin/");
X strcat(binname,envedit);
X strcpy(usrbinname,"/usr/bin/");
X strcat(usrbinname,envedit);
X strcpy(editname,envedit);
X }
X
X#ifndef NOTURTLE
X if (turtdes<0) {
X (*mydpy->state)('t');
X textmode++;
X }
X#endif
X fflush(stdout);
X signal(SIGINT,SIG_IGN);
X signal(SIGQUIT,SIG_IGN);
X switch (pid=fork()) {
X case -1:
X printf("Can't fork to editor.\n");
X errhand();
X case 0:
X /*if (editor) */ execl(editname,editname,editfile,0);
X /* Only try bare name if really user-specified. */
X execl(binname,editname,editfile,0);
X execl(usrbinname,editname,editfile,0);
X printf("Can't find editor.\n");
X exit(2);
X default:
X while (wait(&status) != pid) ;
X }
X if (status&0177400) {
X printf("Redefinition aborted.\n");
X errhand();
X }
X if ((fd=fopen(editfile,"r"))==NULL) {
X printf("Can't reread edits!\n");
X errhand();
X }
X onintr(ehand2,fd);
X while (fgets(line,200,fd)) {
X for (cp = line; (ch = *cp)==' ' || ch=='\t'; cp++) ;
X if (ch == '\n') continue;
X if (strcmp(token(cp),"to")) {
X printf("Edited file includes non-procedure.\n");
X ehand2(fd);
X }
X for (cp += 2; (ch = *cp)==' ' || ch=='\t'; cp++) ;
X name = token(cp);
X printf("Defining %s\n",name);
X sprintf(fname,"%s%s",name,EXTEN);
X ofd = fopen(fname,"w");
X if (ofd==NULL) {
X printf("Can't write %s\n",fname);
X ehand2(fd);
X }
X fprintf(ofd,"%s",line);
X while (fgets(line,200,fd)) {
X fprintf(ofd,"%s",line);
X for (cp = line; (ch = *cp)==' ' || ch=='\t'; cp++) ;
X if (!strcmp(token(cp),"end")) break;
X }
X fclose(ofd);
X }
X fclose(fd);
X onintr(errrec,1);
X}
X
Xstruct object *cmedit(arg)
Xstruct object *arg;
X{
X stedit(arg,0);
X return ((struct object *)(-1));
X}
X
Xstruct object *erase(name) /* delete a procedure from directory */
Xregister struct object *name;
X{
X register struct object *rest;
X char temp[16];
X
X if (name==0) ungood("Erase",name);
X switch(name->obtype) {
X case STRING:
X cpystr(temp,name->obstr,EXTEN,NULL);
X if (unlink(temp)<0) { /* undefined procedure */
X nputs("You haven't defined ");
X puts(name->obstr);
X errhand();
X }
X break;
X case CONS:
X for (rest = name; rest; rest = rest->obcdr)
X erase(localize(rest->obcar));
X break;
X default: /* number */
X ungood("Erase",name);
X }
X mfree(name);
X return ((struct object *)(-1));
X}
X
Xaddlines(edfd) /* read text of procedure, simple TO style */
Xint edfd;
X{
X register char *lintem;
X int oldlet;
X static char tstack[IBUFSIZ];
X int brak,brace,ch; /* BH 1/7/82 */
X
X oldlet=letflag;
X letflag=1; /* read rest of line verbatim */
Xloop:
X putchar('>');
X fflush(stdout);
X lintem=tstack;
X brace = brak = 0; /* BH 1/7/82 count square brackets */
X do {
X while ((ch=getchar())!='\n') {
X if (lintem >= &tstack[IBUFSIZ-2]) {
X printf("Line too long.");
X goto loop;
X }
X *lintem++ = ch;
X if (ch == '\\') *lintem++ = getchar();
X else if (ch == '[') brak++;
X else if (ch == ']') --brak;
X else if (brak == 0) {
X if (ch == '{' || ch == '(') brace++;
X else if (ch == '}' || ch == ')') --brace;
X }
X }
X if (brak > 0) {
X *lintem++ = ' ';
X printf("[: ");
X fflush(stdout);
X } else if (brace > 0) {
X *lintem++ = ' ';
X printf("{(: ");
X fflush(stdout);
X }
X } while (brace+brak > 0);
X *lintem++='\n';
X *lintem='\0';
X write(edfd,tstack,lintem-tstack);
X for (lintem = tstack; memb(*lintem++," \t") ; ) ;
X --lintem;
X if (strcmp(token(lintem),"end")) goto loop;
X letflag=oldlet;
X close(edfd);
X}
X
Xstruct object *show(nameob)
Xregister struct object *nameob;
X{
X register struct object *rest;
X register char *name;
X FILE *sbuf;
X char temp[100];
X
X if (nameob==0) ungood("Show",nameob);
X switch(nameob->obtype) {
X case STRING:
X name = nameob->obstr;
X cpystr(temp,name,EXTEN,NULL);
X if (!(sbuf=fopen(temp,"r"))) {
X cpystr(temp,LIBLOGO,name,EXTEN,NULL);
X if (!(sbuf = fopen(temp,"r"))) {
X printf("You haven't defined %s\n",name);
X errhand();
X }
X }
X onintr(ehand2,sbuf);
X while (putch(getc(sbuf))!=EOF)
X ;
X fclose(sbuf);
X onintr(errrec,1);
X break;
X case CONS:
X for (rest = nameob; rest; rest = rest->obcdr) {
X show(localize(rest->obcar));
X putchar('\n');
X }
X break;
X default: /* number */
X ungood("Show",nameob);
X }
X mfree(nameob);
X return ((struct object *)(-1));
X}
X
END_OF_procedit.c
if test 6263 -ne `wc -c <procedit.c`; then
echo shar: \"procedit.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f procvars.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"procvars.c\"
else
echo shar: Extracting \"procvars.c\" \(7096 characters\)
sed "s/^X//" >procvars.c <<'END_OF_procvars.c'
X
X/* This file contains stuff about user procedure calls and
X* variable assignment and lookup.
X*
X* Copyright (C) 1979, The Children's Museum, Boston, Mass.
X* Written by Douglas B. Klunder
X*/
X
X#include "logo.h"
Xextern struct plist *pcell;
Xextern int *stkbase;
Xextern int stkbi;
Xextern int *newstk;
Xextern int newsti;
Xextern int argno;
Xextern int yylval;
Xextern int yychar;
Xextern short yyerrflag;
Xstatic struct alist *globvars;
Xextern struct stkframe *fbr;
Xextern struct plist *proclist;
Xextern struct alist *locptr;
Xextern struct alist *newloc;
X
Xstruct alist *loclk1();
Xstruct alist *look1();
Xstruct object *look();
X
Xgo(linenum) /* LOGO go */
Xregister struct object *linenum;
X{
X register struct lincell *lptr;
X register numline;
X
X if (pcell==NULL) { /* not in procedure */
X printf("Go can only be used within a procedure.\n");
X errhand();
X }
X linenum = numconv(linenum,"Go");
X if (!intp(linenum)) ungood("Go",linenum);
X numline = linenum->obint;
X mfree(linenum);
X/* Search for saved line no. */
X for (lptr=pcell->plines;lptr;lptr=lptr->nextline) {
X if (lptr->linenum==numline)
X { /* line found, so adjust pseudo-code
X * pointers to continue execution at
X * right place
X */
X stkbase=lptr->base;
X stkbi=lptr->index;
X return;
X }
X }
X /* no match */
X printf("There is no line %d.\n",numline);
X errhand();
X}
X
Xchar *lowcase(name)
Xregister char *name;
X{
X static char result[100];
X register char c,*str;
X
X str = result;
X while (c = *name++) {
X if (c >= 'A' && c <= 'Z') c += 040;
X *str++ = c;
X }
X *str = '\0';
X return(result);
X}
X
Xstruct object *lnamep(name) /* namep */
Xregister struct object *name;
X{ /* check for both local and global definitions */
X register char *nstr;
X
X if (!stringp(name)) ungood("Namep",name);
X nstr = lowcase(name->obstr);
X if (loclk1(nstr) || look1(nstr)) {
X mfree(name);
X return(true());
X }
X mfree(name);
X return(false());
X}
X
Xloccreate(varname,lptr) /* create new local variable cell, with name
X * but without value */
Xregister struct object *varname;
Xregister struct alist **lptr;
X{
X register struct alist *temp1,*temp2;
X char ch,*str;
X
X if (pcell==NULL) { /* not in procedure */
X printf("Local can only be used within a procedure.\n");
X errhand();
X }
X if (!stringp(varname)) ungood("Local",varname);
X str = lowcase(varname->obstr);
X if ((ch = str[0]) == '\0') {
X printf("Variable name can't be empty.\n");
X errhand();
X }
X if (ch<'a' || ch>'z') {
X printf("Variable name %s must start with a letter.\n",
X varname->obstr);
X errhand();
X }
X if (*lptr==NULL) { /* first cell */
X *lptr=(temp1=(struct alist *)ckzmalloc(sizeof(*temp1)));
X } else {
X for (temp1= *lptr;temp1;temp1=temp1->next) {
X if (!strcmp(temp1->name->obstr,str))
X { /* name already present */
X nputs(varname->obstr);
X printf(" is already defined as a local variable.\n");
X errhand();
X }
X temp2=temp1;
X }
X /* create new cell at end of string */
X temp2->next=(struct alist *)ckzmalloc(sizeof(*temp2));
X temp1=temp2->next;
X }
X temp1->next=NULL;
X temp1->name=globcopy(objcpstr(str));
X temp1->val=(struct object *)-1;
X lfree(varname);
X}
X
Xstruct object *cmlocal(arg)
Xstruct object *arg;
X{
X loccreate(globcopy(arg),&locptr);
X mfree(arg);
X return ((struct object *)(-1));
X}
X
Xstruct alist *loclk2(str,lap) /* look for local definition of variable
X * return cell pointer if found */
X /* BH 5/19/81 was loclk1 but now subprocedure */
Xregister char *str;
Xregister struct alist *lap;
X{
X while (lap) {
X if (!strcmp(str,lap->name->obstr)) return(lap);
X lap=lap->next;
X }
X return(NULL);
X}
X
Xstruct alist *loclk1(str) /* look for local definition of variable
X * WITH DYNAMIC SCOPE!! BH 5/19/81 */
Xregister char *str;
X{
X register struct stkframe *skp;
X register struct alist *lap;
X
X if (lap = loclk2(str,locptr)) return(lap);
X /* found in innermost active procedure */
X for (skp = fbr; skp; skp = skp->prevframe) {
X /* else try other active procedures */
X if (skp->loclist)
X if ((lap = loclk2(str,skp->loclist)) != NULL)
X return(lap);
X }
X return(NULL);
X}
X
Xstruct object *alllk(str) /* return value of variable */
Xregister struct object *str;
X{ /* look both locally and globally */
X register struct alist *ap;
X register char *strnm;
X
X if (!stringp(str)) ungood("Thing",str);
X strnm = lowcase(str->obstr);
X if ((ap=loclk1(strnm))==NULL) return(look(str));
X if (ap->val==(struct object *)-1) {
X nputs(strnm);
X puts(" has no value.");
X errhand();
X }
X mfree(str);
X return(localize(ap->val));
X}
X
Xnewfr() /* create new stack frame to accommodate procedure */
X{
X register int *temp;
X
X temp=(int *)ckmalloc(PSTKSIZ*sizeof(int));
X *temp=(int)newstk;
X *(newstk+PSTKSIZ-1)=(int)temp;
X newstk=temp;
X newsti=1;
X}
X
Xstruct plist *proclook(name) /* check if procedure already in memory */
Xregister char *name;
X{
X register struct plist *here;
X
X for (here=proclist;here;here=here->after)
X if (!strcmp(name,here->procname->obstr)) return(here);
X return(NULL);
X}
X
Xargassign(argval) /* assign value to next unfilled input */
Xregister struct object *argval;
X{
X register struct alist *temp1;
X
X for (temp1=newloc;temp1->val!=(struct object *)-1;temp1=temp1->next) {
X if (!stringp(temp1->name)) {
X printf("Argassign bug trap, newloc messed up.\n");
X return;
X }
X }
X temp1->val=globcopy(argval);
X mfree(argval);
X if (--argno==0) { /* all inputs filled, so save unparsed token */
X fbr->oldyyl=yylval;
X fbr->oldyyc=yychar;
X if (yyerrflag) return;
X yychar= -1;
X }
X}
X
Xassign(name,val) /* make */
Xregister struct object *name,*val;
X{
X register struct alist *ap;
X register char *namestr;
X char *tmp,ch;
X
X if (!stringp(name)) ungood("Make",name);
X namestr = lowcase(name->obstr);
X for(tmp=namestr;*tmp;tmp++){
X if((*tmp<'a' || *tmp>'z') && (*tmp <'0' || *tmp>'9')
X && (*tmp != '.') && (*tmp != '_')) {
X pf1("Cannot assign value to %l\n",name);
X errhand();
X }
X }
X if ((ap=loclk1(namestr))) { /* local definition */
X if (ap->val != (struct object *)-1) lfree(ap->val);
X mfree(name);
X ap->val=globcopy(val);
X mfree(val);
X return;
X }
X else if ((ap=look1(namestr))==0)
X { /* new variable, so allocate cell */
X if ((ch = namestr[0]) == '\0') {
X printf("Variable name can't be empty.\n");
X errhand();
X }
X if (ch<'a' || ch>'z') {
X printf("Variable name %s must start with a letter.\n",
X namestr);
X errhand();
X }
X ap=(struct alist *)ckmalloc(sizeof(*ap));
X ap->name = globcopy(objcpstr(namestr));
X ap->next=globvars;
X globvars=ap;
X mfree(name);
X } else { /* old global definition */
X lfree(ap->val);
X mfree(name);
X }
X ap->val=globcopy(val);
X mfree(val);
X}
X
Xstruct object *look(str) /* return value of globally defined variable */
Xregister struct object *str;
X{
X register struct alist *ap;
X register char *strtxt;
X
X if (!stringp(str)) ungood("Thing",str);
X strtxt = lowcase(str->obstr);
X ap=look1(strtxt);
X if (ap==NULL) {
X nputs(strtxt);
X printf(" has no value.\n");
X errhand();
X }
X mfree(str);
X return(localize(ap->val));
X}
X
Xstruct alist *look1(str) /* return pointer to right variable cell */
Xregister char *str;
X{
X register struct alist *ap;
X
X for(ap=globvars; ap != 0; ap=ap->next)
X if (!strcmp(str,ap->name->obstr)) return(ap);
X return(0);
X}
X
END_OF_procvars.c
if test 7096 -ne `wc -c <procvars.c`; then
echo shar: \"procvars.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f storage.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"storage.c\"
else
echo shar: Extracting \"storage.c\" \(4825 characters\)
sed "s/^X//" >storage.c <<'END_OF_storage.c'
X
X#include "logo.h"
X
Xextern struct object *allocstk[];
X
Xchar *ckmalloc(size)
Xint size;
X{
X register char *block;
X extern char *malloc();
X
X block = malloc(size);
X if (block==0) {
X printf("No more memory, sorry.\n");
X errhand();
X }
X#ifdef DEBUG
X if (memtrace) {
X printf("Malloc size=%d loc=0%o\n",size,block);
X }
X#endif
X return(block);
X}
X
Xchar *ckzmalloc(size)
Xint size;
X{
X register char *block;
X register int *ip;
X
X block = ckmalloc(size);
X for (ip = (int *)block; (char *)ip < block+size; )
X *ip++ = 0;
X return(block);
X}
X
Xmfree(ptr) /* free allocated space, allowing another chunk to be */
Xregister struct object *ptr;
X{
X register struct object **i;
X
X#ifdef DEBUG
X if(ptr==(struct object *)-1) {
X puts("mfree of -1");
X return;
X } /* BH 3/5/80 bug trap */
X#endif
X if (ptr==0) return; /* BH 3/5/80 this is ok */
X for (i = allocstk; i < &allocstk[MAXALLOC]; i++)
X if (*i == ptr) break;
X#ifdef DEBUG
X if (*i != ptr) {
X pf1("Trying to mfree nonlocal at 0%o val=%p\n",ptr,ptr);
X return;
X }
X if (memtrace)
X pf1("\nMfree entry=%d loc=0%o val=%p\n",i,ptr,ptr);
X#endif
X *i = 0;
X lfree(ptr);
X}
X
Xlfree(ptr)
Xregister struct object *ptr;
X{
X#ifdef DEBUG
X if(ptr== (struct object *)-1){
X puts("lfree of -1");
X return;
X }
X#endif
X if(ptr==0) return;
X if (--(ptr->refcnt) > 0) return;
X#ifdef DEBUG
X if ((ptr->refcnt) < 0) {
X printf("Trying to lfree negative refcnt, loc=0%o\n",
X ptr);
X return;
X }
X if (memtrace) {
X (ptr->refcnt)++;
X pf1("\nLfree loc=0%o val=%p\n",ptr,ptr);
X (ptr->refcnt)--;
X }
X#endif
X if (listp(ptr)) {
X lfree(ptr->obcar);
X lfree(ptr->obcdr);
X }
X if (stringp(ptr)) {
X#ifdef DEBUG
X if (memtrace)
X printf("Lfree frees string %s at 0%o\n",
X ptr->obstr,ptr->obstr);
X#endif
X free(ptr->obstr);
X }
X free(ptr);
X}
X
X#ifdef SMALL
X/* In small Logo, refcnts are chars. Make an actual copy for things with
X * lots of references, which should be rare. */
Xstruct object *realcopy(old)
Xregister struct object *old;
X{
X register struct object *new;
X
X new = (struct object *)ckmalloc(sizeof(struct object));
X new->obtype = old->obtype;
X new->refcnt = 0;
X switch (new->obtype) {
X case CONS:
X new->obcar = globcopy(old->obcar);
X new->obcdr = globcopy(old->obcdr);
X break;
X case INT:
X new->obint = old->obint;
X break;
X case DUB:
X new->obdub = old->obdub;
X break;
X default: /* STRING */
X new->obstr = ckmalloc(1+strlen(old->obstr));
X strcpy(new->obstr,old->obstr);
X }
X return(new);
X}
X#endif
X
Xstruct object *localize(new)
Xregister struct object *new;
X{
X register struct object **i;
X
X if (new==0) return(0);
X for (i = allocstk; i < &allocstk[MAXALLOC]; i++)
X if (*i == 0) break;
X if (*i != 0) {
X puts("I can't remember everything you have told me.");
X puts("Please enter less complex instructions.");
X errhand();
X }
X#ifdef SMALL
X if (new->refcnt == 127) new = realcopy(new);
X#endif SMALL
X *i = new;
X new->refcnt++;
X return(new);
X}
X
Xstruct object *globcopy(obj)
Xregister struct object *obj;
X{
X if (obj==0) return(0);
X#ifdef SMALL
X if (obj->refcnt == 127) obj = realcopy(obj);
X#endif SMALL
X obj->refcnt++;
X return(obj);
X}
X
Xstruct object *globcons(first,rest)
Xregister struct object *first,*rest;
X{
X register struct object *new;
X
X new = (struct object *)ckmalloc(sizeof(struct object));
X new->obtype = CONS;
X new->refcnt = 0;
X new->obcar = globcopy(first);
X new->obcdr = globcopy(rest);
X return(new);
X}
X
Xstruct object *loccons(first,rest)
Xstruct object *first,*rest;
X{
X return(localize(globcons(first,rest)));
X}
X
Xstruct object *objstr(string)
Xregister char *string;
X{
X register struct object *new;
X
X new = (struct object *)ckmalloc(sizeof(struct object));
X new->obtype = STRING;
X new->refcnt = 0;
X new->obstr = string;
X return(new);
X}
X
Xstruct object *objcpstr(string)
Xregister char *string;
X{
X register struct object *new;
X register char *newstr;
X
X newstr = ckmalloc(strlen(string)+1);
X strcpy(newstr,string);
X new = (struct object *)ckmalloc(sizeof(struct object));
X new->obtype = STRING;
X new->refcnt = 0;
X new->obstr = newstr;
X return(new);
X}
X
Xstruct object *objint(num)
XFIXNUM num;
X{
X register struct object *new;
X
X new = (struct object *)ckmalloc(sizeof(struct object));
X new->obtype = INT;
X new->refcnt = 0;
X new->obint = num;
X return(new);
X}
X
Xstruct object *objdub(num)
XNUMBER num;
X{
X register struct object *new;
X
X new = (struct object *)ckmalloc(sizeof(struct object));
X new->obtype = DUB;
X new->refcnt = 0;
X new->obdub = num;
X return(new);
X}
X
Xstruct object *bigsave(string)
Xregister char *string;
X/* used by stringform to get an extra null at the end, kludge */
X/* Note -- returned object is localized! */
X{
X register char *newstr;
X register struct object *newobj;
X
X newstr = ckmalloc(2+strlen(string));
X strcpy(newstr,string);
X newobj = (struct object *)ckmalloc(sizeof(struct object));
X newobj->obtype = STRING;
X newobj->refcnt = 0;
X newobj->obstr = newstr;
X return(localize(newobj));
X}
X
END_OF_storage.c
if test 4825 -ne `wc -c <storage.c`; then
echo shar: \"storage.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 2 \(of 6\).
cp /dev/null ark2isdone
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 return(x;
X sood