Add `unsafe?` option for image creation procedures

- Add (private bitwise) module and use it
- Add (private checker) module and use it
- Add (private double-byte) module and use it

1 files changed, 85 insertions, 78 deletions

diff --git a/pnm/read.scm b/pnm/read.scm
index a2e0555..f673c35 100644
--- a/pnm/read.scm
+++ b/pnm/read.scm
@@ -20,89 +20,96 @@
   (export image-read
           pnm-parse-error?)
   (import (scheme base)
-          (scheme write)
+          (scheme case-lambda)
           (pnm image)
           (pnm pbm)
           (pnm pgm)
           (pnm ppm))
   (begin
-    (define (image-read in)
-      (define (read-u8*)
-        (let ((u8 (read-u8 in)))
-          (when (eof-object? u8)
-            (unexpected-eof-error))
-          u8))
-      (define (read-magic-number*)
-        (let ((magic-number (read-magic-number in)))
-          (when (eof-object? magic-number)
-            (unexpected-eof-error))
-          (unless magic-number
-            (unexpected-magic-number-error))
-          magic-number))
-      (define (read-number*)
-        (let ((n (read-number in)))
-          (when (eof-object? n)
-            (unexpected-eof-error))
-          (unless n
-            (unexpected-character-error))
-          n))
-      (define (read-whitespaces*)
-        (let ((result (read-whitespaces in)))
-          (when (eof-object? result)
-            (unexpected-eof-error))
-          (unless result
-            (unexpected-character-error))))
-      (define (read-single-whitespace*)
-        (unless (whitespace? (read-u8*))
-          (unexpected-character-error)))
-
-      (let ((magic-number (read-magic-number*)))
-        (read-whitespaces*)
-        (let ((width (read-number in)))
-          (read-whitespaces*)
-          (let ((height (read-number in)))
-            (case magic-number
-              ((P4)
-               (read-single-whitespace*)
-               (%make-pbm-image width height
-                                (read-bytevector (* (ceiling (/ width 8)) height) in)))
-              ((P1)
-               (let ((byte-width (ceiling (/ width 8)))
-                     (pbm-image (make-pbm-image width height)))
-                 (read-text-raster width height #f in
-                                   (lambda (x y v)
-                                     (image-set! pbm-image x y (= v 1)))
-                                   unexpected-eof-error
-                                   unexpected-character-error)
-                 pbm-image))
-              (else
-               (read-whitespaces*)
-               (let ((maxval (read-number in)))
-                 (case magic-number
-                   ((P6)
-                    (read-single-whitespace*)
-                    (%make-ppm-image width height maxval
-                                     (if (< maxval 256)
-                                         (read-bytevector (* 3 width height) in)
-                                         (read-bytevector (* 6 width height) in))))
-                   ((P3)
-                    (let ((ppm-image (make-ppm-image width height maxval)))
-                      (read-text-raster width height #t in (image-pixel-setter ppm-image)
-                                        unexpected-eof-error
-                                        unexpected-character-error)
-                      ppm-image))
-                   ((P5)
-                    (read-single-whitespace*)
-                    (%make-pgm-image width height maxval
-                                     (if (< maxval 256)
-                                         (read-bytevector (* width height) in)
-                                         (read-bytevector (* 2 width height) in))))
-                   ((P2)
-                    (let ((pgm-image (make-pgm-image width height maxval)))
-                      (read-text-raster width height #f in (image-pixel-setter pgm-image)
-                                        unexpected-eof-error
-                                        unexpected-character-error)
-                      pgm-image))))))))))
+    (define image-read
+      (case-lambda
+        ((in)
+         (image-read in #f))
+        ((in unsafe?)
+         (define (read-u8*)
+           (let ((u8 (read-u8 in)))
+             (when (eof-object? u8)
+               (unexpected-eof-error))
+             u8))
+         (define (read-magic-number*)
+           (let ((magic-number (read-magic-number in)))
+             (when (eof-object? magic-number)
+               (unexpected-eof-error))
+             (unless magic-number
+               (unexpected-magic-number-error))
+             magic-number))
+         (define (read-number*)
+           (let ((n (read-number in)))
+             (when (eof-object? n)
+               (unexpected-eof-error))
+             (unless n
+               (unexpected-character-error))
+             n))
+         (define (read-whitespaces*)
+           (let ((result (read-whitespaces in)))
+             (when (eof-object? result)
+               (unexpected-eof-error))
+             (unless result
+               (unexpected-character-error))))
+         (define (read-single-whitespace*)
+           (unless (whitespace? (read-u8*))
+             (unexpected-character-error)))
+
+         (let ((magic-number (read-magic-number*)))
+           (read-whitespaces*)
+           (let ((width (read-number in)))
+             (read-whitespaces*)
+             (let ((height (read-number in)))
+               (case magic-number
+                 ((P4)
+                  (read-single-whitespace*)
+                  (%make-pbm-image width height
+                                   (read-bytevector (* (ceiling (/ width 8)) height) in)
+                                   unsafe?))
+                 ((P1)
+                  (let ((byte-width (ceiling (/ width 8)))
+                        (pbm-image (make-pbm-image width height unsafe?)))
+                    (read-text-raster width height #f in
+                                      (lambda (x y v)
+                                        (image-set! pbm-image x y (= v 1)))
+                                      unexpected-eof-error
+                                      unexpected-character-error)
+                    pbm-image))
+                 (else
+                  (read-whitespaces*)
+                  (let ((maxval (read-number in)))
+                    (case magic-number
+                      ((P6)
+                       (read-single-whitespace*)
+                       (%make-ppm-image width height maxval
+                                        (if (< maxval 256)
+                                            (read-bytevector (* 3 width height) in)
+                                            (read-bytevector (* 6 width height) in))
+                                        unsafe?))
+                      ((P3)
+                       (let ((ppm-image (make-ppm-image width height maxval unsafe?)))
+                         (read-text-raster width height #t in (image-pixel-setter ppm-image)
+                                           unexpected-eof-error
+                                           unexpected-character-error)
+                         ppm-image))
+                      ((P5)
+                       (read-single-whitespace*)
+                       (%make-pgm-image width height maxval
+                                        (if (< maxval 256)
+                                            (read-bytevector (* width height) in)
+                                            (read-bytevector (* 2 width height) in))
+                                        unsafe?))
+                      ((P2)
+                       (let ((pgm-image (make-pgm-image width height maxval unsafe?)))
+                         (read-text-raster width height #f in (image-pixel-setter pgm-image)
+                                           unexpected-eof-error
+                                           unexpected-character-error)
+                         pgm-image))))))))))))
 
     (define (whitespace? u8)
       (case (integer->char u8)