;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Spice Lisp interface to the Spice Environment Manager 
;;; 
;;; Written by Daniel Aronson
;;;
;;; **********************************************************************
(proclaim '(special data-port
		  *env-mgr-port*  ;port to send env. mgr. notices to.
		  *sesame-port*   
		  ))
(defconstant rc-success 101)      ; SUCCESS!
(defconstant rc-nosuchvariable 1601)
(defconstant rc-recursivevariable 1604)
(defvar env-mgr-reply-port)       ;reply port for messages
(defvar sesame-reply-port)

;;; FIND-PATH-NAME

;;; Find-path-name takes a name and sees if it is a legal path name
;;; when concatenated with the various items on the search list.

(defun find-path-name (path-name &optional
				 implicit-search-list first-only)
  (let ((s-name (if (not implicit-search-list) "default"
		   implicit-search-list))
	rc-code
	file-name)
    (do ((list (resolve-search-list s-name first-only) (cdr list)))
	((null list) (values 0 ""))
      (multiple-value-bind (rc-code file-name)
			   (sub-test-name (concatenate 'string
						       (car list)
						       path-name))
	(if (= rc-success rc-code) (return (values rc-code file-name)))))))




;;; GET-STRINGS-FROM-VECTOR

;;; Get-strings-from-vector takes a block of perq-strings and 
;;; converts them into a list of strings.

(defun get-strings-from-vector (u-vec bytes-per-string num)
  (if (zerop num) (error "There were 0 strings in the vector!!"))
  (do* ((base 0 (+ bytes-per-string base))
	(len (%primitive 8bit-system-ref u-vec base)
	     (%primitive 8bit-system-ref u-vec base))
	(str (make-string len) (make-string len))
	(res (list str) (cons str res))
	(cnt (1- num) (1- cnt)))
       (())
    (%sp-byte-blt u-vec (1+ base) str 0 len)
    (when (zerop cnt) (return (nreverse res)))))

;;; CREATE-SEARCH-LIST

;;; Create-search-list creates the alien structure SEARCH-LIST which
;;; contains the search list of the current proccess.

(defun create-search-list (alien)
  (let ((count (from-resolve-search-list-variable-cnt
		alien))
	(bytes-per-item 256))
    (get-strings-from-vector
     (%sp-make-immediate-type
      (from-resolve-search-list-variable alien) 0)
     bytes-per-item
     count))))




;;; Resolve-search-list

;;; The global specials to-resolve-search-list and from-resolve-search-list
;;; hold the messages passed to and from the environment manager to get the 
;;; current search list


(defvar to-resolve-search-list)
(def-alien-structure to-resolve-search-list
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 298)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant env-mgr-reply-port)
  (msg-remote-port port 14 18 :constant *env-mgr-port*)
  (msg-id unsigned-integer 18 22 :constant 1603)
  (string-hack1 unsigned-integer 22 24 :constant 0)
  (string-hack2 unsigned-integer 24 26 :constant 12288)
  (string-hack3 unsigned-integer 26 28 :constant 12)
  (string-hack4 unsigned-integer 28 30 :constant 648)
  (string-hack5 unsigned-integer 30 34 :constant 1)
  (name perq-string 34 292 :default "default")
  (boolean-hack1 unsigned-integer 292 294 :constant 256)
  (boolean-hack2 unsigned-integer 294 296 :constant 4097)
  (first-only (selection () t) 296 298 :default ())
  )

(defvar from-resolve-search-list)
(def-alien-structure from-resolve-search-list
  (msg-size unsigned-integer 2 6 :constant 50)
  (msg-local-port port 10 14 :constant env-mgr-reply-port)
  (rc unsigned-integer 26 28 :direction read)
  (variable-cnt unsigned-integer 36 40 :direction read)
  (variable unsigned-integer 40 44 :direction read)
  (worthless-stuff string 44 50 :direction read)
)


;;; Resolve-search-list takes the name of the search list to resolve (S-NAME),
;;; FIRST-ONLY (if true caller only want first item).  The function 
;;; CREATE-SEARCH-LIST is called which creates the alien structure
;;; (the actual search list)

(defun resolve-search-list (s-name first-only)
  (setf (to-resolve-search-list-name to-resolve-search-list) s-name)
  (setf (to-resolve-search-list-first-only to-resolve-search-list)
	first-only)
  (simple-send to-resolve-search-list)
  (simple-receive from-resolve-search-list)
  (let ((rc (from-resolve-search-list-rc from-resolve-search-list)))
    (cond ((=  rc rc-success))
	  ((= rc rc-nosuchvariable)
	   (error "Environment variable ~a does not exist." s-name))
	  ((= rc rc-recursivevariable)
	   (error "~a is recursively defined." s-name))
	  (t (error "Unknown error.  Rc = ~a" rc))))
  (create-search-list from-resolve-search-list)
  )

;;; SUB-TEST-NAME

(Defvar to-sub-test-name)
(def-alien-structure to-sub-test-name
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 290)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sesame-reply-port)
  (msg-remote-port port 14 18 :constant *sesame-port*)
  (msg-id unsigned-integer 18 22 :constant 1206)
  (string-hack1 unsigned-integer 22 24 :constant 0)
  (string-hack2 unsigned-integer 24 26 :constant 12288)
  (string-hack3 unsigned-integer 26 28 :constant 12)
  (string-hack4 unsigned-integer 28 30 :constant 2048)
  (string-hack5 unsigned-integer 30 34 :constant 1)
  (name perq-string 34 290)
  )


(defvar from-sub-test-name)
(def-alien-structure from-sub-test-name
  (msg-size unsigned-integer 2 6 :constant 308)
  (msg-local-port port 10 14 :constant sesame-reply-port)
  (rc unsigned-integer 26 28 :direction read)
  (name perq-string 40 296 :direction read)
  (entry-type unsigned-integer 298 300 :direction read)
  (name-status unsigned-integer 304 308 :direction read)
)

;;; Sub-test-name tests to see if a file exists.  NAME is the 
;;; pathname of the file.  
;;; Returns:
;;;   RC - the return code.
;;;   NAME- The full path name.

(defun sub-test-name (name)
  (setf (to-sub-test-name-name to-sub-test-name) name)
  (simple-send to-sub-test-name)
  (simple-receive from-sub-test-name)
  (values (from-sub-test-name-rc from-sub-test-name)
	  (from-sub-test-name-name from-sub-test-name)))

;;; ENV-MGR-INIT

;;; Initialize various environment manager variables.

(defun env-mgr-init ()
  (setq env-mgr-reply-port (allocate-port 0))
  (setq to-resolve-search-list (make-to-resolve-search-list))
  (setq from-resolve-search-list (make-from-resolve-search-list))
  (setq to-sub-test-name (make-to-sub-test-name))
  (setq from-sub-test-name (make-from-sub-test-name))
  )