Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge remote branch 'sbcl/master' into windows-threads

  • Loading branch information...
commit f4c054111316b243f3e0211fa572b2b78c302f68 2 parents 42b900d + 6501a92
@dmitryvk authored
Showing with 1,455 additions and 569 deletions.
  1. +24 −0 NEWS
  2. +0 −1  contrib/asdf/Makefile
  3. +157 −85 contrib/asdf/asdf.lisp
  4. +53 −15 contrib/asdf/asdf.texinfo
  5. +2 −6 contrib/sb-introspect/introspect.lisp
  6. +2 −4 contrib/sb-introspect/test-driver.lisp
  7. +18 −0 doc/manual/pathnames.texinfo
  8. +5 −1 make.sh
  9. +13 −2 package-data-list.lisp-expr
  10. +1 −2  src/code/coerce.lisp
  11. +54 −0 src/code/condition.lisp
  12. +3 −0  src/code/defboot.lisp
  13. +48 −4 src/code/early-extensions.lisp
  14. +3 −7 src/code/fd-stream.lisp
  15. +19 −17 src/code/filesys.lisp
  16. +12 −7 src/code/late-type.lisp
  17. +2 −1  src/code/macros.lisp
  18. +20 −13 src/code/ntrace.lisp
  19. +4 −4 src/code/numbers.lisp
  20. +14 −2 src/code/pathname.lisp
  21. +1 −1  src/code/signal.lisp
  22. +1 −1  src/code/sysmacs.lisp
  23. +21 −11 src/code/target-pathname.lisp
  24. +30 −25 src/code/target-thread.lisp
  25. +68 −36 src/code/unix-pathname.lisp
  26. +12 −5 src/code/unix.lisp
  27. +66 −32 src/code/win32-pathname.lisp
  28. +5 −3 src/code/win32.lisp
  29. +18 −0 src/compiler/alpha/call.lisp
  30. +6 −0 src/compiler/alpha/cell.lisp
  31. +13 −11 src/compiler/constraint.lisp
  32. +4 −1 src/compiler/dfo.lisp
  33. +27 −6 src/compiler/gtn.lisp
  34. +18 −0 src/compiler/hppa/call.lisp
  35. +6 −0 src/compiler/hppa/cell.lisp
  36. +1 −0  src/compiler/ir1-translators.lisp
  37. +4 −2 src/compiler/ir1tran-lambda.lisp
  38. +63 −64 src/compiler/ir1tran.lisp
  39. +2 −1  src/compiler/ir1util.lisp
  40. +74 −30 src/compiler/ir2tran.lisp
  41. +18 −14 src/compiler/locall.lisp
  42. +29 −18 src/compiler/main.lisp
  43. +17 −0 src/compiler/mips/call.lisp
  44. +6 −0 src/compiler/mips/cell.lisp
  45. +8 −0 src/compiler/node.lisp
  46. +30 −0 src/compiler/physenvanal.lisp
  47. +4 −6 src/compiler/policy.lisp
  48. +18 −0 src/compiler/ppc/call.lisp
  49. +5 −0 src/compiler/ppc/cell.lisp
  50. +4 −5 src/compiler/proclaim.lisp
  51. +17 −4 src/compiler/seqtran.lisp
  52. +17 −0 src/compiler/sparc/call.lisp
  53. +6 −0 src/compiler/sparc/cell.lisp
  54. +25 −12 src/compiler/srctran.lisp
  55. +20 −0 src/compiler/x86-64/call.lisp
  56. +6 −0 src/compiler/x86-64/cell.lisp
  57. +20 −0 src/compiler/x86/call.lisp
  58. +6 −0 src/compiler/x86/cell.lisp
  59. +52 −77 src/pcl/boot.lisp
  60. +0 −5 src/pcl/macros.lisp
  61. +5 −16 src/pcl/vector.lisp
  62. +14 −3 src/runtime/wrap.c
  63. +15 −0 tests/compiler.impure.lisp
  64. +98 −3 tests/compiler.pure.lisp
  65. +12 −0 tests/condition.pure.lisp
  66. +36 −0 tests/debug.impure.lisp
  67. +10 −0 tests/dynamic-extent.impure.lisp
  68. +29 −1 tests/mop.impure.lisp
  69. +25 −0 tests/pathnames.impure.lisp
  70. +4 −4 tests/threads.impure.lisp
  71. +1 −0  tools-for-build/whitespacely-canonical-filenames
  72. +4 −1 version.lisp-expr
View
24 NEWS
@@ -1,4 +1,28 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.44:
+ * enhancement: ~/ and ~user/ are treated specially in pathnames.
+ Refer to documentation for details.
+ * enhancement: ASDF has been updated to version 2.010.
+ * optimization: mutated closed-over variables that are only accessed by
+ DYNAMIC-EXTENT closures (currently only FLET and LABELS functions
+ declared to be DYNAMIC-EXTENT) are stored directly in their containing
+ stack frame, rather than allocating a VALUE-CELL (lp#586103).
+ * optimization: UNWIND-PROTECT cleanup functions are now declared
+ DYNAMIC-EXTENT.
+ * bug fix: backtracing function with &REST arguments now shows the full
+ argument list. (lp#310173)
+ * bug fix: return types for functions with complex lambda-lists are now
+ derived properly (lp#384892)
+ * bug fix: when SPEED > SPACE compiling CONCATENATE 'STRING with constant
+ long string arguments slowed the compiler down to a crawl.
+ * bug fix: closure VALUE-CELLs are no longer stack-allocated (lp#308934).
+ * bug fix: non-standard MAKE-METHOD-LAMBDA methods could break RETURN-FROM
+ in the DEFMETHOD body.
+ * bug fix: #<SB-C::DEFINED-FUN ...> should no longer appear in compiler
+ messages, being instead replaced with the corresponding function name.
+ * bug fix: don't derive overly complex unions of numeric types for arithmetic
+ operators. (lp#309448)
+
changes in sbcl-1.0.44 relative to sbcl-1.0.43:
* enhancement: RUN-PROGRAM accepts :EXTERNAL-FORMAT argument to select the
external-format for its :INPUT, :OUTPUT, AND :ERROR :STREAMs.
View
1  contrib/asdf/Makefile
@@ -10,5 +10,4 @@ up:
cp asdf-upstream/asdf.lisp asdf.lisp
cp asdf-upstream/doc/asdf.texinfo asdf.texinfo
cp asdf-upstream/README README
- cd asdf-upstream ; make archive
cp asdf-upstream/LICENSE LICENSE
View
242 contrib/asdf/asdf.lisp
@@ -71,14 +71,13 @@
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
- (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134
+ (let* ((asdf-version "2.010") ;; same as 2.146
(existing-asdf (fboundp 'find-system))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
(when existing-asdf
- (format *trace-output*
+ (format *error-output*
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version asdf-version))
(labels
@@ -170,9 +169,9 @@
:shadow ',shadow
:unintern ',(append #-(or gcl ecl) redefined-functions unintern)
:fmakunbound ',(append fmakunbound))))
- (unlink-package :asdf-utilities)
(pkgdcl
:asdf
+ :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
:use (:common-lisp)
:redefined-functions
(#:perform #:explain #:output-files #:operation-done-p
@@ -287,7 +286,7 @@
;; Utilities
#:absolute-pathname-p
- ;; #:aif #:it
+ ;; #:aif #:it
;; #:appendf
#:coerce-name
#:directory-pathname-p
@@ -299,12 +298,13 @@
#:merge-pathnames*
#:pathname-directory-pathname
#:read-file-forms
- ;; #:remove-keys
- ;; #:remove-keyword
+ ;; #:remove-keys
+ ;; #:remove-keyword
#:resolve-symlinks
#:split-string
#:component-name-to-pathname-components
#:split-name-type
+ #:subdirectories
#:truenamize
#:while-collecting)))
(setf *asdf-version* asdf-version
@@ -533,7 +533,18 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
(let* ((specified (pathname specified))
(defaults (pathname defaults))
(directory (pathname-directory specified))
- #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
+ (directory
+ (cond
+ #-(or sbcl cmu)
+ ((stringp directory) `(:absolute ,directory) directory)
+ #+gcl
+ ((and (consp directory) (stringp (first directory)))
+ `(:absolute ,@directory))
+ ((or (null directory)
+ (and (consp directory) (member (first directory) '(:absolute :relative))))
+ directory)
+ (t
+ (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
@@ -542,7 +553,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
(unspecific-handler (p)
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
- (#-gcl ecase #+gcl case (first directory)
+ (ecase (first directory)
((nil)
(values (pathname-host defaults)
(pathname-device defaults)
@@ -559,13 +570,6 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
(if (pathname-directory defaults)
(append (pathname-directory defaults) (cdr directory))
directory)
- (unspecific-handler defaults)))
- #+gcl
- (t
- (assert (stringp (first directory)))
- (values (pathname-host defaults)
- (pathname-device defaults)
- (append (pathname-directory defaults) directory)
(unspecific-handler defaults))))
(make-pathname :host host :device device :directory directory
:name (funcall unspecific-handler name)
@@ -620,7 +624,7 @@ starting the separation from the end, e.g. when called with arguments
(values filename unspecific)
(values name type)))))
-(defun* component-name-to-pathname-components (s &optional force-directory)
+(defun* component-name-to-pathname-components (s &key force-directory force-relative)
"Splits the path string S, returning three values:
A flag that is either :absolute or :relative, indicating
how the rest of the values are to be interpreted.
@@ -637,12 +641,17 @@ The intention of this function is to support structured component names,
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
pathnames."
(check-type s string)
+ (when (find #\: s)
+ (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
(let* ((components (split-string s :separator "/"))
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first components) "")
(if (equal (first-char s) #\/)
- (values :absolute (cdr components))
+ (progn
+ (when force-relative
+ (error "absolute pathname designator not allowed: ~S" s))
+ (values :absolute (cdr components)))
(values :relative nil))
(values :relative components))
(setf components (remove "" components :test #'equal))
@@ -686,11 +695,14 @@ ways that the filename components can be missing are for it to be NIL,
Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
- (flet ((check-one (x)
- (member x '(nil :unspecific "") :test 'equal)))
- (and (check-one (pathname-name pathname))
- (check-one (pathname-type pathname))
- t)))
+ (when pathname
+ (let ((pathname (pathname pathname)))
+ (flet ((check-one (x)
+ (member x '(nil :unspecific "") :test 'equal)))
+ (and (not (wild-pathname-p pathname))
+ (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname))
+ t)))))
(defun* ensure-directory-pathname (pathspec)
"Converts the non-wild pathname designator PATHSPEC to directory form."
@@ -700,7 +712,7 @@ actually-existing directory."
((not (pathnamep pathspec))
(error "Invalid pathname designator ~S" pathspec))
((wild-pathname-p pathspec)
- (error "Can't reliably convert wild pathnames."))
+ (error "Can't reliably convert wild pathname ~S" pathspec))
((directory-pathname-p pathspec)
pathspec)
(t
@@ -743,7 +755,7 @@ actually-existing directory."
(defun* get-uid ()
#+allegro (excl.osi:getuid)
#+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
- :for f = (ignore-errors (read-from-string s))
+ :for f = (ignore-errors (read-from-string s))
:when f :return (funcall f))
#+(or cmu scl) (unix:unix-getuid)
#+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
@@ -773,8 +785,8 @@ with given pathname and if it exists return its truename."
(string (probe-file* (parse-namestring p)))
(pathname (unless (wild-pathname-p p)
#.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
- #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p))
- '(ignore-errors (truename p)))))))
+ #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
+ '(ignore-errors (truename p)))))))
(defun* truenamize (p)
"Resolve as much of a pathname as possible"
@@ -839,7 +851,7 @@ with given pathname and if it exists return its truename."
(eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
- (component-name-to-pathname-components root-string t)
+ (component-name-to-pathname-components root-string :force-directory t)
(declare (ignore relative filename))
(let ((new-base
(make-pathname :defaults root
@@ -921,13 +933,29 @@ with given pathname and if it exists return its truename."
((name :accessor component-name :initarg :name :documentation
"Component name: designator for a string composed of portable pathname characters")
(version :accessor component-version :initarg :version)
- (in-order-to :initform nil :initarg :in-order-to
- :accessor component-in-order-to)
;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
;; POIU is a parallel (multi-process build) extension of ASDF. See
;; http://www.cliki.net/poiu
(load-dependencies :accessor component-load-dependencies :initform nil)
- ;; XXX crap name, but it's an official API name!
+ ;; In the ASDF object model, dependencies exist between *actions*
+ ;; (an action is a pair of operation and component). They are represented
+ ;; alists of operations to dependencies (other actions) in each component.
+ ;; There are two kinds of dependencies, each stored in its own slot:
+ ;; in-order-to and do-first dependencies. These two kinds are related to
+ ;; the fact that some actions modify the filesystem,
+ ;; whereas other actions modify the current image, and
+ ;; this implies a difference in how to interpret timestamps.
+ ;; in-order-to dependencies will trigger re-performing the action
+ ;; when the timestamp of some dependency
+ ;; makes the timestamp of current action out-of-date;
+ ;; do-first dependencies do not trigger such re-performing.
+ ;; Therefore, a FASL must be recompiled if it is obsoleted
+ ;; by any of its FASL dependencies (in-order-to); but
+ ;; it needn't be recompiled just because one of these dependencies
+ ;; hasn't yet been loaded in the current image (do-first).
+ ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
+ (in-order-to :initform nil :initarg :in-order-to
+ :accessor component-in-order-to)
(do-first :initform nil :initarg :do-first
:accessor component-do-first)
;; methods defined using the "inline" style inside a defsystem form:
@@ -1060,7 +1088,8 @@ with given pathname and if it exists return its truename."
(licence :accessor system-licence :initarg :licence
:accessor system-license :initarg :license)
(source-file :reader system-source-file :initarg :source-file
- :writer %set-system-source-file)))
+ :writer %set-system-source-file)
+ (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
;;;; -------------------------------------------------------------------------
;;;; version-satisfies
@@ -1284,22 +1313,21 @@ Going forward, we recommend new users should be using the source-registry.
(setf (gethash (coerce-name name) *defined-systems*)
(cons (get-universal-time) system)))
-(defun* find-system-fallback (requested fallback &optional source-file)
+(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
(setf fallback (coerce-name fallback)
source-file (or source-file *compile-file-truename* *load-truename*)
requested (coerce-name requested))
(when (equal requested fallback)
(let* ((registered (cdr (gethash fallback *defined-systems*)))
(system (or registered
- (make-instance
- 'system :name fallback
- :source-file source-file))))
+ (apply 'make-instance 'system
+ :name fallback :source-file source-file keys))))
(unless registered
(register-system fallback system))
(throw 'find-system system))))
(defun* sysdef-find-asdf (name)
- (find-system-fallback name "asdf"))
+ (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
;;;; -------------------------------------------------------------------------
@@ -1370,7 +1398,8 @@ Going forward, we recommend new users should be using the source-registry.
(merge-component-name-type (string-downcase name) :type type :defaults defaults))
(string
(multiple-value-bind (relative path filename)
- (component-name-to-pathname-components name (eq type :directory))
+ (component-name-to-pathname-components name :force-directory (eq type :directory)
+ :force-relative t)
(multiple-value-bind (name type)
(cond
((or (eq type :directory) (null filename))
@@ -1600,8 +1629,8 @@ recursive calls to traverse.")
(do-traverse op dep-c collect)))
(defun* do-one-dep (operation c collect required-op required-c required-v)
- ;; this function is a thin, error-handling wrapper around
- ;; %do-one-dep. Returns a partial plan per that function.
+ ;; this function is a thin, error-handling wrapper around %do-one-dep.
+ ;; Collects a partial plan per that function.
(loop
(restart-case
(return (%do-one-dep operation c collect
@@ -1612,13 +1641,6 @@ recursive calls to traverse.")
(component-find-path required-c)))
:test
(lambda (c)
- #|
- (print (list :c1 c (typep c 'missing-dependency)))
- (when (typep c 'missing-dependency)
- (print (list :c2 (missing-requires c) required-c
- (equalp (missing-requires c)
- required-c))))
- |#
(or (null c)
(and (typep c 'missing-dependency)
(equalp (missing-requires c)
@@ -1832,7 +1854,8 @@ recursive calls to traverse.")
(setf (gethash (type-of operation) (component-operation-times c))
(get-universal-time)))
-(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
+(declaim (ftype (function ((or pathname string)
+ &rest t &key (:output-file t) &allow-other-keys)
(values t t t))
compile-file*))
@@ -2152,7 +2175,7 @@ details."
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
defsystem-depends-on &allow-other-keys)
options
- (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
+ (let ((component-options (remove-keys '(:class) options)))
`(progn
;; system must be registered before we parse the body, otherwise
;; we recur when trying to find an existing system of the same name
@@ -2457,23 +2480,33 @@ located."
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
- '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
- :corman :cormanlisp :armedbear :gcl :ecl :scl))
+ '((:acl :allegro)
+ (:lw :lispworks)
+ (:digitool) ; before clozure, so it won't get preempted by ccl
+ (:ccl :clozure)
+ (:corman :cormanlisp)
+ (:abcl :armedbear)
+ :sbcl :cmu :clisp :gcl :ecl :scl))
(defparameter *os-features*
- '((:windows :mswindows :win32 :mingw32)
+ '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
(:solaris :sunos)
- :linux ;; for GCL at least, must appear before :bsd.
- :macosx :darwin :apple
+ (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
+ (:macosx :darwin :darwin-target :apple)
:freebsd :netbsd :openbsd :bsd
:unix))
(defparameter *architecture-features*
- '((:x86-64 :amd64 :x86_64 :x8664-target)
- (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
- :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
- :java-1.4 :java-1.5 :java-1.6 :java-1.7))
-
+ '((:amd64 :x86-64 :x86_64 :x8664-target)
+ (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+ :hppa64
+ :hppa
+ (:ppc64 :ppc64-target)
+ (:ppc32 :ppc32-target :ppc :powerpc)
+ :sparc64
+ (:sparc32 :sparc)
+ (:arm :arm-target)
+ (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
(defun* lisp-version-string ()
(let ((s (lisp-implementation-version)))
@@ -2492,7 +2525,7 @@ located."
(if (member :64bit *features*) "-64bit" ""))
#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
#+clisp (subseq s 0 (position #\space s))
- #+clozure (format nil "~d.~d-fasl~d"
+ #+clozure (format nil "~d.~d-f~d" ; shorten for windows
ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*
(logand ccl::fasl-version #xFF))
@@ -2689,10 +2722,6 @@ with a different configuration, so the configuration would be re-read then."
(setf *output-translations* '())
(values))
-(defparameter *wild-asd*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type "asd" :version :newest))
-
(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
(values (or null pathname) &optional))
resolve-location))
@@ -2872,7 +2901,7 @@ with a different configuration, so the configuration would be re-read then."
;; These are for convenience, and can be overridden by the user:
#+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; If we want to enable the user cache by default, here would be the place:
+ ;; We enable the user cache by default, and here is the place we do:
:enable-user-cache))
(defparameter *output-translations-file* #p"asdf-output-translations.conf")
@@ -3051,8 +3080,8 @@ effectively disabling the output translation facility."
(when (and x (probe-file x))
(delete-file x)))
-(defun* compile-file* (input-file &rest keys &key &allow-other-keys)
- (let* ((output-file (apply 'compile-file-pathname* input-file keys))
+(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
+ (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
(tmp-file (tmpize-pathname output-file))
(status :error))
(multiple-value-bind (output-truename warnings-p failure-p)
@@ -3102,7 +3131,8 @@ effectively disabling the output translation facility."
(include-per-user-information nil)
(map-all-source-files (or #+(or ecl clisp) t nil))
(source-to-target-mappings nil))
- (when (and (null map-all-source-files) #-(or ecl clisp) nil)
+ #+(or ecl clisp)
+ (when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
(wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
@@ -3206,7 +3236,8 @@ effectively disabling the output translation facility."
;; Using ack 1.2 exclusions
(defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+ '(".bzr" ".cdv"
+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"
"debian")) ;; debian often build stuff under the debian directory... BAD.
@@ -3234,6 +3265,61 @@ with a different configuration, so the configuration would be re-read then."
(setf *source-registry* '())
(values))
+(defparameter *wild-asd*
+ (make-pathname :directory nil :name :wild :type "asd" :version :newest))
+
+(defun directory-has-asd-files-p (directory)
+ (and (ignore-errors
+ (directory (merge-pathnames* *wild-asd* directory)
+ #+sbcl #+sbcl :resolve-symlinks nil
+ #+ccl #+ccl :follow-links nil
+ #+clisp #+clisp :circle t))
+ t))
+
+(defun subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-cormanlisp
+ (wild (merge-pathnames*
+ #-(or abcl allegro lispworks scl)
+ (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+ #+(or abcl allegro lispworks scl) "*.*"
+ directory))
+ (dirs
+ #-cormanlisp
+ (ignore-errors
+ (directory wild .
+ #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+ccl '(:follow-links nil :directories t :files nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+digitool '(:directories t)
+ #+sbcl '(:resolve-symlinks nil))))
+ #+cormanlisp (cl::directory-subdirs directory))
+ #+(or abcl allegro lispworks scl)
+ (dirs (remove-if-not #+abcl #'extensions:probe-directory
+ #+allegro #'excl:probe-directory
+ #+lispworks #'lw:file-directory-p
+ #-(or abcl allegro lispworks) #'directory-pathname-p
+ dirs)))
+ dirs))
+
+(defun collect-sub*directories (directory collectp recursep collector)
+ (when (funcall collectp directory)
+ (funcall collector directory))
+ (dolist (subdir (subdirectories directory))
+ (when (funcall recursep subdir)
+ (collect-sub*directories subdir collectp recursep collector))))
+
+(defun collect-sub*directories-with-asd
+ (directory &key
+ (exclude *default-source-registry-exclusions*)
+ collect)
+ (collect-sub*directories
+ directory
+ #'directory-has-asd-files-p
+ #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+ collect))
+
(defun* validate-source-registry-directive (directive)
(unless
(or (member directive '(:default-registry (:default-registry)) :test 'equal)
@@ -3297,22 +3383,8 @@ with a different configuration, so the configuration would be re-read then."
(defun* register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
(funcall collect directory)
- (let* ((files
- (handler-case
- (directory (merge-pathnames* *wild-asd* directory)
- #+sbcl #+sbcl :resolve-symlinks nil
- #+clisp #+clisp :circle t)
- (error (c)
- (warn "Error while scanning system definitions under directory ~S:~%~A"
- directory c)
- nil)))
- (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
- :test #'equal :from-end t)))
- (loop
- :for dir :in dirs
- :unless (loop :for x :in exclude
- :thereis (find x (pathname-directory dir) :test #'equal))
- :do (funcall collect dir)))))
+ (collect-sub*directories-with-asd
+ directory :exclude exclude :collect collect)))
(defparameter *default-source-registries*
'(environment-source-registry
View
68 contrib/asdf/asdf.texinfo
@@ -772,7 +772,7 @@ has the effect of
@end lisp
where @code{...} is the component in question.
-In this case @code{...} would expand to something like
+In this case @code{...} would expand to something like
@lisp
(find-component (find-system "foo") "mod")
@@ -795,20 +795,34 @@ For more details on what these methods do, @pxref{Operations} in
@comment node-name, next, previous, up
@section The defsystem grammar
+@c FIXME: @var typesetting not consistently used here. We should either expand
+@c its use to everywhere, or we should kill it everywhere.
+
+
@example
-system-definition := ( defsystem system-designator @var{option}* )
+system-definition := ( defsystem system-designator @var{system-option}* )
+
+system-option := :defsystem-depends-on system-list
+ | module-option
+ | option
-option := :components component-list
+module-option := :components component-list
+ | :serial [ t | nil ]
+ | :if-component-dep-fails component-dep-fail-option
+
+option :=
| :pathname pathname-specifier
- | :default-component-class
+ | :default-component-class class-name
| :perform method-form
| :explain method-form
| :output-files method-form
| :operation-done-p method-form
| :depends-on ( @var{dependency-def}* )
- | :serial [ t | nil ]
| :in-order-to ( @var{dependency}+ )
+
+system-list := ( @var{simple-component-name}* )
+
component-list := ( @var{component-def}* )
component-def := ( component-type simple-component-name @var{option}* )
@@ -834,8 +848,12 @@ pathname-specifier := pathname | string | symbol
method-form := (operation-name qual lambda-list @&rest body)
qual := method qualifier
+
+component-dep-fail-option := :fail | :try-next | :ignore
@end example
+
+
@subsection Component names
Component names (@code{simple-component-name})
@@ -849,6 +867,14 @@ the current package. So a component type @code{my-component-type}, in
the current package @code{my-system-asd} can be specified as
@code{:my-component-type}, or @code{my-component-type}.
+@subsection Defsystem depends on
+
+The @code{:defsystem-depends-on} option to @code{defsystem} allows the
+programmer to specify another ASDF-defined system or set of systems that
+must be loaded @emph{before} the system definition is processed.
+Typically this is used to load an ASDF extension that is used in the
+system definition.
+
@subsection Pathname specifiers
@cindex pathname specifiers
@@ -918,7 +944,7 @@ Unhappily, ASDF 1 didn't properly support
parsing component names as strings specifying paths with directories,
and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
-Note that when specifying pathname objects,
+Note that when specifying pathname objects,
ASDF does not do any special interpretation of the pathname
influenced by the component type, unlike the procedure for
pathname-specifying strings.
@@ -930,7 +956,7 @@ be forced upon you if you were specifying a string.
@subsection Warning about logical pathnames
-@cindex logical pathnames
+@cindex logical pathnames
We recommend that you not use logical pathnames
in your asdf system definitions at this point,
@@ -1031,6 +1057,13 @@ and @code{*load-truename*} is currently unbound
from within an editor without clobbering its source location)
@end itemize
+@subsection if-component-dep-fails option
+
+This option is only appropriate for module components (including
+systems), not individual source files.
+
+For more information about this option, @pxref{Pre-defined subclasses of component}.
+
@node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem
@section Other code in .asd files
@@ -1700,11 +1733,14 @@ to be found, for systems to be found the current directory
(at the time that the configuration is initialized) as well as
@code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and
@code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}.
+For instance, SBCL will include directories for its contribs
+when it can find them; it will look for them where SBCL was installed,
+or at the location specified by the @code{SBCL_HOME} environment variable.
@end enumerate
-Each of these configuration is specified as a SEXP
-in a trival domain-specific language (defined below).
+Each of these configurations is specified as an s-expression
+in a trivial domain-specific language (defined below).
Additionally, a more shell-friendly syntax is available
for the environment variable (defined yet below).
@@ -1733,14 +1769,14 @@ On Windows platforms, when not using Cygwin,
instead of the XDG base directory specification,
we try to use folder configuration from the registry regarding
@code{Common AppData} and similar directories.
-However, support querying the Windows registry is limited as of ASDF 2,
+However, support for querying the Windows registry is limited as of ASDF 2,
and on many implementations, we may fall back to always using the defaults
without consulting the registry.
Patches welcome.
@section Backward Compatibility
-For backward compatibility as well as for a practical backdoor for hackers,
+For backward compatibility as well as to provide a practical backdoor for hackers,
ASDF will first search for @code{.asd} files in the directories specified in
@code{asdf:*central-registry*}
before it searches in the source registry above.
@@ -1754,10 +1790,10 @@ but will take precedence over the new mechanism if you do use it.
@section Configuration DSL
-Here is the grammar of the SEXP DSL for source-registry configuration:
+Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
@example
-;; A configuration is single SEXP starting with keyword :source-registry
+;; A configuration is a single SEXP starting with keyword :source-registry
;; followed by a list of directives.
CONFIGURATION := (:source-registry DIRECTIVE ...)
@@ -1779,6 +1815,8 @@ DIRECTIVE :=
(:exclude PATTERN ...) |
;; augment the defaults for exclusion patterns
(:also-exclude PATTERN ...) |
+ ;; Note that the scope of a an exclude pattern specification is
+ ;; the rest of the current configuration expression or file.
;; splice the parsed contents of another config file
(:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
@@ -1823,7 +1861,6 @@ once contained:
:inherit-configuration)
@end example
-
@section Configuration Directories
Configuration directories consist in files each contains
@@ -1886,6 +1923,7 @@ list of paths, where
@section Search Algorithm
+@vindex *default-source-registry-exclusions*
In case that isn't clear, the semantics of the configuration is that
when searching for a system of a given name,
@@ -3417,7 +3455,7 @@ but that's all.
The defsystem 4 proposal tends to look more at the external features,
whereas this one centres on a protocol for system introspection.
-@section kmp's ``The Description of Large Systems'', MIT AI Memu 801
+@section kmp's ``The Description of Large Systems'', MIT AI Memo 801
Available in updated-for-CL form on the web at
@url{http://nhplace.com/kent/Papers/Large-Systems.html}
View
8 contrib/sb-introspect/introspect.lisp
@@ -424,14 +424,10 @@ If an unsupported TYPE is requested, the function will return NIL.
;; FIXME there may be other structure predicate functions
(member self (list *struct-predicate*))))
-(defun function-arglist (function)
- "Deprecated alias for FUNCTION-LAMBDA-LIST."
+(sb-int:define-deprecated-function :late "1.0.24.5" function-arglist function-lambda-list
+ (function)
(function-lambda-list function))
-(define-compiler-macro function-arglist (function)
- (sb-int:deprecation-warning 'function-arglist 'function-lambda-list)
- `(function-lambda-list ,function))
-
(defun function-lambda-list (function)
"Describe the lambda list for the extended function designator FUNCTION.
Works for special-operators, macros, simple functions, interpreted functions,
View
6 contrib/sb-introspect/test-driver.lisp
@@ -378,12 +378,10 @@
(deftest function-type.2
(values (type-equal (function-type 'sun) (function-type #'sun))
- ;; Does not currently work due to Bug #384892. (1.0.31.26)
- #+nil
(type-equal (function-type #'sun)
'(function (fixnum fixnum &key (:k1 (member nil t)))
(values (member t) &optional))))
- t #+nil t)
+ t t)
;; Local functions
@@ -516,7 +514,7 @@
'(function ((member nil t)
fixnum fixnum
&key (:k1 (member nil t)))
- *)))
+ (values (member nil t) &optional))))
t t)
;; Misc
View
18 doc/manual/pathnames.texinfo
@@ -70,6 +70,24 @@ implementation-defined and so need documentation.
@c * Other symbols and integers have implementation-defined meaning.
@c (19.2.2.4.6)
+@subsection Home Directory Specifiers
+
+SBCL accepts the keyword @code{:home} and a list of the form
+@code{(:home "username")} as a directory component immediately
+following @code{:absolute}.
+
+@code{:home} is represented in namestrings by @code{~/} and
+@code{(:home "username"} by @code{~username/} at the start of the
+namestring. Tilde-characters elsewhere in namestrings represent
+themselves.
+
+Home directory specifiers are resolved to home directory of the
+current or specified user by @code{native-namestring}, which is used
+by the implementation to translate pathnames before passing them on to
+operating system specific routines.
+
+Using @code{(:home "user")} form on Windows signals an error.
+
@subsection The SYS Logical Pathname Host
@cindex Logical pathnames
View
6 make.sh
@@ -121,7 +121,11 @@ Options:
Default prefix is: /usr/local
- --dynamic-space-size=<size> Specify default dynamic-space size.
+ --dynamic-space-size=<size> Default dynamic-space size for target.
+
+ This specifies the default dynamic-space size for the SBCL
+ being built. If you need to control the dynamic-space size
+ of the host SBCL, use the --xc-host option.
If not provided, the default is platform-specific. <size> is
taken to be megabytes unless explicitly suffixed with Gb in
View
15 package-data-list.lisp-expr
@@ -219,6 +219,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME"
"ALLOCATE-DYNAMIC-CODE-OBJECT" "ALLOCATE-FULL-CALL-FRAME"
"ALWAYS-TRANSLATABLE"
+ "ANCESTOR-FRAME-REF" "ANCESTOR-FRAME-SET"
"ANY" "ARG-COUNT-ERROR" "ASSEMBLE-FILE"
"ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION"
"ATTRIBUTES=" "BIND"
@@ -231,7 +232,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"CHECK-SYMBOL"
;; FIXME: 32/64-bit issues
"CHECK-UNSIGNED-BYTE-32" "CHECK-UNSIGNED-BYTE-64"
- "CLOSURE-INIT" "CLOSURE-REF"
+ "CLOSURE-INIT" "CLOSURE-REF" "CLOSURE-INIT-FROM-FP"
"CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
"*CODE-COVERAGE-INFO*"
"COMPARE-AND-SWAP-SLOT"
@@ -669,6 +670,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"IMPLICIT-GENERIC-FUNCTION-NAME"
"IMPLICIT-GENERIC-FUNCTION-WARNING"
"INVALID-FASL"
+ "DEPRECATION-CONDITION"
"NAME-CONFLICT" "NAME-CONFLICT-FUNCTION"
"NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS"
@@ -960,6 +962,14 @@ possibly temporariliy, because it might be used internally."
"*N-BYTES-FREED-OR-PURIFIED*"
+ ;; Deprecating stuff
+ "DEFINE-DEPRECATED-FUNCTION"
+ "EARLY-DEPRECATION-WARNING"
+ "LATE-DEPRECATION-WARNING"
+ "FINAL-DEPRECATION-WARNING"
+ "DEPRECATION-WARNING"
+ "DEPRECATION-ERROR"
+
;; miscellaneous non-standard but handy user-level functions..
"ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
"ADJUST-LIST"
@@ -976,7 +986,6 @@ possibly temporariliy, because it might be used internally."
"PSXHASH"
"%BREAK"
"NTH-BUT-WITH-SANE-ARG-ORDER"
- "DEPRECATION-WARNING"
"BIT-VECTOR-="
"READ-EVALUATED-FORM"
"MAKE-UNPRINTABLE-OBJECT"
@@ -1341,6 +1350,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%WITH-ARRAY-DATA"
"%WITH-ARRAY-DATA/FP"
"%WITH-ARRAY-DATA-MACRO"
+ "*APPROXIMATE-NUMERIC-UNIONS*"
"*CURRENT-LEVEL-IN-PRINT*"
"*EMPTY-TYPE*"
"*EVAL-CALLS*"
@@ -2348,6 +2358,7 @@ no guarantees of interface stability."
"NANOSLEEP"
"UID-USERNAME"
"UID-HOMEDIR"
+ "USER-HOMEDIR"
"WITH-RESTARTED-SYSCALL"
"SB-MKSTEMP"
View
3  src/code/coerce.lisp
@@ -81,8 +81,7 @@
;; become COMPILE instead of EVAL, which seems nicer to me.
(eval `(function ,object)))
((instance-lambda)
- (deprecation-warning 'instance-lambda 'lambda)
- (eval `(function ,object)))
+ (deprecation-error "0.9.3.32" 'instance-lambda 'lambda))
(t
(error 'simple-type-error
:datum object
View
54 src/code/condition.lisp
@@ -1639,6 +1639,60 @@ the usual naming convention (names like *FOO*) for special variables"
(proclamation-mismatch-name warning)
(proclamation-mismatch-old warning)))))
+;;;; deprecation conditions
+
+(define-condition deprecation-condition ()
+ ((name :initarg :name :reader deprecated-name)
+ (replacement :initarg :replacement :reader deprecated-name-replacement)
+ (since :initarg :since :reader deprecated-since)
+ (runtime-error :initarg :runtime-error :reader deprecated-name-runtime-error)))
+
+(def!method print-object ((condition deprecation-condition) stream)
+ (let ((*package* (find-package :keyword)))
+ (if *print-escape*
+ (print-unreadable-object (condition stream :type t)
+ (format stream "~S is deprecated~@[, use ~S~]"
+ (deprecated-name condition)
+ (deprecated-name-replacement condition)))
+ (format stream "~@<~S has been deprecated as of SBCL ~A~
+ ~@[, use ~S instead~].~:@>"
+ (deprecated-name condition)
+ (deprecated-since condition)
+ (deprecated-name-replacement condition)))))
+
+(define-condition early-deprecation-warning (style-warning deprecation-condition)
+ ())
+
+(def!method print-object :after ((warning early-deprecation-warning) stream)
+ (unless *print-escape*
+ (let ((*package* (find-package :keyword)))
+ (format stream "~%~@<~:@_In future SBCL versions ~S will signal a full warning ~
+ at compile-time.~:@>"
+ (deprecated-name warning)))))
+
+(define-condition late-deprecation-warning (warning deprecation-condition)
+ ())
+
+(def!method print-object :after ((warning late-deprecation-warning) stream)
+ (unless *print-escape*
+ (when (deprecated-name-runtime-error warning)
+ (let ((*package* (find-package :keyword)))
+ (format stream "~%~@<~:@_In future SBCL versions ~S will signal a runtime error.~:@>"
+ (deprecated-name warning))))))
+
+(define-condition final-deprecation-warning (warning deprecation-condition)
+ ())
+
+(def!method print-object :after ((warning final-deprecation-warning) stream)
+ (unless *print-escape*
+ (when (deprecated-name-runtime-error warning)
+ (let ((*package* (find-package :keyword)))
+ (format stream "~%~@<~:@_An error will be signaled at runtime for ~S.~:@>"
+ (deprecated-name warning))))))
+
+(define-condition deprecation-error (error deprecation-condition)
+ ())
+
;;;; restart definitions
(define-condition abort-failure (control-error) ()
View
3  src/code/defboot.lisp
@@ -526,6 +526,9 @@ evaluated as a PROGN."
key-vars keywords)
,@forms))))))
(mapcar (lambda (clause)
+ (unless (listp (second clause))
+ (error "Malformed ~S clause, no lambda-list:~% ~S"
+ 'restart-case clause))
(with-keyword-pairs ((report interactive test
&rest forms)
(cddr clause))
View
52 src/code/early-extensions.lisp
@@ -1126,10 +1126,54 @@
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
-(defun deprecation-warning (bad-name &optional good-name)
- (warn "using deprecated ~S~@[, should use ~S instead~]"
- bad-name
- good-name))
+;;;; Deprecating stuff
+
+(defun deprecation-error (since name replacement)
+ (error 'deprecation-error
+ :name name
+ :replacement replacement
+ :since since))
+
+(defun deprecation-warning (state since name replacement
+ &key (runtime-error (neq :early state)))
+ (warn (ecase state
+ (:early 'early-deprecation-warning)
+ (:late 'late-deprecation-warning)
+ (:final 'final-deprecation-warning))
+ :name name
+ :replacement replacement
+ :since since
+ :runtime-error runtime-error))
+
+(defun deprecated-function (since name replacement)
+ (lambda (&rest deprecated-function-args)
+ (declare (ignore deprecated-function-args))
+ (deprecation-error since name replacement)))
+
+(defun deprecation-compiler-macro (state since name replacement)
+ (lambda (form env)
+ (declare (ignore env))
+ (deprecation-warning state since name replacement)
+ form))
+
+(defmacro define-deprecated-function (state since name replacement lambda-list &body body)
+ (let ((doc (let ((*package* (find-package :keyword)))
+ (format nil "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>"
+ name since replacement))))
+ `(progn
+ ,(ecase state
+ ((:early :late)
+ `(defun ,name ,lambda-list
+ ,doc
+ ,@body))
+ ((:final)
+ `(progn
+ (declaim (ftype (function * nil) ,name))
+ (setf (fdefinition ',name)
+ (deprecated-function ',name ',replacement ,since))
+ (setf (documentation ',name 'function) ,doc))))
+ (setf (compiler-macro-function ',name)
+ (deprecation-compiler-macro ,state ,since ',name ',replacement)))))
;;; Anaphoric macros
(defmacro awhen (test &body body)
View
10 src/code/fd-stream.lisp
@@ -407,14 +407,10 @@
;;; this is not something we want to export. Nikodemus thinks the
;;; right thing is to support a low-level non-stream like IO layer,
;;; akin to java.nio.
-(defun output-raw-bytes (stream thing &optional start end)
+(declaim (inline output-raw-bytes))
+(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence
+ (stream thing &optional start end)
(write-or-buffer-output stream thing (or start 0) (or end (length thing))))
-
-(define-compiler-macro output-raw-bytes (stream thing &optional start end)
- (deprecation-warning 'output-raw-bytes)
- (let ((x (gensym "THING")))
- `(let ((,x ,thing))
- (write-or-buffer-output ,stream ,x (or ,start 0) (or ,end (length ,x))))))
;;;; output routines and related noise
View
36 src/code/filesys.lisp
@@ -542,30 +542,32 @@ Experimental: interface subject to change."
*default-pathname-defaults*
:as-directory t))))
+(defun user-homedir-namestring (&optional username)
+ (if username
+ (sb!unix:user-homedir username)
+ (let ((env-home (posix-getenv "HOME")))
+ (if (and env-home (not (string= env-home "")))
+ env-home
+ #!-win32
+ (sb!unix:uid-homedir (sb!unix:unix-getuid))))))
+
;;; (This is an ANSI Common Lisp function.)
(defun user-homedir-pathname (&optional host)
#!+sb-doc
"Return the home directory of the user as a pathname. If the HOME
environment variable has been specified, the directory it designates
is returned; otherwise obtains the home directory from the operating
-system."
+system. HOST argument is ignored by SBCL."
(declare (ignore host))
- (let ((env-home (posix-getenv "HOME")))
- (values
- (parse-native-namestring
- (if (and env-home (not (string= env-home "")))
- env-home
- #!-win32
- (sb!unix:uid-homedir (sb!unix:unix-getuid))
- #!+win32
- ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH
- ;; What?! -- RMK, 2007-12-31
- (return-from user-homedir-pathname
- (sb!win32::get-folder-pathname sb!win32::csidl_profile)))
- #!-win32 sb!impl::*unix-host*
- #!+win32 sb!impl::*win32-host*
- *default-pathname-defaults*
- :as-directory t))))
+ (values
+ (parse-native-namestring
+ (or (user-homedir-namestring)
+ #!+win32
+ (sb!win32::get-folder-namestring sb!win32::csidl_profile))
+ #!-win32 sb!impl::*unix-host*
+ #!+win32 sb!impl::*win32-host*
+ *default-pathname-defaults*
+ :as-directory t)))
;;;; DIRECTORY
View
19 src/code/late-type.lisp
@@ -1883,10 +1883,12 @@
;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
;;;
-;;; Old comment, probably no longer applicable:
-;;;
-;;; ### Note: we give up early to keep from dropping lots of
-;;; information on the floor by returning overly general types.
+;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent
+;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128),
+;;; the compiler does this occasionally during type-derivation to avoid
+;;; creating absurdly complex unions of numeric types.
+(defvar *approximate-numeric-unions* nil)
+
(!define-type-method (number :simple-union2) (type1 type2)
(declare (type numeric-type type1 type2))
(cond ((csubtypep type1 type2) type2)
@@ -1902,7 +1904,8 @@
((and (eq class1 class2)
(eq format1 format2)
(eq complexp1 complexp2)
- (or (numeric-types-intersect type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-intersect type1 type2)
(numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
@@ -1924,7 +1927,8 @@
(integerp (numeric-type-low type2))
(integerp (numeric-type-high type2))
(= (numeric-type-low type2) (numeric-type-high type2))
- (or (numeric-types-adjacent type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
:class 'rational
@@ -1943,7 +1947,8 @@
(integerp (numeric-type-low type1))
(integerp (numeric-type-high type1))
(= (numeric-type-low type1) (numeric-type-high type1))
- (or (numeric-types-adjacent type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
:class 'rational
View
3  src/code/macros.lisp
@@ -165,7 +165,8 @@ invoked. In that case it will store into PLACE and start over."
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-(define-condition duplicate-case-key-warning (style-warning)
+;;; Make this a full warning during SBCL build.
+(define-condition duplicate-case-key-warning (#-sb-xc-host style-warning #+sb-xc-host warning)
((key :initarg :key
:reader case-warning-key)
(case-kind :initarg :case-kind
View
33 src/code/ntrace.lisp
@@ -648,20 +648,27 @@ are evaluated in the null environment."
;;; Untrace one function.
(defun untrace-1 (function-or-name)
(let* ((fun (trace-fdefinition function-or-name))
- (info (gethash fun *traced-funs*)))
+ (info (when fun (gethash fun *traced-funs*))))
(cond
- ((not info)
- (when fun
- (warn "Function is not TRACEd: ~S" function-or-name)))
- (t
- (cond
- ((trace-info-encapsulated info)
- (unencapsulate (trace-info-what info) 'trace))
- (t
- (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
- (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
- (setf (trace-info-untraced info) t)
- (remhash fun *traced-funs*)))))
+ ((and fun (not info))
+ (warn "Function is not TRACEd: ~S" function-or-name))
+ ((not fun)
+ ;; Someone has FMAKUNBOUND it.
+ (let ((table *traced-funs*))
+ (with-locked-hash-table (table)
+ (maphash (lambda (fun info)
+ (when (equal function-or-name (trace-info-what info))
+ (remhash fun table)))
+ table))))
+ (t
+ (cond
+ ((trace-info-encapsulated info)
+ (unencapsulate (trace-info-what info) 'trace))
+ (t
+ (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
+ (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
+ (setf (trace-info-untraced info) t)
+ (remhash fun *traced-funs*)))))
;;; Untrace all traced functions.
(defun untrace-all ()
View
8 src/code/numbers.lisp
@@ -855,10 +855,10 @@ the first."
;; conversion.
(multiple-value-bind (lo hi)
(case '(dispatch-type y)
- ('single-float
+ (single-float
(values most-negative-exactly-single-float-fixnum
most-positive-exactly-single-float-fixnum))
- ('double-float
+ (double-float
(values most-negative-exactly-double-float-fixnum
most-positive-exactly-double-float-fixnum)))
(if (<= lo y hi)
@@ -872,10 +872,10 @@ the first."
;; Likewise
(multiple-value-bind (lo hi)
(case '(dispatch-type x)
- ('single-float
+ (single-float
(values most-negative-exactly-single-float-fixnum
most-positive-exactly-single-float-fixnum))
- ('double-float
+ (double-float
(values most-negative-exactly-double-float-fixnum
most-positive-exactly-double-float-fixnum)))
(if (<= lo y hi)
View
16 src/code/pathname.lisp
@@ -141,8 +141,20 @@
(when directory
(ecase (pop directory)
(:absolute
- (pieces "/"))
- (:relative))
+ (let ((next (pop directory)))
+ (cond ((eq :home next)
+ (pieces "~"))
+ ((and (consp next) (eq :home (car next)))
+ (pieces "~")
+ (pieces (second next)))
+ ((and (plusp (length next)) (char= #\~ (char next 0)))
+ ;; The only place we need to escape the tilde.
+ (pieces "\\")
+ (pieces next))
+ (next
+ (push next directory)))
+ (pieces "/")))
+ (:relative))
(dolist (dir directory)
(typecase dir
((member :up)
View
2  src/code/signal.lisp
@@ -102,7 +102,7 @@ WITHOUT-INTERRUPTS in:
(lambda () (with-local-interrupts ...)))
"
(with-unique-names (outer-allow-with-interrupts without-interrupts-body)
- `(flet ((,without-interrupts-body ()
+ `(dx-flet ((,without-interrupts-body ()
(declare (disable-package-locks allow-with-interrupts
with-local-interrupts))
(macrolet
View
2  src/code/sysmacs.lisp
@@ -51,7 +51,7 @@ system will be deadlocked. Since SBCL does not currently document its internal
locks, application code can never be certain that this invariant is
maintained."
(with-unique-names (without-gcing-body)
- `(flet ((,without-gcing-body ()
+ `(dx-flet ((,without-gcing-body ()
,@body))
(if *gc-inhibit*
(,without-gcing-body)
View
32 src/code/target-pathname.lisp
@@ -515,17 +515,27 @@ the operating system native pathname conventions."
((member :unspecific) '(:relative))
(list
(collect ((results))
- (results (pop directory))
- (dolist (piece directory)
- (cond ((member piece '(:wild :wild-inferiors :up :back))
- (results piece))
- ((or (simple-string-p piece) (pattern-p piece))
- (results (maybe-diddle-case piece diddle-case)))
- ((stringp piece)
- (results (maybe-diddle-case (coerce piece 'simple-string)
- diddle-case)))
- (t
- (error "~S is not allowed as a directory component." piece))))
+ (let ((root (pop directory)))
+ (if (member root '(:relative :absolute))
+ (results root)
+ (error "List of directory components must start with ~S or ~S."
+ :absolute :relative)))
+ (when directory
+ (let ((next (pop directory)))
+ (if (or (eq :home next)
+ (typep next '(cons (eql :home) (cons string null))))
+ (results next)
+ (push next directory)))
+ (dolist (piece directory)
+ (cond ((member piece '(:wild :wild-inferiors :up :back))
+ (results piece))
+ ((or (simple-string-p piece) (pattern-p piece))
+ (results (maybe-diddle-case piece diddle-case)))
+ ((stringp piece)
+ (results (maybe-diddle-case (coerce piece 'simple-string)
+ diddle-case)))
+ (t
+ (error "~S is not allowed as a directory component." piece)))))
(results)))
(simple-string
`(:absolute ,(maybe-diddle-case directory diddle-case)))
View
55 src/code/target-thread.lisp
@@ -59,17 +59,9 @@ offending thread using THREAD-ERROR-THREAD."))
to be joined. The offending thread can be accessed using
THREAD-ERROR-THREAD."))
-(defun join-thread-error-thread (condition)
+(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread
+ (condition)
(thread-error-thread condition))
-(define-compiler-macro join-thread-error-thread (condition)
- (deprecation-warning 'join-thread-error-thread 'thread-error-thread)
- `(thread-error-thread ,condition))
-
-#!+sb-doc
-(setf
- (fdocumentation 'join-thread-error-thread 'function)
- "The thread that we failed to join. Deprecated, use THREAD-ERROR-THREAD
-instead.")
(define-condition interrupt-thread-error (thread-error) ()
(:report (lambda (c s)
@@ -80,17 +72,9 @@ instead.")
"Signalled when interrupting a thread fails because the thread has already
exited. The offending thread can be accessed using THREAD-ERROR-THREAD."))
-(defun interrupt-thread-error-thread (condition)
+(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread
+ (condition)
(thread-error-thread condition))
-(define-compiler-macro interrupt-thread-error-thread (condition)
- (deprecation-warning 'join-thread-error-thread 'thread-error-thread)
- `(thread-error-thread ,condition))
-
-#!+sb-doc
-(setf
- (fdocumentation 'interrupt-thread-error-thread 'function)
- "The thread that was not interrupted. Deprecated, use THREAD-ERROR-THREAD
-instead.")
;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
;;; necessary because threads are only supported with the conservative
@@ -563,11 +547,32 @@ IF-NOT-OWNER is :FORCE)."
(defun condition-wait (queue mutex)
#!+sb-doc
- "Atomically release MUTEX and enqueue ourselves on QUEUE. Another
-thread may subsequently notify us using CONDITION-NOTIFY, at which
-time we reacquire MUTEX and return to the caller.
-
-Note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
+ "Atomically release MUTEX and enqueue ourselves on QUEUE. Another thread may
+subsequently notify us using CONDITION-NOTIFY, at which time we reacquire
+MUTEX and return to the caller.
+
+Important: CONDITION-WAIT may return without CONDITION-NOTIFY having occurred.
+The correct way to write code that uses CONDITION-WAIT is to loop around the
+call, checking the the associated data:
+
+ (defvar *data* nil)
+ (defvar *queue* (make-waitqueue))
+ (defvar *lock* (make-mutex))
+
+ ;; Consumer
+ (defun pop-data ()
+ (with-mutex (*lock*)
+ (loop until *data*
+ do (condition-wait *queue* *lock*))
+ (pop *data*)))
+
+ ;; Producer
+ (defun push-data (data)
+ (with-mutex (*lock*)
+ (push data *data*)
+ (condition-notify *queue*)))
+
+Also note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
returning normally, it may do so without holding the mutex."
#!-sb-thread (declare (ignore queue))
(let (#!+(and win32 sb-thread) (sb!impl::*disable-safepoints* t))
View
104 src/code/unix-pathname.lisp
@@ -55,35 +55,53 @@
:complaint "can't embed #\\Nul or #\\/ in Unix namestring"
:namestring namestring
:offset position))))
- ;; Now we have everything we want. So return it.
- (values nil ; no host for Unix namestrings
- nil ; no device for Unix namestrings
- (collect ((dirs))
- (dolist (piece pieces)
- (let ((piece-start (car piece))
- (piece-end (cdr piece)))
- (unless (= piece-start piece-end)
- (cond ((string= namestring ".."
- :start1 piece-start
- :end1 piece-end)
- (dirs :up))
- ((string= namestring "**"
- :start1 piece-start
- :end1 piece-end)
- (dirs :wild-inferiors))
- (t
- (dirs (maybe-make-pattern namestring
- piece-start
- piece-end)))))))
- (cond (absolute
- (cons :absolute (dirs)))
- ((dirs)
- (cons :relative (dirs)))
- (t
- nil)))
- name
- type
- version))))
+
+ (let (home)
+ ;; Deal with ~ and ~user
+ (when (car pieces)
+ (destructuring-bind (start . end) (car pieces)
+ (when (and (not absolute)
+ (not (eql start end))
+ (string= namestring "~"
+ :start1 start
+ :end1 (1+ start)))
+ (setf absolute t)
+ (if (> end (1+ start))
+ (setf home (list :home (subseq namestring (1+ start) end)))
+ (setf home :home))
+ (pop pieces))))
+
+ ;; Now we have everything we want. So return it.
+ (values nil ; no host for Unix namestrings
+ nil ; no device for Unix namestrings
+ (collect ((dirs))
+ (dolist (piece pieces)
+ (let ((piece-start (car piece))
+ (piece-end (cdr piece)))
+ (unless (= piece-start piece-end)
+ (cond ((string= namestring ".."
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :up))
+ ((string= namestring "**"
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :wild-inferiors))
+ (t
+ (dirs (maybe-make-pattern namestring
+ piece-start
+ piece-end)))))))
+ (cond (absolute
+ (if home
+ (list* :absolute home (dirs))
+ (cons :absolute (dirs))))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version)))))
(defun parse-native-unix-namestring (namestring start end as-directory)
(declare (type simple-string namestring)
@@ -183,15 +201,29 @@
(coerce
(with-output-to-string (s)
(when directory
- (ecase (car directory)
- (:absolute (write-char #\/ s))
+ (ecase (pop directory)
+ (:absolute
+ (let ((next (pop directory)))
+ (cond ((eq :home next)
+ (write-string (user-homedir-namestring) s))
+ ((and (consp next) (eq :home (car next)))
+ (let ((where (user-homedir-namestring (second next))))
+ (if where
+ (write-string where s)
+ (error "User homedir unknown for: ~S" (second next)))))
+ (next
+ (push next directory)))
+ (write-char #\/ s)))
(:relative)))
- (loop for (piece . subdirs) on (cdr directory)
+ (loop for (piece . subdirs) on directory
do (typecase piece
- ((member :up) (write-string ".." s))
- (string (write-string piece s))
- (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
- piece)))
+ ((member :up)
+ (write-string ".." s))
+ (string
+ (write-string piece s))
+ (t
+ (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+ piece)))
if (or subdirs (stringp name))
do (write-char #\/ s)
else
View
17 src/code/unix.lisp
@@ -446,11 +446,18 @@ corresponds to NAME, or NIL if there is none."
;;; Return the namestring of the home directory, being careful to
;;; include a trailing #\/
#!-win32
-(defun uid-homedir (uid)
- (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
- (function (* char) int))
- uid))
- (error "failed to resolve home directory for Unix uid=~S" uid)))
+(progn
+ (defun uid-homedir (uid)
+ (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
+ (function (* char) int))
+ uid))
+ (error "failed to resolve home directory for Unix uid=~S" uid)))
+
+ (defun user-homedir (uid)
+ (or (newcharstar-string (alien-funcall (extern-alien "user_homedir"
+ (function (* char) c-string))
+ uid))
+ (error "failed to resolve home directory for Unix uid=~S" uid))))
;;; Invoke readlink(2) on the file name specified by PATH. Return
;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
View
98 src/code/win32-pathname.lisp
@@ -39,6 +39,11 @@
(defun split-at-slashes-and-backslashes (namestr start end)
(declare (type simple-string namestr)
(type index start end))
+ ;; FIXME: There is a fundamental brokenness in using the same
+ ;; character as escape character and directory separator in
+ ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should
+ ;; probably be (:RELATIVE "*") everywhere, but on Windows it's
+ ;; (:ABSOLUTE :WILD)! See lp#673625.
(let ((absolute (and (/= start end)
(or (char= (schar namestr start) #\/)
(char= (schar namestr start) #\\)))))
@@ -83,35 +88,53 @@
:complaint "can't embed #\\Nul or #\\/ in Unix namestring"
:namestring namestring
:offset position))))
- ;; Now we have everything we want. So return it.
- (values nil ; no host for Win32 namestrings
- device
- (collect ((dirs))
- (dolist (piece pieces)
- (let ((piece-start (car piece))
- (piece-end (cdr piece)))
- (unless (= piece-start piece-end)
- (cond ((string= namestring ".."
- :start1 piece-start
- :end1 piece-end)
- (dirs :up))
- ((string= namestring "**"
- :start1 piece-start
- :end1 piece-end)
- (dirs :wild-inferiors))
- (t
- (dirs (maybe-make-pattern namestring
- piece-start
- piece-end)))))))
- (cond (absolute
- (cons :absolute (dirs)))
- ((dirs)
- (cons :relative (dirs)))
- (t
- nil)))
- name
- type
- version)))))
+
+ (let (home)
+ ;; Deal with ~ and ~user.
+ (when (car pieces)
+ (destructuring-bind (start . end) (car pieces)
+ (when (and (not absolute)
+ (not (eql start end))
+ (string= namestring "~"
+ :start1 start
+ :end1 (1+ start)))
+ (setf absolute t)
+ (if (> end (1+ start))
+ (setf home (list :home (subseq namestring (1+ start) end)))
+ (setf home :home))
+ (pop pieces))))
+
+ ;; Now we have everything we want. So return it.
+ (values nil ; no host for Win32 namestrings
+ device
+ (collect ((dirs))
+ (dolist (piece pieces)
+ (let ((piece-start (car piece))
+ (piece-end (cdr piece)))
+ (unless (= piece-start piece-end)
+ (cond ((string= namestring ".."
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :up))
+ ((string= namestring "**"
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :wild-inferiors))
+ (t
+ (dirs (maybe-make-pattern namestring
+ piece-start
+ piece-end)))))))
+ (cond (absolute
+ (if home
+ (list* :absolute home (dirs))
+ (cons :absolute (dirs))))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version))))))
(defun parse-native-win32-namestring (namestring start end as-directory)
(declare (type simple-string namestring)
@@ -227,10 +250,21 @@
(when device
(write-string (unparse-win32-device pathname t) s))
(when directory
- (ecase (car directory)
- (:absolute (write-char #\\ s))
+ (ecase (pop directory)
+ (:absolute
+ (let ((next (pop directory)))
+ (cond ((eq :home next)
+ (write-string (user-homedir-namestring) s))
+ ((and (consp next) (eq :home (car next)))
+ (let ((where (user-homedir-namestring (second next))))
+ (if where
+ (write-string where s)
+ (error "User homedir unknown for: ~S" (second next)))))
+ (next
+ (push next directory)))
+ (write-char #\\ s)))
(:relative)))
- (loop for (piece . subdirs) on (cdr directory)
+ (loop for (piece . subdirs) on directory
do (typecase piece
((member :up) (write-string ".." s))
(string (write-string piece s))
View
8 src/code/win32.lisp
@@ -432,14 +432,16 @@
err-code
(get-last-error-message err-code))))
-(defun get-folder-pathname (csidl)
+(defun get-folder-namestring (csidl)
"http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
(with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
(syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
- (parse-native-namestring
- (concatenate 'string (cast-and-free apath) "\\"))
+ (concatenate 'string (cast-and-free apath) "\\")
0 csidl 0 0 apath)))
+(defun get-folder-pathname (csidl)
+ (parse-native-namestring (get-folder-namestring csidl)))
+
(defun sb!unix:posix-getcwd ()
(with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
(with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
View
18 src/compiler/alpha/call.lisp
@@ -123,6 +123,24 @@
(when nfp
(inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val)))))
+;;; Accessing a slot from an earlier stack frame is definite hackery.
+(define-vop (ancestor-frame-ref)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (variable-home-tn :load-if nil))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (loadw value frame-pointer (tn-offset variable-home-tn))))
+(define-vop (ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:results (variable-home-tn :load-if nil))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (storew value frame-pointer (tn-offset variable-home-tn))))
+
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(:ignore copy-more-arg-follows)
View
6 src/compiler/alpha/cell.lisp
@@ -239,6 +239,12 @@
(define-vop (closure-init slot-set)
(:variant closure-info-offset fun-pointer-lowtag))
+
+(define-vop (closure-init-from-fp)
+ (:args (object :scs (descriptor-reg)))
+ (:info offset)
+ (:generator 4
+ (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
;;;; value cell hackery
View
24 src/compiler/constraint.lisp
@@ -761,11 +761,11 @@
for var in (lambda-vars fun)
and val in (combination-args call)
when (and val (lambda-var-constraints var))
- do (let* ((type (lvar-type val))
- (con (find-or-create-constraint 'typep var type
- nil)))
- (conset-adjoin con gen))
- (maybe-add-eql-var-var-constraint var val gen)))))
+ do (let ((type (lvar-type val)))
+ (unless (eq type *universal-type*)
+ (let ((con (find-or-create-constraint 'typep var type nil)))
+ (conset-adjoin con gen))))
+ (maybe-add-eql-var-var-constraint var val gen)))))
(ref
(when (ok-ref-lambda-var node)
(maybe-add-eql-var-lvar-constraint node gen)
@@ -778,17 +778,19 @@
(let ((var (ok-lvar-lambda-var lvar gen)))
(when var
(let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
- (do-eql-vars (var (var gen))
- (let ((con (find-or-create-constraint 'typep var atype nil)))
- (conset-adjoin con gen))))))))
+ (unless (eq atype *universal-type*)
+ (do-eql-vars (var (var gen))
+ (let ((con (find-or-create-constraint 'typep var atype nil)))
+ (conset-adjoin con gen)))))))))
(cset
(binding* ((var (set-var node))
(nil (lambda-var-p var) :exit-if-null)
(cons (lambda-var-constraints var) :exit-if-null))
(conset-difference gen cons)
- (let* ((type (single-value-type (node-derived-type node)))
- (con (find-or-create-constraint 'typep var type nil)))
- (conset-adjoin con gen))
+ (let ((type (single-value-type (node-derived-type node))))
+ (unless (eq type *universal-type*)
+ (let ((con (find-or-create-constraint 'typep var type nil)))
+ (conset-adjoin con gen))))
(maybe-add-eql-var-var-constraint var (set-value node) gen)))))
gen)
View
5 src/compiler/dfo.lisp
@@ -190,7 +190,10 @@
(home-kind (functional-kind home))
(home-externally-visible-p
(or (eq home-kind :toplevel)
- (functional-has-external-references-p home))))
+ (functional-has-external-references-p home)
+ (let ((entry (functional-entry-fun home)))
+ (and entry
+ (functional-has-external-references-p entry))))))
(unless (or (and home-externally-visible-p
(eq (functional-kind fun) :external))
(eq home-kind :deleted))
View
33 src/compiler/gtn.lisp
@@ -43,13 +43,34 @@
(let* ((type (if (lambda-var-indirect var)
*backend-t-primitive-type*
(primitive-type (leaf-type var))))
- (temp (make-normal-tn type))
+ (res (make-normal-tn type))
(node (lambda-bind fun))
- (res (if (or (and let-p (policy node (< debug 3)))
- (policy node (zerop debug))
- (policy node (= speed 3)))
- temp
- (physenv-debug-live-tn temp (lambda-physenv fun)))))
+ (debug-variable-p (not (or (and let-p (policy node (< debug 3)))
+ (policy node (zerop debug))
+ (policy node (= speed 3))))))
+ (cond
+ ((and (lambda-var-indirect var)
+ (not (lambda-var-explicit-value-cell var)))
+ ;; Force closed-over indirect LAMBDA-VARs without explicit
+ ;; VALUE-CELLs to the stack, and make sure that they are
+ ;; live over the dynamic contour of the physenv.
+ (setf (tn-sc res) (svref *backend-sc-numbers*
+ sb!vm:control-stack-sc-number))
+ ;; KLUDGE: In the case of a tail-local-call, the entire
+ ;; stack frame is overwritten by the physenv of the called
+ ;; function. Unfortunately, the tail-call appears to end
+ ;; the dynamic contour of the physenv, meaning that the
+ ;; stack slot occupied by the LAMBDA-VAR may be reassigned.
+ ;; Ideally, we might make the TN physenv-live across the
+ ;; physenvs of the tail-set of the lambda, but as a stopgap
+ ;; we can make it component-live instead.
+ (component-live-tn res)
+ #+(or)
+ (physenv-live-tn res (lambda-physenv fun)))
+
+ (debug-variable-p
+ (physenv-debug-live-tn res (lambda-physenv fun))))
+
(setf (tn-leaf res) var)
(setf (leaf-info var) res))))
(values))
View
18 src/compiler/hppa/call.lisp
@@ -127,6 +127,24 @@
(inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
nfp val)))))
+;;; Accessing a slot from an earlier stack frame is definite hackery.
+(define-vop (ancestor-frame-ref)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (variable-home-tn :load-if nil))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (loadw value frame-pointer (tn-offset variable-home-tn))))
+(define-vop (ancestor-frame-set)
+ (:args (frame-pointer :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:results (variable-home-tn :load-if nil))
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (sc-is variable-home-tn control-stack))
+ (storew value frame-pointer (tn-offset variable-home-tn))))
+
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(:ignore copy-more-arg-follows)
View
6 src/compiler/hppa/cell.lisp
@@ -222,6 +222,12 @@
(define-vop (closure-init slot-set)
(:variant closure-info-offset fun-pointer-lowtag))
+
+(define-vop (closure-init-from-fp)
+ (:args (object :scs (descriptor-reg)))
+ (:info offset)
+ (:generator 4
+ (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
;;;; Value Cell hackery.
View
1  src/compiler/ir1-translators.lisp
@@ -1083,6 +1083,7 @@ due to normal completion or a non-local exit such as THROW)."
;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
;; and something can be done to make %ESCAPE-FUN have
;; dynamic extent too.
+ (declare (dynamic-extent #',cleanup-fun))
(block ,drop-thru-tag
(multiple-value-bind (,next ,start ,count)
(block ,exit-tag
View
6 src/compiler/ir1tran-lambda.lisp
@@ -1007,8 +1007,10 @@
:source-name source-name
:debug-name debug-name))
((instance-lambda)
- (deprecation-warning 'instance-lambda 'lambda)
- (ir1-convert-lambda `(lambda ,@(cdr thing))
+ (deprecation-warning :final "0.9.3.32" 'instance-lambda 'lambda)
+ (ir1-convert-lambda `(lambda (&rest args)
+ (declare (ignore args))
+ (deprecation-error "0.9.3.32" 'instance-lambda 'lambda))
:source-name source-name
:debug-name debug-name))
((named-lambda)
View
127 src/compiler/ir1tran.lisp
@@ -43,6 +43,18 @@
(when (source-form-has-path-p form)
(gethash form *source-paths*)))
+(defun simplify-source-path-form (form)
+ (if (consp form)
+ (let ((op (car form)))
+ ;; In the compiler functions can be directly represented
+ ;; by leaves. Having leaves in the source path is pretty
+ ;; hard on the poor user, however, so replace with the
+ ;; source-name when possible.
+ (if (and (leaf-p op) (leaf-has-source-name-p op))
+ (cons (leaf-source-name op) (cdr form))
+ form))
+ form))
+
(defun note-source-path (form &rest arguments)
(when (source-form-has-path-p form)
(setf (gethash form *source-paths*)
@@ -551,7 +563,8 @@
(defun ir1-convert (start next result form)
(ir1-error-bailout (start next result form)
(let* ((*current-path* (or (get-source-path form)
- (cons form *current-path*)))
+ (cons (simplify-source-path-form form)
+ *current-path*)))
(start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
@@ -776,69 +789,55 @@
;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
;;; errors which occur during the macroexpansion.
(defun careful-expand-macro (fun form &optional cmacro)
- (let (;; a hint I (WHN) wish I'd known earlier
- (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)"))
- (flet (;; Return a string to use as a prefix in error reporting,
- ;; telling something about which form caused the problem.
- (wherestring ()
- (let ((*print-pretty* nil)
- ;; We rely on the printer to abbreviate FORM.
- (*print-length* 3)
- (*print-level* 3))
- (format
- nil
- #-sb-xc-host "(in ~A of ~S)"
- ;; longer message to avoid ambiguity "Was it the xc host
- ;; or the cross-compiler which encountered the problem?"
- #+sb-xc-host "(in cross-compiler ~A of ~S)"
- (if cmacro "compiler-macroexpansion" "macroexpansion")
- form))))
- (handler-bind ((style-warning (lambda (c)
- (compiler-style-warn
- "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
- ;; Debian Linux, anyway) raises a CL:WARNING
- ;; condition (not a CL:STYLE-WARNING) for undefined
- ;; symbols when converting interpreted functions,
- ;; causing COMPILE-FILE to think the file has a real
- ;; problem, causing COMPILE-FILE to return FAILURE-P
- ;; set (not just WARNINGS-P set). Since undefined
- ;; symbol warnings are often harmless forward
- ;; references, and since it'd be inordinately painful
- ;; to try to eliminate all such forward references,
- ;; these warnings are basically unavoidable. Thus, we
- ;; need to coerce the system to work through them,
- ;; and this code does so, by crudely suppressing all
- ;; warnings in cross-compilation macroexpansion. --
- ;; WHN 19990412
- #+(and cmu sb-xc-host)
- (warning (lambda (c)
- (compiler-notify
- "~@<~A~:@_~
- ~A~:@_~
- ~@<(KLUDGE: That was a non-STYLE WARNING. ~
- Ordinarily that would cause compilation to ~
- fail. However, since we're running under ~
- CMU CL, and since CMU CL emits non-STYLE ~
- warnings for safe, hard-to-fix things (e.g. ~
- references to not-yet-defined functions) ~
- we're going to have to ignore it and ~
- proceed anyway. Hopefully we're not ~
- ignoring anything horrible here..)~:@>~:>"
- (wherestring)
- c)
- (muffle-warning-or-die)))
- #-(and cmu sb-xc-host)
- (warning (lambda (c)
- (warn "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- (error (lambda (c)
- (compiler-error "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c))))
- (funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))))
+ (flet (;; Return a string to use as a prefix in error reporting,
+ ;; telling something about which form caused the problem.
+ (wherestring ()
+ (let (;; We rely on the printer to abbreviate FORM.
+ (*print-length* 3)
+ (*print-level* 3))
+ (format
+ nil
+ #-sb-xc-host "~@<~;during ~A of ~S. Use ~S to intercept:~%~:@>"
+ ;; longer message to avoid ambiguity "Was it the xc host
+ ;; or the cross-compiler which encountered the problem?"
+ #+sb-xc-host "~@<~;during cross-compiler ~A of ~S. Use ~S to intercept:~%~:@>"
+ (if cmacro "compiler-macroexpansion" "macroexpansion")
+ form
+ '*break-on-signals*))))
+ (handler-bind (;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for Debian
+ ;; Linux, anyway) raises a CL:WARNING condition (not a
+ ;; CL:STYLE-WARNING) for undefined symbols when converting
+ ;; interpreted functions, causing COMPILE-FILE to think the
+ ;; file has a real problem, causing COMPILE-FILE to return
+ ;; FAILURE-P set (not just WARNINGS-P set). Since undefined
+ ;; symbol warnings are often harmless forward references,
+ ;; and since it'd be inordinately painful to try to
+ ;; eliminate all such forward references, these warnings
+ ;; are basically unavoidable. Thus, we need to coerce the
+ ;; system to work through them, and this code does so, by
+ ;; crudely suppressing all warnings in cross-compilation
+ ;; macroexpansion. -- WHN 19990412
+ #+(and cmu sb-xc-host)
+ (warning (lambda (c)
+ (compiler-notify
+ "~@<~A~:@_~
+ ~A~:@_~