zippy/io.lisp at master · OrganicProgramming/zippy · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#|
 This file is a part of zippy
 (c) 2020 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.zippy)

(deftype io ()
  `(or stream vector-input directory-input))

(defstruct (vector-input (:constructor make-vector-input (vector index start end)))
  (vector NIL :type (simple-array (unsigned-byte 8) (*)) :read-only T)
  (start 0 :type fixnum :read-only T)
  (end 0 :type fixnum :read-only T)
  (index 0 :type fixnum))

(defstruct directory-input)

(defun seek (io target)
  (etypecase io
    (vector-input
     (if (<= (vector-input-start io) target (1- (vector-input-end io)))
         (setf (vector-input-index io) target)
         (error "Cannot seek outside allowed vector range.")))
    (stream
     (file-position io target))))

(defun has-more (io)
  (etypecase io
    (vector-input
     (< (vector-input-index io) (vector-input-end io)))
    (stream
     (< (file-position io) (file-length io)))))

(defun index (io)
  (etypecase io
    (vector-input
     (vector-input-index io))
    (file-stream
     (file-position io))
    (stream
     0)))

(defun start (io)
  (etypecase io
    (vector-input
     (vector-input-start io))
    (stream
     0)))

(defun end (io)
  (etypecase io
    (vector-input
     (vector-input-end io))
    (stream
     (file-length io))))

(defmethod size ((io vector-input))
  (- (vector-input-end io) (vector-input-start io)))

(defmethod size ((io stream))
  (file-length io))

(defun ub32 (io)
  (etypecase io
    (vector-input
     (prog1 (nibbles:ub32ref/le (vector-input-vector io) (vector-input-index io))
       (incf (vector-input-index io) 4)))
    (stream
     (nibbles:read-ub32/le io))))

(defun output (io array start end)
  (etypecase io
    (vector-input
     (when (<= (vector-input-end io) (+ (vector-input-index io) (- end start)))
       (error "Output too long for target vector."))
     (loop with vector = (vector-input-vector io)
           for i from start below end
           for j from (vector-input-index io)
           do (setf (aref vector j) (aref array i)))
     (incf (vector-input-index io) (- end start)))
    (stream
     (write-sequence array io :start start :end end))))

(defun parse-structure* (io)
  (etypecase io
    (vector-input
     (multiple-value-bind (value index)
         (decode-structure (vector-input-vector io) (vector-input-index io))
       (setf (vector-input-index io) index)
       value))
    (stream
     (read-structure io))))

(defun write-structure* (structure io)
  (etypecase io
    (vector-input
     (setf (vector-input-index io)
           (encode-structure structure (vector-input-vector io) (vector-input-index io))))
    (stream
     (write-structure structure io)))
  io)

(defmacro parse-structure (structure-type io-var)
  (let ((io (gensym "IO")))
    `(let ((,io ,io-var))
       (etypecase ,io
         (vector-input
          (multiple-value-bind (value index)
              (,(intern (format NIL "~a-~a" 'decode structure-type))
               (vector-input-vector ,io) (vector-input-index ,io))
            (setf (vector-input-index ,io) index)
            value))
         (stream
          (,(intern (format NIL "~a-~a" 'read structure-type)) ,io))))))

(defun call-with-io (function io &key (start 0) end (if-exists :error) (direction :input))
  (etypecase io
    ((or string pathname)
     (if (pathname-utils:directory-p io)
         (funcall function (make-directory-input))
         (with-open-file (stream io :direction direction
                                    :element-type '(unsigned-byte 8)
                                    :if-exists if-exists)
           (funcall function stream))))
    (io
     (funcall function io))
    (vector
     (funcall function (make-vector-input io start start (or end (length io)))))))

(defmacro with-io ((io target &rest args) &body body)
  `(call-with-io (lambda (,io) ,@body) ,target ,@args))