Improved error reports in records.procedural as per Derick

Eddington's suggestions and removed the record-name check for
non-generative records.

doc/ikarus-scheme-users-guide.tex

@@ -820,7 +820,7 @@ you need to specify that explicitly as in the following example.
 This definition gives us, in addition to the constructor, predicate,
 and accessors, two additional procedures:
 \begin{itemize}
-\item The mutators \texttt{set-point-x!} and \texttt{set-point-y!} that,
+\item The mutators \texttt{point-x-set!} and \texttt{point-y-set!} that,
 given a record of type point, and a new value, sets the value stored in the
 \texttt{x} field or \texttt{y} field to the new value.
 \end{itemize}

scheme/ikarus.records.procedural.ss

@@ -54,16 +54,14 @@
                 (not (rtd-opaque? rtd))))))
 
   (define (record-rtd x)
-    (define (err x)
-      (error 'record-rtd "not a record" x))
     (if ($struct? x)
         (let ([rtd ($struct-rtd x)])
           (if (rtd? rtd)
               (if (not (rtd-opaque? rtd))
                   rtd
-                  (err x))
+                  (error 'record-rtd "record is opaque"))
-              (err x)))
+              (error 'record-rtd "not a record" x)))
-        (err x)))
+        (error 'record-rtd "not a record" x)))
 
   (define (record-type-name x)
     (if (rtd? x)
@@ -179,7 +177,8 @@
           [(lookup-rtd uid) =>
            (lambda (rtd) 
              (unless
-               (and (eqv? name (rtd-name rtd))
+               (and ; must not check name!
+                    ; (eqv? name (rtd-name rtd)) 
                     (eqv? parent (rtd-parent rtd))
                     (eqv? sealed? (rtd-sealed? rtd))
                     (eqv? opaque? (rtd-opaque? rtd))

scheme/ikarus.sort.ss

@@ -20,65 +20,68 @@
     (ikarus system $fx)
     (except (ikarus) list-sort vector-sort vector-sort!))
   
-
+  (module (sort-tail)
-  (define (merge1 <? a1 ls1 ls2) 
+    (define (merge1 <? a1 ls1 ls2) 
-    (cond
+      (cond
-      [(null? ls2) ls1]
+        [(null? ls2) ls1]
-      [else
+        [else
-       (let ([a2 (car ls2)])
+         (let ([a2 (car ls2)])
-         (cond
+           (cond
-           [(<? a2 a1) 
+             [(<? a2 a1) 
-            (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
+              (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
-           [else
+             [else
-            (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
+              (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
+    
+    (define (merge2 <? a2 ls1 ls2) 
+      (cond
+        [(null? ls1) ls2]
+        [else
+         (let ([a1 (car ls1)])
+           (cond
+             [(<? a2 a1) 
+              (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
+             [else
+              (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
   
-  (define (merge2 <? a2 ls1 ls2) 
+    (define (merge <? ls1 ls2) 
-    (cond
+      (cond
-      [(null? ls1) ls2]
+        [(null? ls2) ls1]
-      [else
+        [else 
-       (let ([a1 (car ls1)])
+         (let ([a1 (car ls1)] [a2 (car ls2)])
-         (cond
+           (cond
-           [(<? a2 a1) 
+             [(<? a2 a1) 
-            (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
+              (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
-           [else
+             [else
-            (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
+              (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
-
+  
-  (define (merge <? ls1 ls2) 
+    (define (sort-head <? ls n)
-    (cond
+      (cond
-      [(null? ls2) ls1]
+        [($fx= n 0) (values '() ls)]
-      [else 
+        [($fx= n 1)
-       (let ([a1 (car ls1)] [a2 (car ls2)])
+         (values (cons (car ls) '()) (cdr ls))]
-         (cond
+        [else
-           [(<? a2 a1) 
+         (let-values ([(sorted-head tail) 
-            (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
+                       (sort-head <? ls ($fxsra n 1))])
-           [else
+           (let-values ([(sorted-tail tail) 
-            (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
+                         (sort-head <? tail ($fx- n ($fxsra n 1)))])
-
+             (values (merge <? sorted-head sorted-tail) tail)))]))
-  (define (sort-head <? ls n)
+  
-    (cond
+    (define (sort-tail <? ls n) 
-      [($fx= n 0) (values '() ls)]
+      (cond
-      [($fx= n 1)
+        [($fx<= n 1) ls]
-       (values (cons (car ls) '()) (cdr ls))]
+        [else
-      [else
+         (let-values ([(sorted-head tail) 
-       (let-values ([(sorted-head tail) 
+                       (sort-head <? ls ($fxsra n 1))])
-                     (sort-head <? ls ($fxsra n 1))])
+            (merge <? sorted-head 
-         (let-values ([(sorted-tail tail) 
+              (sort-tail <? tail ($fx- n ($fxsra n 1)))))])))
-                       (sort-head <? tail ($fx- n ($fxsra n 1)))])
-           (values (merge <? sorted-head sorted-tail) tail)))]))
-
-  (define (sort-tail <? ls n) 
-    (cond
-      [($fx<= n 1) ls]
-      [else
-       (let-values ([(sorted-head tail) 
-                     (sort-head <? ls ($fxsra n 1))])
-          (merge <? sorted-head (sort-tail <? tail ($fx- n ($fxsra n 1)))))]))
 
   (define (list-sort <? ls) 
     (unless (procedure? <?)
       (error 'list-sort "not a procedure" <?))
     (sort-tail <? ls (length ls)))
 
+
+
   (define (vector-sort <? v)
     ;;; FIXME: improve
     (unless (procedure? <?)
@@ -89,6 +92,8 @@
       (sort-tail <? (vector->list v) (vector-length v))))
 
   (define (vector-sort! <? v) 
+    (import (ikarus system $vectors))
+    (import (ikarus system $pairs))
     (unless (procedure? <?)
       (error 'vector-sort! "not a procedure" <?))
     (unless (vector? v)
@@ -96,8 +101,8 @@
     (let f ([i 0] [v v] 
             [ls (sort-tail <? (vector->list v) (vector-length v))])
       (unless (null? ls) 
-        (vector-set! v i (car ls))
+        ($vector-set! v i ($car ls))
-        (f (fx+ i 1) v (cdr ls)))))
+        (f ($fx+ i 1) v ($cdr ls)))))
     
   )
 

scheme/last-revision

@@ -1 +1 @@
-1160
+1162

scheme/pass-specify-rep-primops.ss

@@ -60,19 +60,20 @@
          (dirty-vector-set addr))]
     [else (dirty-vector-set addr)]))
 
-(define (mem-assign v x i)
+
+(define (slow-mem-assign v x i)
   (with-tmp ([t (prm 'int+ x (K i))])
     (make-seq 
       (prm 'mset t (K 0) (T v))
       (dirty-vector-set t))))
 
-(define (smart-mem-assign what v x i)
+(define (mem-assign v x i)
-  (struct-case what
+  (struct-case v
     [(constant t) 
      (if (or (fixnum? t) (immediate? t))
-         (prm 'mset x (K i) v)
+         (prm 'mset x (K i) (T v))
-         (mem-assign v x i))]
+         (slow-mem-assign v x i))]
-    [else (mem-assign v x i)]))
+    [else (slow-mem-assign v x i)]))
 
 (define (align-code unknown-amt known-amt)
   (prm 'sll