...
 
Commits (68)
......@@ -79,7 +79,7 @@ SCL ?= scl
XCL ?= xcl
header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/eval.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
......
This diff is collapsed.
......@@ -87,18 +87,8 @@
(defmethod perform ((o define-op) (s system))
(nest
(if-let ((pathname (first (input-files o s)))))
(let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control
(print-pprint-dispatch *print-pprint-dispatch*)))
(with-standard-io-syntax)
(let ((*print-readably* nil)
;; Note that our backward-compatible *readtable* is
;; a global readtable that gets globally side-effected. Ouch.
;; Same for the *print-pprint-dispatch* table.
;; We should do something about that for ASDF3 if possible, or else ASDF4.
(*readtable* readtable) ;; restore inside syntax table
(*print-pprint-dispatch* print-pprint-dispatch)
(*package* (find-package :asdf-user))
(*default-pathname-defaults*
(with-shared-syntax (:package :asdf-user))
(let ((*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (physicalize-pathname pathname)))))
(handler-bind
......
......@@ -4,7 +4,7 @@
set here=%~dp0
set header_lisp=header.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\eval.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + forcing.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp
%~d0
......
......@@ -5,7 +5,7 @@
here="$(dirname $0)"
header_lisp="header.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/eval.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp"
all () {
......
......@@ -83,6 +83,7 @@ But do NOT depend on it, for this is deprecated behavior."))
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure)))
(with-shared-syntax (:package :asdf-user))
(unwind-protect
(progn
(incf (operate-level))
......
......@@ -46,8 +46,9 @@ every such file"))
;; Find the first defpackage form in a stream, if any
(defun stream-defpackage-form (stream)
(loop :for form = (read stream nil nil) :while form
:when (defpackage-form-p form) :return form))
(with-shared-syntax (:package :asdf-user)
(loop :for form = (read stream nil nil) :while form
:when (defpackage-form-p form) :return form)))
(defun file-defpackage-form (file)
"Return the first DEFPACKAGE form in FILE."
......
(defsystem "test-quasiquote" :components ((:file "test-quasiquote")))
(in-package :cl-user)
(defparameter *quine*
'((LAMBDA (X) (LIST X `',X)) '(LAMBDA (X) (LIST X `',X))))
;; Interestingly, at least on SBCL, this assertion does not hold:
#-(or sbcl) (assert (equal *quine* (eval *quine*)))
(assert (equal (write-to-string *quine*)
(write-to-string (eval *quine*))))
(assert (equal (eval *quine*)
(eval (eval *quine*))))
......@@ -2,7 +2,7 @@
(load-system "test-asdf/test-module-depend"))
(defparameter *plan* (make-plan () 'load-op "test-asdf/test-module-depend"))
(DBG :foo *plan*
(DBG :foo (asdf::plan-actions *plan*)
(component-depends-on 'compile-op '("test-asdf/test-module-depend" "quux" "file3mod" "file3"))
(asdf::component-if-feature (find-component "test-asdf/test-module-depend" '("quux" "file3mod" "file3"))))
......
;;-*- Lisp -*-
;; Testing that ASDF builds with a controlled syntax
;; when invoked with readtable different from the initial/shared readtable.
(in-package :asdf-test)
#+(or cmucl mkcl)
(leave-test "CMUCL and MKCL have trouble with named-readtables." 0)
;; Simple stuff
(setf *central-registry* (list (subpathname *test-directory* "syntax-control/")))
;; Try to load lisp-invocation from ext/ or from the user environment.
(initialize-source-registry
`(:source-registry
(:directory ,*asdf-directory*)
(:directory (,*asdf-directory* "uiop/"))
(:tree (,*asdf-directory* "ext/"))
:inherit-configuration))
(DBG "Run test-quasiquote. Should be using the system's quasiquote.")
(asdf:load-system :test-quasiquote :force t)
(DBG "Run test-quasiquote. Should STILL be using the system's quasiquote.")
(load-system :fare-quasiquote-readtable)
(named-readtables:in-readtable :fare-quasiquote)
(asdf:load-system :test-quasiquote :force t)
(DBG "Run the previously compiled test-quasiquote. If it used fare-quasiquote, it will fail.")
(asdf::clear-registered-systems)
(delete-package :fare-quasiquote)
(asdf:load-system :test-quasiquote)
......@@ -11,7 +11,7 @@
;; or :use (closer-common-lisp uiop), etc.
(:use-reexport
:uiop/package :uiop/utility :uiop/version
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/eval :uiop/image
:uiop/launch-program :uiop/run-program
:uiop/lisp-build :uiop/configuration :uiop/backward-driver))
......
;;;; -------------------------------------------------------------------------
;;;; Lisp Evaluation
(uiop/package:define-package :uiop/eval
(:recycle :uiop/eval :asdf)
(:use :uiop/common-lisp :uiop/utility :uiop/stream)
(:export
#:*initial-readtable* #:*initial-print-pprint-dispatch*
#:*standard-readtable* #:*standard-print-pprint-dispatch*
#:*shared-readtable* #:*shared-print-pprint-dispatch*
#:*standard-syntax-variables*
#:call-with-shared-syntax #:with-shared-syntax
#:eval-input #:eval-thunk #:shared-eval-thunk))
(in-package :uiop/eval)
;;; Safe syntax
(with-upgradability ()
(defvar *initial-readtable* *readtable*
"The initial readtable, as inherited from the environment at the time UIOP was first loaded.
It initially implements the syntax specified by the CLHS, but may also have implementation-specific
extensions, and may grow user-defined extensions. You MUST ONLY make conservative extensions to it:
A- No one may at any point modify any standard character in any way.
B- No two dependencies may assign different meaning to the same non-standard character.
Using any non-standard character while expecting the implementation to treat some way
counts as such an assignment of meaning (e.g. using CCL's #$ syntax for FFI).
C- Libraries need to document these assignments of meaning to non-standard characters.
D- Free software libraries will register these changes on:
http://www.cliki.net/Macro%20Characters
The above restrictions have always existed but were previously implicit.
There is unhappily no enforcement against non-conservative extensions, so tread carefully.
Do not re-bind this variable.")
(defvar *initial-print-pprint-dispatch* *print-pprint-dispatch*
"The initial readtable, as inherited from the environment at the time UIOP was first loaded.
It initially implements the syntax specified by the CLHS, but may also have implementation-specific
extensions, and may grow user-defined extensions. You MUST ONLY make conservative extensions to it,
i.e. you may not modify standard behavior, or conflict with anyone else's previous extensions.
There is unhappily no enforcement against non-conservative extensions, so tread carefully.
Do not re-bind this variable.")
(defvar *standard-readtable* (with-standard-io-syntax *readtable*)
"The standard readtable, implementing the syntax specified by the CLHS.
It must never be modified in any way whatsoever.
However, only SBCL is known to enforce this prohibition.
Do not re-bind this variable.")
(defvar *standard-print-pprint-dispatch* (with-standard-io-syntax *print-pprint-dispatch*)
"The standard pprint dispatch table, implementing the syntax specified by the CLHS.
It must never be modified in any way whatsoever.
However, only SBCL is known to enforce this prohibition.
Do not re-bind this variable.")
(defvar *shared-readtable* (copy-readtable nil)
"The shared readtable used by all Lisp software while building with ASDF.
This shared readtable is a copy of the *STANDARD-READTABLE*: see the documentation
of that variable for more details. That allows changes, but should provide uniform behavior
across implementations.
This variable can also be bound to other readtables to implement various instrumentations
by Lisp-to-Lisp compilers when (re)building software, presumably with a different fasl cache.")
(defvar *shared-print-pprint-dispatch* *initial-print-pprint-dispatch*
"*print-pprint-dispatch* table shared by all ASDF systems.
It should match the extensions of *shared-readtable* -- see the latter variable's documentation.")
(defvar *standard-syntax-variables*
`((*package* . (find-package :cl-user))
(*print-array* . t)
(*print-base* . 10)
(*print-case* . :upcase)
(*print-circle* . nil)
(*print-escape* . t)
(*print-gensym* . t)
(*print-length* . nil)
(*print-level* . nil)
(*print-lines* . nil)
(*print-miser-width* . nil)
(*print-pprint-dispatch* . ,*standard-print-pprint-dispatch*)
(*print-pretty* . nil)
(*print-radix* . nil)
(*print-readably* . t)
(*print-right-margin* . nil)
(*read-base* . 10)
(*read-default-float-format* . single-float)
(*read-eval* . t)
(*read-suppress* . nil)
(*readtable* . ,*standard-readtable*))))
;;;; Syntax control
(with-upgradability ()
(defun call-with-shared-syntax (function &key package readably)
(with-standard-io-syntax
(let ((*readtable* *shared-readtable*)
(*print-pprint-dispatch* *shared-print-pprint-dispatch*)
(*package* (find-package (or package :cl-user)))
(*print-readably* readably))
(call-function function))))
(defmacro with-shared-syntax ((&rest keys &key &allow-other-keys) &body body)
`(call-with-shared-syntax #'(lambda () ,@body) ,@keys))
(defun eval-input (input)
"Portably read and evaluate forms from INPUT, return the last values."
(with-input (input)
(loop :with results :with eof = '#:eof
:for form = (read input nil eof)
:until (eq form eof)
:do (setf results (multiple-value-list (eval form)))
:finally (return (apply 'values results)))))
(defun eval-thunk (thunk)
"Evaluate a THUNK of code:
If a function, FUNCALL it without arguments.
If a constant literal and not a sequence, return it.
If a cons or a symbol, EVAL it.
If a string, repeatedly read and evaluate from it, returning the last values."
(etypecase thunk
((or boolean keyword number character pathname) thunk)
((or cons symbol) (eval thunk))
(function (funcall thunk))
(string (eval-input thunk))))
(defun shared-eval-thunk (thunk &key (package :cl))
"Like EVAL-THUNK, but in the shared evaluation context."
;; Note: it's "shared-" not "safe-", because evaluation is never safe.
(when thunk
(with-shared-syntax (:package package)
(eval-thunk thunk)))))
......@@ -2,7 +2,8 @@
;;;; Starting, Stopping, Dumping a Lisp image
(uiop/package:define-package :uiop/image
(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
(:use :uiop/common-lisp :uiop/package :uiop/utility
:uiop/os :uiop/pathname :uiop/stream :uiop/eval)
(:export
#:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
#:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
......@@ -16,8 +17,7 @@
#:shell-boolean-exit
#:register-image-restore-hook #:register-image-dump-hook
#:call-image-restore-hook #:call-image-dump-hook
#:restore-image #:dump-image #:create-image
))
#:restore-image #:dump-image #:create-image))
(in-package :uiop/image)
(with-upgradability ()
......@@ -312,7 +312,7 @@ of the function will be returned rather than interpreted as a boolean designatin
(setf *image-prelude* prelude)
(setf *image-restored-p* :in-progress)
(call-image-restore-hook)
(standard-eval-thunk prelude)
(shared-eval-thunk prelude)
(setf *image-restored-p* t)
(let ((results (multiple-value-list
(if entry-point
......@@ -347,7 +347,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(setf *image-dumped-p* (if executable :executable t))
(setf *image-restored-p* :in-regress)
(setf *image-postlude* postlude)
(standard-eval-thunk *image-postlude*)
(shared-eval-thunk *image-postlude*)
(setf *image-dump-hook* dump-hook)
(call-image-dump-hook)
(setf *image-restored-p* nil)
......
......@@ -4,7 +4,7 @@
(uiop/package:define-package :uiop/lisp-build
(:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp
(:use :uiop/common-lisp :uiop/package :uiop/utility
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/eval :uiop/image)
(:export
;; Variables
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
......
......@@ -20,7 +20,6 @@
#:slurp-stream-forms #:slurp-stream-form
#:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
#:read-file-forms #:read-file-form #:safe-read-file-form
#:eval-input #:eval-thunk #:standard-eval-thunk
#:println #:writeln
#:file-stream-p #:file-or-synonym-stream-p
;; Temporary files
......@@ -138,26 +137,21 @@ from non-default encodings to and implementation-defined external-format's")
going through all the proper hooks."
(funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
;;; Safe syntax
;;; Safe I/O
(with-upgradability ()
(defvar *standard-readtable* (with-standard-io-syntax *readtable*)
"The standard readtable, implementing the syntax specified by the CLHS.
It must never be modified, though only good implementations will even enforce that.")
(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
(defmacro with-safe-io-syntax ((&key package) &body body)
"Establish safe CL reader options around the evaluation of BODY"
`(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
`(call-with-safe-io-syntax #'(lambda () ,@body) :package ,package))
(defun call-with-safe-io-syntax (thunk &key (package :cl))
(defun call-with-safe-io-syntax (function &key package)
(with-standard-io-syntax
(let ((*package* (find-package package))
(let ((*package* (find-package (or package :common-lisp)))
(*read-default-float-format* 'double-float)
(*print-readably* nil)
(*read-eval* nil))
(funcall thunk))))
(call-function function))))
(defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
(defun safe-read-from-string (string &key package (eof-error-p t) eof-value (start 0) end preserve-whitespace)
"Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
(with-safe-io-syntax (:package package)
(read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
......@@ -487,37 +481,9 @@ within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
Extracts the form using READ-FILE-FORM,
within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
(with-safe-io-syntax (:package package)
(apply 'read-file-form pathname (remove-plist-key :package keys))))
(defun eval-input (input)
"Portably read and evaluate forms from INPUT, return the last values."
(with-input (input)
(loop :with results :with eof ='#:eof
:for form = (read input nil eof)
:until (eq form eof)
:do (setf results (multiple-value-list (eval form)))
:finally (return (values-list results)))))
(defun eval-thunk (thunk)
"Evaluate a THUNK of code:
If a function, FUNCALL it without arguments.
If a constant literal and not a sequence, return it.
If a cons or a symbol, EVAL it.
If a string, repeatedly read and evaluate from it, returning the last values."
(etypecase thunk
((or boolean keyword number character pathname) thunk)
((or cons symbol) (eval thunk))
(function (funcall thunk))
(string (eval-input thunk))))
(defun standard-eval-thunk (thunk &key (package :cl))
"Like EVAL-THUNK, but in a more standardized evaluation context."
;; Note: it's "standard-" not "safe-", because evaluation is never safe.
(when thunk
(with-safe-io-syntax (:package package)
(let ((*read-eval* t))
(eval-thunk thunk))))))
(apply 'read-file-form pathname (remove-plist-key :package keys)))))
;;; Printers
(with-upgradability ()
(defun println (x &optional (stream *standard-output*))
"Variant of PRINC that also calls TERPRI afterwards"
......
......@@ -38,10 +38,11 @@ you already have a matching UIOP loaded."
(:file "utility" :depends-on ("common-lisp"))
(:file "version" :depends-on ("utility"))
(:file "os" :depends-on ("utility"))
(:file "pathname" :depends-on ("utility" "os"))
(:file "filesystem" :depends-on ("os" "pathname"))
(:file "pathname" :depends-on ("os"))
(:file "filesystem" :depends-on ("pathname"))
(:file "stream" :depends-on ("filesystem"))
(:file "image" :depends-on ("stream"))
(:file "eval" :depends-on ("stream"))
(:file "image" :depends-on ("eval"))
(:file "lisp-build" :depends-on ("image"))
(:file "launch-program" :depends-on ("stream"))
(:file "run-program" :depends-on ("launch-program"))
......
......@@ -401,7 +401,7 @@ If optional ERROR argument is NIL, return NIL instead of an error when the symbo
;;; Function designators
(with-upgradability ()
(defun ensure-function (fun &key (package :cl))
(defun ensure-function (fun &key package)
"Coerce the object FUN into a function.
If FUN is a FUNCTION, return it.
......@@ -422,7 +422,7 @@ and EVAL that in a (FUNCTION ...) context."
(eval fun)
#'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
(string (eval `(function ,(with-standard-io-syntax
(let ((*package* (find-package package)))
(let ((*package* (find-package (or package :common-lisp))))
(read-from-string fun))))))))
(defun access-at (object at)
......@@ -528,7 +528,6 @@ Return two values: the entry after its optional computation, and whether it was
up to the given equality TEST"
(dolist (x list h) (setf (gethash x h) t))))
;;; Lexicographic comparison of lists of numbers
(with-upgradability ()
(defun lexicographic< (element< x y)
......@@ -545,7 +544,6 @@ element< is a strict total order; the resulting order on X and Y will also be st
element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
(not (lexicographic< element< y x))))
;;; Simple style warnings
(with-upgradability ()
(define-condition simple-style-warning
......@@ -558,9 +556,7 @@ element< is a strict total order; the resulting order on X and Y will be a non-s
(symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments))
(style-warning (apply 'warn datum arguments)))))
;;; Condition control
(with-upgradability ()
(defparameter +simple-condition-format-control-slot+
#+abcl 'system::format-control
......@@ -605,7 +601,6 @@ or a string describing the format-control of a simple-condition."
`(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
;;; Conditions
(with-upgradability ()
(define-condition not-implemented-error (error)
((functionality :initarg :functionality)
......