Re: Enhancements for Corman 2.0 for ANSI compatibility

(in-package :lisp)

;;;; Author:  JP Massar.  03/09/03.

;;;; Included code:
;;;; -- FORMATTER (macro instead of function)
;;;; -- WITH-OPEN-STREAM (macro, new)
;;;; -- USER-HOMEDIR-PATHNAME (function, new)
;;;; -- STANDARD-CHAR-P (function, new)
;;;; -- SOFTWARE-TYPE, SOFTWARE-VERSION, SHORT-SITE-NAME, LONG-SITE-NAME,
;;;;    MACHINE-INSTANCE, MACHINE-TYPE, MACHINE-VERSION
;;;;    (functions, new)
;;;; -- PATHNAME-MATCH-P, WILD-PATHNAME-P (functions, new)
;;;; -- SUBLIS (function, patch)
;;;; -- NSUBLIS (function, new)
;;;; -- NAME-CHAR (function, new)
;;;; -- FILE-NAMESTRING, HOST-NAMESTRNG (functions, new)
;;;; -- COMPILE-FILE-PATHNAME (function, new)
;;;; -- FILE-AUTHOR (function, new)
;;;; -- LAMBDA-LIST-KEYWORDS (redefined as DEFCONSTANT)
;;;; -- INTERNAL-TIME-UNITS-PER-SECOND (redefined as DEFCONSTANT)
;;;; -- SHORT-FLOAT-EPSILON, SHORT-FLOAT-NEGATIVE-EPSILON
;;;;    SINGLE-FLOAT-EPSILON, SINGLE-FLOAT-NEGATIVE-EPSILON
;;;;    DOUBLE-FLOAT-EPSILON, DOUBLE-FLOAT-NEGATIVE-EPSILON
;;;;    LONG-FLOAT-EPSILON, LONG-FLOAT-NEGATIVE-EPSILON
;;;;    (constants, new)
;;;; -- LISP::PATHNAME= (internal function, redefined)
;;;;    EQUAL now works on pathnames with reimplementation of this
;;;;    function (used to be noop)

;;;;;;;;;;;;;;;;;;;

;;; Problem:  FORMATTER is not a macro.
;;; FORMATTER is intended to compile the format string at compile
;;; time, but it cannot do this if it is a function, unless the
;;; compiler itself special cases FORMATTER.  If it is a macro,
;;; a special format-string compiler could conceivably be called
;;; at macroexpand time.

;;; Corman doesn't have an explicit format-string compiler, so we
;;; just use the straightforward approach.

(defmacro formatter (string)
  `#'(lambda (*standard-output* &rest arguments)
      	(apply #'format-internal *standard-output* ,string arguments)))


;;; Problem:  WITH-OPEN-STREAM macro not implemented.

(defmacro with-open-stream ((var stream) &body body)
  (unless (symbolp var) 
    (error "WITH-OPEN-STREAM:  <VAR>, ~S, is not a symbol." var))
  `(let ((,var ,stream))
     (unwind-protect
	 (locally ,@body)
     (close ,var)
     )))


;;; Problem:  USER-HOMEDIR-PATHNAME not implemented.

;;; Solution:
;;; USER-HOMEDIR-PATHNAME never returns nil if host is not supplied. -- HS
;;; So... give it our best shot.

;;;  -- First provide a variable the user can set, which if non-nil
;;;     will be returned.
;;;  -- Otherwise see if C:/My Documents/ exists.  If so, use that.
;;;  -- Otherwise see if C:/ exists.  If so use that.
;;;  -- Otherwise use *DEFAULT-PATHNAME-DEFAULTS* to conjure up a path
;;;       if it is non-NIL.
;;;  -- Finally, use the Windows notion of the current directory as
;;;       as last resort.

(defun portable-directory-exists (dirstring)
  (block nil
    #+(OR :ALLEGRO :LISPWORKS)
    (return (probe-file dirstring))
    #+CORMANLISP
    (return (ccl:directory-p dirstring))
    (error "No implementation for PORTABLE-DIRECTORY-EXISTS")
    ))

(defun portable-current-directory ()
  (block nil
    #+:ALLEGRO
    (return (excl::current-directory))
    #+:CORMANLISP
    (return (ccl::get-current-directory))
    #+:LISPWORKS
    (return (win32::get-working-directory))
    (error "No implementation for PORTABLE-CURRENT-DIRECTORY")
    ))

(defparameter *user-homedir-path* nil
  "Intended to be set by a user's initialization file")

(defun user-homedir-pathname (&optional host)
  (cond 
   ;; If it is impossible to determine the user's home directory on host, 
   ;; then nil is returned. -- HS.  Corman doesn't deal with hosts, so...
   (host nil)
   (*user-homedir-path* (pathname *user-homedir-path*))
   ((and (portable-directory-exists "C:/My Documents/")
	 (pathname "C:/My Documents/")))
   ((and (portable-directory-exists "C:/") (pathname "C:/")))
   (*default-pathname-defaults*
    (let ((p *default-pathname-defaults*))
      (make-pathname
       :host (pathname-host p)
       :device (pathname-device p)
       :directory (pathname-directory p)
       :name nil :type nil :version nil
       )))
   (t (pathname (portable-current-directory)))
   ))

;;; Problem:  STANDARD-CHAR-P not implemented.

(defun standard-char-p (ch) (typep ch 'standard-char))

;;; Problem:  SOFTWARE-TYPE and SOFTWARE-VERSION not implemented.
;;; Problem:  SHORT-SITE-NAME and LONG-SITE-NAME not implemented.
;;; Problem:  MACHINE-INSTANCE, MACHINE-TYPE, MACHINE-VERSION not implemented.

(defun software-type () "Windows")
(defun software-version () nil)

(defun short-site-name () nil)
(defun long-site-name () nil)

(defun machine-instance () nil)
(defun machine-type () nil)
(defun machine-version () nil)

;;; Problem:  STREAM-EXTERNAL-FORMAT does not exist.
;;; This should really be contingent of the class FILE-STREAM
;;; which does not exist (but should). 
;;; For now, use this IS-FILE-STREAM function.

(defun is-file-stream (stream)
  (eq (cl::stream-subclass stream) 'file-stream))

(defun stream-external-format (stream)
  (unless (streamp stream) (error "Not a stream: ~A" stream))
  (unless (is-file-stream stream) 
    (error "Not a stream which is a FILE STREAM: ~A" stream))
  :default)


;;; Problem:  PATHNAME-MATCH-P and WILD-PATHNAME-P not implemented.
;;; The implementation here is simple, using only :wild
;;; (which Corman does not otherwise support), or "*" as wild matches
;;; for standard components, and one level of recursion on the CDR
;;; of the directory component.

;;; (Corman doesn't turn "*" into :wild when parsing pathname, it just
;;; leaves the "*" in place as if it were the actual component string.
;;; There's no way without using internal constructors to get ':wild'
;;; explicitly as a component of a pathname).

;;; Matching otherwise is case insensitive.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun pathname-accessor (slotname)
    (intern (concatenate 'string "PATHNAME-" (symbol-name slotname)) :lisp))
  (defun internal-pathname-accessor (slotname)
    (intern
     (concatenate 'string "PATHNAME-INTERNAL-" (symbol-name slotname))
     :pathnames)))

(defun simple-wild-component? (c)
  (or (eq :wild c) (and (stringp c) (string= c "*"))))

(defun wild-pathname-p (path &optional field-key)
  (setq path (pathname path))
  (macrolet ((testwild (slot)
	       (let ((accessor (pathname-accessor slot)))
		 `(simple-wild-component? (,accessor path)))))
    (ecase field-key
      (:host (testwild host))
      (:device (testwild device))
      (:name (testwild name))
      (:type (testwild type))
      (:version (testwild version))
      (:directory
       (or (testwild directory)
	   (let ((pathdir (pathname-directory path)))
	     (and (listp pathdir)
		  (some #'simple-wild-component? (cdr pathdir))))))
      (nil
       (some 
	#'(lambda (c) (wild-pathname-p path c))
	'(:host :device :directory :name :type :version)
	)))))

(defun pathname-match-p (path wild-path)
  (unless (pathnamep path) (setq path (pathname path)))
  (unless (pathnamep wild-path) (setq wild-path (pathname wild-path)))
  (setq wild-path (pathnames::copy-pathname-internal wild-path))
  (flet ((match-simple-component (x y)
	   (cond
	    ((simple-wild-component? y) t)
	    ((stringp y) (and (stringp x) (string-equal x y)))
	    (t nil)
	    )))
    (macrolet 
	((setwild (slot)
	   (let ((accessor (pathname-accessor slot))
		 (iaccessor (internal-pathname-accessor slot)))
	     `(when (or (null (,accessor wild-path))
			(eq :unspecific (,accessor wild-path)))
		(setf (,iaccessor wild-path) :wild))))
	 (matchslot (slot)
	   (let ((accessor (pathname-accessor slot)))
	     `(match-simple-component 
	       (,accessor path) (,accessor wild-path)))))
      ;; Missing components of wildcard default to :wild. -- HS
      (setwild host)
      (setwild device)
      (setwild directory)
      (setwild name)
      (setwild type)
      (setwild version)
      (let ((e1 "Bad path: DIRECTORY is not a list: ~A")
	    (e2 "Bad wild-path:  DIRECTORY is neither a list nor wild: ~A"))
	(and (matchslot host)
	     (matchslot device)
	     (matchslot name)
	     (matchslot type)
	     (matchslot version)
	     (let ((pdir (pathname-directory path))
		   (wdir (pathname-directory wild-path)))
	       (cond
		((simple-wild-component? wdir) t)
		((listp wdir)
		 (unless (listp pdir) (error e1 pdir))
		 (and (eq (first wdir) (first pdir))
		      (= (length wdir) (length pdir))
		      (every 
		       #'match-simple-component (rest pdir) (rest wdir))))
		(t (error e2 wdir))
		)))))))

#+TEST
(defun test-wild-paths ()
  (labels ((cmp (f form result)
	     (let ((actual (eval form)) (supposed result))
	       (unless (equalp actual supposed)
		 (format t "~%~% *** ~S OOPS!~%" f)
		 (format t "  FORM: ~S~%" form)
		 (format t "  ACTUAL RESULT: ~S~%" actual)
		 (format t "  EXPECTED RESULT: ~S~%" supposed)
		 (terpri)
		 )))
	   (cmpw (form result) 
	     (cmp 'wild-pathname-p `(wild-pathname-p ,form) result))
	   (cmpp (p1 p2 result) 
	     (cmp 'pathname-match-p `(pathname-match-p ,p1 ,p2) result)))
    (cmpw "foo.*" t)
    (cmpw "foo.bar" nil)
    (cmpw "*.lisp" t)
    (cmpw "C:/Lispcode/*.lisp" t)
    (cmpw "C:/Lispcode/foo.lisp" nil)
    (cmpw "C:/Lispcode/*/baz" t)
    (cmpw "C:/Lispcode/*/*.lisp" t)
    (cmpw "xyzzy/foo/" nil)
    (cmpw "xyzzy/foo/*/" t)
    (cmpw "*/*/*.*" t)
    (cmpw "C:/foo/bar/baz/xyzzy.plugh" nil)
    (cmpp "foo.bar" "foo.*" t)
    (cmpp "foo.bar" "*.bar" t)
    (cmpp "foo.bar" "*.*" t)
    (cmpp "*.bar" "*.*" t)
    (cmpp "*.*" "*.*" t)
    (cmpp "foo.bar" "fooz.*" nil)
    (cmpp "xyzzy.plugh" "xyzzy1.plugh" nil)
    (cmpp "C:/Lispcode/foo.lisp" "C:/Lispcode/*.lisp" t)
    (cmpp "C:/Lispcode/Corman/foo.lisp" "C:/Lispcode/*/*.lisp" t)
    (cmpp "C:/Lispcode/foo.lisp" "*.lisp" t)
    ))


;;; Problem:  NSUBLIS not implemented and SUBLIS doesn't work right.

(defun sublis (alist tree &key (key #'identity) (test #'eql) test-not)
  (let ((match (find (funcall key tree) alist 
		     :key #'car
		     :test test 
		     :test-not test-not)))
    (if match (cdr match)
      (if (not (consp tree)) tree
	(cons (sublis alist (car tree) 
		      :key key :test test :test-not test-not)
	      (sublis alist (cdr tree) 
		      :key key :test test :test-not test-not))))))


(defun nsublis (alist tree &key (key #'identity) (test #'eql) test-not)
  (let ((match 
	 (find (funcall key tree) alist
	       :key #'car :test test :test-not test-not)))
    (cond
     (match (cdr match))
     ((not (consp tree)) tree)
     (t
      (setf (car tree)
	(nsublis alist (car tree) :key key :test test :test-not test-not))
      (setf (cdr tree)
	(nsublis alist (cdr tree) :key key :test test :test-not test-not))
      tree
      ))))

#+TEST
(defun test-sublis ()
  (flet ((cmp (form result)
	   (let ((actual (eval form)) (supposed result))
	     (unless (equalp actual supposed)
	       (format t "~%~% *** SUBLIS OOPS!~%")
	       (format t "  FORM: ~S~%" form)
	       (format t "  ACTUAL RESULT: ~S~%" actual)
	       (format t "  EXPECTED RESULT: ~S~%" supposed)
	       (terpri)
	       ))))

    ;; Tests are taken from Hyperspec.

    (cmp
     '(sublis '((x . 100) (z . zprime))
       '(plus x (minus g z x p) 4 . x))
     '(PLUS 100 (MINUS G ZPRIME 100 P) 4 . 100))
    (cmp
     '(sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y)))
       '(* (/ (+ x y) (+ x p)) (- x y))
       :test #'equal)
     '(* (/ (- X Y) (+ X P)) (+ X Y)))
    (cmp 
     '(progn 
       (setq tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4)))))
       (sublis '((3 . "three")) tree1))
     '(1 (1 2) ((1 2 "three")) (((1 2 "three" 4)))))
    ;; This is the test that was failing with the old SUBLIS version
    (cmp
     '(sublis '((t . "string"))
       (sublis '((1 . "") (4 . 44)) tree1)
       :key #'stringp)
     '("string" ("string" 2) (("string" 2 3)) ((("string" 2 3 44)))))
    (cmp
     '(progn
       (setq tree2 '("one" ("one" "two") (("one" "Two" "three"))))
       (sublis '(("two" . 2)) tree2))
     '("one" ("one" "two") (("one" "Two" "three"))))
    (cmp
     '(sublis '(("two" . 2)) tree2 :test 'equal) 
     '("one" ("one" 2) (("one" "Two" "three"))))
    (cmp
     '(progn
       (setq tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4)))))
       (nsublis '((t . 'temp))
	tree1
	:key #'(lambda (x) (or (atom x) (< (list-length x) 3)))))
     '((QUOTE TEMP) (QUOTE TEMP) QUOTE TEMP))
    (cmp 
     'tree1
     '((QUOTE TEMP) (QUOTE TEMP) QUOTE TEMP))
    ))


;;; Problem:  NAME-CHAR not implemented.

(defmacro maptimes ((nvar count) &body body)
  (let ((result (gensym (concatenate 'string (string nvar) "-"))))
    `(let ((,result nil))
       (dotimes (,nvar ,count (nreverse ,result))
	 (push (progn ,@body) ,result)))))

(defparameter *name-char-mapping*
    (remove-if-not
     #'(lambda (x) (stringp (first x)))
     (maptimes (j 256) (cons (char-name (code-char j)) (code-char j)))))

(defun name-char (name)
  (cdr (assoc (string name) *name-char-mapping* :test #'string-equal)))


;;; Problem:  FILE-NAMESTRING, HOST-NAMESTRING not implemented.

(defun pathnames::convert-pathname-to-file-namestring (pathname)
  (let ((type (pathnames::pathname-internal-type pathname))
	(name (pathnames::pathname-internal-name pathname)))
    (format nil "~{~A~}~{.~A~}"
	    (if name (list name) nil)
	    (if type (list type) nil))))

(defun file-namestring (pathspec)
  (let ((pathname (pathname pathspec)))
    (pathnames::convert-pathname-to-file-namestring pathname)))

(defun host-namestring (pathspec) (and (pathname pathspec) nil))

;;; Problem:  COMPILE-FILE-PATHNAME not implemented.

(defun lisp::compile-file-pathname (source-filespec)
  (let ((source-pathname (pathname source-filespec)))
    (merge-pathnames #.(pathname ".fasl") source-pathname)
    ))


;;; PROBLEM:  FILE-AUTHOR not implemented.

(defun file-author (path) (and (pathname path) nil))


;;; PROBLEM:  LAMBDA-LIST-KEYWORDS and INTERNAL-TIME-UNITS-PER-SECOND
;;; are not constants.

(defconstant lambda-list-keywords
    '(&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ENVIRONMENT &ALLOW-OTHER-KEYS))

;;; Now, it seems like INTERNAL-TIME-UNITS-PER-SECOND needs to
;;; be computed at system initialization time.  So just defining it
;;; as a DEFCONSTANT to its current value on my machine would not seem
;;; to be at all the right thing.  We can use the internal mechanism
;;; DEFCONSTANT uses to make it a constant, but this has to be done
;;; under the assumption that the system is not later going to try to
;;; SETQ it.

(if (and (boundp 'internal-time-units-per-second)
	 (integerp internal-time-units-per-second))
    (lisp::symbol-set-constant-flag 'internal-time-units-per-second)
  (warn "STILL NEED TO MAKE INTERNAL-TIME-UNITS-PER-SECOND a constant"))


;;; Problem:  The FLOAT-EPSILON family of constants is not defined.
;;; Define the constants and try to insure that they satisfy the
;;; Hyperspec criteria.

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

  (defun epsilon-check (<EPSILON>)
    (not (= (float 1 <EPSILON>) (+ (float 1 <EPSILON>) <EPSILON>))))

  (defun negative-epsilon-check (<EPSILON>)
    (not (= (float 1 <EPSILON>) (- (float 1 <EPSILON>) <EPSILON>))))

  (defun verify-epsilon (x x-minus-delta check-function name)
    (unless (funcall check-function x)
      (warn ";; ***>> the value of ~S, ~S, ~A ~S function" 
	    name x "does not satisfy the" check-function))
    (unless (not (funcall check-function x-minus-delta))
      (warn ";; ***>> the value of ~S, ~S, ~A ~S function. ~A ~S ~A"
	    name x "is not the smallest value satisfying the" 
	    check-function "The value " x-minus-delta "sastisfies it also."
	    ))))
 
;;; These values are copied from Allegro 6.2; fortunately, they
;;; seem to work.

;;; The MINUS-DELTA values are experimental -- the next smaller
;;; float number I could find that was not = to the EPSILON number.
;;; In other words, e.g., (= 5.9604650e-8 5.9604649e-8) --> T.

(defconstant single-float-epsilon 5.9604650e-8)
(defconstant single-float-epsilon-minus-delta 5.9604648e-8)
(defconstant single-float-negative-epsilon 2.9802326e-8)
(defconstant single-float-negative-epsilon-minus-delta 2.9802324e-8)

(defconstant short-float-epsilon single-float-epsilon)
(defconstant short-float-negative-epsilon single-float-negative-epsilon)

(defconstant double-float-epsilon 1.1102230246251568d-16)
(defconstant double-float-epsilon-minus-delta 1.1102230246251566d-16)
(defconstant double-float-negative-epsilon 5.551115123125784d-17)
(defconstant double-float-negative-epsilon-minus-delta 5.551115123125783d-17)

(defconstant long-float-epsilon double-float-epsilon)
(defconstant long-float-negative-epsilon double-float-negative-epsilon)

(verify-epsilon 
 single-float-epsilon single-float-epsilon-minus-delta
 'epsilon-check 'single-float-epsilon)
(verify-epsilon
 single-float-negative-epsilon single-float-negative-epsilon-minus-delta
 'negative-epsilon-check 'single-float-negative-epsilon)
(verify-epsilon 
 double-float-epsilon double-float-epsilon-minus-delta
 'epsilon-check 'double-float-epsilon)
(verify-epsilon
 double-float-negative-epsilon double-float-negative-epsilon-minus-delta
 'negative-epsilon-check 'double-float-negative-epsilon)


;;; Problem:  EQUAL is supposed to work on pathnames, but it doesn't.
;;; The function PATHNAME= exists but does nothing.

;;; This is the obvious definition, but I can think of no reason offhand
;;; that it should not work.

(defun lisp::pathname= (p1 p2)
  (and (equalp (pathname-host p1) (pathname-host p2))
       (equalp (pathname-device p1) (pathname-device p2))
       (equalp (pathname-directory p1) (pathname-directory p2))
       (equalp (pathname-name p1) (pathname-name p2))
       (equalp (pathname-type p1) (pathname-type p2))
       (equalp (pathname-version p1) (pathname-version p2))
       ))