Merge pull request #881 from gambiteer/master

Add, test, and document *vector-swap! and string-swap!
gambit · Jan 27, 2024 · 2cb4737 · 2cb4737
2 parents fe72401 + 9684450
commit 2cb4737
Show file tree

Hide file tree

Showing 25 changed files with 347 additions and 0 deletions.
diff --git a/doc/gambit.txi b/doc/gambit.txi
@@ -4048,6 +4048,25 @@ For example:
 
 @end deffn
 
+@deffn procedure vector-swap! @var{vector} @var{i} @var{j}
+
+The procedure @code{vector-swap!} swaps the elements at index @var{i}
+and index @var{j} of the vector @var{vector}.
+
+For example:
+
+@smallexample
+> @b{(define v1 (vector 0 1 2 3 4))}
+> @b{v1}
+#(0 1 2 3 4)
+> @b{(vector-swap! v1 0 4)}
+> @b{v1}
+#(4 1 2 3 0)
+@end smallexample
+
+@end deffn
+
+
 @deffn procedure string-set @var{string} @var{k} @var{char}
 
 The procedure @code{string-set} returns a new copy of the string
@@ -4067,6 +4086,24 @@ For example:
 
 @end deffn
 
+@deffn procedure string-swap! @var{string} @var{i} @var{j}
+
+The procedure @code{string-swap!} swaps the characters at index @var{i}
+and index @var{j} of the string @var{string}.
+
+For example:
+
+@smallexample
+> @b{(define s1 (string #\a #\b #\c #\d #\e))}
+> @b{s1}
+"abcde"
+> @b{(string-swap! s1 0 4)}
+> @b{s1}
+"ebcda"
+@end smallexample
+
+@end deffn
+
 @deffn procedure string-prefix-length @var{s1} @var{s2} @r{[}@var{start1} @r{[}@var{end1} @r{[}@var{start2} @r{[}@var{end2}@r{]}@r{]}@r{]}@r{]}
 @deffnx procedure string-prefix-length-ci @var{s1} @var{s2} @r{[}@var{start1} @r{[}@var{end1} @r{[}@var{start2} @r{[}@var{end2}@r{]}@r{]}@r{]}@r{]}
 
@@ -8552,6 +8589,7 @@ homogeneous vector types.
 @deffnx procedure s8vector-ref @var{s8vector} @var{k}
 @deffnx procedure s8vector-set @var{s8vector} @var{k} @var{exact-int8}
 @deffnx procedure s8vector-set! @var{s8vector} @var{k} @var{exact-int8}
+@deffnx procedure s8vector-swap! @var{s8vector} @var{i} @var{j}
 @deffnx procedure s8vector->list @var{s8vector}
 @deffnx procedure list->s8vector @var{list-of-exact-int8}
 @deffnx procedure s8vector-fill! @var{s8vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8572,6 +8610,7 @@ homogeneous vector types.
 @deffnx procedure u8vector-ref @var{u8vector} @var{k}
 @deffnx procedure u8vector-set @var{u8vector} @var{k} @var{exact-int8}
 @deffnx procedure u8vector-set! @var{u8vector} @var{k} @var{exact-int8}
+@deffnx procedure u8vector-swap! @var{u8vector} @var{i} @var{j}
 @deffnx procedure u8vector->list @var{u8vector}
 @deffnx procedure list->u8vector @var{list-of-exact-int8}
 @deffnx procedure u8vector-fill! @var{u8vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8592,6 +8631,7 @@ homogeneous vector types.
 @deffnx procedure s16vector-ref @var{s16vector} @var{k}
 @deffnx procedure s16vector-set @var{s16vector} @var{k} @var{exact-int16}
 @deffnx procedure s16vector-set! @var{s16vector} @var{k} @var{exact-int16}
+@deffnx procedure s16vector-swap! @var{s16vector} @var{i} @var{j}
 @deffnx procedure s16vector->list @var{s16vector}
 @deffnx procedure list->s16vector @var{list-of-exact-int16}
 @deffnx procedure s16vector-fill! @var{s16vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8612,6 +8652,7 @@ homogeneous vector types.
 @deffnx procedure u16vector-ref @var{u16vector} @var{k}
 @deffnx procedure u16vector-set @var{u16vector} @var{k} @var{exact-int16}
 @deffnx procedure u16vector-set! @var{u16vector} @var{k} @var{exact-int16}
+@deffnx procedure u16vector-swap! @var{u16vector} @var{i} @var{j}
 @deffnx procedure u16vector->list @var{u16vector}
 @deffnx procedure list->u16vector @var{list-of-exact-int16}
 @deffnx procedure u16vector-fill! @var{u16vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8632,6 +8673,7 @@ homogeneous vector types.
 @deffnx procedure s32vector-ref @var{s32vector} @var{k}
 @deffnx procedure s32vector-set @var{s32vector} @var{k} @var{exact-int32}
 @deffnx procedure s32vector-set! @var{s32vector} @var{k} @var{exact-int32}
+@deffnx procedure s32vector-swap! @var{s32vector} @var{i} @var{j}
 @deffnx procedure s32vector->list @var{s32vector}
 @deffnx procedure list->s32vector @var{list-of-exact-int32}
 @deffnx procedure s32vector-fill! @var{s32vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8652,6 +8694,7 @@ homogeneous vector types.
 @deffnx procedure u32vector-ref @var{u32vector} @var{k}
 @deffnx procedure u32vector-set @var{u32vector} @var{k} @var{exact-int32}
 @deffnx procedure u32vector-set! @var{u32vector} @var{k} @var{exact-int32}
+@deffnx procedure u32vector-swap! @var{u32vector} @var{i} @var{j}
 @deffnx procedure u32vector->list @var{u32vector}
 @deffnx procedure list->u32vector @var{list-of-exact-int32}
 @deffnx procedure u32vector-fill! @var{u32vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8672,6 +8715,7 @@ homogeneous vector types.
 @deffnx procedure s64vector-ref @var{s64vector} @var{k}
 @deffnx procedure s64vector-set @var{s64vector} @var{k} @var{exact-int64}
 @deffnx procedure s64vector-set! @var{s64vector} @var{k} @var{exact-int64}
+@deffnx procedure s64vector-swap! @var{s64vector} @var{i} @var{j}
 @deffnx procedure s64vector->list @var{s64vector}
 @deffnx procedure list->s64vector @var{list-of-exact-int64}
 @deffnx procedure s64vector-fill! @var{s64vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8692,6 +8736,7 @@ homogeneous vector types.
 @deffnx procedure u64vector-ref @var{u64vector} @var{k}
 @deffnx procedure u64vector-set @var{u64vector} @var{k} @var{exact-int64}
 @deffnx procedure u64vector-set! @var{u64vector} @var{k} @var{exact-int64}
+@deffnx procedure u64vector-swap! @var{u64vector} @var{i} @var{j}
 @deffnx procedure u64vector->list @var{u64vector}
 @deffnx procedure list->u64vector @var{list-of-exact-int64}
 @deffnx procedure u64vector-fill! @var{u64vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8712,6 +8757,7 @@ homogeneous vector types.
 @deffnx procedure f32vector-ref @var{f32vector} @var{k}
 @deffnx procedure f32vector-set @var{f32vector} @var{k} @var{inexact-real}
 @deffnx procedure f32vector-set! @var{f32vector} @var{k} @var{inexact-real}
+@deffnx procedure f32vector-swap! @var{f32vector} @var{i} @var{j}
 @deffnx procedure f32vector->list @var{f32vector}
 @deffnx procedure list->f32vector @var{list-of-inexact-real}
 @deffnx procedure f32vector-fill! @var{f32vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}
@@ -8732,6 +8778,7 @@ homogeneous vector types.
 @deffnx procedure f64vector-ref @var{f64vector} @var{k}
 @deffnx procedure f64vector-set @var{f64vector} @var{k} @var{inexact-real}
 @deffnx procedure f64vector-set! @var{f64vector} @var{k} @var{inexact-real}
+@deffnx procedure f64vector-swap! @var{f64vector} @var{i} @var{j}
 @deffnx procedure f64vector->list @var{f64vector}
 @deffnx procedure list->f64vector @var{list-of-inexact-real}
 @deffnx procedure f64vector-fill! @var{f64vector} @var{fill} @r{[}@var{start} @r{[}@var{end}@r{]}@r{]}

diff --git a/lib/_std#.scm b/lib/_std#.scm
@@ -351,6 +351,7 @@
     (define prim-vect-set!-fixnum  (sym "##" name '-set!-fixnum))
     (define prim-vect-set          (sym "##" name '-set))
     (define prim-vect-set-small    (sym "##" name '-set-small))
+    (define prim-vect-swap!        (sym "##" name '-swap!))
     (define prim-vect->list        (sym "##" name '->list))
     (define prim-list->vect        (sym '##list-> name))
     (define prim-vect-copy         (sym "##" name '-copy))
@@ -381,6 +382,7 @@
     (define vect-set!-fixnum       (sym name '-set!-fixnum))
     (define vect-set               (sym name '-set))
     (define vect-set-small         (sym name '-set-small))
+    (define vect-swap!             (sym name '-swap!))
     (define vect->list             (sym name '->list))
     (define list->vect             (sym 'list-> name))
     (define vect->string           (sym name '->string))
@@ -556,6 +558,25 @@
                                   (,elem-name ,elem-type))
                  (,prim-vect-set ,name k ,elem-name))))
 
+       (define-primitive (,vect-swap! ,name i j)
+         (let ((temp (,prim-vect-ref ,name i)))
+           (,prim-vect-set! ,name i (,prim-vect-ref ,name j))
+           (,prim-vect-set! ,name j temp)
+           ,name))
+
+       ,@(if (memq name '(values))
+             '()
+             `((define-procedure (,vect-swap!
+                                  (,name ,name)
+                                  (i (index-range
+                                      0
+                                      (,prim-vect-length ,name)))
+                                  (j (index-range
+                                      0
+                                      (,prim-vect-length ,name))))
+                 (,prim-vect-swap! ,name i j)
+                 (void))))
+
        (define-primitive (,vect->list ,name
                                       (start object
                                              0)

diff --git a/lib/gambit#.scm b/lib/gambit#.scm
@@ -257,6 +257,7 @@ f32vector-ref
 f32vector-set
 f32vector-set!
 f32vector-shrink!
+f32vector-swap!
 f32vector?
 f64vector
 f64vector->list
@@ -270,6 +271,7 @@ f64vector-ref
 f64vector-set
 f64vector-set!
 f64vector-shrink!
+f64vector-swap!
 f64vector?
 fifth
 file-attributes
@@ -724,6 +726,7 @@ s16vector-ref
 s16vector-set
 s16vector-set!
 s16vector-shrink!
+s16vector-swap!
 s16vector?
 s32vector
 s32vector->list
@@ -737,6 +740,7 @@ s32vector-ref
 s32vector-set
 s32vector-set!
 s32vector-shrink!
+s32vector-swap!
 s32vector?
 s64vector
 s64vector->list
@@ -750,6 +754,7 @@ s64vector-ref
 s64vector-set
 s64vector-set!
 s64vector-shrink!
+s64vector-swap!
 s64vector?
 s8vector
 s8vector->list
@@ -763,6 +768,7 @@ s8vector-ref
 s8vector-set
 s8vector-set!
 s8vector-shrink!
+s8vector-swap!
 s8vector?
 scheduler-exception-reason
 scheduler-exception?
@@ -917,6 +923,7 @@ string-suffix-ci?
 string-suffix-length
 string-suffix-length-ci
 string-suffix?
+string-swap!
 string=?-hash
 subf32vector
 subf32vector-fill!
@@ -1069,6 +1076,7 @@ u16vector-ref
 u16vector-set
 u16vector-set!
 u16vector-shrink!
+u16vector-swap!
 u16vector?
 u32vector
 u32vector->list
@@ -1082,6 +1090,7 @@ u32vector-ref
 u32vector-set
 u32vector-set!
 u32vector-shrink!
+u32vector-swap!
 u32vector?
 u64vector
 u64vector->list
@@ -1095,6 +1104,7 @@ u64vector-ref
 u64vector-set
 u64vector-set!
 u64vector-shrink!
+u64vector-swap!
 u64vector?
 u8vector
 u8vector->list
@@ -1109,6 +1119,7 @@ u8vector-ref
 u8vector-set
 u8vector-set!
 u8vector-shrink!
+u8vector-swap!
 u8vector?
 ucs-range->char-set
 ucs-range->char-set!
@@ -1164,6 +1175,7 @@ vector-concatenate
 vector-inc!
 vector-set
 vector-shrink!
+vector-swap!
 void
 will-execute!
 will-testator

diff --git a/lib/gambit/gambit.sld b/lib/gambit/gambit.sld
@@ -609,6 +609,7 @@ f32vector-ref
 f32vector-set
 f32vector-set!
 f32vector-shrink!
+f32vector-swap!
 f32vector?
 f64vector
 f64vector->list
@@ -622,6 +623,7 @@ f64vector-ref
 f64vector-set
 f64vector-set!
 f64vector-shrink!
+f64vector-swap!
 f64vector?
 fifth
 file-attributes
@@ -1073,6 +1075,7 @@ s16vector-ref
 s16vector-set
 s16vector-set!
 s16vector-shrink!
+s16vector-swap!
 s16vector?
 s32vector
 s32vector->list
@@ -1086,6 +1089,7 @@ s32vector-ref
 s32vector-set
 s32vector-set!
 s32vector-shrink!
+s32vector-swap!
 s32vector?
 s64vector
 s64vector->list
@@ -1099,6 +1103,7 @@ s64vector-ref
 s64vector-set
 s64vector-set!
 s64vector-shrink!
+s64vector-swap!
 s64vector?
 s8vector
 s8vector->list
@@ -1112,6 +1117,7 @@ s8vector-ref
 s8vector-set
 s8vector-set!
 s8vector-shrink!
+s8vector-swap!
 s8vector?
 scheduler-exception-reason
 scheduler-exception?
@@ -1266,6 +1272,7 @@ string-suffix-ci?
 string-suffix-length
 string-suffix-length-ci
 string-suffix?
+string-swap!
 string=?-hash
 subf32vector
 subf32vector-fill!
@@ -1418,6 +1425,7 @@ u16vector-ref
 u16vector-set
 u16vector-set!
 u16vector-shrink!
+u16vector-swap!
 u16vector?
 u32vector
 u32vector->list
@@ -1431,6 +1439,7 @@ u32vector-ref
 u32vector-set
 u32vector-set!
 u32vector-shrink!
+u32vector-swap!
 u32vector?
 u64vector
 u64vector->list
@@ -1444,6 +1453,7 @@ u64vector-ref
 u64vector-set
 u64vector-set!
 u64vector-shrink!
+u64vector-swap!
 u64vector?
 u8vector
 u8vector->list
@@ -1458,6 +1468,7 @@ u8vector-ref
 u8vector-set
 u8vector-set!
 u8vector-shrink!
+u8vector-swap!
 u8vector?
 ucs-range->char-set
 ucs-range->char-set!
@@ -1513,6 +1524,7 @@ vector-concatenate
 vector-inc!
 vector-set
 vector-shrink!
+vector-swap!
 void
 will-execute!
 will-testator