fix printing of mpairs, and improve print-object code a little

svn: r11139

collects/swindle/extra.ss

@@ -461,49 +461,50 @@
 (define printer:too-deep "#?#")
 (define printer:too-long "...")
 
+;; use a single implementation for both pairs and mpairs, punctuation
+;; shorthands for pairs only
 (defmethod (print-object [o <pair>] esc? port)
-  (cond
+  (let ([punct (and (pair? (cdr o)) (null? (cddr o))
-   [(null? o) (mz:display "()" port)]
+                    (assq (car o)
-   [(and (pair? (cdr o)) (null? (cddr o))
+                          '([quote "'"] [quasiquote "`"] [unquote ","]
-         (memq (car o) '(quote quasiquote unquote unquote-splicing
+                            [unquote-splicing ",@"]
-                               syntax quasisyntax unsyntax unsyntax-splicing)))
+                            [syntax "#'"] [quasisyntax "#`"] [unsyntax "#,"]
-    (mz:display (case (car o)
+                            [unsyntax-splicing "#,@"])))])
-                  [(quote)             "'"]
+    (if punct
-                  [(quasiquote)        "`"]
+      (begin (mz:display (cadr punct) port) (print-object (cadr o) esc? port))
-                  [(unquote)           ","]
+      (print-pair o esc? port "(" ")" pair? car cdr))))
-                  [(unquote-splicing)  ",@"]
+(defmethod (print-object [o <mutable-pair>] esc? port)
-                  [(syntax)            "#'"]
+  (print-pair o esc? port "{" "}" mpair? mcar mcdr))
-                  [(quasisyntax)       "#`"]
+(define (print-pair p esc? port open close pair? car cdr)
-                  [(unsyntax)          "#,"]
+  (define level (*print-level*))
-                  [(unsyntax-splicing) "#,@"])
+  (if (eq? level 0)
-                port)
+    (mz:display printer:too-deep port)
-    (print-object (cadr o) esc? port)]
+    (begin
-   [(eq? (*print-level*) 0) (mz:display printer:too-deep port)]
+      (mz:display open port)
-   [else
-    (mz:display "(" port)
       (if (eq? (*print-length*) 0)
         (mz:display printer:too-long port)
-      (parameterize ([*print-level* (sub1 (or (*print-level*) 0))])
+        (parameterize ([*print-level* (and level (sub1 level))])
-        (print-object (car o) esc? port)
+          (print-object (car p) esc? port)
-        (do ([o (cdr o) (if (pair? o) (cdr o) '())]
+          (do ([p (cdr p) (if (pair? p) (cdr p) '())]
                [n (sub1 (or (*print-length*) 0)) (sub1 n)])
-            [(or (null? o)
+              [(or (null? p)
                    (and (zero? n)
                         (begin (mz:display " " port)
                                (mz:display printer:too-long port)
                                #t)))]
-          (if (pair? o)
+            (if (pair? p)
-            (begin (mz:display " " port) (print-object (car o) esc? port))
+              (begin (mz:display " " port) (print-object (car p) esc? port))
-            (begin (mz:display " . " port) (print-object o esc? port))))))
+              (begin (mz:display " . " port) (print-object p esc? port))))))
-    (mz:display ")" port)]))
+      (mz:display close port))))
 
 (defmethod (print-object [o <vector>] esc? port)
-  (cond [(eq? (*print-level*) 0) (mz:display printer:too-deep port)]
+  (define level (*print-level*))
+  (cond [(eq? level 0) (mz:display printer:too-deep port)]
         [(zero? (vector-length o)) (mz:display "#()" port)]
         [else (mz:display "#(" port)
               (if (eq? (*print-length*) 0)
                 (mz:display printer:too-long port)
-                (parameterize ([*print-level* (sub1 (or (*print-level*) 0))])
+                (parameterize ([*print-level* (and level (sub1 level))])
                   (print-object (vector-ref o 0) esc? port)
                   (let ([len (if (*print-length*)
                                (min (vector-length o) (*print-length*))
@@ -546,13 +547,14 @@
 ;;>   which should be embedded in a method that is to be added to
 ;;>   `print-object'.
 (define* (print-object-with-slots o esc? port)
-  (if (eq? (*print-level*) 0)
+  (define level (*print-level*))
+  (if (eq? level 0)
     (mz:display printer:too-deep port)
     (let ([class (class-of o)])
       (mz:display "#<" port)
       (mz:display (name-sans-<> (class-name class)) port)
       (mz:display ":" port)
-      (parameterize ([*print-level* (sub1 (or (*print-level*) 0))])
+      (parameterize ([*print-level* (and level (sub1 level))])
         (do ([s (class-slots class) (cdr s)]
              [n (or (*print-length*) -1) (sub1 n)])
             [(or (null? s)

collects/swindle/tiny-clos.ss

@@ -1915,6 +1915,7 @@
 ;;>> <immutable>
 ;;>> <pair>
 ;;>> <mutable-pair>
+;;>> <mpair>
 ;;>> <immutable-pair>
 ;;>> <list>
 ;;>> <nonempty-list>
@@ -2002,6 +2003,7 @@
 (defprimclass <immutable>)
 (defprimclass <pair> <sequence>)
 (defprimclass <mutable-pair> <pair> <mutable>)
+(define* <mpair> <mutable-pair>) ; alias
 (defprimclass <immutable-pair> <pair> <immutable>)
 (defprimclass <list> <sequence>)
 (defprimclass <nonempty-list> <pair> <list> <immutable>)
@@ -2204,6 +2206,7 @@
 ;;>       <sequence> : <primitive-class>
 ;;>         <pair> : <primitive-class>
 ;;>           <mutable-pair> : <primitive-class>
+;;>           <mpair> : <primitive-class>  ; alias for <mutable-pair>
 ;;>           <immutable-pair> : <primitive-class>
 ;;>           <nonempty-list> : <primitive-class>
 ;;>         <list> : <primitive-class>
@@ -2220,6 +2223,7 @@
 ;;>           <path> : <primitive-class>
 ;;>       <mutable> : <primitive-class>
 ;;>         <mutable-pair> : <primitive-class>
+;;>         <mpair> : <primitive-class>  ; alias for <mutable-pair>
 ;;>         <mutable-string-like> : <primitive-class>
 ;;>           <mutable-string> : <primitive-class>
 ;;>           <mutable-bytes> : <primitive-class>