summaryrefslogtreecommitdiff
path: root/module/language/tree-il/compile-cps.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/compile-cps.scm')
-rw-r--r--module/language/tree-il/compile-cps.scm58
1 files changed, 58 insertions, 0 deletions
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 5c0fac579..052c9ec6f 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -408,6 +408,64 @@
(build-term
($branch knot-keyword kheap-object src 'heap-object? #f (kw))))))
+(define-primcall-converter string->utf8
+ (lambda (cps k src op param str)
+ (define not-string
+ #(wrong-type-arg
+ "string->utf8"
+ "Wrong type argument in position 1 (expecting string): ~S"))
+ (with-cps cps
+ (letk knot-string
+ ($kargs () () ($throw src 'throw/value+data not-string (str))))
+ (letk kstr
+ ($kargs () ()
+ ($continue k src ($primcall 'string->utf8 #f (str)))))
+ (letk kheap-object
+ ($kargs () ()
+ ($branch knot-string kstr src 'string? #f (str))))
+ (build-term
+ ($branch knot-string kheap-object src 'heap-object? #f (str))))))
+
+(define-primcall-converter string-utf8-length
+ (lambda (cps k src op param str)
+ (define not-string
+ #(wrong-type-arg
+ "string-utf8-length"
+ "Wrong type argument in position 1 (expecting string): ~S"))
+ (with-cps cps
+ (letv len)
+ (letk knot-string
+ ($kargs () () ($throw src 'throw/value+data not-string (str))))
+ (letk ktag
+ ($kargs ('len) (len)
+ ($continue k src ($primcall 'u64->scm #f (len)))))
+ (letk kstr
+ ($kargs () ()
+ ($continue ktag src ($primcall 'string-utf8-length #f (str)))))
+ (letk kheap-object
+ ($kargs () ()
+ ($branch knot-string kstr src 'string? #f (str))))
+ (build-term
+ ($branch knot-string kheap-object src 'heap-object? #f (str))))))
+
+(define-primcall-converter utf8->string
+ (lambda (cps k src op param bv)
+ (define not-bv
+ #(wrong-type-arg
+ "utf8->string"
+ "Wrong type argument in position 1 (expecting bytevector): ~S"))
+ (with-cps cps
+ (letk knot-bv
+ ($kargs () () ($throw src 'throw/value+data not-bv (bv))))
+ (letk kbv
+ ($kargs () ()
+ ($continue k src ($primcall 'utf8->string #f (bv)))))
+ (letk kheap-object
+ ($kargs () ()
+ ($branch knot-bv kbv src 'bytevector? #f (bv))))
+ (build-term
+ ($branch knot-bv kheap-object src 'heap-object? #f (bv))))))
+
(define (ensure-pair cps src op pred x is-pair)
(define msg
(match pred