Commit 284ff146 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.84: more portability with GCL, ECL, LispWorks

parent 602d43dc
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.83" ;; to be automatically updated by bin/bump-revision
:version "2.26.84" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
......@@ -277,7 +277,7 @@
nil)
(defmethod perform ((o load-fasl-op) (c system))
(if-bind (it (first (input-files o c))) (load it)))
(perform-lisp-load-fasl o c))
(defmethod mark-operation-done :after ((o load-fasl-op) (c system))
(mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components?
......@@ -299,8 +299,7 @@
(declare (ignorable o))
(component-pathname c))
(defmethod perform ((o load-op) (c compiled-file))
(declare (ignorable o))
(load (first (input-files o c))))
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-source-op) (c compiled-file))
(perform (find-operation o 'load-op) c))
(defmethod perform ((o load-fasl-op) (c compiled-file))
......
......@@ -54,7 +54,9 @@
(when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 lacks output-translations and more.
(and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 7)))
(format t "Detected an old GCL 2.6. Only limited functionality available.~%")
(shadow 'type-of :asdf/compatibility)
(export 'with-standard-io-syntax)
(pushnew 'ignorable pcl::*variable-declarations-without-argument*)
(pushnew :gcl<2.7 *features*))
(unless (member :ansi-cl *features*)
......@@ -81,6 +83,7 @@
#+gcl<2.7
(progn ;; Doesn't support either logical-pathnames or output-translations.
(defvar *gcl<2.7* t)
(deftype logical-pathname () nil)
(defun type-of (x) (class-name (class-of x)))
(defun wild-pathname-p (path) (declare (ignore path)) nil)
......@@ -94,6 +97,8 @@
(format stream "#<~@[~S ~]" (when type (type-of object)))
(funcall thunk)
(format stream "~@[ ~X~]>" (when identity (system:address object))))
(defmacro with-standard-io-syntax (&body body)
`(progn ,@body))
(defmacro with-compilation-unit (options &body body)
(declare (ignore options)) `(progn ,@body))
(defmacro print-unreadable-object ((object stream &key type identity) &body body)
......
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
(:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os
:asdf/upgrade :asdf/component :asdf/system)
:asdf/lisp-build :asdf/upgrade :asdf/component :asdf/system)
(:export
#:coerce-name #:find-system #:locate-system #:load-sysdef #:with-system-definitions
#:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
......@@ -251,7 +251,8 @@ Going forward, we recommend new users should be using the source-registry.
(external-format (encoding-external-format (detect-encoding pathname))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
pathname package)
(load pathname #-gcl<2.7 :external-format #-gcl<2.7 external-format)))
(with-controlled-loader-conditions ()
(load* pathname :external-format external-format))))
(delete-package package)))))
(defun* locate-system (name)
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.83: Another System Definition Facility.
;;; This is ASDF 2.26.84: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -158,8 +158,8 @@
(component-name c)))
(perform (find-operation o 'compile-op) c)))))
(defun* perform-lisp-load-fasl (o c)
(with-controlled-loader-conditions ()
(load (first (input-files o c)))))
(if-bind (fasl (first (input-files o c)))
(with-controlled-loader-conditions () (load* fasl))))
(defmethod perform ((o load-op) (c cl-source-file))
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
......
......@@ -145,13 +145,13 @@ or a string describing the format-control of a simple-condition."
(defun* call-with-controlled-compiler-conditions (thunk)
(call-with-muffled-uninteresting-conditions
thunk *uninteresting-compiler-conditions*))
(defmacro with-controlled-compiler-conditions (() &body body)
(defmacro with-controlled-compiler-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler conditions are muffled"
`(call-with-controlled-compiler-conditions #'(lambda () ,@body)))
(defun* call-with-controlled-loader-conditions (thunk)
(call-with-muffled-uninteresting-conditions
thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
(defmacro with-controlled-loader-conditions (() &body body)
(defmacro with-controlled-loader-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler and additional loader conditions are muffled"
`(call-with-muffled-uninteresting-conditions #'(lambda () ,@body)))
......@@ -261,10 +261,9 @@ for processing later (possibly in a different process)."
(remove-keys `(#+(and allegro (not (version>= 8 2))) :external-format
,@(unless output-file '(:output-file))) keys)))))
(defun* load* (x &rest keys &key external-format &allow-other-keys)
(declare (ignorable external-format))
(defun* load* (x &rest keys &key &allow-other-keys)
(etypecase x
((or pathname string #-(or gcl-pre2.7 clozure allegro) stream)
((or pathname string #-(or gcl<2.7 clozure allegro) stream)
(apply 'load x
#-gcl<2.7 keys #+gcl<2.7 (remove-keyword :external-format keys)))
#-(or gcl<2.7 clozure allegro)
......@@ -272,9 +271,10 @@ for processing later (possibly in a different process)."
;; ClozureCL 1.6 can only load from file input stream
;; Allegro 5, I don't remember but it must have been broken when I tested.
(stream ;; make do this way
(let ((*load-pathname* nil)
(*load-truename* nil)
#+clozure (ccl::*default-external-format* external-format))
(let ((*package* *package*)
(*readtable* *readtable*)
(*load-pathname* nil)
(*load-truename* nil))
(eval-input x)))))
(defun* load-from-string (string)
......@@ -293,8 +293,8 @@ for processing later (possibly in a different process)."
(#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys)
#+mkcl progn
(let ((object-file
(apply 'compile-file-pathname
output-file #+ecl :type #+ecl :object #+mkcl :fasl-p #+mkcl nil)))
(compile-file-pathname
output-file #+ecl :type #+ecl :object #+mkcl :fasl-p #+mkcl nil)))
(multiple-value-bind (result flags1 flags2)
(apply 'compile-file* input-file
#+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil
......
......@@ -14,7 +14,8 @@
#:implementation-type #:operating-system #:architecture #:lisp-version-string
#:hostname #:user-homedir #:lisp-implementation-directory
#:getcwd #:chdir #:call-with-current-directory #:with-current-directory
#:*temporary-directory* #:temporary-directory #:default-temporary-directory #:with-temporary-file))
#:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:call-with-temporary-file #:with-temporary-file))
(in-package :asdf/os)
;;; Features
......@@ -282,6 +283,7 @@ then returning the non-empty string value of the variable"
prefix keep (direction :io)
(element-type *default-stream-element-type*)
(external-format :default))
#+gcl<2.7 (declare (ignorable external-format))
(check-type direction (member :output :io))
(loop
:with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
......@@ -292,7 +294,8 @@ then returning the non-empty string value of the variable"
;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr.
(with-open-file (stream pathname
:direction direction
:element-type element-type :external-format external-format
:element-type element-type
#-gcl<2.7 :external-format #-gcl<2.7 external-format
:if-exists nil :if-does-not-exist :create)
(when stream
(return
......
......@@ -38,7 +38,7 @@ If optional ERROR argument is NIL, return NIL instead of an error
when the symbol is not found."
(block nil
(let ((package (find-package* package-designator error)))
(when package
(when package ;; package error handled by find-package* already
(multiple-value-bind (symbol status) (find-symbol (string name) package)
(cond
(status (return (values symbol status)))
......
......@@ -134,12 +134,14 @@ by /bin/sh in POSIX"
(defgeneric* slurp-input-stream (processor input-stream &key &allow-other-keys))
#-(or gcl<2.7 genera)
(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
(funcall function input-stream))
(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
(apply (first list) (cons input-stream (rest list))))
#-(or gcl<2.7 genera)
(defmethod slurp-input-stream ((output-stream stream) input-stream
&key (element-type 'character) &allow-other-keys)
(copy-stream-to-stream
......@@ -165,6 +167,18 @@ by /bin/sh in POSIX"
(declare (ignorable x))
(slurp-stream-forms stream))
(defmethod slurp-input-stream (x stream &key (element-type 'character) &allow-other-keys)
(declare (ignorable stream element-type))
(cond
#+(or gcl<2.7 genera)
((functionp x)
(funcall x stream))
#+(or gcl<2.7 genera)
((output-stream-p x)
(copy-stream-to-stream stream x :element-type element-type))
(t
(error "Invalid ~S destination ~S" 'slurp-input-stream x))))
;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
......@@ -261,8 +275,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
:output (if pipe :stream t)
. #.(append
#+(or clozure cmu ecl sbcl scl) '(:error t)
#+sbcl '(:search t
#|:external-format external-format ; not in old SBCLs|#)))))
;; note: :external-format requires a recent SBCL
#+sbcl '(:search t :external-format external-format)))))
(process
#+(or allegro lispworks) (if pipe (third process*) (first process*))
#+ecl (third process*)
......@@ -352,7 +366,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
:direction :input
:if-does-not-exist :error
:element-type element-type
:external-format external-format)
#-gcl<2.7 :external-format #-gcl<2.7 external-format)
(slurp-input-stream output stream)))
(call-system (system-command command) :interactive interactive)))))
(if (and (not force-shell)
......
......@@ -44,34 +44,24 @@
;;; Output to a stream or string, FORMAT-style
(defgeneric call-with-output (x thunk)
(:documentation
;; code from fare-utils base/streams where it's now named
;; call-with-output-stream to avoid the package clash in a lot of my code.
"Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
(defun* call-with-output (x thunk)
"Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
If OBJ is a stream, use it as the stream.
If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
If OBJ is T, use *STANDARD-OUTPUT* as the stream.
If OBJ is a string with a fill-pointer, use it as a string-output-stream.
Otherwise, signal an error.")
(:method ((x null) thunk)
(declare (ignorable x))
(with-output-to-string (s) (funcall thunk s)))
(:method ((x (eql t)) thunk)
(declare (ignorable x))
(funcall thunk *standard-output*) nil)
#-genera
(:method ((x stream) thunk)
(funcall thunk x) nil)
(:method ((x string) thunk)
(assert (fill-pointer x))
(with-output-to-string (s x) (funcall thunk s)))
(:method (x thunk)
(declare (ignorable thunk))
(cond
#+genera
((typep x 'stream) (funcall thunk x) nil)
(t (error "not a valid stream designator ~S" x)))))
Otherwise, signal an error."
(typecase x
(null
(with-output-to-string (s) (funcall thunk s)))
((eql t)
(funcall thunk *standard-output*))
(stream
(funcall thunk x))
(string
(assert (fill-pointer x))
(with-output-to-string (s x) (funcall thunk s)))
(t (error "not a valid stream designator ~S" x))))
(defmacro with-output ((x &optional (value x)) &body body)
"Bind X to an output stream, coercing VALUE (default: previous binding of X)
......@@ -112,8 +102,10 @@ Otherwise, signal an error."
&key (element-type *default-stream-element-type*)
(external-format :default))
"Open FILE for input with given options, call THUNK with the resulting stream."
#+gcl<2.7 (declare (ignore external-format))
(with-open-file (s pathname :direction :input
:element-type element-type :external-format external-format
:element-type element-type
#-gcl<2.7 :external-format #-gcl<2.7 external-format
:if-does-not-exist :error)
(funcall thunk s)))
......
......@@ -49,7 +49,9 @@
(*print-pretty* nil)
(start-time 0))
(with-open-file (result-stream (asdf::merge-pathnames* "output.txt" root)
(with-open-file (result-stream (asdf::subpathname
*build-directory*
(format nil "results/~(~A~)-pathnames.txt" *implementation*))
:direction :output
:if-exists :supersede :if-does-not-exist :create)
(flet ((src-dir (&rest path) (append (or (pathname-directory root) (list :relative))
......@@ -122,7 +124,7 @@
:defaults root)
,(make-pathname :directory (src-dir "system2" "module4") :name "file" :type "lisp"
:defaults root)
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp"
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp" :version nil
:defaults root)
,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
,@(when support-string-pathnames
......@@ -221,9 +223,7 @@
((error (lambda (c)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
#+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace)
(asdf::print-condition-backtrace c :stream *error-output*)
(format result-stream "~&~%***~%error: ~a~%~s"
c system-definition)
(return-from :test-system))))
......
......@@ -288,6 +288,9 @@ clean_up () {
rm -rf ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d
}
test_clean_load () {
case $lisp in
gcl) return 0 ;; # GCL 2.6 is hopeless
esac
nop=build/results/${lisp}-nop.text
load=build/results/${lisp}-load.text
${command} ${eval} \
......
......@@ -31,7 +31,7 @@ Some constraints:
#+(or cmu scl) (c::brevity 2)))
(defvar *trace-symbols*
'(;; If you want to trace some stuff while debugging ASDF,
`(;; If you want to trace some stuff while debugging ASDF,
;; here's a nice place to say what.
;; These string designators will be interned in ASDF after it is loaded.
))
......@@ -57,7 +57,10 @@ Some constraints:
;;; Survival utilities
(defun asym (name)
(find-symbol (string name) :asdf))
(let ((asdf (find-package :asdf)))
(unless asdf (error "Can't find package ASDF"))
(or (find-symbol (string name) asdf)
(error "Can't find symbol ~A in ASDF" name))))
(defun acall (name &rest args)
(apply (asym name) args))
......@@ -98,7 +101,7 @@ Some constraints:
#+cmu :cmucl
#+corman :cormanlisp
#+digitool :mcl
#+ecl :ecl
#+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl)
#+gcl :gcl
#+lispworks :lispworks
#+mkcl :mkcl
......@@ -181,7 +184,7 @@ Some constraints:
(finish-outputs)
(throw :asdf-test-done return))
(defmacro with-test (() &body body)
(defmacro with-test ((&optional) &body body)
`(call-with-test (lambda () ,@body)))
(defun call-with-test (thunk)
......
#|
make sure that serial t and static-files don't cause full rebuilds all
the time...
|#
(defsystem static-and-serial
:version "0.1"
:serial t
:components
((:static-file "file2.lisp")
(:static-file "run-tests.sh")
(:file "file1")))
......@@ -43,6 +43,9 @@
(defsystem :test-encoding-explicit-u8
:components ((:file "lambda" :encoding :utf-8))))
#-asdf-unicode
(leave-test "No Unicode support to test on this lisp implementation" 0)
;; NB: recent clozure can autodetect without asdf-encodings with :default (!)
#+(and asdf-unicode sbcl)
......
;;; -*- Lisp -*-
#|
make sure that serial t and static-files
don't cause full rebuilds all the time...
|#
(load "script-support.lisp")
(load-asdf)
(in-package :asdf-test)
#+gcl (trace coerce-pathname)
(with-test ()
(format t "dpd: ~S~%f1: ~S~%" *default-pathname-defaults* (asdf::merge-pathnames* "file1"))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(load-test-system 'static-and-serial)
(asdf:operate 'asdf:load-op 'static-and-serial)
(let* ((file1 (asdf:compile-file-pathname* "file1.lisp"))
(file1-date (file-write-date file1))
(date1 (- file1-date 600))
......@@ -22,9 +22,10 @@
(format t "file: ~S~%date: ~S~%" file1 file1-date)
;; date should stay same
(asdf:clear-system 'static-and-serial)
(clear-system 'static-and-serial)
(touch-file "static-and-serial.asd" :offset -10000)
(touch-file "file2.lisp" :timestamp date1)
(touch-file "file1.lisp" :timestamp date2)
(touch-file file1 :timestamp date3)
(asdf:operate 'asdf:load-op 'static-and-serial)
(assert (equal (file-write-date file1) date3))))
(DBG "load again" (oos 'load-op 'static-and-serial))
(assert-equal (file-write-date file1) date3)))
......@@ -6,4 +6,5 @@
(asdf:defsystem :wild-module
:version "0.0"
:components ((:wild-module "systems" :pathname #p"*.asd")))
#-gcl<2.7
(load-system :wild-module))
......@@ -32,7 +32,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.83")
(asdf-version "2.26.84")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......
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