bench/bench-diff.sgl — sigil-format

1;;; Differential test: NEW (sigil format tokenize) vs the OLD v0.16.2

2;;; implementation (inlined below, verbatim algorithm). Token streams must be

3;;; identical: same chars vector, same (type start end line col indent) per

4;;; token, same token-value strings.

6(import (sigil core)

7 (sigil io)

8 (sigil fs)

9 (sigil format tokenize2))

11;; ============================================================

12;; OLD implementation (verbatim from v0.16.2, renamed old-*)

13;; ============================================================

15(define (old-token-value tok chars)

16 (let* ((s (vector-ref tok 1))

17 (e (vector-ref tok 2))

18 (n (- e s))

19 (v (make-string n)))

20 (let loop ((i 0))

21 (if (>= i n)

22 v

23 (begin

24 (string-set! v i (vector-ref chars (+ s i)))

25 (loop (+ i 1)))))))

27(define (old-char-digit? c)

28 (and c

29 (char>=? c #\0)

30 (char<=? c #\9)))

32(define old-delimiter-table

33 (let ((t (make-vector 128 #f)))

34 (for-each (lambda (c) (vector-set! t (char->integer c) #t))

35 '(#\( #\) #\[ #\] #\{ #\} #\" #\; #\' #\` #\,

36 #\space #\tab #\newline #\return))

37 t))

39(define (old-delimiter? c)

40 (or (not c)

41 (let ((code (char->integer c)))

42 (and (< code 128) (vector-ref old-delimiter-table code)))))

44(define (old-looks-like-number? s)

45 (let ((len (string-length s)))

46 (if (= len 0)

47 #f

48 (let ((first (string-ref s 0)))

49 (cond

50 ((old-char-digit? first) #t)

51 ((and (or (char=? first #\+) (char=? first #\-))

52 (> len 1)

53 (old-char-digit? (string-ref s 1))) #t)

54 ((and (char=? first #\.)

55 (> len 1)

56 (old-char-digit? (string-ref s 1))) #t)

57 (else #f))))))

59(define (old-tokenize source filename)

60 (let* ((chars (string->vector source))

61 (len (vector-length chars))

62 (pos 0)

63 (cur-line 1)

64 (col 1)

65 (indent 0))

67 (define (advance-one!)

68 (set! pos (+ pos 1))

69 (set! col (+ col 1)))

71 (define (advance-newline!)

72 (set! pos (+ pos 1))

73 (set! cur-line (+ cur-line 1))

74 (set! col 1)

75 (let loop ((off 0))

76 (if (>= (+ pos off) len)

77 (set! indent off)

78 (let ((ch (vector-ref chars (+ pos off))))

79 (cond

80 ((char=? ch #\space) (loop (+ off 1)))

81 ((char=? ch #\tab) (loop (+ off 2)))

82 (else (set! indent off)))))))

84 (define (advance!)

85 (when (< pos len)

86 (let ((c (vector-ref chars pos)))

87 (if (char=? c #\newline)

88 (advance-newline!)

89 (advance-one!)))))

91 (define (skip-whitespace start-pos start-line start-col start-indent)

92 (let loop ()

93 (if (< pos len)

94 (let ((c (vector-ref chars pos)))

95 (cond

96 ((or (char=? c #\space) (char=? c #\tab))

97 (set! pos (+ pos 1))

98 (set! col (+ col 1))

99 (loop))

100 ((char=? c #\return)

101 (set! pos (+ pos 1))

102 (loop))

103 (else

104 (vector 'whitespace start-pos pos start-line start-col start-indent))))

105 (vector 'whitespace start-pos pos start-line start-col start-indent))))

106

107 (define (skip-to-delimiter)

108 (let loop ()

109 (if (>= pos len)

110 pos

111 (let ((code (char->integer (vector-ref chars pos))))

112 (if (and (< code 128) (vector-ref old-delimiter-table code))

113 pos

114 (begin

115 (set! pos (+ pos 1))

116 (set! col (+ col 1))

117 (loop)))))))

118

119 (define (skip-until-newline)

120 (let loop ()

121 (if (>= pos len)

122 pos

123 (if (char=? (vector-ref chars pos) #\newline)

124 pos

125 (begin

126 (set! pos (+ pos 1))

127 (set! col (+ col 1))

128 (loop))))))

129

130 (define (count-leading-spaces)

131 (let loop ((off 0))

132 (if (>= (+ pos off) len)

133 off

134 (let ((c (vector-ref chars (+ pos off))))

135 (cond

136 ((char=? c #\space) (loop (+ off 1)))

137 ((char=? c #\tab) (loop (+ off 2)))

138 (else off))))))

139

140 (define (read-comment start-pos start-line start-col start-indent)

141 (let sloop ((count 0))

142 (if (and (< pos len) (char=? (vector-ref chars pos) #\;))

143 (begin

144 (set! pos (+ pos 1))

145 (set! col (+ col 1))

146 (sloop (+ count 1)))

147 (begin

148 (skip-until-newline)

149 (vector (if (>= count 3) 'doc-comment 'comment)

150 start-pos pos start-line start-col start-indent)))))

151

152 (define (read-string-token start-pos start-line start-col start-indent)

153 (advance-one!)

154 (let loop ()

155 (if (>= pos len)

156 (vector 'string start-pos pos start-line start-col start-indent)

157 (let ((c (vector-ref chars pos)))

158 (cond

159 ((char=? c #\")

160 (advance-one!)

161 (vector 'string start-pos pos start-line start-col start-indent))

162 ((char=? c #\\)

163 (advance-one!)

164 (when (< pos len)

165 (if (char=? (vector-ref chars pos) #\newline)

166 (advance-newline!)

167 (advance-one!)))

168 (loop))

169 ((char=? c #\newline)

170 (advance-newline!)

171 (loop))

172 (else

173 (set! pos (+ pos 1))

174 (set! col (+ col 1))

175 (loop)))))))

176

177 (define (read-hash-token start-pos start-line start-col start-indent)

178 (advance-one!)

179 (if (>= pos len)

180 (vector 'hash-other start-pos pos start-line start-col start-indent)

181 (let ((c (vector-ref chars pos)))

182 (cond

183 ((or (char=? c #\t) (char=? c #\T))

184 (advance-one!)

185 (vector 'hash-t start-pos pos start-line start-col start-indent))

186 ((or (char=? c #\f) (char=? c #\F))

187 (advance-one!)

188 (vector 'hash-f start-pos pos start-line start-col start-indent))

189 ((char=? c #\\)

190 (advance-one!)

191 (if (>= pos len)

192 (vector 'char start-pos pos start-line start-col start-indent)

193 (begin

194 (advance-one!)

195 (skip-to-delimiter)

196 (vector 'char start-pos pos start-line start-col start-indent))))

197 ((char=? c #\|)

198 (advance-one!)

199 (let loop ((depth 1))

200 (if (= depth 0)

201 (vector 'block-comment start-pos pos start-line start-col start-indent)

202 (if (>= pos len)

203 (vector 'block-comment start-pos pos start-line start-col start-indent)

204 (let ((c (vector-ref chars pos)))

205 (cond

206 ((char=? c #\|)

207 (advance-one!)

208 (if (and (< pos len) (char=? (vector-ref chars pos) #\#))

209 (begin (advance-one!) (loop (- depth 1)))

210 (loop depth)))

211 ((char=? c #\#)

212 (advance-one!)

213 (if (and (< pos len) (char=? (vector-ref chars pos) #\|))

214 (begin (advance-one!) (loop (+ depth 1)))

215 (loop depth)))

216 (else

217 (advance!)

218 (loop depth))))))))

219 ((char=? c #\{)

220 (advance-one!)

221 (vector 'hash-lbrace start-pos pos start-line start-col start-indent))

222 ((char=? c #\[)

223 (advance-one!)

224 (vector 'hash-lbracket start-pos pos start-line start-col start-indent))

225 (else

226 (skip-to-delimiter)

227 (vector 'hash-other start-pos pos start-line start-col start-indent))))))

228

229 (set! indent (count-leading-spaces))

230

231 (let loop ((tokens '()))

232 (if (>= pos len)

233 (let ((eof-tok (vector 'eof pos pos cur-line col indent)))

234 (cons chars (reverse (cons eof-tok tokens))))

235 (let ((c (vector-ref chars pos))

236 (start-pos pos)

237 (start-line cur-line)

238 (start-col col)

239 (start-indent indent))

240 (cond

241 ((or (char=? c #\space) (char=? c #\tab) (char=? c #\return))

242 (loop (cons (skip-whitespace start-pos start-line start-col start-indent) tokens)))

243 ((char=? c #\newline)

244 (advance-newline!)

245 (loop (cons (vector 'newline start-pos pos start-line start-col start-indent) tokens)))

246 ((char=? c #\;)

247 (loop (cons (read-comment start-pos start-line start-col start-indent) tokens)))

248

              ((char=? c #\() (advance-one!) (loop (cons (vector 'lparen start-pos pos start-line start-col start-indent) tokens)))

249

              ((char=? c #\)) (advance-one!) (loop (cons (vector 'rparen start-pos pos start-line start-col start-indent) tokens)))

250

              ((char=? c #\[) (advance-one!) (loop (cons (vector 'lbracket start-pos pos start-line start-col start-indent) tokens)))

251

              ((char=? c #\]) (advance-one!) (loop (cons (vector 'rbracket start-pos pos start-line start-col start-indent) tokens)))

252

              ((char=? c #\{) (advance-one!) (loop (cons (vector 'lbrace start-pos pos start-line start-col start-indent) tokens)))

253

              ((char=? c #\}) (advance-one!) (loop (cons (vector 'rbrace start-pos pos start-line start-col start-indent) tokens)))

254

              ((char=? c #\') (advance-one!) (loop (cons (vector 'quote start-pos pos start-line start-col start-indent) tokens)))

255

              ((char=? c #\`) (advance-one!) (loop (cons (vector 'quasiquote start-pos pos start-line start-col start-indent) tokens)))

256 ((char=? c #\,)

257 (advance-one!)

258 (if (and (< pos len) (char=? (vector-ref chars pos) #\@))

259

                   (begin (advance-one!) (loop (cons (vector 'unquote-splicing start-pos pos start-line start-col start-indent) tokens)))

260 (loop (cons (vector 'unquote start-pos pos start-line start-col start-indent) tokens))))

261 ((char=? c #\")

262 (loop (cons (read-string-token start-pos start-line start-col start-indent) tokens)))

263 ((char=? c #\#)

264 (loop (cons (read-hash-token start-pos start-line start-col start-indent) tokens)))

265 ((char=? c #\.)

266 (let ((next (if (< (+ pos 1) len) (vector-ref chars (+ pos 1)) #f)))

267 (if (old-delimiter? next)

268 (begin

269 (advance-one!)

270 (loop (cons (vector 'dot start-pos pos start-line start-col start-indent) tokens)))

271 (begin

272 (skip-to-delimiter)

273

                       (let* ((text (old-token-value (vector 'symbol start-pos pos start-line start-col start-indent) chars))

274 (tok-type (if (old-looks-like-number? text) 'number 'symbol)))

275 (loop (cons (vector tok-type start-pos pos start-line start-col start-indent) tokens)))))))

276 ((or (char=? c #\+) (char=? c #\-))

277 (skip-to-delimiter)

278 (let* ((text (old-token-value (vector 'symbol start-pos pos start-line start-col start-indent) chars))

279 (tok-type (if (old-looks-like-number? text) 'number 'symbol)))

280 (loop (cons (vector tok-type start-pos pos start-line start-col start-indent) tokens))))

281 ((and (char>=? c #\0) (char<=? c #\9))

282 (skip-to-delimiter)

283 (loop (cons (vector 'number start-pos pos start-line start-col start-indent) tokens)))

284 (else

285 (skip-to-delimiter)

286 (loop (cons (vector 'symbol start-pos pos start-line start-col start-indent) tokens)))))))))

287

288;; ============================================================

289;; Comparison harness

290;; ============================================================

291

292(define failures 0)

293

294(define (compare-streams label src)

295 (let* ((new-r (tokenize src "diff.sgl"))

296 (old-r (old-tokenize src "diff.sgl"))

297 (new-chars (car new-r))

298 (old-chars (car old-r))

299 (new-toks (cdr new-r))

300 (old-toks (cdr old-r)))

301 ;; chars vectors identical

302 (let ((nn (vector-length new-chars))

303 (on (vector-length old-chars)))

304 (if (not (= nn on))

305 (begin

306 (set! failures (+ failures 1))

307 (display "FAIL ") (display label)

308 (display ": chars length ") (display nn) (display " vs ") (display on)

309 (newline))

310 (let closs ((i 0))

311 (when (< i nn)

312 (if (not (char=? (vector-ref new-chars i) (vector-ref old-chars i)))

313 (begin

314 (set! failures (+ failures 1))

315 (display "FAIL ") (display label)

316 (display ": chars differ at ") (display i) (newline))

317 (closs (+ i 1)))))))

318 ;; token streams identical

319 (let tloop ((n new-toks) (o old-toks) (idx 0))

320 (cond

321 ((and (null? n) (null? o)) #t)

322 ((or (null? n) (null? o))

323 (set! failures (+ failures 1))

324 (display "FAIL ") (display label)

325 (display ": token count differs at index ") (display idx) (newline))

326 (else

327 (let ((nt (car n)) (ot (car o)))

328 (let fieldloop ((f 0))

329 (when (< f 6)

330 (if (not (equal? (vector-ref nt f) (vector-ref ot f)))

331 (begin

332 (set! failures (+ failures 1))

333 (display "FAIL ") (display label)

334 (display ": token ") (display idx)

335 (display " field ") (display f)

336 (display " new=") (write (vector-ref nt f))

337 (display " old=") (write (vector-ref ot f))

338 (display " (old tok ") (write ot) (display ")")

339 (newline))

340 (fieldloop (+ f 1)))))

341 ;; token-value identical. The OLD accessor vm-errors on non-ASCII

342 ;; tokens (string-set! byte-width), so compare against the old

343 ;; accessor only for ASCII tokens; for all tokens also compare

344 ;; against an independent char-by-char string-append expected.

345 (when (and (= (vector-length nt) 6) (= (vector-length ot) 6))

346 (let* ((s (vector-ref nt 1))

347 (e (vector-ref nt 2))

348 (ascii? (let aloop ((i s))

349 (cond ((>= i e) #t)

350 ((>= (char->integer (vector-ref new-chars i)) 128) #f)

351 (else (aloop (+ i 1))))))

352 (expected (let xloop ((i s) (acc ""))

353 (if (>= i e)

354 acc

355 (xloop (+ i 1)

356 (string-append acc (string (vector-ref new-chars i)))))))

357 (nv (token-value nt new-chars)))

358 (when (not (string=? nv expected))

359 (set! failures (+ failures 1))

360 (display "FAIL ") (display label)

361 (display ": token-value vs expected differs at ") (display idx)

362 (display " new=") (write nv) (display " expected=") (write expected)

363 (newline))

364 (when ascii?

365 (let ((ov (old-token-value ot old-chars)))

366 (when (not (string=? nv ov))

367 (set! failures (+ failures 1))

368 (display "FAIL ") (display label)

369 (display ": token-value differs at ") (display idx)

370 (display " new=") (write nv) (display " old=") (write ov)

371 (newline))))))

372 (tloop (cdr n) (cdr o) (+ idx 1))))))

373 (display "ok: ") (display label) (newline)))

374

375;; --- Edge cases ---

376(compare-streams "empty" "")

377(compare-streams "whitespace-only" " \t ")

378(compare-streams "newlines-only" "\n\n\n")

379(compare-streams "crlf" "(a b)\r\n(c d)\r\n")

380(compare-streams "cr-inside-ws" "a \r b")

381(compare-streams "tabs-indent" "\t\tfoo\n\ta\n b")

382(compare-streams "tab-quirk" "\ta\n\tb")

383(compare-streams "simple" "(+ 1 2)")

384(compare-streams "nested" "(define (foo x)\n (+ x 1))")

385(compare-streams "numbers" "1 2.5 +5 -3 .5 +x -y . .foo +")

386(compare-streams "dot-eof" ".")

387(compare-streams "dot-delim" "(.)")

388(compare-streams "plus-eof" "+")

389(compare-streams "minus-eof" "-")

390(compare-streams "strings" "\"hello\" \"multi\nline\" \"esc\\\"aped\" \"back\\\\slash\"")

391(compare-streams "string-esc-newline" "\"a\\\nb\"")

392(compare-streams "string-unterminated" "\"abc")

393(compare-streams "string-trailing-backslash" "\"abc\\")

394(compare-streams "string-crlf-inside" "\"a\r\nb\"")

395(compare-streams "comments" "; one\n;; two\n;;; doc\n;;;; four\nx ; trail")

396(compare-streams "comment-eof" "; no newline")

397(compare-streams "semis-only" ";;;")

398(compare-streams "hash-t-f" "#t #f #T #F #true #false")

399(compare-streams "char-literals" "#\\a #\\newline #\\space #\\( #\\) #\\\\")

400(compare-streams "char-literal-newline" "#\\\n x")

401(compare-streams "char-eof" "#\\")

402(compare-streams "hash-eof" "#")

403(compare-streams "hash-paren" "#(1 2)")

404(compare-streams "hash-keyword" "#:key #!eof #u8(1)")

405(compare-streams "hash-brace" "#{a 1} #[1 2]")

406(compare-streams "block-comment" "#| simple |# x")

407(compare-streams "block-comment-nested" "#| a #| b |# c |# y")

408(compare-streams "block-comment-multiline" "#| line1\nline2\n line3 |# z")

409(compare-streams "block-comment-unterminated" "#| never ends")

410(compare-streams "block-comment-hash-tail" "#| a # | #|# x")

411(compare-streams "quotes" "'a `b ,c ,@d , ")

412(compare-streams "comma-eof" ",")

413(compare-streams "comma-at-eof" ",@")

414(compare-streams "unicode-symbols" "(λ (α β→γ) \"héllo wörld\") ; ünïcode\nπ")

415(compare-streams "unicode-astral" "\"emoji: 😀🎸\" 😀-sym")

416(compare-streams "mixed-indent" "(a\n (b\n\t(c\n \t d)))")

417(compare-streams "keywords" "name: value: #:kw")

418(compare-streams "empty-string-tok" "\"\"")

419(compare-streams "adjacent" "()[]{}\"\"''``,,")

420

421;; --- Real files from this repo ---

422(define (compare-file path)

423 (compare-streams path (read-file-string path)))

424

425(compare-file "src/sigil/format.sgl")

426(compare-file "src/sigil/format/tokenize.sgl")

427(compare-file "src/sigil/format/json.sgl")

428(compare-file "test/test-format.sgl")

429(compare-file "test/test-tokenize.sgl")

430

431;; --- Generated large corpus ---

432(define (gen-source n-lines)

433 (call-with-output-string

434 (lambda (p)

435 (let loop ((i 0))

436 (when (< i n-lines)

437 (write-string "(define (fn-" p)

438 (write-string (number->string i) p)

439 (write-string " x) ; comment here\n (+ x " p)

440 (write-string (number->string i) p)

441 (write-string " \"str\"))\n" p)

442 (loop (+ i 1)))))))

443

444(compare-streams "generated-2k-lines" (gen-source 1000))

445

446(newline)

447(if (= failures 0)

448 (display "ALL DIFFERENTIAL CHECKS PASSED\n")

449 (begin (display failures) (display " FAILURES\n")))