internal.scm (9625B)
1 ;;; Scheme implementation of RSV - Rows of String Values. 2 ;;; Copyright (C) 2024 Yuval Langer. 3 ;;; 4 ;;; This program is free software: you can redistribute it and/or modify 5 ;;; it under the terms of the GNU General Public License as published by 6 ;;; the Free Software Foundation, either version 3 of the License, or 7 ;;; (at your option) any later version. 8 ;;; 9 ;;; This program is distributed in the hope that it will be useful, 10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 ;;; GNU General Public License for more details. 13 ;;; 14 ;;; You should have received a copy of the GNU General Public License 15 ;;; along with this program. If not, see <https://www.gnu.org/licenses/>. 16 17 (define-library (rsv internal) 18 (import (scheme base) 19 (scheme file) 20 (scheme write) 21 22 (srfi srfi-41)) 23 (export legal-rsv? 24 legal-utf8? 25 null-value-byte 26 null-value-byte? 27 read-null-value 28 read-rsv 29 read-rsv-row 30 read-rsv-string 31 row-terminator-byte 32 row-terminator-byte? 33 rsv-bytevector->scm 34 scm->rsv-bytevector 35 value-terminator-byte 36 value-terminator-byte? 37 write-rsv 38 write-rsv-field 39 write-rsv-row) 40 41 (begin 42 (define row-terminator-byte #xFD) ;; 253 43 (define value-terminator-byte #xFF) ;; 255 44 (define null-value-byte #xFE) ;; 254 45 46 (define (row-terminator-byte? byte) (= row-terminator-byte byte)) 47 (define (value-terminator-byte? byte) (= value-terminator-byte byte)) 48 (define (null-value-byte? byte) (= null-value-byte byte)) 49 50 (define (write-rsv-field field port) 51 (cond 52 ((not field) 53 (write-u8 null-value-byte 54 port)) 55 (else 56 (write-bytevector (string->utf8 field) 57 port)))) 58 59 (define (write-rsv-row row port) 60 (unless (binary-port? port) 61 (error "Provided port should be a binary port." 62 port)) 63 64 (let loop ((row row)) 65 (cond 66 ((null? row) 67 (write-u8 row-terminator-byte 68 port)) 69 (else 70 (let ((field (car row)) 71 (rest-of-fields (cdr row))) 72 (write-rsv-field field port) 73 (write-u8 value-terminator-byte port) 74 (loop rest-of-fields)))))) 75 76 (define (write-rsv scm port) 77 "Convert provided SCM, which is a list of lists of strings or null values, into RSV and write it into PORT. 78 79 The SCM, the sexp representation of RSV, is defined as: 80 81 RSV := ( ROW* ) 82 ROW := ( STRING-or-NULL-VALUE* ) 83 STRING-or-NULL-VALUE := String | Null-Value 84 Null-Value := #f" 85 (unless (binary-port? port) 86 (error "Expected binary port." port)) 87 88 (let loop ((scm scm)) 89 (cond 90 ((null? scm) '()) 91 (else 92 (let ((row (car scm)) 93 (rest-of-rows (cdr scm))) 94 (write-rsv-row row port) 95 (loop rest-of-rows)))))) 96 97 (define (scm->rsv-bytevector scm) 98 (let ((output-bytevector-port (open-output-bytevector))) 99 (write-rsv scm output-bytevector-port) 100 (get-output-bytevector output-bytevector-port))) 101 102 (define (legal-utf8? byte) 103 ;; XXX: Replace with a better predicate. 104 (and (integer? byte) 105 (< -1 byte #xF8))) 106 107 (define (legal-rsv? byte) 108 ;; XXX: Same as for legal-utf8? 109 (and (integer? byte) 110 (< -1 byte #x100))) 111 112 (define (read-rsv-string row-count column-count port) 113 "Read a string from PORT. 114 115 Return the string just read, and the number of bytes just 116 read." 117 (unless (binary-port? port) 118 (error "Expected binary port." port)) 119 120 (let ((output-field-port (open-output-bytevector))) 121 (let loop ((column-count column-count)) 122 (let ((byte (read-u8 port))) 123 (cond 124 ((eof-object? byte) 125 (error "Prematurely terminated RSV at: (row, column)" 126 row-count 127 column-count)) 128 ((not (legal-rsv? byte)) 129 (error "Illegal value returned by RSV string reader: (illegal value, row, column)" 130 byte 131 row-count 132 column-count)) 133 ((value-terminator-byte? byte) 134 (values (utf8->string (get-output-bytevector output-field-port)) 135 row-count 136 column-count)) 137 ((legal-utf8? byte) 138 (write-u8 byte 139 output-field-port) 140 (loop (+ column-count 1)))))))) 141 142 (define (read-null-value row-count column-count port) 143 ;; `row->scm` had already `peek-u8`-ed and knows that the next 144 ;; `read-u8` will be the Null-Value-Byte, a.k.a. #xFE, so we can 145 ;; remove it without looking at it. 146 (unless (binary-port? port) 147 (error "Expected binary port." port)) 148 149 ;; Remove Null-Value-Byte. XXX: Already checked in the 150 ;; procedure calling read-null-value, so it should be okay not 151 ;; to check it, no? Can a time-of-check-time-of-use result when not checking? 152 (let ((byte (read-u8 port))) 153 (cond 154 ((eof-object? byte) 155 (error "Prematurely terminated RSV: (row, column)" 156 row-count 157 column-count)) 158 ((not (legal-rsv? byte)) 159 (error "Illegal value returned by RSV string reader: (illegal value, row, column)" 160 byte 161 row-count 162 column-count)) 163 ((not (null-value-byte? byte)) 164 (error "Expected a Null Byte (#xFE), instead got: (unexpected byte, row, column)" 165 byte 166 row-count 167 column-count)))) 168 169 (let ((byte (read-u8 port))) ;; Remove value terminator byte. 170 (cond 171 ((eof-object? byte) 172 (error "Prematurely terminated RSV: (row, column)" 173 row-count 174 column-count)) 175 ((not (legal-rsv? byte)) 176 (error "Expected a Value-Terminator-Byte (#xFF) after a Null Byte (#xFE), instead got illegal value: (illegal value, row, column)" 177 byte 178 row-count 179 column-count)) 180 ((value-terminator-byte? byte) 181 ;; Return successfully. 182 (values row-count 183 (+ column-count 2))) 184 (else 185 (error "Expected a Value-Terminator-Byte (#xFF) after a Null Byte (#xFE), instead got illegal value: (illegal value, row, column)" 186 byte 187 row-count 188 column-count))))) 189 190 (define (read-rsv-row row-count column-count port) 191 (unless (binary-port? port) 192 (error "Provided port should be a binary port." 193 port)) 194 (let loop ((row '()) 195 (row-count row-count) 196 (column-count column-count)) 197 (let ((byte (peek-u8 port))) 198 (cond ((eof-object? byte) 199 (error "Prematurely terminated RSV: (row, column)" 200 row-count 201 column-count)) 202 ((row-terminator-byte? byte) ;; End of row. 203 (read-u8 port) ;; Remove row terminator. 204 (values (reverse row) 205 (+ row-count 1) 206 0)) 207 208 ((null-value-byte? byte) ;; Field is null. 209 (let-values (((new-row-count new-column-count) 210 (read-null-value row-count column-count port))) 211 (loop (cons #f row) 212 new-row-count 213 new-column-count))) 214 215 ((value-terminator-byte? byte) 216 (read-u8 port) 217 (loop (cons "" 218 row) 219 row-count 220 (+ column-count 1))) 221 222 ((legal-utf8? byte) ;; Field is a string. 223 (let-values (((new-field-value new-row-count new-column-count) 224 (read-rsv-string row-count 225 column-count 226 port))) 227 (loop (cons new-field-value 228 row) 229 new-row-count 230 new-column-count))) 231 232 (else 233 (error "Illegal value returned in read-rsv-row: (illegal value, row, column)" 234 byte 235 row-count 236 column-count)))))) 237 238 (define (read-rsv port) 239 (unless (binary-port? port) 240 (error "Provided port should be a binary port." 241 port)) 242 (let loop ((rows '()) 243 (row-count 0) 244 (column-count 0)) 245 (let ((byte (peek-u8 port))) 246 (cond 247 ((eof-object? byte) 248 (reverse rows)) 249 250 ((legal-rsv? byte) 251 (let-values (((new-row new-row-count new-column-count) 252 (read-rsv-row row-count column-count port))) 253 (loop (cons new-row rows) 254 new-row-count 255 new-column-count))) 256 257 (else 258 (error "Illegal value returned when reading RSV row: (illegal value, row)" 259 byte 260 row-count)))))) 261 262 (define (rsv-bytevector->scm bv) 263 (let ((bytevector-input-port (open-input-bytevector bv))) 264 (read-rsv bytevector-input-port)))))