;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/corman-asdf/patch.lisp,v 1.4 2004/05/06 10:59:48 edi Exp $

;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :win32)

(defun ccl::set-current-directory (dir) 
  (let ((ret (_chdir (namestring dir))))
    (if (= ret -1)
      (error "Could not set current directory to ~A" dir)
      (setq *default-pathname-defaults*
              (pl::get-current-directory)))))

(defun subdirectory-pathname (directory-pathname subdir-name &key (name nil) (type nil) (version nil))
  (let ((p1 (parse-namestring subdir-name)))
    (truename
     (make-pathname
      :host (pathname-host directory-pathname)
      :device (pathname-device directory-pathname)
      :directory 
      (append 
       (pathname-directory directory-pathname) 
       (list (if (pathname-type p1)
               (format nil "~A.~A" (pathname-name p1) (pathname-type p1))
               (pathname-name p1))))
      :name name
      :type type
      :version version))))

(in-package :pathnames)

(defun make-pathname-internal (&key 
                               (host (pathname-internal-host *default-pathname-defaults*) supplied-host)
                               (device nil supplied-device)
                               (directory nil supplied-directory)
                               (name nil supplied-name)
                               (type nil supplied-type)
                               (version :unspecific supplied-version)
                               (defaults nil)
                               (case :local))
  (declare (ignore case))
  (when defaults
    (setq defaults (pathname defaults))
    (unless supplied-host (setq host (pathname-internal-host defaults)))
    (unless supplied-device (setq device (pathname-internal-device defaults)))
    (unless supplied-directory (setq directory (pathname-internal-directory defaults)))
    (unless supplied-name (setq name (pathname-internal-name defaults)))
    (unless supplied-type (setq type (pathname-internal-type defaults)))
    (unless supplied-version (setq version (pathname-internal-version defaults))))
  (construct-pathname host device directory name type version))

(in-package :common-lisp)

(pushnew :broken-fasl-loader *features*)

(defmacro in-package (name)
  `(eval-when (:load-toplevel :compile-toplevel :execute)
     (let ((package (find-package ',name)))
       (cond (package
               (setq *package* package))
             (t
               (cerror "Create a new package named ~S."
                       (make-condition 'package-error
                                       :package ',name
                                       :format-control "Package ~S not found."
                                       :format-arguments (list ',name))
                       ',name)
               (setq *package* (make-package ',name)))))))

(defmacro define-modify-macro (name lambda-list function &optional documentation)
  (let* ((place (gensym))
         (rest-arg (second (member '&rest lambda-list :test #'eq)))
         (other-args (mapcar (lambda (arg)
                               (if (consp arg) (first arg) arg))
                             (remove '&optional
                                     (if rest-arg (butlast lambda-list 2) lambda-list)
                                     :test #'eq))))
    (flet ((fn-form (new-arg)
             (if rest-arg
               `(append (list 'funcall #',function ,new-arg ,@other-args) ,rest-arg)
               `(list 'funcall #',function ,new-arg ,@other-args))))
      `(defmacro ,name (,place ,@lambda-list &environment env)
         ,@(if documentation (list documentation))
         (multiple-value-bind (vars vals new setter getter)
             (get-setf-expansion ,place env)
           (declare (ignore setter))
           `(let* (,@(mapcar 'list vars vals) (,(car new) ,getter))
              (setf ,getter ,,(fn-form '(car new)))))))))

(in-package :cl-user)