;;; open.lisp ;;; ;;; Copyright (C) 2003-2005 Peter Graves ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License ;;; as published by the Free Software Foundation; either version 2 ;;; of the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; As a special exception, the copyright holders of this library give you ;;; permission to link this library with independent modules to produce an ;;; executable, regardless of the license terms of these independent ;;; modules, and to copy and distribute the resulting executable under ;;; terms of your choice, provided that you also meet, for each linked ;;; independent module, the terms and conditions of the license of that ;;; module. An independent module is a module which is not derived from ;;; or based on this library. If you modify this library, you may extend ;;; this exception to your version of the library, but you are not ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. ;;; Adapted from SBCL. (in-package #:system) (defun upgraded-element-type-bits (bits) (if (zerop (mod bits 8)) bits (+ bits (- 8 (mod bits 8))))) (defun upgraded-element-type (element-type) (setf element-type (normalize-type element-type)) (let ((ok nil)) (if (atom element-type) (case element-type ((character base-char) (setf ok t)) ((unsigned-byte signed-byte) (setf element-type (list element-type 8) ok t)) (bit (setf element-type (list 'unsigned-byte (upgraded-element-type-bits 1)) ok t)) (integer (setf element-type '(signed-byte 8) ok t))) (cond ((eq (%car element-type) 'or) (let ((types (mapcar #'upgraded-element-type (%cdr element-type))) (result '(unsigned-byte 8))) (dolist (type types) (when (eq (car type) 'signed-byte) (setf (car result) 'signed-byte)) (setf (cadr result) (max (cadr result) (cadr type)))) (setf element-type result ok t))) ((and (= (length element-type) 2) (memq (%car element-type) '(unsigned-byte signed-byte))) (let ((type (car element-type)) (width (cadr element-type))) (setf element-type (list type (upgraded-element-type-bits width)) ok t))) ((eq (car element-type) 'integer) (case (length element-type) (2 (setf element-type '(signed-byte 8) ok t)) (3 (let ((low (cadr element-type)) (high (caddr element-type))) (when (consp low) (setf low (1+ (%car low)))) (when (consp high) (setf high (1- (%car high)))) (setf element-type (cond ((eq high '*) (if (minusp low) '(signed-byte 8) '(unsigned-byte 8))) ((minusp low) (list 'signed-byte (upgraded-element-type-bits (max (1+ (integer-length low)) (integer-length high))))) (t (list 'unsigned-byte (upgraded-element-type-bits (integer-length high))))) ok t))))))) (if ok element-type (error 'file-error :format-control "Unsupported element type ~S." :format-arguments (list element-type))))) (defun open (filename &key (direction :input) (element-type 'character) (if-exists nil if-exists-given) (if-does-not-exist nil if-does-not-exist-given) (external-format :default)) ; (declare (ignore external-format)) ; FIXME (setf element-type (case element-type ((character base-char) 'character) (:default '(unsigned-byte 8)) (t (upgraded-element-type element-type)))) (let* ((p (merge-pathnames filename)) (pathname (if (typep p 'logical-pathname) (translate-logical-pathname p) p))) (when (wild-pathname-p pathname) (error 'file-error :pathname pathname :format-control "Cannot OPEN a wild pathname.")) (when (memq direction '(:output :io)) (unless if-exists-given (setf if-exists (if (eq (pathname-version pathname) :newest) :new-version :error)))) (unless if-does-not-exist-given (setf if-does-not-exist (cond ((eq direction :input) :error) ((and (memq direction '(:output :io)) (memq if-exists '(:overwrite :append))) :error) ((eq direction :probe) nil) (t :create)))) (case direction (:input (case if-does-not-exist (:error (unless (probe-file pathname) (error 'file-error :pathname pathname :format-control "The file ~S does not exist." :format-arguments (list pathname)))) (:create ;; CREATE-NEW-FILE "atomically creates a new, empty file named by ;; this abstract pathname if and only if a file with this name does ;; not yet exist." See java.io.File.createNewFile(). (create-new-file (namestring pathname)))) (make-file-stream pathname element-type :input nil external-format)) (:probe (case if-does-not-exist (:error (unless (probe-file pathname) (error 'file-error :pathname pathname :format-control "The file ~S does not exist." :format-arguments (list pathname)))) (:create ;; CREATE-NEW-FILE "atomically creates a new, empty file named by ;; this abstract pathname if and only if a file with this name does ;; not yet exist." See java.io.File.createNewFile(). (create-new-file (namestring pathname)))) (let ((stream (make-file-stream pathname element-type :input nil external-format))) (when stream (close stream)) stream)) ((:output :io) (case if-does-not-exist (:error (unless (probe-file pathname) (error 'file-error :pathname pathname :format-control "The file ~S does not exist." :format-arguments (list pathname)))) ((nil) (unless (probe-file pathname) (return-from open nil)))) (case if-exists (:error (when (probe-file pathname) (error 'file-error :pathname pathname :format-control "The file ~S already exists." :format-arguments (list pathname)))) ((nil) (when (probe-file pathname) (return-from open nil))) ((:rename :rename-and-delete) (when (probe-file pathname) ;; Make sure the original file is not a directory. (when (probe-directory pathname) (error 'file-error :pathname pathname :format-control "The file ~S is a directory." :format-arguments (list pathname))) (let ((backup-name (concatenate 'string (namestring pathname) ".bak"))) (when (probe-file backup-name) (when (probe-directory backup-name) (error 'file-error :pathname pathname :format-control "Unable to rename ~S to ~S." :format-arguments (list pathname backup-name))) (delete-file backup-name)) (rename-file pathname backup-name)))) ((:new-version :supersede :overwrite :append)) ; OK to proceed. (t (error 'simple-error :format-control "Option not supported: ~S." :format-arguments (list if-exists)))) (let ((stream (make-file-stream pathname element-type direction if-exists external-format))) (unless stream (error 'file-error :pathname pathname :format-control "Unable to open ~S." :format-arguments (list pathname))) stream)) (t (error 'simple-error :format-control ":DIRECTION ~S not supported." :format-arguments (list direction))))))