;;; ****************************************************************
 ;;; 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*