shithub: mlisp

Info  •  Files  •  Log  •  Branches

rudimentary string type; proper mapping functions

--- a/lisp.c

+++ b/lisp.c

@@ -27,6 +27,7 @@

 void *Atom = (void*)CAR_ATOM;

 void *Fixnum = (void*)(CAR_ATOM|CAR_FIX);

 void *Flonum = (void*)(CAR_ATOM|CAR_FLO);

+void *String = (void*)(CAR_ATOM|CAR_STR);

 /* absence of a value */

 C *noval = (C*)~0;

@@ -155,6 +156,15 @@

 }

 C*

+mkstr(char *s)

+{

+	C *c;

+	c = cons(String, nil);

+	c->str = s;

+	return c;

+}

+

+C*

 mksubr(C *(*subr)(void), int n)

 {

 	F nf, sf;

@@ -195,6 +205,13 @@

 	return c == nil || !(c->ap & CAR_ATOM);

 }

+int

+stringp(C *c)

+{

+	return c != nil && c->ap & CAR_ATOM && c->ap & CAR_STR;

+}

+

+

 fixnum

 length(C *c)

 {

@@ -209,61 +226,7 @@

 	return n;

 }

-/* functions for handling pnames */

-int

-matchpname(C *c, char *name)

-{

-	int i;

-	char *s;

-	char c1, c2;

-

-	s = name;

-	i = 0;

-	for(;;){

-		c1 = *s++;

-		c2 = c ? c->af->c[i++] : '\0';

-		if(i == C2W){

-			i = 0;

-			c = c->d;

-		}

-		if(c1 != c2)

-			return 0;

-		if(c1 == '\0')

-			return 1;

-	}

-}

-

 C*

-makepname(char *name)

-{

-	int i;

-	F w;

-	char *s;

-	C *ret, **next;

-

-	/* TODO: maybe do this elsewhere? */

-	ret = cons(nil, nil);

-	temlis.pn = ret;

-	next = &ret->a;

-

-	/* split up name into full words

-	 * and build list structure */

-	s = name;

-	while(*s != '\0'){

-		w.fw = 0;

-		for(i = 0; i < C2W; i++){

-			if(*s == '\0')

-				break;

-			w.c[i] = *s++;

-		}

-		*next = cons(consw(w.fw), nil);

-		next = &(*next)->d;

-	}

-	temlis.pn = nil;

-	return ret;

-}

-

-C*

 get(C *l, C *p)

 {

 	assert(l != nil);

@@ -360,12 +323,12 @@

 		pn = get(c->a, pname);

 		if(pn == nil)

 			continue;

-		if(matchpname(pn, name))

+		assert(stringp(pn));

+		if(strcmp(pn->str, name) == 0)

 			return c->a;

 	}

 	c = cons(Atom,

-		cons(pname,

-		makepname(name)));

+		cons(pname, cons(mkstr(strdup(name)), nil)));

 	oblist = cons(c, oblist);

 	return c;

 }

@@ -374,55 +337,20 @@

  * output

  */

-void

-princpname(C *c)

+/* figure out whether |...| are needed to print symbol.

+ * TODO: actually fix this */

+static int

+specname(char *s)

 {

-	char chr;

-	word fw;

-	int i;

-	for(c = c->a; c != nil; c = c->d){

-		fw = ((F*)c->a)->fw;

-		for(i = 0; i < C2W; i++){

-			chr = fw&0xFF;

-			if(chr == 0) return;

-			putc(chr, sysout);

-			fw >>= 8;

-		}

-	}

+	for(; *s != '\0'; s++)

+		if(islower(*s))

+			return 1;

+	return 0;

 }

 void

-printpname(C *c)

+printatom(C *c, int x)

 {

-	char chr;

-	C *cc;

-	word fw;

-	int i;

-	int spec;

-

-	cc = c;

-	spec = 0;

-	for(c = c->a; c != nil; c = c->d){

-		fw = ((F*)c->a)->fw;

-		for(i = 0; i < C2W; i++){

-			chr = fw&0xFF;

-			if(chr == 0) goto pr;

-			if(!isupper(fw&0x7F)){

-				spec = 1;

-				goto pr;

-			}

-			fw >>= 8;

-		}

-	}

-pr:

-	if(spec) putc('|', sysout);

-	princpname(cc);

-	if(spec) putc('|', sysout);

-}

-

-void

-printatom(C *c, void (*pnm)(C *c))

-{

 	if(c == nil)

 		fprintf(sysout, "NIL");

 	else if(fixnump(c))

@@ -429,11 +357,21 @@

 		fprintf(sysout, "%lld", (long long int)c->fix);

 	else if(flonump(c))

 		fprintf(sysout, "%f", c->flo);

-	else{

+	else if(stringp(c)){

+		if(x)

+			fprintf(sysout, "%s", c->str);

+		else

+			fprintf(sysout, "\"%s\"", c->str);

+	}else{

 		assert(atom(c));

 		for(; c != nil; c = c->d)

 			if(c->a == pname){

-				pnm(c->d);

+				c = c->d->a;

+				assert(stringp(c));

+				if(!x && specname(c->str))

+					fprintf(sysout, "|%s|", c->str);

+				else

+					fprintf(sysout, "%s", c->str);

 				return;

 			}

 		fprintf(sysout, "%%ATOM%%");

@@ -441,11 +379,11 @@

 }

 void

-printsxp(C *c, void (*pnm)(C *c))

+printsxp(C *c, int x)

 {

 	int fst;

 	if(atom(c))

-		printatom(c, pnm);

+		printatom(c, x);

 	else{

 		putc('(', sysout);

 		fst = 1;

@@ -452,7 +390,7 @@

 		for(; c != nil; c = c->d){

 			if(atom(c)){

 				fprintf(sysout, " . ");

-				printatom(c, pnm);

+				printatom(c, x);

 				break;

 			}

 			if(!fst)

@@ -467,13 +405,13 @@

 void

 lprint(C *c)

 {

-	printsxp(c, printpname);

+	printsxp(c, 0);

 }

 void

 princ(C *c)

 {

-	printsxp(c, princpname);

+	printsxp(c, 1);

 }

 /*

@@ -566,6 +504,23 @@

 }

 C*

+readstr(void)

+{

+	int c;

+	char buf[128], *p;

+

+	p = buf;

+	while(c = chsp(), c != EOF){

+		// TODO: some escapes

+		if(c == '"')

+			break;

+		*p++ = c;	// TODO: overflow

+	}

+	*p = '\0';

+	return mkstr(strdup(buf));

+}

+

+C*

 readatom(void)

 {

 	C *num;

@@ -586,7 +541,7 @@

 			spec = !spec;

 			continue;

 		}

-		*p++ = c;

+		*p++ = c;	// TODO: overflow

 	}

 	*p = '\0';

 	if(lc)

@@ -646,6 +601,8 @@

 		err("error: unexpected ')'");

 	if(c == '(')

 		return readlist();

+	if(c == '"')

+		return readstr();

 	nextc = c;

 	return readatom();

 }

@@ -747,7 +704,7 @@

 tail:

 	if(form == nil)

 		return nil;

-	if(numberp(form))

+	if(numberp(form) || stringp(form))

 		return form;

 	if(atom(form)){

 		if(tt = getx(form, value), tt != nil)

@@ -907,7 +864,7 @@

 	/* init oblist so we can use intern */

 	pname = cons(Atom, nil);

-	pname->d = cons(pname, makepname("PNAME"));

+	pname->d = cons(pname, cons(mkstr("PNAME"), nil));

 	oblist = cons(pname, nil);

 	/* Now enable GC */

@@ -953,7 +910,7 @@

 	putprop(star, star, value);

 	for(;;){

 		putc('\n', sysout);

-		princ(eval(star, nil));

+		lprint(eval(star, nil));

 		putc('\n', sysout);

 		e = readsxp();

 		if(e == noval)

--- a/lisp.h

+++ b/lisp.h

@@ -81,6 +81,7 @@

 		fixnum fix;

 		flonum flo;

+		char *str;

 	};

 };

@@ -91,7 +92,8 @@

 	CAR_ATOM = 2,

 	CAR_FIX  = 4,

 	CAR_FLO  = 8,

-	CAR_NUM  = CAR_FIX | CAR_FLO

+	CAR_NUM  = CAR_FIX | CAR_FLO,

+	CAR_STR = 16

 };

@@ -179,6 +181,7 @@

 int flonump(C *c);

 int numberp(C *c);

 int listp(C *c);

+int stringp(C *c);

 fixnum length(C *c);

 C *get(C *l, C *p);

 C *assq(C *x, C *y);

@@ -188,7 +191,7 @@

 C *readsxp(void);

 void lprint(C *c);

 void princ(C *c);

-void printatom(C *c, void (*pnm)(C *c));

+void printatom(C *c, int x);

 C *eval(C *form, C *a);

 C *evlis(C *m, C *a);

 C *apply(C *fn, C *args, C *a);

--- a/mem.c

+++ b/mem.c

@@ -30,7 +30,7 @@

 		a = c->a;

 		c->ap |= CAR_MARK;

 		if(c->ap & CAR_ATOM){

-			if(c->ap & CAR_NUM)

+			if(c->ap & (CAR_NUM|CAR_STR))

 				return;

 		}else

 			mark(a);

@@ -64,6 +64,11 @@

 		if(c->ap & CAR_MARK)

 			c->ap &= ~CAR_MARK;

 		else{

+			if(c->ap & CAR_ATOM){

+				/* special handling for atoms */

+				if(c->ap & CAR_STR)

+					free(c->str);

+			}

 			c->a = nil;

 			c->d = fclist;

 			fclist = c;

--- a/subr.c

+++ b/subr.c

@@ -6,9 +6,17 @@

 	return fabs(x-y) < 0.000003;

 }

+typedef int (*Eql)(C *a, C *b);

+

 int

+eq(C *a, C *b)

+{

+	return a == b;

+}

+int

 equal(C *a, C *b)

 {

+tail:

 	if(atom(a) != atom(b))

 		return 0;

 	if(atom(a)){

@@ -18,10 +26,16 @@

 		if(flonump(a))

 			return flonump(b) &&

 				floeq(a->flo, b->flo);

+		if(stringp(a))

+			return stringp(b) &&

+				strcmp(a->str, b->str) == 0;

 		return a == b;

 	}

-	return equal(a->a, b->a)

-		&& equal(a->d, b->d);

+	if(!equal(a->a, b->a))

+		return 0;

+	a = a->d;

+	b = b->d;

+	goto tail;

 }

 /* this is a bit ugly... */

@@ -59,6 +73,9 @@

 C *numberp_subr(void){

 	return numberp(alist[0]) ? t : nil;

 }

+C *stringp_subr(void){

+	return stringp(alist[0]) ? t : nil;

+}

 /* Basics */

@@ -191,26 +208,18 @@

 C *length_subr(void){

 	return mkfix(length(alist[0]));

 }

-C *member_subr(void){

+C *member_aux(Eql cmp){

 	C *l;

 	for(l = alist[1]; l != nil; l = l->d){

 		if(atom(l))

 			err("error: no list");

-		if(equal(l->a, alist[0]))

+		if(cmp(l->a, alist[0]))

 			return t;

 	}

 	return nil;

 }

-C *memq_subr(void){

-	C *l;

-	for(l = alist[1]; l != nil; l = l->d){

-		if(atom(l))

-			err("error: no list");

-		if(l->a == alist[0])

-			return t;

-	}

-	return nil;

-}

+C *member_subr(void){ return member_aux(equal); }

+C *memq_subr(void){ return member_aux(eq); }

 C *null_subr(void){

 	return alist[0] == nil ? t : nil;

 }

@@ -227,7 +236,7 @@

 	return cons(alist[1], alist[0]);

 }

 C *list_fsubr(void){

-	return evlis(alist[0], alist[1]) ;

+	return evlis(alist[0], alist[1]);

 }

 C *append_subr(void){

 	C *l, **p;

@@ -296,7 +305,29 @@

 	}

 	return last;

 }

+C *delete_aux(Eql cmp){

+	C **p;

+	fixnum n;

+	if(largs.nargs < 2)

+		err("error: arg count");

+	n = -1;

+	if(largs.nargs > 2)

+		n = largs.alist[3]->fix;

+	for(p = &largs.alist[2]; *p != nil; p = &(*p)->d){

+		if(atom(*p))

+			err("error: no list");

+		if(cmp((*p)->a, largs.alist[1])){

+			if(n-- == 0)

+				break;

+			*p = (*p)->d;

+		}

+	}

+	return largs.alist[2];

+}

+C *delete_lsubr(void){ return delete_aux(equal); }

+C *delq_lsubr(void){ return delete_aux(eq); }

+

 /* Boolean logic */

 C *and_fsubr(void){

@@ -376,13 +407,6 @@

 C *get_subr(void){

 	return get(alist[0], alist[1]);

-/*

-	C *l;

-	for(l = alist[0]; l != nil; l = l->d)

-		if(l->a == alist[1])

-			return l->d->a;

-	return nil;

-*/

 }

 C *putprop_subr(void){

 	return putprop(alist[0], alist[1], alist[2]);

@@ -785,86 +809,67 @@

 /* Mapping */

-C *maplist_subr(void){

-	C *l, *c, **p;

-	p = push(nil);

-	for(l = alist[1]; l != nil; l = l->d){

-		push(c = cons(l, nil));

-		c->a = apply(alist[0], c, nil);

-		c->d = nil;

-		*p = pop();

-		p = &(*p)->d;

+/* zip is for internal use.

+ * It returns successively zipped lists for mapping

+ * leaving the list on the stack. */

+static int

+zip(C *(*f)(C*))

+{

+	int i;

+	C **ap;

+	ap = push(nil);

+	for(i = 2; i <= largs.nargs; i++){

+		if(largs.alist[i] == nil){

+			pop();

+			return 1;

+		}

+		*ap = cons(f(largs.alist[i]), nil);

+		ap = &(*ap)->d;

+		largs.alist[i] = largs.alist[i]->d;

 	}

-	return pop();

+	return 0;

 }

-C *mapcar_subr(void){

-	C *l, *c, **p;

+C *id(C *c) { return c; }

+static int ziplist(void){ return zip(id); }

+static int zipcar(void){ return zip(car); }

+

+C *maplist_aux(int (*zip)(void)){

+	C **p;

+	if(largs.nargs < 2)

+		err("error: arg count");

 	p = push(nil);

-	for(l = alist[1]; l != nil; l = l->d){

-		push(c = cons(l->a, nil));

-		c->a = apply(alist[0], c, nil);

-		c->d = nil;

-		*p = pop();

+	while(!zip()){

+		*p = cons(apply(largs.alist[1], pop(), nil), nil);

 		p = &(*p)->d;

 	}

 	return pop();

 }

-C *map_subr(void){

-	C *l, *a;

-	push(a = cons(nil, nil));

-	for(l = alist[1]; l != nil; l = l->d){

-		a->a = l;

-		a->d = nil;

-		apply(alist[0], a, nil);

-	}

-	pop();

+C *maplist_lsubr(void){ return maplist_aux(ziplist); }

+C *mapcar_lsubr(void){ return maplist_aux(zipcar); }

+C *map_aux(int (*zip)(void)){

+	if(largs.nargs < 2)

+		err("error: arg count");

+	while(!zip())

+		apply(largs.alist[1], pop(), nil);

 	return nil;

 }

-C *mapc_subr(void){

-	C *l, *a;

-	push(a = cons(nil, nil));

-	for(l = alist[1]; l != nil; l = l->d){

-		a->a = l->a;

-		a->d = nil;

-		apply(alist[0], a, nil);

-	}

-	pop();

-	return nil;

-}

-C *mapcon_subr(void){

-	C *l, *a, **p;

+C *map_lsubr(void){ return map_aux(ziplist); }

+C *mapc_lsubr(void){ return map_aux(zipcar); }

+C *mapcon_aux(int (*zip)(void)){

+	C **p;

+	if(largs.nargs < 2)

+		err("error: arg count");

 	p = push(nil);

-	push(a = cons(nil, nil));

-	for(l = alist[1]; l != nil; l = l->d){

-		a->a = l;

-		a->d = nil;

-		*p = apply(alist[0], a, nil);

-		if(*p == nil)

-			err("error: nil in mapcon");

+	while(!zip()){

+		*p = apply(largs.alist[1], pop(), nil);

 		for(; *p != nil; p = &(*p)->d)

 			if(atom(*p))

 				err("error: no list");

 	}

-	pop();

 	return pop();

 }

-C *mapcan_subr(void){

-	C *l, *a, **p;

-	p = push(nil);

-	push(a = cons(nil, nil));

-	for(l = alist[1]; l != nil; l = l->d){

-		a->a = l->a;

-		a->d = nil;

-		*p = apply(alist[0], a, nil);

-		if(*p == nil)

-			err("error: nil in mapcon");

-		for(; *p != nil; p = &(*p)->d)

-			if(atom(*p))

-				err("error: no list");

-	}

-	pop();

-	return pop();

-}

+C *mapcon_lsubr(void){ return mapcon_aux(ziplist); }

+C *mapcan_lsubr(void){ return mapcon_aux(zipcar); }

 /* IO */

@@ -890,64 +895,6 @@

 }

-/*

- * LISP 1.5 leftover

- */

-

-C *attrib_subr(void){

-	C *l;

-	for(l = alist[0]; l != nil; l = l->d){

-//		if(atom(l))	// have to allow this for p-lists

-		if(numberp(l))

-			err("error: no list");

-		if(l->d == nil){

-			l->d = alist[1];

-			break;

-		}

-	}

-	return alist[1];

-}

-C *prop_subr(void){

-	C *l;

-	for(l = alist[0]; l != nil; l = l->d)

-		if(l->a == alist[1])

-			return l->d;

-	return apply(alist[2], nil, nil);

-}

-C *pair_subr(void){

-	return pair(alist[0], alist[1]);

-}

-C *copy_subr(void){

-	C *l, **p;

-	assert(temlis.a == nil);

-	p = (C**)&temlis.a;

-	for(l = alist[0]; l != nil; l = l->d){

-		if(atom(l))

-			err("error: no list");

-		*p = cons(l->a, nil);

-		p = &(*p)->d;

-	}

-	l = temlis.a;

-	temlis.a = nil;

-	return l;

-}

-C *efface_subr(void){

-	C *l, **p;

-	p = &alist[1];

-	for(l = alist[1]; l != nil; l = l->d){

-		if(atom(l))

-			err("error: no list");

-		if(equal(l->a, alist[0])){

-			*p = l->d;

-			break;

-		}

-		p = &(*p)->d;

-	}

-	return alist[1];

-}

-

-

-

 /* Prog feature */

 Prog prog;

@@ -1035,6 +982,7 @@

 	SUBR("FIXP", fixp_subr, 1)

 	SUBR("FLOATP", floatp_subr, 1)

 	SUBR("NUMBERP", numberp_subr, 1)

+	SUBR("STRINGP", stringp_subr, 1)

 	SUBR("APPLY", apply_subr, 3)

 	SUBR("EVAL", eval_subr, 2)

@@ -1099,6 +1047,8 @@

 	SUBR("RPLACD", rplacd_subr, 2)

 	SUBR("NCONC", nconc_subr, 2)

 	SUBR("NREVERSE", nreverse_subr, 1)

+	LSUBR("DELETE", delete_lsubr)

+	LSUBR("DELQ", delq_lsubr)

 	FSUBR("AND", and_fsubr)

 	FSUBR("OR", or_fsubr)

@@ -1138,12 +1088,12 @@

 	LSUBR("LOGXOR", logxor_lsubr)

 	SUBR("LSH", lsh_subr, 2)

-	SUBR("MAPLIST", maplist_subr, 2)

-	SUBR("MAPCAR", mapcar_subr, 2)

-	SUBR("MAP", map_subr, 2)

-	SUBR("MAPC", mapc_subr, 2)

-	SUBR("MAPCON", mapcon_subr, 2)

-	SUBR("MAPCAN", mapcan_subr, 2)

+	LSUBR("MAPLIST", maplist_lsubr)

+	LSUBR("MAPCAR", mapcar_lsubr)

+	LSUBR("MAP", map_lsubr)

+	LSUBR("MAPC", mapc_lsubr)

+	LSUBR("MAPCON", mapcon_lsubr)

+	LSUBR("MAPCAN", mapcan_lsubr)

 	SUBR("READ", read_subr, 0)

 	SUBR("PRIN1", prin1_subr, 1)

@@ -1150,13 +1100,4 @@

 	SUBR("PRINT", print_subr, 1)

 	SUBR("PRINC", princ_subr, 1)

 	SUBR("TERPRI", terpri_subr, 0)

-

-

-

-

-	SUBR("ATTRIB", attrib_subr, 2)

-	SUBR("PROP", prop_subr, 3)

-	SUBR("PAIR", pair_subr, 2)

-	SUBR("COPY", copy_subr, 1)

-	SUBR("EFFACE", efface_subr, 2)

 }

-- 

⑨