Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / common-lisp / data-encoding / data-encoding.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               data-encoding.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    This package exports functions to encode and decode data 
10 ;;;;    in a byte vector buffer.
11 ;;;;    
12 ;;;;AUTHORS
13 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
14 ;;;;MODIFICATIONS
15 ;;;;    2004-06-18 <PJB> Extracted from palm-dba.lisp. Augmented.
16 ;;;;BUGS
17 ;;;;LEGAL
18 ;;;;    AGPL3
19 ;;;;    
20 ;;;;    Copyright Pascal J. Bourguignon 2004 - 2004
21 ;;;;    
22 ;;;;    This program is free software: you can redistribute it and/or modify
23 ;;;;    it under the terms of the GNU Affero General Public License as published by
24 ;;;;    the Free Software Foundation, either version 3 of the License, or
25 ;;;;    (at your option) any later version.
26 ;;;;    
27 ;;;;    This program is distributed in the hope that it will be useful,
28 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
29 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
30 ;;;;    GNU Affero General Public License for more details.
31 ;;;;    
32 ;;;;    You should have received a copy of the GNU Affero General Public License
33 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
34 ;;;;****************************************************************************
35
36 (in-package "COMMON-LISP-USER")
37 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.DATA-ENCODING.DATA-ENCODING"
38   (:use "COMMON-LISP"
39         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
40   (:export "SIZE-OF-ENCTYPE" "ENCTYPE-INSTANCE" "ENCTYPE-WRITE" "ENCTYPE-READ"
41            "MAKE-ENCTYPE" "DEF-ENCRECORD" "DEF-ENCTYPE")
42   (:documentation
43    "This package exports functions to encode and decode data 
44     in a byte vector buffer.
45
46     Copyright Pascal J. Bourguignon 2002 - 2004
47     This package is provided under the GNU General Public License.
48     See the source file for details."))
49 (in-package "COM.INFORMATIMAGO.COMMON-LISP.DATA-ENCODING.DATA-ENCODING")
50
51
52
53 ;; Carl Shapiro (cshapiro+spam@panix.com)
54 ;; The right way to manipulate record-oriented data in Common Lisp is by
55 ;; overlaying source data with byte-arrays which are in turn overlaid
56 ;; with displaced arrays of the correct type for the structure member
57 ;; data.  This is the strategy which the Lisp Machine uses deep within
58 ;; the file system internals as well as in other situations where
59 ;; pointer-oriented structures are not an appropriate abstraction for
60 ;; modeling domain data.  If you have control over your implementation's
61 ;; array primitives you can easily clobber the data pointer for an
62 ;; array-header object to reuse the base record and spare yourself some
63 ;; otherwise gratuitous copying.  It's "a veritable bos grunniens of
64 ;; hair", as some would have said, but at the same time, unequivocally
65 ;; effective.
66
67
68 ;; Agregate encoding types:
69 ;;
70 ;; (record lisp-type [:size size] (offset name enc-type)...)
71 ;; (array  element-enc-type dimensions)
72 ;;
73 ;;
74 ;; Simple encoding types:
75 ;;
76 ;; (string size [padchar])
77 ;; pascal-string:   (length,characters...)
78 ;; c-string:        characters...,0,garbage
79 ;; modula-2-string: characters...,0,garbage or characters...|end of field
80 ;; cobol-strings:   characters...,padchar...
81 ;;
82 ;; (string size [:green-length [integer-enc-type]
83 ;;               | [padchar] [:terminated [:if-smaller]|:padded [:strip]]])
84 ;;
85 ;; (string size
86 ;;         [:green-length [integer-enc-type]
87 ;;         | [padchar]
88 ;;           [:terminated [:if-smaller]
89 ;;           |:padded [:strip]]] [:encoding encoding] )
90 ;;
91 ;;
92 ;; (number encoding [parameters])
93 ;; encodings:
94 ;;     unsigned                                    -- unsigned binary
95 ;;     two-complement       binary    comp comp-4  -- two-complement signed bin.
96 ;;     one-complement                              -- one-complement signed bin.
97 ;;     binary-coded-decimal packed-decimal comp-3  -- signed BCD
98 ;;     ieee-float-single                   comp-1  -- CHECK IEEE SPECIFIES
99 ;;     ieee-float-double                   comp-2  -- BYTE ORDER!
100 ;;     display                                     -- ASCII
101 ;;
102 ;; unsigned             byte-size big-endian|little-endian
103 ;; two-complement       byte-size big-endian|little-endian
104 ;; one-complement       byte-size big-endian|little-endian
105 ;; binary-coded-decimal byte-size big-endian|little-endian
106 ;; ieee-float-single                     -- no parameter, 32-bit
107 ;; ieee-float-double                     -- no parameter, 64-bit
108 ;; display              "format"         -- picture format usage display
109 ;;
110 ;;     default is big-endian
111 ;;
112 ;; (number display "z(7)9")
113 ;; (number display "-Z(7)9") --> "-       1"
114 ;; (number formated "~10,3F") --> "    -1.000"
115 ;;
116 ;;
117 ;; number-enctype
118 ;;     unsigned-integer-enctype
119 ;;        two-complement-integer-enctype
120 ;;        one-complement-integer-enctype
121 ;;        binary-coded-decimal-integer-enctype
122 ;;     ieee-float-single-number-enctype
123 ;;     ieee-float-double-number-enctype
124 ;;     display-number-enctype
125
126
127 (defgeneric write-value (self buffer offset value))
128 (defgeneric number-of-digit (self))
129 (defgeneric maximum-length (self))
130 (defgeneric to-lisp-type (self))
131 (defgeneric default-value (self))
132 (defgeneric size-of-enctype (self))
133 (defgeneric get-value (self buffer offset))
134 (defgeneric set-value (self buffer offset record))
135
136 ;; ------------------------------------------------------------
137
138 (defclass enctype ()
139   ((name :accessor name :type symbol :initarg :name
140          :documentation "The root name of the type."))
141   (:documentation "An abstract encoded type."))
142
143
144
145 ;; ------------------------------------------------------------
146
147 (defclass number-enctype (enctype)
148   ((size
149     :accessor size :type fixnum :initarg :size
150     :documentation "Number of bytes used by a number in this representation.")
151    (modulo
152     :accessor modulo :type integer :initarg :modulo
153     :documentation "1+the maximum value")
154    (endian
155     :accessor endian  :initarg :endian
156     :documentation "The endian, either :big, :little or whatnot."))
157   (:documentation "An abstract number type.")) ;;number-enctype
158
159
160 ;; ------------------------------------------------------------
161
162 (defclass unsigned-integer-enctype (number-enctype)
163   ()
164   (:documentation "A binary unsigned integer type."))
165
166
167 (defmethod initialize-instance ((self unsigned-integer-enctype) &rest args)
168   (declare (ignore args))
169   (call-next-method)
170   (setf (modulo self)  (expt 2 (* 8 (size self))))
171   self) ;;initialize-instance
172
173
174 (defmethod print-object ((self unsigned-integer-enctype) (out stream))
175   (warn "We don't implement printer control variables in UNSIGNED-INTEGER-ENCTYPE PRINT-OBJECT.~&")
176   (format out "#<UNSIGNED-INTEGER ~D-BIT, ~A-ENDIAN>"
177           (* 8 (size-of-enctype self)) (endian self))
178   self) ;;print-object
179
180
181 (defmethod to-lisp-type    ((self unsigned-integer-enctype))
182   (declare (ignorable self))
183   '(integer 0))
184 (defmethod default-value   ((self unsigned-integer-enctype))
185   (declare (ignorable self))
186   0)
187 (defmethod size-of-enctype ((self unsigned-integer-enctype))
188   (size self))
189
190
191 (defmethod get-value ((self unsigned-integer-enctype) buffer offset)
192   (let ((value 0))
193     (case (endian self)
194       ((:big)    (dotimes (i (size self))
195                    (setf value (+ (* 256 value) (aref buffer (+ offset i))))))
196       ((:little) (do ((i (1- (size self)) (1- i))) ((< i 0))
197                    (setf value (+ (* 256 value) (aref buffer (+ offset i))))))
198       (otherwise (error "Unknown endian ~S" (endian self))))
199     (values value (+ offset (size self))))) ;;get-value
200
201
202 (defmethod set-value ((self unsigned-integer-enctype) buffer offset value)
203   (assert (and (integerp value) (<= 0 value) (< value (modulo self))))
204   (write-value self buffer offset value))
205
206
207 (defmethod write-value ((self unsigned-integer-enctype) buffer offset value)
208   (case (endian self)
209     ((:big)    (do ((i (1- (size self)) (1- i))) ((< i 0))
210                  (setf (aref buffer (+ offset i)) (mod value 256)
211                        value (truncate value 256))))
212     ((:little) (dotimes (i (size self))
213                  (setf (aref buffer (+ offset i)) (mod value 256)
214                        value (truncate value 256))))
215     (otherwise (error "Unknown endian ~S" (endian self))))
216   (+ offset (size self))) ;;write-value
217
218
219 ;; ------------------------------------------------------------
220
221 (defclass two-complement-integer-enctype (unsigned-integer-enctype)
222   ()
223   (:documentation "A two-complement signed integer type."))
224
225
226 (defmethod print-object ((self two-complement-integer-enctype) (out stream))
227   (warn "We don't implement printer control variables in TWO-COMPLEMENT-INTEGER-ENCTYPE PRINT-OBJECT.")
228   (format out "#<TWO-COMPLEMENT-INTEGER ~D-BIT, ~A-ENDIAN>"
229           (* 8 (size-of-enctype self)) (endian self))
230   self) ;;print-object
231
232
233 (defmethod to-lisp-type    ((self two-complement-integer-enctype))
234   (declare (ignorable self))
235   'integer)
236 (defmethod default-value   ((self two-complement-integer-enctype))
237   (declare (ignorable self))
238   0)
239 (defmethod size-of-enctype ((self two-complement-integer-enctype))
240   (size self))
241
242
243
244 (defmethod get-value ((self two-complement-integer-enctype) buffer offset)
245   (multiple-value-bind (uval noffset) (call-next-method self buffer offset)
246     (if (< uval (/ (modulo self) 2))
247         (values uval noffset)
248         (values (- uval (modulo self)) noffset)))) ;;get-value
249
250
251 (defmethod set-value ((self two-complement-integer-enctype) buffer offset value)
252   (assert (and (integerp value)
253                (<= (- (/ (modulo self) 2)) value (1- (/ (modulo self) 2)))))
254   (if (< value 0)
255       (write-value self buffer offset (+ value (modulo self)))
256       (write-value self buffer offset value))) ;;set-value
257
258
259 ;; ------------------------------------------------------------
260
261 (defclass one-complement-integer-enctype (unsigned-integer-enctype)
262   ()
263   (:documentation "A one-complement signed integer type."))
264
265
266 (defmethod print-object ((self one-complement-integer-enctype) (out stream))
267   (warn "We don't implement printer control variables in ONE-COMPLEMENT-INTEGER-ENCTYPE PRINT-OBJECT.~&")
268   (format out "#<ONE-COMPLEMENT-INTEGER ~D-BIT, ~A-ENDIAN>"
269           (* 8 (size-of-enctype self)) (endian self))
270   self) ;;print-object
271
272
273 (defmethod to-lisp-type    ((self one-complement-integer-enctype))
274   (declare (ignorable self))
275   'integer)
276 (defmethod default-value   ((self one-complement-integer-enctype))
277   (declare (ignorable self))
278   0)
279 (defmethod size-of-enctype ((self one-complement-integer-enctype))
280   (size self))
281
282
283 (defmethod get-value ((self one-complement-integer-enctype) buffer offset)
284   (multiple-value-bind (uval noffset) (call-next-method self buffer offset)
285     (if (< uval (/ (modulo self) 2))
286         (values uval noffset)
287         (values (- uval -1 (modulo self)) noffset)))) ;;get-value
288
289
290 (defmethod set-value ((self one-complement-integer-enctype) buffer offset value)
291   (assert (and (integerp value)
292                (< (- (/ (modulo self) 2)) value (/ (modulo self) 2))))
293   (if (< value 0)
294       (write-value self buffer offset (+ value (modulo self) -1))
295       (write-value self buffer offset value))) ;;set-value
296
297
298 ;; ------------------------------------------------------------
299
300 (defclass binary-coded-decimal-integer-enctype (unsigned-integer-enctype)
301   ()
302   (:documentation "A binary-coded-decimal signed integer type."))
303
304
305 (defmethod initialize-instance ((self binary-coded-decimal-integer-enctype) &rest args)
306   (declare (ignore args))
307   (call-next-method)
308   (setf (modulo self) (expt 10 (number-of-digit self)))
309   self) ;;initialize-instance
310
311
312
313 (defmethod print-object ((self binary-coded-decimal-integer-enctype) (out stream))
314   (warn "We don't implement printer control variables in BINARY-CODED-DECIMAL-INTEGER-ENCTYPE PRINT-OBJECT.~&")
315   (format out "#<BINARY-CODED-DECIMAL-INTEGER ~D-DIGITS, ~A-ENDIAN>"
316           (number-of-digit self) (endian self))
317   self) ;;print-object
318
319
320 (defmethod to-lisp-type    ((self binary-coded-decimal-integer-enctype))
321   (declare (ignorable self))
322   'integer)
323 (defmethod default-value   ((self binary-coded-decimal-integer-enctype))
324   (declare (ignorable self))
325   0)
326 (defmethod size-of-enctype ((self binary-coded-decimal-integer-enctype))
327   (size self))
328
329 (defmethod number-of-digit ((self binary-coded-decimal-integer-enctype))
330   (1- (* 2 (size-of-enctype self))))
331
332
333
334 (defun integer-to-bcd (value)
335   (do ((bcd   (if (< value 0)  #xd      #xc))
336        (value (if (< value 0) (- value) value))
337        (hex 16 (* 16 hex)))
338       ((zerop value) bcd)
339     (multiple-value-bind (q r) (truncate value 10)
340       (incf bcd (* hex r))
341       (setf value q)))) ;;integer-to-bcd
342
343
344 (defun integer-from-bcd (bcd)
345   (do ((sign   (if (= #xc (mod bcd 16)) 1 -1))
346        (value  0)
347        (bcd    (truncate bcd 16))
348        (dix 1 (* 10 dix)))
349       ((zerop bcd) (* sign value))
350     (multiple-value-bind (q r) (truncate bcd 16)
351       (incf value (* dix r))
352       (setf bcd q)))) ;;integer-from-bcd
353
354
355 (defmethod get-value ((self binary-coded-decimal-integer-enctype) buffer offset)
356   (multiple-value-bind (bcd noffset) (call-next-method self buffer offset)
357     (values (integer-from-bcd bcd) noffset)))
358
359
360 (defmethod set-value ((self binary-coded-decimal-integer-enctype) buffer offset value)
361   (assert (and (integerp value) (< (- (modulo self)) value (modulo self))))
362   (write-value self buffer offset (integer-to-bcd value)))
363
364
365 ;; ------------------------------------------------------------
366
367 ;;; (defclass display-number-enctype (number-enctype)
368 ;;;   ()
369 ;;;   (:documentation "A display number type.
370 ;;;     Inspired from COBOL PICTURE xxx USAGE DISPLAY, but in COBOL,
371 ;;;     numbers are stored in EBCDIC (usage DISPLAY), and the PICTURE
372 ;;;     is used when printing (formating) the field.
373 ;;;     Here, we want to ''store'' the number formated as per the PICTURE,
374 ;;;     and to parse it back."));;display-number-enctype
375
376
377 ;;; NOT YET: numbers stored as string need charset encoding like strings.
378 ;;;          let's declare these fields as strings and format or parse
379 ;;;          them with normal lisp functions (format, read-from-string).
380
381
382 ;; USAGE DISPLAY
383 ;; 
384 ;;     this indicates that the field is stored in an uncompressed,
385 ;;     displayable format. This is actually the default USAGE type and
386 ;;     will be assumed if the field is omitted entirely. A value of 15000
387 ;;     will be stored in a field of this type as x'f1f5f0f0f0' which is
388 ;;     the ebcdic equivalent to 15000. To calculate the length of a
389 ;;     display field count one for each occurrence of A X 9 Z * - + B / ,
390 ;;     . $ and two for each occurrence of G CR DB.
391
392 ;;
393 ;; The following PICTURE keys specify alphabetic data:      AXG
394 ;; and the following PICTURE keys specify storage variants: TRSV
395 ;; Therefore, they're not relevant to formating numeric data
396 ;; and are rejected..
397 ;;
398
399 ;; one byte for: A X 9 Z * - + B / , . $ and two for each occurrence of G CR DB.
400 ;;
401 ;; A
402 ;; 
403 ;;     corresponds to a single alphabetic character. The content of this
404 ;;     position within the data field is allowed to be any uppercase of
405 ;;     lowercase alphabetic character or a blank. Numerics and other
406 ;;     symbols are not allowed
407 ;; 
408 ;; X
409 ;; 
410 ;;     corresponds to a single alphanumeric character. Any character from
411 ;;     within the entire ebcdic character set can be contained in this
412 ;;     field.
413 ;; 
414 ;; G
415 ;; 
416 ;;     corresponds to two bytes in the field which are being used to hold
417 ;;     a double byte character. For example in Japan this definition
418 ;;     would be used for fields that hold Kanji characters.
419 ;; 
420 ;; 9
421 ;; 
422 ;;     corresponds to a numeric character. Only the numeric values of
423 ;;     zero through nine can be contained in this character.
424 ;; 
425 ;; E
426 ;; 
427 ;;     indicates that the following digits are the exponential for a
428 ;;     floating point number. For example PIC '9v99999e99'.
429 ;; 
430 ;; S
431 ;; 
432 ;;     used to indicate that a numeric field is signed. The sign is
433 ;;     always contained within the upper half byte of the last character
434 ;;     of a display field or the lower half byte of a packed decimal
435 ;;     field. A value of 'C' (12) representing positive and 'D' (13)
436 ;;     negative. Binary fields represent negative numbers using the twos
437 ;;     complement method.
438 ;; 
439 ;; T
440 ;; 
441 ;;     used to indicate that a display numeric field should only insert
442 ;;     the sign into the upper half of the last byte if the value is
443 ;;     negative.
444 ;; 
445 ;; R
446 ;; 
447 ;;     used to indicate that a display numeric field should only insert
448 ;;     the sign into the upper half of the last byte if the value is
449 ;;     positive.
450 ;; 
451 ;; P
452 ;; 
453 ;;     represents a virtual digit in a number that has no storage
454 ;;     allocated to it. For example PIC '99ppp' can contain the value
455 ;;     15000 as x'f1f5' with the number being assumed to represent
456 ;;     thousands.
457 ;; 
458 ;; V
459 ;; 
460 ;;     used to indicate the position of a virtual decimal point. For
461 ;;     example PIC '99999v99' can contain the value 15000 as
462 ;;     x'f1f5f0f0f0f0f0' with the last two digits being assumed to
463 ;;     represent hundredths.
464 ;; 
465 ;; Z
466 ;; 
467 ;;     corresponds to a leading numeric digit that if zero will be
468 ;;     replaced by blank. Usually used to suppress leading zeros on
469 ;;     numbers being printed.
470 ;; 
471 ;; *
472 ;; 
473 ;;     corresponds to a leading numeric digit that if zero will be
474 ;;     replaced by *. Usually used to suppress leading zeros on numbers
475 ;;     being printed on cheques.
476 ;; 
477 ;; -
478 ;; 
479 ;;     formatting character used with numeric fields. This will display
480 ;;     as a blank if the number is zero or positive and will display as
481 ;;     shown if the number is negative.
482 ;; 
483 ;; +
484 ;; 
485 ;;     formatting character used with numeric fields. This will display
486 ;;     as shown if the number is zero or positive and will display as a -
487 ;;     if the number is negative.
488 ;; 
489 ;; CR
490 ;; 
491 ;;     formatting character used with numeric fields. This will display
492 ;;     as a blank if the number is zero or positive and will display as
493 ;;     shown if the number is negative.
494 ;; 
495 ;; DB
496 ;; 
497 ;;     formatting character used with numeric fields. This will display
498 ;;     as shown if the number is zero or positive and will display as CR
499 ;;     if the number is negative.
500 ;; 
501 ;; B
502 ;; 
503 ;;     corresponds to a character that is always blank. Usually used to
504 ;;     insert a blank into the middle of a field that is about to be
505 ;;     output.
506 ;; 
507 ;; / or , or . or $
508 ;; 
509 ;;     formatting characters used in display fields being output. These
510 ;;     values will display exactly as shown. For example the field PIC
511 ;;     '99,999' containing the value x'f1f5f0f0f0' will print as '15,000'.
512
513
514
515 ;; ------------------------------------------------------------
516
517 (defvar +string-enctype-default-encoding+ :standard-ascii
518   "The encoding used by default when string enctypes are created
519    without specifying an encoding.
520    If you want to use another encoding (implementation dependant values),
521    you must set DECODE-STRING and ENCODE-STRING to functions that can
522    handle it.") ;;+string-enctype-default-encoding+
523
524
525 (defvar +standard-characters+ (format nil "~C~A~A~A"
526                                       #\newline
527                                       " !\"#$%&'()*+,-./0123456789:;<=>?"
528                                       "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"
529                                       "`abcdefghijklmnopqrstuvwxyz{|}~")
530   "A string containing all the COMMON-LISP standard characters,
531   first newline, then from ASCII space to ASCII tilde in order.
532   The COMMON-LISP implementation does not necessarily use the ASCII encoding
533   for its strings. Our STANDARD-DECODE-STRING and STANDARD-ENCODE-STRING
534   functions will take care to convert these characters to and from the
535   ASCII encoding.")
536
537 (eval-when (:compile-toplevel :load-toplevel :execute)
538   (defconstant +ascii-lf+ 10 "Code of ASCII LF")
539   (defconstant +ascii-cr+ 13 "Code of ASCII CR")
540   );;eval-when
541
542
543 (defun standard-decode-string (byte-vector encoding &key (start 0) (end nil))
544   "
545 PRE:     (eq encoding :standard-ascii)
546 DO:      This function decodes a byte vector containing only ASCII codes
547          of COMMON-LISP standard characters into a string.
548 "
549   (assert (eq encoding :standard-ascii))
550   (setq end (or end (length byte-vector)))
551   (assert (and (<= 0 start) (<= start end) (<= end (length byte-vector))))
552   (do ((string (make-string (- end start)))
553        (i start (1+ i))
554        (j 0 (1+ j))
555        (code))
556       ((>= i end) string)
557     (setf code (aref byte-vector i))
558     (cond
559       ((or (= code +ascii-lf+) (= code +ascii-cr+))
560        (setf (aref string j) #\newline))
561       ((<= 32 code 126)
562        (setf (aref string j) (aref +standard-characters+ (- code 31))))
563       (t
564        (error "Code ~D is not the ASCII code of a COMMON-LISP standard character."
565               code)))))
566
567
568 (defun standard-encode-string (string encoding &key (start 0) (end nil))
569   "
570 PRE:     (eq encoding :standard-ascii)
571 DO:      This function encodes a string containing only COMMON-LISP
572          standard characters into an ASCII code byte vector.
573 "
574   (assert (eq encoding :standard-ascii))
575   (setq end (or end (length string)))
576   (assert (and (<= 0 start) (<= start end) (<= end (length string))))
577   (do ((bytes (make-array (list (- end start))
578                           :element-type '(unsigned-byte 8)))
579        (i start (1+ i))
580        (j 0 (1+ j))
581        (code))
582       ((>= i end) bytes)
583     (setf code (position (aref string i) +standard-characters+))
584     (cond
585       ((null code)
586        (error "Character ~C is not a COMMON-LISP standard character."
587               (aref string i)))
588       ((= 0 code) (setf (aref bytes j) +ascii-lf+))
589       (t          (setf (aref bytes j) (+ 31 code))))) ) ;;standard-encode-string
590
591
592 (defvar decode-string (function standard-decode-string)
593   "The function used to decode strings.")
594
595
596 (defvar encode-string (function standard-encode-string)
597   "The function used to encode strings.")
598
599
600
601
602 ;; ------------------------------------------------------------
603
604 (defclass string-enctype (enctype)
605   ((allocated-size
606     :accessor allocated-size :type fixnum :initarg :allocated-size :initform 0
607     :documentation "The total number of bytes where the string is stored.")
608    (pad-code
609     :accessor pad-code :type (unsigned-byte 8) :initarg :pad-code :initform 0
610     :documentation "The code used as terminator or to pad the string.")
611    (encoding
612     :accessor encoding :initarg :encoding
613     :initform +string-enctype-default-encoding+
614     :documentation
615     "The encoding used to convert between strings and byte vectors.
616      The :standard encoding use the ASCII code on the COMMON-LISP standard
617      characters. The presence of any other character throws an error."))
618   (:documentation "")) ;;string-enctype
619
620
621 (defmethod to-lisp-type    ((self string-enctype))
622   (declare (ignorable self))
623   'string)
624 (defmethod default-value   ((self string-enctype))
625   (declare (ignorable self))
626   "")
627 (defmethod size-of-enctype ((self string-enctype))
628   (allocated-size self))
629
630
631 ;; ............................................................
632
633 (defclass green-length-string-enctype (string-enctype)
634   ((green-length
635     :accessor green-length :type number-enctype
636     :initarg :green-length 
637     :documentation "The enctype used to store the green length.
638     The PAD-CODE is used to ease processing by external programs."))
639   (:documentation "")) ;;green-length-string-enctype
640
641
642 (defmethod print-object ((self green-length-string-enctype) (out stream))
643   (warn "We don't implement printer control variables in GREEN-LENGTH-STRING-ENCTYPE PRINT-OBJECT.~&")
644   (format out "#<GREEN-LENGTH-STRING ~D WITH GREEN-LENGTH ~S, ENCODED IN ~A>"
645           (allocated-size self)  (green-length self) (encoding self))
646   self) ;;print-object
647
648
649 (defmethod maximum-length ((self green-length-string-enctype))
650   (- (allocated-size self) (size-of-enctype (green-length self))))
651
652
653 (defmethod get-value ((self green-length-string-enctype) buffer offset)
654   (assert (<= (+ offset (allocated-size self)) (length buffer))
655           () "Buffer overflow: field-size=~D > ~D=available size."
656           (allocated-size self) (- (length buffer) offset))
657   (multiple-value-bind
658         (length bytes-offset) (get-value (green-length self) buffer offset)
659     (values (funcall decode-string buffer (encoding self)
660                      :start bytes-offset :end (+ bytes-offset length))
661             (+ offset (allocated-size self))))) ;;get-value
662
663
664 (defmethod set-value ((self green-length-string-enctype) buffer offset string)
665   (assert (<= (+ offset (allocated-size self)) (length buffer))
666           () "Buffer overflow: field-size=~D > ~D=available size."
667           (allocated-size self) (- (length buffer) offset))
668
669   (let ((bytes (funcall encode-string string (encoding self))))
670     (assert (<= (length bytes) (maximum-length self))
671             () "String too long for field: encoded bytes=~D>~D=maximum length."
672             (length bytes) (maximum-length self))
673     (let ((bytes-offset
674            (set-value (green-length self) buffer offset (length bytes))))
675       (replace buffer bytes
676                :start1 bytes-offset)
677       (fill buffer (pad-code self)
678             :start (+ bytes-offset (length bytes))
679             :end   (+ offset (allocated-size self)))))
680   (+ offset (allocated-size self))) ;;set-value
681
682
683 ;; ............................................................
684
685 (defclass terminated-string-enctype (string-enctype)
686   ((if-smaller
687     :accessor if-smaller :type boolean :initarg :if-smaller :initform nil
688     :documentation "When NIL, the maximum length for the string is one less
689     the allocated size, and the terminator character is always present."))
690   (:documentation "")) ;;terminated-string-enctype
691
692
693 (defmethod print-object ((self terminated-string-enctype) (out stream))
694   (warn "We don't implement printer control variables in TERMINATED-STRING-ENCTYPE PRINT-OBJECT.~&")
695   (format out
696     "#<TERMINATED-STRING ~D TERMINATED WITH ~S~:[~; IF-SMALLER~], ENCODED IN ~A>"
697     (allocated-size self) (pad-code self) (if-smaller self) (encoding self))
698   self) ;;print-object
699
700
701 (defmethod maximum-length ((self terminated-string-enctype))
702   (if (if-smaller self)
703       (allocated-size self)
704       (1- (allocated-size self))))
705
706
707
708 (defmethod get-value ((self terminated-string-enctype) buffer offset)
709   "
710 NOTE:   We don't check for if-smaller terminator, but we limit to allocated size.
711 "
712   (assert (<= (+ offset (allocated-size self)) (length buffer))
713           () "Buffer overflow: field-size=~D > ~D=available size."
714           (allocated-size self) (- (length buffer) offset))
715   (values (funcall decode-string buffer (encoding self)
716                    :start offset
717                    :end  (do ((end offset (1+ end))
718                               (limit (+ offset (allocated-size self))))
719                              ((or (>= end limit)
720                                   (= (pad-code self) (aref buffer end)))
721                               end)))
722           (+ offset (allocated-size self)))) ;;get-value
723
724
725 (defmethod set-value ((self terminated-string-enctype) buffer offset string)
726   "
727 NOTE:    The handling of IF-SMALLER is hidden in (MAXIMUM-LENGTH SELF).
728 NOTE:    This is the same implementation as for PADDED-STRING-ENCTYPE.
729 "
730   (assert (<= (+ offset (allocated-size self)) (length buffer))
731           () "Buffer overflow: field-size=~D > ~D=available size."
732           (allocated-size self) (- (length buffer) offset))
733   (let ((bytes (funcall encode-string string (encoding self))))
734     (assert (<= (length bytes) (maximum-length self))
735             () "String too long for field: encoded bytes=~D>~D=maximum length."
736             (length bytes) (maximum-length self))
737     (replace buffer bytes :start1 offset)
738     (fill buffer (pad-code self)
739           :start (+ offset (length bytes))
740           :end   (+ offset (allocated-size self))))
741   (+ offset (allocated-size self))) ;;set-value
742
743
744 ;; ............................................................
745
746 (defclass padded-string-enctype (string-enctype)
747   ((strip
748     :accessor strip :type boolean :initarg :strip      :initform nil
749     :documentation "The PAD-CODE must be removed in the lisp string."))
750   (:documentation "")) ;;padded-string-enctype
751
752                                                               
753 (defmethod print-object ((self padded-string-enctype) (out stream))
754   (warn "We don't implement printer control variables in PADDED-STRING-ENCTYPE PRINT-OBJECT.~&")
755   (format out
756     "#<PADDED-STRING ~D PADDED WITH ~S~:[~;, STRIPPED~], ENCODED IN ~A>"
757     (allocated-size self) (pad-code self) (strip self) (encoding self))
758   self) ;;print-object
759
760
761 (defmethod maximum-length ((self padded-string-enctype))
762   (allocated-size self))
763
764
765
766 (defmethod get-value ((self padded-string-enctype) buffer offset)
767   "
768 "
769   (assert (<= (+ offset (allocated-size self)) (length buffer))
770           () "Buffer overflow: field-size=~D > ~D=available size."
771           (allocated-size self) (- (length buffer) offset))
772   (values (funcall decode-string buffer (encoding self)
773                    :start offset
774                    :end  (if (strip self)
775                              (do ((end (+ offset (allocated-size self)) (1- end)))
776                                  ((or (<= end offset)
777                                       (/= (pad-code self) (aref buffer (1- end))))
778                                   end))
779                              (+ offset (allocated-size self))))
780           (+ offset (allocated-size self)))) ;;get-value
781
782
783 (defmethod set-value ((self padded-string-enctype) buffer offset string)
784   "
785 NOTE:    This is the same implementation as for TERMINATED-STRING-ENCTYPE.
786 "
787   (assert (<= (+ offset (allocated-size self)) (length buffer))
788           () "Buffer overflow: field-size=~D > ~D=available size."
789           (allocated-size self) (- (length buffer) offset))
790   (let ((bytes (funcall encode-string string (encoding self))))
791     (assert (<= (length bytes) (maximum-length self))
792             () "String too long for field: encoded bytes=~D>~D=maximum length."
793             (length bytes) (maximum-length self))
794     (replace buffer bytes :start1 offset)
795     (fill buffer (pad-code self)
796           :start (+ offset (length bytes))
797           :end   (+ offset (allocated-size self))))
798   (+ offset (allocated-size self))) ;;set-value
799
800
801
802 ;; ------------------------------------------------------------
803 ;; array
804
805 (defclass array-enctype (enctype)
806   ((dimensions :accessor dimensions :type list :initarg :dimensions
807                :initform ())
808    (element-type
809     :accessor element-type :type enctype :initarg :element-type
810     :documentation "The enctype instance of the type of the elements"))
811   (:documentation "An array type.")) ;;array-enctype
812
813
814 (defmethod print-object ((self array-enctype) (out stream))
815   (warn "We don't implement printer control variables in ARRAY-ENCTYPE PRINT-OBJECT.")
816   (format out "#<ARRAY ~S [~S]>" (element-type self) (dimensions self) )
817   self)
818
819
820 (defmethod to-lisp-type  ((self array-enctype))
821   `(array ,(to-lisp-type (element-type self)) ,(dimensions self)))
822
823
824 (defmethod default-value ((self array-enctype))  
825   `(make-array ',(dimensions self)
826                :initial-element (default-value (element-type self))))
827
828
829 (defmethod size-of-enctype ((self array-enctype))
830   (apply (function *) (size-of-enctype (element-type self)) (dimensions self)))
831
832
833 (defmethod get-value ((self array-enctype) buffer offset)
834   (let* ((element-size (size-of-enctype (element-type self)))
835          (dimensions (dimensions self))
836          (array (make-array
837                  dimensions
838                  :element-type (to-lisp-type (element-type self)))))
839     (when (> (length dimensions) 1)
840       (error "Reading multidimensional array not implemented yet."))
841     (do ((i 0 (1+ i))
842          (o offset (+ o element-size)))
843         ((>= i (first dimensions))
844          array)
845       (setf (aref array i) (get-value (element-type self) buffer o)))
846     (values array (+ offset (size-of-enctype self))))) ;;get-value
847
848
849 (defmethod set-value ((self array-enctype) buffer offset array)
850   (assert (equal (array-dimensions array) (dimensions self)))
851   (do ((i 0 (1+ i))
852        (o offset (+ o (size-of-enctype (element-type self)))))
853       ((>= i (first (dimensions self)))
854        o)
855     (set-value (element-type self) buffer o (aref array i)))) ;;set-value
856
857
858 ;; ------------------------------------------------------------
859 ;; record
860
861
862 (defclass record-enctype (enctype)
863   ((lisp-type
864     :accessor lisp-type
865     :type symbol
866     :initarg :lisp-type
867     :documentation
868     "The name of the class whose instances store the record fields.
869 We need to use a class instead of a structure to be able to dynamically
870 set and retrieve the values of the fields.")
871    (size
872     :accessor size
873     :type (and fixnum (integer 0)) ; fixnum doesn't take any argument.
874     :initarg :size
875     :initform 0)
876    (fields
877     :accessor fields
878     :type list
879     :initarg :fields
880     :initform ()
881     :documentation "A list of field structures in no particular order."))
882   (:documentation "A record type.")) ;;record-enctype
883
884
885 (defstruct field
886   (offset 0   :type integer)
887   (name   nil :type symbol)
888   (type   nil :type (or null enctype)))
889
890
891 (defmethod print-object ((self record-enctype) (out stream))
892   (warn "We don't implement printer control variables in RECORD-ENCTYPE PRINT-OBJECT.")
893   (format out "~&#<RECORD ~S :SIZE ~D~{~&  ~S~}>" (lisp-type self)
894           (size self) (fields self))
895   self) ;;print-object
896
897
898 (defmethod to-lisp-type  ((self record-enctype))
899   (lisp-type self))
900
901
902 (defmethod default-value ((self record-enctype))  
903   `(make-instance (lisp-type self)))
904
905
906 (defmethod size-of-enctype ((self record-enctype))
907   (size self))
908
909
910 (defmethod get-value ((self record-enctype) buffer offset)
911   (values
912    (apply (function make-instance) (lisp-type self)
913           (mapcan (lambda (field)
914                     (list (conc-symbol (field-name field) :package "KEYWORD")
915                           (get-value (field-type field)
916                                      buffer (+ offset (field-offset field)))))
917                   (fields self)))
918    (+ offset (size-of-enctype self)))) ;;get-value
919
920
921 (defmethod set-value ((self record-enctype) buffer offset record)
922   (map nil (lambda (field)
923              (set-value (field-type field)
924                         buffer (+ offset (field-offset field))
925                         (slot-value record (field-name field))))
926        (fields self))
927   (+ offset (size-of-enctype self))) ;;set-value
928
929
930
931 ;; ------------------------------------------------------------------------
932 ;; 
933 ;; Here, we map enctype descriptors (sexps) to clos instances of
934 ;; the enctype classes defined above.
935 ;;
936
937 (defparameter *enctype-instances* (make-hash-table :test (function equal))
938   "A cache for all the enctypes seen,
939    mapping the enctype descriptor to the clos instance representing it.")
940
941
942 (defparameter *enctype-definitions* (make-hash-table :test (function eq))
943   "The type definitions")
944
945
946 (defun purge ()
947   (setf *enctype-instances* (make-hash-table :test (function equal))
948         *enctype-definitions* (make-hash-table :test (function eq))))
949
950
951 (defun defined-enctype (sexp)
952   (let ((ad (gethash (car sexp) *enctype-definitions*)))
953     (if ad
954         (let ((name           (car sexp))
955               (effective-args (cdr sexp))
956               (formal-args    (car ad))
957               (definition     (cdr ad)))
958           (unless (= (length effective-args) (length formal-args))
959             (error "Number of argument mismatch for type ~A, expected ~D, got ~D."
960                    name (length formal-args) (length effective-args)))
961           (map nil
962                (lambda (value arg)
963                  (setf definition (subst value arg definition
964                                          :test (function eq))))
965                effective-args formal-args)
966           definition)
967         (error "Unknown enctype ~S." sexp)))) ;;defined-enctype
968
969
970
971
972 (defun make-enctype-instance (enctype)
973   "
974 ENCTYPE: A sexp denoting the enctype.
975          enctype ::= 
976             (record lisp-type [:size size] (offset name enc-type)...)
977             (array  element-enc-type dimensions)
978             (string size ...)
979             (number encoding [parameters])
980             (defined-type ...)
981 RETURN:  An instance of a subclass of enctype representing the enctype.
982 "
983   (assert (and (listp enctype) (car enctype) (symbolp (car enctype))))
984   (scase (first enctype)
985     ;;   (record :lisp-type lisp-type :size size record-options...
986     ;;           :fields ((name type [:offset offset field-options...])...)))
987     ((record)
988      (make-instance 'record-enctype
989        :name :record
990        :lisp-type (getf (cdr enctype) :lisp-type)
991        :size (let ((size-option (getf (cdr enctype) :size)))
992                (if size-option
993                    size-option
994                    (let ((offset 0))
995                      (maximize
996                       (lambda (field)
997                         (let ((new-offset (getf (cddr field) :offset))
998                               (enctype (enctype-instance (second field))))
999                           (when new-offset (setf offset new-offset))
1000                           (incf offset (size-of-enctype enctype))))
1001                       (getf (cdr enctype) :fields)))))
1002        :fields (let ((offset 0))
1003                  (mapcar
1004                   (lambda (field)
1005                     (let ((new-offset (getf (cddr field) :offset))
1006                           (enctype (enctype-instance (second field))))
1007                       (when new-offset (setf offset new-offset))
1008                       (prog1 (make-field :offset offset
1009                                          :name (first field)
1010                                          :type enctype)
1011                         (incf offset (size-of-enctype enctype)))))
1012                   (getf (cdr enctype) :fields)))))
1013     ((array)
1014      (make-instance 'array-enctype
1015        :name :array
1016        :element-type (enctype-instance (second enctype))
1017        :dimensions   (third enctype) ))
1018     ((string)
1019      (do ((allocated-size (second enctype))
1020           (args (cddr enctype))
1021           (green-length nil)(terminated nil)(if-smaller nil)
1022           (padded nil)(strip nil)(encoding :standard-ascii)(pad-code 0))
1023          ((null args)
1024           (when (or (and terminated green-length) (and terminated padded)
1025                     (and green-length padded))
1026             (error "Incompatible string enctype arguments in ~S" enctype))
1027           (cond
1028             (green-length (make-instance 'green-length-string-enctype
1029                             :name :string
1030                             :allocated-size allocated-size
1031                             :encoding encoding
1032                             :pad-code pad-code
1033                             :green-length green-length))
1034             (terminated   (make-instance 'terminated-string-enctype
1035                             :name :string
1036                             :allocated-size allocated-size
1037                             :encoding encoding
1038                             :pad-code pad-code
1039                             :if-smaller if-smaller))
1040             (t            (make-instance 'padded-string-enctype
1041                             :name :string
1042                             :allocated-size allocated-size
1043                             :encoding encoding
1044                             :pad-code pad-code
1045                             :strip strip))))
1046        (scase (car args)
1047          ((:green-length)
1048           (pop args)
1049           (setf green-length
1050                 (if (or (listp (car args))
1051                         (and (symbolp (car args)) (not (keywordp (car args)))))
1052                     (enctype-instance (pop args))
1053                     (enctype-instance '(number unsigned 8)))))
1054          ((:terminated) (pop args) (setf terminated t))
1055          ((:if-smaller) (pop args) (setf if-smaller t))
1056          ((:padded)     (pop args) (setf padded t))
1057          ((:strip)      (pop args) (setf strip  t))
1058          ((:encoding)   (pop args) (setf encoding (pop args)))
1059          ((null)        (pop args) (setf pad-code 0))
1060          ((space)
1061           (pop args)
1062           (setf pad-code (aref (standard-encode-string " " :standard-ascii) 0)))
1063          ;; TODO: replace :standard-ascii by the encoding used by the string.
1064          (otherwise
1065           (typecase (car args)
1066             (character
1067              (setf pad-code (aref (standard-encode-string
1068                                    (format nil "~C" (pop args))
1069                                    :standard-ascii) 0)))
1070             ;; TODO: replace :standard-ascii by the encoding used by the string.
1071             (string
1072              (setf pad-code (aref (standard-encode-string
1073                                    (pop args) :standard-ascii) 0)))
1074             (integer
1075              (setf pad-code (pop args))
1076              (assert (<= 0 pad-code 255)))
1077             (otherwise
1078              (error "Invalid argument to string enctype declation: ~S"
1079                     (car args)))) ))))
1080     ((number)
1081      (let ((encoding (second enctype))
1082            (size     (third enctype))
1083            (endian   (fourth enctype))
1084            (class))
1085        (setf class (scase (second enctype)
1086                      ((unsigned)
1087                       'unsigned-integer-enctype)
1088                      ((two-complement binary comp comp-4)
1089                       'two-complement-integer-enctype)
1090                      ((one-complement)
1091                       'one-complement-integer-enctype)
1092                      ((binary-coded-decimal packed-decimal comp-3)
1093                       'binary-coded-decimal-integer-enctype)
1094                      ;; ((ieee-float-single comp-1) 'ieee-float-single-enctype)
1095                      ;; ((ieee-float-double comp-2) 'ieee-float-double-enctype)
1096                      (otherwise (error "Unknown number encoding ~S." 
1097                                        encoding))))
1098        (assert (integerp size))
1099        (setf endian (cdr (assoc (or endian 'big-endian)
1100                                 '((big-endian . :big)
1101                                   (little-endian . :little))
1102                                 :test (function string=))))
1103        (assert endian (endian) "Invalid endian ~S" (fourth enctype))
1104        (make-instance class  :name :number :size size :endian endian)))
1105     (otherwise (make-enctype-instance (defined-enctype enctype))))
1106   ) ;;make-enctype-instance
1107
1108
1109
1110 (defun enctype-instance (enctype)
1111   "
1112 ENCTYPE: A sexp denoting the enctype.
1113          enctype ::= 
1114             (record lisp-type [:size size] (offset name enc-type)...)
1115             (array  element-enc-type dimensions)
1116             (string size ...)
1117             (number encoding [parameters])
1118             (defined-type ...)
1119             defined-type
1120 RETURN:  An instance of a subclass of enctype representing the enctype.
1121 "
1122   (or (gethash enctype *enctype-instances*)
1123       (setf (gethash enctype *enctype-instances*)
1124             (typecase enctype
1125               (symbol (make-enctype-instance (defined-enctype (list enctype))))
1126               (list
1127                (scase (first enctype)
1128                  ((string array record number) (make-enctype-instance enctype))
1129                  (otherwise (make-enctype-instance (defined-enctype enctype)))))
1130               (otherwise
1131                (error "Unknown enctype ~S." enctype)))))) ;;enctype-instance
1132
1133
1134
1135 (defun enctype-read (encname enctype stream)
1136   "
1137 DO:      Read from the STREAM a value of type ENCTYPE.
1138 RETURN:  The decoded list value.
1139 "
1140   (let ((buffer (make-array (list (size-of-enctype enctype))
1141                             :element-type '(unsigned-byte 8)
1142                             :initial-element 0)))
1143     (if (= (length buffer) (read-sequence buffer stream))
1144         (get-value enctype buffer 0)
1145         (error "Could not read a ~A (~D bytes)." encname (length buffer))))
1146   ) ;;ENCTYPE-READ
1147
1148
1149 (defun enctype-write (encname enctype stream value)
1150   "
1151 DO:      Write to the STREAM a value of type ENCTYPE.
1152 "
1153   (declare (ignore encname))
1154   (let ((buffer (make-array (list (size-of-enctype enctype))
1155                             :element-type '(unsigned-byte 8)
1156                             :initial-element 0)))
1157     (set-value enctype buffer 0 value)
1158     (write-sequence buffer stream))) ;;ENCTYPE-WRITE
1159
1160
1161
1162
1163 ;; deftype - like API
1164 ;; (def-enctype name lambda-list [[declaration* | documentation]] form*)
1165 ;; (def-enctype name (arg...)
1166 ;;   (record :lisp-type lisp-type :size size record-options...
1167 ;;           :fields ((name type [:offset offset field-options...])...)))
1168 ;;
1169 ;; defstruct - like  API:
1170 ;; (def-encrecord name-and-options [documentation] {slot-description}*)
1171
1172
1173
1174 (defun make-enctype (name args definition)
1175   (setf (gethash name *enctype-definitions*) (cons args definition))
1176   name)
1177
1178
1179 (defmacro def-enctype (name args definition)
1180   "
1181 DO:     Defines an enctype template.
1182 "
1183   ;; TODO: make it more deftype - like.
1184   ;; TODO: we cannot create an instance because a def-enctype is actually a template.  But not when there's no argument! So we could create the reader and writer sometimes.
1185   `(make-enctype ',name ',args ',definition)) ;;def-enctype
1186
1187
1188
1189
1190 (defun even-list-p (list)
1191   (cond
1192     ((null list) t)
1193     ((null (cdr list)) nil)
1194     (t (even-list-p (cddr list))))) ;;even-list-p
1195
1196
1197
1198 (defmacro def-encrecord (name-and-options &rest doc-and-fields)
1199   "
1200 DO:     Defines an enctype template for a record type,
1201         a lisp structure with the same name,
1202         a reader and a writer functions.
1203 "
1204   (let ((name (if (symbolp name-and-options) 
1205                   name-and-options
1206                   (car name-and-options)))
1207         (options (if (symbolp name-and-options) 
1208                      nil
1209                      (cdr name-and-options)))
1210         (documentation (when (stringp (car doc-and-fields))
1211                          (car doc-and-fields)))
1212         (fields (if (stringp (car doc-and-fields))
1213                     (cdr doc-and-fields)
1214                     doc-and-fields)))
1215     (unless (even-list-p options)
1216       (error "Odd options ~S." options))
1217     `(progn
1218        (def-enctype ,name () 
1219          (record :name ,name ,@options ,@(unless (getf options :lisp-type) 
1220                                                  (list :lisp-type name))
1221                  ,@(when documentation
1222                          (list :documentation documentation))
1223                  :fields ,fields))
1224        (defstruct ,name  ,@(when documentation
1225                                  (list :documentation documentation))
1226                   ,@(mapcar (lambda (oof)
1227                               (let ((enctype (enctype-instance (second oof))))
1228                                 `(,(first oof) ,(default-value enctype)
1229                                    :type ,(to-lisp-type enctype))))
1230                             fields))
1231        (let ((enctype (enctype-instance ',name)))
1232          (setf (name enctype) ',name)
1233          (defun ,(conc-symbol "READ-" name)  (stream)
1234            (enctype-read  ',name enctype stream))
1235          (defun ,(conc-symbol "WRITE-" name) (value stream)
1236            (enctype-write ',name enctype stream value))
1237          ',name)))) ;;def-encrecord
1238
1239     
1240
1241
1242 ;; ----------------------------------------------------------------------
1243 ;;
1244 ;; http://www.felgall.com/cob1.htm
1245 ;;
1246 ;;
1247 ;; (cobol picture "s99v99"  usage comp-3)
1248 ;; One can have a field encoded as a string containing a lisp integer
1249 ;; for example.
1250 ;; (cobol pic Z(3)9 usage display) or (string 5 #\space) o (string 12 #\null)
1251 ;;
1252 ;; Should cobol encoding imply EBCDIC?
1253 ;; No because we want to benefit from its expressive power with other
1254 ;; character encodings too. The character encoding will be specified
1255 ;; globally. See: EXT:CONVERT-STRING-TO-BYTES.
1256 ;;
1257 ;; usage:
1258 ;; ------
1259 ;;
1260 ;; DISPLAY
1261 ;; 
1262 ;;     this indicates that the field is stored in an uncompressed,
1263 ;;     displayable format. This is actually the default USAGE type and
1264 ;;     will be assumed if the field is omitted entirely. A value of 15000
1265 ;;     will be stored in a field of this type as x'f1f5f0f0f0' which is
1266 ;;     the ebcdic equivalent to 15000. To calculate the length of a
1267 ;;     display field count one for each occurrence of A X 9 Z * - + B / ,
1268 ;;     . $ and two for each occurrence of G CR DB.
1269 ;; 
1270 ;; INDEX
1271 ;; 
1272 ;;     A four byte binary field is used to store an index. The value of
1273 ;;     an index field should not be directly accessed. An index is
1274 ;;     incremented and decremented in multiples of the size of the field
1275 ;;     that the index is on.
1276 ;; 
1277 ;; POINTER
1278 ;; 
1279 ;;     A four byte binary field is also used to store a pointer.
1280 ;; 
1281 ;; BINARY or COMP or COMP-4
1282 ;; 
1283 ;;     These are all equivalent and define a field as being stored in a
1284 ;;     binary compressed format. A binary field to hold 1-4 digits will
1285 ;;     take up two bytes, one to hold 5-9 digits will take four bytes,
1286 ;;     and one to hold 10-18 digits will take eight bytes. A value of
1287 ;;     15000 will be stored in a field of this type as x'00003a98' which
1288 ;;     is the hexadecimal equivalent of 15000.
1289 ;; 
1290 ;; PACKED-DECIMAL or COMP-3
1291 ;; 
1292 ;;     These are equivalent and define the field as having two digits
1293 ;;     compressed into each byte (with the last half byte reserved for
1294 ;;     the sign). A value of 15000 will be stored in a field of this type
1295 ;;     as x'15000C'. To calculate the length of a packed decimal field
1296 ;;     add 1 to the number of digits (9s in the pic'999' field) divide by
1297 ;;     two and round halves up to the next byte.
1298 ;; 
1299 ;; COMP-1
1300 ;; 
1301 ;;     Identifies the field as a single precision floating point number.
1302 ;; 
1303 ;; COMP-2
1304 ;; 
1305 ;;     Identifies the field as a double precision floating point number.
1306 ;; 
1307 ;;
1308 ;; picture:
1309 ;; --------
1310 ;;
1311 ;; one byte for: A X 9 Z * - + B / , . $ and two for each occurrence of G CR DB.
1312 ;;
1313 ;; A
1314 ;; 
1315 ;;     corresponds to a single alphabetic character. The content of this
1316 ;;     position within the data field is allowed to be any uppercase of
1317 ;;     lowercase alphabetic character or a blank. Numerics and other
1318 ;;     symbols are not allowed
1319 ;; 
1320 ;; X
1321 ;; 
1322 ;;     corresponds to a single alphanumeric character. Any character from
1323 ;;     within the entire ebcdic character set can be contained in this
1324 ;;     field.
1325 ;; 
1326 ;; G
1327 ;; 
1328 ;;     corresponds to two bytes in the field which are being used to hold
1329 ;;     a double byte character. For example in Japan this definition
1330 ;;     would be used for fields that hold Kanji characters.
1331 ;; 
1332 ;; 9
1333 ;; 
1334 ;;     corresponds to a numeric character. Only the numeric values of
1335 ;;     zero through nine can be contained in this character.
1336 ;; 
1337 ;; E
1338 ;; 
1339 ;;     indicates that the following digits are the exponential for a
1340 ;;     floating point number. For example PIC '9v99999e99'.
1341 ;; 
1342 ;; S
1343 ;; 
1344 ;;     used to indicate that a numeric field is signed. The sign is
1345 ;;     always contained within the upper half byte of the last character
1346 ;;     of a display field or the lower half byte of a packed decimal
1347 ;;     field. A value of 'C' (12) representing positive and 'D' (13)
1348 ;;     negative. Binary fields represent negative numbers using the twos
1349 ;;     complement method.
1350 ;; 
1351 ;; T
1352 ;; 
1353 ;;     used to indicate that a display numeric field should only insert
1354 ;;     the sign into the upper half of the last byte if the value is
1355 ;;     negative.
1356 ;; 
1357 ;; R
1358 ;; 
1359 ;;     used to indicate that a display numeric field should only insert
1360 ;;     the sign into the upper half of the last byte if the value is
1361 ;;     positive.
1362 ;; 
1363 ;; P
1364 ;; 
1365 ;;     represents a virtual digit in a number that has no storage
1366 ;;     allocated to it. For example PIC '99ppp' can contain the value
1367 ;;     15000 as x'f1f5' with the number being assumed to represent
1368 ;;     thousands.
1369 ;; 
1370 ;; V
1371 ;; 
1372 ;;     used to indicate the position of a virtual decimal point. For
1373 ;;     example PIC '99999v99' can contain the value 15000 as
1374 ;;     x'f1f5f0f0f0f0f0' with the last two digits being assumed to
1375 ;;     represent hundredths.
1376 ;; 
1377 ;; Z
1378 ;; 
1379 ;;     corresponds to a leading numeric digit that if zero will be
1380 ;;     replaced by blank. Usually used to suppress leading zeros on
1381 ;;     numbers being printed.
1382 ;; 
1383 ;; *
1384 ;; 
1385 ;;     corresponds to a leading numeric digit that if zero will be
1386 ;;     replaced by *. Usually used to suppress leading zeros on numbers
1387 ;;     being printed on cheques.
1388 ;; 
1389 ;; -
1390 ;; 
1391 ;;     formatting character used with numeric fields. This will display
1392 ;;     as a blank if the number is zero or positive and will display as
1393 ;;     shown if the number is negative.
1394 ;; 
1395 ;; +
1396 ;; 
1397 ;;     formatting character used with numeric fields. This will display
1398 ;;     as shown if the number is zero or positive and will display as a -
1399 ;;     if the number is negative.
1400 ;; 
1401 ;; CR
1402 ;; 
1403 ;;     formatting character used with numeric fields. This will display
1404 ;;     as a blank if the number is zero or positive and will display as
1405 ;;     shown if the number is negative.
1406 ;; 
1407 ;; DB
1408 ;; 
1409 ;;     formatting character used with numeric fields. This will display
1410 ;;     as shown if the number is zero or positive and will display as CR
1411 ;;     if the number is negative.
1412 ;; 
1413 ;; B
1414 ;; 
1415 ;;     corresponds to a character that is always blank. Usually used to
1416 ;;     insert a blank into the middle of a field that is about to be
1417 ;;     output.
1418 ;; 
1419 ;; / or , or . or $
1420 ;; 
1421 ;;     formatting characters used in display fields being output. These
1422 ;;     values will display exactly as shown. For example the field PIC
1423 ;;     '99,999' containing the value x'f1f5f0f0f0' will print as '15,000'.
1424 ;;
1425 ;; ----------------------------------------------------------------------
1426
1427
1428 ;;;; data-encoding.lisp               --                     --          ;;;;