X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=io.lisp;h=7f06bd9b51b2f97ef6e62f791a09260c28ecd139;hp=aedca9942a166d716bf11f44c227d711176ee105;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=09816397bfa39bd4b3c85e9f5fc05d30b073bacb diff --git a/io.lisp b/io.lisp index aedca99..7f06bd9 100644 --- a/io.lisp +++ b/io.lisp @@ -7,8 +7,6 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id$ -;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg ;;;; ;;;; KMRCL users are granted the rights to distribute and use this software @@ -23,7 +21,7 @@ (when (probe-file file) (let ((eof (cons 'eof nil))) (with-open-file (in file :direction :input) - (do ((line (read-line in nil eof) + (do ((line (read-line in nil eof) (read-line in nil eof))) ((eq line eof)) (write-string line strm) @@ -31,38 +29,37 @@ (defun read-stream-to-string (in) (with-output-to-string (out) - (let ((eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) - (format out "~A~%" line))))) - + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + (defun read-file-to-string (file) "Opens a reads a file. Returns the contents as a single string" - (with-output-to-string (out) - (with-open-file (in file :direction :input) - (read-stream-to-string in)))) + (with-open-file (in file :direction :input) + (read-stream-to-string in))) (defun read-file-to-usb8-array (file) "Opens a reads a file. Returns the contents as single unsigned-byte array" - (with-open-file (in file :direction :input) + (with-open-file (in file :direction :input :element-type '(unsigned-byte 8)) (let* ((file-len (file-length in)) - (usb8 (make-array file-len :element-type '(unsigned-byte 8))) - (pos (read-sequence usb8 in))) + (usb8 (make-array file-len :element-type '(unsigned-byte 8))) + (pos (read-sequence usb8 in))) (unless (= file-len pos) - (error "Length read (~D) doesn't match file length (~D)~%" pos file-len)) + (error "Length read (~D) doesn't match file length (~D)~%" pos file-len)) usb8))) - + (defun read-stream-to-strings (in) (let ((lines '()) - (eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) + (eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) (push line lines)) (nreverse lines))) - + (defun read-file-to-strings (file) "Opens a reads a file. Returns the contents as a list of strings" (with-open-file (in file :direction :input) @@ -71,7 +68,7 @@ (defun file-subst (old new file1 file2) (with-open-file (in file1 :direction :input) (with-open-file (out file2 :direction :output - :if-exists :supersede) + :if-exists :supersede) (stream-subst old new in out)))) (defun print-n-chars (char n stream) @@ -94,14 +91,14 @@ (defun indent-html-spaces (n &optional (stream *standard-output*)) "Indent n*2 html spaces to output stream" (print-n-strings " " (+ n n) stream)) - + (defun print-list (l &optional (output *standard-output*)) "Print a list to a stream" (format output "~{~A~%~}" l)) (defun print-rows (rows &optional (ostrm *standard-output*)) - "Print a list of list rows to a stream" + "Print a list of list rows to a stream" (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r))) @@ -126,7 +123,7 @@ (setf (bref b (incf (buf-end b))) x)) (defun buf-pop (b) - (prog1 + (prog1 (bref b (incf (buf-start b))) (setf (buf-used b) (buf-start b) (buf-new b) (buf-end b)))) @@ -192,28 +189,28 @@ (defun null-output-stream () (when (probe-file #p"/dev/null") - (open #p"/dev/null" :direction :output :if-exists :overwrite)) + (open #p"/dev/null" :direction :output :if-exists :overwrite)) ) (defun directory-tree (filename) "Returns a tree of pathnames for sub-directories of a directory" (let* ((root (canonicalize-directory-name filename)) - (subdirs (loop for path in (directory - (make-pathname :name :wild - :type :wild - :defaults root)) - when (probe-directory path) - collect (canonicalize-directory-name path)))) + (subdirs (loop for path in (directory + (make-pathname :name :wild + :type :wild + :defaults root)) + when (probe-directory path) + collect (canonicalize-directory-name path)))) (when (find nil subdirs) (error "~A" subdirs)) (when (null root) (error "~A" root)) (if subdirs - (cons root (mapcar #'directory-tree subdirs)) - (if (probe-directory root) - (list root) - (error "root not directory ~A" root))))) + (cons root (mapcar #'directory-tree subdirs)) + (if (probe-directory root) + (list root) + (error "root not directory ~A" root))))) (defmacro with-utime-decoding ((utime &optional zone) &body body) @@ -224,15 +221,15 @@ (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) ,@body)) -(defvar +datetime-number-strings+ +(defvar +datetime-number-strings+ (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil - :initial-contents - '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "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"))) + :initial-contents + '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "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"))) (defun is-dst (utime) (with-utime-decoding (utime) @@ -242,19 +239,19 @@ (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body) (with-gensyms (zone) `(let* ((,zone (cond - ((eq :utc ,utc-offset) - 0) - ((null utc-offset) - nil) - (t - (if (is-dst ,utime) - (1- (- ,utc-offset)) - (- ,utc-offset)))))) + ((eq :utc ,utc-offset) + 0) + ((null utc-offset) + nil) + (t + (if (is-dst ,utime) + (1- (- ,utc-offset)) + (- ,utc-offset)))))) (if ,zone - (with-utime-decoding (,utime ,zone) - ,@body) - (with-utime-decoding (,utime) - ,@body))))) + (with-utime-decoding (,utime ,zone) + ,@body) + (with-utime-decoding (,utime) + ,@body))))) (defun write-utime-hms (utime &key utc-offset stream) @@ -322,9 +319,78 @@ (write-char #\: stream) (write-string (aref +datetime-number-strings+ minute) stream))) -(defun copy-binary-stream (in out &key (chunk-size 4096)) +(defun copy-binary-stream (in out &key (chunk-size 16384)) (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8))) - (pos (read-sequence buf in) (read-sequence buf in))) + (pos (read-sequence buf in) (read-sequence buf in))) ((zerop pos)) (write-sequence buf out :end pos))) + +(defmacro def-unsigned-int-io (len r-name w-name &key (big-endian nil)) + "Defines read and write functions for an unsigned integer with LEN bytes from STREAM." + (when (< len 1) + (error "Number of bytes must be greater than 0.~%")) + (let ((endian-string (if big-endian "big" "little"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ,r-name (stream) + ,(format nil "Reads an ~A byte unsigned integer (~A-endian)." + len endian-string) + (declare (optimize (speed 3) (compilation-speed 0) (safety 0) + (space 0) (debug 0)) + (type stream stream)) + (let ((val 0)) + (declare (type + ,(if (< (expt 256 len) most-positive-fixnum) + 'fixnum + `(integer 0 ,(1- (expt 256 len)))) + val)) + ,@(loop for i from 1 upto len + collect + `(setf (ldb (byte 8 ,(* (if big-endian (1- i) (- len i)) + 8)) val) (read-byte stream))) + val)) + (defun ,w-name (val stream &key (bounds-check t)) + ,(format nil "Writes an ~A byte unsigned integer as binary to STREAM (~A-endian)." + len endian-string) + (declare (optimize (speed 3) (compilation-speed 0) (safety 0) + (space 0) (debug 0)) + (type stream stream) + ,(if (< (expt 256 len) most-positive-fixnum) + '(type fixnum val) + '(type integer val))) + (when bounds-check + (when (>= val ,(expt 256 len)) + (error "Number ~D is too large to fit in ~D bytes.~%" val ,len)) + (when (minusp val) + (error "Number ~D can't be written as unsigned integer." val))) + (locally (declare (type (integer 0 ,(1- (expt 256 len))) val)) + ,@(loop for i from 1 upto len + collect + `(write-byte (ldb (byte 8 ,(* (if big-endian (1- i) (- len i)) + 8)) val) stream))) + val) + nil))) + +(defmacro make-unsigned-int-io-fn (len) + "Makes reader and writer functions for unsigned byte input/output of +LEN bytes with both little and big endian order. Function names are in the +form of {READ,WRITE}-UINT-{be,le}." + `(progn + (def-unsigned-int-io + ,len + ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:le))) + ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:le))) + :big-endian nil) + (def-unsigned-int-io + ,len + ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:be))) + ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:be))) + :big-endian t))) + +(make-unsigned-int-io-fn 2) +(make-unsigned-int-io-fn 3) +(make-unsigned-int-io-fn 4) +(make-unsigned-int-io-fn 5) +(make-unsigned-int-io-fn 6) +(make-unsigned-int-io-fn 7) +(make-unsigned-int-io-fn 8)