;;;; Implementation of various ANSI bits missing from Corman Lisp - Version 1.1
;;;;
;;;; Copyright (C) 2004 Espen Wiborg. All Rights Reserved.
;;;;
;;;; License
;;;; =======
;;;; This software is provided 'as-is', without any express or implied
;;;; warranty. In no event will the author be held liable for any damages
;;;; arising from the use of this software.
;;;;
;;;; Permission is granted to anyone to use this software for any purpose,
;;;; including commercial applications, and to alter it and redistribute
;;;; it freely, subject to the following restrictions:
;;;;
;;;; 1. The origin of this software must not be misrepresented; you must
;;;;    not claim that you wrote the original software. If you use this
;;;;    software in a product, an acknowledgment in the product documentation
;;;;    would be appreciated but is not required.
;;;;
;;;; 2. Altered source versions must be plainly marked as such, and must
;;;;    not be misrepresented as being the original software.
;;;;
;;;; 3. This notice may not be removed or altered from any source 
;;;;    distribution.
;;;;
(in-package :common-lisp)

(require 'winbase)

(defun get-standard-pprint-dispatch-table ()
  (xp::make-pprint-dispatch))

(defun get-standard-readtable ()
  *common-lisp-readtable*)

(export '(get-standard-pprint-dispatch-table get-standard-readtable)
        "COMMON-LISP")

;; Cop-out implementation
(defun machine-instance ()
  nil)

;;
;; Need these as well
;; Thanks to Andy Sloane <andy@guildsoftware.com>
(defun machine-version ()
  nil)

(defun machine-type ()
  nil)

(defun user-homedir-pathname (&optional host)
  (flet ((getenv (name)
           (let ((buffer (ct:malloc 1))
                 (cname (ct:lisp-string-to-c-string name)))
             (let* ((needed-size (win:getenvironmentvariable
                                  cname buffer 0))
                    (buffer1 (ct:malloc (1+ needed-size))))
               (prog1 (if (zerop (win:getenvironmentvariable
                                  cname buffer1 needed-size)) 
                          nil
                          (ct:c-string-to-lisp-string buffer1))
                 (ct:free buffer)
                 (ct:free buffer1))))))
    (cond ((or (stringp host)
               (and (consp host)
                    (every #'stringp host)))
           nil)
          ((or (eq host :unspecific)
               (null host))
           (let ((homedrive (getenv "HOMEDRIVE"))
                 (homepath (getenv "HOMEPATH")))
             (parse-namestring
              (if (and (stringp homedrive)
                       (stringp homepath)
                       (= (length homedrive) 2)
                       (> (length homepath) 0))
                  (concatenate 'string homedrive homepath)
                  "C:\\"))))
          (t
           (error "HOST must be a string, list of strings, NIL or :UNSPECIFIC")))))
  
(defun wild-pathname-p (pathname &optional field-key)
  (let ((obj (ecase field-key
               ((nil) (namestring pathname))
               ((:host) (pathname-host pathname))
               ((:device) (pathname-device pathname))
               ((:directory) (pathname-directory pathname))
               ((:name) (pathname-name pathname))
               ((:type) (pathname-type pathname))
               ((:version) (pathname-version pathname)))))
    (flet ((wild-p (sym) (or (eq sym :wild)
                             (eq sym :wild-inferiors))))
      (etypecase obj
        (symbol (wild-p obj))
        (list (position-if (lambda (o) (typecase o
                                         (symbol (wild-p o))
                                         (string (string= obj "*"))))
                           obj))
        (string (position #\* obj :test #'char=))))))

(provide "MISC-ANSI")