From 275cc1a5b16c4f8069b3284bddcd9705f9e5441b Mon Sep 17 00:00:00 2001
From: Jan Tuomi <jan@jantuomi.fi>
Date: Fri, 28 Feb 2025 13:40:43 +0200
Subject: Add emit-packed-string

---
 atk16_schasm/lib.scm | 60 +++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 57 insertions(+), 3 deletions(-)

diff --git a/atk16_schasm/lib.scm b/atk16_schasm/lib.scm
index af4c756..4e316d0 100644
--- a/atk16_schasm/lib.scm
+++ b/atk16_schasm/lib.scm
@@ -24,9 +24,9 @@
 
 (define (def-label sym . exprs)
   (set! *labels* (cons (cons sym *cursor*) *labels*))
-  ; don't do anything with exprs, it's there for allowing
-  ; a nice appearance for labeled blocks
-)
+  ;; don't do anything with exprs, it's there for allowing
+  ;; a nice appearance for labeled blocks
+  )
 
 (define (at-addr addr)
   (unless (and (number? addr)
@@ -291,6 +291,25 @@
 	`(8 . ,imm))        ; offset
   )
 
+;; "Macros"
+
+(define (emit-packed-string s)
+  ;; emit length
+  (define sl (string-length s))
+  (u16 sl) ; cast to u16 to get bounds check
+  (emit sl)
+
+  ;; compute packed words
+  (define words (pack-bytes-to-words (string->ascii-list s)))
+
+  (let loop ((ws words))
+    (if (null? ws)
+	;; if done, return total number of words emitted
+	(length words)
+	;; if not, emit the word and loop
+	(begin (emit (car ws))
+	       (loop (cdr ws))))))
+
 ;; Utils
 
 (define (type-of v)
@@ -305,3 +324,38 @@
 (define (assocdr k alist)
   (let ((v (assoc k alist)))
     (and v (cdr v))))
+
+(define (string->ascii-list s)
+  (let* ((len (string-length s))
+         (dummy (cons #f '()))
+         (tail dummy))
+    (do ((i 0 (+ i 1)))
+        ((= i len))
+      (set-cdr! tail (cons (char->integer (string-ref s i)) '()))
+      (set! tail (cdr tail)))
+    (cdr dummy)))
+
+(define (pack-bytes-to-words bytes)
+  (cond
+   ((>= (length bytes) 2)
+    (let* ((hi   (car bytes))
+	   (lo   (cadr bytes))
+	   (word (+ (arithmetic-shift hi 8) lo)))
+
+      (unless (and (>= word 0)
+		   (<  word (expt 2 16)))
+	(error "packing of two bytes produced an invalid 16 bit word" word))
+
+      (cons word (pack-bytes-to-words (cddr bytes)))))
+   ((= (length bytes) 1)
+    (let* ((hi   (car bytes))
+	   (word (arithmetic-shift hi 8)))
+
+      (unless (and (>= word 0)
+		   (<  word (expt 2 16)))
+	(error "packing of one byte produced an invalid 16 bit word" word))
+
+      (list word)))
+
+   ((= (length bytes) 0)
+    '())))
-- 
cgit v1.3