;;; ZWEI host -*-Mode: Lisp; Package: ZWEI; Base: 10.;Readtable:ZL-*-
;;; Copyright (c) 1982 Devon S. McCullough, all rights reserved.
;;; I may give you permission to use this -- ask if you
;;; are interested -- but I will insist that you agree to
;;; return all improvements to me for redistribution.

; Make ZWEI a host so Lisp Machine programs can treat buffers like files.

; hosts:  ED:  accepts any name the completing reader would
;         ED-FILE:  accepts a pathname and does a find file (like Control-X Control-F)
;         ED-BUFFER:  must have the exact buffer name or will create new buffer

; known bugs:  ED-FILE won't allow :NEW-FILE nil (I'll fix later)

; --- ZWEI-HOST ---

(defmacro zwei-host-def (flavor name)
  
  `(progn 'compile
	  (defflavor ,flavor () (SI:BASIC-HOST))	; hmmmm, tasty...
	  
	  (defmethod (,flavor :NAME) ()		; what's your use name?
	    ,name)

	  (defmethod (,flavor :SYSTEM-TYPE) () :zwei)
	  
	  (defmethod (,flavor :NAME-AS-FILE-COMPUTER) ()	; what can I call you?
	    ,name)

	  (defmethod (,flavor :PATHNAME-FLAVOR) ()	; how can I reach you?
	    ',(intern (string-append name "-PATHNAME")))
	  
	  (defmethod (,flavor :PATHNAME-HOST-NAMEP) (name)	; zwei, is that you?
	    (or (typep name ',flavor)
		(string-equal name ,name)))))
  
(zwei-host-def zwei-host "ED")
(zwei-host-def zwei-file-host "ED-FILE")
(zwei-host-def zwei-buffer-host "ED-BUFFER")
  
; -- ZWEI-PATHNAME --

(defflavor ed-basic-pathname () (fs:pathname))
(defflavor ed-pathname () (ed-basic-pathname))
(defflavor ed-file-pathname () (ed-basic-pathname))
(defflavor ed-buffer-pathname () (ed-basic-pathname))

(defmethod (ed-basic-pathname :string-for-host) ()
  ;;Print our name with no host or directory
  (send self :name))

(defmethod (ed-basic-pathname :STRING-FOR-PRINTING) ()	; print our name
  (string-append (send (send self :HOST) :NAME) ": "
		 (let ((name (send self :NAME)))
		   (if (not (or (null name) (eq name :unspecific))) (print name) ""))))

(defmethod (ed-basic-pathname :STRING-FOR-EDITOR) ()
  (string-append (send self :NAME) " " (send (send self :HOST) :NAME) ":"))

; PARSE-NAMESTRING accepts HOST-SPECIFIED (t or nil) which I ignore
;                          NAMESTRING (to be parsed)
;                          optional START and END indices into NAMESTRING
; returns multiple values DEVICE DIRECTORY NAME TYPE VERSION

(defmethod (ed-basic-pathname :PARSE-NAMESTRING) (ignored
					     namestring
					     &optional (start 0) end)
  (values :UNSPECIFIC  :UNSPECIFIC
	  (string-trim '(#\Space #\Tab) (string-upcase (substring namestring start end)))
	  :UNSPECIFIC :UNSPECIFIC))

(defmethod (ed-basic-pathname :HOMEDIR) (user)
  user
  (make-pathname :host fs:host :directory :unspecific :device :unspecific))

; OPEN returns what?  it's called from SI:INSTANCE-HASH-FAILURE from OPEN
;      (LEXPR-FUNCALL FILENAME :OPEN FILENAME KEYWORD-ARGS)
; So I need to understand KEYWORD-ARGS in order to implement this right.

;;; Possible keywords and values include the following:

; :DIRECTION is ignored if specified, ZWEI is always open for IO.
; :CHARACTERS (T and :DEFAULT for character mode, NIL for 16-bit :TYO mode)
; :BYTE-SIZE is ignored if specified, since :CHARACTERS does the job
; :ERROR if nil, return error string instead of bombing
; :NEW-FILE mustn't be T for ZWEI:
;           shouldn't (or should it?) be NIL for ZWEI-FILE:
;           if T, allows creation of new buffer for ZWEI-BUFFER:
; :OLD-FILE (T and :REWRITE = normal, :APPEND start at end)
; other keywords are totally ignored.

(defmethod (ed-pathname :OPEN)  ed-pathname-open)
(defmethod (ed-file-pathname :OPEN)  ed-pathname-open)
(defmethod (ed-buffer-pathname :OPEN)  ed-pathname-open)

(defun ED-PATHNAME-OPEN (ignored pathname
			 &key &optional (characters t)
			 (direction :input)
			 (error t)
			 (if-exists :append)
			 (if-does-not-exist
			   (if (eq direction :output) :create
			     :error))
			 &allow-other-keys)
  "parse OPEN keywords and then call the :REALLY-OPEN method"
  (let ((stream
	  (send self :REALLY-OPEN pathname characters error
		(eq if-does-not-exist :create))))
    (if (and (eq direction :output)
	     (eq if-exists :append))
	(send stream :read-until-eof))
    stream))

(defmethod (ED-PATHNAME :REALLY-OPEN) (pathname characters error new-file)
  pathname
  "Use completing reader to find buffer name.  Never make a new file."
  (cond ((and new-file
	      (neq new-file :DEFAULT))
	 (if error
	     (ferror nil "can't handle :NEW-FILE keyword, use ED-BUFFER: instead"))
	 nil)
	(t
	 (multiple-value-bind (ignore alist) (complete-string (send self :name)
							      *ZMACS-BUFFER-NAME-ALIST*
							      '(#\SP #/- #/. #/\ #// #/#))
	   (cond ((null alist)
		  (if error
		      (ferror nil "not found"))
		  nil)
		 ((not (= 1 (length alist)))
		  (if error
		      (ferror nil "ambiguous name"))
		  nil)
		 (t
		  (interval-stream (cdar alist) nil nil (if characters nil :TYO) t)))))))

(defmethod (ED-FILE-PATHNAME :REALLY-OPEN) (pathname characters error new-file)
  pathname error new-file
  (let ((name (fs:parse-pathname (send self :name)))
	(*interval* nil))
    (interval-stream
      (or (find-buffer-named pathname)		; don't bash existing buffer!
	  (find-file name nil t
		     (when new-file t nil)))	; LOAD-P should be nil for new files
      nil
      nil
      (if characters nil :TYO)
      t)))

(defmethod (ED-BUFFER-PATHNAME :REALLY-OPEN) (pathname characters error new-file)
  pathname
  (let ((buffer (find-buffer-named (send self :name) (not (null new-file)))))
    (cond ((null buffer)
	   (if error
	       (ferror nil "ED-BUFFER: not found"))
	   nil)
	  (t
	   (interval-stream buffer nil nil (if characters nil :TYO) t)))))

(defvar zwei-host (make-instance 'zwei-host))
(defvar zwei-buffer-host (make-instance 'zwei-buffer-host))
(defvar zwei-file-host (make-instance 'zwei-file-host))

(defun add-zwei-hosts ()
  (or (memq zwei-host fs:*pathname-host-list*)
      (push zwei-host fs:*pathname-host-list*))
  (or (memq zwei-buffer-host fs:*pathname-host-list*)
      (push zwei-buffer-host fs:*pathname-host-list*))
  (or (memq zwei-file-host fs:*pathname-host-list*)
      (push zwei-file-host fs:*pathname-host-list*)))

(compile-flavor-methods zwei-host zwei-buffer-host zwei-file-host
			ed-pathname ed-buffer-pathname ed-file-pathname)

(add-initialization "Add ZWEI Hosts" '(add-zwei-hosts) '(:site))