Commit 24dd8bb9 authored by Robert Goldman's avatar Robert Goldman

Merge branch 'master' into 'master'

Minimal set of changes to allow ASDF to function on Genera.

See merge request !102
parents 4125c273 0046d995
...@@ -45,3 +45,14 @@ ...@@ -45,3 +45,14 @@
;;; The problem with writing a defsystem replacement is bootstrapping: ;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it. Hence, all in one file. ;;; we can't use defsystem to compile it. Hence, all in one file.
#+genera
(eval-when (:compile-toplevel :load-toplevel :execute)
(multiple-value-bind (system-major system-minor)
(sct:get-system-version)
(multiple-value-bind (is-major is-minor)
(sct:get-system-version "Intel-Support")
(unless (or (> system-major 452)
(and is-major
(or (> is-major 3)
(and (= is-major 3) (> is-minor 86)))))
(error "ASDF requires either System 453 or later or Intel Support 3.87 or later")))))
...@@ -71,7 +71,13 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -71,7 +71,13 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(or (ignore-errors (truename p)) (or (ignore-errors (truename p))
;; this is here because trying to find the truename of a directory pathname WITHOUT supplying ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
;; a trailing directory separator, causes an error on some lisps. ;; a trailing directory separator, causes an error on some lisps.
#+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))))))) #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))
;; On Genera, truename of a directory pathname will probably fail as Genera
;; will merge in a filename/type/version from *default-pathname-defaults* and
;; will try to get the truename of a file that probably doesn't exist.
#+genera (when (directory-pathname-p p)
(let ((d (scl:send p :directory-pathname-as-file)))
(ensure-directory-pathname (ignore-errors (truename d)) nil)))))))
(defun safe-file-write-date (pathname) (defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
......
...@@ -714,9 +714,10 @@ it will filter them appropriately." ...@@ -714,9 +714,10 @@ it will filter them appropriately."
(with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
(with-muffled-compiler-conditions () (with-muffled-compiler-conditions ()
(or #-(or clasp ecl mkcl) (or #-(or clasp ecl mkcl)
(apply 'compile-file input-file :output-file tmp-file (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
#+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) (apply 'compile-file input-file :output-file tmp-file
#-sbcl keywords) #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
#-sbcl keywords))
#+ecl (apply 'compile-file input-file :output-file #+ecl (apply 'compile-file input-file :output-file
(if object-file (if object-file
(list* object-file :system-p t keywords) (list* object-file :system-p t keywords)
...@@ -768,19 +769,20 @@ it will filter them appropriately." ...@@ -768,19 +769,20 @@ it will filter them appropriately."
(defun load* (x &rest keys &key &allow-other-keys) (defun load* (x &rest keys &key &allow-other-keys)
"Portable wrapper around LOAD that properly handles loading from a stream." "Portable wrapper around LOAD that properly handles loading from a stream."
(with-muffled-loader-conditions () (with-muffled-loader-conditions ()
(etypecase x (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) (etypecase x
(apply 'load x keys)) ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
;; Genera can't load from a string-input-stream (apply 'load x keys))
;; ClozureCL 1.6 can only load from file input stream ;; Genera can't load from a string-input-stream
;; Allegro 5, I don't remember but it must have been broken when I tested. ;; ClozureCL 1.6 can only load from file input stream
#+(or allegro clozure genera) ;; Allegro 5, I don't remember but it must have been broken when I tested.
(stream ;; make do this way #+(or allegro clozure genera)
(let ((*package* *package*) (stream ;; make do this way
(*readtable* *readtable*) (let ((*package* *package*)
(*load-pathname* nil) (*readtable* *readtable*)
(*load-truename* nil)) (*load-pathname* nil)
(eval-input x)))))) (*load-truename* nil))
(eval-input x)))))))
(defun load-from-string (string) (defun load-from-string (string)
"Portably read and evaluate forms from a STRING." "Portably read and evaluate forms from a STRING."
......
...@@ -91,8 +91,8 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ...@@ -91,8 +91,8 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
;; See CLHS make-pathname and 19.2.2.2.3. ;; See CLHS make-pathname and 19.2.2.2.3.
;; This will be :unspecific if supported, or NIL if not. ;; This will be :unspecific if supported, or NIL if not.
(defparameter *unspecific-pathname-type* (defparameter *unspecific-pathname-type*
#+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific
#+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
(defun make-pathname* (&rest keys &key directory host device name type version defaults (defun make-pathname* (&rest keys &key directory host device name type version defaults
...@@ -330,7 +330,14 @@ actually-existing directory." ...@@ -330,7 +330,14 @@ actually-existing directory."
(make-pathname :directory (append (or (normalize-pathname-directory-component (make-pathname :directory (append (or (normalize-pathname-directory-component
(pathname-directory pathspec)) (pathname-directory pathspec))
(list :relative)) (list :relative))
(list (file-namestring pathspec))) (list #-genera (file-namestring pathspec)
;; On Genera's native filesystem (LMFS),
;; directories have a type and version
;; which must be ignored when converting
;; to a directory pathname
#+genera (if (typep pathspec 'fs:lmfs-pathname)
(pathname-name pathspec)
(file-namestring pathspec))))
:name nil :type nil :version nil :defaults pathspec) :name nil :type nil :version nil :defaults pathspec)
(error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c))))))) (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment