Bumped version, cleaned up a bit (some renaming here and there to be more consistent)

;;;                 suppress compiler warnings in CMU CL.

;;; 17-MAR-95 mk    Added conditionalizations to avoid certain CMU CL compiler

;;;                 warnings reported by lmh.

;;; 19990610  ma    Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed.

;;; 19991211  ma    NEW VERSION 4.0 started.

;;; 19991211  ma    Merged in changes requested by T. Russ of

;;; 1999-06-10 ma   Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed.

;;;

;;; 1999-12-11 ma   NEW VERSION 4.0 started.

;;; 1999-12-11 ma   Merged in changes requested by T. Russ of

;;;                 ISI. Please refer to the special "ISI" comments to

;;;                 understand these changes

;;; 20000228 ma     The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM,

;;; 2000-02-28 ma   The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM,

;;;                 COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer

;;;                 imported in the COMMON-LISP-USER package.

;;;                 Cfr. the definitions of *EXPORTS* and

;;;                 case-sensitive images

;;; 2024-06-28 ma   Bullet bitten: clean up all the REQUIRE/PROVIDE

;;;                 cruft and brought (mostly) up to speed to 2024 CL

;;;                 implementations.

;;;                 implementations.  Note that the version is 3.9.2

;;;                 and not 4.0 as in the note above.

;;;---------------------------------------------------------------------------

;;; ISI Comments

;;;

;;; 19991211 Marco Antoniotti

;;; 1999-12-11 Marco Antoniotti

;;; These comments come from the "ISI Branch".  I believe I did

;;; include the :load-always extension correctly.  The other comments

;;; seem superseded by other changes made to the system in the

;;;

;;;    MK:DEFSYSTEM has been tested (succesfully) in the following CL

;;;    implementations:

;;;       Lispworks 8.0.1 (2024)

;;;       SBCL 2.2.9 (2024)

;;;       Allegro CL 11.0 (2024)

;;;       Clozure Common Lisp 1.12.2 (2024)

;;;    

;;;

;;;    DEFSYSTEM has been previously tested (successfully) in the

;;;       ECL 24.5.10 (2024)

;;;       Lispworks 8.0.1 (2024)

;;;       SBCL 2.2.9 (2024)

;;;    DEFSYSTEM had been previously tested (successfully) in the

;;;    following Common Lisp's:

;;;       CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)

;;;       CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach)

;;; Common Lisp Code

;;; ----------------

;;; Defsystem Version

;;; -----------------

(eval-when (:compile-toplevel :load-toplevel :execute) ; Sorry LUCID!

  (defparameter *defsystem-version* "3.9.2 (Cleaner Shinier), 2024-06-30."

    "Current version number/date for MK:DEFSYSTEM.")

  #+(or :unix :linux :dos :msdos :windows :mswindows :w32 :win32 :vms)

  (format t "~&;;; MK: loading MK-DEFSYSTEM ~A.~%"

	  *defsystem-version*)

  #-(or :unix :linux :dos :msdos :windows :mswindows :w32 :win32 :vms)

  (warn "~&;;; MK: loading MK-DEFSYSTEM ~A on a not-so-supported platform.~%"

	*defsystem-version*)

  )

;;; Massage CLtL2 onto *features*

;;; -----------------------------

;;;

;;; Let's be smart about CLtL2 compatible Lisps:

(eval-when (:compile-toplevel :load-toplevel :execute)

  (pushnew :cltl2 *features*))

(eval-when (:compile-toplevel :load-toplevel :execute) ; Sorry LUCID!

  ;; This ANSI EVAL-WHEN is already a show stopper for older CLs.

  ;; You can downgrade, but it would break other things.

  (pushnew :cltl2 *features*)

  )

;;; Set up the MAKE Package

(in-package "MAKE")

;;; Compatibility

;;; =============

;;;

;;; Notes:

;;; 2024-06-30 MA: added warning valid at this date.

;;; Some compatibility issues.  Mostly for CormanLisp.

;;; 2002-02-20 Marco Antoniotti

  (pushnew :pcl *features*))

;;; Defsystem Version

;;; -----------------

(defparameter *defsystem-version* "3.9.2 (Cleaner Shinier), 2024-06-28."

  "Current version number/date for MK:DEFSYSTEM.")

;;; Customizable System Parameters

;;; ------------------------------

(defvar *filename-extensions*

  #-:allegro (cons "lisp" (pathname-type (compile-file-pathname "foo.lisp")))

  #+:allegro (cons "cl" (pathname-type (compile-file-pathname "foo.lisp")))

  #-:allegro

  (cons "lisp" (pathname-type (compile-file-pathname "foo.lisp")))

  #+:allegro

  (cons "cl" (pathname-type (compile-file-pathname "foo.lisp")))

  "Filename extensions for Common Lisp.

A cons of the form (Source-Extension . Binary-Extension). If the

Notes:

Most of the functionality of this variable is superseded by COMPILE-FILE-PATHANME.

Most of the functionality of this variable is superseded by

COMPILE-FILE-PATHANME.

")

  *filename-extensions*)

(defun set-default-source-extension (source-extesion)

(defun set-default-source-extension (source-extension)

  "Set the default source extension.

Useful for initialization purposes."

;;; AFS @sys imitator

;;; -----------------

;;; 2024-06-28 MA: all of this may probably disappear without problems.

;;; 2024-06-28 MA: all of this, up to "END AFS",  may probably

;;; disappear without problems.

;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.

(defun compiler-version ()

  #+:lispworks

  (concatenate 'string

	       "lispworks" " " (lisp-implementation-version))

	       "Lispworks" " " (lisp-implementation-version))

  #+excl

  (concatenate 'string

	       "excl" " " excl::*common-lisp-version-number*)

	       "Allegro" " " excl::*common-lisp-version-number*)

  #+sbcl

  (concatenate 'string

	       "sbcl" " " (lisp-implementation-version))

	       "SBCL" " " (lisp-implementation-version))

  #+cmu

  (concatenate 'string

	       "cmu" " " (lisp-implementation-version))

	       "CMUCL" " " (lisp-implementation-version))

  #+scl

  (concatenate 'string

	       "scl" " " (lisp-implementation-version))

  #+kcl       "kcl"

  #+IBCL      "ibcl"

  #+akcl      "akcl"

  #+gcl       "gcl"

  #+ecl       "ecl"

  #+lucid     "lucid"

  #+ACLPC     "aclpc"

  #+CLISP     "clisp"

  #+Xerox     "xerox"

  #+symbolics "symbolics"

  #+mcl       "mcl"

  #+ccl       "ccl"

  #+coral     "coral"

  #+gclisp    "gclisp"

  #+(or abcl armedbear)      "abcl"

	       "SCL" " " (lisp-implementation-version))

  #+kcl       "KCL"

  #+IBCL      "IBCL"

  #+akcl      "AKCL"

  #+gcl       "GCL"

  #+ecl       "ECL"

  #+lucid     "Lucid"

  #+ACLPC     "ACLPC"

  #+CLISP     "CLISP"

  #+Xerox     "XEROX"

  #+symbolics "Symbolics"

  #+mcl       "MCL"

  #+ccl       "CCL"

  #+coral     "Coral"

  #+gclisp    "Gclisp"

  #+(or abcl armedbear)      "ABCL"

  )

(defun compiler-type-translation (name &optional translation)

  (if operation

  (if name

      (setf (gethash (string-upcase name) *compiler-type-hash-table*) translation)

      (gethash (string-upcase name) *compiler-type-hash-table*)))

(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")

(compiler-type-translation "lispworks 4.2.0"         "lispworks")

(compiler-type-translation "lispworks 8.0.0"         "lispworks")

(compiler-type-translation "lispworks 8.0.1"         "lispworks")

#+allegro

          root-directory

          (and version-flag (translate-version *version*))))

;;; END AFS

;;; System Names

;;; ------------

;;;       "[root.][subdir]BAZ"

;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2

;;; 2024-06-30 MA

;;; New code replacing NEW-APPEND-DIRECTORIES with

;;; STITCH-NAMES-AS-DIRECTORIES.

;;; *empty-pathname*

;;; A useful "placeolder"

(defvar *empty-pathname*

  (make-pathname :host nil

		 :device nil

		 :directory nil

		 :name nil

		 :type nil

		 :version nil))

;;; pathname-designator

(deftype pathname-designator ()

  '(or string pathname file-stream #| stream |#)

  ;; FILE-STREAM may be too strict, and STREAM is surely too wide.

  )

;;; pathname-as-directory

(defun pathname-as-directory (p)

  "Returns a pathname that is a 'directory' pathname.

UN*X and Windows people are used to treat pathnames at the string

(NAMESTRING) level.  This creates problems when people do not realize

that \"foo/bar.baz\" has a 'name' of \"bar\", a 'type' of \"baz\" and

a 'directory' of `(:RELATIVE \"foo\")`, which then breaks expectations

in a variety of cases.

This function takes a pathname P and ensures its transformation into a

'directory' pathname with :NAME and :TYPE set to NIL.  The example

above will return a pathname with :DIRECTORY

`(:RELATIVE \"foo\" \"bar.baz\")`; note how the last directory

component name is constructed, which may wreck havoc on older file

systems like VMS."

  (declare (type pathname p))

  (flet ((quote-filename-as-dirname (nd)

	   (declare (type pathname nd))

	   #+(or :unix :linux :windows :mswindows :win32 :msdos :dos)

	   nd

	   #+(or :vms)			; Ok: we may not have VMS

					; laying around, and yet...

	   (concatenate 'string

			(pathname-name nd)

			"^."		; Quote the dot.

			(pathname-type nd))

	   #-(or :vms :unix :linux :windows :mswindows :win32 :msdos :dos)

	   (progn			; Let'pray, but

					; warn...

	     (warn "MK: using ~S as a directory name on a rare platform."

		   nd)

	     nd)

	   )

	 )

    (let* ((pd (pathname-directory p))

	   (pn (pathname-name p))

	   (pt (pathname-type p))

	   (nd (cond ((and pn pt)

		      (namestring

		       (quote-filename-as-dirname

			(make-pathname

			 :name pn

			 :type pt

			 :defaults *empty-pathname*))))

		     (pn pn)

		     (pt

		      (namestring

		       (quote-filename-as-dirname

			(make-pathname

			 :type pt

			 :defaults *empty-pathname*))))

		     (t ())

		     ))

	   (dir (cond ((and pd nd) (append pd (list nd)))

		      (pd pd)

		      (nd (list :relative nd))

		      (t nil)))

	   )

      (make-pathname

       :directory dir

       :name nil

       :type nil

       :defaults p))

    ))

;;; relativize-pathname

;;; Transform a pathname into a relative one (if it has a non null

;;; directory component)

(defun relativize-pathname (p)

  (declare (type pathname p))

  (let ((pd (pathname-directory p)))

    (cond ((null pd) (merge-pathnames *empty-pathname* p))

	  ((eq :relative (first pd))

	   (merge-pathnames *empty-pathname* p)) ; Copy the pathname.

	  ((eq :absolute (first pd))

	   (make-pathname :directory (list* :relative (rest pd))

			  :defaults p)

	   )

	  (t (error "MK: cannot handle pathname directory ~S."

		    pd))

	  )

    ))

;;; stitch-names-as-directories

(defun stitch-names-as-directories (d1 d2)

  ;; Version of NEW-APPEND-DIRECTORIES which should work in 2024 for

  ;; "modern" CLs.

  (declare (type (or null pathname-designator) d1 d2))

  (flet ((normalize-name (n)

	   (etypecase n

	     (null (pathname ""))

	     (string (pathname n))

	     (pathname n)

	     (file-stream (pathname n))

	     ))

	 )

    (let* ((nd1 (normalize-name d1))

	   (nd2 (normalize-name d2))

	   (nd1-as-dir (pathname-as-directory nd1))

	   (nd2-as-relative (relativize-pathname nd2))

	   )

      (declare (type pathname nd1 nd2 nd1-as-dir nd2-as-relative))

      (merge-pathnames nd2-as-relative nd1-as-dir)

      )

    ))

;;; Pre 2024-06-30 code.

(defun directory-to-list (directory)

  ;; The directory should be a list, but nonstandard implementations have

  ;; been known to use a vector or even a string.

				  :name relative-directory))

       ;; Cross your fingers and pray.

       #-(or :VMS :macl1.3.2)

       (new-append-directories absolute-directory relative-directory)

       ;; (new-append-directories absolute-directory relative-directory)

       (stitch-names-as-directories absolute-directory relative-directory)

       ))))

		   (pathname-version relative-dir))))))

|#

;;; Determines if string or pathname object is logical

;;; Determines if string or pathname object is logical.

#+:logical-pathnames-mk

(defun logical-pathname-p (thing)

  (eq (lp:pathname-host-type thing) :logical))

;;; From Kevin Layer for 4.1final.

#+(and (and allegro-version>= (version>= 4 1))

       (not :logical-pathnames-mk))

#+(and nil				; Useless in 2024.

       (and allegro-version>= (version>= 4 1))

       (not :logical-pathnames-mk)

       )

(defun logical-pathname-p (thing)

  (typep (parse-namestring thing) 'logical-pathname))

;;; This should work on Allegro of 2024...

(defun pathname-logical-p (thing)

  (typecase thing

    (logical-pathname t)

    #+clisp ; CLisp has non conformant Logical Pathnames.

    (pathname (pathname-logical-p (namestring thing)))

    (string (and (= 1 (count #\: thing)) ; Shortcut.

		 (ignore-errors (translate-logical-pathname thing))

		 t))

    (t nil)))

    (string (ignore-errors

	     (not (null (translate-logical-pathname thing)))))

    (t nil))

  )

#||

;;; Add other types of systems...

;;; Lispworks Defsystem

;;; -------------------

;;; Allegro Defsystem

;;; -----------------

;;; KMP Defsystem

;;; -----------------

;;; Components' load time

;;; ---------------------