;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb); Lowercase: Yes -*- ;;; ;;; $Header: /ct/interp/sequenio.l,v 1.35 84/09/26 13:37:10 alex Exp $ ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SEQUEN_IO ;;; ;;; Formerly, SERIAL_IO ;;; ;;; ;;; ;;; John Shelton, Mark Miller, Alex C. Meng Spring 1983 ;;; ;;; ;;; ;;; This file implements the LISP side of generic sequential input- ;;; ;;; output for Ada. The code was originally written by John and not ;;; ;;; used for several months. Mark brought it back to working order, ;;; ;;; basically eliminating the software "rot" that had occurred. ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; AJPO, Feb 1983. ANSI/MIL-STD-1815A Ada Reference Manual. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;; ;;; ;;; ASSUMES CT_LOAD AND SUITABLE FILEMAP ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (eval-when (compile load eval) (ct_load 'charmac)) (eval-when (compile load eval) (ct_load 'aip)) (eval-when (compile load eval) (ct_load 'compat)) (eval-when (compile load eval) (ct_load 'ctflav)) (eval-when (compile load eval) ;Constants etc. (ct_load 'iocompat)) (eval-when (compile load eval) ;With_ada_parameters macro. (ct_load 'bifmacs)) (eval-when (compile load eval) ;For ada_raise. (ct_load 'dsmacs)) (eval-when (compile load eval) ;For string package (ct_load 'ctstrl)) (eval-when (compile load eval) (ct_load 'diana)) ; diana structure (eval-when (compile load eval) ;For functions defined there (ct_load 'textiol)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) (declare (special *seqio_temp_file_list* **sequen_file_list** **sequen_file_num** *activation* *ada_eol* *seqio_eof*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 14.2.3 Specification of the Package Sequential_IO ;;; 1 ;;; with IO_EXCEPTIONS; ;;; generic ;;; type ELEMENT_TYPE is private; ;;; package SEQUENTIAL_IO is ;;; ;;; type FILE_TYPE is limited private; ;;; type FILE_MODE is (IN_FILE, OUT_FILE); ;;; ;;; -- File management ;;; ;;; procedure CREATE (FILE : in out FILE_TYPE; ;;; MODE : in FILE_MODE:= OUT_FILE; ;;; NAME : in STRING := ""; ;;; FORM : in STRING := ""); ;;; ;;; procedure OPEN (FILE : in out FILE_TYPE; ;;; MODE : in FILE_MODE ;;; NAME : in STRING; ;;; FORM : in STRING := ""); ;;; ;;; procedure CLOSE (FILE : in out FILE_TYPE); ;;; procedure DELETE (FILE : in out FILE_TYPE); ;;; procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE); ;;; procedure RESET (FILE : in out FILE_TYPE); ;;; ;;; function MODE (FILE : in FILE_TYPE) return FILE_MODE; ;;; function NAME (FILE : in FILE_TYPE) return STRING; ;;; function FORM (FILE : in FILE_TYPE) return STRING; ;;; function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN; ;;; ;;; -- Input and output operations ;;; ;;; procedure READ (FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE); ;;; procedure WRITE (FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE); ;;; ;;; function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN; ;;; ;;; -- Exceptions ;;; ;;; STATUS_ERROR : exception renames IO_EXCEPTIONS.STATUS_ERROR; ;;; MODE_ERROR : exception renames IO_EXCEPTIONS.MODE_ERROR; ;;; NAME_ERROR : exception renames IO_EXCEPTIONS.NAME_ERROR; ;;; USE_ERROR : exception renames IO_EXCEPTIONS.USE_ERROR; ;;; DEVICE_ERROR : exception renames IO_EXCEPTIONS.DEVICE_ERROR; ;;; END_ERROR : exception renames IO_EXCEPTIONS.END_ERROR; ;;; DATA_ERROR : exception renames IO_EXCEPTIONS.DATA_ERROR; ;;; ;;; private ;;; -- implementation dependent ;;; end SEQUENTIAL_IO; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -- ANSI/MIL-STD-1815A Ada Reference Manual ;;; -- Approved February 17, 1983 ;;; ;;; 2 ;;; References: close procedure 14.2.1, create procedure 14.2.1, ;;; data_error exception 14.4, delete procedure 14.2.1, device_error ;;; exception 14.4, end_error exception 14.4, end_of_file function ;;; 14.2.2, file_mode 14.1, file_type 14.1, form function 14.2.1, ;;; in_file 14.1, io_exceptions 14.4, is_open function 14.2.1, mode ;;; function 14.2.1, mode_error exception 14.4, name function 14.2.1, ;;; name_error exception 14.4, open procedure 14.2.1, open procedure ;;; 14.2.1, out_file 14.1, read procedure 14.2.2, reset procedure ;;; 14.2.1, sequential_io package 14.2 14.2.2, status_error exception ;;; 14.4, use_error exception 14.4, write procedure 14.2.2, [sic]. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Important Implementation Notes -- ;;; Recall the parameter conventions for Ada-LISP functions. Those ;;; LISP functions that model Ada procedures accept a single argument, ;;; "ar". The macro "with_ada_parameters" (defined in bifmacs) allows ;;; you to extract the LISP-ified versions of the formal parameter ;;; names. LISP functions that model Ada procedures return a LIST of ;;; parameters. If a parameter is IN type, then chances are the LISP ;;; function does something with it, and returns a meaningless version ;;; (or perhaps returns the parameter as it was passed in). If a ;;; paramter is OUT type, the LISP function does not depend on a value ;;; being supplied, but will supply one in the return list. If a ;;; parameter is IN/OUT, then the LISP function can both look at the ;;; value and generate a new one. Those LISP functions that model Ada ;;; FUNCTIONS return a single value. Functions and procedures are ;;; provided here in the same order as seen (above) in Ada LRM 14.2.3, ;;; specification of the package Sequential_IO. ;;; Some of these functions are non-optimal in that they do excessive ;;; argument checking which in some cases is redundant due to strong ;;; typing. That is, they test for circumstances which should have ;;; been caught in the front end anyway. This should be fixed. ++mlm ;;; NB: Any implementation-dependent aspects must be documented in ;;; Appendix F of the C*T Ada LRM. These include the default size ;;; of Direct_IO files, and the fact that the FORM parameter to CREATE ;;; is [currently] ignored, and must be the empty string. ++mlm ;;; There is some redundancy between sequential, direct, and text IO ;;; packages, and some code/checks in this package that is only ;;; relevant to the others. The sharable parts need to be merged and ;;; the redundancies eliminated. Likewise, checks (e.g. for INOUT ;;; as a file_mode, which is only legal for Direct_IO) need to be ;;; strengthened in some cases. ++mlm ;;; The LISP atoms 'in, 'out, and 'inout represent the file_modes ;;; in_file, out_file, and inout_file [Direct_IO only], respectively. ;;; Issue: should the string "ctvax:" be appended to all NAME params ;;; depending on #+lispm??? ++mlm ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros Follow -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_create (ar) ;;;;;;;;;;;;;;;;;;;;;;;; ;;; From 14.2.1 File Management -- ;;; procedure CREATE (FILE : in out FILE_TYPE; ;;; MODE : in FILE_MODE := OUT_FILE; ;;; NAME : in STRING := ""; ;;; FORM : in STRING := ""); ;;; ;;; Establishes a new external file, with the given name and form, and ;;; associates this external file with the given file. The given ;;; file is left open. The current mode of the given file is set to ;;; the given access mode. The default access mode is the mode ;;; OUT_FILE for sequential and text input-output; it is the mode ;;; INOUT_FILE for direct input-output. For direct access, the size ;;; of the created file is implementation dependent. A null string ;;; for NAME specifies an external file that is not accessible after ;;; the completion of the main program (a temporary file). A null ;;; string for FORM specifies the use of the default options of the ;;; implementation for the external file. ;;; ;;; The exception STATUS_ERROR is raised if the given file is already ;;; open. The exception NAME_ERROR is raised if the string given as ;;; name does not allow the identification of an external file. The ;;; exception USE_ERROR is raised if, for the specified mode, the ;;; environment does not support creation of an external file with ;;; the given name (in the absence of NAME_ERROR) and form. ;;; {Since it is allowed by the LRM, we do not complain if you open ;;; a new file with file_mode in_file.} (with_ada_parameters ((file file) (mode mode) (name name) (form form)) (let* ((fmode (#+lispm string #+franz get_pname (implode (second (diana_get mode 'lx_symrep))))) (fmode (cond ((equal "in_file" fmode) 'in) ((equal "out_file" fmode) 'out))) (fname (#+lispm string #+franz get_pname (implode (second (convert_strrep_to_lexstr name))))) (fform (#+lispm string #+franz get_pname (implode (second (convert_strrep_to_lexstr form))))) (ffile (ct_if (eq (get_filepos file) 0) nil (get_filepos file))) (fileo (cond (ffile (ct_nth ffile **sequen_file_list**)) (t nil))) (tempfile nil)) (ct_if (not (equal fform "")) (ada_raise '|use_error| ;;; Is it ok to raise use_error for this? ++mlm "The FORM parameter to CREATE must be empty in CTADA.")) ;;; for existing file, it just overwrite ;;;(ct_if fileo (ada_raise '|status_error| "File object already exists.")) (ct_if (null fmode) (setq fmode 'out)) (ct_if (not (memq fmode '(in out))) (ada_raise '|status_error| "Not a valid mode for creating a sequential file.")) (ct_if (equal fname "") ; Implies file is temporary. (setq fname (ct_string_append "#junk" (#+lispm string #+franz get_pname (gensym))) tempfile t)) (ct_if (eq fmode 'in) (let* ((f (errset (ada_careful_open fname 'out) nil)) (f (ct_if f (car f) (ada_raise '|name_error| "cannot create the file")))) (ct_closef f))) (let* ((f (errset (ada_careful_open fname fmode) nil)) (f (ct_if f (car f) (ada_raise '|name_error| "cannot create the file")))) (setq fileo (ct_make_instance 'ada_sequential_io_file 'real_stream f 'name fname 'mode fmode 'status 'open))) (setq **sequen_file_list** (nconc **sequen_file_list** (list fileo)) file (list **sequen_file_num**) **sequen_file_num** (add1 **sequen_file_num**)) (ct_if tempfile (setq *seqio_temp_file_list* (cons fileo *seqio_temp_file_list*))) (list file mode name form)))) ;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_open (ar) ;;;;;;;;;;;;;;;;;;;;;; ;;; procedure OPEN ( FILE : in out FILE_TYPE; ;;; MODE : in FILE_MODE; ;;; NAME : in STRING; ;;; FORM : in STRING := "" ); ;;; ;;; Associates the given file with an existing external file having ;;; the given name and form, and sets the current mode of the given ;;; file to the given mode. The given file is left open. ;;; ;;; The exception STATUS_ERROR is raised if the given file is already ;;; open. The exception NAME_ERROR is raised if the string given as ;;; NAME does not allow the identification of an external file; in ;;; particular, this exception is raised if no external file with the ;;; given name exists. The exception USE_ERROR is raised if, for the ;;; specified mode, the environment does not support opening for an ;;; external file with the given name (in the absence of NAME_ERROR) ;;; and form. (with_ada_parameters ((file file) (mode mode) (name name) (form form)) (let* ((fmode (cond ((or (equal mode '*unassigned*) (null mode)) (ada_raise '|mode_error| "uninitialized file MODE")) (t (#+lispm string #+franz get_pname (implode (second (diana_get mode 'lx_symrep))))) )) (fmode (cond ((equal "in_file" fmode) 'in) ((equal "out_file" fmode) 'out) (t (ada_raise '|use_error| "unsupported file MODE")))) (fname (cond ((eq name '*unassigned*) "") (t (#+lispm string #+franz get_pname (implode (second (convert_strrep_to_lexstr name))))) )) (fform (#+lispm string #+franz get_pname (implode (second (convert_strrep_to_lexstr form))))) (ffile (ct_if (eq (get_filepos file) 0) nil (get_filepos file))) (fileo (cond ((null ffile) (ct_if (not (ct_probef fname)) (ada_raise '|name_error| "Non-existing file cannot be open") (find_ada_file fname **sequen_file_list**))) (t (ct_nth (file_exist_check file) **sequen_file_list**)))) ) (cond (fileo (ct_if (eq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "File already open.")) (ct_if (null fmode) (setq fmode (get-iv ada_sequential_io_file fileo 'mode)))) ((null fmode) (setq fmode 'in))) (cond ((not (memq fmode '(in out))) (ada_raise '|status_error| "Not a valid file_mode to OPEN.")) ((not (ct_probef fname)) (ada_raise '|name_error| "File does not exist.")) ((eq fmode 'out) ; OK to disallow? ++mlm (ada_raise '|use_error| "Environment does not support opening an existing file for output.")) (t (let* ((f (errset (ada_careful_open fname fmode) nil)) (f (ct_if f (car f) (ada_raise '|name_error| "cannot create the file")))) (setq fileo (ct_make_instance 'ada_sequential_io_file 'real_stream f 'name fname 'mode fmode 'status 'open))))) (setq **sequen_file_list** (nconc **sequen_file_list** (list fileo)) file (list **sequen_file_num**) **sequen_file_num** (add1 **sequen_file_num**))) (list file mode name form))) ;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_close (ar) ;;;;;;;;;;;;;;;;;;;;;;; ;;; procedure CLOSE (FILE : in out FILE_TYPE); ;;; ;;; Severs the association between the given file and its associated ;;; external file. The given file is left closed. ;;; ;;; The exception STATUS_ERROR is raised if the given file is not ;;; open. (with_ada_parameters ((file file)) (let ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot close file, it is not open.")) (ct_closef (get-iv ada_sequential_io_file fileo 'real_stream)) (set-iv ada_sequential_io_file fileo 'status 'closed) (list file)))) ;;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_delete (ar) ;;;;;;;;;;;;;;;;;;;;;;;; ;;; procedure DELETE (FILE : in out FILE_TYPE); ;;; ;;; Deletes the external file associated with the given file. The ;;; given file is closed, and the external file ceases to exist. ;;; ;;; The exception STATUS_ERROR is raised if the given file is not ;;; open. The exception USE_ERROR is raised if (as fully defined in ;;; Appendix F) deletion of the external file is not supported by the ;;; environment. (with_ada_parameters ((file file)) (let* ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "File not open, cannot delete.")) (ct_closef (get-iv ada_sequential_io_file fileo 'real_stream)) (set-iv ada_sequential_io_file fileo 'status 'closed) (or (errset (ct_deletef (get-iv ada_sequential_io_file fileo 'name)) nil) (ada_raise '|use_error| "File deletion failed.")) (list file)))) ;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_reset_with_mode (ar) ;;;;;;;;;;;;;;;;;;;;;;; ;;; procedure RESET (FILE : in out FILE_TYPE; ;;; MODE : in FILE_MODE); ;;; ;;; Resets the given file so that reading from or writing to its ;;; elements can be restarted from the beginning of the file; in ;;; particular, for direct access this means that the current index ;;; is set to 1. If a MODE parameter is supplied, the current mode ;;; of the given file is set to the given mode. ;;; ;;; The exception STATUS_ERROR is raised if the file is not open. ;;; The exception USE_ERROR is raised if the environment does not ;;; support resetting for the external file and, also, if the environ- ;;; ment does not support resetting to the specified mode for the ;;; external file. ;;; {Operates by closing and re-opening the file.} (with_ada_parameters ((file file) (mode mode)) (let* ( (fmode (cond ((equal mode '*unassigned*) (ada_raise '|mode_error| "uninitialized FILE parameter")) (t (#+lispm string #+franz get_pname (implode (second (diana_get mode 'lx_symrep))))))) (fmode (cond ((equal "in_file" fmode) 'in) ((equal "out_file" fmode) 'out) (t (ada_raise '|use_error| "unsupported MODE parameter")))) (fileo (ct_nth (file_exist_check file) **sequen_file_list**)) ) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "File not open, cannot reset.")) (ct_if (not (memq fmode '(in out))) (ada_raise '|status_error| "Mode must be in_file or out_file when resetting.")) (ct_closef (get-iv ada_sequential_io_file fileo 'real_stream)) (set-iv ada_sequential_io_file fileo 'real_stream (ada_careful_open (get-iv ada_sequential_io_file fileo 'name) fmode)) (set-iv ada_sequential_io_file fileo 'mode fmode) (list file fmode)))) (defun ada_sequential_io_reset (ar) ;;;;;;;;;;;;;;;;;;;;;;; ;;; procedure RESET (FILE : in out FILE_TYPE); ;;; ;;; Resets the given file so that reading from or writing to its ;;; elements can be restarted from the beginning of the file; in ;;; particular, for direct access this means that the current index ;;; is set to 1. If a MODE parameter is supplied, the current mode ;;; of the given file is set to the given mode. ;;; ;;; The exception STATUS_ERROR is raised if the file is not open. ;;; The exception USE_ERROR is raised if the environment does not ;;; support resetting for the external file and, also, if the environ- ;;; ment does not support resetting to the specified mode for the ;;; external file. ;;; {Operates by closing and re-opening the file.} (with_ada_parameters ((file file)) (let ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "File not open, cannot reset.")) (ct_closef (get-iv ada_sequential_io_file fileo 'real_stream)) (set-iv ada_sequential_io_file fileo 'real_stream (ada_careful_open (get-iv ada_sequential_io_file fileo 'name) (get-iv ada_sequential_io_file fileo 'mode))) (list file )))) ;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_mode (ar) ;;;;;;;;;;;;;;;;;;;;;; ;;; function MODE (FILE : in FILE_TYPE) return FILE_MODE; ;;; ;;; Returns the current mode of the given file. ;;; ;;; The exception STATUS_ERROR is raised if the file is not open. (with_ada_parameters ((file file)) (let* ((fileo (ct_nth (file_exist_check file) **sequen_file_list**)) (str (cond ((equal 'in (get-iv ada_sequential_io_file fileo 'mode)) "in_file") (t "out_file")))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot return mode, file not open.")) (get-enum str *activation*)))) ;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_name (ar) ;;;;;;;;;;;;;;;;;;;;;; ;;; function NAME (FILE : in FILE_TYPE) return STRING; ;;; ;;; Returns a string which uniquely identifies the external file ;;; currently associated with the given file (and may thus be used in ;;; an OPEN operation). If an environment allows alternative ;;; specifications of the name (for example abbreviations) the string ;;; returned by the function should correspond to a full ;;; specification of the name. ;;; ;;; The exception STATUS_ERROR is raised if the given file is not ;;; open. (with_ada_parameters ((file file)) (let ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot return name, file not open.")) (cons 'lex_string (list (exploden (get-iv ada_sequential_io_file fileo 'name))))))) ;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_form (ar) ;;;;;;;;;;;;;;;;;;;;;; ;;; function FORM (FILE : in FILE_TYPE) return STRING; ;;; ;;; Returns the form string for the external file currently ;;; associated with the given file. If an environment allows ;;; alternative specifications of the form (for example, abbreviations ;;; using default options), the string returned by the function should ;;; correspond to a full specification (that is, it should indicate ;;; explicitly all options selected, including default options). ;;; ;;; The exception STATUS_ERROR is raised if the given file is not ;;; open. (with_ada_parameters ((file file)) (let ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot return form, file not open.")) ;;; Current FORM is not used in CTADA. Return the empty string. (cons 'lex_string (list nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_is_open (ar) ;;;;;;;;;;;;;;;;;;;;;;;;; ;;; function IS_OPEN (FILE: in FILE_TYPE) return BOOLEAN; ;;; ;;; Returns TRUE if the file is open (that is, if it is associated ;;; with an external file), otherwise returns FALSE. (with_ada_parameters ((file file)) (let ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (cond ((and fileo (eq (get-iv ada_sequential_io_file fileo 'status) 'open)) (get-enum "true" *activation*)) (t (get-enum "false" *activation*)))))) ;;; 14.2.2 Sequential Input-Output ;;; ;;; The operations available for sequential input and output are ;;; described in this section. The exception STATUS_ERROR is raised ;;; if any of these operations is attempted for a file that is not open. ;;; {Here is the real meat of the Sequential_IO package. Items are READ ;;; and written as LISP S-Expressions, with space characters trailing. ;;; After reading the element from the file, if there is a space ;;; character following, it is read.} ;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_read (ar) ;;;;;;;;;;;;;;;;;;;;;; ;;; procedure READ (FILE : in FILE_TYPE; ;;; ITEM : out ELEMENT_TYPE); ;;; ;;; Operates on a file of mode IN_FILE. Reads an element from the ;;; given file, and returns the value of this element in the ITEM ;;; parameter. ;;; ;;; The exception MODE_ERROR is raised if the mode is not IN_FILE. ;;; The exception END_ERROR is raised if no more elements can be ;;; read from the given file. The exception DATA_ERROR is raised ;;; if the element read cannot be interpreted as a value of the ;;; type ELEMENT_TYPE; however, an implementation is allowed to ;;; omit this check if performing the check is too complex. (with_ada_parameters ((file file) (item item)) (let* ((fileo (ct_nth (file_exist_check file) **sequen_file_list**)) (stream (get-iv ada_sequential_io_file fileo 'real_stream)) (itemo (ada_parameter item)) (prinlevel nil) (prinlength nil)) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot READ, file is not open.")) (ct_if (neq (get-iv ada_sequential_io_file fileo 'mode) 'in) (ada_raise '|mode_error| "Cannot READ, file_mode is not in_file.")) (ct_if (= (ct_tyipeek stream) *seqio_eof*) (ada_raise '|end_error| "Cannot READ, at end of file.")) (cond ((ada_num_p itemo) (setq item (sequen_read_num stream))) ((ada_array_type itemo) (sequen_read_array stream item)) ((ada_enumeration_type itemo) (setq item (sequen_read_enum itemo stream))) ((ada_record_type itemo) (setq item (sequen_read_record stream item)))) (ct_send fileo 'possible_remove_space)))) ;;; ;;; routines reading the element from the stream ;;; (defun sequen_read_num (stream ) (prog () (return (ct_read stream)))) (defun sequen_read_char (stream ) (prog () (return (convert_integer_to_char (car (ct_read stream)))))) (defun sequen_read_array (stream item) (let* ((list-of-values (ct_read stream)) (arraystorage (get-iv dt_array_type item 'array_storage)) (eleobj #+lispm (aref arraystorage 0) #+franz (arraycall t arraystorage 0))) (fill-in-value-for-array list-of-values item ))) (defun sequen_read_record (stream item) (let* ((recvalue (ada_record_value%record item)) (num_of_fields (length recvalue)) (nuval (ct_read stream))) (uci_loop (initial count num_of_fields reclist recvalue nuvalue nuval itemo (cdr (first reclist))) (do (cond ((ada_num_p itemo) (ct_send itemo 'set_val nil (car nuvalue))) ((ada_enumeration_type itemo) (ct_send itemo 'set_val nil (get_enum_literal (car nuvalue) itemo))) ((is_array itemo) (fill-in-value-for-array (car nuvalue) itemo)) ((ada_record_type itemo) (fill-in-value-for-record (car nuvalue) itemo)))) (until (eq count 0)) (next count (sub1 count) reclist (cdr reclist) nuvalue (cdr nuvalue) itemo (cdr (first reclist))) ) item)) (defun sequen_read_enum (itemo stream) (get_enum_literal (ct_read stream) itemo)) ;;; ;;; given an enum literal (123 234 112 112) and a instance of the flavor of ;;; dt_enumeration_type, return the diana node of enumeration id (defun get_enum_literal (literal item) (let ((enumlist (diana_get (extract_basetype (ct_send item 'sm_defn)) 'as_list))) (do ((ll enumlist (cdr ll)) (found nil) (answer nil)) (found answer) (cond ((equal literal (second (diana_get (car ll) 'lx_symrep))) (setq found t answer (car ll))))))) (defun fill-in-value-for-array (nuval item) (let* ((arraystorage (get-iv dt_array_type item 'array_storage)) (eleobj #+lispm (aref arraystorage 0) #+franz (arraycall t arraystorage 0))) (cond ((ada_num_p eleobj) (for-each-ele-in-array arraystorage nuval)) ((ada_enumeration_type eleobj) (for-each-ele-in-array arraystorage (convert-valist-to-enumlist arraystorage nuval))) ((is_array eleobj) (mapcar 'fill-in-value-for-array nuval (list-of-arr-ele arraystorage))) ((ada_record_type eleobj) (mapcar 'fill-in-value-for-record nuval (list-of-arr-ele arraystorage)) )))) ;;; for a given array, return the list of it's element (defun list-of-arr-ele (arr) (do ((bound #+lispm (array-length arr) #+franz (second (arraydims arr))) (n 0 (add1 n)) (ans nil)) ((>= n bound) (nreverse ans)) (setq ans (cons #+lispm (aref arr n) #+franz (arraycall t arr n) ans)))) ;;; given an uninitialized dt_enumeration_type, return a list of dn_enum_id's (defun list-of-dn_enum_id (item) (let ((as-list (ct_send item 'sm_defn))) (cond ((listp as-list) as-list) (t (cond ((equal (diana_get as-list 'ct_nodetype) 'dn_enum_literal_s) (diana_get as-list 'as_list)) )) )) ) ;; search through a list of dn_enum_id's to find the node which char list is ;; the given charl (defun find-dn_enum_id (charl enumlist) (do ((ll enumlist (cdr ll)) (fini nil)) ((or fini (null ll)) fini)2 (cond ((equal charl (second (diana_get (car ll) 'lx_symrep))) (setq fini (car ll))) )) ) (defun fill-in-value-for-record (nuval item) (let* ((value (ada_record_value%record (ct_send item 'current_value))) (num_of_fields (length value))) (do ((count num_of_fields (sub1 count)) (alist value (cdr alist)) (nuvalue nuval (cdr nuvalue)) ) ((eq count 0)) (setq item (cdar alist)) (cond ((ada_num_p item) (ct_send item 'set_val nil (car nuvalue))) ((ada_enumeration_type item) (ct_send item 'set_val nil (find-dn_enum_id (car nuvalue) (list-of-dn_enum_id item)))) ((is_array item) (fill-in-value-for-array (car nuvalue) item)) ((ada_record_type item) (fill-in-value-for-record (car nuvalue) item)) ) ) )) (defun for-each-ele-in-array (arrayname valist) (let ((len #+lispm (array-length arrayname) #+franz (second (arraydims arrayname)))) (do ((ll valist (cdr ll)) (lastone len) (index 0 (add1 index))) ((eq index lastone)) (ct_send #+lispm (aref arrayname index) #+franz (arraycall t arrayname index) 'set_val nil (car ll))))) (defun CONVERT-valist-to-enumlist (arr valist) (COND ((NOT (EQ (LENGTH VALIST) (array-length arr))) (ADA_RAISE '|data_error| "the length of the enumeration literal is not what declared")) ((do ((n 0 (add1 n)) (vl valist (cdr vl)) (item nil) (ans nil) (temp nil)) ((>= n #+lispm (array-length arr) #+franz (second (ARRAYDIms arr))) (nreverse ans)) (ct_send (setq ITEM #+lispm (aref arr n) #+franz (arraycall t arr n)) 'set_val nil (progn (setq temp (search-enum-charl (car vl) item) ans (cons temp ans)) temp)))) )) (defun flat-list1 (l) (ct_if l (mapcar 'car l))) ;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_write (ar) ;;;;;;;;;;;;;;;;;;;;;;; ;;; procedure WRITE (FILE : in FILE_TYPE; ;;; ITEM : in ELEMENT_TYPE); ;;; ;;; Operates on a file of mode OUT_FILE. ;;; Writes the value of ITEM to the given file. ;;; ;;; The exception MODE_ERROR is raised if the mode is not ;;; OUT_FILE. The exception USE_ERROR is raised if the ;;; capacity of the external file is exceeded. (with_ada_parameters ((file file) (item item)) (let* ((fileo (ct_nth (file_exist_check file) **sequen_file_list**)) (stream (get-iv ada_sequential_io_file fileo 'real_stream)) (prinlength nil) (itemo (ada_parameter item)) (prinlevel nil) (prinlength nil)) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot WRITE, file is not open.")) (ct_if (neq (get-iv ada_sequential_io_file fileo 'mode) 'out) (ada_raise '|mode_error| "Cannot WRITE, mode is not OUT_FILE.")) (cond ((numberp item) (sequen_write_num stream item)) ((is_char item) (sequen_write_char stream itemo)) ((is_enumeration item) (sequen_write_enum stream itemo)) ((ada_record_type itemo) (sequen_write_record stream item)) ((is_array item) (sequen_write_array stream item)) (t (ada_raise '|data_error| "sequen io write-- type not implemented")))))) ;;; ;;; predicate to dtermine the type of the input parameter ;;; (defun is_char (item) (and (diana_nodep item) (eq (diana_nodetype_get item) 'dn_def_char))) (defun is_array (item) (eq (ct_typep item) 'dt_array_type)) (defun ada_array_type (item) (eq (ct_typep item) 'dt_array_type)) (defun is_enumeration (item) (and (diana_nodep item) (eq (diana_nodetype_get item) 'dn_enum_id))) (defun ada_integer_type (item) (eq (ct_typep item) 'dt_integer_type)) (defun ada_floating_type (item) (eq (ct_typep item) 'dt_floating_type)) (defun ada_enumeration_type (item) (eq (ct_typep item) 'dt_enumeration_type)) (defun ada_record_type (item) (eq (ct_typep item) 'dt_record_type)) (defun ada_fixed_point_type (item) (eq (ct_typep item) 'dt_fixed_point_type)) ;;; ;;; predicts to determine the data type for a type object ;;; (defun ada_num_p (item) (or (ada_integer_type item) (ada_floating_type item) (ada_fixed_point_type item))) ;;; ;;; routines writing the item to the stream ;;; (defun sequen_write_num (stream item) (ct_if (or (equal item '*unassigned*) (equal item 0) (equal item nil)) (ada_raise '|program_error| "uninitialized ITEM ") (prin1_sp item stream))) (defun sequen_write_enum (stream item) (ct_if (equal item '*unassigned*) (ada_raise '|program_error| "uninitialized ITEM ") (let ((data (ct_send item 'printvalue))) (ct_if (or (equal data '*unassigned*) (equal data 0) (equal data nil)) (ada_raise '|program_error| "uninitialized ITEM ") (prin1_sp data stream)) ))) (defun sequen_write_char (stream item) (ct_if (equal item '*unassigned*) (ada_raise '|program_error| "uninitialized ITEM ") (let ((data (ct_send item 'printvalue))) (ct_if (or (equal data '*unassigned*) (equal data 0) (equal data nil)) (ada_raise '|program_error| "uninitialized ITEM ") (prin1_sp data stream)) ))) (defun sequen_write_array (stream item) (ct_if (equal item '*unassigned*) (ada_raise '|program_error| "uninitialized ITEM ") (let ((data (ct_send item 'printvalue))) (ct_if (or (equal data '*unassigned*) (equal data 0) (equal data nil)) (ada_raise '|program_error| "uninitialized ITEM ") (prin1_sp data stream)) ))) (defun sequen_write_record (stream item) (ct_if (equal item '*unassigned*) (ada_raise '|program_error| "uninitialized ITEM ") (let ((data (mapcar '(lambda (x) (ct_send (cdr x) 'printvalue)) (ada_record_value%record item)))) (ct_if (or (equal data '*unassigned*) (equal data 0) (equal data nil)) (ada_raise '|program_error| "uninitialized ITEM ") (prin1_sp data stream)) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ada_sequential_io_end_of_file (ar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN; ;;; ;;; Operates on a file of mode IN_FILE. Returns TRUE if no ;;; more elements can be read from the given file; otherwise ;;; returns FALSE. ;;; ;;; The exception MODE_ERROR is raised if the mode is not IN_FILE. ;;; {To check for end of file, we peek. Since the space after each ;;; element is read as we go along, reading the last element will read ;;; the last character in the file. This is a function that returns T ;;; or NIL.} (with_ada_parameters ((file file)) (let ((fileo (ct_nth (file_exist_check file) **sequen_file_list**))) (ct_if (neq (get-iv ada_sequential_io_file fileo 'status) 'open) (ada_raise '|status_error| "Cannot check for end of file, file is not open.")) (ct_if (neq (get-iv ada_sequential_io_file fileo 'mode) 'in) (ada_raise '|mode_error| "Cannot check for end of file, file_mode is out_file.")) (let* ((eof (ct_tyipeek (get-iv ada_sequential_io_file fileo 'real_stream)))) (cond ((or (= eof *seqio_eof*) (= eof *ada_eol*)) (get-enum "true" *activation*)) (t (get-enum "false" *activation*))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros/Flavors -- ;;; Sequential files are written and read as linear collections of ;;; homogeneous data. In this particular implementation, data elements ;;; are written as LISP S-Expressions, allowing for trivial reading. ;;; The flavor sequential_file is instantiated for each sequential ;;; file open. ;;;;;;;;;;;;;;;;;;;;;; (ct_defflavor ada_sequential_io_file ;;;;;;;;;;;;;;;;;;;;;; (real_stream ;The physical stream. name mode ;One of in or out. status ;One of open or closed. ) () :settable-instance-variables :gettable-instance-variables) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_sequential_io_file possible_remove_space) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; If there is a space next in the file, it is tyi'd. Does not ;;; blow up at end of file. () (ct_if (= (ct_tyipeek real_stream) #\space) ;; If next ch is space, (ct_tyi real_stream))) ;; tyi the space. ;;;;;;;;;;;;;;;; (defun ada_careful_open (name mode) ;;;;;;;;;;;;;;;; (let ((x)) (cond ((errset (setq x (cond ((eq mode 'in) (ct_open_in name)) ((eq mode 'out) (ct_open_out name)) (t (ada_raise '|mode_error| "Illegal file mode for open.")))) nil) ; Perhaps shouldn't suppress? ++mlm x) (t (ada_raise '|name_error| "Cannot open file.Maybe too many opens"))))) (ct_defmethod (ada_sequential_io_file close)() (ct_if (neq status 'open) (ada_raise '|status_error| "File not open")) (ct_closef real_stream) (setq status 'closed) ) (ct_defmethod (ada_sequential_io_file delete)() (ct_if (neq status 'open) (ada_raise '|status_error| "File not open")) (ct_closef real_stream) (setq status 'closed) (or (errset (ct_deletef name) nil) (ada_raise '|use_error| "File deletion failed"))) (defun seq_get_status (fileo) (get-iv ada_sequential_io_file fileo 'status)) (defun delete_seqio_temp_file () (progn (ct_if *seqio_temp_file_list* (aip_for (x in *seqio_temp_file_list*) (when (eq (seq_get_status x) 'open)) (do (ct_send x 'delete)))) (ct_if **sequen_file_list** (aip_for (x in **sequen_file_list**) (when (eq (seq_get_status x) 'open)) (do (ct_send x 'close)))) )) ;;; The following is for debugging purposes only -- #| ;;;;;;;;;;;;;;;;;;; (defun with_ada_parameters macro (l) ;;;;;;;;;;;;;;;;;;; (rplaca l 'let)) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;