misc tweaks

svn: r2495

src/mzscheme/src/print.c

@@ -2360,7 +2360,8 @@ print_pair(Scheme_Object *pair, int notdisplay, int compact,
 	  /* This needs a tag */
 	  break;
 	}
-      }cdr = SCHEME_CDR(cdr);
+      }
+      cdr = SCHEME_CDR(cdr);
     }
     if (SCHEME_NULLP(cdr)) {
       /* Proper list without sharing. */

src/mzscheme/src/regexp.c

@@ -1660,6 +1660,8 @@ regmatch(Regwork *rw, rxpos prog)
 	case CLOSEN:
 	  isopen = 0;
 	  no = OPLEN(OPERAND(scan));
+	  if (!no)
+	    no = -1; /* => don't set in result array */
 	  break;
 	default:
 	  if (OP(scan) < CLOSE) {
@@ -1671,36 +1673,40 @@ regmatch(Regwork *rw, rxpos prog)
 	  }
 	}
 
-	save = rw->input;
+	if (no < 0) {
-
+	  /* No need to recur */
-	if (isopen) {
-	  if (regmatch(rw, next)) {
-	    if (no >= 0) {
-	      /*
-	       * Don't set startp if some later
-	       * invocation of the same parentheses
-	       * already has.
-	       */
-	      if (rw->startp[no] == -1)
-		rw->startp[no] = save;
-	    }
-	    return(1);
-	  } else
-	    return(0);
 	} else {
-	  if (regmatch(rw, next)) {
+	  save = rw->input;
-	    if (no >= 0) {
+
-	      /*
+	  if (isopen) {
-	       * Don't set endp if some later
+	    if (regmatch(rw, next)) {
-	       * invocation of the same parentheses
+	      if (no >= 0) {
-	       * already has.
+		/*
-	       */
+		 * Don't set startp if some later
-	      if (rw->endp[no] == -1)
+		 * invocation of the same parentheses
-		rw->endp[no] = save;
+		 * already has.
-	    }
+		 */
-	    return(1);
+		if (rw->startp[no] == -1)
-	  } else
+		  rw->startp[no] = save;
-	    return(0);
+	      }
+	      return(1);
+	    } else
+	      return(0);
+	  } else {
+	    if (regmatch(rw, next)) {
+	      if (no >= 0) {
+		/*
+		 * Don't set endp if some later
+		 * invocation of the same parentheses
+		 * already has.
+		 */
+		if (rw->endp[no] == -1)
+		  rw->endp[no] = save;
+	      }
+	      return(1);
+	    } else
+	      return(0);
+	  }
 	}
       }
       break;
@@ -2502,7 +2508,7 @@ static Scheme_Object *do_make_regexp(const char *who, int is_byte, int argc, Sch
       for (i = 0; i < slen; i++) {
 	if (!cp[i]) cp[i] = '0';
       } 
-      printf("%d %s\n", slen, cp);
+      printf("%d %s\n", slen, scheme_write_to_string(scheme_make_byte_string(cp), 0));
     }
 #endif
   }

src/mzscheme/src/salloc.c

@@ -986,7 +986,11 @@ void scheme_print_tagged_value(const char *prefix,
   scheme_check_print_is_obj = check_home;
 
   if (!xtagged) {
-    type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w);
+    if (SCHEME_PAIRP(v)) {
+      /* Pairs are used for all sorts of non-Scheme values: */
+      type ="#<pair>";
+    } else
+      type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w);
     if (!scheme_strncmp(type, "#<thread", 8) 
 	&& ((type[8] == '>') || (type[8] == ':'))) {
       char buffer[256];

src/mzscheme/src/startup.inc

@@ -98,10 +98,12 @@
 " #f)))"
 "(define-values(append/#f)"
 "(lambda(l1 l2)"
+"(if l1"
 "(if l2"
 "(if(null? l2)"
 " l1"
 "(append l1 l2))"
+" #f)"
 " #f)))"
 "(define-values(stx-rotate)"
 "(lambda(l)"
@@ -1009,10 +1011,7 @@
 "(pair?(cdr e1))"
 "(null?(cddr e1)))"
 " `(cons/#f ,(cadr e1) ,e2)"
-" `(let((v ,e1))"
+" `(append/#f ,e1 ,e2)))"
-"(if v"
-"(append/#f v ,e2)"
-" #f))))"
 "(-define(make-pexpand p proto-r k dest)"
 "(-define top p)"
 "(-define(expander p proto-r local-top use-ellipses? use-tail-pos hash!)"

src/mzscheme/src/startup.ss

@@ -160,15 +160,17 @@
 	  (cons i l)
 	  #f)))
 
-  ;; used in pattern-matching where the second
+  ;; used in pattern-matching where either
   ;;  list can be a failure; if it's null, the first
   ;;  part might be an improper list
   (define-values (append/#f)
     (lambda (l1 l2)
-      (if l2
+      (if l1
-	  (if (null? l2)
+	  (if l2
-	      l1
+	      (if (null? l2)
-	      (append l1 l2))
+		  l1
+		  (append l1 l2))
+	      #f)
 	  #f)))
 
   ;; The rotate procedures are used to
@@ -1209,10 +1211,7 @@
 	     (pair? (cdr e1))
 	     (null? (cddr e1)))
 	`(cons/#f ,(cadr e1) ,e2)
-	`(let ([v ,e1])
+	`(append/#f ,e1 ,e2)))
-	   (if v
-	       (append/#f v ,e2)
-	       #f))))
 
   ;; ----------------------------------------------------------------------
   ;; Output generator

src/mzscheme/src/struct.c

@@ -584,7 +584,7 @@ static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *p
   return scheme_false;
 }
 
-static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg, int error_ok)
+static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg, int error_ok, const char *name)
 {
   Scheme_Struct_Type *stype;
 
@@ -611,7 +611,7 @@ static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg,
   }
   
   if (error_ok) /* hack; see scheme_struct_type_property_ref */
-    scheme_wrong_type("property accessor", 
+    scheme_wrong_type(name ? name : "property accessor", 
 		      "struct or struct-type with property", 
 		      0, 1, (Scheme_Object **)&arg);
   return NULL;
@@ -619,7 +619,8 @@ static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg,
 
 static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
-  return do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0], 1);
+  return do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0], 1, 
+			  ((Scheme_Primitive_Proc *)prim)->name);
 }
 
 static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
@@ -689,7 +690,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
 
 Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
 {
-  return do_prop_accessor(prop, s, 0);
+  return do_prop_accessor(prop, s, 0, NULL);
 }
 
 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[])