[jl/goldfish:bump to 17.10.8]

TeXmacs/plugins/goldfish/goldfish/liii/base.scm

@@ -24,11 +24,8 @@
   ; R7RS 5: Program Structure
   define-values define-record-type
   ; R7RS 6.2: Numbers
-  square
-  exact inexact
-  floor s7-floor ceiling s7-ceiling truncate s7-truncate round s7-round
-  floor-quotient
-  gcd lcm s7-lcm
+  square exact inexact floor s7-floor ceiling s7-ceiling truncate s7-truncate
+  round s7-round floor-quotient gcd lcm s7-lcm
   ; R7RS 6.3: Booleans
   boolean=?
   ; R7RS 6.4: list
@@ -42,18 +39,14 @@
   ; R7RS 6.7: String
   string-copy
   ; R7RS 6.8 Vector
-  vector->string string->vector
-  vector-copy vector-copy! vector-fill!
+  vector->string string->vector vector-copy vector-copy! vector-fill!
   ; R7RS 6.9 Bytevectors
-  bytevector? make-bytevector bytevector bytevector-length
-  bytevector-u8-ref bytevector-u8-set! bytevector-append
-  utf8->string string->utf8 u8-string-length u8-substring
+  bytevector? make-bytevector bytevector bytevector-length bytevector-u8-ref
+  bytevector-u8-set! bytevector-append utf8->string string->utf8 u8-string-length
+  u8-substring
   ; Input and Output
-  call-with-port port? binary-port? textual-port?
-  input-port-open? output-port-open?
-  open-binary-input-file open-binary-output-file
-  close-port
-  eof-object
+  call-with-port port? binary-port? textual-port? input-port-open? output-port-open?
+  open-binary-input-file open-binary-output-file close-port eof-object
   ; Control flow
   string-map vector-map string-for-each vector-for-each
   ; Exception

TeXmacs/plugins/goldfish/goldfish/liii/base64.scm

@@ -0,0 +1,136 @@
+;
+; Copyright (C) 2024 The Goldfish Scheme Authors
+;
+; Licensed under the Apache License, Version 2.0 (the "License");
+; you may not use this file except in compliance with the License.
+; You may obtain a copy of the License at
+;
+; http://www.apache.org/licenses/LICENSE-2.0
+;
+; Unless required by applicable law or agreed to in writing, software
+; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+; License for the specific language governing permissions and limitations
+; under the License.
+;
+
+(define-library (liii base64)
+(import (liii base)
+        (liii bitwise))
+(export
+  string-base64-encode bytevector-base64-encode base64-encode
+  string-base64-decode bytevector-base64-decode base64-decode
+)
+(begin
+(define-constant BYTE2BASE64_BV
+  (string->utf8 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"))
+
+(define-constant BASE64_PAD_BYTE
+  (char->integer #\=))
+
+(define bytevector-base64-encode
+  (typed-lambda ((bv bytevector?))
+    (define (encode b1 b2 b3)
+      (let* ((p1 b1)
+             (p2 (if b2 b2 0))
+             (p3 (if b3 b3 0))
+             (combined (bitwise-ior (ash p1 16) (ash p2 8) p3))
+             (c1 (bitwise-and (ash combined -18) #x3F))
+             (c2 (bitwise-and (ash combined -12) #x3F))
+             (c3 (bitwise-and (ash combined -6) #x3F))
+             (c4 (bitwise-and combined #x3F)))
+        (values
+          (BYTE2BASE64_BV c1)
+          (BYTE2BASE64_BV c2)
+          (if b2 (BYTE2BASE64_BV c3) BASE64_PAD_BYTE)
+          (if b3 (BYTE2BASE64_BV c4) BASE64_PAD_BYTE))))
+
+    (let* ((input-N (bytevector-length bv))
+           (output-N (* 4 (ceiling (/ input-N 3))))
+           (output (make-bytevector output-N)))
+      (let loop ((i 0) (j 0))
+        (when (< i input-N)
+          (let* ((b1 (bv i))
+                 (b2 (if (< (+ i 1) input-N) (bv (+ i 1)) #f))
+                 (b3 (if (< (+ i 2) input-N) (bv (+ i 2)) #f)))
+            (receive (r1 r2 r3 r4) (encode b1 b2 b3)
+              (bytevector-u8-set! output j r1)
+              (bytevector-u8-set! output (+ j 1) r2)
+              (bytevector-u8-set! output (+ j 2) r3)
+              (bytevector-u8-set! output (+ j 3) r4)
+              (loop (+ i 3) (+ j 4))))))
+      output)))
+
+(define string-base64-encode
+  (typed-lambda ((str string?))
+    (utf8->string (bytevector-base64-encode (string->utf8 str)))))
+
+(define (base64-encode x)
+  (cond ((string? x)
+         (string-base64-encode x))
+        ((bytevector? x)
+         (bytevector-base64-encode x))
+        (else
+         (type-error "input must be string or bytevector"))))
+
+(define-constant BASE64_TO_BYTE_V
+  (let1 byte2base64-N (bytevector-length BYTE2BASE64_BV)
+    (let loop ((i 0) (v (make-vector 256 -1)))
+      (if (< i byte2base64-N)
+          (begin
+            (vector-set! v (BYTE2BASE64_BV i) i)
+            (loop (+ i 1) v))
+          v))))
+
+(define (bytevector-base64-decode bv)
+  (define (decode c1 c2 c3 c4)
+    (let* ((b1 (BASE64_TO_BYTE_V c1))
+           (b2 (BASE64_TO_BYTE_V c2))
+           (b3 (BASE64_TO_BYTE_V c3))
+           (b4 (BASE64_TO_BYTE_V c4)))
+      (if (or (negative? b1) (negative? b2)
+              (and (negative? b3) (!= c3 BASE64_PAD_BYTE))
+              (and (negative? b4) (!= c4 BASE64_PAD_BYTE)))
+          (value-error "Invalid base64 input")
+          (values
+            (bitwise-ior (ash b1 2) (ash b2 -4))
+            (bitwise-and (bitwise-ior (ash b2 4) (ash b3 -2)) #xFF)
+            (bitwise-and (bitwise-ior (ash b3 6) b4) #xFF)
+            (if (negative? b3) 1 (if (negative? b4) 2 3))))))
+
+  (let* ((input-N (bytevector-length bv))
+         (output-N (* input-N 3/4))
+         (output (make-bytevector output-N)))
+
+    (unless (zero? (modulo input-N 4))
+      (value-error "length of the input bytevector must be 4X"))
+
+    (let loop ((i 0) (j 0))
+      (if (< i input-N)
+          (receive (r1 r2 r3 cnt)
+                   (decode (bv i) (bv (+ i 1)) (bv (+ i 2)) (bv (+ i 3)))
+            (bytevector-u8-set! output j r1)
+            (when (>= cnt 2)
+              (bytevector-u8-set! output (+ j 1) r2))
+            (when (>= cnt 3)
+              (bytevector-u8-set! output (+ j 2) r3))
+            (loop (+ i 4) (+ j cnt)))
+          (let ((final (make-bytevector j)))
+            (vector-copy! final 0 output 0 j)
+            final)))))
+
+(define string-base64-decode
+  (typed-lambda ((str string?))
+    (utf8->string (bytevector-base64-decode (string->utf8 str)))))
+
+(define (base64-decode x)
+  (cond ((string? x)
+         (string-base64-decode x))
+        ((bytevector? x)
+         (bytevector-base64-decode x))
+        (else
+         (type-error "input must be string or bytevector"))))
+
+) ; end of begin
+) ; end of define-library
+

TeXmacs/plugins/goldfish/goldfish/liii/bitwise.scm

@@ -19,13 +19,17 @@
         (liii error))
 (export
   ; from (srfi srfi-151)
-  bitwise-not bitwise-and bitwise-ior bitwise-xor
+  bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-or bitwise-nor bitwise-nand
+  bit-count
   arithmetic-shift
   ; S7 built-in
   lognot logand logior logxor
   ash
 )
 (begin
+
+(define bitwise-or bitwise-ior)
+
 ) ; end of begin
 ) ; end of library
 

TeXmacs/plugins/goldfish/goldfish/liii/list.scm

@@ -153,7 +153,11 @@
         ((integer? depth)
          (flatten-depth lst depth))
         (else
-         (error 'type-error "flatten: the second argument depth should be symbol `deepest' or a integer, which will be uesd as depth, but got a ~A" depth)))
+         (type-error
+          (string-append
+            "flatten: the second argument depth should be symbol "
+            "`deepest' or a integer, which will be uesd as depth,"
+            " but got a ~A") depth)))
   ) ; end of (define* (flatten))
 
 ) ; end of begin

TeXmacs/plugins/goldfish/goldfish/liii/os.scm

@@ -17,10 +17,13 @@
 (define-library (liii os)
 (export
   os-arch os-type os-windows? os-linux? os-macos? os-temp-dir
+  os-sep pathsep
   os-call system
   mkdir chdir rmdir getenv unsetenv getcwd listdir access getlogin getpid)
 (import (scheme process-context)
-        (liii error))
+        (liii base)
+        (liii error)
+        (liii string))
 (begin
 
 (define (os-call command)
@@ -47,8 +50,19 @@
   (let ((name (os-type)))
     (and name (string=? name "Darwin"))))
 
+(define (os-sep)
+  (if (os-windows?)
+    #\\
+    #\/))
+
+(define (pathsep)
+  (if (os-windows?)
+    #\;
+    #\:))
+
 (define (os-temp-dir)
-  (g_os-temp-dir))
+  (let1 temp-dir (g_os-temp-dir)
+    (string-remove-suffix temp-dir (string (os-sep)))))
 
 (define (access path mode)
   (cond ((eq? mode 'F_OK) (g_access path 0))

TeXmacs/plugins/goldfish/goldfish/liii/string.scm

@@ -26,20 +26,26 @@
   string-take string-take-right string-drop string-drop-right
   string-pad string-pad-right
   string-trim string-trim-right string-trim-both
-  string-prefix? string-suffix?
   string-index string-index-right
   string-contains string-count
   string-upcase string-downcase
   string-reverse
   string-tokenize
   ; Liii extras
+  string-starts? string-ends?
   string-remove-prefix string-remove-suffix
 )
 (import (srfi srfi-13)
         (liii base)
         (liii error))
 (begin
 
+(define (string-starts? str prefix)
+  (string-prefix? prefix str))
+
+(define (string-ends? str suffix)
+  (string-suffix? suffix str))
+
 (define string-remove-prefix
   (typed-lambda ((str string?) (prefix string?))
     (if (string-prefix? prefix str)

TeXmacs/plugins/goldfish/goldfish/liii/vector.scm

@@ -28,7 +28,7 @@
   vector-count
   vector-any vector-every vector-copy vector-copy!
   vector-index vector-index-right vector-partition
-  vector-swap!)
+  vector-swap! vector-cumulate reverse-list->vector)
 (begin
 
 ) ; end of begin

TeXmacs/plugins/goldfish/goldfish/scheme/base.scm

@@ -20,12 +20,8 @@
   ; R7RS 5: Program Structure
   define-values define-record-type
   ; R7RS 6.2: Numbers
-  square
-  exact inexact
-  floor s7-floor ceiling s7-ceiling truncate s7-truncate round s7-round
-  floor-quotient
-  gcd lcm s7-lcm
-  boolean=?
+  square exact inexact floor s7-floor ceiling s7-ceiling truncate s7-truncate
+  round s7-round floor-quotient gcd lcm s7-lcm boolean=?
   ; R7RS 6.4: list
   pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr
   null? list? make-list list length append reverse list-tail
@@ -37,18 +33,13 @@
   ; R7RS 6.7: String
   string-copy
   ; R7RS 6.8: Vector
-  vector->string string->vector
-  vector-copy vector-copy! vector-fill!
+  vector->string string->vector vector-copy vector-copy! vector-fill!
   ; R7RS 6.9: Bytevectors
-  bytevector? make-bytevector bytevector bytevector-length
-  bytevector-u8-ref bytevector-u8-set! bytevector-append
-  utf8->string string->utf8 u8-string-length
+  bytevector? make-bytevector bytevector bytevector-length bytevector-u8-ref
+  bytevector-u8-set! bytevector-append utf8->string string->utf8 u8-string-length
   ; Input and Output
-  call-with-port port? binary-port? textual-port?
-  input-port-open? output-port-open?
-  open-binary-input-file open-binary-output-file
-  close-port
-  eof-object
+  call-with-port port? binary-port? textual-port? input-port-open? output-port-open?
+  open-binary-input-file open-binary-output-file close-port eof-object
   ; Control flow
   string-map vector-map string-for-each vector-for-each
   ; Exception

TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm

@@ -21,7 +21,7 @@
   vector-count
   vector-any vector-every vector-copy vector-copy!
   vector-index vector-index-right vector-partition
-  vector-swap!)
+  vector-swap! vector-cumulate reverse-list->vector)
 (begin
 
 (define (vector-empty? v)
@@ -37,6 +37,23 @@
               (loop (+ i 1) (+ count 1)))
              (else (loop (+ i 1) count)))))
 
+; Return a new vector v-rst with same length of input vector vec.
+; Every element of the result is the result the i-th iteration of fn cumu_i vec_i.
+;   Where fn should be a procedure with 2 args.
+;   The type of knil and vector could be different.
+; In the i-th iteration, cumu_i = fn cumu_(i-1) vec_i, with cumu_0 = fn knil vec_0.
+
+(define vector-cumulate
+  (typed-lambda ((fn procedure?) knil (vec vector?))
+    (let* ((len (vector-length vec))
+           (v-rst (make-vector len)))
+      (let loop ((i 0) (lhs knil))
+           (if (= i len)
+               v-rst
+               (let1 cumu-i (fn lhs (vec i))
+                 (begin
+                   (vector-set! v-rst i cumu-i)
+                   (loop (+ 1 i) cumu-i))))))))
 ; TODO optional parameters
 (define (vector-any pred v)
   (let loop ((i 0))
@@ -89,6 +106,16 @@
     (vector-set! vec j elem-i)
     ))
 
+; Input a proper-list, return a vector with inversed order elements.
+(define reverse-list->vector
+  (typed-lambda ((lst proper-list?))
+    (let* ((len (length lst)) (v-rst (make-vector len)))
+      (let loop ((l lst) (i (- len 1)))
+        (if (null? l) v-rst
+            (begin
+              (vector-set! v-rst i (car l))
+              (loop (cdr l) (- i 1))))))))
+
 ) ; end of begin
 ) ; end of define-library