;; -*- Mode:Common-Lisp; Package:PASCALX; Fonts:(MEDFNT HL12B HL12I MEDFNB); Base:10 -*-


;1;  REVISION HISTORY:*
;1;*
;1;  5-24-88 Replaced SELECTQ with CASE.  This fixed some I/O problems. SJP*
;1;*

;; Crock to get around warnings and such.  Should be fixed elsewhere.
(defun fix (number) (zlc:fix number))
(defun remainder (dividend modulus) (zlc:remainder dividend modulus))

;3(DEFUN ORD (x)*
;   (cond ((integerp x)   x)
;	 ((characterp x) (char-code x))
;	 ((eq x true)    1)
;	 ((eq x false)   0)
;	 ((symbolp x)    (zlc:symeval x)))
;   );1ord

3(DEFSUBST** 3ORD (x)*
   (cond ((integerp x)   x)
	 ((characterp x) (char-code x))
	 ((eq x true)    1)
	 ((eq x false)   0)
	 ((symbolp x)    (zlc:symeval x)))
   );1ord*


;1;;; MISCELLANEOUS PASCAL RUNTIME CONSTANTS
3(DEFCONSTANT TRUE**   t)
3(DEFCONSTANT FALSE*  nil)
3(DEFCONSTANT MAXINT* MOST-POSITIVE-FIXNUM)
3(DEFCONSTANT SPACE-CHARACTERS (list #\Newline #\Return #\Space #\Tab #\Linefeed)
2   "the character that are equivalent to spaces")**

(defconstant *TwoToTheEighth* 256)
(defconstant *TwoToTheSixteenth* 65536)
(defconstant *TwoToTheTwentyfourth* 16777216)
(defconstant *TwoToTheThirtysecond* 4294967296)

(EVAL-WHEN (COMPILE load eval)
3(DEFVAR *RUNTIME-CHECK-ASSIGNMENTS-P** nil
  2"controls whether at runtime assignments statements are checked for the rhs being uninitialized"*))

3(DEFVAR *OPEN-STREAMS** nil
   2"the list of streams opened by RESET and REWRITE"*)


3(DEFSTRUCT (*FILE-VARIABLE* (:PREDICATE NIL) (:COPIER*
						       3NIL) (:CONSTRUCTOR *MAKE-FILE-VARIABLE*)*
			        (:alterant)
			        3(:CONC-NAME "*FILE*-"))*
   "2PASCAL FILE VARIABLE DATA STRUCTURE"*
  (buffer-variable nil :type t)		           1; the current value of the buffer variable*
  (buffer-line     nil :type string)	           1; the most recent line of text read from a text file (input only)*
  (buffer-pos      0   :type counter)	           1; the position in*
						1    ; buffer-line, if this is a text file.*
  (data-buffer	   nil :type (OR array null) )	   ;1 The buffer*
						1    *;1 from the stream*
  (data-index	   0   :type (OR integer null))    ;1 The index in data-buffer*
  (data-count	   0   :type (OR integer null))    ;1 The count in data-buffer*
  (stream          nil :type stream)	           1; the stream associated with the file*
  (name		   nil :type string)	           1; the name of the file*
;1;; ++pso removed read-only for num-of-bits and text-p because the copier uses them*
;  (text-p           nil :read-only t)	           1; true => this is a text file, false otherwise*
  (text-p           nil)	           1; true => this is a text file, false otherwise*
;  (num-of-bits     nil :type counter :read-only t) 1; the number of bits for a packed file*
  (num-of-bits     nil :type counter) 1; the number of bits for a packed file*
  (end-if-file-p     nil :type t)		           1; true => have reached end-of-file*
  (end-of-line     nil :type t)		           1; true => have reached end-of-line (text files only)*
;1; ++ sjp removed the :read-only on IN-OR-OUT because RESET and others try to*
;1; set it. *7/05/86 18:27:55
  (in-or-out    'input :type (member 'input 'output))
  (error-p          t :type t)		           1; true and IN-OR-OUT = 'INPUT => file opened successfully*
  );1*file-variable**

(defun copy-*file-variable* (to from)
  "2This copy will be saved in the closure. Don't bother copying a bunch of junk (ie. the buffer...)*"
  (setf (*file*-name to) (*copy-object* (*file*-name from)))
  (setf (*file*-text-p to) (*file*-text-p from))
  (setf (*file*-num-of-bits to) (*file*-num-of-bits from))
  to)

;1;;; MISCELLANEOUS ACCESSORS
3(DEFMACRO *POINTER* (object)**         object)
3(DEFMACRO *MAKE-VAR-PARM* (object)* `(locf ,object))
3(DEFMACRO *VAR-PARM-REF* (object)*  `(contents ,object)) ;1 ++ was car
3(DEFMACRO *CHAR-REF* (object)     ** `(schar ,object 0))
3(DEFMACRO *VAR-PARM* (object)     * `(first ,object))


(DEFMACRO alter-*file-variable* (fv &rest keywords)
       (DO ((kws keywords (CDDR kws))
	    (res nil (CONS `(*set* (,(intern (string-append '*file*-
							  (CAR
							    kws)))
				    ,fv)
				   ,(CADR kws))
			   res)))
	   ((NULL kws)
	    `(PROG () . ,(REVERSE res)))))

3(DEFMACRO *SET* (accessor value)*
   "2implements a general runtime assignment with optional initialization check"*
   (if *RUNTIME-CHECK-ASSIGNMENTS-P*
       ;1; then expand into a check that VALUE is initialized*
       `(if (eq ,value '*UNINITIALIZED*)
	    ;1; then it is not intialized, so report a proceedable error*
	    (cerror "Skip this assignment and continue."
		    "Uninitialized variable on the right hand side of assignment statement in ~A." '*SET*)
	    ;1; else it is initialized, so do it*
	    (setf ,accessor ,value))
       ;1; else expand into an unconditional assignment*
       `(setf ,accessor ,value)
       );1if*
   );1*set*


3(DEFMACRO *SET-FOR-SETS* (accessor value)**
   "2implements a runtime assignment for sets with optional initialization check"*
   (if *RUNTIME-CHECK-ASSIGNMENTS-P*
       ;1; then expand into a check that VALUE is initialized*
      `(if (eq ,value '*UNINITIALIZED*)
	   ;1; then it is not initialized, so report a proceedable error*
	   (cerror "Skip this assignment and continue."
		   "Uninitialized variable on the right hand side of assignment statement in ~A."
		   '*SET-FOR-SETS*)
	   ;1; else it is initialized, so do it*
	   (setf ,accessor (copy-list ,value)))
      ;1; else expand into an unconditional assignment*
      `(setf ,accessor (copy-list ,value))
      );1if*
   );1*set-for-sets*


3(DEFMACRO *FOR-TO-LOOP* ((control-variable assign-fun initial-value final-value) stmt)**
  (let ((loopvar (gensym)))
    (once-only (initial-value final-value)
      `(loop for ,loopvar from (pascalx:ord (progn (,assign-fun ,control-variable ,initial-value)
						  ,initial-value))
	     to (pascalx:ord ,final-value)
	     do ,stmt
	     when (not (eq ,control-variable ,final-value))
	     do (*set* ,control-variable (succ ,control-variable))
	     );1loop*
      ));1let*
   );1*for-to-loop*


3(DEFMACRO *FOR-DOWNTO-LOOP* ((control-variable assign-fun initial-value final-value) stmt)**
  (let ((loopvar (gensym)))
    (once-only (initial-value final-value)
      `(loop for ,loopvar from (pascalx:ord (progn (,assign-fun ,control-variable ,initial-value)
						  ,initial-value))
	     downto (pascalx:ord ,final-value)
	     do ,stmt
	     when (neq ,control-variable ,final-value)
	     do (*set* ,control-variable (pred ,control-variable))
	     );1loop*
      ));1let*
   );1*for-downto-loop*


;;; DEFINE THE PASCAL OPERATORS.
3(DEFMACRO *DIVIDE* (x y)** `(global:quotient (float ,x) (float ,y)))

1;;; DEFINE THE RELATIONAL OPERATORS
3(DEFMACRO SUBSET?     (x y)** `(equal ,x (subseq ,y 0 (length ,x))))
3(DEFMACRO *SET-LE*    (x y) *`(subset? ,x ,y))
3(DEFMACRO *SET-GE*    (x y) *`(subset? ,y ,x))
3(DEFMACRO *NE*        (x y)* `(not (equal ,x ,y)))
3(DEFMACRO *ENUM-GT*   (x y)* `(>  (zlc:symeval ,x) (zlc:symeval ,y)))
3(DEFMACRO *ENUM-LT*   (x y)* `(<  (zlc:symeval ,x) (zlc:symeval ,y)))
3(DEFMACRO *ENUM-LE*   (x y)* `(<= (zlc:symeval ,x) (zlc:symeval ,y)))
3(DEFMACRO *ENUM-GE*   (x y)* `(>= (zlc:symeval ,x) (zlc:symeval ,y)))


1;;; DEFINE THE SET OPERATORS
3(DEFUN *SET-CONSTRUCTOR* (&rest args)**
   2"*SET-CONSTURCTOR* constructs a set from ARGS, if args is the list (NIL) then it returns NIL otherwise it returns
the append of the construction of the first of args with the rest of args.  The construction of an atom is the list
containing just that atom, the construction of a list is all the object between the first and second objects in the list
\(these are found with SUCC)"*
   (sort  (loop with result
		for arg in args do
		(SETQ result (union result
		       (if (consp arg)
;1;; ++ pso when=>if*
			 (loop for i from (ord (first arg)) 
			       to (ord (second arg))
			       for elem first (first arg) then (succ elem nil) collect elem)
;1; ++ sjp knocked off extra paren after (list arg) *7/05/86 19:10:52
			 (list arg))))
		finally (return result))
	  #'*element-lessp*)
   )					   ;1*set-constructor*


3(DEFMACRO *SET-DIFFERENCE* (set1 set2)** `(set-difference ,set1 ,set2 :test #'equal))
3(DEFMACRO *SET-UNION*      (set1 set2)* `(sort (union ,set1 ,set2 :test #'equal) #'element-lessp))
3(DEFMACRO *INTERSECTION*   (set1 set2)* `(sort (intersection ,set1 ,set2 :test #'equal) #'element-lessp))


3(DEFUN *ELEMENT-EQUAL* (x y)*
  2"does a comparision for elements of sets"*
  (cond ((and (numberp x) (numberp y))  (= x y))
	((and (symbolp x) (symbolp y))  (= (zlc:symeval x) (zlc:symeval y)))
	((and (stringp x) (stringp y))  (string-equal x y)))
  );1*element-equal*


3(DEFUN *ELEMENT-LESSP* (x y)**
   2"does a comparision for elements of sets"*
   (cond ((and (numberp x) (numberp y))   (< x y))
	 ((and (symbolp x) (symbolp y))   (< (zlc:symeval x) (zlc:symeval y)))
	 ((and (stringp x) (stringp y))   (string-lessp x y)))
   );1*element-lessp*


3(DEFUN SQR    (x)** (* x x))
3(DEFUN LN     (x)* (log x))
3(DEFUN ARCTAN* 3(x)* (+ pi (atan x)))	   ;1?
3(DEFUN TRUNC  (x)** (truncate x))

3(DEFMACRO CHR (int)* `(code-char ,int))


3(DEFUN SUCC (x &optional (signal-runtime-error-p t))*
  (cond ((integerp x) (1+ x))
	((and (characterp x)
	      (< x (1- CHAR-CODE-LIMIT))) (code-char (1+ (char-code x))))
	((eq x false)                     true)
	((not (eq x true))                (global:get x '*SUCCESSOR*))
	((or signal-runtime-error-p
	     (null x)
	     (eq x '*UNINITIALIZED*))     (cerror "Return ~A as its own successor and continue"
						2   *"There is no successor for ~A in SUCC." x)
	                                  x)
	);1cond*
   );1succ


3(DEFUN PRED (x  &optional (signal-runtime-error-p t))**
  (cond ((INTEGERP x)         (1- x))	   ;1++ added x in integerp *7/05/86 18:00:14
	((and (character x)
	      (plusp x))    (code-char (1- (char-code x))))
	((eq x true)        false)
	((not (eq x false)) (global:get x '*PREDECESSOR*))
	((or signal-runtime-error-p
	     (null x)
	     (eq x '*UNINITIALIZED*)) (cerror "Return ~A as its own predecessor and continue"
					      "There is no predecessor for ~A" x)
	                              x)
	);1cond*
   );1pred

3(DEFMACRO ODD  (integer)** `(oddp ,integer))
3(DEFMACRO EVEN (integer)* `(evenp ,integer))

3(DEFUN EOF (file-var)*
   (when (eq (*file*-in-or-out file-var) 'output)
     (cerror "Return its EOF status and continue"
	     "Tried to call EOF on a file open for OUTPUT, in EOF."))
   (*file*-end-if-file-p file-var)
   );1eof


3(DEFUN EOLN (file-var)**
  (when (or (not (*file*-text-p file-var))
	    (eq (*file*-in-or-out file-var) 'output))
    (cerror "Return its End-Of-Line status anyway and continue"
	    "Tried to call EOLN on a file open for OUTPUT, or on a non-text file, in EOLN."))
;  (if (not (*file*-end-if-file-p file-var))
   (*file*-end-of-line file-var)
;      (error "EOF was true (end of file was reached) in EOLN")
;      );1if*
  );1eoln


3(DEFUN *TIME* ()**
   2"Returns a the time since midnight in milliseconds, even though it is only computed in seconds, since the PASCAL-20
has a function TIME that does that."*
  (multiple-value-bind (seconds minutes hours)
      (get-decoded-time)
    (* 1000 (+ (* hours 60 60)
	       (* minutes 60)
	       seconds))
    );1multiple-value-bind*
  );1*time*


3(DEFUN DATE ()
2   "Returns a string with nine characters in it, the form is \"dd-mmm-yy\"  dd is the day of the month, mmm is a month
string, JAN, FEB, MAR, etc. and yy is the year"***
  (multiple-value-bind (seconds minutes hours day month year)
      (get-decoded-time)
    (declare (ignore seconds minutes hours))
    (format nil "~2D-~3A-~2D" day
	    (elt '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") month)
	    year))
  );1date*


;3(DEFMACRO NEW (pointer constructor-fun &rest constants)*
;   `(setf ,pointer (,constructor-fun ,@constants)))

3(DEFMACRO NEW (pointer constructor)*
   `(setf ,pointer ,constructor))

3(DEFMACRO DISPOSE (pointer*)
3 * `(setf ,pointer (*init-pointer*)))	   ;1++ removed &rest args *7/05/86 18:22:38


;;; ++pso This was a deftype, but it seems that deftypes don't work for :element-types of files
;3(DEFTYPE *ELEMENT-TYPE* (file-var)*
;   "2:element-type of Pascal file variable, FILE-VAR"*
;   (print file-var)
;   (if (null (*file*-num-of-bits file-var))
;       'string-char
;       `(unsigned-byte ,(*file*-num-of-bits file-var)))
;   );1*element-type*
3(**defsubst3 *ELEMENT-TYPE* (file-var)*
   "2:element-type of Pascal file variable, FILE-VAR"*
   (if (null (*file*-num-of-bits file-var))
       'string-char
       `(unsigned-byte ,(*file*-num-of-bits file-var)))
   );1*element-type**

(DEFUN erstat (file-var)
  ;1; Returns 0 if file-var is kosher 1 otherwise. Probably incomplete*
  (IF (*file*-error-p file-var) 1 0))


(DEFUN break (file-var)
  ;1; Flushes output buffer*
  (SEND (*file*-stream file-var) :clear-output))

(DEFUN breakin (file-var ignore)
  ;1; Flushes input buffer ++ ignores second variable*
  (SEND (*file*-stream file-var) :clear-input))

3(DEFUN RESET (*default-directory 3file-var*
			  3&optional file-name*
			  3&rest* 3keywords)*
   "2If FILE-NAME is non-NIL, then it is recorded in NAME slot of FILE-VAR and a stream is opened to it and recorded
in STREAM slot.  If one of the KEYWORDS is :NO-ERROR, then a non-existent FILE-NAME is OK.  A keyword of
:NO-INITIAL-GET controls the inital get."*
   (let ((signal-error-p   (not (member :NO-ERROR keywords)))
	 (no-initial-get-p (MEMBER :NO-INITIAL-GET keywords)))
     (IF (null file-name)
	 (SETF file-name (*file*-name file-var)))
;     (SETQ file-name "3bugs:perkins.rel3pasx.p;nil.lisp*")
     (when (string= file-name "")
       (setf file-name nil))
     (when (stringp file-name)
       (setf file-name (string-right-trim '(#\Space #\Tab) file-name)))

     (when (AND (streamp (*file*-stream file-var))
		(NOT (STRING= file-name "3TTY:*")))  ;1 ++ never close terminal*
       (global:close (*file*-stream file-var) nil))
     
     (SETQ no-initial-get-p (OR (string= file-name "3TTY:*")
				no-initial-get-p))

     (cond ((and (not signal-error-p)
		 (NOT (STRING= file-name "3TTY:*"))
		 (when (not (null file-name))
		   (multiple-value-bind (ignore errorp)
		       (pathname-pas default-directory file-name t)
		     (if (not errorp)
			 (not (probe-file (pathname-pas default-directory file-name t)))
			 t))))
	    (setf (*file*-error-p file-var) t))
	   (file-name
	    (SETF (*file*-name file-var) file-name)
	    (setf (*file*-stream file-var)
		  (IF (NOT (STRING= file-name "3TTY:*"))
		      (open-pas
			file-name
			default-directory
			:direction
			:input
			:characters (*file*-text-p file-var)
			:element-type (*element-type*
					file-var))
		      *standard-input*))
	    (SETF (*file*-data-buffer file-var)   nil)
	    (SETF (*file*-data-index file-var)   0)
	    (SETF (*file*-data-count file-var)   0)
	    (setf (*file*-buffer-line file-var)   nil)
	    (setf (*file*-buffer-pos file-var)    nil)
	    (setf (*file*-end-if-file-p file-var) nil)
	    (setf (*file*-in-or-out file-var)    'INPUT)
	    (setf (*file*-error-p file-var)      nil)
	    (when (not no-initial-get-p)
	      (get file-var)))
	   (t (ignore))			   ;1 assumed to be terminal IO*
	   );1cond*
     (pushnew (*file*-stream file-var) *open-streams*)
     );1let*
  );1reset*
           
;; Made the CLOSE global.  5/26/88 SJP

(defun probed (file)
  "Return T if directory exists"
  (condition-case (stream)
      (open file ':direction nil)
    (fs:file-not-found T)
    (fs:directory-not-found NIL)
    (:no-error  (global:close stream) T)))

;1; ++ removed optional KEYWORDS from REWRITE becuase they were never used *7/05/86 18:38:46
3(DEFUN REWRITE (*default-directory 3file-var &optional file-name* &rest keywords3)*
   (let ((signal-error-p   (not (member :NO-ERROR keywords))))
     (when (AND (NOT (STRING= file-name "3TTY:*"))
		(streamp (*file*-stream file-var)))
       (global:close (*file*-stream file-var) nil))
     (if (null file-name)
	 (setf file-name (*file*-name file-var)))
     (cond
       ((and (not signal-error-p)
	     (NOT (STRING= file-name "3TTY:*"))
	     (multiple-value-bind (path error-p) (pathname-pas default-directory file-name t)
	       (or error-p
		   ;; Should check if directory found
		   (not (probed
			  (fs:make-pathname
			    :host (send path :host) 
			    :device (send path :device)
			    :directory (send path :directory) ))))))
	(setf (*file*-error-p file-var) t))
       (t
	(setf (*file*-error-p file-var) nil)
	(setf (*file*-name file-var) file-name)
	(setf (*file*-stream file-var)
	      (IF (NOT (STRING= file-name "3TTY:*"))
		  (open-pas (string-right-trim '(#\Space #\Tab)
					       file-name)
			    default-directory
			    :direction :output
			    :characters (*file*-text-p file-var)
			    :element-type (*element-type* file-var))
		  *standard-output*))
	(setf (*file*-in-or-out file-var) 'output))
       )				   ;1cond*
     (pushnew (*file*-stream file-var) *open-streams*)
     ))					   ;1rewrite


3(DEFUN FILEEXISTSP (file-var)**
  (or (eq (*file*-in-or-out file-var) 'output) (not (*file*-error-p file-var))))

;1; ++ sjp closed the SETF after *OPEN-STREAMS*. Was previously closed after*
;1; close statement. *7/05/86 18:41:53
3(DEFUN CLOSE* 3(file-var)*
  (when (not (or (null (*file*-stream file-var)) (*file*-error-p file-var)))
    (setf *OPEN-STREAMS* (delete (*file*-stream file-var) *OPEN-STREAMS*))
    (global:close  (*file*-stream file-var)))
   );1*close**


(defun pathname-pas (default-directory fn &optional error-protect)
  "Tries to return a pathname fn w/ default default-directory as 1st arg.
   2nd arg is true if it could not parse the pathname."
  (if error-protect
      (catch-error
	(let ((odf (fs:default-pathname)))
	  (prog2
	    (fs:set-default-pathname nil)
	    (fs:merge-pathnames fn default-directory)
	    (fs:set-default-pathname odf)))
	nil)
      (let ((odf (fs:default-pathname)))
	(prog2
	  (fs:set-default-pathname nil)
	  (fs:merge-pathnames fn default-directory)
	  (fs:set-default-pathname odf)))))


(defun open-pas (fn default-directory
		 &rest keywords &aux ignore1)
  (DO ((element-type 'STRING-CHAR)
       (element-type-p nil)
       (BYTE-SIZE :default)
       (other-keys nil)
       (fn (pathname-pas default-directory fn nil))
       (kws keywords (CDDR kws)))
      ((NULL (CDR kws))
       (WHEN ELEMENT-TYPE-P
	 (MULTIPLE-VALUE-setq (ignore1 BYTE-SIZE ignore1 ignore1)
			      (fs:DECODE-ELEMENT-TYPE ELEMENT-TYPE BYTE-SIZE)))
       (cond
	   ((not (zlc:memq byte-size '(16. 8 4 2 1 :DEFAULT)))
	    (case byte-size
		  (32. (setq byte-size 16.)))))
       (LET ((file-stream
		 (apply #'open (list* fn :byte-size byte-size
				      other-keys))))
	 file-stream))
    (COND ((EQ (CAR kws) :element-type)
	   (SETQ element-type (CADR kws))
	   (SETQ element-type-p t))
	  ((EQ (CAR kws) :byte-size)
	   (SETQ byte-size (CADR kws)))
	  (t (SETQ other-keys (LIST* (CAR kws) (CADR kws) other-keys)))))
)

3(DEFUN PUT (file-var)*
   2"puts the value of the buffer variable of FILE-VAR to the stream of FILE-VAR,
 if this is not a text file, then outputs a return to separate things."*
   (cond ((*file*-text-p file-var)
	  (write-char (*file*-buffer-variable file-var) (*file*-stream file-var)))
	 ((*file*-num-of-bits file-var)
	  (IF
	    (not (zlc:memq (*file*-num-of-bits file-var)
		       '(16. 8 4 2 1)))
	    ;1; Our own hack pso sjp*
	    (CASE (*file*-num-of-bits file-var)
		  (32.
;		   (global:BREAK "3FOO*")

		   (WRITE-BYTE
		       (LDB (BYTE 16. 16.)
			  (ZLC:FIX
			      (*file*-buffer-variable file-var)))
		     (*file*-stream file-var))
		   (WRITE-BYTE
		       (LDB (BYTE 16. 0.)
			  (ZLC:FIX
			      (*file*-buffer-variable file-var)))
		     (*file*-stream file-var))
;		   (WRITE-BYTE
;		       (LDB (BYTE 8. 24.)
;			  (FIX
;			      (*file*-buffer-variable file-var)))
;		     (*file*-stream file-var))
;		   (WRITE-BYTE
;		       (LDB (BYTE 8. 16.)
;			  (FIX
;			      (*file*-buffer-variable file-var)))
;		     (*file*-stream file-var))
;		   (WRITE-BYTE
;		       (LDB (BYTE 8. 8.)
;			  (FIX
;			      (*file*-buffer-variable file-var)))
;		     (*file*-stream file-var))
;		   (WRITE-BYTE
;		     (LDB (BYTE 8. 0.)
;			  (FIX
;			      (*file*-buffer-variable file-var)))
;		     (*file*-stream file-var))
		   )
		  )
	    (write-byte (*file*-buffer-variable file-var) (*file*-stream file-var))))
	 (t (prin1 (*make-arrays-into-list* (*file*-buffer-variable file-var)) (*file*-stream file-var))
	    (terpri (*file*-stream file-var)))
	 );1cond*
   );1put


3(DEFUN *SET-END-OF-LINE* (file-var)**
   (setf (*file*-end-of-line file-var)
	 (= (length (*file*-buffer-line file-var)) (*file*-buffer-pos file-var))))


3(DEFUN *GET-NEXT-LINE* (file-var)*
   2"If this stream is built on TV:MINIMUM-WINDOW and handles the message :STRING-OUT, then we send a \"*\" as a
prompt and read a line.  If it doesn't handle :STRING-OUT, then we just read a line.  (for text files).  Other file types are
assumed to be attached to files,INPUT is the only file variable that can be attached to a window and it is a text file."*
  (let ((interactive-p
	  (or (and (typep (*file*-stream file-var) 'tv:minimum-window)
		   (send (*file*-stream file-var) :operation-handled-p :string-out))
	      1;; Test if this is a syn stream, if the function cell is a stream*
	      (and (typep (*file*-stream file-var) :symbol)
		   (fboundp (*file*-stream file-var))
		   (typep (symbol-function (*file*-stream file-var)) 'tv:minimum-window)
		   (send (*file*-stream file-var) :operation-handled-p :string-out)))))
    
    (multiple-value-bind (string x delimiter)
	(if interactive-p
	    (*my-readline* (*file*-stream file-var) '*eof*)
	    (zlc:readline (*file*-stream file-var) '*eof*))
      (declare (ignore x))
      1;; If DELIMITER is CONTROL-Z then if anything was read, insert a RETURN, otherwise just set EOF*
      (cond ((eq string '*eof*)
	     (setf (*file*-end-if-file-p file-var) t))
	    
	    ((and interactive-p (string= string "") (char= delimiter #\end))
	     (setf (*file*-end-if-file-p file-var) t)
	     (setf (*file*-buffer-line file-var) (string #\End)))
	    
	    ((and interactive-p (char= delimiter #\end))
	     (setf (*file*-buffer-line file-var) (string-append string #\Space #\End)))
	    
	    (t (setf (*file*-buffer-line file-var) (concatenate 'string string " ")))))
    
    (when (not (*file*-end-if-file-p file-var))
      (setf (*file*-buffer-variable file-var)
	    (if (*file*-text-p file-var)
	      (rotate-character
		  (char (*file*-buffer-line file-var) 0))
	      (char (*file*-buffer-line file-var) 0)))
      (setf (*file*-buffer-pos file-var) 1)
      (*set-end-of-line* file-var))
    );1let*
   );1*get-next-line**


(DEFUN rotate-character (ch)
  "2Does character translation to lower ascii. Necessary for TeX*"
  (COND
      ((OR (member ch '(#\page #\tab))
	   (MEMBER (CHARACTER (+ ch 128)) '(#\page #\tab)))
       #\space)      
      ((OR (< ch 128.) (MEMber ch '(#\newline #\linefeed))) 
	 ch)
      (t
       (CHARACTER (MOD ch 128)))))

;1 (send stream :get-input-buffer) buffer, index, count*
;1 ++ should be a defsubst*
(defun primitive-get (file-var &optional (eof nil))
  (COND
      ((ZEROP (*file*-data-count file-var))
       (SEND (*file*-stream file-var) :setup-next-input-buffer)
       (MULTIPLE-VALUE-BIND (buffer index count)
	   (SEND (*file*-stream file-var) :get-input-buffer)
	 (IF (NULL buffer)
	     eof
	     (PROG1
		 (ZLC:FIX (AREF buffer index))
		 (SETF (*file*-data-buffer file-var) buffer)
		 (SETF (*file*-data-index file-var) (1+ index))
		 (SETF (*file*-data-count file-var) (1- count))))))
      (t
       (PROG1
	   (ZLC:FIX (AREF (*file*-data-buffer file-var)
		      (*file*-data-index file-var)))
	   (INCF (*file*-data-index file-var))
	   (DECF (*file*-data-count file-var))))))

3(DEFUN GET (file-var &aux obj)*
   "Reads a character from the file"
  (cond ((*file*-text-p file-var)
	 (when (*file*-end-if-file-p file-var)
	   (global:error "Tried to read past end of file in Pascal GET."))
	 (cond ((or (null (*file*-buffer-line file-var))
		    (= (*file*-buffer-pos file-var) (length (*file*-buffer-line file-var))))
		(*get-next-line* file-var))
	       
	       ((= (char (*file*-buffer-line file-var) (*file*-buffer-pos file-var)) #\End)
		(setf (*file*-buffer-line file-var) " ")
		(setf (*file*-buffer-pos file-var) 0)
		(setf (*file*-end-of-line file-var) t)
		(setf (*file*-end-if-file-p file-var) t))
	       
	       (t (setf (*file*-buffer-variable file-var)
			(rotate-character
			    (char (*file*-buffer-line
					  file-var)
				  (*file*-buffer-pos file-var))))
		  (incf (*file*-buffer-pos file-var))
		  (*set-end-of-line* file-var))))
	
	((null (*file*-num-of-bits file-var))
	 (setf obj (global:read (*file*-stream file-var) '*eof*))
	 (if (eq obj '*eof*)
	     (progn
	       (setf (*file*-buffer-variable file-var) nil)
	       (setf (*file*-end-if-file-p file-var) t))
	     (setf (*file*-buffer-variable file-var)
		   (*make-lists-into-array* obj (*file*-buffer-variable file-var)))))
	
	(t				   1; read byte file, with size given by (*FILE*-NUM-OF-BITS FILE-VAR)*
	 (CASE (*file*-num-of-bits file-var)
	       (32.
		(let* ((quarter (primitive-get file-var '*eof*)))
		  ;; ++ Do not use lsh, etc. because they operate on 25 bit integers (not 32)
		  (if (eq quarter '*eof*)
		      (progn
			(setf (*file*-buffer-variable file-var) nil)
			(setf (*file*-end-if-file-p file-var) t))
		      (setf (*file*-buffer-variable file-var)
			    (if (logbitp 15 quarter)	   ; It is a negative number
				(-
				  (+
				    (primitive-get file-var '*eof*)
				    (* quarter *TwoToTheSixteenth*))
				  *TwoToTheThirtysecond*)
				(+
				  (primitive-get file-var '*eof*)
				  (* quarter *TwoToTheSixteenth*)))))))
	       ((16. 8. 4. 2. 1)
		(setq obj
		      (primitive-get file-var '*eof*))
		(if (eq obj '*eof*)
		    (progn
		      (setf (*file*-buffer-variable file-var) nil)
		      (setf (*file*-end-if-file-p file-var) t))
		    (setf (*file*-buffer-variable file-var) obj)))))	     
	);1cond*
   );1get


3(DEFUN PACK (from-array index to-array)**
   "2copies FROM-ARRAY to TO-ARRAY starting at the zero-based index INDEX in FROM-ARRAY."*
   (do ((k index (1+ k))
	(j 0     (1+ j)))
       ((< j (length to-array)))
     (if (typep (aref from-array k) :array)
	 (*copyarray* (aref to-array j) (aref from-array k))
	 (setf (aref to-array j) (aref from-array k)))
     );1do*
   );1pack


3(DEFUN UNPACK (from-array to-array index)**
   "2copies FROM-ARRAY to TO-ARRAY starting at zero-base index INDEX in TO-ARRAY."*
   (do ((k index (1+ k))
	(j 0     (1+ j)))
       ((< j (length to-array)))
     (if (typep (aref from-array j) :array)
	 (*copyarray* (aref to-array k) (aref from-array j))
	 (setf (aref to-array k) (aref from-array j)))
     );1do*
   );1unpack


3(DEFUN ACTIVATION-CHAR-P (ch)**
   (not (null (member ch '(#\End #\Newline #'Return #\Linefeed #\Control-z)))))


3(DEFUN *MY-READLINE* (&optional (stream **3STANDARD-INPUT**3) eof-option)*
  (declare (special eof-option))
  (multiple-value-prog1
    (with-input-editing (stream '((:activation activation-char-p)))
      (zlc:readline stream eof-option))
    (write-char #\Newline *standard-output*))
  );1*my-readline*


3(DEFUN *READ-DIGIT-SEQUENCE* (file-var)**
  "2reads one character and then reads more until it finds a number returning a list of the characters it read"*
   (let((str ""))
     (loop
       (setf str (concatenate 'string str (string (*file*-buffer-variable file-var))))
       (get file-var)
       (when (not (digit-char-p (*file*-buffer-variable file-var))) (return str))
       );1loop*
     );1let*
   );1*read-digit-sequence*


3(DEFUN *READ-INTEGER* (file-var)**
   "2reads and returns an integer"*
   (loop
     (when (member (*file*-buffer-variable file-var) '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\-))
       (return))
     (when (not (member (*file*-buffer-variable file-var) space-characters))
       (cerror "Ignore illegal character and continue by reading another."
	       "Read a illegal character (~C), while trying to read a number, in *READ-INTEGER*."
	       (*file*-buffer-variable file-var)))
     (get file-var)
     );1loop*
   (read-from-string (*read-digit-sequence* file-var))
   );1*read-integer**
       

3(DEFUN *READ-REAL* (file-var)*
  "2read a real and return it"*
  (let (str)
    (loop until (or (digit-char-p (*file*-buffer-variable file-var))
		  (char= #\+ (*file*-buffer-variable file-var))
		  (char= #\- (*file*-buffer-variable file-var)))
	  when (not (member (*file*-buffer-variable file-var) space-characters))
	  do (cerror "Ignore illegal character and continue by reading another."
		     "Read a illegal character (~C), while trying to read a number, in *READ-REAL*."
		     (*file*-buffer-variable file-var))
	  do (get file-var)
	  );1loop*
    (setf str (*read-digit-sequence* file-var))
    (cond ((string= (*file*-buffer-variable file-var) #\.)
	   (setf str (concatenate str (*read-digit-sequence* file-var)))))
    (when (and (string-equal (*file*-buffer-variable file-var)
			     #\e)
;1; ++ sjp in first line of OR, changed BUFFER-FILE to be BUFFER-LINE.  There is no*
;1; BUFFER-FILE. Assumed it was a typo. *7/05/86 18:52:38
	       (or (digit-char-p (*file*-buffer-line (*file*-buffer-pos file-var)))
		   (char= #\+ (*file*-buffer-line (*file*-buffer-pos file-var)))
		   (char= #\- (*file*-buffer-line (*file*-buffer-pos file-var)))))
      (setf str (concatenate 'string str (string (*file*-buffer-variable file-var))))
      (get file-var)
      (setf str (concatenate 'string str (*read-digit-sequence* file-var))))
  (read-from-string str)
;1; ++ sjp moved the LET so that it follows READ-FROM-STRING because STR is*
;1; local. *7/05/86 18:48:08
  );1let*
  );1*read-real**


(defsubst *read-string* (file-var str-locative break-set)
  (let ((str (car str-locative)))
    (fill str #\Space)
    (cond ((or (*file*-end-of-line file-var)
	       (member (*file*-buffer-variable file-var) break-set)) 0)
	  (t (setf (aref str 0) (*file*-buffer-variable file-var))
	     (loop with str-len = (length (*file*-buffer-line file-var))
		   for i from (*file*-buffer-pos file-var)
		   and j from 1
		   until (or (>= i (zlc:sub1 str-len))
			     (member (zlc:substring (*file*-buffer-line file-var)
						i (1+ i))
				     break-set)
			     (= j (length str)))
		   do (setf (aref str j)
			    (rotate-character
				(AREF (*file*-buffer-line
					  file-var) i)))
		   finally (setf (*file*-buffer-pos file-var) i)
		   (get file-var)
		   (return (min j (1+ str-len))))))))

;1;  Modified the integer command so that it used CONTENTS instead of CAR for*
;1;  locatives.  5/24/88  SJP*

;;; if FILE-VAR is a text file then args must be locatives, so have to do CAR to reference them
;;; otherwise args is a alternating sequence of keywords and locatives.  The recognized keywords
;;; are :CHAR, :INTEGER and :REAL and :STRING.  If the keyword is :STRING, then a string read
;;; a la DEC-20 PASCAL is done.  The next object should be a list
;;; of (STRING HOW-MANY BREAK-SET), how-many should be a locative that will be set to the
;;; number of characters read (including the one left in the buffer), and break set is a
;;; of characters that specify to stop reading when the current characters is in the break set
(defun read (file-var &rest args)
  (cond ((*file*-text-p file-var)
	 (if (null (*file*-buffer-line file-var)) (get file-var))
	 (loop for (keyvar arg) on args by 'cddr
	       do (case keyvar
		    (:string (cond ((listp arg)
				    (setf (car (second arg)) (*read-string* file-var
									    (first arg) (third arg))))
				   (t (*read-string* file-var (first arg) nil))))
		    (:char (setf (contents arg) (*file*-buffer-variable file-var))
		     (get file-var))
		    (:integer (setf (car arg) (*read-integer* file-var)))
		    (:real (setf (car arg) (*read-real* file-var)))
		    (otherwise  (*signal-runtime-error* 'read t
						       "undefined keyword ~S in"
						       keyvar)))))
	(t (WHEN
;	       (= (send (*file*-stream file-var) :read-pointer)
;	       0)
	       (NULL (*file*-data-buffer file-var))
	     (get file-var)
	     )
	   (loop for this-one on args by 'cddr
		 do (cond ((typep (car this-one) :array)
			   (*copyarray* (contents (cadr this-one))
					(*file*-buffer-variable file-var)))
			  (t (setf (contents (cadr this-one)) (*file*-buffer-variable file-var))))
		 (get file-var)))))


;;; The Procedure Readln ANSI 6.9.2 p. 88
(defun readln (file-var &rest args)
  "does a PASCAL read of the args from the stream of FILE-VAR then moves to beginning of next line"
  (if (not (*file*-text-p file-var))
      (*signal-runtime-error* 'readln nil "Readln is only defined on text files, in"))
  (if (not (null args))
      (zlc:lexpr-funcall #'read file-var args))
  (alter-*file-variable* file-var end-of-line t
			 buffer-pos (length (*file*-buffer-line file-var)))
  (get file-var))


;;; The Procedure Write ANSI 6.9.3 p. 88  & ANSI 6.6.5.2 p. 64
(defsubst *write-character* (file-var exp &optional (width 1))
  (dotimes (i (- width 1)) (send (*file*-stream file-var) :tyo #\Sp))
  (send  (*file*-stream file-var) :tyo exp))

(defsubst *write-non-number* (file-var exp &optional (width nil))
  (let* ((str (string exp))
	 (str-len (length str))
	 (leading-spaces (if (not (null width)) (- width str-len) 0))
	 (len (if (or (null width) (<= width 0))
		  str-len
		  (min width str-len))))
    (dotimes (i leading-spaces) (send (*file*-stream file-var) :tyo #\Sp))
    (princ (zlc:substring str 0 len) (*file*-stream file-var))))


(defsubst *write-integer* (file-var exp width)
  (format (*file*-stream file-var) "~VD" (or width 11) exp))


(defsubst *write-real* (file-var exp &optional (total-width nil) (frac-digits nil)) 
  (if (= exp -0.0) (setf exp 0.0))
  (if (not total-width) (setf total-width 14))
  (if frac-digits
      (format (*file*-stream file-var) "~V,1,V,,$" frac-digits total-width exp)
      (let* ((exp-digits 2)		  ; the number of digits in the exponent
	     (exp-string (format nil "~E" exp))
	     (sign (if (< exp 0) #\- #\Space))
	     (e-pos (zlc:string-search-char #\e exp-string))
	     (mantissa (read-from-string exp-string nil
					 nil :start 0 :end e-pos))
	     (exponent (read-from-string exp-string nil
					 nil 
					 :start (1+ e-pos)))
	     (act-width (max total-width (+ exp-digits 6))))
        (format (*file*-stream file-var) "~C~V,1,V,$e~:[+~;-~]~2,'0D"
                sign  (- act-width exp-digits 5) (- act-width exp-digits 3) mantissa
                (minusp exponent) #|exp-digits3|*# (ABS
						      exponent))))) ;1++ exp digits*


(defun write (file-var type exp &optional (newline nil) &aux total-width frac-digits)
  (if (and newline (not (*file*-text-p file-var)))
      (*signal-runtime-error* 'write nil "Writeln is only defined on text files, in"))
  (cond ((*file*-text-p file-var)
	 (cond ((listp exp)
		(setf total-width (second exp)
		      frac-digits (third exp))
		(setf exp (first exp))))
	 (case type
	   (:integer (*write-integer* file-var exp total-width))
	   (:string (*write-non-number* file-var exp total-width))
	   (:boolean (*write-non-number* file-var (if (not (null exp))
						      "TRUE" "FALSE")
					 total-width))
	   (:char (*write-character* file-var exp (or total-width 1)))
	   (:real (*write-real* file-var exp total-width frac-digits))
	   (:writeln)	  ;do nothing, this is a plain WRITELN,
			1   *;with no parms
	   (otherwise (*signal-runtime-error* 'write t
					     "illegal type of object (~A) to write"
					      type)))
	 (if newline (terpri (*file*-stream file-var))))
	(t (setf (*file*-buffer-variable file-var) exp)
	   (put file-var))))

;;; The Procedure WRITELN ANSI 6.9.4 p. 93 is taken care of by WRITE

;;; Define procedures to help doing read and write of other than text files.
(defun *make-arrays-into-list* (object)
  (cond ((and (arrayp object) (not (stringp object)))
	 (loop for i from 0 to (zlc:sub1 (array-length object))
	       collect (*make-arrays-into-list* (aref object i))))
	(t object)))


(defun *make-lists-into-array* (object array)
  (if (or (not (arrayp array)) (not (listp object)))
      object				  ; just return the object
      (loop for item in object		  ; otherwise fill the array
	    and i from 0
	    do (if (listp item)
		   (*make-lists-into-array* item (aref array i))
		   (setf (aref array i) item))
	    finally (return array))))



;;; The Procedure Page ANSI 6.9.5 p. 94
(defun page (file-var)
  "writes a page mark to the output file"
  (cond ((get-handler-for (*file*-stream file-var) :clear-screen)
	 (send (*file*-stream file-var) :clear-screen))
	(t (format (*file*-stream file-var) "~%~|"))))


;;; Define functions for runtime support

;;; *SET-UP-FILE-VARIABLE* sets up a file variable with the NAME name and the VALUE value.
;;; VALUE is the initial value of the file variable, i.e. usually the value passed the
;;; program.  NAME is mainly useful for INPUT and OUTPUT, which are handled a little
;;; differently from other variables.  IF TEXT-P is true then this is a text file, INIT-FORM
;;; is the form to initialize the buffer variable.  KEYWORDS is a list of keywords, right now
;;; the only one that is recognized is :NO-IMPLICIT-GET, which if NAME is "INPUT" means that
;;; no initial get is done.

(zlc:defconst input-output-options `(:FRESH-LINE NIL
					 :CHOICES
					 ((("INPUT" "Interactive input stream.") #\I)
					  (("OUTPUT" "Interactive output stream.") #\O))))

(DEFUN input-output-other-p (name)
  (cond
    ((y-or-n-p "Would you like ~a to be an interactive file stream?" name)
     (format query-io "~%")
     (FQUERY input-output-options
	     "Would you like ~a to be input or output?"
	     name))
    (t
     (format query-io "~%")
     name)))

(defun *set-up-file-variable* (name value text-p init-form default-directory
			       &optional (num-of-bits nil) &rest keywords)
  "sets up a file variable, which is returned"
  (let ((var (*make-file-variable* :text-p text-p
				   :buffer-line nil
				   :buffer-variable init-form
				   :num-of-bits num-of-bits))
	temp)
;    (if (null (or (string-equal name "INPUT")
;		  (string-equal name "OUTPUT")))
;	;; ask whether name should be interactive
;	(setq name (input-output-other-p name)))
    (cond ((or (string-equal name "INPUT")
	       (string-equal name "OUTPUT"))
	   (alter-*file-variable* var buffer-line nil
				  buffer-pos 0
				  in-or-out (if (string-equal name "INPUT")
						'input
						'output))
	   (cond ((null value) (setf (*file*-stream var)
				     (if (string-equal name "INPUT")
					 standard-input
					 standard-output))
		  (if (string-equal name "OUTPUT") (terpri standard-output)))
		 ((eq value t) (multiple-value-bind (str fname)
				   (*prompt-for-file-or-stream* name)
				 (alter-*file-variable*
				   var
				   stream (or str
					      (open-pas fname
							default-directory
							:characters
							(*file*-text-p var)
							:direction
							(if (string-equal name "INPUT")
							    :in :out)))
				   name fname))
		  (if (and (string-equal name "OUTPUT")
			   (eq (*file*-stream var) standard-output)) (terpri standard-output)))
		 ((member (type-of value) '(fs:logical-pathname :string :cons))
		  (setf temp (fs:parse-pathname value))
		  (alter-*file-variable* var
					 name temp
					 stream (open-pas temp
							  default-directory
							  :characters (*file*-text-p var) 
							  :direction
						      (if (string-equal name "INPUT") :input :output))))
		 (t (setf (*file*-stream var) value)
		    (if (and (string-equal name "OUTPUT")
			     (eq (*file*-stream var) standard-output)) (terpri standard-output))))
	   (if (equal name "INPUT") (*initialize* var (if (not (null keywords)) (car keywords)))))
	  (t
	   (alter-*file-variable* var
				    name (or value
					     (*prompt-for-file-or-stream* name :file-only)))))
    var))


;;; KEYWORDS can be :NO-IMPLICIT-GET, in which case no get is done
(defun *initialize* (input &optional keywords)
  (alter-*file-variable* input end-if-file-p nil
			 end-of-line nil
			 buffer-line nil
			 buffer-pos 0)
  (if (or (and (typep (*file*-stream input) 'tv:minimum-window)
	      (send (*file*-stream input) :operation-handled-p :string-out))
	 ;; Test if this is a syn stream, if the function cell is a stream
	 (and (typep (*file*-stream input) :symbol)
	      (fboundp (*file*-stream input))
	      (typep (symbol-function (*file*-stream input)) 'tv:minimum-window)
	      (send (*file*-stream input) :operation-handled-p :string-out)))
      (cond ((neq (car keywords) :no-implicit-get)
	     (send (*file*-stream input) :string-out
		   (format nil "~%End input with ~C~%" #\end))
	     (get input))))
      nil)


2;;; *PROMPT-FOR-FILE-OR-STREAM* prompts the user for a file or a stream, to be used
;;; as the input or outputu stream (file).  OPTIONS are additional options, currently
;;; the only recognized option is :FILE-ONLY, which specifies that only a file name
;;; can be read.  If :FILE-ONLY is not specified, multiple values are returned,
;;; the stream and the file pathname (NIL if a stream is given), if name is INPUT then
;;; the stream is opened for input, if OUTPUT it is opened for output.*
(defun *prompt-for-file-or-stream* (name &rest options)
  "prompts the user for a file or a stream"
  (cond ((eq (car options) :file-only)
	 (loop for path =
	       (prompt-and-read '(:pathname-or-nil)
				"Enter a file name to be used as the value of the file variable ~A~%~
                                 (default is ~A)  "
;1; ++ sjp make *DEFAULT-PATHNAME-DEFAULTS* GLOBAL instead of FS.*
				name (fs:default-pathname global:*default-pathname-defaults*))
	       until path
	       do (format query-io
			  "~%You MUST enter a file name to be used as the value of ~A"
			  name)
	       finally (return path)))
	(t (loop for exp = (prompt-and-read :expression
					    "Enter a file or stream name to be used as ~
					     the value of the file variable ~A: "
					    name)
		 when exp do (cond ((member (type-of exp) '(fs:logical-pathname :string :cons))
				    (return nil (fs:parse-pathname exp)))
				    ((symbolp exp)
				     (if (member (type-of (zlc:symeval exp))
						 '(fs:logical-pathname :string :cons))
					 (return nil (fs:parse-pathname (zlc:symeval exp)))
					 (return (zlc:symeval exp) nil)))
				    (t (format query-io
					       "~%You MUST enter a file name ~
					          to be used as the value of ~A"
					       name)))))))


;;; The following 2 functions should be useful when it is necessary to copy parameters
;;; for passing structured types as VALUE parameters.

;;; *COPYARRAY* copies FROM-ARRAY to TO-ARRAY
;;; if an element of FROM-ARRAY is an array it is also copied.
;;; FROM-ARRAY MUST be 1 dimensional
(defun *copyarray* (to-array from-array)
  "copies FROM-ARRAY to TO-ARRAY like COPY-ARRAY-CONTENTS, but if the elements are also copied if necessary"
;  (if (neq (array-length from-array) (array-length to-array))
;      (*signal-runtime-error* '*copyarray* nil
;			      "trying to copy arrays of different size in"))
  (if (typep to-array '*file-variable*)
      (copy-*file-variable* to-array from-array)
      ;1; else*
      (loop for i from 0 to (zlc:sub1 (array-length from-array))
	    do (setf (aref to-array i)
		     (if (typep (aref from-array i) :array)
			 (*copyarray* (aref from-array i)
				      (aref to-array i))
			 (aref from-array i)))
	    finally (return to-array))))


;;; Returns a copy of object to be passed as a value parameter
(defun *copy-object* (object)
  (cond ((listp object) (mapcar #'*copy-object* object))
	((arrayp object)
	 ;1; ++ If is a hack because of compiler error unable to handle*
	1  *;1; :named-structure-symbol nil*
	     (loop with new-arr = (IF (named-structure-p object)
				      (make-array (array-dimensions object)
					      :type (array-type object)
					      :named-structure-symbol
					      (named-structure-p object))
				      ;1;ELSE*
				      (make-array (array-dimensions object)
					      :type (array-type object)))
		   for i from 0 to (zlc:sub1 (array-length object))
		   do (setf (aref new-arr i) (*copy-object* (aref object i)))
		   finally (return new-arr)))
	(t object)))

;;; The following are the values that variables of different types are initialized to.
;;; NOTE: This constants are used in the DEFSTRUCT forms to send up the compiler symbol
;;; table, however they are evaluated each time, so that if you change them, you should
;;; get the new value.
(defvar *uninitialized-variable-is-error* nil
  "if T then if a variable is uninitialized it will be an error,
   because the variable will be bound to *UNINITIALIZED*")

(defvar *numeric-init-form* 0
  "the initial value for numbers (integers, reals and subranges of them)")

(defvar *character-init-form* #\Null
  "the initial value for character types (and subranges of them)")

(defvar *enumerated-init-form* nil
  "the initial value for enumerated types (including Booleans and subranges of them)")

(defvar *pointer-init-form* nil
  "the initial value for pointer types")

(defvar *set-init-form* nil
  "the initial value for set types")

(defun *init-array* (array &quote form)
  "initializes array to the value of evaluating form"
  (dotimes (i (array-length array)) (setf (aref array i) (eval form)))
  array)

(defmacro *init-numeric* ()
  (if *uninitialized-variable-is-error* ''*uninitialized* '*numeric-init-form*))

;;; Define a macro to initial packed subranges, note they are 0'd since '*UNINITIALIZED*
;;; can't fit in one word
(defmacro *init-packed-subrange* () *numeric-init-form*)

(defmacro *init-enumerated* ()
  (if *uninitialized-variable-is-error* ''*uninitialized* '*enumerated-init-form*))

(defmacro *init-pointer* ()
  (if *uninitialized-variable-is-error* ''*uninitialized* '*pointer-init-form*))

(defmacro *init-set* ()
  (if *uninitialized-variable-is-error* ''*uninitialized* '*set-init-form*))

(defmacro *init-character* () '*character-init-form*)

(defmacro *init-string* () '*character-init-form*)

;1; ++ sjp  created function on *7/07/86 09:56:561.  I think it catches all that it*
;1; is supposed to do.*

(DEFUN *signal-runtime-error* (func moreargs str &rest word)
  (BEEP)
  (TERPRI)
  (FORMAT t "3in *SIGNAL-RUNTIME-ERROR*:*")
  (TERPRI)
  (TERPRI)
  (IF moreargs
      (FORMAT t str (CAR word))		   ;1 WORD contains only one arg*
      (FORMAT t str))
  (FORMAT t "3 ~A ~%*" func)
  (global:BREAK))

(DEFUN round (n) (global:round n))	   ;1 probably correct*

(DEFUN abs (n) (global:abs n))		   ;1 probably correct*


;1;; The following are included to handle fields of variant word records*
(DEFINE-SETF-METHOD fix (list)
  (LET ((TEMPVARS (LIST (GENSYM)))
	(TEMPARGS (LIST LIST))
	(STOREVAR (GENSYM)))
    (values tempvars nil (list storevar)
	    `(setf ,(first tempargs) ,storevar)
	    `(zlc:fix ,(first tempargs)))))


(DEFINE-SETF-METHOD float (LIST)
  (LET ((tempvars (LIST (GENSYM)))
	(tempargs (LIST list))
	(storevar (GENSYM)))
    (VALUES tempvars nil (LIST storevar)
	    `(SETF ,(FIRST tempargs) ,storevar)
	    `(FLOAT ,(FIRST tempargs)))))