shithub: mlisp

Download patch

ref: 17bd705b9375def88831e9e10f64618b98831b75
parent: 442728dece582ebc742f771362acf4ea861a812f
author: aap <aap@papnet.eu>
date: Sun Aug 21 11:41:01 EDT 2022 

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)
 }