home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / o / ops5.zip / OPS-IO.LIS < prev    next >
Lisp/Scheme  |  1992-03-06  |  15KB  |  542 lines
  1. ;
  2. ;************************************************************************
  3. ;
  4. ;    VPS2 -- Interpreter for OPS5
  5. ;
  6. ;
  7. ;
  8. ; This Common Lisp version of OPS5 is in the public domain.  It is based
  9. ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
  10. ; at Carnegie-Mellon University, which was placed in the public domain by
  11. ; the author in accordance with CMU policies.  This version has been
  12. ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
  13. ; and Dan Kuokka.
  14. ;
  15. ; This code is made available is, and without warranty of any kind by the
  16. ; authors or by Carnegie-Mellon University.
  17. ;
  18.  
  19. ;;;; This file contains all the functions pertaining to I/O.
  20.  
  21. (in-package "OPS")
  22. (shadow '(write))    ; Should get this by requiring ops-rhs
  23.  
  24.  
  25. ;;; Internal global variables.
  26.  
  27. (defvar *write-file*)
  28. (defvar *trace-file*)
  29. (defvar *accept-file*)
  30. (defvar *ppline*)
  31. (defvar *filters*)
  32.  
  33.  
  34.  
  35. ;;; Initialization
  36.  
  37. (defun io-init ()
  38.   (setq *write-file* nil)
  39.   (setq *trace-file* nil)
  40.   (setq *accept-file* nil))
  41.  
  42.  
  43.  
  44. ;;; User I/O commands
  45. ;;; Dario Giuse - rewrote the (write) function to follow OPS-5 specifications.
  46. ;;; Michael Huhns fixed a few bugs in this rewrttien functions some years later.
  47.  
  48.  
  49. (defmacro append-string (x)
  50.   `(setq wrstring (concatenate 'simple-string wrstring ,x)))
  51.  
  52.  
  53. (defun ops-write (z)
  54.   (prog (port max k x)
  55.     (cond ((not *in-rhs*)
  56.        (%warn '|cannot be called at top level| 'write)
  57.        (return nil)))
  58.     ($reset)
  59.     (eval-args z)
  60.     (setq max ($parametercount))
  61.     (cond ((< max 1)
  62.        (%warn '|write: nothing to print| z)
  63.        (return nil)))
  64.     (setq x ($parameter 1))
  65.     (cond ((and (symbolp x) ($ofile x)) 
  66.        (setq port ($ofile x))
  67.        (setq k 2))
  68.       (t
  69.        (setq port (default-write-file))
  70.        (setq k 1)))
  71.     ;; Analyze and output all the parameters (write) was passed.
  72.     (do* ((wrstring "")
  73.       (x ($parameter k) ($parameter k))
  74.       (field-width))
  75.      ((> k max)
  76.       (format port wrstring)
  77.       (force-output))     ; Dario Giuse - added to force output
  78.       (incf k)
  79.       (case x
  80.     (|=== C R L F ===|
  81.      (format port "~A~%" wrstring)     ; Flush the previous line
  82.      (setq wrstring ""))
  83.     (|=== R J U S T ===|
  84.      (setq field-width ($parameter k))           ; Number following (tabto)
  85.      (incf k)
  86.      (setq x (format nil "~A" ($parameter k)))   ; Next field to print
  87.      (when (<= (length x) field-width)
  88.        ;; Right-justify field
  89.        (append-string (format nil "~V@A" field-width x))
  90.        (incf k)))   ; Skip next field, since we printed it already
  91.     (|=== T A B T O ===|
  92.      (setq x ($parameter k))         ; Position to tab to
  93.      (incf k)
  94.      (when (< x (length wrstring))
  95.        ;; Flush line, start a new one
  96.        (format port "~A~%" wrstring)
  97.        (setq wrstring ""))
  98.      (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
  99.     (t
  100.      (append-string (format nil "~A " x)))))))
  101.  
  102.  
  103. (defun ops-openfile (z)
  104.   (prog (file mode id)
  105.     ($reset)
  106.     (eval-args z)
  107.     (cond ((not (equal ($parametercount) 3.))
  108.        (%warn '|openfile: wrong number of arguments| z)
  109.        (return nil)))
  110.     (setq id ($parameter 1))
  111.     (setq file ($parameter 2))
  112.     (setq mode ($parameter 3))
  113.     (cond ((not (symbolp id))
  114.        (%warn '|openfile: file id must be a symbolic atom| id)
  115.        (return nil))
  116.       ((null id)
  117.        (%warn '|openfile: 'nil' is reserved for the terminal| nil)
  118.        (return nil))
  119.       ((or ($ifile id)($ofile id))
  120.        (%warn '|openfile: name already in use| id)
  121.        (return nil)))
  122. ;@@@    (cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
  123. ;@@@          ((eq mode 'out) (putprop id (outfile file) 'outputfile))
  124. ; dec 7 83 gdw added setq : is putprop needed ? )
  125.     (cond ((eq mode 'in) (putprop id (setq id (infile file)) 'inputfile))
  126.       ((eq mode 'out) (putprop id (setq id (outfile file)) 'outputfile))
  127.       (t (%warn '|openfile: illegal mode| mode)
  128.          (return nil)))
  129.     (return nil)))
  130.  
  131.  
  132. (defun infile (f_name)
  133.   (open f_name :direction :input))
  134.  
  135. (defun outfile (f_name)
  136.   (open f_name :direction :output :if-exists :new-version))
  137.  
  138. (defun ops-closefile (z)
  139.   ($reset)
  140.   (eval-args z)
  141.   (mapc (function closefile2) (use-result-array)))
  142.  
  143. (defun closefile2 (file)
  144.   (prog (port)
  145.     (cond ((not (symbolp file))
  146.        (%warn '|closefile: illegal file identifier| file))
  147.       ((setq port ($ifile file))
  148.        (close port)
  149.        (remprop file 'inputfile))
  150.       ((setq port ($ofile file))
  151.        (close port)
  152.        (remprop file 'outputfile)))
  153.     (return nil)))
  154.  
  155.  
  156. (defun ops-default (z)
  157.   (prog (file use)
  158.     ($reset)
  159.     (eval-args z)
  160.     (cond ((not (equal ($parametercount) 2.))
  161.        (%warn '|default: wrong number of arguments| z)
  162.        (return nil)))
  163.     (setq file ($parameter 1))
  164.     (setq use ($parameter 2))
  165.     (cond ((not (symbolp file))
  166.        (%warn '|default: illegal file identifier| file)
  167.        (return nil))
  168.       ((not (member use '(write accept trace) :test #'equal))
  169.        (%warn '|default: illegal use for a file| use)
  170.        (return nil))
  171.       ((and (member use '(write trace) :test #'equal)
  172.         (not (null file))
  173.         (not ($ofile file)))
  174.        (%warn '|default: file has not been opened for output| file)
  175.        (return nil))
  176.       ((and (equal use 'accept) 
  177.         (not (null file))
  178.         (not ($ifile file)))
  179.        (%warn '|default: file has not been opened for input| file)
  180.        (return nil))
  181.       ((equal use 'write) (setq *write-file* file))
  182.       ((equal use 'accept) (setq *accept-file* file))
  183.       ((equal use 'trace) (setq *trace-file* file)))
  184.     (return nil)))
  185.  
  186.  
  187. (defun ops-accept (z)
  188.   (prog (port arg)
  189.     (cond ((> (length z) 1.)
  190.        (%warn '|accept: wrong number of arguments| z)
  191.        (return nil)))
  192.     (setq port *standard-input*)
  193.     (cond (*accept-file*
  194.        (setq port ($ifile *accept-file*))
  195.        (cond ((null port) 
  196.           (%warn '|accept: file has been closed| *accept-file*)
  197.           (return nil)))))
  198.     (cond ((= (length z) 1)
  199.        (setq arg ($varbind (car z)))
  200.        (cond ((not (symbolp arg))
  201.           (%warn '|accept: illegal file name| arg)
  202.           (return nil)))
  203.        (setq port ($ifile arg))
  204.        (cond ((null port) 
  205.           (%warn '|accept: file not open for input| arg)
  206.           (return nil)))))
  207.     (cond ((equal (peek-char t port nil "eof" ) "eof" )
  208.        ($value 'end-of-file)
  209.        (return nil)))
  210.     (flat-value (read port)))) 
  211.  
  212.  
  213.  
  214. ;;; Dario Giuse - completely changed the algorithm. It now uses one read-line
  215. ;;; and the read-from-string.
  216. ;;;
  217. (defun ops-acceptline (z)
  218.   (let ((port *standard-input*)
  219.     (def z))
  220.     (cond (*accept-file*
  221.        (setq port ($ifile *accept-file*))
  222.        (cond ((null port) 
  223.           (%warn '|acceptline: file has been closed| 
  224.              *accept-file*)
  225.           (return-from ops-acceptline nil)))))
  226.     (cond ((> (length def) 0)
  227.        (let ((arg ($varbind (car def))))
  228.          (cond ((and (symbolp arg) ($ifile arg))
  229.             (setq port ($ifile arg))
  230.             (setq def (cdr def)))))))
  231.     (let ((line (read-line port nil 'eof)))
  232.       (declare (simple-string line))
  233.       ;; Strip meaningless characters from start and end of string.
  234.       (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
  235.       (when (equal line "")
  236.     (mapc (function $change) def)
  237.     (return-from ops-acceptline nil))
  238.       (setq line (concatenate 'simple-string "(" line ")"))
  239.       ;; Read all items from the line
  240.       (flat-value (read-from-string line)))))
  241.  
  242.  
  243.  
  244.  
  245. (defun ops-rjust (z)
  246.   (prog (val)
  247.     (cond ((not (= (length z) 1.))
  248.        (%warn '|rjust: wrong number of arguments| z)
  249.        (return nil)))
  250.     (setq val ($varbind (car z)))
  251.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  252.        (%warn '|rjust: illegal value for field width| val)
  253.        (return nil)))
  254.     ($value '|=== R J U S T ===|)
  255.     ($value val)))
  256.  
  257.  
  258. (defun ops-crlf (z)
  259.   (cond  (z (%warn '|crlf: does not take arguments| z))
  260.      (t ($value '|=== C R L F ===|))))
  261.  
  262.  
  263. (defun ops-tabto (z)
  264.   (prog (val)
  265.     (cond ((not (= (length z) 1.))
  266.        (%warn '|tabto: wrong number of arguments| z)
  267.        (return nil)))
  268.     (setq val ($varbind (car z)))
  269.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  270.        (%warn '|tabto: illegal column number| z)
  271.        (return nil)))
  272.     ($value '|=== T A B T O ===|)
  273.     ($value val)))
  274.  
  275.  
  276.  
  277. (defun do-rjust (width value port)
  278.   (prog (size)
  279.     (cond ((eq value '|=== T A B T O ===|)
  280.        (%warn '|rjust cannot precede this function| 'tabto)
  281.        (return nil))
  282.       ((eq value '|=== C R L F ===|)
  283.        (%warn '|rjust cannot precede this function| 'crlf)
  284.        (return nil))
  285.       ((eq value '|=== R J U S T ===|)
  286.        (%warn '|rjust cannot precede this function| 'rjust)
  287.        (return nil)))
  288.     ;original->        (setq size (flatc value (1+ width)))
  289.     (setq size (min value (1+ width)))  ;### KLUGE
  290.     (cond ((> size width)
  291.        (princ '| | port)
  292.        (princ value port)
  293.        (return nil)))
  294.     ;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
  295.     ;^^^KLUGE @@@do
  296.     (princ value port)))
  297.  
  298. (defun do-tabto (col port)
  299.   (prog (pos)
  300.     ;### KLUGE: FLUSHES STREAM & SETS POS TO 0
  301.     ;OIRGINAL->    (setq pos (1+ (nwritn port)))    ;hmm-takes 1 arg @@@ port
  302.     (finish-output port);kluge
  303.     (setq pos 0);kluge
  304.     (cond ((> pos col)
  305.        (terpri port)
  306.        (setq pos 1)))
  307.     ;###(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
  308.     ;^^^KLUGE @@@do
  309.     (return nil)))
  310.  
  311.  
  312. (defun flat-value (x)
  313.   (cond ((atom x) ($value x))
  314.     (t (mapc (function flat-value) x)))) 
  315.  
  316.  
  317.  
  318. ;;; Printing WM
  319.  
  320. (defun ops-ppwm (avlist)
  321.   (prog (next a)
  322.     (setq *filters* nil)
  323.     (setq next 1.)
  324.     loop   (and (atom avlist) (go print))
  325.     (setq a (car avlist))
  326.     (setq avlist (cdr avlist))
  327.     ;this must be expecting (ppwm class ^ attr ^ attr2 ...) not ^attr
  328.     (cond ((eq a '^)
  329.        (setq next (car avlist))
  330.        (setq avlist (cdr avlist))
  331.        (setq next ($litbind next))
  332.        (and (floatp next) (setq next (fix next)))
  333.        (cond ((or (not (numberp next))
  334.               (> next *size-result-array*)
  335.               (> 1. next))
  336.           (%warn '|illegal index after ^| next)
  337.           (return nil))))
  338.       ((variablep a)
  339.        (%warn '|ppwm does not take variables| a)
  340.        (return nil))
  341.       (t (setq *filters* (cons next (cons a *filters*)))
  342.          (setq next (1+ next))))
  343.     (go loop)
  344.     print (mapwm (function ppwm2))
  345.     (terpri)
  346.     (return nil))) 
  347.  
  348.  
  349. (defun default-write-file ()
  350.   (prog (port)
  351.     (setq port *standard-output*)
  352.     (cond (*write-file*
  353.        (setq port ($ofile *write-file*))
  354.        (cond ((null port) 
  355.           (%warn '|write: file has been closed| *write-file*)
  356.           (setq port *standard-output*)))))
  357.     (return port)))
  358.  
  359.  
  360. (defun trace-file ()
  361.   (prog (port)
  362.     (setq port *standard-output*)
  363.     (cond (*trace-file*
  364.        (setq port ($ofile *trace-file*))
  365.        (cond ((null port)
  366.           (%warn '|trace: file has been closed| *trace-file*)
  367.           (setq port *standard-output*)))))
  368.     (return port)))
  369.  
  370.  
  371. (defun ppwm2 (elm-tag)
  372.   (cond ((filter (car elm-tag))
  373.      (terpri) (ppelm (car elm-tag) (default-write-file))))) 
  374.  
  375. (defun filter (elm)
  376.   (prog (fl indx val)
  377.     (setq fl *filters*)
  378.     top  (and (atom fl) (return t))
  379.     (setq indx (car fl))
  380.     (setq val (cadr fl))
  381.     (setq fl (cddr fl))
  382.     (and (ident (nth (1- indx) elm) val) (go top))
  383.     (return nil))) 
  384.  
  385. (defun ident (x y)
  386.   (cond ((eq x y) t)
  387.     ((not (numberp x)) nil)
  388.     ((not (numberp y)) nil)
  389.     ((=alg x y) t)
  390.     (t nil))) 
  391.  
  392. ; the new ppelm is designed especially to handle literalize format
  393. ; however, it will do as well as the old ppelm on other formats
  394.  
  395. (defun ppelm (elm port)
  396.   (prog (ppdat sep val att mode lastpos)
  397.     (princ (creation-time elm) port)
  398.     (princ '|:  | port)
  399.     (setq mode 'vector)
  400.     (setq ppdat (get (car elm) 'ppdat))
  401.     (and ppdat (setq mode 'a-v))
  402.     (setq sep "(")                ; ")" 
  403.     (setq lastpos 0)
  404.     (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
  405.     ((atom vlist) nil)                    ; terminate
  406.       (setq val (car vlist))                ; tagbody begin
  407.       (setq att (assoc curpos ppdat))    ;should ret (curpos attr-name) 
  408.       (cond (att (setq att (cdr att)))    ; att = (attr-name) ??
  409.         (t (setq att curpos)))
  410.       (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
  411.       (cond ((or (not (null val)) (eq mode 'vector))
  412.          (princ sep port)
  413.          (ppval val att lastpos port)
  414.          (setq sep '|    |)
  415.          (setq lastpos curpos))))
  416.     (princ '|)| port)))
  417.  
  418. (defun ppval (val att lastpos port)
  419.   ;  (break "in ppval")        
  420.   (cond ((not (equal att (1+ lastpos)))        ; ok, if we got an att 
  421.      (princ '^ port)
  422.      (princ att port)
  423.      (princ '| | port)))
  424.   (princ val port))
  425.  
  426.  
  427.  
  428. ;;; Printing production memory
  429.  
  430. (defun ops-pm (z) (mapc (function pprule) z) (terpri) nil)
  431.  
  432. (defun pprule (name)
  433.   (prog (matrix next lab)
  434.     (and (not (symbolp name)) (return nil))
  435.     (setq matrix (get name 'production))
  436.     (and (null matrix) (return nil))
  437.     (terpri)
  438.     (princ '|(p |)      ;)
  439.     (princ name)
  440.     top    (and (atom matrix) (go fin))
  441.     (setq next (car matrix))
  442.     (setq matrix (cdr matrix))
  443.     (setq lab nil)
  444.     (terpri)
  445.     (cond ((eq next '-)
  446.        (princ '|  - |)
  447.        (setq next (car matrix))
  448.        (setq matrix (cdr matrix)))
  449.       ((eq next '-->)
  450.        (princ '|  |))
  451.       ((and (eq next '{) (atom (car matrix)))
  452.        (princ '|   {|)
  453.        (setq lab (car matrix))
  454.        (setq next (cadr matrix))
  455.        (setq matrix (cdddr matrix)))
  456.       ((eq next '{)
  457.        (princ '|   {|)
  458.        (setq lab (cadr matrix))
  459.        (setq next (car matrix))
  460.        (setq matrix (cdddr matrix)))
  461.       (t (princ '|    |)))
  462.     (ppline next)
  463.     (cond (lab (princ '| |) (princ lab) (princ '})))
  464.     (go top)
  465.     fin    (princ '|)|)))
  466.  
  467. (defun ppline (line)
  468.   (prog ()
  469.     (cond ((atom line) (princ line))
  470.       (t
  471.        (princ '|(|)      ;)
  472.        (setq *ppline* line)
  473.        (ppline2)
  474.        ;(
  475.        (princ '|)|)))
  476.     (return nil)))
  477.  
  478. (defun ppline2 ()
  479.   (prog (needspace)
  480.     (setq needspace nil)
  481.     top  (and (atom *ppline*) (return nil))
  482.     (and needspace (princ '| |))
  483.     (cond ((eq (car *ppline*) '^) (ppattval))
  484.       (t (pponlyval)))
  485.     (setq needspace t)
  486.     (go top)))
  487.  
  488. (defun ppattval ()
  489.   (prog (att val)
  490.     (setq att (cadr *ppline*))
  491.     (setq *ppline* (cddr *ppline*))
  492.     (setq val (getval))
  493.     ;###    (cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)))
  494.     ;@@@ nwritn no arg
  495.     ;                        ;"plus" changed to "+" by gdw
  496.     ;           (terpri)
  497.     ;           (princ '|        |)
  498.     (princ '^)
  499.     (princ att)
  500.     (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
  501.  
  502. (defun pponlyval ()
  503.   (prog (val needspace)
  504.     (setq val (getval))
  505.     (setq needspace nil)
  506.     ;###    (cond ((> (+ (nwritn) (flatc val)) 76.)))
  507.     ;"plus" changed to "+" by gdw
  508.     ;           (setq needspace nil)        ;^nwritn no arg @@@
  509.     ;           (terpri)
  510.     ;           (princ '|        |)
  511.     top    (and (atom val) (return nil))
  512.     (and needspace (princ '| |))
  513.     (setq needspace t)
  514.     (princ (car val))
  515.     (setq val (cdr val))
  516.     (go top)))
  517.  
  518. (defun getval ()
  519.   (prog (res v1)
  520.     (setq v1 (car *ppline*))
  521.     (setq *ppline* (cdr *ppline*))
  522.     (cond ((member v1 '(= <> < <= => > <=>))
  523.        (setq res (cons v1 (getval))))
  524.       ((eq v1 '{)
  525.        (setq res (cons v1 (getupto '}))))
  526.       ((eq v1 '<<)
  527.        (setq res (cons v1 (getupto '>>))))
  528.       ((eq v1 '//)
  529.        (setq res (list v1 (car *ppline*)))
  530.        (setq *ppline* (cdr *ppline*)))
  531.       (t (setq res (list v1))))
  532.     (return res)))
  533.  
  534. (defun getupto (end)
  535.   (prog (v)
  536.     (and (atom *ppline*) (return nil))
  537.     (setq v (car *ppline*))
  538.     (setq *ppline* (cdr *ppline*))
  539.     (cond ((eq v end) (return (list v)))
  540.       (t (return (cons v (getupto end))))))) 
  541.  
  542.