This is logoop.m in view mode; [Download] [Up]
/* Miscellaneous operations in LOGO.
* Copyright (C) 1979, The Children's Museum, Boston, Mass.
* Written by Douglas B. Klunder.
*/
#include "logo.h"
struct object *true()
{
return(localize(objcpstr("true")));
}
struct object *false()
{
return(localize(objcpstr("false")));
}
obstrcmp(obj,str)
register struct object *obj;
char *str;
{
if (!stringp(obj)) return(1);
return(strcmp(obj->obstr,str));
}
int truth(x) /* used by if handler in logo.y */
register struct object *x;
{
if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("If",x);
if (!obstrcmp(x,"true")) {
mfree(x);
return(1);
} else {
mfree(x);
return(0);
}
}
char *mkstring(obj)
register struct object *obj;
{
/* subroutine for several operations which treat numbers as words,
* turn number into character string.
* Note: obj must be known to be nonempty; result is ptr to static.
*/
register char *cp;
static char str[30];
switch(obj->obtype) {
case STRING:
cp = obj->obstr;
break;
case INT:
sprintf(str,FIXFMT,obj->obint);
cp = str;
break;
case DUB:
sprintf(str,"%g",obj->obdub);
if (!index(str,'.')) strcat(str,".0");
cp = str;
break;
default: /* case CONS */
return(0); /* not a string, handle uplevel */
}
return(cp);
}
struct object *and(x,y) /* both */
register struct object *x,*y;
{
if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Both",x);
if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Both",y);
if (!obstrcmp(x,"true")) {
mfree(x);
return(y);
} else {
mfree(y);
return(x);
}
}
struct object *or(x,y) /* either */
register struct object *x,*y;
{
if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Either",x);
if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Either",y);
if (!obstrcmp(x,"true")) {
mfree(y);
return(x);
} else {
mfree(x);
return(y);
}
}
emptyp(x) /* non-LOGO emptyp, returning 1 if empty, 0 if not. */
register struct object *x;
{
if (x==0) return(1);
switch (x->obtype) {
case STRING:
if (*(x->obstr)=='\0') /* check for character */
return(1);
default:
return(0);
}
}
struct object *lemp(x) /* LOGO emptyp */
register struct object *x;
{
if (emptyp(x)) {
mfree(x);
return(true());
} else {
mfree(x);
return(false());
}
}
struct object *comp(x) /* not */
register struct object *x;
{
if (!obstrcmp(x,"true")) {
mfree(x);
return(false());
} else if (!obstrcmp(x,"false")) {
mfree(x);
return(true());
} else ungood("Not",x);
}
struct object *lsentp(x) /* LOGO sentencep */
register struct object *x;
{
register struct object *y;
if (x==0) return(true());
if (listp(x)) {
/* BH 4/30/81 true only for a flat sentence,
not a list of lists */
for (y = x; y; y = y->obcdr)
if (listp(y->obcar)) {
mfree(x);
return(false());
}
mfree(x);
return(true());
} else {
mfree(x);
return(false());
}
}
struct object *lwordp(x) /* LOGO wordp */
register struct object *x;
{
if (!listp(x)) {
mfree(x);
return(true());
} else {
mfree(x);
return(false());
}
}
struct object *first(x) /* first */
register struct object *x;
{
register struct object *temp;
register char *cp;
char str[2];
if (emptyp(x)) ungood("First",x);
if (cp = mkstring(x)) {
str[0] = *cp;
str[1] = '\0';
mfree(x);
return(localize(objcpstr(str)));
} else {
temp = x->obcar;
localize(temp);
mfree(x);
return(temp);
}
}
struct object *butfir(x) /* butfirst */
register struct object *x;
{
register struct object *temp;
register char *cp;
if (emptyp(x)) ungood("Butfirst",x);
if (cp = mkstring(x)) {
cp++; /* skip first char */
mfree(x);
return(localize(objcpstr(cp)));
} else {
temp = x->obcdr;
localize(temp);
mfree(x);
return(temp);
}
}
struct object *last(x) /* last */
register struct object *x;
{
register struct object *temp;
register char *cp;
if (emptyp(x)) ungood("Last",x);
if (cp = mkstring(x)) {
mfree(x);
return(localize(objcpstr(&cp[strlen(cp)-1])));
} else {
for(temp=x; temp->obcdr; temp=temp->obcdr) ;
temp = temp->obcar;
localize(temp);
mfree(x);
return(temp);
}
}
struct object *butlas(x) /* butlast */
register struct object *x;
{
register struct object *temp,*temp2,*ans;
register char *cp;
if (emptyp(x)) ungood("Butlast",x);
if (cp = mkstring(x)) {
mfree(x);
temp = objstr(ckmalloc(strlen(cp)));
strncpy(temp->obstr,cp,strlen(cp)-1);
(temp->obstr)[strlen(cp)-1] = '\0';
return(localize(temp));
} else {
if ((x->obcdr)==0) {
mfree(x);
return(0);
}
temp2 = ans = globcons(0,0);
for(temp=x; temp->obcdr->obcdr; temp=temp->obcdr) {
temp2->obcar = globcopy(temp->obcar);
temp2->obcdr = globcopy(globcons(0,0));
temp2 = temp2->obcdr;
}
temp2->obcar = globcopy(temp->obcar);
localize(ans);
mfree(x);
return(ans);
}
}
struct object *fput(x,y)
register struct object *x,*y;
{
register struct object *z;
if(!listp(y)) {
printf("Second input of fput must be a list.\n");
errhand();
}
z = loccons(x,y);
mfree(x);
mfree(y);
return(z);
}
struct object *lput(x,y)
struct object *x,*y;
{
register struct object *a,*b,*ans;
if (!listp(y)) {
printf("Second input of lput must be a list.\n");
errhand();
}
if (y == 0) { /* 2nd input is empty list */
b = loccons(x,0);
mfree(x);
return(b);
}
ans = a = loccons(0,0);
for (b=y; b; b=b->obcdr) {
a->obcar = globcopy(b->obcar);
a->obcdr = globcopy(globcons(0,0));
a = a->obcdr;
}
a->obcar = globcopy(x);
mfree(x);
mfree(y);
return(ans);
}
struct object *list(x,y)
struct object *x,*y;
{
register struct object *a,*b;
b = globcons(y,0);
a = loccons(x,b);
mfree(x);
mfree(y);
return(a);
}
struct object *length(x) /* count */
register struct object *x;
{
register struct object *temp;
register char *cp;
register int i;
if (x==0) return(localize(objint((FIXNUM)0)));
if (cp = mkstring(x)) {
i = strlen(cp);
mfree(x);
return(localize(objint((FIXNUM)i)));
} else {
i = 0;
for (temp=x; temp; temp = temp->obcdr)
i++;
mfree(x);
return(localize(objint((FIXNUM)i)));
}
}
logois(x,y) /* non-Logo is, despite the name */
register struct object *x,*y;
{
if (listp(x)) {
if (listp(y)) {
if (x==0) return(y==0);
if (y==0) return(0);
return(logois(x->obcar,y->obcar) &&
logois(x->obcdr,y->obcdr) );
}
return(0);
}
if (listp(y)) return(0);
if (x->obtype != y->obtype) return(0);
switch (x->obtype) {
case INT:
return(x->obint == y->obint);
case DUB:
return(x->obdub == y->obdub);
default: /* case STRING */
return(!strcmp(x->obstr,y->obstr));
}
}
struct object *lis(x,y)
register struct object *x,*y;
{
register z;
z = logois(x,y);
mfree(x);
mfree(y);
return(z ? true() : false());
}
leq(x,y) /* non-Logo numeric equal */
register struct object *x,*y;
{
NUMBER dx,dy;
FIXNUM ix,iy;
int xint,yint;
if (listp(x) || listp(y)) return(logois(x,y));
if (stringp(x) && !nump(x)) return(logois(x,y));
if (stringp(y) && !nump(y)) return(logois(x,y));
xint = yint = 0;
if (stringp(x)) {
if (isint(x)) {
xint++;
sscanf(x->obstr,FIXFMT,&ix);
} else {
sscanf(x->obstr,EFMT,&dx);
}
} else {
if (intp(x)) {
xint++;
ix = x->obint;
} else {
dx = x->obdub;
}
}
if (stringp(y)) {
if (isint(y)) {
yint++;
sscanf(y->obstr,FIXFMT,&iy);
} else {
sscanf(y->obstr,EFMT,&dy);
}
} else {
if (intp(y)) {
yint++;
iy = y->obint;
} else {
dy = y->obdub;
}
}
if (xint != yint) {
if (xint) dx = ix;
else dy = iy;
xint = 0;
}
if (xint)
return (ix == iy);
else
return (dx == dy);
}
struct object *equal(x,y) /* Logo equalp */
register struct object *x,*y;
{
register z;
z = leq(x,y);
mfree(x);
mfree(y);
return(z ? true() : false());
}
struct object *worcat(x,y) /* word */
register struct object *x,*y;
{
char *val,*xp,*yp;
char xstr[30],ystr[30];
if (listp(x)) ungood("Word",x);
if (listp(y)) ungood("Word",y);
switch(x->obtype) {
case INT:
sprintf(xstr,FIXFMT,x->obint);
xp = xstr;
break;
case DUB:
sprintf(xstr,"%g",x->obdub);
if (!index(xstr,'.')) strcat(xstr,".0");
xp = xstr;
break;
default: /* case STRING */
xp = x->obstr;
}
switch(y->obtype) {
case INT:
sprintf(ystr,FIXFMT,y->obint);
yp = ystr;
break;
case DUB:
sprintf(ystr,"%g",y->obdub);
if (!index(ystr,'.')) strcat(ystr,".0");
yp = ystr;
break;
default: /* case STRING */
yp = y->obstr;
}
val=ckmalloc(strlen(xp)+strlen(yp)+1);
cpystr(val,xp,yp,NULL);
mfree(x);
mfree(y);
return(localize(objstr(val)));
}
struct object *sencat(x,y) /* sentence */
struct object *x,*y;
{
register struct object *a,*b,*c;
if (x==0) {
if (listp(y)) return(y);
a = loccons(y,0);
mfree(y);
return(a);
}
if (listp(x)) {
c = a = globcons(0,0);
for (b=x; b->obcdr; b = b->obcdr) {
a->obcar = globcopy(b->obcar);
a->obcdr = globcopy(globcons(0,0));
a = a->obcdr;
}
a->obcar = globcopy(b->obcar);
}
else c = a = globcons(x,0);
if (listp(y)) b = y;
else b = globcons(y,0);
a->obcdr = globcopy(b);
mfree(x);
mfree(y);
return(localize(c));
}
struct object *memberp(thing,group)
struct object *thing,*group;
{
register char *cp;
register struct object *rest;
int i;
if (group==0) {
mfree(thing);
return(false());
}
if (cp = mkstring(group)) {
if (thing==0) {
mfree(group);
return(false());
}
switch (thing->obtype) {
case INT:
if((thing->obint >= 0)&&(thing->obint < 10)) {
i = memb('0'+thing->obint,cp);
break;
}
case CONS:
case DUB:
i = 0;
break;
default: /* STRING */
if (strlen(thing->obstr) == 1) {
i = memb(*(thing->obstr),cp);
} else i = 0;
}
} else {
i = 0;
for (rest=group; rest; rest=rest->obcdr) {
if (leq(rest->obcar,thing)) {
i++;
break;
}
}
}
mfree(thing);
mfree(group);
return(torf(i));
}
struct object *item(num,group)
struct object *num,*group;
{
int inum,ernum;
register char *cp;
register struct object *rest;
char str[2];
num = numconv(num,"Item");
if (intp(num)) inum = num->obint;
else inum = num->obdub;
if (inum <= 0) ungood("Item",num);
if (group == 0) ungood("Item",group);
if (cp = mkstring(group)) {
if (inum > strlen(cp)) {
pf1("%p has fewer than %d items.\n",group,inum);
errhand();
}
str[0] = cp[inum-1];
str[1] = '\0';
mfree(num);
mfree(group);
return(localize(objcpstr(str)));
} else {
ernum = inum;
for (rest = group; --inum; rest = rest->obcdr) {
if (rest==0) break;
}
if (rest==0) {
pf1("%p has fewer than %d items.\n",
group,ernum);
errhand();
}
mfree(num);
rest = localize(rest->obcar);
mfree(group);
return(rest);
}
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.