Commit 0046d995 authored by Gary Palter 's avatar Gary Palter

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

These changes require a large set of patches to Genera which are, presently, only
available in the world used by the Intel and ARM versions of Open Genera called
Portable Genera.  (If there's ever a new release of Genera, ...)
parent 4125c273
...@@ -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