;;; ****************************************************************
 ;;; OPS5 Interpreter ***********************************************
 ;;; ****************************************************************
 ;;; This Common Lisp version of OPS5 is in the public domain.  It is based
 ;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
 ;;; at Carnegie-Mellon University, which was placed in the public domain by
 ;;; the author in accordance with CMU policies.  Ported to Common Lisp by 
 ;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
 ;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka. 
 ;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by 
 ;;; Mark Kantrowitz on 14-OCT-92.
 ;;; 
 ;;; This code is made available is, and without warranty of any kind by the
 ;;; authors or by Carnegie-Mellon University.
 ;;;
 
 ;;;; This file contains all the functions pertaining to I/O.
 
 (in-package "OPS")
 ;; (shadow '(write))    ; Should get this by requiring ops-rhs
 
 
 ;;; Internal global variables.
 

 (defvar *write-file* nil)
 (defvar *trace-file* nil)
 (defvar *accept-file* nil)
 (defvar *ppline* nil)
 (defvar *filters* nil)

 
 
 
 ;;; Initialization
 
 (defun io-init ()
   (setq *write-file* nil)
   (setq *trace-file* nil)
   (setq *accept-file* nil))
 
 
 
 ;;; User I/O commands
 ;;; Dario Giuse - rewrote the (write) function to follow OPS-5 specifications.
 ;;; Michael Huhns fixed a few bugs in this rewrttien functions some years later.
 
 
 ;;; used only in this file.
 (defmacro append-string (x)
   `(setq wrstring (concatenate 'simple-string wrstring ,x)))
 
 
 (defun ops-write (z)
   (if (not *in-rhs*)
       (%warn '|cannot be called at top level| 'write)
       (prog (port max k x)
 	($reset)
 	(eval-args z)
 	(setq max ($parametercount))
 	(when (< max 1)
 	  (%warn '|write: nothing to print| z)
 	  (return nil))
 	(setq x ($parameter 1))
 	(cond ((and (symbolp x) ($ofile x)) 
 	       (setq port ($ofile x))
 	       (setq k 2))
 	      (t
 	       (setq port (default-write-file))
 	       (setq k 1)))
 	;; Analyze and output all the parameters (write) was passed.
 	(do* ((wrstring "")
 	      (x ($parameter k) ($parameter k))
 	      (field-width))
 	     ((> k max)
 	      (format port wrstring)
 	      (force-output))		; Dario Giuse - added to force output
 	  (incf k)
 	  (case x
 	    (|=== C R L F ===|
 	     (format port "~A~%" wrstring) ; Flush the previous line
 	     (setq wrstring ""))
 	    (|=== R J U S T ===|
 	     (setq field-width ($parameter k)) ; Number following (tabto)
 	     (incf k)
 	     (setq x (format nil "~A" ($parameter k))) ; Next field to print
 	     (when (<= (length x) field-width)
 	       ;; Right-justify field
 	       (append-string (format nil "~V@A" field-width x))
 	       (incf k)))		; Skip next field, since we printed it already
 	    (|=== T A B T O ===|
 	     (setq x ($parameter k))	; Position to tab to
 	     (incf k)
 	     (when (< x (length wrstring))
 	       ;; Flush line, start a new one
 	       (format port "~A~%" wrstring)
 	       (setq wrstring ""))
 	     (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
 	    (t
 	     (append-string (format nil "~A " x))))))))
 
 
 (defun ops-openfile (z)
   (prog (file mode id)
     ($reset)
     (eval-args z)
     (cond ((not (equal ($parametercount) 3.))
 	   (%warn '|openfile: wrong number of arguments| z)
 	   (return nil)))
     (setq id ($parameter 1))
     (setq file ($parameter 2))
     (setq mode ($parameter 3))
     (cond ((not (symbolp id))
 	   (%warn '|openfile: file id must be a symbolic atom| id)
 	   (return nil))
 	  ((null id)
 	   (%warn '|openfile: 'nil' is reserved for the terminal| nil)
 	   (return nil))
 	  ((or ($ifile id)($ofile id))
 	   (%warn '|openfile: name already in use| id)
 	   (return nil)))
 ;@@@	(cond ((eq mode 'in) (setf (gethash id *inputfile-table*) (infile file)))
 ;@@@	      ((eq mode 'out) (setf (gethash id *outputfile-table*) (outfile file)))
 ; dec 7 83 gdw added setq : is putprop needed ? )
     (cond ((eq mode 'in) (setf (gethash id *inputfile-table*)
 			       (setq id (infile file))))
 	  ((eq mode 'out) (setf (gethash id *outputfile-table*)
 				(setq id (outfile file))))
 	  (t (%warn '|openfile: illegal mode| mode)
 	     (return nil)))
     (return nil)))
 
 
 (defun infile (f_name)
   (open f_name :direction :input))
 
 (defun outfile (f_name)
   (open f_name :direction :output :if-exists :new-version))
 
 (defun ops-closefile (z)
   ($reset)
   (eval-args z)
   (mapc #'closefile2 (use-result-array)))
 
 (defun closefile2 (file)
   (let (port)
     (cond ((not (symbolp file))
 	   (%warn '|closefile: illegal file identifier| file))
 	  ((setq port ($ifile file))
 	   (close port)
 	   (remhash file *inputfile-table*))
 	  ((setq port ($ofile file))
 	   (close port)
 	   (remhash file *outputfile-table*)))
     nil))
 
 (defun ops-default (z)
   (prog (file use)
     ($reset)
     (eval-args z)
     (cond ((not (equal ($parametercount) 2.))
 	   (%warn '|default: wrong number of arguments| z)
 	   (return nil)))
     (setq file ($parameter 1))
     (setq use ($parameter 2))
     (cond ((not (symbolp file))
 	   (%warn '|default: illegal file identifier| file)
 	   (return nil))
 	  ((not (member use '(write accept trace) :test #'equal))
 	   (%warn '|default: illegal use for a file| use)
 	   (return nil))
 	  ((and (member use '(write trace) :test #'equal)
 		(not (null file))
 		(not ($ofile file)))
 	   (%warn '|default: file has not been opened for output| file)
 	   (return nil))
 	  ((and (equal use 'accept) 
 		(not (null file))
 		(not ($ifile file)))
 	   (%warn '|default: file has not been opened for input| file)
 	   (return nil))
 	  ((equal use 'write) (setq *write-file* file))
 	  ((equal use 'accept) (setq *accept-file* file))
 	  ((equal use 'trace) (setq *trace-file* file)))
     (return nil)))
 
 
 (defun ops-accept (z)
   (prog (port arg)
     (cond ((> (length z) 1.)
 	   (%warn '|accept: wrong number of arguments| z)
 	   (return nil)))
     (setq port *standard-input*)
     (cond (*accept-file*
 	   (setq port ($ifile *accept-file*))
 	   (cond ((null port) 
 		  (%warn '|accept: file has been closed| *accept-file*)
 		  (return nil)))))
     (cond ((= (length z) 1)
 	   (setq arg ($varbind (car z)))
 	   (cond ((not (symbolp arg))
 		  (%warn '|accept: illegal file name| arg)
 		  (return nil)))
 	   (setq port ($ifile arg))
 	   (cond ((null port) 
 		  (%warn '|accept: file not open for input| arg)
 		  (return nil)))))
     (cond ((equal (peek-char t port nil "eof" ) "eof" )
 	   ($value 'end-of-file)
 	   (return nil)))
     (flat-value (read port)))) 
 
 
 
 ;;; Dario Giuse - completely changed the algorithm. It now uses one read-line
 ;;; and the read-from-string.
 ;;;
 (defun ops-acceptline (z)
   (let ((port *standard-input*)
 	(def z))
     (cond (*accept-file*
 	   (setq port ($ifile *accept-file*))
 	   (cond ((null port) 
 		  (%warn '|acceptline: file has been closed| 
 			 *accept-file*)
 		  (return-from ops-acceptline nil)))))
     (cond ((> (length def) 0)
 	   (let ((arg ($varbind (car def))))
 	     (cond ((and (symbolp arg) ($ifile arg))
 		    (setq port ($ifile arg))
 		    (setq def (cdr def)))))))
     (let ((line (read-line port nil 'eof)))
       (declare (simple-string line))
       ;; Strip meaningless characters from start and end of string.
       (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
       (when (equal line "")
 	(mapc (function $change) def)
 	(return-from ops-acceptline nil))
       (setq line (concatenate 'simple-string "(" line ")"))
       ;; Read all items from the line
       (flat-value (read-from-string line)))))
 
 (defun ops-rjust (z)
   (prog (val)
     (when (not (= (length z) 1.))
       (%warn '|rjust: wrong number of arguments| z)
       (return nil))
     (setq val ($varbind (car z)))
     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
 	   (%warn '|rjust: illegal value for field width| val)
 	   (return nil)))
     ($value '|=== R J U S T ===|)
     ($value val)))
 
 
 (defun ops-crlf (z)
   (cond  (z (%warn '|crlf: does not take arguments| z))
 	 (t ($value '|=== C R L F ===|))))
 
 
 (defun ops-tabto (z)
   (prog (val)
     (when (not (= (length z) 1.))
       (%warn '|tabto: wrong number of arguments| z)
       (return nil))
     (setq val ($varbind (car z)))
     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
 	   (%warn '|tabto: illegal column number| z)
 	   (return nil)))
     ($value '|=== T A B T O ===|)
     ($value val)))
 
 (defun do-rjust (width value port)
   (prog (size)
     (cond ((eq value '|=== T A B T O ===|)
 	   (%warn '|rjust cannot precede this function| 'tabto)
 	   (return nil))
 	  ((eq value '|=== C R L F ===|)
 	   (%warn '|rjust cannot precede this function| 'crlf)
 	   (return nil))
 	  ((eq value '|=== R J U S T ===|)
 	   (%warn '|rjust cannot precede this function| 'rjust)
 	   (return nil)))
     ;original->        (setq size (flatc value (1+ width)))
     (setq size (min value (1+ width)))  ;### KLUGE
     (cond ((> size width)
 	   (princ '| | port)
 	   (princ value port)
 	   (return nil)))
     ;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
     ;^^^KLUGE @@@do
     (princ value port)))
 
 (defun do-tabto (col port)
   (prog (pos)
     ;### KLUGE: FLUSHES STREAM & SETS POS TO 0
     ;OIRGINAL->	(setq pos (1+ (nwritn port)))	;hmm-takes 1 arg @@@ port
     (finish-output port);kluge
     (setq pos 0);kluge
     (cond ((> pos col)
 	   (terpri port)
 	   (setq pos 1)))
     ;###(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
     ;^^^KLUGE @@@do
     (return nil)))
 
 
 (defun flat-value (x)
   (cond ((atom x) ($value x))
 	(t (mapc #'flat-value x)))) 
 
 
 
 ;;; Printing WM
 
 (defun ops-ppwm (avlist)
   (prog (next a)
     (setq *filters* nil)
     (setq next 1.)
     loop   (and (atom avlist) (go print))
     (setq a (car avlist))
     (setq avlist (cdr avlist))
     ;this must be expecting (ppwm class ^ attr ^ attr2 ...) not ^attr
     (cond ((eq a '^)
 	   (setq next (car avlist))
 	   (setq avlist (cdr avlist))
 	   (setq next ($litbind next))
 	   (and (floatp next) (setq next (floor next)))
 	   (cond ((or (not (numberp next))
 		      (> next *size-result-array*)
 		      (> 1. next))
 		  (%warn '|illegal index after ^| next)
 		  (return nil))))
 	  ((variablep a)
 	   (%warn '|ppwm does not take variables| a)
 	   (return nil))
 	  (t (setq *filters* (cons next (cons a *filters*)))
 	     (setq next (1+ next))))
     (go loop)
     print (mapwm #'ppwm2)
     (terpri)
     (return nil))) 
 
 
 (defun default-write-file ()
   (let ((port *standard-output*))
     (when *write-file*
       (setq port ($ofile *write-file*))
       (when (null port) 
 	(%warn '|write: file has been closed| *write-file*)
 	(setq port *standard-output*)))
     port))
 
 (defun trace-file ()
   (let ((port *standard-output*))
     (when *trace-file*
       (setq port ($ofile *trace-file*))
       (when (null port)
 	(%warn '|trace: file has been closed| *trace-file*)
 	(setq port *standard-output*)))
     port))
 
 (defun ppwm2 (elm-tag)
   (cond ((filter (car elm-tag))
 	 (terpri) (ppelm (car elm-tag) (default-write-file))))) 
 
 (defun filter (elm)
   (prog (fl indx val)
     (setq fl *filters*)
     top  (and (atom fl) (return t))
     (setq indx (car fl))
     (setq val (cadr fl))
     (setq fl (cddr fl))
     (and (ident (nth (1- indx) elm) val) (go top))
     (return nil))) 
 
 (defun ident (x y)
   (cond ((eq x y) t)
 	((not (numberp x)) nil)
 	((not (numberp y)) nil)
 	((=alg x y) t)
 	(t nil))) 
 
 ; the new ppelm is designed especially to handle literalize format
 ; however, it will do as well as the old ppelm on other formats
 
 (defun ppelm (elm port)
   (prog (ppdat sep val att mode lastpos)
     (princ (creation-time elm) port)
     (princ '|:  | port)
     (setq mode 'vector)
     (setq ppdat (gethash (car elm) *ppdat-table*))
     (and ppdat (setq mode 'a-v))
     (setq sep "(")				; ")" 
     (setq lastpos 0)
     (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
 	((atom vlist) nil)					; terminate
       (setq val (car vlist))				; tagbody begin
       (setq att (assoc curpos ppdat))	;should ret (curpos attr-name) 
       (cond (att (setq att (cdr att)))	; att = (attr-name) ??
 	    (t (setq att curpos)))
       (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
       (cond ((or (not (null val)) (eq mode 'vector))
 	     (princ sep port)
 	     (ppval val att lastpos port)
 	     (setq sep '|    |)
 	     (setq lastpos curpos))))
     (princ '|)| port)))
 
 (defun ppval (val att lastpos port)
   ;  (break "in ppval")		
   (cond ((not (equal att (1+ lastpos)))		; ok, if we got an att 
 	 (princ '^ port)
 	 (princ att port)
 	 (princ '| | port)))
   (princ val port))
 
 
 
 ;;; Printing production memory
 
 (defun ops-pm (z) (mapc #'pprule z) (terpri) nil)
 
 (defun pprule (name)
   (prog (matrix next lab)
     (and (not (symbolp name)) (return nil))
     (setq matrix (gethash name *production-table*))
     (and (null matrix) (return nil))
     (terpri)
     (princ '|(p |)      ;)
     (princ name)
     top	(and (atom matrix) (go fin))
     (setq next (car matrix))
     (setq matrix (cdr matrix))
     (setq lab nil)
     (terpri)
     (cond ((eq next '-)
 	   (princ '|  - |)
 	   (setq next (car matrix))
 	   (setq matrix (cdr matrix)))
 	  ((eq next '-->)
 	   (princ '|  |))
 	  ((and (eq next '{) (atom (car matrix)))
 	   (princ '|   {|)
 	   (setq lab (car matrix))
 	   (setq next (cadr matrix))
 	   (setq matrix (cdddr matrix)))
 	  ((eq next '{)
 	   (princ '|   {|)
 	   (setq lab (cadr matrix))
 	   (setq next (car matrix))
 	   (setq matrix (cdddr matrix)))
 	  (t (princ '|    |)))
     (ppline next)
     (cond (lab (princ '| |) (princ lab) (princ '})))
     (go top)
     fin	(princ '|)|)))
 
 (defun ppline (line)
   (cond ((atom line) (princ line))
 	(t
 	 (princ '|(|)			;)
 	 (setq *ppline* line)
 	 (ppline2)
 					;(
 	 (princ '|)|)))
   nil)
 
 (defun ppline2 ()
   (prog (needspace)
     (setq needspace nil)
     top  (and (atom *ppline*) (return nil))
     (and needspace (princ '| |))
     (cond ((eq (car *ppline*) '^) (ppattval))
 	  (t (pponlyval)))
     (setq needspace t)
     (go top)))
 
 (defun ppattval ()
   (prog (att val)
     (setq att (cadr *ppline*))
     (setq *ppline* (cddr *ppline*))
     (setq val (getval))
     ;###	(cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)))
     ;@@@ nwritn no arg
     ;						;"plus" changed to "+" by gdw
     ;	       (terpri)
     ;	       (princ '|        |)
     (princ '^)
     (princ att)
     (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
 
 (defun pponlyval ()
   (prog (val needspace)
     (setq val (getval))
     (setq needspace nil)
     ;###	(cond ((> (+ (nwritn) (flatc val)) 76.)))
     ;"plus" changed to "+" by gdw
     ;	       (setq needspace nil)		;^nwritn no arg @@@
     ;	       (terpri)
     ;	       (princ '|        |)
     top	(and (atom val) (return nil))
     (and needspace (princ '| |))
     (setq needspace t)
     (princ (car val))
     (setq val (cdr val))
     (go top)))
 
 (defun getval ()
   (let ((v1 (pop *ppline*))
 	res)
     (cond ((member v1 '(= <> < <= => > <=>))
 	   (setq res (cons v1 (getval))))
 	  ((eq v1 '{)
 	   (setq res (cons v1 (getupto '}))))
 	  ((eq v1 '<<)
 	   (setq res (cons v1 (getupto '>>))))
 	  ((eq v1 '//)
 	   (setq res (list v1 (car *ppline*)))
 	   (setq *ppline* (cdr *ppline*)))
 	  (t (setq res (list v1))))
     res))
 
 (defun getupto (end)
   (if (atom *ppline*) nil
       (let ((v (pop *ppline*)))
 	(if (eq v end) 
 	    (list v)
 	    (cons v (getupto end))))))
 
 ;;; *EOF*