!111 case-char in (liii lang)

LiiiLabs · Jan 11, 2025 · 99061ce · 99061ce
1 parent 615fd78
commit 99061ce
Show file tree

Hide file tree

Showing 3 changed files with 181 additions and 2 deletions.
diff --git a/GoldfishLang.tmu b/GoldfishLang.tmu
@@ -92,14 +92,16 @@
 
     (import (liii string) (liii vector)
 
-    \ \ \ \ \ \ \ \ (liii list) (liii hash-table))
+    \ \ \ \ \ \ \ \ (liii list) (liii hash-table) (liii bitwise))
 
     (export
 
     \ \ option option? option=? none
 
     \ \ case-integer case-integer? case-integer=?
 
+    \ \ case-char case-char? case-char=?
+
     \ \ case-string case-string? case-string=?
 
     \ \ case-list case-list? case-list=?
@@ -369,12 +371,138 @@
     \;
   </goldfish-chunk>
 
+  <paragraph|case-integer%to-char>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define (%to-char)
+
+    \ \ (case-char data))
+
+    \;
+  </goldfish-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
+    (check-catch 'value-error ((box #x110000) :to-char))
+
+    \;
+  </goldfish-chunk>
+
   <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
     )
 
     \;
   </goldfish-chunk>
 
+  <subsection|case-char>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define-case-class case-char ((code-point integer?))
+
+    \;
+  </goldfish-chunk>
+
+  <paragraph|case-char%to-bytevector>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define (%to-bytevector)
+
+    \ \ (cond
+
+    \ \ \ \ ((\<less\>= code-point #x7F)
+
+    \ \ \ \ \ (bytevector code-point))
+
+    \;
+
+    \ \ \ \ ((\<less\>= code-point #x7FF)
+
+    \ \ \ \ \ (let ((byte1 (bitwise-ior #b11000000 (bitwise-and (arithmetic-shift code-point -6) #b00011111)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (byte2 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111))))
+
+    \ \ \ \ \ \ \ (bytevector byte1 byte2)))
+
+    \;
+
+    \ \ \ \ ((\<less\>= code-point #xFFFF)
+
+    \ \ \ \ \ (let ((byte1 (bitwise-ior #b11100000 (bitwise-and (arithmetic-shift code-point -12) #b00001111)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (byte2 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -6) #b00111111)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (byte3 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111))))
+
+    \ \ \ \ \ \ \ (bytevector byte1 byte2 byte3)))
+
+    \;
+
+    \ \ \ \ ((\<less\>= code-point #x10FFFF)
+
+    \ \ \ \ \ (let ((byte1 (bitwise-ior #b11110000 (bitwise-and (arithmetic-shift code-point -18) #b00000111)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (byte2 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -12) #b00111111)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (byte3 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -6) #b00111111)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (byte4 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111))))
+
+    \ \ \ \ \ \ \ (bytevector byte1 byte2 byte3 byte4)))
+
+    \;
+
+    \ \ \ \ (else
+
+    \ \ \ \ \ (value-error "Invalid code point"))))
+
+    \;
+  </goldfish-chunk>
+
+  <paragraph|case-char%to-string>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define (%to-string)
+
+    \ \ (case-string (utf8-\<gtr\>string (%to-bytevector))))
+
+    \;
+  </goldfish-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
+    (check (((case-char #x41) :to-string) :unbox) =\<gtr\> "A")
+
+    (check (((case-char #xA3) :to-string) :unbox) =\<gtr\> "£")
+
+    (check (((case-char #x4E2D) :to-string) :unbox) =\<gtr\> "<code|中>")
+
+    (check (((case-char #x1F600) :to-string) :unbox) =\<gtr\> "<code|😀>")
+
+    \;
+  </goldfish-chunk>
+
+  \;
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    )
+
+    \;
+  </goldfish-chunk>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define make-case-char case-char)
+
+    \;
+
+    (typed-define (case-char (code integer?))
+
+    \ \ (if (and (\<gtr\>= code 0) (\<less\>= code #x10FFFF))
+
+    \ \ \ \ \ \ (make-case-char code)
+
+    \ \ \ \ \ \ (value-error "case-char: code point out of range" code)))
+
+    \;
+  </goldfish-chunk>
+
   <subsection|case-string>
 
   Unicode编码的字符串。

diff --git a/goldfish/liii/lang.scm b/goldfish/liii/lang.scm
@@ -16,10 +16,11 @@
 
 (define-library (liii lang)
 (import (liii string) (liii vector)
-        (liii list) (liii hash-table))
+        (liii list) (liii hash-table) (liii bitwise))
 (export
   option option? option=? none
   case-integer case-integer? case-integer=?
+  case-char case-char? case-char=?
   case-string case-string? case-string=?
   case-list case-list? case-list=?
   case-vector case-vector? case-vector=?
@@ -80,8 +81,51 @@
       (case-list (list))
       (case-list (iota (+ (- n data)) data))))
 
+(define (%to-char)
+  (case-char data))
+
+)
+
+(define-case-class case-char ((code-point integer?))
+
+(define (%to-bytevector)
+  (cond
+    ((<= code-point #x7F)
+     (bytevector code-point))
+
+    ((<= code-point #x7FF)
+     (let ((byte1 (bitwise-ior #b11000000 (bitwise-and (arithmetic-shift code-point -6) #b00011111)))
+           (byte2 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111))))
+       (bytevector byte1 byte2)))
+
+    ((<= code-point #xFFFF)
+     (let ((byte1 (bitwise-ior #b11100000 (bitwise-and (arithmetic-shift code-point -12) #b00001111)))
+           (byte2 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -6) #b00111111)))
+           (byte3 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111))))
+       (bytevector byte1 byte2 byte3)))
+
+    ((<= code-point #x10FFFF)
+     (let ((byte1 (bitwise-ior #b11110000 (bitwise-and (arithmetic-shift code-point -18) #b00000111)))
+           (byte2 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -12) #b00111111)))
+           (byte3 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -6) #b00111111)))
+           (byte4 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111))))
+       (bytevector byte1 byte2 byte3 byte4)))
+
+    (else
+     (value-error "Invalid code point"))))
+
+(define (%to-string)
+  (case-string (utf8->string (%to-bytevector))))
+
 )
 
+(define make-case-char case-char)
+
+(typed-define (case-char (code integer?))
+  (if (and (>= code 0) (<= code #x10FFFF))
+      (make-case-char code)
+      (value-error "case-char: code point out of range" code)))
+
 (define-case-class case-string ((data string?))
 
 (define (%unbox) data)

diff --git a/tests/goldfish/liii/lang-test.scm b/tests/goldfish/liii/lang-test.scm
@@ -70,6 +70,13 @@
 (check (((box 1) :until 2) :collect) => (list 1))
 (check (((box 2) :until 2) :collect) => (list ))
 
+(check-catch 'value-error ((box #x110000) :to-char))
+
+(check (((case-char #x41) :to-string) :unbox) => "A")
+(check (((case-char #xA3) :to-string) :unbox) => "£")
+(check (((case-char #x4E2D) :to-string) :unbox) => "中")
+(check (((case-char #x1F600) :to-string) :unbox) => "😀")
+
 (check ((box "abc") :unbox) => "abc")
 (check ((box "") :unbox) => "")